#!/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($en