#!/usr/bin/perl -w
#=============================================================================
#
# AUTOPKG - Slackware package creation tool
#
# Author: Joshua Swink <jswink@pacbell.net>
#
# autopkg is released under the GNU General Public License.
# See the file COPYING, or http://www.gnu.org/copyleft/gpl.html.
#
#=============================================================================
require 5.004;
use strict;
use Archive::Tar;
use Archive::Tar::Constant;
use Cwd qw(cwd abs_path);
use POSIX qw(strftime tmpnam);
use IO::File;
use File::Basename;
use File::Path;
use File::Copy;
use File::Find;
use Getopt::Long;
use Symbol;
use Config;
use vars qw(
$programname
$version
%suffixes
%options
%cleanups
$verbosity
$srcsuffix
$rulesfile
$givendesc
$descfile
$addsrcindex
%doinstvals
$iw_log
$opt_jobs
$def_cc
$ARCH
$BUILD
$ID
$SOURCES
$INPUTDIR
$RULESDIR
$DESCDIR
$STARTDIR
$PKGDIR
$SOURCE
$TMPDIR
$SRCDIR
$NAME
$VERSION
%VERSIONS
$PKGNAME
$PKGFORMAT
%OWNERSHIP
%DEFPERMS
%OPTIONS
%DIROWNER
%SUBS
$vermajor
$verminor
$verpatchlevel
);
$programname = basename $0;
$version= '0.8.8';
choke("$programname shouldn't be run as root.") unless $>;
usage() unless @ARGV;
$opt_jobs = '-j2';
$def_cc = '';
# BEGIN PKGPARSE VARIABLES
my $pp_pkgdir = '/var/log/packages';
# Apparently the pkgtools demand 11 lines of description.
my $slack_desc_lines = 11;
my %aliasfields = (
'PACKAGE NAME' => 'name',
'COMPRESSED PACKAGE SIZE' => 'compressed',
'UNCOMPRESSED PACKAGE SIZE' => 'uncompressed',
'PACKAGE LOCATION' => 'location',
'PACKAGE MD5SUM' => 'md5sum');
my @stdpkgfields = (
'PACKAGE NAME',
'COMPRESSED PACKAGE SIZE',
'UNCOMPRESSED PACKAGE SIZE',
'PACKAGE LOCATION',
'PACKAGE MD5SUM');
my $aliaskeymatch = join('|', keys %aliasfields);
my $aliasvalmatch = join('|', values %aliasfields, 'files', 'desc');
my %reversealias;
my $howtoedit =
"# HOW TO EDIT THIS FILE:
# The \"handy ruler\" below makes it easier to edit a package description. Line
# up the first '|' above the ':' following the base package name, and the '|'
# on the right side marks the last column you can put a character in. You must
# make exactly 11 lines for the formatting to be correct. It's also
# customary to leave one space after the ':'.
";
my $handyruler =
'|-----handy-ruler------------------------------------------------------|';
foreach (keys %aliasfields) {
$reversealias{$aliasfields{$_}} = $_;
}
# END PKGPARSE VARIABLES
Getopt::Long::Configure('bundling');
#=============================================================================
# Make sure the temporary directory gets cleaned up:
#=============================================================================
# Also make warnings fatal!
for (qw(PIPE INT TERM HUP __DIE__ __WARN__)) {
$SIG{$_} = \&sigcatcher;
}
#=============================================================================
# Set up some defaults
#=============================================================================
# suffixes -- archive types we know how to deal with. the values are
# the tar option to decompress.
%suffixes = (
'.tar.gz' => 'z',
'.tgz' => 'z',
'.tar.bz2' => 'j',
'.tar.Z' => 'Z',
'.zip' => ''
);
%options = (
'rules', => ''
);
%DEFPERMS = (
'exec' => 0755,
'data' => 0644,
'dir' => 0755
);
%OWNERSHIP = ();
%OPTIONS = (
'STRIP' => 1,
'SETOWNERS' => 1,
'DEFOWN' => [0, 0, 'root', 'root'],
'SETPERMS' => 1,
'SCRIPTLINKS' => 1,
'VERBOSITY' => 0,
'DESTDIR' => cwd(),
'USE_DESCDIR' => 1,
'USE_INSTALLED_DESC' => 0,
'DESC_INSTRUCTIONS' => 1,
'HANDLE_PERLLOCAL_POD' => 0
);
# Determine architecture:
chomp($ARCH = `uname -m`);
$ARCH = 'i486' if $ARCH =~ /^i\d8\d$/;
$BUILD = '1';
$ID = 'anon';
$PKGFORMAT = 'NAME-VERSION-ARCH-BUILDID.tgz';
#=============================================================================
# Work out how what we're supposed to be doing and how
#=============================================================================
$verbosity = 0;
readrc();
procopts();
choke("Cannot create packages: Perl package IO::Zlib not installed")
unless Archive::Tar->can_handle_compressed_files;
$options{destdir} and $OPTIONS{DESTDIR} = $options{destdir};
$verbosity = $OPTIONS{VERBOSITY} || 0;
if ($options{combine}) {
combinepkgs($options{combine}, @ARGV);
exit;
}
$STARTDIR = cwd() or choke("Can't determine current directory.");
($vermajor, $verminor, $verpatchlevel) = (0, 0, 0);
#=============================================================================
# See if we're making a package from an installwatch log. If so, there
# will be no source or rules file (the next two sections are skipped).
#=============================================================================
if ($options{iw}) {
$PKGNAME = $options{iw};
$iw_log = shift
or choke("This option requires both the package name and logfile.");
} else {
#=============================================================================
# Examine the source
#=============================================================================
$SOURCE = shift or badusage('source directory or archive required');
if (! -e $SOURCE) {
if ($SOURCES) {
my @srces = glob("$SOURCES/$SOURCE*");
if (@srces == 0) {
choke("Can't find $SOURCE in . or $SOURCES");
} elsif (@srces == 1) {
$SOURCE = $srces[0];
} else {
choke("Multiple candidates for $SOURCE in $SOURCES");
}
} else {
choke("No such file: $SOURCE");
}
}
$SOURCE = canonicalize($SOURCE);
$INPUTDIR = dirname $SOURCE;
($NAME, $VERSION, $srcsuffix) = parsesource($SOURCE);
dbugout(1, "name = \"$NAME\", version = \"$VERSION\"");
if ($VERSION =~ /^(\d+)\.(\d+)\.(\d+)/) {
($vermajor, $verminor, $verpatchlevel) = ($1, $2, $3);
} elsif ($VERSION =~ /^(\d+)\.(\d+)/) {
($vermajor, $verminor, $verpatchlevel) = ($1, $2, 0);
} elsif ($VERSION =~ /^(\d+)/) {
($vermajor, $verminor, $verpatchlevel) = ($1, 0, 0);
}
#=============================================================================
# Deal with the rules file
#=============================================================================
if ($options{rules}) {
$rulesfile = $options{rules};
if ($options{name}) {
$NAME = $options{name};
} elsif ($rulesfile =~ m!([^/]+)\.apkg$!) {
$NAME = $1;
} else {
$NAME = basename($rulesfile);
}
} else {
$NAME = $options{name} if $options{name};
choke("Package name not determined, aborting.") unless $NAME;
dbugout(2, "getrulesfile($NAME)");
$rulesfile = getrulesfile($NAME);
}
dbugout(0, "Creating package with rules file $rulesfile.");
$RULESDIR = dirname($rulesfile);
$DESCDIR = "$RULESDIR/descriptions" unless $DESCDIR; # Might have been set in rcfile.
eval slurpfile($rulesfile);
$@ and choke("Error in rules file $rulesfile:\n $@");
}
#=============================================================================
# Get to work
#=============================================================================
#-- get a temporary directory --#
$TMPDIR = tmpnam() or choke("Couldn't get a name for the temporary directory");
mkdir $TMPDIR, 0700 or choke("Can't mkdir $TMPDIR: $!");
$cleanups{tmpdir} = $TMPDIR;
dbugout(2, "\$TMPDIR is $TMPDIR ");
#-- execute rules file's pre_extract() --#
callrule('pre_extract');
#-- examine %VERSIONS --#
versioncheck($VERSION, \%VERSIONS);
#-- move source to temporary directory --#
unless ($options{iw}) {
dbugout(2, "\$SRCDIR = src_to_tempdir($TMPDIR , $SOURCE, $srcsuffix)");
$SRCDIR = src_to_tempdir($SOURCE, $TMPDIR, $srcsuffix);
}
#-- create $PKGDIR --#
$PKGDIR = tmpnam() or choke("Couldn't get a name for the package directory");
mkdir $PKGDIR, 0700 or choke("Can't mkdir $PKGDIR: $!");
$cleanups{pkgdir} = $PKGDIR;
dbugout(2, "\$PKGDIR is $PKGDIR");
#-- chdir to source directory --#
unless ($options{iw}) {
dbugout(2, "chdir $SRCDIR or choke");
chdir $SRCDIR or choke("can't chdir $SRCDIR: $!");
}
#-- execute rules file's build() --#
callrule('build');
process_iwlog($iw_log) if $options{iw};
#-- set permissions --#
if ($OPTIONS{SETPERMS}) {
dbugout(1, "setting default permissions at $PKGDIR");
setperms($PKGDIR, %DEFPERMS);
} else {
dbugout(2, "not setting default permissions");
}
#-- check for a perllocal.pod file --#
handle_perllocal_pod() if $OPTIONS{HANDLE_PERLLOCAL_POD};
#-- execute STRIP rule --#
if ($OPTIONS{STRIP}) {
dbugout(0, "stripping.");
symbolstrip($PKGDIR);
} else {
dbugout(2, "(not stripping)");
}
#-- call ziptree() on specified directories --#
if ($OPTIONS{ZIPDIRS}) {
my @zdirs;
foreach (@{$OPTIONS{ZIPDIRS}}) {
push @zdirs, $_ if -d "$PKGDIR/$_";
}
if (@zdirs) {
ziptree(@zdirs);
} else {
dbugout(0, "no zipdir directories in package");
}
} else {
dbugout(2, "(not compressing any directory trees)");
}
#-- execute rules file's pre_package() --#
callrule('pre_package');
#-- evaluate any user/group names in ownership settings --#
procnames(\%OWNERSHIP, \%OPTIONS);
procnames(\%DIROWNER, \%OPTIONS);
#-- create the description file, if appropriate --#
unless ($options{iw}) {
create_descfile();
}
#-- determine package filename --#
unless (defined $PKGNAME) {
$PKGNAME = getpkgname($PKGFORMAT,
{
ARCH => $ARCH,
BUILD => $BUILD,
ID => $ID,
BUILDID => "$BUILD$ID",
NAME => $NAME,
VERSION => $VERSION
}
);
}
#-- create the package --#
maketgz($PKGDIR, $PKGNAME, $OPTIONS{SCRIPTLINKS});
#-- move .tgz to destination directory --#
dbugout(1, "moving $PKGNAME to $OPTIONS{DESTDIR}");
move("$PKGDIR/$PKGNAME", $OPTIONS{DESTDIR}) or
choke("can't move $PKGNAME to $OPTIONS{DESTDIR}: $!");
#-- erase temporary directory --#
cleantmp();
dbugout(0, "finished.");
#-- execute rules file's final() --#
callrule('final');
#-----------------------------------------------------------------------------#
sub readrc {
my $rcfile = "$ENV{HOME}/.autopkgrc";
return unless -r $rcfile and -f _;
eval slurpfile($rcfile);
$@ and choke("Error in $rcfile:\n $@");
if ($OPTIONS{VERBOSITY} !~ /^\d+$/) {
choke("Invalid VERBOSITY in $rcfile:\nmust be between 0 and 3");
}
unless (-d $OPTIONS{DESTDIR}) {
choke("Bad DESTDIR $OPTIONS{DESTDIR}");
}
}
sub procopts {
if (!GetOptions(
'build|b=i', \$options{build},
'combine|c=s', \$options{combine},
'destdir|d=s', \$options{destdir},
'help|h|?', \$options{help},
'id|i=s', \$options{id},
'name|n=s', \$options{name},
'nopause|N', \$options{nopause},
'rules|r=s', \$options{rules},
'verbose|v+', \$options{verbose},
'version|V', \$options{version},
'iw=s', \$options{iw}
)) {
exit 1;
}
$options{help} and usage();
$options{version} and version();
$OPTIONS{VERBOSITY} = $options{verbose} if defined $options{verbose};
$options{build} and $BUILD = $options{build};
$options{id} and $ID = $options{id};
}
sub usage {
print
"Usage: $programname [options] <source-archive>|<source-dir>
Create a slackware package from source according to preset rules.
-b, --build <num> Set build number for package filename
-c, --combine <name> <package.tgz> <package.tgz> [<package.tgz> ...]
Combine several packages into one
-d, --destdir <dir> Specify directory to write package
-h, --help Print this usage summary
-i, --id <id> Builder id, e.g. your initials
-n, --name <name> Use package <name> rather than parsing archive
-N, --nopause Don't pause when package building fails
-r, --rules <file> Use the rules file <file>.
-v, --verbose Enable verbose output. Multiple '-v's increase verbosity.
-V, --version Print version information and exit
--iw <name> <logfile>
Create package according to installwatch log file
";
exit;
}
sub version {
print "$programname $version\n";
exit;
}
sub badusage {
foreach (@_) {
print STDERR "$programname: $_\n";
}
print STDERR "Try $programname --help for usage instructions.\n";
exit 1;
}
sub dbugout {
my $level = shift;
if ($verbosity >= $level) {
foreach (@_) {
print " [$programname] $_\n";
}
}
}
sub callrule {
my $rulefunc = shift;
my $sym = $main::{$rulefunc};
$sym->() if defined $sym and defined &$sym;
}
sub canonicalize {
my $file = shift;
my ($name, $path) = fileparse($file);
return abs_path($path) . "/$name";
}
## parsesource - return (NAME, version, suffix[if file])
sub parsesource {
my $source = shift;
my ($name, $path, $suffix);
($name, $path, $suffix) = fileparse($source, keys %suffixes);
$name =~ s/[-.]src$//;
if (-f $source) {
if (!$suffix) {
choke("can't use $source: not a supported archive (" .
join(', ', grep {s/^\.//} my @junk = keys %suffixes) . ')');
} elsif ($name =~ /^(.+?)-(\d[^_-]*(?:-\d+)?)$/) {
($1, $2, $suffix);
} else {
($name, '', $suffix);
}
} elsif (-d $source) {
if ($source eq '/') {
choke("Extracting source into /? That can't be good.");
} elsif ($source=~ m!(?:^|/)([^/]+?)-(\d[^_/-]*(?:-\d+)?)/?\.?$!) {
($1, $2, '');
} else {
($name, '', '');
}
} else {
choke("can't use $source: not a file or directory");
}
}
sub getrulesfile {
my $package = shift;
if (-f "$package.apkg") {
"$package.apkg";
} elsif (-f "$ENV{HOME}/.autopkg/$package.apkg") {
"$ENV{HOME}/.autopkg/$package.apkg";
} else {
choke("Can't find $package.apkg in current directory or ~/.autopkg");
}
}
sub src_to_tempdir {
my ($source, $tempdir, $suffix) = @_;
my ($entry, $gotfiles, $taropt, @mvfiles, $srcdir);
my $dh = gensym();
if (-d $source) {
#-- source is in a directory: copy to temp --#
$source =~ s!/*$!!;
dbugout(1, "Copying contents of $source to temporary directory");
opendir $dh, $source or choke("Can't opendir $source: $!");
while (defined ($entry = readdir $dh)) {
next if $entry =~ /^\.\.?$/;
system('cp', '-a', "$source/$entry", $tempdir) and
choke("Couldn't copy files from $source to $tempdir");
}
} else {
#-- source is in an archive: extract to temp --#
if (!exists $suffixes{$suffix}) {
choke("internal error - unknown archive suffix \"$suffix\"");
}
dbugout(1, "extracting $source to $tempdir");
if ($suffix eq '.zip') {
system('unzip', '-q', '-d', $tempdir, $source)
and choke("Error extracting $source to $tempdir");
} else {
system('tar', '-C', $tempdir,
"-x$suffixes{$suffix}" . 'v' x ($verbosity - 1) . 'f', $source) and
choke("error extracting $source");
}
}
# If the extraction has created a single subdirectory, use that
# as $srcdir. Otherwise use plain temp dir.
opendir $dh, $tempdir or choke("can't opendir $tempdir: $!");
while (defined($entry = readdir $dh)) {
next if $entry =~ /^\.\.?$/;
if (-f "$tempdir/$entry") {
$srcdir = $tempdir;
last;
} elsif (-d "$tempdir/$entry") {
if ($srcdir) {
$srcdir = $tempdir;
last;
} else {
$srcdir = "$tempdir/$entry";
}
}
}
closedir $dh;
$srcdir or choke("No files found. Nothing to do.");
}
sub versioncheck {
my ($version, $versions) = @_;
my ($control, $action, $message);
if (exists $$versions{$version}) {
$control = $$versions{$version};
} elsif (exists $OPTIONS{UNKNOWNVER}) {
$control = $OPTIONS{UNKNOWNVER};
} elsif (%$versions) {
$control = 'warn';
} else {
return;
}
if ($control =~ /^(\w+):(.+)/) {
$action = $1;
$message = $2;
} elsif ($control =~ /^(\w+)/) {
$action = $1;
}
return unless $action;
if ($action eq 'warn') {
print STDERR "Warning: the rules file may not work with $NAME version $version.\n";
print STDERR "Reason: $message\n" if $message;
print STDERR "Press ctrl-c to abort, or <enter> to continue ";
<STDIN>;
} elsif ($action eq 'abort') {
print STDERR "This rules file should not be used with $NAME version $version.\n";
print STDERR "Reason: $message\n" if $message;
choke();
} elsif ($action ne 'ok') {
choke("\"$action\" is not a proper version control action.");
}
}
sub setperms {
my ($dir, %defperms) = @_;
my $type;
return unless %defperms;
find (
sub {
if (! /^\.\.?$/) {
my $f = $File::Find::name;
if (-d $f) { $type = 'dir' }
elsif (-x _) { $type = 'exec' }
else { $type = 'data' }
if (!-l $f and $defperms{$type}) {
chmod $defperms{$type}, $f
or choke("Can't chmod $f: $!");
}
}
},
$dir);
}
sub mkdirs {
my $dir;
foreach (@_) {
($dir = $_) =~ s!^/*!$PKGDIR/!;
unless (-d $dir) {
mkpath(($dir), $verbosity > 1, 0755);
}
}
}
sub copyfiles {
my ($destdir, @files) = @_;
my ($file, $dir, $filename, $perms, $dirperms);
if ($DEFPERMS{dir}) {
$dirperms = $DEFPERMS{dir};
} else {
$dirperms = 0755;
}
$destdir =~ s!^/*!!;
foreach $file (@files) {
$file =~ s!^/*!!;
if ($file =~ m!/!) {
($filename, $dir) = fileparse($file);
} else {
($filename, $dir) = ($file, '');
}
choke("copyfiles: $file doesn't exist") unless -f "$SRCDIR/$file";
# copy() stomps permissions, so save them, copy, and restore
$perms = (stat "$SRCDIR/$file")[2] & 07777;
mkpath(["$PKGDIR/$destdir"], $verbosity > 1, $dirperms)
unless -d "$PKGDIR/$destdir";
copy("$SRCDIR/$dir$filename", "$PKGDIR/$destdir/$filename") or
choke("failed to copy $SRCDIR/$file\n to: $PKGDIR/$destdir/$filename: $!");
chmod($perms, "$PKGDIR/$destdir/$filename") or
choke("couldn't chmod $PKGDIR/$file: $!");
}
}
# symbolstrip:
#
# This sub takes a directory and strips all object files that
# it can find, in that directory and all of its subdirectories.
#
# It uses `file' to determine whether a file should be stripped.
# This is because `file' is much faster than `strip', and furthermore,
# it can be given a list of files to check. And if you try to
# strip an inappropriate file, you get an error message :)
#
# This is one situation where a double pipe would be nice,
# but that's complex, so instead we'll do:
#
# 1) generate a list of files
# 2) write the list to a temporary file
# 3) run `file' on the list, and parse its output
# 4) run `strip --strip-unneeded' on the files that
# `file' indicated might need stripping.
sub symbolstrip {
my $striproot = shift;
my ($dir, $entry, @files, $line);
my @dirs = ($striproot);
my $dh = gensym();
my $fh = gensym();
my $listfile = tmpnam() or choke("Couldn't get tempfile from tmpnam");
# Create a text file with a list of filenames to pass to file.
sysopen $fh, $listfile, O_CREAT | O_WRONLY | O_EXCL | O_NOFOLLOW, 0600 or
choke("Can't sysopen $listfile: $!");
$cleanups{stripping} = $listfile;
while (@dirs) {
$dir = pop @dirs;
opendir $dh, $dir or choke("Can't opendir $dir: $!");
while (defined ($entry = readdir $dh)) {
next if $entry =~ /^\.\.?$/ or -l "$dir/$entry"; # do not try to follow symlinks
if (-d "$dir/$entry") {
push @dirs, "$dir/$entry";
} elsif (-f _) {
print $fh "$dir/$entry\n";
push @files, "$dir/$entry";
}
}
closedir $dh;
}
close $fh or choke("Error closing $listfile: $!");
open $fh, "file -b -f \Q$listfile\E |" or
choke("Can't read from file: $!");
while (defined($line = <$fh>)) {
# `file' needs some updating :(
if ($line =~ /\b(?:not stripped)\b/) {
# if ($line =~ /\b(?:not stripped|current ar archive)\b/) {
dbugout(2, "stripping $files[0]");
system('strip', '--strip-unneeded', $files[0]);
}
shift @files;
}
close $fh;
unlink $listfile or choke("Can't unlink $listfile: $!");
delete $cleanups{stripping};
}
sub docfiles {
copyfiles("usr/doc/$NAME-$VERSION", @_);
}
sub getconfig {
my ($option, $default, @progs) = @_;
my $answer;
foreach (@progs) {
chomp ($answer = `\Q$_\E --\Q$option\E 2>/dev/null`);
return $answer if $answer ne '';
}
$default;
}
sub addsource {
my $name = shift;
my (@found, $src, $tmpdir, $version, $suffix, $srcdir);
if ($SOURCES and -d $SOURCES) {
my @found = glob("$SOURCES/$name*");
if (@found < 1) {
choke("Can't find required archive for '$name' in $SOURCES");
} elsif (@found > 1) {
choke("Multiple candidates found for '$name' in $SOURCES");
}
$src = $found[0];
$tmpdir = tmpnam() or choke("Couldn't get a temporary directory");
mkdir $tmpdir, 0700 or choke("Can't mkdir $tmpdir: $!");
$addsrcindex ||= 0;
$addsrcindex++;
$cleanups{"addsource$addsrcindex"} = $tmpdir;
(undef, $version, $suffix) = parsesource($src);
$srcdir = src_to_tempdir($src, $tmpdir, $suffix);
($srcdir, $version);
}
}
sub ziptree {
my @dirs = @_;
my ($dir, $pdir, $dh, $verbose, $entry, %links, $link, $linkdir);
dbugout(1, "compressing files in " . join(', ', @dirs));
$verbosity ? $verbose = 'v' : $verbose = '';
$dh = gensym();
%links = ();
while ($dir = pop @dirs) {
$pdir = "$PKGDIR/$dir";
opendir $dh, $pdir or choke("Can't opendir $pdir: $!");
while (defined($entry = readdir $dh)) {
next if $entry =~ /^\.\.?$/;
if (-l "$pdir/$entry") {
$links{"$dir/$entry"} = readlink "$pdir/$entry";
} elsif (-d _) {
push @dirs, "$dir/$entry";
} elsif (-f _ and $entry !~ /\.gz$/) {
system('gzip', "-${verbose}9", "$pdir/$entry");
}
}
}
# At this point, $link will always be relative to $PKGDIR
# Fix any symbolic links that pointed to something that was
# just gzipped. Only works on single-level symlinks, though
foreach $link (keys %links) {
$linkdir = dirname $link;
if (!(($links{$link} =~ m!^/! and -e $links{$link}) or -e "$PKGDIR/$linkdir/$links{$link}")) {
if ((-e "$links{$link}.gz" and $links{$link} =~ m!^/!) or -e "$PKGDIR/$linkdir/$links{$link}.gz") {
dbugout(1, "(ziptree) Changing symbolic link:\n $PKGDIR/$link -> $links{$link}\n to $PKGDIR/$link.gz -> $links{$link}.gz");
unlink "$PKGDIR/$link" or choke("Can't unlink $PKGDIR/$link: $!");
symlink "$links{$link}.gz", "$PKGDIR/$link.gz" or
choke("Can't create symbolic link $PKGDIR/$link.gz -> $links{$link}.gz: $!");
}
}
}
}
sub apply_patches {
my $patchdir = shift || "$RULESDIR/patches";
my @patches = (
glob("$RULESDIR/patches/$NAME-$VERSION-*patch"),
glob("$RULESDIR/patches/$NAME-$VERSION-*patch.gz"),
glob("$RULESDIR/patches/$NAME-$VERSION-*patch.bz2")
);
if (@patches) {
foreach (@patches) {
if (/\.gz$/) {
shellcmd("zcat \Q$_\E | patch -p1", 'apply patch');
} elsif (/\.bz2$/) {
shellcmd("bzip2 -dc \Q$_\E | patch -p1", 'apply patch');
} else {
shellcmd("patch -p1 < \Q$_\E", 'apply patch');
}
}
} else {
dbugout(1, '(apply_patches) No patches to apply.');
}
}
sub preserve_config {
my @current = @_;
my ($current, $currentscriptname, $moveto, $movetoscriptname, $script);
if ($doinstvals{added_preserve_sub}) {
$script = '';
} else {
$script = '
cfgpreserve() {
OLD="$1"
NEW="$2"
# If there\'s no config file by that name, mv it over:
if [ ! -r $OLD ]; then
mv $NEW $OLD
elif [ "`cat $OLD | md5sum`" = "`cat $NEW | md5sum`" ]; then # toss the redundant copy
rm $NEW
fi
# Otherwise, we leave the .new copy for the admin to consider...
}
';
$doinstvals{added_preserve_sub} = 1;
}
foreach $current (@current) {
$current =~ s/^\Q$PKGDIR\E//;
$current =~ s:^/*::;
($currentscriptname = $current) =~ s/"/\\"/g;
unless (-e "$PKGDIR/$current") {
choke("Can't preserve_config $current: not found.");
}
$moveto = "$current.new";
($movetoscriptname = $moveto) =~ s/"/\\"/g;
if (-e "$PKGDIR/$moveto") {
choke("Can't preserve_config $current, $moveto already present!");
}
rename("$PKGDIR/$current", "$PKGDIR/$moveto")
or choke("Can't rename $PKGDIR/$current to $PKGDIR/$moveto: $!");
$script .= qq[cfgpreserve "$currentscriptname" "$movetoscriptname"\n];
}
doinst_append($script);
}
sub checkdupes { foreach (@_) { _checkdupes($_) } }
sub _checkdupes {
my ($orig) = @_;
my $porig = "$PKGDIR/$orig";
my $size = (stat $porig)[7];
my $dh = gensym();
my $dir = dirname($porig);
my $obase = basename($orig);
my ($md5sum, $entry, $esum);
choke("$porig doesn't exist") unless -e $porig;
choke("$porig is not a file") unless -f $porig;
($md5sum = `md5sum \Q$porig\E`) =~ s/\s.*//s;
opendir $dh, $dir or choke("Can't opendir $dir: $!");
while (defined ($entry = readdir $dh)) {
next if $entry eq $obase;
if (-f "$dir/$entry" and (stat _)[7] == $size) {
($esum = `md5sum \Q$dir/$entry\E`) =~ s/\s.*//s;
if ($esum eq $md5sum) {
dbugout(0, "replacing $dir/$entry with symbolic link to $obase");
unlink "$dir/$entry" or choke("Can't unlink $dir/$entry: $!");
symlink $obase, "$dir/$entry" or choke("Can't symlink $dir/$entry: $!");
}
}
}
closedir $dh;
}
sub handle_perllocal_pod {
my ($mm, $pkgpodfile, $podtext, $module_name);
# Perl modules installed with MakeMaker often append a notice of their
# presence to perllocal.pod. With autopkg, this has to be dealt with
# for two reasons:
#
# 1. Our $PKGDIR will contain a file, perllocal.pod, that would simply
# overwrite the existing one when installed. Something has to be
# done so that it will be appended, instead.
#
# 2. It contains the line "installed into <dir>", and <dir> will be
# $PKGDIR/<prefix>/... which won't be true after actual package
# installation.
# Sometimes perllocal.pod ends up in $Config{installsitearch}.
# But perldoc always looks for it in $Config{installarchlib}.
# So both places must be checked.
foreach (qw(installarchlib installsitearch)) {
$pkgpodfile = "$PKGDIR$Config{$_}/perllocal.pod";
last if -f $pkgpodfile;
}
return unless -f $pkgpodfile;
dbugout(1, "Handling $pkgpodfile");
# Prepare a modified perllocal.pod:
$podtext = slurpfile($pkgpodfile);
$podtext =~ s/into: \Q$PKGDIR\E/into: /
or choke("Can't fix perllocal.pod: no \"installed into\" line found.");
# Determine the package name
if ($podtext =~ /^=head.*<Module>.*L<([^|]+)\|/m) {
$module_name = $1;
choke("Can't handle a perllocal.pod for a module whose name contains \"'\"")
if $module_name =~ /'/;
} else {
choke("Can't determine module name from perllocal.pod");
}
# Get rid of old perllocal.pod so it won't overwrite when installed:
unlink $pkgpodfile;
# Cause doinst.sh to append our perllocal.pod to the system one at
# install time (unfortunately it will remain there if uninstalled):
doinst_append(
"if [ `which perl 2>/dev/null` ]; then\n" .
" perl install/appendpod \Q$module_name\E install/perllocal.pod.append\n" .
"fi\n" .
"rm -f install/cleanpod install/perllocal.pod.append\n");
# This script uses only the INSTALLARCHLIB directory of the system
# it's being run on... _not_ the directory as it was on the build
# system.
stowfile("$PKGDIR/install/appendpod",
'#!/usr/bin/perl -w
# This should probably be done in awk.
# Perl program to remove a particular section of perllocal.pod and
# append a new file afterward.
use Config;
$package = shift or die "Remove what package from perllocal.pod?\n";
$newpod = shift or die "Append what to the existing perllocal.pod?\n";
($ial = $Config{installarchlib}) =~ s:^/::;
$plp = "$ial/perllocal.pod";
chomp($tmp = `tempfile`);
$tmp and -e $tmp or die "Can\'t get a tempfile!\n";
open FO, ">$tmp" or die "Can\'t write $tmp: $!\n";
if (-e $plp) {
open F, $plp or die "Can\'t read $plp: $!\n";
$inpack = 0;
$over = 0;
while (<F>) {
if ($inpack) {
if (/^=over/) {
$over++;
} elsif (/^=back/) {
$over--;
die "Malformed podfile (too many =back): $plp\n";
} elsif (/^=head.*Module/ and $over == 0) {
$inpack = 0;
print FO;
}
} elsif (/^=head.*<\Q$package\E\|/) {
$inpack = 1;
} else {
print FO;
}
}
close F;
unlink $plp or die "Can\'t unlink $plp: $!\n";
} elsif (! -d $ial) {
system("mkdir", "-p", $ial) and die "mkdir -p $ial failed.\n";
}
close FO;
system("mv", $tmp, $plp) and die "Can\'t mv $tmp $plp!\n";
chmod 0644, $plp;
system("cat \Q$newpod\E >> \Q$plp\E") and die "Append $newpod to $plp failed.\n";
');
# Now that $PKGDIR/install is sure to exist, save our perllocal.pod:
stowfile("$PKGDIR/install/perllocal.pod.append", $podtext);
}
# check_perl_module
#
# greps all files in the given directory (which defaults to $PKGDIR)
# for the string "$PKGDIR". $PKGDIR, being a directory that only has
# meaning during the packaging process, had better not be embedded
# in any of the package's files. Inattentive perl program package
# writers sometimes let this sort of thing happen. So we check for it
# here, and fix it if it's in perllocal.pod or .packlist. But if
# it's in some other file, we don't try to fix it as there's no way
# to be sure that just removing the text of $PKGDIR from the file
# will be okay. We abort in that case.
#
# > perllocal.pod: does nothing; handle_perllocal_pod should deal with it.
# > .packlist: fixes it, removing all $PKGDIR.
# > (other file): This is a fatal error.
sub check_perl_module {
my $checkdir = shift || $PKGDIR;
my ($f, $err);
find (
sub {
if (! /^\.\.?$/) {
$f = $File::Find::name;
if (-f $f and `grep $PKGDIR $f`) {
if ($f =~ m!/\.packlist$!) {
fixpacklist($f);
} elsif ($f !~ m!/perllocal\.pod$!) {
print STDERR " [autopkg] Fatal: check_perl_module: $f contained $PKGDIR\n";
$err = 1;
}
}
}
},
$checkdir);
choke('check_perl_module found errors.') if $err;
}
sub fixpacklist {
my $file = shift;
my ($fh, $line, %lines);
open $fh, $file or choke("Can't read $file: $!");
while ($line = <$fh>) {
$line =~ s/^\Q$PKGDIR\E//;
$lines{$line} = 1;
}
close $fh;
open $fh, ">$file" or choke("Can't write $file: $!");
foreach (sort keys %lines) {
print $fh $_;
}
close $fh;
}
sub doinst_append {
my $text = shift;
my $doinst;
if (-e "$PKGDIR/install/doinst.sh") {
$doinst = slurpfile("$PKGDIR/install/doinst.sh");
} else {
mkdirs('install');
$doinst = '';
}
stowfile("$PKGDIR/install/doinst.sh", $doinst . $text);
}
sub procnames {
# Change [user, group] where user and group may be numeric or named
# into [numeric uid, numeric gid, string name, string group].
# Preserve any additional values that may be present.
# This is what addfile() will want.
# This sub will receive a hash whose values are references to arrays.
# It is only interested in the first two values of each array.
# Those values are: name, group.
# It will determine the uid of the name, and the gid of the group.
# It will then INSERT those two values after the second item in the array.
# Therefore, a hash like %DIROWNER, which has values of [username, group, perms]
# will have its third item moved to position #5.
my ($ownership, $options) = @_;
my ($k, $uname, $uid, $gname, $gid);
foreach $k (keys %$ownership) {
($uid, $gid, $uname, $gname) = getusergroup(@{$ownership->{$k}});
$ownership->{$k} = [$uid, $gid, $uname, $gname,
@{$ownership->{$k}}[2.. $#{$ownership->{$k}} ]];
dbugout(2, "(procnames $k) - [$uid, $gid, $uname, $gname]");
}
($uid, $gid, $uname, $gname) = getusergroup(@{$options->{DEFOWN}});
$options->{DEFOWN} = [$uid, $gid, $uname, $gname];
}
sub getusergroup {
my ($user, $group) = @_;
my ($uid, $gid, $uname, $gname);
$group =~ s/(\d)\s.*/$1/;
if ($user !~ /^\d+$/) {
$uid = getpwnam($user);
defined $uid or choke("Can't get uid for user $user");
$uname = $user;
} else {
$uid = $user;
$uname = getpwuid($uid) or choke("Can't get username for $uid");
}
if ($group !~ /^\d+$/) {
$gid = getgrnam($group);
defined $gid or choke("Can't get gid for group $group");
$gname = $group;
} else {
$gid = $group;
$gname = getgrgid($gid) or choke("Can't get group name for $gid");
}
($uid, $gid, $uname, $gname);
}
sub getpkgname {
my ($format, $subs) = @_;
my $name = $format;
my ($key, $val);
while (($key, $val) = each %$subs) {
$val =~ s/-/_/g;
$name =~ s/\Q$key\E/$val/g;
}
$name;
}
sub process_iwlog {
my $logfile = shift;
my $fh = gensym();
# This sub generally replaces the rules functions like build().
# Therefore, its purpose is to recreate, in $PKGDIR, whatever was
# installed. The logfile has all the information we need.
# These directories are likely places where the software was built.
# If the installation procedure did more building, they may show up
# in the installation log. But they should not be included in the
# package. /dev is also excluded.
my @excludedirs = qw(/tmp/ /home/ /dev/);
# The following operations may be ignored:
#
# Operation Reason
# ---------- -------------------------------------------------------
# chown Whatever intermediate values the uid/gid of the file
# have been, we only care where they ended up-- which
# will be checked when the file is copied over.
# time irrelevant
# fchmod same reason as chown
# fchown ^
# lchown ^
# unlink If the file isn't there, we don't have to worry about
# including it.
# rmdir same reason as unlink
# The following operations should (probably?) be handled but aren't, so
# abort when seen:
#
# chroot
# creat
# creat64
# truncate
# ftruncate
# truncate64
# ftruncate64
# link
my @ignoreiw = qw(chmod chown time fchmod fchown lchown unlink rmdir);
my $ignoreiw = join('|', @ignoreiw);
my @abortiw = qw(chroot creat creat64 truncate ftruncate truncate64
ftruncate64);
my $abortiw = join('|', @abortiw);
my ($line, $result, $command, $file1, $file2, $arg1, $arg2, $message);
my ($name, $path, $uid, $gid, $mode);
open $fh, $logfile or choke("Can't read $logfile: $!");
IWLINE:
while(defined($line = <$fh>)) {
chomp $line;
dbugout(3, " >>> $line");
if ($line =~ /([-\d]+)\t(open|open64|fopen|fopen64|mkdir)\t([^\t]+)\t#(.+)/) {
($result, $command, $file1, $message) = ($1, $2, $3, $4);
} elsif ($line =~ /([-\d]+)\t(symlink|rename|link)\t([^\t]+)\t([^\t]+)\t#(.+)/) {
($result, $command, $file1, $file2, $message) = ($1, $2, $3, $4, $5);
# You might see a file created, a new link made to it, and the original
# file removed. By the time you run autopkg, it appears that a link
# is being made to a nonexistent file. To handle this situation, we
# will pretend that it's just an 'open' operation.
if ($command eq 'link' and ! -e "$PKGDIR$file1" and -e $file2) {
$command = 'open';
$file1 = $file2;
}
} elsif ($line =~ /[-\d]+\t($abortiw)\t/) {
choke("I cant't handle the '$1' operation from installwatch logs, sorry.");
} elsif ($line =~ /[-\d]+\t(?:$ignoreiw)\t/) {
next;
} elsif ($line =~ /[-\d]+\t(\w+)\t/) {
choke("Unknown operation '$1' in the installwatch log.");
} else {
chomp $line;
choke("Unrecognized line from $logfile: $line");
}
dbugout(2, "[iwlog] command: \U$command\E");
foreach (@excludedirs) {
if ($file1 =~ /^\Q$_\E/) {
dbugout(3, " -- skipping operation in excluded directory $_");
next IWLINE;
}
}
# OPEN FOPEN FOPEN64 RENAME
if ($command =~ /^(?:open|open64|fopen|fopen64|rename)$/) {
$file1 = $file2 if $command eq 'rename';
if ($result == -1) {
choke(" !! $command failed: $message");
}
if (! -e $file1) {
dbugout(2, " -- skipping nonexistent $file1");
next;
}
dbugout(3, " ++ adding $file1");
($name, $path) = fileparse($file1);
mkdirs($path);
copy($file1, "$PKGDIR$path") or choke("Can't copy $file1 to $PKGDIR$path");
$mode = (stat $file1)[2] & 07777;
chmod $mode, "$PKGDIR$path/$name";
(undef, undef, undef, undef, $uid, $gid) = stat($file1);
$OWNERSHIP{$file1} = [$uid, $gid];
# LINK
} elsif ($command eq 'link') {
unless (-e "$PKGDIR$file1") {
choke("Can't link, $PKGDIR$file1 doesn't exist!");
}
($name, $path) = fileparse($file2);
mkdirs($path);
link "$PKGDIR$file1", "$PKGDIR$file2" or
choke("Can't link $PKGDIR$file2 -> $PKGDIR$file1: $!");
# MKDIR
} elsif ($command eq 'mkdir') {
if ($result == -1 and $message !~ /\bexists\b/) {
choke(" !! open failed: $message");
}
if (! -d $file1) {
dbugout(2, " -- skipping nonexistent $file1");
next;
}
dbugout(3, " ++ adding $file1");
mkdirs($file1);
# SYMLINK
} elsif ($command eq 'symlink') {
dbugout(2, " ++ making symlink $PKGDIR$file2 -> $file1");
symlink($file1, "$PKGDIR$file2")
or choke("Couldn't symlink $PKGDIR$file2 -> $file1: $!");
}
}
close $fh;
}
sub maketgz {
my ($pkgdir, $name, $scriptlinks) = @_;
my ($tarball, $savecwd, $dir, $entry, $ename, $linkage, @tarfiles, $tarfile);
my @filelist = ();
my $isfile = 'install/doinst.sh';
dbugout(0, qq{making tarball "$name"});
$savecwd = cwd();
chdir($pkgdir) or choke("Can't chdir to $pkgdir: $!");
$tarball = Archive::Tar->new() or
choke("Couldn't create a tar archive: " . Archive::Tar::error());
my @dirs = ('.');
my $dh = gensym();
my $instscript = '';
# Add './' to appease Slackware 8.1's installpkg.
push @filelist, './';
# This loop will make a list of files in the package directory.
# However, it will probably not add symbolic links. Instead, they
# will be used to build up the script that will be written to
# doinst.sh.
while ($dir = pop @dirs) {
opendir $dh, $dir or choke("Can't opendir $dir: $!");
while (defined ($entry = readdir $dh)) {
next if $entry =~ /^\.\.?$/;
($ename = "$dir/$entry") =~ s!^\./!!;
# Skip this file if it's "doinst.sh"; that one will be handled
# after these two loops.
next if $ename eq $isfile and $scriptlinks;
# Handle symbolic links here
if (-l $ename) {
$linkage = readlink("$dir/$entry") or
choke("Can't readlink $dir/$entry: $!");
$linkage =~ s!^\Q$pkgdir\E!!;
if ($scriptlinks) {
# This is what to do if symlinks are to be created by
# doinst.sh.
dbugout(3, "(adding symlink: to doinst.sh) $ename");
$instscript .= "( cd " . dirname($ename) . " ; rm -rf " .
basename($ename) . " )\n( cd " . dirname($ename) .
" ; ln -sf $linkage " . basename($ename) . " )\n";
} else {
# Will reaccomplish the link just in case it was originally
# an absolute link. Such a link would be broken when the
# package is installed. If it wasn't, the following two
# operations will effectively be a no-op.
unlink $ename or choke("Can't unlkink $ename: $!");
symlink $linkage, $ename or
choke("Can't symlink $ename -> $linkage: $!");
push @filelist, $ename;
}
} else {
# ... not a symbolic link:
if (-d _) {
push @dirs, "$dir/$entry";
push @filelist, "$ename/";
} else {
push @filelist, $ename;
}
}
} # (while reading dir entries)
} # (while popping dirs)
# Most of the files are in @filelist. Only the install directory
# and doinst.sh remain.
if ( $instscript or ($scriptlinks and -f $isfile) ) {
if (-f $isfile) {
my $origis = slurpfile($isfile);
# This is _not_ the same as #?\@SYMLINKS\@#?
unless ($origis =~ s/(?:#\@SYMLINKS\@#|\@SYMLINKS\@)/$instscript/) {
$origis =~ s/^/$instscript/;
}
$instscript = $origis;
}
unless (-d 'install') {
mkdirs('install');
push @filelist, 'install';
}
stowfile($isfile, $instscript);
push @filelist, $isfile;
}
# Finally, all of the filenames are in @filelist. They can be
# added to the tarball now.
@tarfiles = $tarball->add_files(sort @filelist);
# Manually modify the owner/group of each file.
foreach $tarfile (@tarfiles) {
# Oh and by the way, when we added './', it had permissions of
# 0700 (because it was a /tmp/fooxxxxx directory). This needs
# to be changed to 0755 -- it will be written to the actual root
# directory when the package is installed.
if ($tarfile->type == DIR and $tarfile->prefix eq '.') {
$tarfile->mode(0755);
}
set_tarfile_owner($tarfile);
}
# Now the tarball is ready to be written.
dbugout(1, "compressing and writing the tarball");
$tarball->write($name, 1)
or choke("tarball-write to $name failed? " . $tarball->error());
chdir($savecwd) or choke("Can't chdir to $savecwd: $!");
}
sub set_tarfile_owner {
my $tarfile = shift;
my $ownership;
my $name = $tarfile->prefix . '/' . $tarfile->name;
$name =~ s:/*$::;
if ($ownership = getownership($name, $tarfile)) {
$tarfile->uid($ownership->[0]);
$tarfile->gid($ownership->[1]);
$tarfile->uname($ownership->[2]);
$tarfile->gname($ownership->[3]);
}
}
sub getownership {
my ($filename, $tarfile) = @_;
# Check for ownership modification by %OWNERSHIP
return $OWNERSHIP{$filename} if $OWNERSHIP{$filename};
if (-d $filename) {
foreach (keys %DIROWNER) {
if (($tarfile->mode & $DIROWNER{$_}->[4]) == $DIROWNER{$_}->[4] and
$_ eq $filename) {
return $DIROWNER{$_};
}
}
} else {
foreach (keys %DIROWNER) {
if (($tarfile->mode & $DIROWNER{$_}->[4]) == $DIROWNER{$_}->[4] and
$_ eq dirname($filename)) {
return $DIROWNER{$_};
}
}
}
# Check for ownership modification by $OPTIONS{DEFOWN}
return $OPTIONS{DEFOWN} if $OPTIONS{SETOWNERS};
}
# create_descfile - should be called between the time when the
# source of the description file can be definitively determined,
# and the beginning of the tarring up process.
sub create_descfile {
my ($logfile, $data);
# $givendesc is set by a call to include_desc, which has the highest priority:
if ($givendesc) {
mkdirs('install') unless -d "$PKGDIR/install";
stowfile("$PKGDIR/install/slack-desc", $givendesc);
# $DESCDIR has the next highest priority
} elsif ($OPTIONS{USE_DESCDIR} and -e "$DESCDIR/$NAME") {
dbugout(1, "using description file $DESCDIR/$NAME");
mkdirs('install') unless -d "$PKGDIR/install";
$data = slurpfile("$DESCDIR/$NAME");
$data =~ s/\@([a-zA-Z_]\w*)\@/getsub($1)/eg;
stowfile("$PKGDIR/install/slack-desc", $data);
# using an installed desc is the last resort
} elsif ($OPTIONS{USE_INSTALLED_DESC} and $logfile = locate_pkg_log($NAME)) {
dbugout(1, "nabbing description from $logfile");
$data = read_pkg_log($logfile);
if (exists $data->{desc}) {
mkdirs('install') unless -d "$PKGDIR/install";
stowfile("$PKGDIR/install/slack-desc",
slack_desc($data, $OPTIONS{DESC_INSTRUCTIONS}));
} else {
dbugout(1, "(no description was found in $logfile)");
}
}
}
sub getsub {
my $key = shift;
return $SUBS{$key} if exists $SUBS{$key};
no strict 'vars';
no strict 'refs';
if (exists $main::{$key}) {
local *sym = $main::{$key};
return $$key if defined $sym;
}
choke("No \%subs value or global scalar is available for '$key'.");
}
sub combinepkgs {
my $pkgname = shift;
my @inpkgs = @_;
my ($tmpkey, $tmpdir) = gettempdir(0700);
my $doinstsh = '';
my ($package, $line, $owner, $group, $filename);
$pkgname .= '.tgz' unless $pkgname =~ /\.tgz$/;
choke("combinepkgs requires two or more packages") if @inpkgs < 2;
foreach (@inpkgs) {
dbugout(1, "Checking $_");
choke("$_ doesn't exist") unless -f $_;
choke("$_ isn't a package") unless /.\.tgz$/;
}
foreach $package (@inpkgs) {
dbugout(0, "Extracting $package");
# Pipe the tar command so it can be parsed, and special
# ownerships be preserved:
open F, "tar -C \Q$tmpdir\E -xzvvf \Q$package\E|"
or choke("Can't pipe tar -C $tmpdir -xzf $package: $!");
while (defined($line = <F>)) {
if ($line =~ m!^\S+\s+([^\s/]+)/([^\s/]+)\s+\d+\s+\S+\s+\S+\s(.+)!) {
($owner, $group, $filename) = ($1, $2, $3);
if ($owner ne 'root' or $group ne 'root') {
$filename =~ s:^\.?/+::;
$filename =~ s:/*$::;
dbugout(2, "retaining ownership: $filename => $owner, $group");
$OWNERSHIP{$filename} = [$owner, $group];
}
}
}
close F;
if (-e "$tmpdir/install/doinst.sh") {
$doinstsh .= slurpfile("$tmpdir/install/doinst.sh");
unlink "$tmpdir/install/doinst.sh" or
choke("Can't unlink $tmpdir/install/doinst.sh: $!");
}
}
if ($doinstsh) {
stowfile("$tmpdir/install/doinst.sh", $doinstsh);
}
%DIROWNER = ();
procnames(\%OWNERSHIP, \%OPTIONS);
maketgz($tmpdir, $pkgname, 0);
dbugout(0, "moving $pkgname to $OPTIONS{DESTDIR}");
move("$tmpdir/$pkgname", $OPTIONS{DESTDIR}) or
choke("can't move $pkgname to $OPTIONS{DESTDIR}: $!");
cleantmp();
dbugout(0, "finished.");
}
sub slurpfile {
my $filename = shift;
my $fh = gensym();
open $fh, $filename or choke("Can't read $filename: $!");
local $/;
my $data = <$fh>;
close $fh;
$data;
}
sub stowfile {
my ($filename, $data, $mode) = @_;
my $fh = gensym();
open $fh, ">$filename" or choke("Can't write $filename: $!");
print $fh $data;
close $fh or choke("Problem closing $filename: $!");
if (defined $mode) {
chmod $mode, $filename or
choke(sprintf("(stowfile) can't chmod 0%o $filename: $!", $mode));
}
1;
}
sub shellcmd {
my ($command, $purpose) = @_;
$command .= " > /dev/null" unless $verbosity;
if ($purpose) {
dbugout(1, "(shellcmd: $purpose) $command");
} else {
dbugout(1, "(shellcmd) $command");
}
$purpose ||= $command;
system($command) and choke("$purpose failed!");
}
sub include_desc {
my ($text, $instructions) = @_;
my $data = {}; # construct data structure as PKGPARSE functions desire
$instructions = $OPTIONS{DESC_INSTRUCTIONS} unless defined $instructions;
$data->{name} = $NAME;
$data->{desc} = [];
foreach (split /\n/, $text) {
push @{$data->{desc}}, $_;
}
$givendesc = slack_desc($data, $instructions);
}
sub cleantmp {
my $tmp;
foreach (keys %cleanups) {
$tmp = $cleanups{$_};
delete $cleanups{$_};
dbugout(1, "clean up: rmtree($tmp)");
rmtree($tmp, $verbosity > 2);
}
}
sub gettempdir {
my $tmpkey = gensym();
my $tmpdir = tmpnam() or choke("Can't get a temporary directory!");
my $mask = shift || 0755;
mkdir $tmpdir, $mask or choke("Can't mkdir $tmpdir: $!");
$cleanups{$tmpkey} = $tmpdir;
($tmpkey, $tmpdir);
}
sub choke {
print STDERR "$programname - fatal: ";
for (@_) { print STDERR "$_\n" }
fatal_pause();
}
sub sigcatcher {
my $signame = '';
if (exists $SIG{$_[0]}) { # Now why doesn't a die() pass '__DIE__' here?
$signame = shift;
$SIG{$signame} = 'DEFAULT';
}
print STDERR @_, "\n**** Package not built ****\n\n";
fatal_pause();
}
sub fatal_pause {
unless ($options{nopause}) {
print " - source directory is $SRCDIR\n" if $SRCDIR;
print " - package directory is $PKGDIR\n" if $PKGDIR;
print "Pausing; press enter to clean up ";
<STDIN>;
}
cleantmp();
exit 1;
}
#===========================================================================#
# BEGIN PKGPARSE IMPORT #
#===========================================================================#
# PKGPARSE ------- subroutines for dealing with Slackware package installation
# logs (the files in /var/log/packages) and slack-desc files
# THE PACKAGE DATA STRUCTURE
# ==========================
#
# These routines deal with exactly one kind of data structure. Here's its
# format.
#
# It is a reference to a hash. Its keys are the same as the field names
# found in an installation log, for example 'PACKAGE MD5SUM'. The values
# are whatever text was found after a field name. All fields found in
# a log file during parsing will be included, even odd ones that this
# code doesn't recognize. Furthermore, the output functions that produce
# text from this data structure will faithfully reproduce such unknown
# data, though with one important caveat -- their order will not be
# preserved. The known fields will be output in a predetermined order,
# however.
#
# There are two exceptions to the rule about all fields from a log file
# ending up in the structure. First, the package description and file
# list data will end up under the keys 'desc' and 'files', respectively,
# and this data will _not_ be available via the keys 'PACKAGE DESCRIPTION'
# and 'FILE LIST'. Second, the data for the standard fields will
# be available via aliases:
#
# name - "PACKAGE NAME"
# compressed - "COMPRESSED PACKAGE SIZE"
# uncompressed - "UNCOMPRESSED PACKAGE SIZE"
# md5sum - "PACKAGE MD5SUM"
# location - "PACKAGE LOCATION"
#
# If you modify one of these structures or create your own, you can use
# the long key names or the aliases. The functions below that do things
# with a structure will accept either. They will even accept
# 'PACKAGE DESCRIPTION' or 'FILE LIST'. Note however that those keys
# can never be expected to be in a returned structure.
# THE FUNCTIONS
# =============
# locate_pkg_log - given a package name, return the log filename
# base_pkg_name - given a package name in any format, return its base name
#
# Examples:
#
# 'zlib-1.1.4-i386-1' -> 'zlib'
# 'gdk-pixbuf-0.13-i386-1' -> 'gdk-pixbuf'
# 'analog' -> 'analog'
# dump_pkg_data - given a log structure, print its contents to stdout
# (a debugging aid)
# slack_desc - given a log structure, return a string suitable for
# saving as a slack-desc file. only the name and desc
# fields are needed. It will include blank lines as
# needed to supply the required 11 lines. It will
# _not_ discard lines if it discovers more than 11,
# though.
#
# The returned string will not include the ubiquitous
# "how to edit this file" instructions unless you pass
# it a second true parameter, e.g.:
# $text = slack_desc($foodata, 1);
#
# The advantage of asking this sub to put the text there is
# that it will line up the "handy ruler" with the colon
# after the short package name, just as it is in the Real
# Thing [tm].
# make_pkg_log - given a log structure, return a string suitable for
# saving as a package installation log file. in other
# words, it is the reverse operation of read_pkg_log.
# duplicate_pkg_data - make a copy of a log structure
# normalize_pkg_data - make sure a log structure has the alternate
# short field names _and_ their associated long
# names (except desc and files)
# read_pkg_log - given a log filename, read and parse it and return
# a log structure.
# read_pkg_desc - given a filename for a slack-desc or similar file,
# read and parse it and return a log structure.
sub locate_pkg_log {
my $name = shift;
my ($longname, $foundname, $requestname);
$requestname = base_pkg_name($name);
if (-e "$pp_pkgdir/$name") {
$foundname = "$pp_pkgdir/$name";
} else {
foreach $longname (glob "$pp_pkgdir/$name*") {
if ($requestname eq base_pkg_name($longname)) {
$foundname = $longname;
last;
}
}
}
if (!$foundname) {
return undef;
} elsif (-d $foundname) {
choke("locate_pkg_log: found $foundname (a directory?)");
}
$foundname;
}
sub base_pkg_name {
my $package = shift;
my $name;
$name = basename($package, (".tgz"));
# This regex is nice and picky, and only assumes that we have
# a long-style package name if there are three -xxxx constructs to
# chop off, and the final one is composed of digits. The release
# section should in fact be only digits.
# Using this regex rather than something like s/^([^-]+).*/$1/
# because the base name may also contain dashes.
# name-version-arch-release
$name =~ s/([^-])-[^-]+-[^-]+-\d[^-\s]*$/$1/;
$name;
}
sub read_pkg_log {
my $logfile = shift;
my ($text, $key, $val, $line);
my $data = {};
my $found_file_list = 0;
my $found_package_desc = 0;
my $basename = base_pkg_name($logfile);
my $descindent = 80;
open F, $logfile or choke("Can't read $logfile: $!");
while (defined ($line = <F>)) {
chomp $line;
if ($found_file_list) {
$line =~ s!^\.?/!!;
$line =~ s#/$##;
push @{$data->{files}}, $line if $line =~ /\S/;
} elsif ($found_package_desc and $line =~ /^\s*\Q$basename\E:(.*)/) {
$text = $1;
$text =~ s/^\s//;
push @{$data->{desc}}, $text;
if ($text =~ /^(\s*)\S/ and length($1) < $descindent) {
$descindent = length($1);
}
} elsif ($line =~ /^PACKAGE DESCRIPTION:/) {
$found_package_desc = 1;
$data->{desc} = [];
} elsif ($line =~ /^FILE LIST:/) {
$found_file_list = 1;
$data->{files} = [];
} elsif ($line =~ /^($aliaskeymatch):(.*)/) {
($key, $val) = ($1, $2);
$val =~ s/^\s*//;
$data->{$key} = $val;
if (exists $aliasfields{$key}) {
$data->{$aliasfields{$key}} = $val;
} else {
warn "read_pkg_log: don't know alias for \"$key\"?\n";
}
} elsif ($line =~ /^(\S[^:]*):(.*)/) {
($key, $val) = ($1, $2);
$val =~ s/^\s//;
$data->{$key} = $val;
} else {
warn "read_pkg_log: can't comprehend line $. of $logfile:\n $line\n";
}
}
close F;
if (@{$data->{desc}} == 0) {
delete $data->{desc};
} elsif ($descindent) {
foreach (@{$data->{desc}}) {
s/^\s{$descindent}//;
}
}
$data;
}
sub dump_pkg_data {
my $data = shift;
print "= Data dump of package $data->{name} =\n";
print " ( standard fields )\n";
foreach (keys %aliasfields) {
if (exists $data->{$_}) {
if (exists $data->{$aliasfields{$_}}) {
print "$aliasfields{$_}: $data->{$aliasfields{$_}}\n";
} else {
print "(um, no alias key for $_?)\n";
print "$_: $data->{$_}\n";
}
}
}
print " ( extra fields )\n";
foreach (keys %$data) {
next if exists $aliasfields{$_} or /^(?:$aliasvalmatch)$/;
print "$_: $data->{$_}\n";
}
print " ( description )\n";
if (exists $data->{desc}) {
foreach (@{$data->{desc}}) {
print "$_\n";
}
} else {
print "[no description]\n";
}
if (exists $data->{files}) {
print " ( file list )\n";
foreach (@{$data->{files}}) {
print "$_\n";
}
} else {
print "[no file list]\n";
}
}
sub normalize_pkg_data {
my $data = shift;
my $dup = duplicate_pkg_data($data);
my $key;
if (exists $dup->{'PACKAGE DESCRIPTION'}) {
$dup->{desc} = $dup->{'PACKAGE DESCRIPTION'}
unless exists $dup->{desc};
delete $dup->{'PACKAGE DESCRIPTION'};
}
if (exists $dup->{'FILE LIST'}) {
$dup->{files} = $dup->{'FILE LIST'}
unless exists $dup->{files};
delete $dup->{'FILE LIST'};
}
foreach $key (keys %$dup) {
if (exists $aliasfields{$key} and not exists $dup->{$aliasfields{$key}}) {
$dup->{$aliasfields{$key}} = $dup->{$key};
} elsif (exists $reversealias{$key} and not exists $dup->{$reversealias{$key}}) {
$dup->{$reversealias{$key}} = $dup->{$key};
}
}
$dup;
}
sub duplicate_pkg_data {
my $data = shift;
my ($datakey, $line);
my $dup = {};
foreach $datakey (keys %$data) {
if ($datakey =~ /^(?:PACKAGE DESCRIPTION|FILE LIST|desc|files)$/) {
$dup->{$datakey} = [];
foreach $line (@{$data->{$datakey}}) {
push @{$dup->{$datakey}}, $line;
}
} else {
$dup->{$datakey} = $data->{$datakey};
}
}
$dup;
}
sub slack_desc {
my ($data, $instructions) = @_;
my ($workdata, $basename, $sdesc);
$workdata = normalize_pkg_data($data);
$basename = base_pkg_name($workdata->{name});
if ($instructions) {
$sdesc = $howtoedit . ' ' x length($basename) . $handyruler . "\n";
} else {
$sdesc = '';
}
foreach (@{$data->{desc}}) {
$sdesc .= "$basename: $_\n";
}
$sdesc .= "$basename: \n" x ($slack_desc_lines - @{$data->{desc}});
$sdesc;
}
sub make_pkg_log {
my $data = shift;
my $key;
my $workdata = normalize_pkg_data($data);
my $text = '';
my $basename = base_pkg_name($workdata->{name});
# First put in the standard fields, in the standard order.
# Delete them as we go (and their aliases also). That way,
# everything that remains (except desc and files) is an extra
# field to be printed in the second phase.
foreach $key (@stdpkgfields) {
# (don't need to decide whether to print a 'standard' key or
# its alias for two reasons:
# 1. normalize_pkg_data() has made certain that for every
# standard or alias key, its partner is also present
# 2. their contents should be identical, and if they
# aren't, it isn't my problem :-)
if (exists $workdata->{$key}) {
$text .= "$key: $workdata->{$key}\n";
delete $workdata->{$key};
}
delete $workdata->{$aliasfields{$key}}
if exists $workdata->{$aliasfields{$key}};
}
# Secondly print out all remaining fields except desc and files.
# These are the unknown fields.
foreach $key (keys %$workdata) {
next if $key =~ /^(?:PACKAGE DESCRIPTION|FILE LIST|desc|files)$/;
$text .= "$key: $workdata->{$key}\n";
}
# Thirdly deal with the description and file list.
# This line seems to be present (in log files created by installpkg)
# whether the description itself is or not, so I will include it
# to be safe and not sorry:
$text .= "PACKAGE DESCRIPTION:\n";
if (exists $workdata->{desc}) {
foreach (@{$workdata->{desc}}) {
$text .= "$basename: $_\n";
}
}
$text .= "FILE LIST:\n";
if (exists $workdata->{files}) {
foreach (@{$workdata->{files}}) {
$text .= "$_\n";
}
}
$text;
}
sub read_pkg_desc {
my $filename = shift;
my ($line, $name, $text);
my $data = {};
open F, $filename or choke("Can't read $filename: $!");
while (defined ($line = <F>)) {
if ($name) {
if ($line =~ /^\Q$name\E:(.*)/) {
$text = $1;
$text =~ s/^\s//;
push @{$data->{desc}}, $text;
}
} elsif ($line =~ /^([^#\s|][^:]*):(.*)/) {
$name = $1;
$text = $2;
$text =~ s/^\s//;
$data->{desc} = [$text];
$data->{name} = $name;
}
}
close F;
$data;
}
#===========================================================================#
# END PKGPARSE IMPORT #
#===========================================================================#
syntax highlighted by Code2HTML, v. 0.9.1