#!/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