#!/bin/sh

##############################################################################
#                                                                            #
# This entire file is toast, a program for installing and managing software. #
# Copyright (C) 2003-2005 Jacques Frechet.                                   #
# Note that this file contains Version 2 of the GNU General Public License,  #
# which includes its own copyright notice.                                   #
#                                                                            #
# For more information on toast, including purpose, usage, licensing, and    #
# LACK OF ANY WARRANTY, visit http://www.toastball.net/toast/, run "toast"   #
# without arguments, or refer to the documentation at the end of this file.  #
#                                                                            #
##############################################################################

exec perl -x $0 ${1+"$@"}
echo "Can't find perl in PATH; aborting." >&2
exit 1

##############################################################################

#!perl
&the_correct_line_number_for_this_line_is(23); # perl thinks this is line 2...

use 5; # oldest version that actually works might be 5.003; not sure....

# allow script to run even in the absence of strict.pm, etc.
BEGIN { $^W = 1 } # use warnings
BEGIN { $^H |= 0x602 } # use strict

# warn if "use warnings" and "use strict" are not both in effect
if($^V && %SIG) # test requires perl 5.6.0 with working %SIG (not microperl)
{
  { my($ok); { local $SIG{'__WARN__'} = sub { die };
      $ok = !eval('1 + "a"') } $ok || warn("use warnings"); }
  { eval('$foo = 1') && warn("use strict"); $@ = undef }
}

##############################################################################

my($rcsid) = q$Id: toast,v 1.432 2005/11/27 07:01:15 zaphod Exp $;
$rcsid =~ /^Id: (.+),v (\S+) (\S+ \S+) (\S+) Exp (\S+ )?$/ || die;
my($myname, $myversion, $mytimestamp, $myauthor) = ($1, $2, $3, $4);
$myversion .= "+" if $5; # if this version may contain changes not in RCS
my($myurl) = "http://www.toastball.net/toast/";
my($mycopyright) = "Copyright (C) 2003-2005 Jacques Frechet";
my($genby) = "generated by $myname version $myversion [$myurl]";
$myname eq "toast" && $myauthor eq "zaphod" || die; # avoid accidents w/ CVS

##############################################################################

BEGIN
{
  my($linedelta, $filedelta);

  sub the_correct_line_number_for_this_line_is($)
  {
    my($realline) = @_;
    my($package, $file, $line) = caller(0);
    $linedelta = $realline - $line;
    $filedelta = $file;
  }

  sub trace(;$)
  {
    my($i, $out, $prev) = (shift || 1, "", "");
    while(my($package, $file, $line) = caller($i++))
    {
      $line += $linedelta if defined($linedelta) && $file eq $filedelta;
      $out .= ($prev eq $file ? "/" : $out ? "; $file: " : "$file: ") . $line;
      $prev = $file;
    }
    $out .= " (from #!perl line)" unless defined($linedelta);
    $out .= " v$myversion";
    return $out;
  }
}

sub msg($@)
{
  my($default) = shift;
  my($msg) = join('', @_) || $default;
  $msg =~ s/\n+$//;
  return $msg . "\n[" . trace(2) . "]\n";
}

sub error(@)
{
  die(msg("assertion failed", @_));
}

sub warning(@)
{
  warn(msg("warning", @_));
}

##############################################################################

sub true() { 1 }
sub false() { "" }

sub scalify(@) { return @_ if wantarray; error if scalar(@_) > 1; $_[0] }
sub emptytoundef(@) { scalify(map(defined($_) && $_ eq "" ? undef : $_, @_)) }
sub undeftoempty(@) { scalify(map(defined($_) ? $_ : "", @_)) }
sub firstdef(@) { return $_ foreach grep(defined($_), @_); undef; }

sub samelist(\@\@)
{
  my($x, $y) = @_;
  my($size) = scalar(@$x);
  return false if $size != scalar(@$y);
  return true unless $size > 0;
  for(0..$size-1)
  {
    my($vx, $vy) = ($$x[$_], $$y[$_]);
    my($dx, $dy) = map { defined($_) ? 1 : 0 } ($vx, $vy);
    return false if $dx != $dy || $dx & $vx ne $vy;
  }
  return true;
}

##############################################################################

sub max(@)
{
  my($result);
  for(@_)
  {
    $result = $_ if !defined($result) || $result < $_;
  }
  $result;
}

sub min(@)
{
  my($result);
  for(@_)
  {
    $result = $_ if !defined($result) || $result > $_;
  }
  $result;
}

sub uniq(@)
{
  my(@list) = @_;
  my(@result, %seen);
  for(@list)
  {
    next if $seen{$_};
    $seen{$_} = true;
    push(@result, $_);
  }
  return @result;
}

##############################################################################

sub dirname($) { my($arg) = @_; $arg =~ s|/[^/]*$|| ? $arg : "."; }
sub basename($) { my($arg) = @_; $arg =~ s|.*/||g; $arg; }
sub stripext($) { my($a)=@_;$a=~s/(\.(t|sh)ar(\.g?z)?)?(\.[a-z]\w*)?$//i;$a }
sub stripquery($) { my($arg) = @_; $arg =~ s/\?.*$//; $arg; }

sub path(@)
{
  my(@args) = @_;
  @args || error("empty path");
  defined($_) || error("undefined path component in @args") for @args;
  $args[0] = "" if $args[0] eq "/";
  my($ret) = join("/", @args);
  $ret =~ m|//| && error("double slash in path(@args): $ret");
  $ret =~ m|/$| && error("final slash in path(@args): $ret");
  return $ret;
}

sub laxpath(@)
{
  my(@args) = @_;
  defined($_) || error("undefined path component in @args") for @args;
  length($_) || error("empty path component in @args") for @args;
  my($ret) = join("/", @args);
  $ret =~ s|/+|/|g;
  $ret =~ s|/$||;
  return $ret;
}

sub optpath(@)
{
  path(grep { defined($_) && $_ ne "" } @_);
}

sub unpath($)
{
  my($path) = @_;
  $path =~ s|^/|| || error;
  $path =~ m|^/| && error;
  $path =~ m|/$| && error;
  $path =~ m|//| && error;
  return split(/\//, $path);
}

##############################################################################

sub checkedeval($)
{
  my($code) = @_;
  my($result) = eval($code);
  if($@)
  {
    local($_) = $code;
    s/\s+/ /g;
    error($@, $_);
  }
  $result;
}

##############################################################################

sub safeopen(*$$)
{
  local(*HANDLE) = shift;
  my($mode, $file) = @_;
  my($escaped) = "$file\x00";
  $escaped = "./$escaped" unless $escaped =~ m!^/!;
  open(HANDLE, "$mode$escaped") || error("open $file: $!");
  binmode(HANDLE) || error("binmode $file: $!"); # perl 5.8.0 utf8 bug
}

sub whilefile(&$)
{
  my($sub, $file) = @_;
  local(*FILE, $_);
  safeopen(*FILE, "<", $file);
  while(defined($_ = <FILE>) && &$sub($_)) { }
  close(FILE) || error("close $file for read: $!");
  !defined($_);
}

sub readfile($)
{
  my($file) = @_;
  my(@result);
  whilefile { push(@result, $_) } $file;
  @result;
}

##############################################################################

BEGIN
{
  my($uid, $euid) = ($<, $>);

  sub superuser()
  {
    $uid == 0 || $euid == 0;
  }
}

##############################################################################

BEGIN
{
  my(%optdefault) =
  (
    "storedir" =>
        (superuser || !$ENV{HOME}) ? "/toast" : "$ENV{HOME}/.toast",
    "armdir" => superuser ? "/usr/local" : "armed",
    "altarmdirs" => "",
    "username" => "toast",
    "fallbackuid" => 23,
    "nice" => 10,
    "postarmprog" => superuser ? "/sbin/ldconfig" : "",
    "editprog" => "",
    "defaultcmd" => "help",
    "stickyopts" => "reconfigure confappend makeappend",
    "findsites" => "all",
    "httpproxy" => exists($ENV{http_proxy}) ? $ENV{http_proxy} : "",
    "ftpproxy" => exists($ENV{ftp_proxy}) ? $ENV{ftp_proxy} : "",
    "confappend" => "",
    "makeappend" => "",
    "quiet" => "false",
    "expand" => "true",
    "autofind" => "true",
    "autochange" => "false",
    "autorename" => "true",
    "autoenv" => "true",
    "autoclean" => "true",
    "autopurge" => "false",
    "autoarm" => "true",
    "autodisarm" => "true",
    "autodemolish" => "true",
    "autoremove" => "false",
    "crossversion" => "false",
    "skipmismatched" => "true",
    "ccache" => "true",
    "preload" => "true",
    "strictpreload" => $^O eq "linux" ? "true" : "false",
    "useflock" => $^O =~ /win/i ? "false" : "true",
    "reconfigure" => "true",
    "fixliblinks" => "true",
    "interactive" => "false",
    "stoponerror" => "true",
    "ignorecase" => "true",
    "showurls" => "true",
    "showopts" => "true",
    "infodir" => "true",
    "xmlcatalog" => "true",
    "hspkg" => "false",
    "protect" => "false",
    "relative" => "false",
    "debugrewrite" => "false",
  );

  sub envopt($)
  {
    $ENV{uc("${myname}_$_[0]")};
  }

  my(%optloaded);

  sub istrue($)
  {
    my($val) = @_;
    return $val && $val =~ /^(1|true|on|yes|enabled)$/i;
  }

  sub isboolean($)
  {
    my($val) = @_;
    return !$val || istrue($val) || $val =~ /^(false|off|no|disabled)$/i;
  }

  sub isopt($)
  {
    my($name) = @_;
    return exists($optdefault{$name});
  }

  sub isboolopt($)
  {
    my($name) = @_;
    return false unless isopt($name);
    my($def) = $optdefault{$name};
    return defined($def) && ($def eq "true" || $def eq "false");
  }

  sub checkoptname($)
  {
    my($name) = @_;
    isopt($name) || error("no such option: $name");
  }

  my(%cmdlineopt);

  sub unloadopts(;$;$)
  {
    my($n, $v) = @_;
    my($key) = undeftoempty($n) . "/" . undeftoempty($v);
    delete $optloaded{$key};
  }

  sub loadopts(;$;$)
  {
    my($n, $v) = @_;
    my($key) = undeftoempty($n) . "/" . undeftoempty($v);
    return $optloaded{$key} if exists($optloaded{$key});
    my($opts) = $optloaded{$key} = {};
    my(@list);
    push(@list, laxpath($ENV{HOME}, qw[.toast conf]))
        if exists($ENV{HOME}) && length($ENV{HOME});
    push(@list, qw[/toast/conf /etc/toast.conf /usr/local/etc/toast.conf]);
    @list = path(pkgpath($n, $v), "conf") if defined($n);
    for(@list)
    {
      my($dotfile) = $_;
      if(-e($dotfile))
      {
        whilefile
        {
          s/^\s+//;
          s/\s+$//;
          return true if $_ eq "" || /^\#/;
          /^([^\=]*?)\s*\=\s*(.*)$/ ||
              error("$dotfile: line $.: missing \"=\"");
          my($name, $val) = ($1, $2);
          isopt($name) ||
              error("$dotfile: line $.: unknown option name \"$name\"");
          !isboolopt($name) || isboolean($val) ||
              error("$dotfile: line $.: illegal boolean value: \"$val\"");
          $opts->{$name} = $val;
          true;
        } $dotfile;
        last unless defined($n);
      }

      next unless defined($n);
      next if (defined($v) ? 1 : 0) eq (&crossversion ? 1 : 0);

      my($changed);
      for(map($_ ne "all" ? $_ : grep($_ ne "stickyopts", keys(%cmdlineopt)),
          map(lc, split(/\W+/, getopt("stickyopts")))))
      {
        my($new) = $cmdlineopt{$_};
        next unless defined($new);
        my($old) = $opts->{$_};
        if($new eq getglobalopt($_))
        {
          next unless defined($old);
          delete($opts->{$_});
          $changed = true;
        }
        elsif(!defined($old) || $new ne $old)
        {
          $new =~ s/\n/ /g;
          $opts->{$_} = $new;
          $changed = true;
        }
      }
      if($changed)
      {
        my(@lines);
        for(sort(keys(%{$opts})))
        {
          my($value) = $opts->{$_};
          next unless defined($value);
          push(@lines,
              "$_=" . (!isboolopt($_) ? $value : $value ? "1" : "0") . "\n");
        }
        writefile($dotfile, @lines) if @lines;
        rm($dotfile) unless @lines;
      }

    }
    return $opts;
  }

  sub parseopt($$)
  {
    my($name, $val) = @_;
    checkoptname($name);
    if(isboolopt($name))
    {
      error("$name is a boolean option") unless isboolean($val);
      $val = istrue($val);
    }
    else
    {
      error("option $name is undefined") unless defined($val);
      if($name =~ /dir$/ && $val !~ m|^/|)
      {
        error("relative path not allowed for storedir: $val")
            if $name eq "storedir";
        $val = path(&storedir, $val);
      }
    }
    return $val;
  }

  sub setopt($$)
  {
    my($name, $val) = @_;
    $cmdlineopt{$name} = parseopt($name, $val);
  }

  sub getglobalopt($)
  {
    my($name) = @_;
    error unless isopt($name);
    return firstdef(envopt($name), loadopts()->{$name}, $optdefault{$name});
  }

  my($an, $av);

  sub setactivepkg(;$;$)
  {
    unloadopts($an, $av) if defined($an);
    ($an, $av) = @_;
    unloadopts($an, $av) if defined($an);
    loadopts($an, $av) if defined($an);
  }

  sub getopt($)
  {
    my($name) = @_;
    error unless isopt($name);
    my($nvopts, $nopts);
    $nvopts = loadopts($an, $av) if defined($av);
    $nopts = loadopts($an) if defined($an);
    return parseopt($name, firstdef($cmdlineopt{$name},
        $nvopts->{$name}, $nopts->{$name}, getglobalopt($name)));
  }

  checkedeval("sub $_() { getopt('$_') }") foreach keys(%optdefault);
}

sub cmd_getopt(@)
{
  my($name) = shift;
  error("option name required") unless defined($name);
  error("invalid option name: $name") unless isopt($name);
  my(@pkgs) = parse(@_);
  error("only one package allowed") if scalar(@pkgs) > 1;
  setactivepkg();
  for(@pkgs)
  {
    my($n, $v) = @$_;
    setactivepkg($n, $v);
  }
  my($result);
  eval { $result = getopt($name) };
  my($err) = $@;
  setactivepkg();
  die($err) if $err;
  $result = ($result ? "true" : "false") if isboolopt($name);
  error unless defined($result);
  print("$result\n");
}

##############################################################################

sub pkgdir() { "pkg" }
sub archivedir() { "archive" }
sub editdir() { "edit" }
sub urlfile() { "url" }
sub armdirlink() { "armdir" }
sub srcdir() { "src" }
sub helperdir() { "helpers" }
sub rootdir() { "root" }
sub buildlog() { "build.log" }
sub brokenlog() { "broken.log" }
sub offsuffix() { ".off" }
sub tmpsuffix() { ".tmp" }
sub baksuffix() { ".orig" }

##############################################################################

BEGIN
{
  my($verbosified) = false;
  sub verbosify() { $verbosified = true }
  sub say(@) { print(@_) if $verbosified || !quiet }
}

sub explain(@) { say("# @_\n"); }
sub announce(@) { say("@_\n"); }

##############################################################################

sub unbuffer(*)
{
  local(*HANDLE) = shift;
  my($save) = select(HANDLE) || error;
  $| = 1;
  select($save) || error;
}

##############################################################################

sub whiledir(&$)
{
  my($sub, $dir) = @_;
  local(*DIR);
  opendir(DIR, $dir) || error("opendir $dir: $!");
  my(@list) = sort(grep($_ ne "." && $_ ne "..", readdir(DIR)));
  closedir(DIR);
  my($result) = true;
  for(@list)
  {
    last unless $result = &$sub($_);
  }
  return !!$result;
}

sub fordir(&@)
{
  my($sub, $dir) = @_;
  my($result) = true;
  whiledir { &$sub(@_) || !($result = false) } $dir;
  $result;
}

sub abswhiledir(&$)
{
  my($sub, $dir) = @_;
  whiledir { &$sub($_ = path($dir, $_)) } $dir;
}

sub ls($)
{
  my($dir) = @_;
  my(@result);
  whiledir { push(@result, $_) } $dir;
  @result;
}

sub optls($)
{
  my($dir) = @_;
  return -e($dir) ? ls($dir) : ();
}

sub absls($)
{
  my($dir) = @_;
  map { path($dir, $_) } ls($dir);
}

sub dfs($&&&)
{
  my($base, $predir, $file, $postdir, $rel) = @_;
  defined($rel) || -e($base) || -l($base) || error("not found: $base");
  local($_) = optpath($base, $rel);
  (-l || !-d) ? &$file($rel) :
      &$predir($rel) &&
      (whiledir {&dfs($base, $predir, $file, $postdir, optpath($rel, $_))} $_)
      && &$postdir($rel);
}

##############################################################################

sub md(@)
{
  announce("mkdir", @_);
  mkdir($_, 0777) || error("mkdir $_: $!") foreach @_;
  true;
}

sub optmd(@)
{
  foreach(@_)
  {
    next if -d;
    announce("mkdir", $_);
    if(!mkdir($_, 0777))
    {
      my($err) = $!;
      -d || error("mkdir $_: $err");
    }
  }
  true;
}

##############################################################################

sub mv($$)
{
  my($source, $dest) = @_;
  announce("mv", $source, $dest);
  rename($source, $dest) || error("mv $source $dest: $!");
}

sub ln($$)
{
  my($source, $target) = @_;
  announce("ln", "-s", $source, $target);
  symlink($source, $target) || error("ln -s $source $target: $!");
}

sub relln($$)
{
  my($src, $target) = @_;
  ln($src =~ m|^/| ? findrelpath(dirname($target), $src) : $src, $target);
}

sub optrelln($$)
{
  my($source, $target) = @_;
  relln($source, $target) unless -e($target) || -l($target);
}

##############################################################################

sub safestat($)
{
  my($file) = @_;
  my(@result) = stat($file);
  @result || error("stat $file: $!");
  @result;
}

sub getmode($) { (safestat($_[0]))[2] & 07777 }

sub chmodimpl($$@)
{
  my($mode, $announce, @files) = @_;
  $mode &= 01777 & ~umask;
  my($txtmode) = sprintf("%lo", $mode);
  @files = grep { getmode($_) != $mode } @files;
  announce("chmod", $txtmode, @files) if @files && $announce;
  chmod($mode, $_) || error("chmod $txtmode $_: $!") for @files;
  true;
}

sub safechmod($@)
{
  my($mode, @files) = @_;
  chmodimpl($mode, true, @files);
}

sub silentchmod($@)
{
  my($mode, @files) = @_;
  chmodimpl($mode, false, @files);
}

sub writefilemode($$@)
{
  my($name, $mode, @contents) = @_;
  local(*FILE);
  explain("creating $name");
  safeopen(*FILE, ">", $name) || error("open $name for write: $!");
  print FILE @contents;
  close(FILE) || error("close $name for write: $!");
  safechmod($mode, $name) if $mode;
}

sub writefile($@)
{
  my($name, @contents) = @_;
  writefilemode($name, false, @contents);
}

sub writescript($@)
{
  my($name, @contents) = @_;
  writefilemode($name, 0777, @contents);
}

sub samefile($$)
{
  my($a, $b) = @_;
  my($da, $ia) = safestat($a);
  my($db, $ib) = safestat($b);
  $da eq $db && $ia eq $ib;
}

sub optsamefile($$)
{
  my($a, $b) = @_;
  my($da, $ia) = stat($a);
  return false unless defined($da);
  my($db, $ib) = stat($b);
  defined($db) && $da eq $db && $ia eq $ib;
}

sub patch(&$)
{
  my($sub, $file) = @_;
  my(@contents) = readfile($file);
  my($patched) = false;

  local($_);
  for(@contents)
  {
    my($old) = $_;
    &$sub($_);
    $patched ||= $old ne $_;
  }

  if($patched)
  {
    my($mode) = getmode($file);
    mv($file, addbak($file));
    writefilemode($file, $mode, @contents);
  }

  return $patched;
}

sub optpatch(&$)
{
  my($sub, $file) = @_;
  return -e($file) ? &patch($sub, $file) : false;
}

##############################################################################

sub silentrm(@)
{
  unlink || error("rm $_: $!") for @_;
  true;
}

sub rm(@)
{
  announce("rm", "-f", @_) if @_;
  silentrm(@_);
}

sub silentrd(@)
{
  rmdir || error("rmdir $_: $!") for @_;
  true;
}

sub rd(@)
{
  announce("rmdir", @_) if @_;
  silentrd(@_);
}

sub rmall(@)
{
  announce("rm", "-rf", @_) if @_;
  dfs
  (
    $_,
    sub { -w($_) ? true : silentchmod(0777, $_) },
    sub { silentrm($_) },
    sub { silentrd($_) }
  ) for @_;
  true;
}

sub optrmall(@) { rmall(grep(-e || -l, @_)) }

##############################################################################

sub benice()
{
  my($inc) = nice;
  return $inc eq "0" unless $inc =~ /^-?[1-9][0-9]*$/;
  eval { setpriority(0, 0, min(getpriority(0, 0) + $inc, 20)) };
}

sub safeexec(@)
{
  my(@prog) = @_;
  {
    local($^W) = false; # suppress misguided exec failure warning
    exec(@prog);
  }
  error("exec @prog: $!");
}

sub runimpl(@)
{
  my(@prog) = @_;
  announce(@prog);
  my($result);
  {
    local($^W) = false; # suppress misguided exec failure warning
    $result = system(@prog);
  }
  return "exec @prog: $!" unless defined($result) && $result != -1;
  my($code) = ($? >> 8) & 0xff;
  my($sig) = $? & 0xff;
  return "@prog failed (code $code, signal $sig)" if $?;
  return undef;
}

sub run(@)
{
  my($msg) = runimpl(@_);
  error($msg) if defined($msg);
  return true;
}

sub optrun(@)
{
  my($msg) = runimpl(@_);
  explain("warning: $msg; continuing") if defined($msg);
  return !defined($msg);
}

sub optcdrunimpl($$@)
{
  my($asroot, $dir, @prog) = @_;
  announce("(cd $dir; @prog)");
  my($pid);
  if($pid = fork) # parent
  {
    waitpid($pid, 0);
    return !$?;
  }
  else # child
  {
    defined($pid) || error("fork: $!");
    dropprivs() unless $asroot;
    silentcd($dir);
    safeexec(@prog);
  }
}

sub optcdrun($@)
{
  my($dir, @prog) = @_;
  optcdrunimpl(true, $dir, @prog);
}

sub cdrun($@)
{
  my($dir, @prog) = @_;
  optcdrun($dir, @prog) || error("@prog returned $?");
}

sub cdrunnonroot($@)
{
  my($dir, @prog) = @_;
  optcdrunimpl(false, $dir, @prog) || error("@prog returned $?");
}

sub shellescape(@)
{
  my(@words) = @_;
  for(@words)
  {
    error unless defined($_);
    next unless m![^\w\+,\./:\@-]!;
    /'/ ? s!([^\w\+,\./:\@-])!\\$1!g : ($_ = "'$_'");
  }
  return join(" ", @words);
}

sub openprog(*$@)
{
  local(*HANDLE) = shift;
  my($prog, @args) = @_;
  announce($prog, @args);
  @args = shellescape(@args);
  {
    local($^W) = false; # suppress misguided exec failure warning
    if(!open(HANDLE, "$prog @args |"))
    {
      explain("failed to exec $prog: $!");
      return false;
    }
  }
  binmode(HANDLE) || error("binmode: $!"); # perl 5.8.0 utf8 bug
}

##############################################################################

sub urlunescape($)
{
  local($_) = @_;
  s/\%([0-9a-f]{2})/chr(hex($1))/gei;
  $_;
}

sub tcpconnect(*$$;$)
{
  local(*HANDLE) = shift;
  my($host, $port, $ip) = @_;
  $ip = gethostbyname($host) || error("gethostbyname $host: $!")
      unless defined($ip);
  socket(HANDLE, 2, 1, 0) || error("$!");
  binmode(HANDLE) || error("binmode: $!"); # perl 5.8.0 utf8 bug
  connect(HANDLE, pack("Sna4x8", 2, $port, $ip)) ||
      error("connect $host:$port: $!");
  unbuffer(HANDLE);
  return $ip;
}

sub openhttp(*$;$;$)
{
  local(*HANDLE) = shift;
  my($url, $method, $proxy) = @_;
  $method ||= "GET";
  $proxy = httpproxy unless defined($proxy);
  explain("fetching $url");
  $url =~ m!^(\w+)://([-\w\.]+)(:(\d+))?(/[\!-\~]*)?$! ||
      error("bad url: $url");
  my($proto, $host, $port, $path) = ($1, $2, $4 || 80, $5 || '/');
  my($hdrhost) = $port == 80 ? $host : "$host:$port";
  if($proxy)
  {
    $path = "$proto://$host:$port$path";
    $proxy =~ m!^(\w+://)?([-\w\.]+)(:(\d+))?/?$!
        || error("bad proxy URL: $proxy");
    ($host, $port) = ($2, $4 || 8080);
  }
  my($uagent) = "$myname/$myversion ($^O; $myurl)";
  my($request) = "$method $path HTTP/1.0\r\nHost: $hdrhost\r\n".
      "User-Agent: $uagent\r\nAccept: */*\r\n\r\n";
  tcpconnect(*HANDLE, $host, $port);
  print HANDLE $request || error("write to $host:$port: $!");
}

sub httphead($)
{
  my($url) = @_;
  local(*HANDLE);
  openhttp(*HANDLE, $url, "HEAD");
  my($result) = join('', <HANDLE>);
  close(HANDLE) || error;
  return $result;
}

sub openhttpurl(*$;$)
{
  local(*HANDLE) = shift;
  my($url, $proxy) = @_;
  for(1..5)
  {
    openhttp(*HANDLE, $url, undef, $proxy);
    local($_);
    $_ = <HANDLE>;
    s/\r?\n?$//;
    m|^HTTP/[\w\.]+ [23]0[01237] | || error("$url: $_");
    my($redirect);
    while(<HANDLE>)
    {
      $redirect = $1 if /^location:\s*(\S+)/i;
      last if /^\r?\n?$/;
    }
    return $url unless $redirect;
    ($url) = linksfromstring("<a href=$redirect>", $url); # *wince*
  }
  error("too many HTTP redirects");
}

sub ftpcmd(*$;$)
{
  local(*CTRL, $_) = shift;
  my($cmd, $expected) = @_;
  print CTRL "$cmd\r\n" || error("error sending ftp command: $!") if $cmd;
  while(<CTRL>)
  {
    s/[\r\n]+$//;
    if(/^(\d{3}) /)
    {
      my($response) = $1;
      error("ftp server: $_") if defined($expected) && $response != $expected;
      return $_;
    }
  }
  error("lost ftp control connection") unless $cmd =~ /QUIT/;
}

sub openftpurl(*$)
{
  local(*HANDLE) = shift;
  my($url) = @_;
  return openhttpurl(*HANDLE, $url, ftpproxy) if ftpproxy;

  explain("fetching $url");
  $url =~ m!^(\w+)://([-\w\.]+)(:(\d+))?(/[\!-\~]*)?$!
      || error("bad url: $url");
  my($proto, $host, $port, $path) = ($1, $2, $4 || 21, $5 || '/');
  error("don't know how to fetch FTP directory listings") if $path =~ m!/$!;

  local(*CTRL, *DATA);
  my($ip) = tcpconnect(*CTRL, $host, $port);
  ftpcmd(*CTRL, undef, 220);
  ftpcmd(*CTRL, "USER anonymous", 230);
  ftpcmd(*CTRL, "TYPE I");
  my($size) = ftpcmd(*CTRL, "SIZE $path", 213);
  $size =~ /^\d+\s+(\d+)/ or die("bad SIZE response: $size");
  $size = $1;
  my($pasv) = ftpcmd(*CTRL, "PASV", 227);
  $pasv =~ /(\d+)\s*,\s*(\d+)\s*\)/ || error("bad PASV response: $pasv");
  my($dataport) = $1*256 + $2;
  tcpconnect(*DATA, $host, $dataport, $ip);
  my($retr) = ftpcmd(*CTRL, "RETR $path");
  $retr =~ /^(\d+) / && $1 <= 150 || error("ftp RETR error: $retr");
  my($pid) = open(HANDLE, "-|");
  error("fork: $!") unless defined($pid);
  if($pid)
  {
    close(CTRL) || error("close ftp control: $!");
    close(DATA) || error("close ftp data: $!");
    return true;
  }

  binmode(STDOUT) || error("binmode stdout: $!"); # perl 5.8.0 utf8 bug
  my($buf) = 0;
  while(sysread(DATA, $buf = "", min(8192, $size), 0))
  {
    print($buf) || error("write stdout: $!");
    $size -= length($buf);
  }
  error("lost ftp data connection") if $size;
  close(DATA) || error("close ftp data: $!");
  ftpcmd(*CTRL, undef, 226);
  ftpcmd(*CTRL, "QUIT");
  exit(0);
  error;
}

sub openfileurl(*$)
{
  local(*HANDLE) = shift;
  my($url) = @_;
  $url =~ m!^file://([^/]+)(/.*)$! || error("bad url: $url");
  my($host, $path) = ($1, $2);
  $host eq "localhost" || error("bad file-url hostname: $host");
  my($source) = urlunescape($path);
  explain("reading $source");
  safeopen(*HANDLE, "<", $source);
}

sub opensshurl(*$)
{
  local(*HANDLE) = shift;
  my($url) = @_;
  $url =~ m!^ssh://([^/]+)(/.*)$! || error("bad url: $url");
  my($userhost, $path) = ($1, $2);
  $userhost = urlunecape($userhost);
  $path = urlunescape($path);
  $userhost =~ /^\-/ && error("bad url: $url");
  $path =~ /^\-/ && error("bad url: $url");
  openprog(*HANDLE, "ssh", $userhost, "cat", $path);
}

sub openurl(*$)
{
  local(*HANDLE) = shift;
  my($url) = @_;
  $url =~ /^(\w+):/ || error("bad url: $url");
  my($proto) = lc($1);

  local($ENV{http_proxy}) = httpproxy if httpproxy;
  local($ENV{ftp_proxy}) = ftpproxy if ftpproxy;

  return openhttpurl(*HANDLE, $url) if $proto eq "http";

  $proto eq "file" && openfileurl(*HANDLE, $url) ||
  $proto eq "ssh" && opensshurl (*HANDLE, $url) ||
  openprog(*HANDLE, "wget", "-O-", $url) ||
  openprog(*HANDLE, "GET", $url) ||
  $proto eq "ftp" && openftpurl(*HANDLE, $url) ||
  error("unable to download: $url");

  return $url;
}

sub geturl($$)
{
  my($url, $dest) = @_;

  my($newurl);
  eval q{
    use LWP::UserAgent;
    $newurl = false;
    explain("fetching $url to $dest");
    my($ua) = LWP::UserAgent->new;
    $ua->proxy(["http", "https"], httpproxy) if httpproxy;
    $ua->proxy("ftp", ftpproxy) if ftpproxy;
    my($r) = $ua->get($url, ":content_file" => $dest);
    my($msg) = $r->message;
    die("unable to fetch $url: $msg\n") if $r->is_error;
    $newurl = $r->base;
  } if $url !~ /^(file|ssh)/;
  error($@) if $@ && defined($newurl);
  return $newurl if $newurl;
  
  if(defined($newurl))
  {
    error($@) unless $newurl;
    return $newurl;
  }

  local(*SOURCE, *DEST);
  explain("creating $dest");
  safeopen(*DEST, ">", $dest);
  $newurl = openurl(*SOURCE, $url);

  my($buf, $result);
  my(@dstat) = stat(DEST);
  my($bufsize) = $dstat[11] || 4096;
  while($result = read(SOURCE, $buf, $bufsize))
  {
    (print DEST $buf) || error("write to $dest: $!");
  }
  defined($result) || error("read from $url: $!");

  close(DEST) || error("close $dest for write: $!");
  close(SOURCE) || error("close $url for read: $!");
  return $newurl;
}

sub linksfromstring($$)
{
  my($html, $url) = @_;
  $url =~ m!^((\w+:)//[^/]+)([^\?\#]*/)?! || error("bad url: $url");
  my($proto, $host, $parent) = ($2, $1, $3);
  $parent = defined($parent) && $parent ne "" ? "$host$parent" : "$host/";
  my(@links);
  while($html =~ m!\b(href\s*\=\s*\"?|((http|ftp)://))([^\s\>\"]+)!ig)
  {
    my($link) = join("", undeftoempty($2, $4));
    next if $link =~ /^mailto:/i;
    $link = $proto . $link if $link =~ m!^//!;
    $link = $host . $link if $link =~ m!^/!;
    $link = $parent . $link unless $link =~ m!^(\w+)://!;
    $link =~ s/\&amp;/\&/g;
    push(@links, cleanurl($link));
  }
  return @links;
}

sub linksfromstream(*$)
{
  local(*HANDLE, $_) = shift;
  my($url) = @_;
  my(@links);
  while(<HANDLE>)
  {
    push(@links, linksfromstring($_, $url));
  }
  return uniq(@links);
}

sub linksfromurl($)
{
  my($url) = @_;
  return map("file://localhost$_", absls($1)) if $url =~ m!^file://\w+(/.*)/$!;
  local(*HANDLE);
  my($newurl) = openurl(*HANDLE, $url);
  my(@links) = linksfromstream(*HANDLE, $newurl);
  close(HANDLE) || error("unable to fetch $url");
  return @links;
}

##############################################################################

{
  my($pwd);

  sub pwd()
  {
    return $pwd if defined($pwd);

    my($env) = $ENV{PWD};
    return $pwd = $env if defined($env) && -d($env) && samefile($env, ".");

    my($dir, $result) = (".", "");
    for(1..1024)
    {
      my($parent) = path($dir, "..");
      my($dd, $id) = safestat($dir);
      my($dp, $ip) = safestat($parent);
      return $pwd = "/$result" if $dd eq $dp && $id eq $ip;
      error("can't find working directory") if whiledir
      {
        my($d, $i) = safestat(path($parent, $_));
        my($same) = $d eq $dd && $i eq $id;
        $result = optpath($_, $result) if $same;
        !$same;
      } $parent;
      $dir = $parent;
    }
    error("level>1024 in pwd");
  }

  sub silentcd($)
  {
    my($dir) = @_;
    $ENV{PWD} = $pwd = abspath($dir);
    chdir($dir) || error("chdir $dir: $!");
    return true;
  }
}

sub abspath($)
{
  my($path) = @_;
  return $path if $path =~ m!^/!;
  $path =~ s!^./!!;
  $path =~ s!/./!/!g;
  return path(pwd, $path);
}

sub findrelpath($$)
{
  my($from, $to) = @_;
  
  # allow last component of $to to be missing or not a directory
  my(@append);
  if(!-d($to)) 
  {
    push(@append, basename($to));
    $to = dirname($to);
  }

  # walk from $to all the way to /, leaving a trail of bread crumbs
  my($dir, $lastdi, @names, %ditonameidx) = ($to, "");
  for(1..1024)
  {
    my($d, $i) = safestat($dir);
    my($di) = "$d $i";
    $ditonameidx{$di} = $#names unless exists($ditonameidx{$di});
    last if $dir eq "/";
    $dir = path($dir, "..");
    last if whiledir # figure out how to get down one level from here
    {
      my($pd, $pi) = stat(path($dir, $_));
      return true unless defined($pd) && "$pd $pi" eq $di;
      push(@names, $_);
      return false;
    } $dir;
    last if $di eq $lastdi;
    $lastdi = $di;
  }

  # walk up from $from towards / looking for bread crumbs
  ($dir, $lastdi) = ($from, "");
  my(@result);
  for(1..1024)
  {
    my($d, $i) = safestat($dir);
    my($di) = "$d $i";
    last if $di eq $lastdi;
    $lastdi = $di;
    if(exists($ditonameidx{$di}))
    {
      my($nameidx) = $ditonameidx{$di};
      push(@result, reverse(@names[0..$nameidx]));
      push(@result, @append);
      return scalar(@result) == 0 ? "." : path(@result);
    }
    $dir = path($dir, "..");
    push(@result, "..");
  }

  error("no relative path from $from to $to");
}

##############################################################################

sub validname($)
{
  my($name) = @_;
  defined($name) && $name =~
      /^[\w\x80-\xff][\w_ -\)\+-\-\x80-\xff]*[\w\x80-\xff]/;
}

sub validversion($)
{
  my($version) = @_;
  defined($version) && $version =~
      /^[\w\x80-\xff]([\w_ -\)\+-\-\x80-\xff\.]*[\w\x80-\xff])?/;
}

sub validbuild($)
{
  my($build) = @_;
  defined($build) && /[1-9][0-9]*/;
}

##############################################################################

sub pkgpath(;$$$)
{
  my($name, $version, $build) = @_;
  !defined($build) || ($build =~ /^[1-9]\d*$/) || error("bad build: $build");
  optpath(storedir, pkgdir, $name, defined($version) && "v$version", $build);
}

sub addoff($)
{
  my($path) = @_;
  error if offsuffix eq "";
  return $path . offsuffix;
}

sub addtmp($)
{
  my($path) = @_;
  error if tmpsuffix eq "";
  return $path . tmpsuffix;
}

sub addbak($)
{
  my($path) = @_;
  error if baksuffix eq "";
  return $path . baksuffix;
}

##############################################################################

sub commonlen(@)
{
  my(@sources) = @_;
  my($firstsource) = $sources[0] || error;
  my($i) = 0;
  while(true)
  {
    for(@sources)
    {
      return $i if length == $i ||
          substr($_, $i, 1) ne substr($firstsource, $i, 1);
    }
    $i++;
  }
}

sub reverseall(@)
{
  my(@result);
  push(@result, scalar reverse($_)) foreach @_;
  @result;
}

sub collapse(@)
{
  my(@sources) = @_;
  my($firstsource) = $sources[0];
  return $firstsource if scalar(@sources) == 1;
  my($frontlen) = commonlen(@sources);
  my($backlen) = commonlen(reverseall(@sources));
  my($len) = length($firstsource);
  return $firstsource if $frontlen + $backlen >= $len
      || $frontlen + $backlen == 0;
  substr($firstsource, 0, $frontlen) . substr($firstsource, $len - $backlen);
}

sub sanitize($)
{
  my($word) = @_;
  $word =~ s/\:/_/g;
  $word =~ s/^[\W_]+//;
  $word =~ s/(source|src)$//i; # e.g. mozilla, libjpeg, minicom, XFree86
  $word =~ s/[^a-z0-9\+]+$//i; # allow e.g. gtk+
  $word eq "" ? undef : $word;
}

sub guessnv(@)
{
  my(@urls) = @_;
  s/^(cvs.*)\#(\d+)$/$1-$2/ for @urls;
  my($base) = collapse(map(stripext(basename(stripquery($_))), @urls));
  $base =~ /^([\w]+[\w\-]*[a-z]+)[-_]v?(\d[\w\.\+\-]+)$/i  # Cryptix_src_3-1-1
      || $base =~ /^([a-z][a-z_-]*[a-z])\.(\d[\d\.]+)$/i #device-mapper.1.00.07
      || $base =~ /^(LVM2)\.(2\.\d[\d\.]+)$/               # LVM2.2.00.08
      || $base =~ /^([^-]+)-(.*\d.+)$/                     # iputils-ss020124
      || $base =~ /^(\D+[^a-z])v(\d.*)$/                   # TinyMAZEv2.4a
      || $base =~ /^(\D+)(\d.*)$/                          # fceu019linux
      || $base =~ /^(.*)()$/;                              # Xmerge
  my($name, $version) = ($1, $2);
  $name =~ s/\./_/g; # helps parse() distinguish filenames from pkg names
  $name =~ s/::/-/g; # perl module naming convention
  return (sanitize($name), sanitize($version));
}

##############################################################################

sub padfactor() { 40 }

sub padsingle($)
{
  my($arg) = @_;
  $arg = "" unless defined($arg);
  my($len) = length($arg);
  $len > padfactor ? $arg : (' ' x (padfactor - $len)) . $arg;
}

sub padnum($)
{
  my($arg) = @_;
  my(@post) = $arg =~ s/-?([a-z]+)(\d+)$//i ? ($1, $2) : ("z" x padfactor, 0);
  my(@n) = split(/\./, $arg);
  join(' ', map(padsingle($_), @n[0..max(padfactor, $#n)], @post));
}

sub cmpab()
{
  my($na, $nb) = map
  {
    my($x) = $_;
    $x =~ s/\d+(\.\d+)*(-?(pre|rc|test)\d+)?/padnum($&)/gie;
    $x;
  } ($a, $b);
  my($lca, $lcb) = (lc($na), lc($nb));
  $lca ne $lcb ? $lca cmp $lcb : $na ne $nb ? $na cmp $nb : $a cmp $b;
}

sub lastitem(@)
{
  @_ ? $_[$#_] : undef;
}

sub mkcmdline(@)
{
  join(' ', map { my($a) = $_; $a =~ s/[^\w_\-\.\/]/\\$&/g; $a; } @_);
}

##############################################################################

BEGIN
{
  my($uid, $gid, $usertext);

  sub initnonroot()
  {
    error unless superuser;
    return if $uid;
    $usertext = username;
    my($name);
    ($name, undef, $uid, $gid) = getpwnam($usertext);
    return if defined($name);
    my($tryuid) = fallbackuid;
    error("no such user: $usertext") unless $tryuid;
    explain("no such user: $usertext");
    for(1..65535)
    {
      if(!defined(getpwuid($tryuid)))
      {
        explain("falling back on uid $tryuid, gid $tryuid");
        ($uid, $gid, $usertext) = ($tryuid, $tryuid, $tryuid);
        return;
      }
      ++$uid;
      $uid = 1 if $uid == 65536;
    }
    error("can't find unused uid");
  }

  sub chownnonroot(@)
  {
    my(@files) = @_;
    return true unless superuser;
    initnonroot;
    $uid || error;
    announce("chown", $usertext, @files);
    chown($uid, $gid, @files) || error("chown $uid:$gid @files: $!");
  }

  sub belongstononroot($)
  {
    my($path) = @_;
    my(@stats) = safestat($path);
    initnonroot;
    $uid || error;
    return $stats[4] == $uid;
  }

  sub dropprivs()
  {
    return true unless superuser;
    initnonroot;
    explain("running as user $usertext");
    $uid || error("refusing to run as root");
    $( = $gid;
    $) = "$gid $gid";
    ($<, $>) = ($uid, $uid);
    $> == $< || error("real and effective UIDs do not match");
    $> == $uid || error("uid is not set correctly");
  }
}

##############################################################################

sub which($)
{
  my($prog) = @_;
  for(split(/:/, $ENV{"PATH"}))
  {
    my($path) = path($_, $prog);
    $path = abspath($path) unless $path =~ m!^/!;
    return $path if -x($path);
  }
  error("can't find $prog in PATH");
}

##############################################################################

sub newenvvar($$;$;$)
{
  my($varname, $subdirs, $default, $delim) = @_;
  $delim ||= ":";
  my(@dirs) = map(path(armdir, $_), split(/$delim/, $subdirs));
  my($current) = exists($ENV{$varname}) ? $ENV{$varname} : $default;

  if(defined($current))
  {
    my(%have);
    $have{$_} = 1 for split(/$delim/, $current);
    @dirs = grep(!$have{$_}, @dirs);
    push(@dirs, $current);
  }

  return($varname, join($delim, @dirs));
}

sub newenv()
{
  my($defaultman) = "/usr/man:/usr/share/man:/usr/local/man:/usr/X11R6/man";
  if(!exists($ENV{MANPATH})) # don't bother unless we're going to use it...
  {
    my($out) = `man -w 2>/dev/null`;
    chomp($out) if defined($out);
    $defaultman = $out if defined($out) && $out =~ m!^/! && $out !~ /\n/;
  }
  my($x) = path(qw(etc xml toast-xml-catalog));
  my($hspkgdir) = path(qw(etc toast-hs-package.conf));

  my(@vars);
  push(@vars, newenvvar("PATH", "bin"));
  push(@vars, newenvvar("MANPATH", "man", $defaultman));
  push(@vars, newenvvar("INFOPATH", "info", "")) if infodir;
  push(@vars, newenvvar("CPATH", "include"));
  push(@vars, newenvvar("LIBRARY_PATH", "lib"));
  push(@vars, newenvvar("XML_CATALOG_FILES", $x, "/$x", " ")) if xmlcatalog;
  push(@vars, newenvvar("GHC_PKG_PATH", $hspkgdir)) if hspkg;
  # there's also a LIBRARY_RUN_PATH or something that affects ld somehow...
  return @vars;
}

sub printnewenv()
{
  my(@vars) = newenv;
  while(@vars)
  {
    my($key, $value) = (shift(@vars), shellescape(shift(@vars)));
    my($export) = exists($ENV{$key}) ? "" : " export $key;";
    print("$key=$value;$export\n");
  }
  return @vars;
}

sub setbuildenv()
{
  my(%vars) = printnewenv;
  $ENV{$_} = $vars{$_} for keys(%vars);
  true;
}

sub env(@)
{
  @_ && error;
  printnewenv;
  return true;
}

##############################################################################

sub yes()
{
  explain("forking yes subprocess");
  my($pid) = open(STDIN, "-|");
  error("fork: $!") unless defined($pid);
  return if $pid;
  print("\n") || last for 1..9999;
  exit(0)
}

sub showprebuildinfo($$$)
{
  my($name, $version, $build) = @_;
  explain("$myname $myversion building " . pkgname($name, $version, $build));
  explain("$^X $0 $] $^O");
  optrun("uname", "-a");
  optrun("perl", "-V");
  optrun("printenv") || optrun("env");
  explain("argv: $_") for @ARGV;
  my(@urls) = pkgurls($name, $version);
  explain("no urls") unless @urls;
  explain("url: $_") for @urls;
  my(@archives) = absls(path(pkgpath($name, $version), archivedir));
  explain("no archives") unless @archives;
  optrun("md5sum", @archives) if @archives;
  true;
}

sub gettimes() { (time, times) }

sub showtimedeltas(@)
{
  my($swall, $suser, $ssys, $scuser, $scsys) = @_;
  my($ewall, $euser, $esys, $ecuser, $ecsys) = gettimes;
  my($text) = "";
  if(defined($suser))
  {
    $text .= ($euser - $suser + $ecuser - $scuser) . "s user ";
    $text .= ($esys  - $ssys  + $ecsys  - $scsys ) . "s system ";
  }
  $text .= ($ewall - $swall) . "s total";
  explain($text);
}

##############################################################################

# patch files may have leading garbage, so it can help for this to be largish:
sub magicbufsize { 1024 }

sub magicstring($)
{
  local($_) = @_;

  return ".Z" if /^\x1f\x9d/;
  return ".gz" if /^\x1f\x8b/;
  return ".bz2" if /^BZ/;
  return ".zip" if /^PK\x03\x04/;
  return ".rpm" if /^\xed\xab\xee\xdb/;
  return ".deb" if /^\!\<arch\>\n/;
  return ".cpio" if /^07070[a-f\d]{30}/i;
  return ".tar" if /^[^\x00]+(..)?\x00{5,}[\x00\s\d]{30}/
      || /\x00ustar[ \x00]/;
  return ".shar" if m:^(\#!/bin/sh\n)?\# This is a shell archive:;
  return ".patch" if /^(diff |\*\*\* |Only in |Common subdirectories: |--- )/m;

  return "";
}

sub magicfile($)
{
  my($file) = $_;
  local(*FILE);
  safeopen(*FILE, "<", $file);
  my($buf);
  defined(read(FILE, $buf, magicbufsize)) || error("read $file: $!");
  my($type) = magicstring($buf);
  if(!$type && length($buf) >= magicbufsize)
  {
    seek(FILE, -22, 2) || error("seek $file: $!");
    defined(read(FILE, $buf = "", 22)) || error("read $file: $!");
    $type = ".zip" if $buf =~ /^PK\x05\x06/; # end-of-directory signature
  }
  close(FILE) || error("close $file for read: $!");
  return $type;
}

sub readstdin($)
{
  my($len) = @_;
  my($buf) = "";
  while($len > 0)
  {
    my($result) = sysread(STDIN, $buf, $len, length($buf));
    defined($result) || error("read stdin: $!");
    last unless $result;
    $len -= $result;
  }
  $buf;
}

sub skipstdin($)
{
  my($len) = @_;
  while($len > 0)
  {
    my($chunk) = min($len, 8192);
    error("unexpected eof") unless length(readstdin($chunk)) == $chunk;
    $len -= $chunk;
  }
  return true;
}

sub forkstdin()
{
  my($pid) = open(STDIN, "-|");
  defined($pid) || error("fork stdin: $!");
  binmode(STDIN) || error("binmode stdin: $!"); # perl 5.8.0 utf8 bug
  return $pid;
}

sub dumpstdin($)
{
  my($buf) = @_;
  binmode(STDOUT) || error("binmode stdout: $!"); # perl 5.8.0 utf8 bug
  print($buf);
  print($buf) while sysread(STDIN, $buf = "", 8192, 0);
  exit(0);
}

sub extractstdin($);

sub autoextractstdin(;$)
{
  my($buf) = @_;
  $buf = readstdin(magicbufsize) unless defined($buf);
  my($type) = magicstring($buf);
  error("unknown file type: " . unpack("H*", $buf)) unless $type;
  forkstdin ? extractstdin($type) : dumpstdin($buf);
}

sub applypatchfromstdin()
{
  my($subdir);
  my($ok) = whiledir { !defined($subdir) && ($subdir = $_) } ".";
  safeexec(qw[patch -p1 -d], $subdir) if $ok && $subdir;
  safeexec(qw[patch -p0]);
}

sub rpmextractstdin()
{
  my($lead) = readstdin(96);
  $lead =~ /^\xed\xab\xee\xdb[\x03\x04]/ || error("not rpm v3 or v4");

  my($pad) = 0;
  my($hdr);
  while(magicstring($hdr = readstdin($pad + 16)) !~ /^\..z/i)
  {
    error("short rpm: " . unpack("H*", $hdr)) unless length($hdr) == $pad + 16;
    my($magic, $zero, $sections, $bytes) = unpack("x$pad N4", $hdr);
    $magic == 0x8eade801 || error(sprintf("bad rpm header: %08x", $magic));
    skipstdin($bytes + 16*$sections);
    $pad = (8 - $bytes%8) % 8;
  }

  autoextractstdin($hdr);
  error;
}

sub debextractstdin()
{
  my($magic) = readstdin(8);
  error("bad deb magic: " . unpack("H*", $magic)) unless $magic eq "!<arch>\n";

  for(;;)
  {
    my($hdr) = readstdin(60);
    error("bad deb hdr: " . unpack("H*", $hdr)) unless $hdr =~ / (\d+) +\`$/;
    my($len) = $1;
    skipstdin(1) if $hdr =~ s/^\n//;
    autoextractstdin if $hdr =~ /^data\./; # autoextractstdin doesn't return
    skipstdin($len);
  }

  error;
}

BEGIN # built-in gunzip (zcat)
{
  my($inbuf, $inlen, $outbuf, $written);
  my(@llens) = qw[3 4 5 6 7 8 9 10 11 13 15 17 19 23 27 31 35 43 51 59 67 83
      99 115 131 163 195 227 258];
  my(@lbits) = qw[0 0 0 0 0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 4 4 4 4 5 5 5 5 0];
  my(@dists) = qw[1 2 3 4 5 7 9 13 17 25 33 49 65 97 129 193 257 385 513 769
      1025 1537 2049 3073 4097 6145 8193 12289 16385 24577];
  my(@dbits) = qw[0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 10 10 11 11 12
      12 13 13];
  my(@order) = qw[16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15];

  sub zread($)
  {
    my($len) = @_;
    my($ofs, $buf) = 0;
    while($len > 0)
    {
      my($ret) = read(STDIN, $buf, $len, $ofs);
      defined($ret) or die("read: $!");
      die("unexpected EOF") if $ret == 0;
      $ofs += $ret;
      $len -= $ret;
    }
    return $buf;
  }

  sub readbit()
  {
    ($inbuf, $inlen) = (unpack("C", zread(1)), 8) unless $inlen;
    return ($inbuf & (1 << (8 - $inlen--))) ? 1 : 0;
  }

  sub nextbyte()
  {
    readbit && die("bad pad bit") while $inlen;
  }

  sub readbits($)
  {
    my($result, $bits) = (0, @_);
    $result |= readbit << $_ for(0..$bits-1);
    return $result;
  }

  sub inithuff(@)
  {
    my(@lens) = @_;
    my($maxlen) = 0;
    $_ > $maxlen && ($maxlen = $_) for @lens;
    my(%result) = (maxlen => $maxlen);
    my($code, $len) = 0;
    for $len (1..$maxlen)
    {
      $code <<= 1;
      for(0..$#lens)
      {
        $result{sprintf("\%0${len}b", $code++)} = $_ if $lens[$_] == $len;
      }
    }
    return %result;
  }

  sub readhuff(%)
  {
    my(%map) = @_;
    my($maxlen) = $map{"maxlen"};
    my($bits) = "";
    while(length($bits) < $maxlen)
    {
      $bits .= readbit;
      return $map{$bits} if exists($map{$bits});
    }
    die("bad huffman code: $bits");
  }

  sub zwrite($)
  {
    my($data) = @_;
    $written += length($data);
    $outbuf .= $data;
    substr($outbuf, 0, length($outbuf) - 32768) = "" if length($outbuf) > 65536;
    print($data);
  }

  sub zcat()
  {
    my($id1, $id2, $cm, $flg) = unpack("C4", zread(10));
    die("bad magic: $id1 $id2") unless $id1 == 31 && $id2 == 139;
    die("bad cm: $cm") unless $cm == 8;
    die("bad flags: $flg") if $flg & 0xe0;
    zread(unpack("v", zread(2))) if $flg & 4; # FEXTRA
    if($flg & 8) { while(zread(1) ne "\x00") { } } # FNAME
    if($flg & 16) { while(zread(1) ne "\x00") { } } # FCOMMENT
    zread(2) if $flg & 2; # FHCRC

    ($written, $outbuf) = (0, "");
    my($bfinal);
    do
    {
      $bfinal = readbit;
      my($btype) = readbits(2);
      if($btype == 3)
      {
        die("bad btype");
      }
      elsif($btype == 0) # no compression
      {
        nextbyte;
        my($len, $nlen) = unpack("v2", zread(4));
        die("bad nlen: $len $nlen") if $nlen != (65535 - $len);
        zwrite(zread($len));
      }
      else
      {
        my(%llmap, %dmap, $ll);
        if($btype == 1) # fixed Huffman
        {
          $llmap{sprintf('%07b', $_)} = $_ + 256 for 0..23;
          $llmap{sprintf('%08b', $_ + 48)} = $_ for 0..143;
          $llmap{sprintf('%08b', $_ + 192)} = $_ + 280 for 0..7;
          $llmap{sprintf('%09b', $_ + 400)} = $_ + 144 for 0..111;
          $llmap{"maxlen"} = 9;
          $dmap{sprintf('%05b', $_)} = $_ for 0..29;
          $dmap{"maxlen"} = 5;
        }
        else # dynamic Huffman
        {
          my($hlit, $hdist, $hclen) = map(readbits($_), 5, 5, 4);
          my(@rawclens, @clens, @lens);
          push(@rawclens, readbits(3)) for 1..4+$hclen;
          $clens[$order[$_]] = $rawclens[$_] || 0 for 0..$#order;
          my(%cmap) = inithuff(@clens);
          while(scalar(@lens) < $hlit + $hdist + 258)
          {
            my($code) = readhuff(%cmap);
            if($code == 16)
            {
              die("no last code") unless @lens;
              my($last) = $lens[$#lens];
              push(@lens, $last) for 1..3+readbits(2);
            }
            elsif($code == 17)
            {
              push(@lens, 0) for 1..3+readbits(3);
            }
            elsif($code == 18)
            {
              push(@lens, 0) for 1..11+readbits(7);
            }
            else
            {
              push(@lens, $code);
            }
          }
          %llmap = inithuff(@lens[0..$hlit+256]);
          %dmap = inithuff(@lens[$hlit+257..$hlit+$hdist+257]);
        }

        while(256 != ($ll = readhuff(%llmap)))
        {
          if($ll < 256)
          {
            zwrite(chr($ll));
          }
          else
          {
            my($i) = $ll - 257;
            my($len) = $llens[$i] + readbits($lbits[$i]);
            my($dist) = $dists[$i = readhuff(%dmap)] + readbits($dbits[$i]);
            zwrite(substr($outbuf, length($outbuf) - $dist, 1)) for(1..$len);
          }
        }
      }
    } until($bfinal);
    my($crc32, $isize) = unpack("V2", zread(8));
    die("bad isize: $isize != $written") unless $isize == $written;
  }
}

sub zfork()
{
  explain("falling back on built-in gunzip");
  return true if forkstdin;
  zcat;
  exit(0);
  error;
}

sub extractstdin($)
{
  my($type) = @_;

  safeexec("tar", "xf", "-") if $type eq ".tar";
  safeexec("cpio", "-di") if $type eq ".cpio";
  safeexec("/bin/sh") if $type eq ".shar";

  applypatchfromstdin if $type eq ".patch";

  rpmextractstdin if $type eq ".rpm";
  debextractstdin if $type eq ".deb";

  if($type =~ /^\.(Z|gz|bz2)$/)
  {
    my($prog) = $type eq ".bz2" ? "bunzip2" : "gunzip";
    open(STDIN, "$prog |") || $prog eq "gunzip" && zfork || error("$prog: $!");
    binmode(STDIN) || error("binmode stdin: $!"); # perl 5.8.0 utf8 bug
    autoextractstdin;
    error;
  }

  error("unable to handle $type data in this context") if $type;
  error("unknown file type");
}

sub extractfile($$)
{
  my($infile, $outdir) = @_;
  explain("extracting $infile");

  my($type) = magicfile($infile);
  my($pid) = fork;
  error("fork: $!") unless defined($pid);
  if($pid)
  {
    waitpid($pid, 0);
    error("extract subprocess returned $?")
        if $? && !($? == 256 && $type eq ".zip");
  }
  else
  {
    silentcd($outdir);
    safeexec("unzip", "-qo", $infile) if $type eq ".zip";
    safeopen(*STDIN, "<", $infile);
    extractstdin($type);
    error;
  }
}

sub extractname($)
{
  my($file) = @_;

  my($arg) = local($_) = $file;
  s/\.tgz$/.tar.gz/i;

  my($cmd, $ok) = ("", false);
  ($cmd, $arg) = ($cmd . "gunzip < $arg | ", "-") if s/\.gz$//i;
  ($cmd, $arg) = ($cmd . "bunzip2 < $arg | ", "-") if s/\.bz2$//i;
  ($cmd, $ok) = ($cmd . "tar tf $arg | ", true) if s/\.tar$//i;
  ($cmd, $ok) = ("unzip -Z1 $arg | ", true) if $arg eq $_ && s/\.zip$//i;
  return undef unless $ok;
  $cmd .= "head";

  explain($cmd);

  local(*SAVE);
  open(SAVE, "<&STDIN") || error("save stdin: $!");
  safeopen(*STDIN, "<", $file);
  my($result) = `$cmd`;
  open(STDIN, "<&SAVE") || error("restore stdin: $!");

  $result = undeftoempty($result);
  $result =~ s/[\r\n].*//;
  $result =~ s|/+$||;
  emptytoundef($result);
}

##############################################################################

sub allnames(;$)
{
  @_ && defined($_[0]) ? @_ : sort cmpab optls(pkgpath);
}

sub allversions($;$)
{
  my($name) = shift;
  @_ && defined($_[0]) ? @_ : sort cmpab grep { s/^v// } ls(pkgpath($name));
}

sub allbuilds($$;$)
{
  my($name, $version) = (shift, shift);
  @_ && defined $_[0] ? @_ : sort { $a<=>$b } grep { /^[1-9]\d*$/ }
      ls(pkgpath($name, $version));
}

##############################################################################

sub isname($)
{
  my($name) = @_;
  defined($name) && -d(pkgpath($name));
}

sub isversion($$)
{
  my($name, $version) = @_;
  defined($name) && defined($version) && -d(pkgpath($name, $version));
}

sub isbuild($$$)
{
  my($name, $version, $build) = @_;
  defined($name) && defined($version) && defined($build) &&
      -d(pkgpath($name, $version, $build));
}

##############################################################################

sub latestversion($;$)
{
  my($name, $version) = @_;
  lastitem(allversions($name, $version));
}

sub latestbuilt($$;$)
{
  my($name, $version, $build) = @_;
  defined($name) || error;
  defined($version) || error;
  return undef unless isversion($name, $version);
  for $build (reverse(allbuilds($name, $version, $build)))
  {
    return $build if isbuiltmatch($name, $version, $build);
  }
  return undef;
}

##############################################################################

sub whilebuild(&@)
{
  my($sub, $name, $version, $build, @urls) = @_;

  for $name (allnames($name))
  {
    for $version (allversions($name, $version))
    {
      for $build (allbuilds($name, $version, $build))
      {
        return false unless &$sub($name, $version, $build);
      }
    }
  }

  return true;
}

##############################################################################

sub isadded($$)
{
  my($name, $version) = @_;
  return -d(pkgpath($name, $version));
}

sub isstored($$)
{
  my($name, $version) = @_;
  return -d(path(pkgpath($name, $version), archivedir));
}

sub isbuilt(@)
{
  my($name, $version, $build) = @_;
  return isadded($name, $version) && !whilebuild
  {
    my($name, $version, $build) = @_;
    return !-f(path(pkgpath($name, $version, $build), buildlog));
  } @_;
}

sub isbroken($$$)
{
  my($name, $version, $build) = @_;
  return -f(path(pkgpath($name, $version, $build), brokenlog));
}

sub isclean($$$)
{
  my($name, $version, $build) = @_;
  return !-d(path(pkgpath($name, $version, $build), srcdir));
}

sub isbuildarmedin($$$$)
{
  my($armdir, $name, $version, $build) = @_;
  $build || error;
  my($rootdir) = path(pkgpath($name, $version, $build), rootdir);
  return -d($rootdir) && !dfs
  (
    $rootdir,
    sub { true },
    sub
    {
      my($rel) = @_;
      my($armfile) = path($armdir, $rel);
      while(-e($armfile) || -l($armfile))
      {
        return false if optsamefile($_, $armfile);
        $armfile = addoff($armfile);
      }
      return true;
    },
    sub { true }
  );
}

sub allarmdirs()
{
  my(@armdirs, %seendi);
  for (armdir, split(/:/, altarmdirs))
  {
    my($armdir) = m!^/! ? $_ : path(storedir, $_);
    my($device, $inode) = stat($armdir);
    next unless defined($device);
    next unless -d(_);
    my($di) = "$device $inode";
    next if exists($seendi{$di});
    $seendi{$di} = true;
    push(@armdirs, $armdir);
  }
  return @armdirs;
}

sub isarmed(@)
{
  return !whilebuild
  {
    my($name, $version, $build) = @_;
    for (allarmdirs)
    {
      return false if isbuildarmedin($_, $name, $version, $build);
    }
    return true;
  } @_;
}

sub isarmedmatch(@)
{
  return isarmed(@_) if !skipmismatched;
  return !whilebuild
  {
    my($name, $version, $build) = @_;
    return !isbuildarmedin(armdir, $name, $version, $build);
  } @_;
}

sub ismismatched($$$)
{
  my($name, $version, $build) = @_;
  $build || error;
  my($armdirlink) = path(pkgpath($name, $version, $build), armdirlink);
  my($armdirisdir, $linkisdir) = (-d(armdir), -d($armdirlink));
  return !samefile($armdirlink, armdir) if $armdirisdir && $linkisdir;
  return true if !$armdirisdir && $linkisdir;
  my($target) = readlink($armdirlink);
  return false unless defined($target);
  return $target ne armdir;
}

sub isbuiltmatch(@)
{
  return isbuilt(@_) if !skipmismatched;
  my($name, $version, $build) = @_;
  return !whilebuild
  {
    my($name, $version, $build) = @_;
    return !isbuilt(@_) || ismismatched($name, $version, $build);
  } @_;
}

##############################################################################

sub lookslikepkgurl($;$;$)
{
  my($url, $name, $version) = @_;
  return false unless $url =~ m!^(http|ftp)://.*/[^/]+\.[a-z][^/]+$!i;
  return false if $url =~ m/\#/;
  my($noquery) = stripquery($url);
  return false unless $noquery =~ m!\.\w+$!;
  return false if $noquery =~ m!\.(html?|php|txt|diff|gif|jpg|png|css|asc|sum|sig|sign|lsm|md5)(\.\w\w)?$!i;
  return true unless defined($name);
  my($basename) = basename($noquery);
  return false unless $basename =~ /\Q$name\E/i;
  return true unless defined($version);
  return false unless $basename =~ /\Q$version\E/i;
  return true;
}

sub findnewpkg($$)
{
  my($name, $version) = @_;
  defined($name) || error;
  $name =~ /^[\w-]+$/ || error("invalid package name: $name");
  my($lcname) = lc($name);
  my($perlname) = $name;
  $perlname =~ s/-/::/g;

  my(@sites) =
  (
    "freshmeat" => "http://freshmeat.net/projects-xml/$lcname/$lcname.xml",
    "sourceforge" => "http://prdownloads.sourceforge.net/$lcname/",
    "gnu" => "http://ftp.gnu.org/gnu/$lcname/",
    "cpan" => "http://cpan.uwinnipeg.ca/module/$perlname",
  );

  my(%sites) = @sites;
  my(@all) = grep(/^\w+$/, @sites);
  my(@findsites) = split(/\s+/, findsites);
  @findsites = map { ($_ eq "all") ? @all : $_ } @findsites;
  @findsites = map { exists($sites{$_}) ? $sites{$_} : $_ } @findsites;
  s/\*/\Q$name\E/g for @findsites;
  @findsites = $myurl if $lcname eq $myname;
  @findsites = uniq(@findsites);

  my($url);
  for $url (@findsites)
  {
    my(@ret) = eval
    {
      my($tries) = 1;
      if($url =~ m!^http://(freshmeat.net)/.*\.xml$!)
      {
        local(*XML, $_);
        my($sitename) = $1;
        openurl(*XML, $url);
        my($notfound, %fmurl);
        while(<XML>)
        {
          $notfound = /^Error: project not found/i ? 1 : 0
              if !defined($notfound);
          $fmurl{$1} = $2 while m!<url_(\w+)>([^<]+)</!g;
        }
        close(XML) || error("unable to contact $sitename");

        error("no listing for package $name on $sitename") if $notfound;

        my($redirurl);
        $redirurl ||= $fmurl{$_} for qw(bz2 tgz zip deb rpm homepage);
        $redirurl || error("no suitable URL for package $name on $sitename");

        my($redirhead) = httphead($redirurl);
        $redirhead =~ /^Location: ([^\r\n]+)/im ||
            error("unexpected response from $redirurl");
        $url = $1;
        # wget can't always get FTP directory listing w/o trailing slash
        $url .= "/" if $url =~ m!^ftp:.*/[^/\.]+$!; # e.g. atop
        $url = cleanurl($url);
        $tries = 3;
      }

      my(@links) = $url;
      for(1..$tries)
      {
        $url = $links[$#links];
        @links = sort cmpab grep(lookslikepkgurl(
            $_, defined($version) ? $name : undef, $version), @links);
        my(@result);
        for(@links)
        {
          my($v) = $version;
          (undef, $v) = guessnv($_) unless defined($v);
          push(@result, [$name, $v, undef, $_])
        }
        if(scalar(@result) == 1)
        {
          eval { @result = findnewerpkg(@{$result[0]}) }
        }
        return @result if @result;
        last if lookslikepkgurl($url);

        @links = linksfromurl($url);
        my(@urls) = grep(lookslikepkgurl($_, $name, $version), @links);
        my($ext);
        for $ext (qw[.tar.bz2 .tar.gz .tgz .zip .deb .rpm])
        {
          my(@matches) = grep(stripquery($_) =~ /\Q$ext\E$/i, @urls);

          my(@namematches) =
              grep { my($n) = guessnv($_); lc($n) eq lc($name) } @matches;
          @matches = @namematches if @namematches;

          if(defined($version))
          {
            my(@vermatches) =
                grep { my(undef, $v) = guessnv($_); $v eq $version } @matches;
            @matches = @vermatches if @vermatches;
          }

          @matches = sort cmpab @matches;
          @result = ();
          for(@matches)
          {
            my($undef, $v) = guessnv($_);
            push(@result, [$name, $v, undef, $_]);
          }
          return @result if @result;
        }

        @links = grep(/^\Q$url\E/, @links);
        last unless @links;
      }
    };

    return @ret if !$@ && @ret && $ret[0];
    explain($_) for(split(/\n/, $@));
  }

  error("can't find " . pkgname($name, $version));
}

sub pkgurls($$)
{
  my($name, $version) = @_;
  defined($name) || error;
  defined($version) || error;
  my($urlfile) = path(pkgpath($name, $version), urlfile);
  return () unless -r($urlfile);
  return map { chomp; $_ } readfile($urlfile);
}

sub setpkgurls($$@)
{
  my($name, $version, @urls) = @_;
  error unless defined($name);
  error unless defined($version);
  error unless @urls;

  my($verdir) = pkgpath($name, $version);
  my($urlfile) = path($verdir, urlfile);
  my($tmpfile) = addtmp($urlfile);
  writefile($tmpfile, map("$_\n", @urls));
  mv($tmpfile, $urlfile);
}

sub choose($@)
{
  my($curver, @pkgs) = @_;
  return @pkgs unless scalar(@pkgs) > 1 && interactive;
  my(@allurls);
  for(@pkgs)
  {
    my($name, $version, $build, @urls) = @$_;
    error unless @urls;
    push(@allurls, @urls);
  }
  error unless @allurls;
  my($pl, $sl) = (commonlen(@allurls), commonlen(reverseall(@allurls)));
  print(substr($allurls[0], 0, $pl), " [...] ", substr($allurls[0], -$sl), "\n")
      if $pl || $sl;
  my($i, $cvi) = (0, 0);
  for(@pkgs)
  {
    ++$i;
    my($name, $version, $build, @urls) = @$_;
    my($margin) = "   ";
    ($cvi, $margin) = ($i, "0) ") 
        if !$cvi && $curver && $version && $curver eq $version;
    print("$margin$i) ",
        join(" ", map(substr($_, $pl, $sl ? -$sl : 9999), @urls)), "\n");
  }
  my($choice) = "";
  while(!($choice =~ /^\d+$/ && $choice > 0 && $choice <= $i))
  {
    print("> [$i] ");
    $choice = scalar(<STDIN>);
    error("EOF") unless defined($choice);
    $choice =~ s/\s+//g;
    $choice = $i if $choice eq "";
    $choice = $cvi if $choice eq "0";
  }
  return $pkgs[$choice-1];
}

##############################################################################

sub add(@)
{
  my($name, $version, $build, @urls) = @_;

  $build && error;
  $name || @urls || error;

  if(!@urls && autofind)
  {
    my(@pkgs) = reverse(choose(undef, findnewpkg($name, $version)));
    error unless @pkgs;
    ($name, $version, undef, @urls) = @{$pkgs[0]};
    error unless $name;
    error unless @urls;
  }

  @urls || error("autofind is disabled; please specify URL(s) for " .
      pkgname($name, $version));

  $name = "unknown" unless defined($name);
  my($namedir) = pkgpath($name);
  optmd(storedir, pkgpath, $namedir);

  my($goodver) = defined($version);
  $version = "unknown" unless $goodver;
  my($verdir) = pkgpath($name, $version);

  if($goodver)
  {
    if(!-d($verdir))
    {
      md($verdir);
    }
    else
    {
      my(@existingurls) = pkgurls($name, $version);
      if(samelist(@urls, @existingurls))
      {
        explain(pkgname($name, $version) .
            " exists with matching urls; treating as successfully added");
        return($name, $version);
      }
      else
      {
        error(pkgname($name, $version) . " exists with conflicting urls:\n  " .
            join("\n  ", @existingurls));
      }
    }
  }
  else
  {
    my($max, $errmsg) = (-1, true);
    while($errmsg)
    {
      local($_);
      for(allversions($name))
      {
        $max = max($max, $1 || 0) if /^unknown(\d*)$/;
      }
      if($max >= 0)
      {
        $version = "unknown" . ($max + 1);
        $verdir = pkgpath($name, $version);
      }
      $errmsg = mkdir($verdir, 0777) ? false : $!;
      error("mkdir $verdir: $errmsg") if $errmsg && !-d($verdir);
    }
    announce("mkdir", $verdir);
  }

  setpkgurls($name, $version, @urls);

  setactivepkg($name, $version);
  ($name, $version, @urls);
}

##############################################################################

sub smartgeturl($$)
{
  my($url, $dir) = @_;

  if($url =~ m!^cvsroot(\+ssh)?:(.+)/([^/]+)\#(\d+)$!)
  {
    my($usessh, $cvsroot, $module, $time) = ($1, $2, $3, $4);
    announce("export CVS_RSH=ssh") if $usessh;
    local($ENV{CVS_RSH}) = "ssh" if $usessh;
    my($moddir) = path($dir, $module);
    optmd($moddir);
    chownnonroot($moddir);
    cdrunnonroot($dir, "cvs", (quiet ? "-Q" : "-q"),
        "-d", $cvsroot, "co", "-D", "\@$time", $module);
    cdrun($dir, qw(tar czf), "$module.tar.gz", $module);
    rmall($moddir);
    return $url;
  }

  my(%visited);
  for(1..5)
  {
    my($basename) = basename(stripquery($url));
    $basename = "index" if $basename eq "";
    my($file) = path($dir, $basename);

    my($newurl) = geturl($url, $file);
    $visited{$url} = 1;

    local(*FILE);
    safeopen(*FILE, "<", $file);
    my($header);
    read(FILE, $header, 128) || error("read $file: $!");
    my($redir);
    if($header =~ /^\<.*\bHTML\b/i)
    {
      seek(FILE, 0, 0) || error("rewind $file: $!");
      my(@links) = reverse(sort cmpab linksfromstream(*FILE, $newurl));
      my(@goodlinks) = grep(/\.tar\./, @links);
      @goodlinks = grep(!/\.(s?html?|php)$/i, @links) unless @goodlinks;
      @links = @goodlinks if @goodlinks;
      for (@links)
      {
        $redir = $_ if !$redir && basename(stripquery($_)) eq $basename
            && !$visited{$_};
      }
      my($ext);
      for $ext (qw[.tar.bz2 .tar.gz .tgz .zip .deb .rpm])
      {
        for (@links)
        {
          $redir = $_ if !$redir && stripquery($_) =~ /\Q$ext\E$/i
              && !$visited{$_};
        }
      }
      error("no more links to try") unless $redir;
    }
    close(FILE) || error("close $file: $!");

    return $url unless $redir;

    rm($file);
    $url = $redir;
    error if $visited{$url};
  }

  error("too many links: $url");
}

sub renamepkg($$$$)
{
  my($oldname, $oldversion, $newname, $newversion) = @_;

  my($oldnamedir) = pkgpath($oldname);
  my($newnamedir) = pkgpath($newname);
  my($oldverdir) = pkgpath($oldname, $oldversion);
  my($newverdir) = pkgpath($newname, $newversion);

  optmd($newnamedir);
  mv($oldverdir, $newverdir);
  rmdir($oldnamedir) && announce("rmdir", $oldnamedir);
  return ($newname, $newversion);
}

sub autorenamepkg($$@)
{
  my($name, $version, @urls) = @_;

  if(@urls)
  {
    my($newname, $newversion) = guessnv(@urls);
    return renamepkg($name, $version, $newname, $newversion)
        if defined($newname) && defined($newversion);
  }

  my($verdir) = pkgpath($name, $version);
  my($archivedir) = path($verdir, archivedir);

  local($_);
  for(absls($archivedir))
  {
    my($extractname) = extractname($_);
    next unless defined($extractname);

    my($newname, $newversion) = guessnv($extractname);
    return renamepkg($name, $version, $newname, $newversion)
        if defined($newname) && defined($newversion);
  }

  ($name, $version);
}

sub get(@)
{
  my($name, $version, $build, @urls) = @_;
  my($autorename) = @urls && !defined($version) && autorename;

  ($name, $version, @urls) = add(@_) if @urls || !isadded($name, $version);

  $build && error;
  defined($name) || error;
  defined($version) || error;

  @urls = pkgurls($name, $version) unless @urls;

  return ($name, $version, @urls) if isstored($name, $version);

  my($verdir) = pkgpath($name, $version);
  my($realdir) = path($verdir, archivedir);
  my($tempdir) = addtmp($realdir);

  optmd($tempdir);

  my($changed) = false;
  for(@urls)
  {
    my($newurl) = smartgeturl($_, $tempdir);
    if($newurl ne $_ && autochange)
    {
      $_ = $newurl;
      $changed = true;
    }
  }
  setpkgurls($name, $version, @urls) if $changed;

  mv($tempdir, $realdir);
  ($name, $version) = autorenamepkg($name, $version, $changed ? @urls : ())
      if $autorename;

  ($name, $version, @urls);
}

##############################################################################

sub exprecedence($)
{
  local($_) = @_;
  /\.(patch|diff)\b/i;
}

sub excmp($$)
{
  my($a, $b) = @_;
  exprecedence($a) - exprecedence($b) || $a cmp $b;
}

sub extract($$)
{
  my($indir, $outdir) = @_;
  my(@infiles) = absls($indir);
  @infiles || error("$indir is empty");
  extractfile($_, $outdir) foreach sort { excmp($a, $b) } @infiles;
}

sub makedir($)
{
  my($dir) = @_;
  my($subdir);
  my($ok) = whiledir
  {
    my($abs) = path($dir, $_);
    return false unless -d($abs);
    return true if $_ eq "CVS";
    return false if defined($subdir);
    $subdir = $abs;
    return true;
  } $dir;
  error("empty directory: $dir") if $ok && !defined($subdir);
  return $ok ? &makedir($subdir) : $dir;
}

sub quote($)
{
  local($_) = undeftoempty(@_);
  s/\\/\\\\/g;
  s/'/\\'/g;
  "'$_'";
}

sub cquote($)
{
  local($_) = @_;
  s/\\/\\\\/g;
  s/"/\\"/g;
  "\"$_\"";
}

sub helpstub($$)
{
  my($helperdir, $cmd) = @_;
  my($path) = quote($ENV{PATH});
  writescript(path($helperdir, $cmd),
      "#!/bin/sh\nPATH=$path\nexec $cmd \"\$\@\"\n");
}

sub helpnop($$)
{
  my($helperdir, $cmd) = @_;
  helpstub($helperdir, $cmd);
  writescript(path($helperdir, "$cmd.helper"), "#!/bin/sh\ntrue\n");
}

sub helprewrite($$$$$)
{
  my($srcdir, $rootdir, $helperdir, $cmd, $force) = @_;
  helpstub($helperdir, $cmd);
  writescript(path($helperdir, "$cmd.helper"), "#!/bin/sh\n# $genby\n", q[

exec perl -x $0 ${1+"$@"}
echo "Can't find perl in PATH; aborting." >&2
exit 1

#!perl
$cmd = ], quote($cmd), q[;
$srcdir = ], quote($srcdir), q[;
$rootdir = ], quote($rootdir), q[;
$armdir = ], quote(armdir), q[;
$path = ], quote($ENV{PATH}), q[;
$preload = ], quote($ENV{LD_PRELOAD}), q[;
$myname = ], quote($myname), q[;

# cleanse environment
$ENV{PATH} = $path;
if($preload eq "")
{
  delete($ENV{LD_PRELOAD});
}
else
{
  $ENV{LD_PRELOAD} = $preload;
}

# save old arguments
@oldargs = @ARGV;

# compute new arguments
my($dashp) = $cmd eq "mkdir"; # force mkdir -p
while(@ARGV)
{
  $_ = shift(@ARGV);
  $dashp &&= $_ ne "-p";
  if($cmd eq "install" && /^-(o|-owner|g|-group)$/)
  {
    $rewritten = 1;
    shift(@ARGV);
  }
  else
  {
    if(m|^/| && !m!^(\Q$srcdir\E|\Q$rootdir\E)($|/)! &&
        (s!^\Q$armdir\E($|/)!$1! || !m!^/(dev|proc|tmp)($|/)!))
    {
      $rewritten = 1;
      my($dir, $elem) = "";
      for $component (split(/\//, $_))
      {
        $dir ne "" && mkdir("$rootdir$dir", 0777) &&
            print("$myname: created directory $rootdir$dir\n");
        $dir .= "/$component";
      }
      -d("$armdir$_") && mkdir("$rootdir$_", 0777) &&
          print("$myname: created directory $rootdir$_\n");
      $_ = "$rootdir$_";
    }
    push(@newargs, $_);
  }
}
if($dashp)
{
  $rewritten = 1;
  unshift(@newargs, "-p");
}

# print and execute real command
print("$myname: rewriting $cmd @oldargs -> $cmd @newargs\n") if $rewritten;
], $force ? q[
# return success, even if command returns failure
system($cmd, @newargs) == -1 && die("system $cmd: $!");
exit(0);
] : q[
# allow command to fail
exec($cmd, @newargs);
die("exec $cmd: $!");
]);
}

sub helphspkg($$$)
{
  my($rootdir, $helperdir, $cmd) = @_;
  return true unless hspkg;
  helpstub($helperdir, $cmd);
  writescript(path($helperdir, "$cmd.helper"), "#!/bin/sh\n# $genby\n", q[
rootdir=], quote($rootdir), q[
name=], time() . "-$$", q[
PATH=], quote($ENV{"PATH"}), q[

wrapper="$rootdir/bin/ghc.wrapped"
cat > "$wrapper" << "EOF"
#!/bin/sh
exec perl -wx "$0" "$@"
#!perl

$0 =~ m!([^/]+)$! or die;
my($me) = $1;

my($wrap) = $ENV{"TOAST_HS_WRAPPER"} || "";
$wrap .= ":" if $wrap;
$ENV{"TOAST_HS_WRAPPER"} = $wrap .= $0;

my(@extra);
push(@extra, ($me =~ /-pkg/ ? "-" : "") . "-package-conf", $_)
    for grep(-r, split(/:/, $ENV{"GHC_PKG_PATH"} || ""));

DIR: for(split(/:/, $ENV{"PATH"}))
{
  for("$_/$me.unwrapped", "$_/$me")
  {
    if(-x)
    {
      my(@stats) = stat or die("stat $_: $!");
      my($skip);
      for $skip (split(/:/, $wrap))
      {
        my(@skipstats) = stat($skip) or die("stat $skip: $!");
        next DIR if "$skipstats[0] $skipstats[1]" eq "$stats[0] $stats[1]";
      }
      if(exists($ENV{"TOAST_VERBOSE_HS_WRAPPER"}))
      {
        print("toast: not rewriting $0 @ARGV\n") unless @extra;
        print("toast: rewriting $0 @ARGV -> $0 @extra @ARGV\n") if @extra;
      }
      exec $_ ($0, @extra, @ARGV);
      die("exec $_ failed: $!");
    }
  }
}

die("can't find next $me in PATH");
EOF

chmod +x "$wrapper"
for i in ghc ghci ghc-pkg; do
  path="$rootdir/bin/$i"
  if [ -r "$path" -a ! -r "$path.unwrapped" ] && ! diff -q "$path" "$wrapper"
  then
    mv "$path" "$path.unwrapped"
  fi
  ln -sf ghc.wrapped "$rootdir/bin/$i"
done

[ "$*" = "--toast-install-wrapper-only" ] && exit 0

ghc-pkg "$@" --user # let --auto-ghci-libs do its thing
 
for arg; do
  case "$arg" in
    -*) ;;
    *) [ -r "$arg" ] && exec < "$arg" ;;
  esac
done

exec cat > "$rootdir/hspkg/$name"
]);
}

sub helpccache($$$)
{
  my($rootdir, $helperdir, $cmd) = @_;
  return true unless ccache;

  my($path) = $ENV{"PATH"};
  my($found);
  $found ||= -x(laxpath($_, "ccache")) for split(/:/, $path);
  return true unless $found;

  for($cmd, "$cmd.helper")
  {
    writescript(path($helperdir, $_), qq[#!/bin/sh
# $genby
PATH=$path
exec ccache $cmd "\$\@"
]);
  }
}

sub helplib($$$)
{
  my($srcdir, $rootdir, $helperdir) = @_;

  return undef unless preload;

  my($defdebug) = "#define DEBUG stderr";
  $defdebug = "/* $defdebug */" unless debugrewrite;

  my($code) = qq[/* $genby */

#define _GNU_SOURCE

#include <dlfcn.h>
#include <errno.h>
#include <stdio.h>
#include <string.h>

#ifdef __CYGWIN__
#ifndef RTLD_NEXT
#define RTLD_NEXT ((void *) -1L)
#endif
#endif

#ifndef DEBUG
$defdebug
#endif

struct timeval; /* to match the utimes() prototype that SunOS pulls in... */

#ifdef DEBUG
#define debug(fmt, args...) do { fprintf(DEBUG, "$myname: " fmt "\\n", ## args); fflush(DEBUG); } while(0)
#else
#define debug(fmt, args...) ((void)0)
#endif

#define BUFSIZE 4096

static const char *srcdir = ] . cquote($srcdir) . qq[;
static const char *rootdir = ] . cquote($rootdir) . qq[;
static const char *helperdir = ] . cquote($helperdir) . qq[;
static const char *armdir = ] . cquote(armdir) . qq[;

static int startswith(const char *s, const char *prefix)
{
  int len = strlen(prefix);
  int result = strncmp(s, prefix, len) == 0 && (s[len] == 0 || s[len] == '/');
  /* debug("startswith(%s, %s) = %d", s, prefix, result); */
  return result;
}

static const char *check_strip_armdir(const char *pathname)
{
  if(!pathname)
  {
    debug("NULL pathname");
    return 0;
  }
  else if(pathname[0] != '/')
  {
    debug("relative pathname: %s", pathname);
    return 0;
  }
  else if(startswith(pathname, srcdir))
  {
    debug("pathname in srcdir: %s", pathname);
    return 0;
  }
  else if(startswith(pathname, rootdir))
  {
    debug("pathname in rootdir: %s", pathname);
    return 0;
  }
  else if(startswith(pathname, helperdir))
  {
    debug("pathname in helperdir: %s", pathname);
    return 0;
  }
  else
  {
    if(startswith(pathname, armdir))
    {
      debug("pathname in armdir: %s", pathname);
      pathname += strlen(armdir);
      debug("stripping armdir: %s", pathname);
    }
    else if(startswith(pathname, "/dev"))
    {
      debug("pathname in /dev: %s", pathname);
      return 0;
    }
    else if(startswith(pathname, "/proc"))
    {
      debug("pathname in /proc: %s", pathname);
      return 0;
    }
    else if(startswith(pathname, "/tmp"))
    {
      debug("pathname in /tmp: %s", pathname);
      return 0;
    }

    if(BUFSIZE < strlen(rootdir) + strlen(pathname) + 1)
    {
      debug("pathname is too long: %s", pathname);
      return 0;
    }
    else
    {
      debug("pathname is rewritable: %s", pathname);
      return pathname;
    }
  }
}

static int real_mkdir(const char *pathname, int mode);

static void mkparents(const char *pathname)
{
  const char *stripped = check_strip_armdir(pathname);
  if(!stripped)
  {
    debug("not creating parents for %s", pathname);
  }
  else
  {
    int saved_errno = errno;
    char buf[BUFSIZE];
    char *p = buf + strlen(rootdir);
    int done = 0;

    memset(buf, 0, sizeof(buf));
    strcpy(buf, rootdir);

    while(!done)
    {
      do
      {
        *(p++) = *(stripped++);
        done = done || !*stripped;
      } while(!done && *stripped != '/');

      if(!done)
      {
        int ret = real_mkdir(buf, 0755) != 0;
        if(ret == -1)
        {
          debug("can't create parent directory %s", buf);
        }
        else
        {
          debug("created parent directory %s", buf);
        }
      }
    }

    errno = saved_errno;
  }
}

static const char *rewrite(const char *pathname)
{
  static char buffers[2][BUFSIZE];
  static int whichbuf = 0;
  const char *stripped = check_strip_armdir(pathname);

  if(!stripped)
  {
    debug("not rewriting pathname %s", pathname);
    return pathname;
  }
  else
  {
    char *buffer = buffers[whichbuf];
    whichbuf ^= 1;
    strcpy(buffer, rootdir);
    strcat(buffer, stripped);
    debug("rewriting %s -> %s", pathname, buffer);
    return buffer;
  }
}

];

  my(@decls) = split(/;/, q[
    wrap FILE *fopen(const char *pathname, const char *mode);
    wrap FILE *freopen(const char *pathname, const char *mode, FILE *file);
    wrap void *opendir(const char *pathname);
    wrap void *dlopen(const char *pathname, int flag);
    wrap int creat(const char *pathname, int flags);
    wrap int open(const char *pathname, int flags, int mode);
    wrap int access(const char *pathname, int flags);
    wrap int chdir(const char *pathname);
    wrap int xstat(int version, const char *pathname, void *foo);
    wrap int lxstat(int version, const char *pathname, void *foo);
    wrap int readlink(const char *pathname, char *buf, int size);
    wrap int link(const char *pathname1, const char *pathname2);
    wrap int symlink(const char *pathname1, const char *pathname2);
    wrap0 int mkdir(const char *pathname, int mode);
    wrap int rmdir(const char *pathname);
    wrap int chmod(const char *pathname, int mode);
    wrap0 int rename(const char *pathname1, const char *pathname2);
    wrap0 int unlink(const char *pathname);
    wrap int utime(const char *pathname, void *foo);
    wrap int utimes(const char *pathname, const struct timeval *tvp);
    wrap int execve(const char *pathname, void *foo1, void *foo2);
    suppress int chown(const char *pathname, int user, int group);
    suppress int lchown(const char *pathname, int user, int group);
    suppress int fchown(int fd, int user, int group);
  ]);

  for(@decls)
  {
    s/\s+//;
    next unless $_;
    /^(wrap0?|suppress) (int |\w+ \*)(\w+)\((.*)\)$/ || error;
    my($iswrap, $rettype, $basename, $proto) = ($1 ne "suppress", $2, $3, $4);
    # wrapped dlopen() always fails with "Service not available" in FreeBSD (?)
    next if $basename eq "dlopen" && $^O eq "freebsd";
    my($iswrap0) = $1 eq "wrap0";
    my($retfailed, $retfmt) = $rettype =~ /\*/ ? (0, '%p') : (-1, '%d');
    my(@alist) = map { /\w+$/ ? $& : error } split(/, /, $proto);
    my($args) = join(", ", @alist);
    my($newargs) = join(", ", map { /pathname/ ? "rewrite($_)" : $_ } @alist);
    my($allrewritable) = join(" && ", map("check_strip_armdir($_)",
        grep(/pathname/, @alist)));
    my($destarg) = $proto =~ /pathname2/ ? "pathname2" : "pathname";

    my($nameprefix, $namesuffix);
    for $nameprefix ("", "_", "__")
    {
      for $namesuffix ("", "64")
      {
        my($name) = "$nameprefix$basename$namesuffix";
        $code .= $iswrap ? qq[
static $rettype(*next_$name)($proto) = 0;

static ${rettype}real_$name($proto)
{
  if(!next_$name)
  {
    next_$name = dlsym(RTLD_NEXT, "$name");
  }

  return next_$name($args);
}

$rettype$name($proto)
{
  ${rettype}result;

  debug("rewriting $name");

  mkparents($destarg);

  result = real_$name($newargs);
  debug("rewritten $name returned $retfmt", result);

  if(result == $retfailed)
  {
    debug("retrying $name with original args");
    result = real_$name($args);
    debug("original $name returned $retfmt", result);
  }
] . ($iswrap0 ? qq[
  if(result == $retfailed && $allrewritable)
  {
    debug("suppressing $name");
    result = 0;
    errno = 0;
  }
] : "") . qq[
  return result;
}
] : qq[
$rettype$name($proto)
{
  debug("suppressing $name");
  return 0;
}
];
      }
    }
  }

  my($so, $do, $cc, $ld, $libs) =
      ("so", ".o", "gcc -fPIC", "gcc -shared", "-ldl");
  eval q{
    use Config;
    $so = $Config{"dlext"} or die;
    $do = $Config{"_o"} or die;
    $libs = "" unless $Config{"libs"} =~ /-ldl\b/;
    $cc = "$Config{cc} $Config{cccdlflags}";
    $ld = "$Config{ld} $Config{lddlflags}";
    $cc .= " -Wall -Werror" if $Config{ccname} eq "gcc" && strictpreload;
  };

  writefile(path($helperdir, "dummy.c"), "void ____toast_dummy_4u38291(){}\n");
  writefile(path($helperdir, "rewrite.c"), $code);

  return path($helperdir, "rewrite.$so")
      if optcdrun($helperdir, "$cc -c dummy.c -o dummy$do")
      && optcdrun($helperdir, "$ld dummy$do -o rewrite.$so")
      && optcdrun($helperdir, "$cc -c rewrite.c -o rewrite$do")
      && optcdrun($helperdir, "$ld rewrite$do -o rewrite.$so.helper $libs");

  error("unable to compile with strictpreload enabled") if strictpreload;
  explain("unable to compile; strictpreload disabled, continuing");
  return undef;
}

sub helphome($$$)
{
  my($srcdir, $rootdir, $helperdir) = @_;

  my($makehome) = path($helperdir, "home");
  my($installhome) = path($helperdir, "home.helper");
  md($makehome, $installhome);

  my($makedir) = makedir($srcdir);
  my($scriptdir) = path($installhome, "bin");
  my($script) = path($scriptdir, "installkernel");
  my($kbase) = "vmlinuz";
  my($mbase) = "System.map";
  my($kernel) = path($rootdir, "boot", $kbase);
  my($map) = path($rootdir, "boot", $mbase);

  md($scriptdir);
  writescript($script, qq[#!/bin/sh
# script to be run by Linux kernel Makefile install target
# $genby
set -e
set -x
cat \$2 > $kernel
cp \$3 $map
ln -s $kbase $kernel-\$1
ln -s $mbase $map-\$1
]);

  return $makehome;
}

sub inithelpers($$$)
{
  my($srcdir, $rootdir, $helperdir) = @_;
  my(%env) = %ENV;

  md($helperdir);

  helprewrite($srcdir, $rootdir, $helperdir, $_, false)
      for (qw[mkdir rmdir touch cp rm ln install chmod test ranlib gzip
      xmlcatalog], "[");
  helprewrite($srcdir, $rootdir, $helperdir, $_, true) for (qw[mv]);
  helpnop($helperdir, $_) for (qw[chown chgrp ldconfig install-info mknod]);
  helphspkg($rootdir, $helperdir, $_) for (qw[ghc-pkg]);
  helpccache($rootdir, $helperdir, $_) for (qw[cc gcc g++]);
  $env{PATH} = "$helperdir:$env{PATH}";

  my($preload) = helplib($srcdir, $rootdir, $helperdir);
  if($preload)
  {
    if(exists($env{LD_PRELOAD}) && length($env{LD_PRELOAD}))
    {
      $env{LD_PRELOAD} .= " $preload";
    }
    else
    {
      $env{LD_PRELOAD} = $preload;
    }
  }

  $env{HOME} = helphome($srcdir, $rootdir, $helperdir);

  %env;
}

sub armhelpers($)
{
  my($helperdir) = @_;
  my(@files) = absls($helperdir);
  /\.helper$/ ? mv($_, $`) : mv($_, "$_.stub") foreach sort(@files);
}

sub makefile($)
{
  my($dir) = @_;
  for(qw[GNUmakefile makefile Makefile])
  {
    my($file) = path($dir, $_);
    return $file if -r($file);
  }
  return false;
}

sub splitwords($)
{
  my($s) = @_;
  $s =~ s/^\s+//;
  my(@words);
  while($s =~ s/^"((\\.|[^"])*)"//s || $s =~ s/^'((\\.|[^'])*)'//s ||
      $s =~ s/^((\\.|\S)+)//s)
  {
    push(@words, $1);
    $s =~ s/^\s+//;
  }
  error("unbalanced quotes") unless $s eq "";
  return @words;
}

sub cdrunconf($@)
{
  my($dir, @prog) = @_;
  cdrun($dir, @prog, splitwords(confappend));
}

sub configure($$)
{
  my($dir, $prefix) = @_;

  # Haskell Cabal (http://www.haskell.org/cabal/)
  # Must be checked for before "configure" due to the following craziness:
  # http://haskell.org/ghc/docs/6.4/html/Cabal/authors.html#system-dependent
  for("Setup.hs", "Setup.lhs")
  {
    if(-r(path($dir, $_)))
    {
      cdrun($dir, qw(ghc-pkg list)); # work around ~/.ghc bug in ghc-pkg 6.4 (?)
      cdrunconf($dir, "runghc", $_, "configure", "--prefix=$prefix",
          "--with-hc-pkg=ghc-pkg");
      writefile
      (
        path($dir, "Makefile"),
        "# $genby\n\n",
        "all:\n\trunghc $_ build\n\n",
        "install:\n\trunghc $_ copy --copy-prefix=\$(DESTDIR)\n",
        "\trunghc $_ register\n",
      );
      return $dir;
    }
  }

  # find a configure script
  my($cfg);
  #            autoconf  Perl          openssl elm       libmng     pmk
  for $cfg (qw[configure configure.gnu config  Configure autogen.sh pmkcfg.sh])
  {
    my($confprog) = path($dir, $cfg);
    next if -d($confprog);
    next unless -x($confprog) || (-r($confprog) && $confprog =~ /\.sh$/);

    my($self) = false;
    my($builddir) = false;
    my($bogus) = false;
    my($twowordprefix) = false;
    my($noprefix) = false;
    my($mozilla) = false;
    my(%confopts);

    my($opensslcfg) = path($dir, "Configure");
    if(reconfigure && $cfg eq "config" && -x($opensslcfg))
    {
      whilefile
      {
        !($confopts{"shared"} ||= /^# \[no-\]shared\s/);
      } $opensslcfg;
    }

    patch
    {
      $self ||= /this is toast 89a72ef9c34e1fd4927afa36c9be8b15/;
      $twowordprefix ||= /^\s*prefix=\$2; shift;;$/; # ocaml
      $twowordprefix ||= /  --prefix dir  /; # doxygen
      $builddir ||= /error: you must configure in a separate build/; # glibc
      $builddir||=m!\. \$srcdir/build-tools/scripts/configure-top !;#arch/tla
      $builddir ||= /Building in the source directory is not support/; # gcc 4
      $bogus ||= /There is no .+configure.+ script .+Instead/i; # libpng
      $bogus ||= /configure is no longer used - just type /i; # cdrtools
      s/(^\s*)read\s+(acceptance)(\s*$)/$1$2=yes$3/; # qt license
      s/^if test ! -t 0; /if false; /; # elm
      $noprefix = $confopts{"-d"} = 1 if /^\s*-d\) shift; fastread='y/; # elm
      $noprefix ||= /elif \[ x.sysname = x \]; then/; # isc dhcp
      if(reconfigure)
      {
        s/^\s*AUTOTHREAD=no\s+\#+ leave off for now/\#$&/; # qt multithreaded
        $mozilla = $1 if /(--enable-default-toolkit)=TK/;
        my($opt); # glibc; libjpeg; tetex; others?
        for $opt ("enable-add-ons", # glibc
            "enable-shared", # various
            "with-shared", # ncurses
            "disable-multiplatform") # tetex
        {
          $confopts{"--$opt"} ||= / \Q--$opt\E\b($|[^-])/;
        }
        $confopts{$1} = 1 if /"configure (-\S+)"; by default a static/;#zlib
      }
    } $confprog;
    $noprefix ||= -x(path($dir, "installnetpbm")); # netpbm 10.19
    if($mozilla)
    {
      local($^W) = false; # suppress misguided exec failure warning
      $confopts{"$mozilla=gtk2"} ||= system(qw(pkg-config gtk+)) == 0;
    }

    my(@confcmd) = ("./$cfg", "--prefix=$prefix");
    if(!$self)
    {
      next if $bogus;
      @confcmd = ("./$cfg", "--prefix", $prefix) if $twowordprefix;
      @confcmd = ("./$cfg") if $noprefix;
      push(@confcmd, sort(grep($confopts{$_}, keys(%confopts))));
      unshift(@confcmd, "sh") unless -x($confprog);
      if($builddir)
      {
        $confcmd[0] = "../$cfg";
        $dir = path($dir, "$myname-build.d");
        md($dir);
      }
      elsif($cfg eq "configure.gnu")
      {
        # force perl to install files it thinks are already installed
        # (5.8.2 and later support DESTDIR and should no longer need this)
        optpatch { s/^use File::Compare;$/sub compare(\$\$){1}; #$genby/ }
            path($dir, "installperl");
      }
    }

    my($amhelper) = path($dir, "install-sh");
    if(-l($amhelper) && !-r($amhelper)) # e.g. sgml-common/0.6.3
    {
      optcdrun($dir, "aclocal");
      optcdrun($dir, "automake", "-acf");
      optcdrun($dir, "autoconf", "-f");
    }

    cdrunconf($dir, @confcmd);
    return $dir;
  }

  for(qw[build_unix build.unix]) # e.g. Sleepycat DB and nvi, respectively
  {
    my($bubuilddir) = path($dir, $_);
    my($buconfprog) = path($dir, "dist", "configure");
    return $bubuilddir if -d($bubuilddir) && -x($buconfprog) &&
        cdrunconf($bubuilddir, "../dist/configure", "--prefix=$prefix");
  }

  # configure script might be hidden in a "source" subdirectory (e.g. samba)
  for(qw[source src])
  {
    my($subdir) = path($dir, $_);
    my($confprog) = path($subdir, "configure");
    return &configure($subdir, $prefix) if -x($confprog);
  }

  # if this XFree86, we have to set ProjectRoot in xc/config/cf/site.def...
  optpatch { s!(\#\s*define\s+ProjectRoot\s+)(/usr/X\S+)!$1$prefix!; }
      path($dir, qw[config cf site.def]);

  # if there's a Makefile, just use that
  return $dir if makefile($dir);

  # OK, how about an Imakefile?
  my($imf) = path($dir, "Imakefile");
  if(-r($imf))
  {
    my($xaw3d); # cajole standalone Xaw3d build
    patch
    {
      $xaw3d = 0 if $xaw3d && s/^XCOMM\s+//;
      $xaw3d = 1 if !defined($xaw3d) && /^XCOMM When.*outside an X11 source t/;
    } $imf;
    if(defined($xaw3d))
    {
      md(path($dir, "X11"));
      ln("..", path($dir, "X11", lastitem(unpath($dir))));
    }
    cdrunconf($dir, "xmkmf");
    return $dir;
  }

  # perl modules have a Makefile.PL script that spits out a Makefile
  my($mfpl) = path($dir, "Makefile.PL");
  return $dir if -r($mfpl) && cdrunconf($dir, "perl", $mfpl);

  # pmk is some kind of newfangled autoconf replacement
  my($pmkfile) = path($dir, "pmkfile");
  return $dir if -r($pmkfile) && cdrunconf($dir, "pmk");

  # qmake is a similar tool that comes with Qt
  my(@profiles) = grep(/\.pro$/i, ls($dir));
  return $dir if scalar(@profiles)==1&& cdrunconf($dir, "qmake", $profiles[0]);

  # Write a custom Makefile for glibc with add-ons and/or kernel headers.
  my($glibcdir, $hdrdir, @addons);
  my($glibcok) = whiledir
  {
    push(@addons, $_);
    my($abs) = path($dir, $_);
    return false if !-d($abs) || -l($abs);
    if(-r(path($abs, qw[include linux kernel.h])))
    {
      $hdrdir = $abs;
      pop(@addons);
      return true;
    }
    my($cfg) = path($abs, "configure");
    if(-r($cfg))
    {
      return true if whilefile { /^\s*(\#|exit|$)/ } $cfg;
      return false if $glibcdir;
      $glibcdir = $abs;
      pop(@addons);
    }
    true;
  } $dir;
  if($glibcok && (@addons || $hdrdir) && $glibcdir)
  {
    mv(path($dir, $_), path($glibcdir, $_)) foreach @addons;
    my($makedir) = path($glibcdir, "$myname-build.d");
    md($makedir);

    if($hdrdir)
    {
      cdrun($hdrdir, qw[make include/linux/version.h]);
      optcdrun($hdrdir, qw[make include/asm]) || # 2.6.x
          cdrun($hdrdir, qw[make symlinks]); # 2.4.x
    }

    my($emdir) = shellescape($makedir);
    my($ehdir) = defined($hdrdir) ? (shellescape($hdrdir)) : ();
    my($mftext) = "# $genby\n\nall:\n" .
        "\tyes '' | make -C $ehdir oldconfig dep\n" . # mtools, LVM2...
        "\t\$(MAKE) -C $emdir\n\n" .
        "install:\n\t\$(MAKE) -C $emdir install\n";
    my($inclist) = "include/linux include/asm/. include/asm-generic";
    $mftext .= "\t\(cd $ehdir && tar c $inclist) | (cd \$(DESTDIR) && tar x)\n"
        if $ehdir;
    writefile(path($dir, "Makefile"), $mftext);

    my(%confopts) = ("--prefix=$prefix" => 1);
    $confopts{"--with-headers=$hdrdir/include"} = 1 if $hdrdir;
    my($cfg) = path($glibcdir, "configure");
    patch
    {
      $confopts{$1} = 1 if /(--(enable-add-ons|with-tls))\b/;
    } $cfg if reconfigure;
    cdrunconf($makedir, qw(sh ../configure), sort(keys(%confopts)));

    return $dir;
  }

  # Write a custom Makefile for Sun J2SDK (grumble grumble).
  if(-x(path($dir, qw[jre bin java])))
  {
    my($mftext) = "# $genby" . q{

all:
  for i in "" `find . -name '*.pack'`; do [ -n "$$i" ] && \
    lib/unpack $$i "`dirname $$i`/`basename $$i .pack`.jar"; rm -f $$i; done

install:
  tar c */ | (cd $(DESTDIR)/usr && tar x)
};
    $mftext =~ s/^  /\t/gm;
    writefile(path($dir, "Makefile"), $mftext);
    return $dir;
  }

  # look for Unixish or OS-specific Makefile in a subdir and mv it here
  # e.g. zip -> unix/Makefile; libpng -> scripts/makefile.linux
  # note that this rule would incorrectly grab a spurious subdirectory
  # Makefile from glibc+linuxthreads or j2sdk 1.5 if the above rules didn't
  # come first
  return $dir unless dfs
  (
    $dir,
    sub { true },
    sub
    {
      my($rel) = @_;
      return true unless $rel =~ /makefile/i;
      return true unless $rel =~ /$^O|\bunix/i;
      mv($_, path($dir, "Makefile"));
      return false;
    },
    sub { true }
  );

  # Maybe there's just an install script of some kind that we need to run.
  # Create an appropriate Makefile.
  for(qw[install.sh INSTALL install.pl vmware-install.pl])
  {
    my($script) = path($dir, $_);
    if(-x($script))
    {
      my(@cmd) = "./$_";
      my($isscript, $useprefix, $prefixenvvar);
      patch
      {
        $isscript ||= /^#!/;
        $useprefix ||= /--prefix=/;
        s/\bOutputLicense\b/true/g unless /\(/; # acroread
        $prefixenvvar = $1 if /\b(InstallDir)\b/; # acroread
        s/not is_root\(\)/0/; # vmware
      } $script;
      next unless $isscript;
      unshift(@cmd, "$prefixenvvar=$prefix") if defined($prefixenvvar);
      push(@cmd, "--prefix=$prefix") if $useprefix;
      writefile(path($dir, "Makefile"),
          "# $genby\n\nall:\n\ttrue\n\ninstall:\n\t@cmd\n");
      return $dir;
    }
  }

  # Construct a Makefile to invoke setup.py on behalf of certain Python source
  # packages (notably BitTorrent):
  if(-r(path($dir, "setup.py")))
  {
    writefile
    (
      path($dir, "Makefile"),
      "# $genby\n\n",
      "all:\n\tpython setup.py build\n\n",
      "install:\n\tpython setup.py install " .
          "--prefix=\Q$prefix\E --root=\$(DESTDIR)\n",
    );
    return $dir;
  }

  # some packages (e.g. htmltidy) expect us to locate and run yet another
  # shell script that generates the real configure script that generates....
  for(grep(-r(path($dir, $_)), "build/gnuauto/setup.sh"))
  {
    cdrun($dir, "sh", $_);
    return &configure($dir, $prefix) if -x(path($dir, "configure"));
  }

  # try looking in promisingly-named subdirectories
  -d && return &configure($_, $prefix) foreach map(path($dir, $_), qw[src]);

  # construct a Makefile for various intransigent binary packages
  my(%file2dir);
  %file2dir = () unless whiledir
  {
    my($name) = @_;
    local($_) = path($dir, $name);
    return false if !-f;
    return $file2dir{$name} = "/usr/lib/netscape/plugins"
        if $name =~ /flashplayer\.(xpt|so)$/; # flash player 6
    return $file2dir{$name} = "/bin"
        if $name =~ /^[a-z]+$/ && -x && -B; # upx
    return $file2dir{$name} = "/man/man1"
        if $name =~ /^[a-z]+\.1$/ && !-x && -T;
    $name =~ /readme|flashplayer-installer|^[A-Z]+$|\.(doc|html)$/;
  } $dir;
  if(%file2dir)
  {
    my($mftext) = "# $genby\nPREFIX=$prefix\nall:\n\ttrue\n\ninstall:\n";
    for(sort(keys(%file2dir)))
    {
      my($d) = $file2dir{$_};
      $mftext .= "\tmkdir -p $d\n\tcp $_ \$(DESTDIR)\$(PREFIX)$d\n";
    }
    writefile(path($dir, "Makefile"), $mftext);
    return $dir;
  }

  # getting desperate now -- try to construct a Makefile from thin air
  my(@prog, @sources, @man);
  dfs
  (
    $dir,
    sub { true },
    sub
    {
      my($file) = @_;
      if(/\.c$/)
      {
        push(@sources, $file);
        push(@prog, stripext(basename($_)))
            if grep { /\bmain\b/ } readfile($_);
      }
      push(@man, $file) if /\.1$/ || ($file =~ s/\.man$/.1/);
      true;
    },
    sub { true }
  );

  # give up if our still-hypothetical Makefile is looking too implausible
  error("can't figure out how to compile in $dir")
      unless scalar(@prog) == 1 && @sources && scalar(@sources) < 100;

  my($mftext) = qq[# $genby

PREFIX=$prefix
BINDIR=\$(PREFIX)/bin
MANDIR=\$(PREFIX)/man/man1

@prog: @sources

install: @prog
\tcp @prog \$(BINDIR)
];
  $mftext .= "\tcp @man \$(MANDIR)\n" if @man;

  writefile(path($dir, "Makefile"), $mftext);
  return $dir;
}

sub make($)
{
  my($dir) = @_;
  my($mf) = makefile($dir) || error("no Makefile found");

  my($abort) = false;
  my($ok) = true;
  my($systype) = false;
  my($lk) = false; # blatant special case for older Linux kernels
  my($xf86) = false; # blatant special case for XFree86
  my($please) = ""; # blatant special case for xdaliclock
  my($figlet, $ocaml); # further eponymous special case
  my($menuconfig); # busybox, uClibc
  my($silentoldconfig); # newer linux kernels

  explain("examining $mf...");
  patch
  {
    $systype ||= /You must specify the system which you want to compil/;#mpg123
    $systype ||= /If you're not sure about the characteristics of your /;#unzip
    $systype ||= /^\t\@echo 'Choose target:'$/; # plugger 5.0
    $lk ||= /^do-it-all:.*\bvmlinux\b/;
    $xf86 ||= /Please use make World/i;
    $ocaml ||= /^\# For users who don't read the INSTALL file$/; #thanks ocaml!
    $please = $1 if /  please make one of: "([^"]+)"/;
    $abort ||= /^all:[^\#]*\binstall\b/; # all implies install (e.g. man-pages)
    s/^DEFAULTFONTDIR = fonts$/# $&/ if $figlet;
    $figlet ||= m!^DEFAULTFONTDIR = /usr.*/figlet$!;
    $menuconfig ||= m!^all: menuconfig$!;
    $silentoldconfig ||= /Makefile silentoldconfig$/;
    s!(^PERL\s*=\s*)(/usr/.*/perl)($)!$1 . (-x($2) ? $2 : which("perl")) . $3!e
        if reconfigure; # psutils/p17
  } $mf;

  return false if $abort;
  my(@prog) = "make";
  my(@targets);
  @targets = $^O if $systype;
  @targets = qw[oldconfig dep bzImage] if $lk;
  @targets = qw[oldconfig all] if $menuconfig || $silentoldconfig;
  @targets = "World" if $xf86;
  @targets = qw[world opt] if $ocaml;
  @targets = $please if $please;

  if(($lk || $silentoldconfig) && reconfigure)
  {
    my($in) = path("/proc", "config.gz");
    my($out) = path($dir, ".config");
    optrun("gunzip < " . shellescape($in) . " > " . shellescape($out))
        if -r($in) && !-e($out)
  }

  my(@args) = splitwords(makeappend);
  return cdrun($dir, @prog, @args) unless @targets;
  cdrun($dir, @prog, $_, @args) foreach @targets;
  return true;
}

sub install($$)
{
  my($makedir, $rootdir) = @_;
  my($mf) = makefile($makedir) || error("no Makefile found");
  my(@trace);
  @trace = qw[strace -s 256 -f -F -o make.install.strace] if debugrewrite;
  @trace = qw[ktrace -i -f make.install.ktrace] if @trace && $^O =~ /bsd/i;
  local($ENV{ROOT}) = $rootdir; # lilo
  local($ENV{DESTDIR}) = $rootdir; # not always on command line due to libtiff
  local($ENV{install_root}) = $rootdir;
  local($ENV{PREFIX}) = $rootdir; # airhook v2
  announce("export", "$_=$ENV{$_}") for (qw[ROOT DESTDIR install_root PREFIX]);
  my(@targets) = "install";
  my($man, $subdir, $netpbm, $usedestdir, $nodestdir, $useinstallprefix,
      $cdrtools, $e2fsprogs, $modules);
  whilefile
  {
    $man ||= /^install\.man:/;
    $subdir = $1 if /  to install the X version: "cd (\w+);/; # xdaliclock
    $netpbm ||= /^\t\@echo "  make package pkgdir=DIR"$/;
    $usedestdir ||= /\b(DESTDIR|Makefile\.in)\b/; # atop, glibc; not libtiff!
    $nodestdir ||= m!^\s*DESTDIR\s*=[^#]*/bin\s*$!; # figlet
    $useinstallprefix ||= m!INSTALL_PREFIX is for package builders!; # openssl
    $cdrtools ||= / Due to a bug in SunPRO make we need special rules /;
    $e2fsprogs ||= /^\t.* e2fsck .* ; then \$\(MAKE\) install-libs ; fi/;
    $modules ||= /^modules_install: _modinst_/; # linux 2.6.x
    true
  } $mf;
  my($cf) = path($makedir, ".config");
  $modules &&= whilefile { !/ CONFIG_MODULES is not/ } $cf if -r($cf);
  $netpbm &&= -x(path($makedir, "installnetpbm")) && path($makedir, "pkg");
  return &install(path($makedir, $subdir), $rootdir) if $subdir;
  push(@targets, "install.man") if $man && reconfigure; # e.g. XFree86
  push(@targets, "install-libs") if $e2fsprogs && reconfigure;
  @targets = ("package", "pkgdir=$netpbm") if $netpbm;
  @targets = "upgrade" if -r(path($makedir, "postfix-install")); # postfix
  push(@targets, "DESTDIR=$rootdir") if $usedestdir && !$nodestdir;
  push(@targets, "install_root=$rootdir") if $usedestdir; # glibc
  push(@targets, "PREFIX=$rootdir") if $usedestdir; # busybox
  push(@targets, "INSTALL_PREFIX=$rootdir") if $useinstallprefix; # openssl
  push(@targets, "INS_BASE=$rootdir") if $cdrtools;
  push(@targets, "RUN_QUERY_LOADER_TEST=true", "RUN_QUERY_IMMODULES_TEST=true")
      if -d(path($makedir, "gdk-pixbuf")); # gtk+
  push(@targets, "modules_install", "INSTALL_MOD_PATH=$rootdir") if $modules;
  cdrun($makedir, @trace, "make", @targets);
  run(@trace, "sh", "-c", "cp -R '$netpbm'/*/ '$rootdir'") if $netpbm;
  error("trace complete; aborting") if debugrewrite;
}

sub stddirs()
{
  my(@result) =
  (
    qw[bin boot etc include info lib libexec man share src var],
    map(path("man", "man$_"), 1..9), path(qw[var spool]),
    path(qw[etc rc.d]), map(path("etc", "rc.d", "rc$_.d"), 0..6), # vmware
    path(qw[var run]), # hotplug/2004_01_05
    path(qw[share aclocal]), # librep/0.16.1
    "hspkg", # holding area for Haskell package files; see sub helphspkg()
  );
  sort(@result);
}

sub stdlinks()
{
  (
    "usr" => ".",
    "local" => ".",
    "X11R6" => ".",
    "sbin" => "bin",
    "games" => "bin",
    "share/man" => "../man",
    "share/info" => "../info",
  );
}

sub rootlinks() { stdlinks }

sub mkrootdir($$)
{
  my($rootdir, $armdir) = @_;
  md($rootdir);
  md(path($rootdir, $_)) foreach stddirs;
  my(%link) = rootlinks;
  ln($link{$_}, path($rootdir, $_)) foreach keys(%link);
  my($p) = $rootdir;
  optrelln($rootdir, $p = path($p, $_)) for unpath($armdir), unpath($rootdir);
}

sub mkxmlcatalog($@)
{
  my($name, @contents) = @_;
  writefile($name, qq[<?xml version="1.0"?>
<!DOCTYPE catalog PUBLIC "-//OASIS//DTD Entity Resolution XML Catalog V1.0//EN" "http://www.oasis-open.org/committees/entity/release/1.0/catalog.dtd">
<catalog xmlns="urn:oasis:names:tc:entity:xmlns:xml:catalog">\n],
      map("  $_\n", @contents), "</catalog>\n");
}

sub compiledata($$)
{
  my($srcdir, $rootdir) = @_;
  my(@installdir);

  # docbook-xml, maybe other things too?
  my($cat) = path($srcdir, "catalog.xml");
  if(-r($cat))
  {
    my($name, $version, $dup);
    patch
    {
      ($name, $version) = (lc($1), $2) if m!//DTD (\w+) XML V([\d\.]+)//!i;
      $dup .= $_ if $dup;
      $dup = "$1.1.2/$2" if reconfigure &&
          m!(<public publicId="-//OASIS//DTD DocBook XML V4).*(/EN".*)!s;
      ($dup, $_) = (undef, "$_$dup") if $dup && />/;
    } $cat;
    @installdir = (qw(share xml), $name, $version) if $version;
  }

  # docbook-xsl
  my(@ls) = ls($srcdir);
  if(!@installdir && scalar(@ls) == 1 && $ls[0] =~ /^docbook-xsl-/)
  {
    $srcdir = path($srcdir, $ls[0]);
    @installdir = qw(share xml docbook-xsl);
    my($cat) = path($srcdir, "catalog.xml");
    my($rewritePrefix) = path(armdir, @installdir);
    mkxmlcatalog($cat, qq[<rewriteURI uriStartString="http://docbook.sourceforge.net/release/xsl/current" rewritePrefix="$rewritePrefix"/>]) unless -r($cat);
  }

  return false unless @installdir;
  my($dir) = $rootdir;
  for(@installdir)
  {
    md($dir);
    $dir = path($dir, $_);
  }
  return mv($srcdir, $dir);
}

sub compilebin($$)
{
  my($srcdir, $rootdir) = @_;
  return false if -d(path($srcdir, "xc")); # Xaw3d
  my($one);
  my($ok);
  abswhiledir
  (
    sub
    {
      $one = $one ? 0 : $_ unless defined($one);
      $ok ||= m!/(usr|bin|etc|lib|sbin)$!;
      -d
    },
    $srcdir
  ) && ($ok ? mv($srcdir, $rootdir) : ($one && &compilebin($one, $rootdir)));
}

sub compilehelp($$$)
{
  my($srcdir, $rootdir, $helperdir) = @_;
  my($makedir) = makedir($srcdir);

  my(%initenv) = inithelpers($srcdir, $rootdir, $helperdir);
  return false unless %initenv;

  defined($ENV{$_}) && $ENV{$_} eq $initenv{$_} ||
      announce("export", "$_=$initenv{$_}") foreach keys(%initenv);
  local(%ENV) = %initenv;

  $makedir = configure($makedir, armdir);
  make($makedir);
  mkrootdir($rootdir, armdir);
  armhelpers($helperdir);
  install($makedir, $rootdir);

  !defined($ENV{$_}) ? announce("unset", $_) :
      ($ENV{$_} eq $initenv{$_} || announce("export", "$_=$ENV{$_}"))
      foreach keys(%initenv);

  return true;
}

sub fixbrokenrootlink($)
{
  # stdlinks fool XFree86 and busybox into creating broken symlinks; fix them!
  my($link) = @_;
  my($dest) = readlink($link);
  defined($dest) || error("not a link: $link");
  explain("found broken symlink: $link -> $dest");
  while($dest =~ s!\.\./!! && !-e($link))
  {
    rm($link);
    ln($dest, $link);
  }
  rm($link) unless -e($link);
  true;
}

sub fixrootfile($)
{
  my($file) = @_;
  return -e($file) ? true : fixbrokenrootlink($file) if -l($file);
  safechmod(-x($file) ? 0555 : 0444, $file);
}

sub polishrootdir($$)
{
  my($rootdir, $armdir) = @_;

  my(%link) = rootlinks;
  -l && rm($_) foreach map { path($rootdir, $_) }
      (keys(%link), unpath($rootdir), unpath($armdir));

  optrmall(path($rootdir, "info", "dir"));

  my($total, %count) = 0;
  dfs
  (
    $rootdir,
    sub { $count{$_} = $total; true },
    sub { fixrootfile($_); ++$total },
    sub { $count{$_} < $total ? !protect || safechmod(0555, $_) : rd($_) }
  );
  $total || error("no files found in $rootdir");

  # XFree86 4.3.0 libGL.so needs this due to some kind of bug/interaction,
  # as do some binary packages:
  my($libdir) = path($rootdir, "lib");
  if(fixliblinks && -d($libdir))
  {
    my(%liblinks);
    fordir
    {
      return unless /^(lib.*\.so)((\.[\d]+)+)$/;
      my($base, $ext) = ($1, $2);
      return if exists($liblinks{$base}) && length($liblinks{$base}) > length;
      $liblinks{$base} = $_;
      for $ext (split(/\./, $ext))
      {
        next unless $ext;
        $base .= ".$ext";
        next if $_ eq $base;
        $liblinks{$base} = $_;
      }
    } $libdir;
    my($mode) = getmode($libdir);
    for(sort(keys(%liblinks)))
    {
      my($from, $to) = ($liblinks{$_}, path($libdir, $_));
      if(!-e($to) && !-l($to))
      {
        safechmod(0777, $libdir);
        ln($from, $to);
      }
    }
    safechmod($mode, $libdir);
  }
}

sub wraphaskell($$$)
{
  my($srcdir, $rootdir, $helperdir) = @_;
  return true unless -x(path($rootdir, qw(bin ghc)));
  my($script) = path($helperdir, "ghc-pkg");
  if(!-x($script))
  {
    optmd($helperdir);
    helphspkg($rootdir, $helperdir, "wrap-ghc");
    $script = path($helperdir, "wrap-ghc");
    armhelpers($helperdir);
  }
  run($script, "--toast-install-wrapper-only");
}

sub compile($$$)
{
  my($srcdir, $rootdir, $helperdir) = @_;
  compiledata($srcdir, $rootdir) ||
      compilebin($srcdir, $rootdir) ||
      compilehelp($srcdir, $rootdir, $helperdir);
  wraphaskell($srcdir, $rootdir, $helperdir) if hspkg;
  polishrootdir($rootdir, armdir);
}

sub clean(@)
{
  whilebuild
  {
    my($name, $version, $build) = @_;
    my($builddir) = pkgpath($name, $version, $build);
    return rmall($builddir) if isbroken($name, $version, $build);
    return true unless isbuilt($name, $version, $build);
    my($srcdir) = path($builddir, srcdir);
    my($helperdir) = path($builddir, helperdir);
    optrmall($srcdir, $helperdir);
  } @_;

  return true;
}

sub purge(@)
{
  my($name, $version, $build, @urls) = @_;
  $build && error;

  for $name (allnames($name))
  {
    for $version (allversions($name, $version))
    {
      my($archivedir) = path(pkgpath($name, $version), archivedir);
      optrmall($archivedir);
    }
  }

  return true;
}

sub rebuild(@)
{
  my($name, $version, $build, @urls) = @_;
  $build && error;

  ($name, $version) = get(@_) if !isstored($name, $version);
  defined($name) || error;
  defined($version) || error;

  clean($name, $version) if autoclean;

  local(%ENV) = %ENV;
  if(ccache)
  {
    my($storecachedir) = path(storedir, "ccache");
    my($cachedir);
    if(exists($ENV{"CCACHE_DIR"}))
    {
      $cachedir = $ENV{"CCACHE_DIR"};
    }
    elsif(superuser)
    {
      optmd($cachedir = $storecachedir);
    }
    elsif(exists($ENV{"HOME"}) && -d($ENV{"HOME"}))
    {
      $cachedir = path($ENV{"HOME"}, ".ccache");
    }

    chownnonroot($cachedir) if superuser && !belongstononroot($cachedir) &&
        optsamefile($cachedir, $storecachedir);

    $ENV{"CCACHE_DIR"} = $cachedir;
    announce("export", "CCACHE_DIR=$cachedir");
  }

  my($verdir) = pkgpath($name, $version);
  my(@allbuilds) = allbuilds($name, $version);
  $build = @allbuilds ? max(@allbuilds) : 0;
  my($errmsg, $builddir) = true;
  while($errmsg)
  {
    $build++;
    $builddir = path($verdir, $build);
    $errmsg = mkdir($builddir, 0777) ? false : $!;
    error("mkdir $builddir: $errmsg") if $errmsg && !-d($builddir);
  }
  announce("mkdir", $builddir);
  chownnonroot($builddir);

  local(*CHILD);
  my($pid);
  if(!($pid = open(CHILD, "-|"))) # child
  {
    defined($pid) || error("fork: $!");

    my(@times) = gettimes;

    open(STDERR, ">&STDOUT") || error("dup stdout: $!");
    verbosify;
    benice;
    dropprivs;
    showprebuildinfo($name, $version, $build);
    yes;
    setbuildenv if autoenv;

    my($archivedir) = path($verdir, archivedir);
    my($srcdir) = path($builddir, srcdir);
    my($helperdir) = path($builddir, helperdir);
    my($rootdir) = path($builddir, rootdir);
    my($armdirlink) = path($builddir, armdirlink);

    ln(armdir, $armdirlink);
    md($srcdir);
    extract($archivedir, $srcdir);
    compile($srcdir, $rootdir, $helperdir);

    showtimedeltas(@times);
    exit(0);
  }

  $SIG{INT} = "IGNORE";
  my($tmplogname) = addtmp(path($builddir, buildlog));
  local(*LOG);
  safeopen(*LOG, ">", $tmplogname);

  while(<CHILD>)
  {
    print LOG $_;
    chomp;
    say("  $_\n");
  }

  my($success) = close(CHILD);
  $SIG{INT} = "DEFAULT";
  my($msg) = "child returned $?";
  close(LOG) || error("close $tmplogname for write: $!");

  if($success && superuser)
  {
    announce("chown", "-Rh", "root:root", $builddir);
    dfs
    (
      $builddir,
      sub { chown(0, 0, $_) || ($success = !($msg = "chown $_: $!")) },
      sub
      {
        if(!-l)
        {
          return chown(0, 0, $_) || ($success = !($msg = "chown $_: $!"))
        }
        else
        {
          my($source) = readlink;
          error("readlink $_: $!") unless defined($source);
          return (unlink || ($success = !($msg = "unlink $_: $!"))) &&
              (symlink($source, $_) ||
              ($success = !($msg = "symlink $source $_: $!")));
        }
      },
      sub { true }
    );
  }

  my($logname) = path($builddir, $success ? buildlog : brokenlog);
  mv($tmplogname, $logname);
  $success || error($msg);

  clean($name, $version, $build) if autoclean;
  purge($name, $version) if autopurge;
  arm($name, $version, $build) if autoarm && isarmedmatch($name, $version);

  if(autodemolish || autoremove)
  {
    my($aversion, $abuild);
    for $aversion (allversions($name, crossversion ? undef : $version))
    {
      if(autodemolish)
      {
        for $abuild (allbuilds($name, $aversion))
        {
          next if $aversion eq $version && $abuild == $build;
          next if skipmismatched && ismismatched($name, $aversion, $abuild);
          next if !autodisarm && isarmed($name, $aversion, $abuild);
          demolish($name, $aversion, $abuild);
        }
      }
      if(autoremove)
      {
        next if $aversion eq $version;
        next if !autodisarm && isarmed($name, $aversion);
        remove($name, $aversion);
      }
    }
  }

  ($name, $version, $build);
}

sub build(@)
{
  my($name, $version, $build, @urls) = @_;
  $build && error;
  $build = defined($version) ? latestbuilt($name, $version) : undef;
  return $build ? ($name, $version, $build) : rebuild(@_);
}

##############################################################################

sub displace($)
{
  local($_) = @_;
  if(-e || -l)
  {
    error("refusing to displace directory: $_") if -d && !-l;
    my($offname) = addoff($_);
    &displace($offname);
    mv($_, $offname);
  }
  $_;
}

sub isempty($)
{
  my($dir) = @_;
  my($result) = true;
  whiledir { $result = false } $dir;
  $result;
}

BEGIN
{
  my(%locks);

  sub lock($)
  {
    my($path) = @_;
    error("$path already locked") if $locks{$path};
    local(*LOCK);
    safeopen(*LOCK, "<", $path);
    $locks{$path} = *LOCK{IO};
    return unless useflock;
    if(!flock(LOCK, 6)) # LOCK_EX | LOCK_NB
    {
      explain("waiting for lock on $path");
      flock(LOCK, 2) || error("flock $path: $!"); # LOCK_EX
    }
  }

  sub unlock($)
  {
    my($path) = @_;
    my($lock) = $locks{$path};
    error("$path not locked") unless $lock;
    flock($lock, 8) || error("unlock $path: $!") if useflock; # LOCK_UN
    close($lock) || error("close $path: $!");
    delete($locks{$path});
  }
}

sub rebuildinfodir($)
{
  my($armdir) = @_;
  my($dir) = path($armdir, "info");
  return true unless -d($dir);

  my($dirfile) = path($dir, "dir");

  # remove old links left by previous version of toast:
  my($oldfile) = addoff($dirfile);
  while(-e($oldfile) || -l($oldfile))
  {
    rm($oldfile);
    $oldfile = addoff($oldfile);
  }

  my($mode) = getmode($dir);

  if(!infodir)
  {
    if(-e($dirfile) || -l($dirfile))
    {
      safechmod(0777, $dir);
      rm($dirfile);
    }
  }
  else
  {
    my($tmpfile) = addtmp($dirfile);
    if(-e($tmpfile) || -l($tmpfile))
    {
      safechmod(0777, $dir);
      rm($tmpfile);
    }
    my($tmpsuffix) = tmpsuffix;
    my($offsuffix) = offsuffix;
    abswhiledir
    {
      return true if m!(/dir|\Q$tmpsuffix\E|\Q$offsuffix\E|-\d+(\.info)?)$!;
      safechmod(0777, $dir);
      optrun("install-info", $_, $tmpfile);
      true;
    } $dir;
    mv($tmpfile, $dirfile) if -e($tmpfile);
  }

  safechmod($mode, $dir);
}

sub rebuildxmlcatalog(@)
{
  my($armdir) = @_;
  my($etcdir) = path($armdir, "etc");
  my($xmldir) = path($etcdir, "xml");
  my($master) = path($xmldir, "toast-xml-catalog");
  my(@subcats);

  if(xmlcatalog)
  {
    @subcats = -d($xmldir) ? grep(m!/catalog[^/]*$!, absls($xmldir)) : ();
    my($dir) = path($armdir, qw[share xml]);
    dfs
    (
      $dir,
      sub { true },
      sub { push(@subcats, $_) if m!/catalog.xml$!; true },
      sub { true },
    ) if -d($dir);
  }

  return -e($master) || -l($master) ? rm($master) : true unless @subcats;

  for(grep(!-d, $etcdir, $xmldir))
  {
    my($parent) = dirname($_);
    my($mode) = getmode($parent);
    safechmod(0777, $parent);
    md($_);
    safechmod($mode, $parent);
  }

  my($mode) = getmode($xmldir);
  safechmod(0777, $xmldir);
  safechmod(0666, $master) if -e($master);
  mkxmlcatalog($master, map(qq[<nextCatalog catalog="$_"/>], sort(@subcats)));
  safechmod($mode, $xmldir);

  if(protect)
  {
    safechmod(0444, $master);
    safechmod(0555, $_) for($xmldir, $etcdir, $armdir);
  }
}

sub rebuildhspkg($)
{
  my($armdir) = @_;

  my($dir) = path($armdir, "hspkg");
  my(@pkgs);
  @pkgs = absls($dir) if hspkg and -d($dir);

  my($etcdir) = path($armdir, "etc");
  my($file) = path($etcdir, "toast-hs-package.conf");
  return -e($file) || -l($file) ? rm($file) : true unless @pkgs;

  if(!-d($etcdir))
  {
    my($mode) = getmode($armdir);
    safechmod(0777, $armdir);
    md(path($etcdir));
    safechmod($mode, $armdir);
  }

  my($mode) = getmode($etcdir);
  safechmod(0777, $etcdir);
  safechmod(0666, $file) if -e($file);
  writefile($file, "[]\n");
  optrun("ghc-pkg", "--force", "-f", $file, "update", $_) for(@pkgs);
  optrmall("$file.old");
  safechmod($mode, $etcdir);

  if(protect)
  {
    safechmod(0444, $file);
    safechmod(0555, $_) for($etcdir, $armdir);
  }
}

sub arm(@)
{
  my($name, $version, $build, @urls) = @_;
  ($name, $version, $build) = build(@_) unless $build;

  return ($name, $version, $build) if isarmed($name, $version, $build);

  optmd(armdir);
  lock(armdir);

  my($mode) = (protect ? 0555 : 0777) & ~umask;
  if(getmode(armdir) != $mode)
  {
    dfs
    (
      armdir,
      sub { safechmod($mode, $_) },
      sub { true },
      sub { true }
    );
  }

  my(%link) = stdlinks;
  for(keys(%link))
  {
    my($abs) = path(armdir, $_);
    if(!-e($abs) && !-l($abs))
    {
      my($dir) = dirname($abs);
      if(!-d($dir))
      {
        my($parent) = dirname($dir);
        safechmod(0777, $parent);
        md($dir);
        safechmod($mode, $parent);
      }
      safechmod(0777, $dir);
      ln($link{$_}, $abs);
      safechmod($mode, $dir);
    }
  }

  $build || error;
  my($rootdir) = path(pkgpath($name, $version, $build), rootdir);
  dfs
  (
    $rootdir,
    sub
    {
      my($dir) = optpath(armdir, $_[0]);
      if(!-d($dir))
      {
        safechmod(0777, dirname($dir)) if defined($_[0]);
        md($dir);
      }
      return true;
    },
    sub
    {
      my($target) = optpath(armdir, $_[0]);
      safechmod(0777, dirname($target));
      displace($target);
      relative ? relln($_, $target) : ln($_, $target);
    },
    sub { safechmod($mode, optpath(armdir, $_[0])) }
  );

  rebuildinfodir(armdir);
  rebuildxmlcatalog(armdir);
  rebuildhspkg(armdir);
  run(postarmprog) if postarmprog;

  unlock(armdir);

  if(autodisarm)
  {
    my($aversion, $abuild);
    for $aversion (allversions($name, crossversion ? undef : $version))
    {
      for $abuild (allbuilds($name, $aversion))
      {
        disarm($name, $aversion, $abuild)
            unless $aversion eq $version && $abuild == $build;
      }
    }
  }

  ($name, $version, $build);
}

sub disarm(@)
{
  my(@nvb) = @_; # see nvb comment below

  my(@armdirs) = allarmdirs;
  my($i, $armdir, $anychanged);
  for $armdir (@armdirs)
  {
    lock($armdir);
    my($changed);

    whilebuild
    {
      my($name, $version, $build) = @_;

      my($rootdir) = path(pkgpath($name, $version, $build), rootdir);
      my(@dirmodes);
      -d($rootdir) && dfs  # ignore broken packages
      (
        $rootdir,
        sub
        {
          my($rel) = @_;
          my($armsubdir) = optpath($armdir, $rel);
          if(-d($armsubdir) && !-l($armsubdir))
          {
            push(@dirmodes, getmode($armsubdir));
          }
          return true;
        },
        sub
        {
          my($rel) = @_;
          my($armfile) = path($armdir, $rel);
          while(-e($armfile) || -l($armfile))
          {
            if(optsamefile($armfile, $_))
            {
              safechmod(0777, dirname($armfile));
              rm($armfile);
              my($off);
              while(-e($off = addoff($armfile)) || -l($off))
              {
                mv($off, $armfile);
                $armfile = $off;
              }
              return $changed = true;
            }
            $armfile = addoff($armfile);
          }
          return true;
        },
        sub
        {
          my($rel) = @_;
          my($armsubdir) = optpath($armdir, $rel);
          if(-d($armsubdir) && !-l($armsubdir))
          {
            my($mode) = pop(@dirmodes);
            return safechmod($mode, $armsubdir) unless isempty($armsubdir);
            safechmod(0777, dirname($armsubdir)) if @dirmodes;
            rd($armsubdir);
          }
          return true;
        }
      );
      error if @dirmodes;
      return true;
    } @nvb; # can't replace @nvb with ($n, $v, $b) due to perl 5.6.1 bug (?)

    rebuildinfodir($armdir) if $changed;
    rebuildxmlcatalog($armdir) if $changed;
    rebuildhspkg($armdir) if $changed;
    $anychanged ||= $changed;
    run(postarmprog) if ++$i == scalar(@armdirs) && $anychanged && postarmprog;
    unlock($armdir);
  }

  return true;
}

##############################################################################

sub findnewerpkg($$$@)
{
  my($name, $version, $build, @urls) = @_;
  error unless defined($name);
  error unless defined($version);
  error if defined($build);

  @urls = pkgurls($name, $version) unless @urls;
  error unless @urls;

  # Look for new version numbers that start with a digit and that don't
  # contain dashes (as in "zsh-4.0.6-doc.tar.gz"),
  # unless the original version number lacked those properties.
  my($verchar) = $version =~ /-/ ? '.' : '[^\-]';
  my($verpat) = $version =~ /^\d/ ? "\\d$verchar*" : "$verchar+";

  my(%linkmap, %candidates, @newurls);
  my($hasver) = false;
  for(@urls)
  {
    if(/^(cvs.*)\#\Q$version\E$/)
    {
      my($newurl) = cleanurl($1);
      my(undef, $newv) = guessnv($newurl);
      push(@newurls, $newurl);
      $candidates{$newv} = $hasver = true;
      next;
    }
    m!^((http|ftp|file)://[^\?]+/)([^\?/]*)(\?.*)?$!i ||
        error("bad URL for upgrade: $_");
    my($dirname, $basename, $query) = undeftoempty($1, $3, $4);
    if($basename !~ /^(.*)\Q$version\E(.*)$/)
    {
      push(@newurls, $_); # URL has no version number; use as-is
    }
    else
    {
      $hasver = true;
      my($pre, $post) = ($1, $2);
      $linkmap{$dirname} = [linksfromurl($dirname)]
          unless exists($linkmap{$dirname});
      my(@links) = @{$linkmap{$dirname}};
      my(%vermap);
      for(@links)
      {
        if(m!/\Q$pre\E($verpat)\Q$post\E(\?.*)?$!)
        {
          $vermap{$1} = $_;
          $candidates{$1} = 1;
        }
      }
      push(@newurls, \%vermap);
    }
  }

  return &findnewerpkg($name, $version, $build, @urls)
      if !$hasver && $version =~ s/-toast\d+$//;

  my($pkgname) = pkgname($name, $version);
  error("URLs for $pkgname don't seem version-specific") unless $hasver;

  my(@result);
  for(sort cmpab keys(%candidates))
  {
    my($candidate) = $_;
    my($ok) = true;
    my(@curls) = @newurls;
    for(@curls)
    {
      next unless ref;
      my(%vermap) = %$_;
      if(!exists($vermap{$candidate}))
      {
        $ok = false;
        last;
      }
      $_ = $vermap{$candidate};
    }
    push(@result, [$name, $candidate, undef, @curls]) if $ok;
  }

  error("can't find consistent URLs for $pkgname") unless @result;
  return @result;
}

sub find(@)
{
  my($name, $version, $build, @urls) = @_;
  error unless defined($name);
  error if defined($build);

  my(@pkgs) = defined($version) && (@urls || isadded($name, $version))
      ? findnewerpkg($name, $version, $build, @urls)
      : findnewpkg($name, $version);

  error unless @pkgs;
  $name = ${$pkgs[0]}[0];
  $name eq ${$pkgs[$_]}[0] or error for 0..$#pkgs;

  say("\n");

  print("$name\n");
  for(@pkgs)
  {
    (undef, $version, undef, @urls) = @$_;
    $version = "unknown" unless defined($version);
    print("  version $version: found\n");
    print("    urls:\n");
    print("      $_\n") for(@urls);
  }

  return true;
}

sub upgrade(@)
{
  my($name, $version, $build, @urls) = @_;
  error if defined($build);

  my(@pkgs) =
      reverse(choose($version, findnewerpkg($name, $version, $build, @urls)));
  my(@cmdargs) = @{$pkgs[0]};
  my($newver) = $cmdargs[1];

  my($pkgname) = pkgname($name, $version);
  return ($name, $version, $build, @urls)
      if interactive && $version eq $newver;
  error("$pkgname appears to be the latest available version")
      if $version eq $newver;
  my(@sortvers) = sort cmpab ($version, $newver);
  error("only found older versions of $pkgname")
      if $sortvers[1] eq $version && !interactive;

  if(autoarm && isarmedmatch($name, $version))
  {
    return arm(@cmdargs);
  }
  elsif(isbuiltmatch($name, $version))
  {
    return build(@cmdargs);
  }
  elsif(isstored($name, $version))
  {
    return get(@cmdargs);
  }
  else
  {
    return add(@cmdargs);
  }
}

##############################################################################

sub ensuredisarmed($;$$)
{
  my($name, $version, $build) = @_;
  return true unless isarmed($name, $version, $build);
  error(pkgname($name, $version, $build) . " is armed") unless autodisarm;
  disarm($name, $version, $build);
}

##############################################################################

sub remove(@)
{
  my($name, $version, $build, @urls) = @_;
  $name || error;
  ensuredisarmed($name, $version, $build);
  rmall(pkgpath($name, $version, $build));
}

sub demolish(@)
{
  my($name, $version, $build, @urls) = @_;
  whilebuild { remove(@_) } @_;
}

##############################################################################

sub printopts($;$)
{
  my($name, $version) = @_;
  return true unless showopts;
  my($indent) = defined($version) ? "  " : "";
  my($opts) = loadopts($name, $version);
  return unless %{$opts};
  print("$indent  options:\n");
  for(sort(keys(%{$opts})))
  {
    my($value) = $opts->{$_};
    print("$indent    --" .  (!isboolopt($_) ? "$_=" . quote($value) :
        $value ? "$_" : "no$_") . "\n");
  }
}

sub status(@)
{
  my($name, $version, $build, @urls) = @_;
  my($result) = true;

  my(@armdirs) = allarmdirs;

  for $name (allnames($name))
  {
    print("$name\n");
    printopts($name);

    for $version (allversions($name, $version))
    {
      print("  version $version",
          isstored($name, $version) ? ": stored\n" : "\n");

      if(showurls || @urls)
      {
        my(@haveurls) = pkgurls($name, $version);
        my($mismatch) = !@urls || samelist(@haveurls, @urls)
            ? "" : " differ from those specified";
        $result = false if $mismatch;
        if(showurls || $mismatch)
        {
          print("    urls$mismatch:\n");
          print("      $_\n") foreach @haveurls;
        }
      }

      printopts($name, $version);

      for $build (allbuilds($name, $version, $build))
      {
        my($status, @notes, @armedin);
        my($normalarmdir) = armdir;
        if(isbroken($name, $version, $build))
        {
          $status = "broken";
        }
        elsif(!isbuilt($name, $version, $build))
        {
          $status = "building";
        }
        else
        {
          push(@notes, "not clean") unless isclean($name, $version, $build);
          for(@armdirs)
          {
            push(@armedin, $_) if isbuildarmedin($_, $name, $version, $build);
          }
          if(ismismatched($name, $version, $build))
          {
            $status = "mismatched";
            my($armdirlink) =
                path(pkgpath($name, $version, $build), armdirlink);
            my($builtfor) = readlink($armdirlink);
            push(@notes, "built for $builtfor") if defined($builtfor);
            push(@notes, "armed") if @armedin;
            $normalarmdir = $armdirlink;
          }
          elsif(@armedin)
          {
            $status = "armed";
          }
          else
          {
            $status = "built";
          }
        }
        my($notetext) = @notes ? " (" . join("; ", @notes) . ")" : "";
        print("    build $build: $status$notetext\n");
        if(@armedin && (scalar(@armedin) > 1 ||
            !optsamefile($armedin[0], $normalarmdir)))
        {
          print("      armed in:\n");
          print("        $_\n") for @armedin;
        }
      }
    }
  }

  return $result;
}

##############################################################################

sub edit(@)
{
  my($name, $version, $build, @urls) = @_;
  error unless defined($name);
  error if defined($build);

  ($name, $version) = get($name, $version, $build, @urls)
      unless defined($version) && isstored($name, $version);
  error unless defined($name);
  error unless defined($version);

  my($suffix) = "-$myname";
  my($oldversion) = $version =~ /^(.*)(\Q$suffix\E\d+)$/ ? $1 : $version;
  error unless defined($oldversion);
  error(pkgname($name, $oldversion) . " is no longer stored")
      unless isstored($name, $oldversion);

  my($oldverdir) = pkgpath($name, $oldversion);
  my($oldarchivedir) = path($oldverdir, archivedir);

  my($verdir) = pkgpath($name, $version);
  my($archivedir) = path($verdir, archivedir);

  my($num) = 1;
  my($newversion, $newverdir);
  while(true)
  {
    $newversion = $oldversion . $suffix . $num;
    $newverdir = pkgpath($name, $newversion);
    last if mkdir($newverdir, 0777);
    error("mkdir $newverdir: $!") unless -d($newverdir);
    $num++;
  }
  announce("mkdir", $newverdir);

  my($newarchivedir) = path($newverdir, archivedir);
  my($editdir) = path($newverdir, editdir);
  my($olddir) = path($editdir, "old");
  my($newdir) = path($editdir, "new");
  my($patchfilename) = "edit.patch";
  my($patchfile) = path($editdir, $patchfilename);
  md($editdir, $olddir, $newdir);

  chownnonroot($olddir, $newdir);

  local(*PATCH);
  safeopen(*PATCH, ">", $patchfile);
  my($pid) = fork;
  error("fork: $!") unless defined($pid);

  if(!$pid) # child
  {
    dropprivs;
    extract($oldarchivedir, $olddir);
    extract($archivedir, $newdir);
    my($prog) = length(editprog) ? editprog :
        exists($ENV{SHELL}) ? $ENV{SHELL} : "/bin/sh";
    cdrun(makedir($newdir), $prog);

    local(*DIFF, $_);
    openprog(*DIFF, "diff", "-urN", $olddir, $newdir);
    while(<DIFF>)
    {
      s!^(\+\+\+|---) (\Q$olddir\E|\Q$newdir\E)/!$1 !;
      print PATCH $_;
    }
    close(DIFF); # ignore error
    close(PATCH) or error("close $patchfile: $!");

    exit(0);
    error;
  }

  my($errmsg);
  waitpid($pid, 0) or error("waitpid $pid: $!");
  $errmsg ||= "subprocess returned $?" unless $? == 0;
  close(PATCH) or error("close $patchfile: $!");
  $errmsg ||= "no changes found" unless -s($patchfile);
  if($errmsg)
  {
    rmall($newverdir);
    error($errmsg);
  }
  rmall($olddir, $newdir);

  my(@newurls) = pkgurls($name, $oldversion);
  push(@newurls, fileurl($patchfile));
  setpkgurls($name, $newversion, @newurls);

  md($newarchivedir);
  fordir { ln(path($oldarchivedir, $_), path($newarchivedir, $_)) }
      $oldarchivedir;
  ln($patchfile, path($newarchivedir, $patchfilename));

  return build($name, $newversion, undef, @newurls);
}

##############################################################################

sub rename(@)
{
  my($sname, $sversion, $sbuild, $dname, $dversion, $dbuild) = @_;

  defined($sname) == defined($dname) || error;
  defined($sversion) == defined($dversion) || error;
  defined($sbuild) == defined($dbuild) || error;
  defined($sname) || error;
  defined($sbuild) && !defined($sversion) && error;

  my($sdir) = pkgpath($sname, $sversion, $sbuild);
  my($ddir) = pkgpath($dname, $dversion, $dbuild);

  -d($sdir) || error(pkgname($sname, $sversion, $sbuild) . " does not exist");
  -d($ddir) && error(pkgname($dname, $dversion, $dbuild) . " already exists");
  isarmed($sname, $sversion, $sbuild) &&
      error(pkgname($sname, $sversion, $sbuild) . " is armed");

  my($namedir) = pkgpath($dname);
  optmd($namedir) unless $ddir eq $namedir;
  my($versiondir) = pkgpath($dname, $dversion);
  optmd($versiondir) unless $ddir eq $versiondir;
  mv($sdir, $ddir);

  my($oldnamedir) = pkgpath($sname);
  rmdir($oldnamedir) && announce("rmdir", $oldnamedir);

  return !defined($dversion) ? ($dname) :
      !defined($dbuild) ? ($dname, $dversion) :
      ($dname, $dversion, $dbuild);
}

##############################################################################

sub change(@)
{
  my($name, $version, $build, @urls) = @_;
  error unless defined($name);
  error unless defined($version);
  error if defined($build);
  error unless @urls;

  setpkgurls($name, $version, @urls);
  ($name, $version);
}

##############################################################################

BEGIN
{
  my($checkresult);

  sub failcheck(@)
  {
    print(join(": ", @_) . "\n");
    $checkresult = false;
    return true;
  }

  sub checkbuild($$$)
  {
    my($name, $version, $build) = @_;
    my($path) = pkgpath($name, $version, $build);

    return failcheck($path, "not a directory") unless -d($path);

    # @todo check various

    fordir
    {
      /^(src|root|helpers|build\.log\.tmp|build\.log|broken\.log)$/ ||
          failcheck(path($path, $_));
    } $path;
  }

  sub checkversion($$)
  {
    my($name, $version) = @_;
    my($path) = pkgpath($name, $version);

    failcheck($path, "invalid version number") unless validversion($version);
    return failcheck($path, "not a directory") unless -d($path);

    my($urlfile) = path($path, urlfile);
    # @todo check urlfile

    my($archivedir) = path($path, archivedir);
    # @todo check archivedir

    fordir
    {
      validbuild($_) ? checkbuild($name, $version, $_) :
          /^(archive|url)(\.tmp)?$/ ||
          failcheck(path($path, $_));
    } $path;
  }

  sub checkname($)
  {
    my($name) = @_;
    my($path) = pkgpath($name);

    failcheck($path, "invalid package name") unless validname($name);
    return failcheck($path, "not a directory") unless -d($path);

    fordir
    {
      s/^v// ? checkversion($name, $_) : failcheck(path($path, $_));
    } $path;
  }

  sub checkall()
  {
    my($path) = pkgpath;

    return failcheck($path, "not found") unless -e($path);
    return failcheck($path, "not a directory") unless -d(_);
    # @todo check permissions

    fordir { checkname($_) } $path;
  }

  sub check(@)
  {
    my($name, $version, $build) = @_;

    $checkresult = true;

    defined($build) ? checkbuild($name, $version, $build) :
        defined($version) ? checkversion($name, $version) :
        defined($name) ? checkname($name) :
        checkall;

    my($msg) = "$myname check ";
    $msg .= $checkresult ? "passed" : "failed";
    $msg .= ": " . pkgname($name, $version, $build) if defined($name);
    print("$msg\n");

    return $checkresult;
  }
}

##############################################################################

sub selfopen(*)
{
  local(*SCRIPT) = @_;
  my($package, $file) = caller(0);
  safeopen(*SCRIPT, "<", $file);
}

sub depodify($)
{
  local($_) = @_;
  s/I\<([^\>]+)\>/\*$1\*/g;
  s/C\<([^\>]+)\>/\`$1\'/g;
  s/[A-Z]\<|\>//g;
  s/^=(over|back).*\r?\n?//gm;
  s/^=\w+\s+//gm;
  s/\n\n\n+/\n\n/g;
  $_;
}

sub help(@)
{
  my(@topics) = @_;
  @topics = ("commands") unless @topics;

  print << "EOF";

$myname version $myversion -- $myurl
$mycopyright
$myname comes with ABSOLUTELY NO WARRANTY; for details run "$myname license".

EOF

  local(*SCRIPT, $_);
  selfopen(*SCRIPT);

  my($usage);
  while(<SCRIPT>) { last if /^=head1 SYNOPSIS$/ }
  while(<SCRIPT>)
  {
    last if /^=/;
    $usage .= $_;
  }
  $usage =~ /^\s*(\S.*\S)\s*$/ || error;
  $usage = depodify("usage:  $1\n\n");

  my(@items, @cmds, @opts, %head, %body);
  for(1..2)
  {
    while(<SCRIPT>) { last if /^=head\d (commands|options)$/i }
    while(<SCRIPT>)
    {
      last if /^=(back|cut)/;
      if(/^=item .*\Q$myname\E (\w+)/)
      {
        @items = ($1);
        $head{$1} .= $_;
        push(@cmds, $1) unless $body{$1};
      }
      elsif(/^=item \S*-(\w+)(.*)/)
      {
        @items = ($1);
        push(@opts, $1) unless $body{$1};
        my($rest) = $2;
        push(@items, $1) while $rest =~ /-(\w+)/g;
        my($item);
        for $item (@items)
        {
          $head{$item} .= $_;
        }
      }
      else
      {
        my($item);
        for $item (@items)
        {
          $body{$item} .= $_;
        }
      }
    }
  }
  close(SCRIPT) || error;

  $head{"commands"} = "${usage}where *COMMAND* is one of the following " .
      "words:\n\n";
  my($maxcmdlen) = max(map { length } @cmds);
  for(@cmds)
  {
    $body{$_} =~ /\w[^\.]+\./ || error;
    my($spaces) = " " x ($maxcmdlen - length);
    $body{"commands"} .= "  $_  $spaces$&\n";
  }
  $body{"commands"} .= "\nFor help on a specific command: " .
      "  $myname help *COMMAND*\n";
  $body{"commands"} .= "For a list of available options:" .
      "  $myname help options\n\n";

  $head{"options"} = "${usage}where *OPTION* is one of the following:\n\n";
  for(@opts)
  {
    $body{"options"} =~ s/\n$/ |\n/ if $body{"options"};
    $body{"options"} .= "  " . depodify($head{$_});
  }
  $body{"options"} .= qq{\nFor help on --*OPTNAME*:  "$myname help *OPTNAME*"}
      . "  (leave out the dashes)\n\n";

  print(exists($head{$_}) ? depodify("$head{$_}$body{$_}") :
      qq{Topic not found: "$_" -- try "$myname help".\n\n}) for (@topics);
  return true;
}

##############################################################################

sub findmanparser(@)
{
  for(@_)
  {
    /^[\w\:]+$/ || error("bad parser: $_");
    my($parser) = eval("use IO::Handle; use Pod::$_; Pod::$_->new()");
    return $parser if $parser;
  }
  return false;
}

sub fakeman(;$)
{
  my($out) = @_;
  local(*SCRIPT, $_);
  selfopen(*SCRIPT);
  my($pod);
  while(<SCRIPT>)
  {
    $pod .= $_ if $pod || /^=\w+/;
    last if /^=cut/;
  }
  close(SCRIPT) || error;
  my($old) = $out ? select($out) || error : false;
  print(depodify($pod));
  select($old) || error if $old;
  return true;
}

sub tryman($;$)
{
  my($parser, $pager) = @_;

  my($out);
  local(*PAGER);
  if($pager)
  {
    return false unless open(PAGER, "| $pager");
    $out = \*PAGER;
  }
  local(*SCRIPT);
  selfopen(*SCRIPT);
  $parser ? $parser->parse_from_filehandle(*SCRIPT, $out) : fakeman($out);
  close(PAGER) if $out;
  close(SCRIPT) || error;
  return true;
}

sub man()
{
  return tryman(findmanparser("Text")) || error unless -t(STDOUT);
  my($parser) = findmanparser(qw(Text::Overstrike Text::Termcap Text));
  exists($ENV{$_}) && tryman($parser, $ENV{$_}) && return true
      foreach qw(MANPAGER PAGER);
  tryman($parser, $_) && return true foreach ("less -ir", "more", "");
  error;
}

##############################################################################

sub license();

sub cmd_license()
{
  print license;
}

##############################################################################

sub cmd_version()
{
  print "$myname $myversion\n";
}

##############################################################################

sub urlescapechar($)
{
  my($char) = @_;
  my($hex) = hex(ord($char));
  $hex = "0$hex" if length($hex) == 1;
  "\%$hex";
}

sub cleanurl($)
{
  my($url) = @_;
  $url =~ s/ /\+/g;
  $url =~ s/[^\!-\~]/urlescapechar($&)/ge;
  $url .= "/" if $url =~ m!^\w+://[^/]+$!;
  $url =~ s!^(ftp://[^/:]+):21/!$1/!; # wget emits redundant ftp port no.
  $url .= "#" . time() if $url =~ /^cvs/ && $url !~ /\#\d+$/;
  return $url;
}

sub fileurl($)
{
  my($file) = @_;
  $file = abspath($file);
  $file =~ s/[\%]/urlescapechar($&)/ge;
  return cleanurl("file://localhost$file");
}

sub pkgname($;$$)
{
  my($name, $version, $build) = @_;
  error unless defined($name);
  my($result) = "$name";
  $result .= " version $version" if defined($version);
  $result .= " build $build" if defined($build);
  $result;
}

##############################################################################

sub findpkg($$)
{
  my($name, $version) = emptytoundef(@_);

  return () unless defined($name);
  return ($name, $version)
      if defined($version) ? isversion($name, $version) : isname($name);
  return () unless ignorecase;

  ($name, $version) = (lc($name), defined($version) ? lc($version) : undef);
  my($n, $v);

  for $n (allnames)
  {
    if(lc($n) eq $name)
    {
      return ($n) unless defined($version);
      for $v (allversions($n))
      {
        return ($n, $v) if lc($v) eq $version;
      }
    }
  }

  return ();
}

##############################################################################

sub parse(@)
{
  my(@args) = @_;
  my(@result) = ();
  while(@args)
  {
    local($_) = shift(@args);
    my($name, $version, $build, @urls, $nourls, $multi, $split);

    if($_ ne "[" && m!^([^:/\.]*)(/([^:/]+)(/([1-9]\d*))?)?(:?)$!)
    {
      my($oname, $oversion);
      ($oname, $oversion, $build, $nourls) = ($1, $3, $5, !$6);
      ($name, $version) = findpkg($oname, $oversion);
      if(!$nourls)
      {
        defined($oversion) || error("missing version number: \"$_\"");
        defined($build) && error("unexpected build number: \"$_\"");
        @args || error("expected file or URL after \"$_\"");
        $_ = shift(@args);
      }
      elsif(defined($oversion) && !defined($version))
      {
        ($nourls, $name, $oname) = false if -r && !-d;
      }
      else
      {
        !defined($build) || isbuild($name, $version, $build) ||
            error("no such build: ", pkgname($name, $version, $build));
      }
      ($name, $version) = ($oname, $oversion) unless defined($name);
    }

    if(!$nourls)
    {
      if(s/^\[//)
      {
        $multi = true unless s/\]$//;
        if($_ eq "")
        {
          ($multi && @args) || error("expected file after \"[\"");
          $_ = shift(@args);
        }
      }

      while($multi || !@urls)
      {
        if(s/\]$//)
        {
          $multi = false;
          last unless $_ ne "";
        }

        my($url);
        if(/^[\w\+]+:./)
        {
          $url = cleanurl($_);
          if(expand && $url =~ m!/$!)
          {
            my(@expansion) = grep(lookslikepkgurl($_, $name, $version),
                linksfromurl($url));

            # filter out less desirable links, e.g. LVM2.0-stable.tgz
            # lilo-2.6.binary.tar.gz, zsh-4.2.1-doc.tar.bz2
            my(@filtered) =
                grep(!/\b(latest|stable|binary|doc)\b/i, @expansion);
            @expansion = @filtered if @filtered;

            # filter out older versions of duplicated packages
            my(%bestver);
            for(@expansion)
            {
              my($n, $v) = guessnv($_);
              $bestver{$n} = $v if defined($n) && defined($v) &&
                  (!defined($bestver{$n}) ||
                  (sort cmpab ($bestver{$n}, $v))[1] eq $v);
            }
            @expansion = grep
            {
              my($n, $v) = guessnv($_);
              defined($n) && defined($v) && $bestver{$n} eq $v;
            } @expansion;

            # filter out foo.tar.gz if foo.tar.bz2 is also present
            my(%expansion);
            $expansion{$_} = true for @expansion;
            @expansion = grep
            {
              my($xform) = $_;
              !($xform =~ s/\.\w+(\.g?z)?$/.tar.bz2/i && $expansion{$xform});
            } @expansion;

            error("unable to expand $url") unless @expansion;

            $url = shift(@expansion);
            if(@expansion)
            {
              if(defined($name) && !$multi)
              {
                $multi = true;
                push(@expansion, "]");
              }
              unshift(@args, @expansion);
            }
          }
        }
        else
        {
          (-r && !-d) || error("unable to read file: $_");
          $url = fileurl($_);
        }
        push(@urls, $url);

        if($multi)
        {
          @args || error("expected \"]\" after \"$_\"");
          $_ = shift(@args);
        }
      }

      @urls || error("expected at least one file between \"[\" and \"]\"");
      ($name, $version) = guessnv(@urls) unless defined($name);
    }

    push(@result, [$name, $version, $build, @urls]);
  }

  return @result;
}

sub cmd_parse(@)
{
  my(@args) = @_;
  my(@pkgs) = parse(@args);
  print("parsed ", scalar(@args), " word(s) into ",
      scalar(@pkgs), " package(s)\n");
  my($index) = 0;
  for(@pkgs)
  {
    my($name, $version, $build, @urls) = @$_;
    print("package ", ++$index, ":\n");
    print(defined($name) ? "  name: $name\n" : "  no name\n");
    print(defined($version) ? "  version: $version\n" : "  no version\n");
    print(defined($build) ? "  build: $build\n" : "  no build\n");
    if(!@urls)
    {
      print("  no urls\n");
    }
    else
    {
      print("  urls:\n");
      print("    $_\n") for @urls;
    }
  }
  true;
}

##############################################################################

sub rejectall(@)
{
  @_ && error("unexpected argument: $_[0]");
  [];
}

sub allowall(@)
{
  my(@args) = @_;
  \@args;
}

sub rejectempty(@)
{
  @_ || error("arguments expected");
  @_;
}

sub allowempty(@)
{
  @_ ? @_ : [];
}

sub rejectmissing(@)
{
  for(@_)
  {
    my($name, $version, $build, @urls) = @$_;
    error("no such package: ", pkgname($name, $version))
        unless defined($version) ? isversion($name, $version) : isname($name);
  }
  @_;
}

sub rejectbuilds(@)
{
  for(@_)
  {
    my($name, $version, $build, @urls) = @$_;
    $build && error("unexpected build number: ",
        pkgname($name, $version, $build));
  }
  @_;
}

sub requirename(@)
{
  for(@_)
  {
    my($name, $version, $build, @urls) = @$_;
    defined($name) || error("unable to guess package name from urls: @urls");
  }
  @_;
}

sub requireurls(@)
{
  for(@_)
  {
    my($name, $version, $build, @urls) = @$_;
    @urls || error("filename or URL expected for " .
        pkgname($name, $version, $build));
  }
  @_;
}

sub uselatestversion(@)
{
  my(@result);
  for(@_)
  {
    my($name, $version, $build, @urls) = @$_;
    $version = latestversion($name, $version) if isname($name);
    push(@result, [$name, $version, $build, @urls]);
  }
  @result;
}

sub emptytoall(@)
{
  return @_ ? @_ : map([$_], allnames);
}

##############################################################################

sub parse_find(@) { requirename(uselatestversion(emptytoall(rejectbuilds(parse(@_))))); }
sub parse_add(@) { rejectempty(parse(@_)); }
sub parse_get(@) { uselatestversion(emptytoall(rejectbuilds(parse(@_)))); }
sub parse_build(@) { uselatestversion(emptytoall(rejectbuilds(parse(@_)))); }
sub parse_arm(@) { uselatestversion(emptytoall(parse(@_))); }
sub parse_rebuild(@) { uselatestversion(emptytoall(rejectbuilds(parse(@_)))); }
sub parse_upgrade(@) { rejectmissing(uselatestversion(emptytoall(rejectbuilds(parse(@_))))); }
sub parse_disarm(@) { rejectempty(rejectmissing(parse(@_))); }
sub parse_clean(@) { allowempty(rejectmissing(parse(@_))); }
sub parse_demolish(@) { rejectempty(rejectmissing(parse(@_))); }
sub parse_purge(@) { rejectempty(rejectmissing(rejectbuilds(parse(@_)))); }
sub parse_remove(@) { rejectempty(rejectmissing(parse(@_))); }
sub parse_edit(@) { rejectempty(uselatestversion(rejectbuilds(parse(@_)))); }
sub parse_rename(@);
sub parse_change(@) { requireurls(rejectempty(rejectmissing(uselatestversion(rejectbuilds(parse(@_)))))); }
sub parse_status(@) { allowempty(rejectmissing(parse(@_))); }
sub parse_check(@) { rejectall(@_); }
sub parse_env(@) { rejectall(@_); }
sub parse_help(@) { allowall(@_); }
sub parse_man(@) { rejectall(@_); }

##############################################################################

sub parse_rename(@)
{
  my(@src) = @_;
  my($dest) = pop(@src);
  @src || error("at least two arguments required for rename");

  $dest =~ m!^([^:/\.]*)/?([^:/]*)/?([1-9]\d*)?$! ||
      error("bad destination: $dest");
  my(@destnvb) = emptytoundef($1, $2, $3);

  my(@result);
  local($_);
  for(@src)
  {
    m!^([^:/\.]+)(/([^:/]+)(/([1-9]\d*))?)?$! || error("bad source: $_");

    my($sname, $sversion, $sbuild) = emptytoundef($1, $3, $5);
    my($dname, $dversion, $dbuild) = @destnvb;
    $dname = $sname unless defined($dname);
    $dversion = $sversion unless defined($dversion);
    $dbuild = $sbuild unless defined($dbuild);

    defined($sversion) == defined($dversion) ||
        error("missing source version: $_ -> $dest");
    defined($sbuild) == defined($dbuild) ||
        error("missing source build: $_ -> $dest");
    !defined($sbuild) || $sname eq $dname && $sversion eq $dversion ||
        error("illegal build move: $_ -> $dest");

    push(@result, [$sname, $sversion, $sbuild, $dname, $dversion, $dbuild]);
  }

  return @result;
}

##############################################################################

sub getsub($)
{
  my($subname) = @_;
  my($result) = $subname =~ /^\w+$/ && checkedeval("\\&$subname");
  $result if defined(&$result);
}

##############################################################################

sub badcmd(@)
{
  return &cmd(defaultcmd, @_) if defaultcmd ne "help" && iscmd(defaultcmd);
  my($cmd) = @_;
  select(STDERR);
  help;
  error("bad defaultcmd: " . defaultcmd) if defaultcmd ne "help";
  error("no such command: $cmd") if defined($cmd);
  error("command expected");
}

sub iscmd($)
{
  my($cmd) = @_;
  !!(getsub("cmd_$cmd") || getsub("parse_$cmd"));
}

sub parseopts(@)
{
  my($opt, $cmd, @result);
  while(($opt = shift))
  {
    if($opt eq "--")
    {
      push(@result, @_);
      last;
    }
    elsif($opt !~ /^-/)
    {
      push(@result, $opt);
      next;
    }

    $opt = "--help" if $opt =~ /^--?[h\?]$/i;
    if($opt =~ /^--?(\w+)=(.*)$/)
    {
      setopt(lc($1), $2);
    }
    elsif($opt =~ /^--?no(\w+)$/i)
    {
      setopt(lc($1), false);
    }
    elsif($opt =~ /^--?(\w+)$/)
    {
      my($name, $val) = (lc($1), @_);
      if(iscmd($name))
      {
        error("conflicting command options: $cmd and $name")
            if $cmd && $cmd ne $name;
        $cmd = $name;
      }
      else
      {
        checkoptname($name);
        if(isboolopt($name) && !(defined($val) && isboolean($val)))
        {
          setopt($name, true);
        }
        elsif(!defined($val))
        {
          error("option $name requires an argument");
        }
        elsif($val =~ /^-/)
        {
          error("option $name requires an argument; found \"$val\" instead");
        }
        else
        {
          setopt($name, $val);
          shift;
        }
      }
    }
    else
    {
      error("unable to parse option: \"$opt\"");
    }
  }

  unshift(@result, $cmd) if $cmd;
  return @result;
}

sub cmd(@)
{
  my($cmd, @args) = @_;
  setactivepkg();
  return badcmd unless defined($cmd);
  $cmd = lc($cmd);
  my($cmdsub) = getsub("cmd_$cmd");
  return &$cmdsub(@args) if $cmdsub;
  my($parser) = getsub("parse_$cmd");
  return badcmd(@_) unless $parser;
  my($doer) = getsub($cmd);
  my($result) = true;
  my($pid) = $$;
  for(&$parser(@args))
  {
    my($name, $version) = @$_;
    setactivepkg($name, $version);
    $result = false unless eval { &$doer(@$_) };
    my($err) = $@;
    setactivepkg();
    if($err)
    {
      die($err) if $$ != $pid;
      print STDERR "$@\n";
      return false if stoponerror;
    }
  }
  return $result;
}

sub cmdline(@)
{
  my(@argv) = @_;
  return help unless @argv;
  return cmd(parseopts(@argv));
}

##############################################################################

sub main(@)
{
  $| = 1;
  my($result) = cmdline(@_) ? 0 : 1;
  close(STDOUT) || error("close stdout: $!");
  exit($result);
}

##############################################################################

sub selfconfigure(@)
{
  verbosify;

  my($prefix) = "/usr";
  my($arg);
  while(defined($arg = shift))
  {
    if($arg =~ /^--?prefix$/i)
    {
      $prefix = shift;
      error("expected argument for $arg") unless defined($prefix);
      next;
    }
    elsif($arg =~ /--?prefix=(.+)$/i)
    {
      $prefix = $1;
    }
    else
    {
      print STDERR "warning: ignoring argument $arg\n";
    }
  }

  explain("prefix is $prefix");

  my($mypackage, $mysource) = caller(0);

  writefile("Makefile", "# $genby\n", qq[
mysource = $mysource
myname = $myname
myversion = $myversion
prefix = $prefix
], map { my($l) = $_; $l =~ s/^ +/\t/gm; $l } q[
bindir = $(prefix)/bin
mandir = $(prefix)/man
man1dir = $(mandir)/man1

DESTDIR =

CP = cp
MKINSTALLDIRS = mkdir -p
POD2MAN = pod2man

prog = $(myname)
manpage = $(myname).1
targets = $(prog) $(manpage)
tarball = $(myname)-$(myversion).tar.gz

all: $(prog) $(manpage)

$(prog): $(mysource)
  $(CP) $(prog) $(mysource)

$(manpage): $(prog)
  $(POD2MAN) $(prog) > $(manpage) || rm -f $(manpage)

$(tarball): $(prog)
  ./$(prog) tarself < $(prog) > $(tarball) || rm -f $(tarball)

install: $(prog) $(manpage)
  $(MKINSTALLDIRS) $(DESTDIR)$(bindir) $(DESTDIR)$(man1dir)
  $(CP) $(prog) $(DESTDIR)$(bindir)
  $(CP) $(manpage) $(DESTDIR)$(man1dir) || true

dist: $(tarball)
]);
}

##############################################################################

sub strip0(@) { my(@args) = @_; s/^0+$/0/ || s/^0+// for @args; @args; }

sub mytime()
{
  $mytimestamp =~ m|^(\d+)/(\d+)/(\d+) (\d+):(\d+):(\d+)$| || error;
  my($yr, $mo, $day, $hr, $min, $sec) = strip0($1, $2-1, $3, $4, $5, $6);
  checkedeval("use Time::Local; timegm($sec,$min,$hr,$day,$mo,$yr)") || error;
}

sub tar(;$$)
{
  my($name, $contents) = @_;
  $contents = "" unless defined($contents);
  return pack("x512") unless defined($name) && $name ne "";
  my($magic, $uid, $gid, $user, $group, $mtime, $target) =
      ("ustar  ", 0, 0, "root", "root", mytime, "");
  my($isdir) = $name =~ m|/$|;
  my($islink) = $name =~ s/\@$//;
  my($isex) = $name =~ s/\*$//;
  my($mode) = $isdir ? 040755 : $isex ? 0100755 : $islink ? 0120777 : 0100644;
  my($type) = $isdir ? 5 : $islink ? 2 : 0;
  ($target, $contents) = ($contents, "") if $islink;
  my($size) = length($contents);
  my($pad) = "\x00" x ((512 - ($size % 512)) % 512);
  $type = " $type";
  $_ = sprintf("%07o", $_) for($mode, $uid, $gid);
  $_ = sprintf("%011o", $_) for($size, $mtime);
  my($presum, $postsum) =
      (pack("Z100 Z8 Z8 Z8 Z12 Z12", $name, $mode, $uid, $gid, $size, $mtime),
      pack("a2 Z100 Z8 Z32 Z32 x183", $type, $target, $magic, $user, $group));
  my($sum) = sprintf("%06o\x00", unpack("%32C*", "$presum       $postsum"));
  return $presum . $sum . $postsum . $contents . $pad;
}

sub cmd_tarself(@)
{
  error('try "make dist" instead') if @_ || -t(STDIN) || -t(STDOUT);

  my($namever) = "$myname-$myversion";
  my($tarfile) = "$namever.tar";

  local(*TAR2GZIP);
  my($pid) = open(TAR2GZIP, "|-");
  defined($pid) || error("fork: $!");
  if($pid)
  {
    my($contents) = join('', (<STDIN>));
    binmode(TAR2GZIP) || error("binmode: $!"); # perl 5.8.0 utf8 bug
    print TAR2GZIP
        tar("$namever/"),
        tar("$namever/$myname*", $contents),
        tar("$namever/configure@", $myname),
        tar("$namever/COPYING", license),
        tar;
    close(TAR2GZIP) && !$? or error("gzip filter subprocess returned $?");
  }
  else
  {
    local(*GZIP);
    open(GZIP, "gzip -c -9 |") || error("spawn gzip: $!");
    binmode(GZIP) || error("binmode: $!"); # perl 5.8.0 utf8 bug
    my($header);
    read(GZIP, $header, 10) == 10 || error;
    my($id, $cm, $flg, $mtime, $xfl, $os) = unpack("a2 C C L C C", $header);
    $flg == 0 || error("unexpected gzip flags");
    $flg |= 0x18; # FNAME + FCOMMENT
    $mtime = mytime;
    print(pack("a2 C C L C C Z* Z*",
        $id, $cm, $flg, $mtime, $xfl, $os, $tarfile, $myname), (<GZIP>));
    close(GZIP) && !$? or error("gzip returned $?");
    exit(0);
  }
}

##############################################################################

sub license()
{
  return << '--- END GNU GPL ---'; # the GNU GPL starts here:
		    GNU GENERAL PUBLIC LICENSE
		       Version 2, June 1991

 Copyright (C) 1989, 1991 Free Software Foundation, Inc.
                       59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 Everyone is permitted to copy and distribute verbatim copies
 of this license document, but changing it is not allowed.

			    Preamble

  The licenses for most software are designed to take away your
freedom to share and change it.  By contrast, the GNU General Public
License is intended to guarantee your freedom to share and change free
software--to make sure the software is free for all its users.  This
General Public License applies to most of the Free Software
Foundation's software and to any other program whose authors commit to
using it.  (Some other Free Software Foundation software is covered by
the GNU Library General Public License instead.)  You can apply it to
your programs, too.

  When we speak of free software, we are referring to freedom, not
price.  Our General Public Licenses are designed to make sure that you
have the freedom to distribute copies of free software (and charge for
this service if you wish), that you receive source code or can get it
if you want it, that you can change the software or use pieces of it
in new free programs; and that you know you can do these things.

  To protect your rights, we need to make restrictions that forbid
anyone to deny you these rights or to ask you to surrender the rights.
These restrictions translate to certain responsibilities for you if you
distribute copies of the software, or if you modify it.

  For example, if you distribute copies of such a program, whether
gratis or for a fee, you must give the recipients all the rights that
you have.  You must make sure that they, too, receive or can get the
source code.  And you must show them these terms so they know their
rights.

  We protect your rights with two steps: (1) copyright the software, and
(2) offer you this license which gives you legal permission to copy,
distribute and/or modify the software.

  Also, for each author's protection and ours, we want to make certain
that everyone understands that there is no warranty for this free
software.  If the software is modified by someone else and passed on, we
want its recipients to know that what they have is not the original, so
that any problems introduced by others will not reflect on the original
authors' reputations.

  Finally, any free program is threatened constantly by software
patents.  We wish to avoid the danger that redistributors of a free
program will individually obtain patent licenses, in effect making the
program proprietary.  To prevent this, we have made it clear that any
patent must be licensed for everyone's free use or not licensed at all.

  The precise terms and conditions for copying, distribution and
modification follow.

		    GNU GENERAL PUBLIC LICENSE
   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION

  0. This License applies to any program or other work which contains
a notice placed by the copyright holder saying it may be distributed
under the terms of this General Public License.  The "Program", below,
refers to any such program or work, and a "work based on the Program"
means either the Program or any derivative work under copyright law:
that is to say, a work containing the Program or a portion of it,
either verbatim or with modifications and/or translated into another
language.  (Hereinafter, translation is included without limitation in
the term "modification".)  Each licensee is addressed as "you".

Activities other than copying, distribution and modification are not
covered by this License; they are outside its scope.  The act of
running the Program is not restricted, and the output from the Program
is covered only if its contents constitute a work based on the
Program (independent of having been made by running the Program).
Whether that is true depends on what the Program does.

  1. You may copy and distribute verbatim copies of the Program's
source code as you receive it, in any medium, provided that you
conspicuously and appropriately publish on each copy an appropriate
copyright notice and disclaimer of warranty; keep intact all the
notices that refer to this License and to the absence of any warranty;
and give any other recipients of the Program a copy of this License
along with the Program.

You may charge a fee for the physical act of transferring a copy, and
you may at your option offer warranty protection in exchange for a fee.

  2. You may modify your copy or copies of the Program or any portion
of it, thus forming a work based on the Program, and copy and
distribute such modifications or work under the terms of Section 1
above, provided that you also meet all of these conditions:

    a) You must cause the modified files to carry prominent notices
    stating that you changed the files and the date of any change.

    b) You must cause any work that you distribute or publish, that in
    whole or in part contains or is derived from the Program or any
    part thereof, to be licensed as a whole at no charge to all third
    parties under the terms of this License.

    c) If the modified program normally reads commands interactively
    when run, you must cause it, when started running for such
    interactive use in the most ordinary way, to print or display an
    announcement including an appropriate copyright notice and a
    notice that there is no warranty (or else, saying that you provide
    a warranty) and that users may redistribute the program under
    these conditions, and telling the user how to view a copy of this
    License.  (Exception: if the Program itself is interactive but
    does not normally print such an announcement, your work based on
    the Program is not required to print an announcement.)

These requirements apply to the modified work as a whole.  If
identifiable sections of that work are not derived from the Program,
and can be reasonably considered independent and separate works in
themselves, then this License, and its terms, do not apply to those
sections when you distribute them as separate works.  But when you
distribute the same sections as part of a whole which is a work based
on the Program, the distribution of the whole must be on the terms of
this License, whose permissions for other licensees extend to the
entire whole, and thus to each and every part regardless of who wrote it.

Thus, it is not the intent of this section to claim rights or contest
your rights to work written entirely by you; rather, the intent is to
exercise the right to control the distribution of derivative or
collective works based on the Program.

In addition, mere aggregation of another work not based on the Program
with the Program (or with a work based on the Program) on a volume of
a storage or distribution medium does not bring the other work under
the scope of this License.

  3. You may copy and distribute the Program (or a work based on it,
under Section 2) in object code or executable form under the terms of
Sections 1 and 2 above provided that you also do one of the following:

    a) Accompany it with the complete corresponding machine-readable
    source code, which must be distributed under the terms of Sections
    1 and 2 above on a medium customarily used for software interchange; or,

    b) Accompany it with a written offer, valid for at least three
    years, to give any third party, for a charge no more than your
    cost of physically performing source distribution, a complete
    machine-readable copy of the corresponding source code, to be
    distributed under the terms of Sections 1 and 2 above on a medium
    customarily used for software interchange; or,

    c) Accompany it with the information you received as to the offer
    to distribute corresponding source code.  (This alternative is
    allowed only for noncommercial distribution and only if you
    received the program in object code or executable form with such
    an offer, in accord with Subsection b above.)

The source code for a work means the preferred form of the work for
making modifications to it.  For an executable work, complete source
code means all the source code for all modules it contains, plus any
associated interface definition files, plus the scripts used to
control compilation and installation of the executable.  However, as a
special exception, the source code distributed need not include
anything that is normally distributed (in either source or binary
form) with the major components (compiler, kernel, and so on) of the
operating system on which the executable runs, unless that component
itself accompanies the executable.

If distribution of executable or object code is made by offering
access to copy from a designated place, then offering equivalent
access to copy the source code from the same place counts as
distribution of the source code, even though third parties are not
compelled to copy the source along with the object code.

  4. You may not copy, modify, sublicense, or distribute the Program
except as expressly provided under this License.  Any attempt
otherwise to copy, modify, sublicense or distribute the Program is
void, and will automatically terminate your rights under this License.
However, parties who have received copies, or rights, from you under
this License will not have their licenses terminated so long as such
parties remain in full compliance.

  5. You are not required to accept this License, since you have not
signed it.  However, nothing else grants you permission to modify or
distribute the Program or its derivative works.  These actions are
prohibited by law if you do not accept this License.  Therefore, by
modifying or distributing the Program (or any work based on the
Program), you indicate your acceptance of this License to do so, and
all its terms and conditions for copying, distributing or modifying
the Program or works based on it.

  6. Each time you redistribute the Program (or any work based on the
Program), the recipient automatically receives a license from the
original licensor to copy, distribute or modify the Program subject to
these terms and conditions.  You may not impose any further
restrictions on the recipients' exercise of the rights granted herein.
You are not responsible for enforcing compliance by third parties to
this License.

  7. If, as a consequence of a court judgment or allegation of patent
infringement or for any other reason (not limited to patent issues),
conditions are imposed on you (whether by court order, agreement or
otherwise) that contradict the conditions of this License, they do not
excuse you from the conditions of this License.  If you cannot
distribute so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you
may not distribute the Program at all.  For example, if a patent
license would not permit royalty-free redistribution of the Program by
all those who receive copies directly or indirectly through you, then
the only way you could satisfy both it and this License would be to
refrain entirely from distribution of the Program.

If any portion of this section is held invalid or unenforceable under
any particular circumstance, the balance of the section is intended to
apply and the section as a whole is intended to apply in other
circumstances.

It is not the purpose of this section to induce you to infringe any
patents or other property right claims or to contest validity of any
such claims; this section has the sole purpose of protecting the
integrity of the free software distribution system, which is
implemented by public license practices.  Many people have made
generous contributions to the wide range of software distributed
through that system in reliance on consistent application of that
system; it is up to the author/donor to decide if he or she is willing
to distribute software through any other system and a licensee cannot
impose that choice.

This section is intended to make thoroughly clear what is believed to
be a consequence of the rest of this License.

  8. If the distribution and/or use of the Program is restricted in
certain countries either by patents or by copyrighted interfaces, the
original copyright holder who places the Program under this License
may add an explicit geographical distribution limitation excluding
those countries, so that distribution is permitted only in or among
countries not thus excluded.  In such case, this License incorporates
the limitation as if written in the body of this License.

  9. The Free Software Foundation may publish revised and/or new versions
of the General Public License from time to time.  Such new versions will
be similar in spirit to the present version, but may differ in detail to
address new problems or concerns.

Each version is given a distinguishing version number.  If the Program
specifies a version number of this License which applies to it and "any
later version", you have the option of following the terms and conditions
either of that version or of any later version published by the Free
Software Foundation.  If the Program does not specify a version number of
this License, you may choose any version ever published by the Free Software
Foundation.

  10. If you wish to incorporate parts of the Program into other free
programs whose distribution conditions are different, write to the author
to ask for permission.  For software which is copyrighted by the Free
Software Foundation, write to the Free Software Foundation; we sometimes
make exceptions for this.  Our decision will be guided by the two goals
of preserving the free status of all derivatives of our free software and
of promoting the sharing and reuse of software generally.

			    NO WARRANTY

  11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN
OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS
TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE
PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
REPAIR OR CORRECTION.

  12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
POSSIBILITY OF SUCH DAMAGES.

		     END OF TERMS AND CONDITIONS

	    How to Apply These Terms to Your New Programs

  If you develop a new program, and you want it to be of the greatest
possible use to the public, the best way to achieve this is to make it
free software which everyone can redistribute and change under these terms.

  To do so, attach the following notices to the program.  It is safest
to attach them to the start of each source file to most effectively
convey the exclusion of warranty; and each file should have at least
the "copyright" line and a pointer to where the full notice is found.

    <one line to give the program's name and a brief idea of what it does.>
    Copyright (C) <year>  <name of author>

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA


Also add information on how to contact you by electronic and paper mail.

If the program is interactive, make it output a short notice like this
when it starts in an interactive mode:

    Gnomovision version 69, Copyright (C) year name of author
    Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
    This is free software, and you are welcome to redistribute it
    under certain conditions; type `show c' for details.

The hypothetical commands `show w' and `show c' should show the appropriate
parts of the General Public License.  Of course, the commands you use may
be called something other than `show w' and `show c'; they could even be
mouse-clicks or menu items--whatever suits your program.

You should also get your employer (if you work as a programmer) or your
school, if any, to sign a "copyright disclaimer" for the program, if
necessary.  Here is a sample; alter the names:

  Yoyodyne, Inc., hereby disclaims all copyright interest in the program
  `Gnomovision' (which makes passes at compilers) written by James Hacker.

  <signature of Ty Coon>, 1 April 1989
  Ty Coon, President of Vice

This General Public License does not permit incorporating your program into
proprietary programs.  If your program is a subroutine library, you may
consider it more useful to permit linking proprietary applications with the
library.  If this is what you want to do, use the GNU Library General
Public License instead of this License.
--- END GNU GPL ---
}

##############################################################################

$0 =~ /\bconfigure$/i ? selfconfigure(@ARGV) : main(@ARGV);

##############################################################################

=head1 NAME

toast - simple source-and-symlinks package manager for root and non-root users

=head1 SYNOPSIS

B<toast> S<[ I<OPTION> ... ]> S<[ I<COMMAND> ]> S<[ I<ARGUMENT> ... ]>

=head1 DESCRIPTION

B<toast> is a simple, self-contained tool for downloading, building,
installing, uninstalling and managing software packages.  Unlike
traditional package-management systems, B<toast> is primarily intended
to work directly with software distributed as source code, rather than
in some precompiled or specialized binary format, such as RPM.  Binary
packages are also supported.

=head2 Purpose

B<toast> is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
for more details.

B<toast> is designed to be used in any of three ways:

=over 4

=item 1.

Installing and managing software in the home directory of a non-root user
on a multi-user system.  For example, I like to be able to run valgrind,
xdaliclock, Opera, and a few other programs on the Linux cluster at work
without having to bother the IT department about installing or supporting
those packages.

=item 2.

Installing and managing software packages in parallel to those installed
by a conventional package manager.  For example, if I were maintaining a
computer system running some kind of mainstream Unix-like OS, it might be
convenient to be able to quickly install the latest OpenSSH from source
into C</usr/local> in order to work around a security vulnerability,
and then conveniently remove it once my vendor or distribution releases
an official package for that version.

=item 3.

Installing and managing all software for an entire Unix system; that is,
using B<toast> as the one true package manager for the system.  This is
what I do on my (single-user) Linux box at home.

=back

Use #1 seems to be by far the most common in practice.  As far as I know,
I'm the only one crazy enough to attempt #3, and no one bothers with #2.
In general, it's probably a good idea to use a real distribution (such
as Debian), and to use its native package management system whenever
possible, rather than using B<toast> to replace it or go behind its back.

=head2 Requirements

B<toast> itself has been known to work with Perl 5.005_03 through 5.8.x
under Linux, FreeBSD, Solaris, MacOS X, and Cygwin, without relying on
the presence or absence of any Perl modules or other tools.  Perl is
available for download at C<http://www.cpan.org/src/stable.tar.gz>.
Although it isn't required, B<toast get> works better if you have
GNU wget; you can use C<toast arm wget> to download and install it if
necessary.  Additional requirements for B<toast build> vary according
to the package being built.

=head2 Setup

To have the latest version of B<toast> download and install itself in your
home directory, run one of the following commands as a non-root user.
(See below for instructions to install as root.)  The first command
requires GNU wget.  The second relies on the GET utility that comes
with the LWP Perl module.  The third command is broken over three lines,
though your shell should let you paste it exactly as written; it relies
only on Perl with no modules at all.

  wget -O- http://toastball.net/toast/toast|perl -x - arm toast

  GET http://toastball.net/toast/toast|perl -x - arm toast

  perl -e 'socket(S,2,1,0)&&connect(S,pack("Sna4x8",2,80,gethostbyname(
      "toastball.net")||die("dns")))&&syswrite(S,"GET /toast/toast\n")&&
      open(STDIN,"<&S")&&exec($^X,qw(-x - arm toast))||die($!)'

Of course, if you already have a previous version of B<toast> up and
running, just type C<toast upgrade toast>.  If B<toast> is installed
system-wide, but you want to install the latest version in your home
directory, try B<toast arm toast>.

B<toast> should now have installed itself and everything it
needs under C<I<$HOME>/.toast>.  You'll probably need to add
C<I<$HOME>/.toast/armed/bin> to your C<PATH> environment variable in order
to be able to use B<toast> and any other packages it installs.  You can
adjust C<PATH> (and a few other useful variables) with this command:

  eval `$HOME/.toast/armed/bin/toast env`

(Note that those are backticks, not single quotes.)  It probably makes
sense to add the above command to your C<.zshenv> or C<.profile> or
whatnot, so that your environment variables will be set up automatically
whenever you log in.  For more information, run C<toast help env>,
or just C<toast env> to see what variables would be set.

To have B<toast> install itself as root under C</toast> with symlinks in
C</usr/local>, you should first either create a user called C<toast> whose
UID and GID will be used when building packages, or create a configuration
file specifying an alternate username (C<fred> in this example):

  echo 'username=fred' >> /etc/toast.conf

If you want to use directories other than C</toast> and C</usr/local>,
now would be a good time to specify those as well, since relocating
armed packages can be tricky and time-consuming:

  echo 'storedir=/path/to/use/to/store/files' >> /etc/toast.conf
  echo 'armdir=/place/to/put/symlinks/to/armed/packages' >> /etc/toast.conf

Once the C<toast> user and/or C</etc/toast.conf> configuration file has
been created, just execute as root one of the same three download/install
commands given above for non-root users.  When using the default B<armdir>
location of C</usr/local>, you probably won't need to bother with the
B<toast env> stuff described above, but when using another location,
you may wish to put some variation on the B<toast env> command given
above in C</etc/profile> or something.

The above procedure is by no means required in order to install or
use B<toast>.  Both the uncompressed B<toast> script and an official
compressed tarball distribution containing B<toast> are available for
download at C<http://www.toastball.net/toast/>. The unmodified B<toast>
script can be copied to and run from any location, and you can use
B<toast man> to view the man page without having to install it first.
The default option settings should be sensible, and any necessary
directories will be created on demand.

A GNU-like C<configure> program (OK, symbolic link) is also provided
with the official B<toast> distribution for your convenience.  You can
supply an alternate installation directory prefix with C<./configure
--prefix=foo>, or keep the default prefix of C</usr> by running
C<./configure> without arguments.  Then run C<make>, become root if
necessary, and run C<make install>, which will install both the B<toast>
program and a man page.  Sadly, B<toast>'s C<configure> script does
not support most of the other command-line options and features of
B<configure> scripts produced by the real GNU autoconf.

=head2 Commands

=over 4

=item S<B<toast find> I<PACKAGE> ...>

Locate some of the URLs from which a package could be downloaded.
This command does not write to the disk at all.  The output format is
similar to that of B<toast status>, but all information comes from the
network rather than the on-disk package database.  If a given package
has not been added and no URLs were specified on the command line,
B<toast find> looks for an exact name match on the web sites specified
by the B<findsites> option; otherwise it attempts to list the directory
or directories to which the package's URL(s) belong.  If an explicit
version number is given, only that version is listed; otherwise all
versions are listed from oldest to newest.

=item S<B<toast add> I<PACKAGE> ...>

Adds new packages to the repository by storing URLs.  Use this command to
store package file locations without actually downloading anything.  Each
I<PACKAGE> must specify at least one URL or file unless the B<autofind>
option is enabled.  Absolute and relative pathnames are automatically
translated into file URLs.  If the given package has already been added,
the command merely compares the given URLs against those already stored
and gives an error if they don't match; use B<toast remove> or B<toast
change> to specify new URLs for an existing package.

=item S<B<toast get> [ I<PACKAGE> ...]>

Ensures that the given packages have been downloaded.  Implies B<toast
add>.  If no arguments are given, acts on the latest version of every
existing package.  After this command completes successfully, other
commands will be able to operate on the package without downloading
any additional files from the network.  If a given package is already
C<stored>, the existing downloaded files are silently preserved; use
B<toast purge> to force them to be downloaded afresh.  If GNU B<wget>
is installed, B<toast get> will use it to fetch C<http>, C<https>, and
C<ftp> URLs; otherwise, if LWP is installed, B<toast get> will use the
B<GET> utility to fetch those types of URLs; otherwise B<toast get>
will try to fetch C<http> and C<ftp> URLs itself using rudimentary
built-in routines.  B<toast get> always handles C<file> URLs itself.
If B<ssh> is available, B<toast get> can use it to fetch (non-standard)
URLs of the form C<ssh://[username@]hostname/absolute/path/to/file>.
If B<cvs> is available, B<toast get> can also handle (even less standard)
URLs of the form C<cvsroot[+ssh]:$CVSROOT/module[#unixtime]>; note that
$CVSROOT often starts with a colon, resulting in two colons in a row.

=item S<B<toast build> [ I<PACKAGE> ...]>

Ensures that the given packages are compiled and ready.  If no arguments
are given, acts on the latest version of every existing package.
Packages that already have at least one C<built> or C<armed> build (as
reported by B<toast status>) are skipped by this command without causing
an error; use B<toast rebuild> to force such packages to be rebuilt.
Building may involve implicitly invoking B<toast get>, decompressing and
extracting archives, applying patch files, compiling a new build of the
package and installing it in a build-specific directory tree.  Supported
archive formats include compress, gzip, bzip2, zip, rpm, deb, cpio,
tar, shar, patch, and most combinations of the above.  You don't need to
have RPM installed to extract .rpm files; cpio should usually suffice.
Similarly, only tar should be required to extract .deb files.  Note that
toast completely ignores dependencies and other meta-information in .rpm
and .deb files; only the raw binaries are extracted and used.  Archives
should contain either precompiled binaries or source code, which will
be identified and/or built according to heuristics too mind-numbing to
describe completely; in the case of source files, a C<configure> script,
C<Makefile> or similar is often required.  Many options can influence
this command's behavior; see the options reference for full details.

=item S<B<toast arm> [ I<BUILD> | I<PACKAGE> ...]>

Installs symbolic links to allow builds to be used.  This is perhaps the
most frequently used B<toast> command.  It is normally required before
programs compiled by B<toast build> or B<toast rebuild> can be run.  If no
arguments are given, acts on the latest version of every existing package.
If no explicit build number is supplied for a given package, B<toast
build> is implied, and the latest C<built> or C<armed> build is armed.
If a build to be armed is already in the C<armed> state, this command
has no effect.  The B<armdir> option controls where the symbolic links to
the files in each armed build will be installed; the default location is
C</usr/local> (for root) or C<I<$HOME>/.toast/armed> (for everyone else).
Non-root users might want to add C<I<$HOME>/.toast/armed/bin> to the
C<I<$PATH>> environment variable to make it easier to run armed packages.
Existing links to other builds are moved out of the way if necessary,
and the corresponding builds are still considered to be armed.

=item S<B<toast rebuild> [ I<PACKAGE> ...]>

Forces packages to be built or rebuilt.  If no arguments are given,
acts on the latest version of every existing package.  A new build
will be created as if by B<toast build> for every package given, even
if the package has already been successfully built.  Each package can
have any number of independent builds.  Builds for a given package are
automatically assigned sequential numbers starting from 1.  Many options
can influence this command's behavior; see the options reference for
complete details.

=item S<B<toast upgrade> [ I<PACKAGE> ...]>

Checks for a later version of an existing package.  If no arguments are
given, this command acts on the latest version of every existing package.
The existing package's URLs are used as a starting point to locate the
new version.  If the filename component of a given URL doesn't appear to
contain the package's version number, that URL will be left unmodified
for the new version; otherwise, the directory portion of the URL will
be immediately downloaded and searched for a similar URL containing a
higher version number.  The command fails if no URLs would change or if
no single consistent newer version for all version-containing URLs can be
found; otherwise, the highest eligible version is used for all modified
URLs and the package itself.  The command performs an implicit B<add>,
B<get>, B<build> or B<arm> on the extrapolated URLs so as to match the
state of the given existing version, except that an implicit B<arm>
will become an implicit B<build> if the B<autoarm> option is disabled.

=item S<B<toast disarm> I<BUILD> | I<PACKAGE> ...>

Deletes symlinks created by B<toast arm>.  This works by removing symbolic
links to the given build and replacing any links that had been moved
out of the way.  No error occurs if no such links exist.  If no build
number is given, all C<armed> builds, including C<mismatched> builds
reported to be C<armed>, are disarmed from all directories specified
by the B<armdir> and B<altarmdirs> options.  If the package version
number is also omitted, all C<armed> builds belonging to packages with
the given name are disarmed.

=item S<B<toast clean> [ I<BUILD> | I<PACKAGE> ...]>

Removes intermediate files and broken builds.  If no arguments are
given, all builds are cleaned.  If no explicit version and/or build
number is given, all matching versions and/or builds are cleaned.
Cleaning a broken build removes the build entirely; otherwise only
files that are not required by B<toast arm> are removed from the build.
These typically consist of files created directly by B<toast> as part
of the build environment, extracted source files, and intermediate files
created by the package itself during compilation.  Some kinds of binary
packages that do not involve intermediate files never require cleaning,
and B<toast build> and B<toast build> may automatically perform this
step if the B<autoclean> option is enabled.  Builds that are still in
the C<building> state (as reported by B<toast status>) are silently
ignored by this command.

=item S<B<toast demolish> I<BUILD> | I<PACKAGE> ...>

Deletes one or more builds.  If no version and/or build number is
given, all matching builds are disarmed.  If one of the builds to be
demolished is currently armed and the B<autodisarm> option is disabled,
B<toast demolish> reports an error and no builds are deleted; otherwise,
B<toast disarm> is implied.  Demolishing a package reverses the effects
of B<toast build> or B<toast rebuild> (and, optionally, B<toast arm>),
but never those of B<toast get> or B<toast add>.

=item S<B<toast purge> I<PACKAGE> ...>

Deletes files downloaded by B<toast get>.  Deletes toast's local copy of
the original archive used to build the given package or set of packages.
Existing builds are not affected by this command, but creating a new
build will implicitly reinvoke B<toast get>.  If the B<autopurge> option
is enabled, B<toast build> or B<toast rebuild> may implicitly invoke
this command.

=item S<B<toast remove> I<BUILD> | I<PACKAGE> ...>

Deletes a build, a package, or a set of packages.  Removing a build has
the same effect as B<toast demolish>.  Removing a package deletes all
of its builds and additionally reverses the effects of B<toast get> and
B<toast add>.  If any of the builds to be deleted is currently armed,
and the B<autodisarm> option is disabled, B<toast remove> reports an
error and nothing is removed; otherwise B<toast disarm> is implied.

=item S<B<toast rename> I<PACKAGE> ... I<NEWNAME>>

Renames an existing package or set of packages.  The package or packages
must already exist.  I<NEWNAME> uses the same syntax used to refer to
an existing package or build, except that the destination package must
not already exist and must contain the same number of slash characters as
I<PACKAGE>.  This command can also be used to renumber builds.  Currently,
armed packages or builds must be disarmed before they can be renamed.

=item S<B<toast change> I<PACKAGE> ...>

Changes the stored URLs for an existing package or packages.  Use with
caution!  Each package must already exist, and at least one URL must be
given explicitly for each.  The URL or URLs previously stored for each
package by B<toast add> will be discarded and replaced by the given URL
or URLs.  No further action is taken; in particular, neither B<toast get>
nor B<toast purge> is implied.  Note that it is often simpler and safer to
remove and then re-create a package than it would be to use this command.

=item S<B<toast status> [ I<BUILD> | I<PACKAGE> ] ...>

Displays information about packages and builds.  If invoked without
arguments, displays information about all packages and builds.  A package
is marked as C<stored> only if the original files have been downloaded by
B<toast get> and haven't been deleted by C<toast purge>.  The package URLs
may also be listed; see the B<showurls> option.  Every package has zero
or more builds, each of which is either C<building> (if B<toast build>
or B<toast rebuild> is still running), C<broken> (if it failed), C<built>
(if it succeeded), or C<armed> (by B<toast arm>).  In the last two cases,
the build will be marked C<(not clean)> if intermediate files created
by B<toast build> have not yet been removed by C<toast clean>.

=item S<B<toast env>>

Prints shell commands to make armed packages usable.  This command is
normally invoked with C<eval `toast env`> (note the backticks) from a
shell initialization file such as C<.zshenv> or C<.profile>.  This will
add C<I<armdir>/bin> to the front of C<PATH>, unless either directory
already appears anywhere in C<PATH>, in which case that directory will
be left in its current position instead of being moved to the front.
Other environment variables are similarly affected: C<MANPATH> (used to
find man pages), C<INFOPATH> (used by GNU info), C<CPATH> (used by gcc
to find include files), C<XML_CATALOG_FILES> (used by DocBook and other
tools to locate XML catalogs), and C<LIBRARY_PATH> (used by GNU ld to
find libraries; not to be confused with C<LD_LIBRARY_PATH>, which also
affects shared library loading at run time).  Note that if C<MANPATH>
in particular is unset, B<toast env> will run C<man -w> to try to get
the default value; if this causes problems, it may help to ensure that
C<MANPATH> is set before invoking B<toast env>.  This command assumes a
Bourne-like shell -- zsh and bash will work, tcsh won't.  None of this
is likely to be necessary if B<armdir> is C</usr> or C</usr/local>
(the default when running as root).

=item S<B<toast help> [ I<TOPIC> ] ...>

Summarizes usage information from the B<toast> man page.  If invoked
without arguments, displays a one-line summary of every command.
If invoked with an argument, displays a longer summary of the given topic,
which may be a command name, an option name, C<commands> or C<options>.
If B<toast> itself is invoked without any arguments, B<toast help>
is assumed.  Note that most information displayed by this command is
taken directly from a subset of the B<toast> man page.

=item S<B<toast man>>

Displays the complete B<toast> man page.  You're either reading the man
page now, or reading something that was derived from it (such as the
output of B<toast help>).  This command is supposed to behave about the
same way C<man toast> would, but it doesn't require the C<man> program or
the C<toast> man page to be installed.  If standard output is a tty, the
man page is formatted using C<Pod::Text::Overstrike>, C<Pod::Termcap>,
C<Pod::Text> or the rudimentary internal formatting routine used
by B<toast help>, and the formatted page is piped to C<$MANPAGER>,
C<$PAGER>, C<less -ir>, or C<more>, or dumped directly to the terminal
as a last resort.  If output is redirected to a file or pipe, the man
page is rendered as plain text using C<Pod::Text> if available or the
internal routine otherwise.  If you want more control over the output,
try feeding the C<toast> script itself to S<C<pod2text>>, C<pod2html>,
C<pod2man>, or C<pod2latex>, all of which are command-line utilities
that accepts lots of exciting switches and things and that come bundled
with recent versions of Perl.

=back

=head2 Arguments

Most commands take one or more arguments denoting packages or builds.
Such arguments usually follow one or more of the forms below.  Note that
not all commands accept all of these forms; in fact, some commands
(like B<toast help>) accept none of them.

=over 4

=item I<NAME>[B</>I<VERSION>]

This syntax can be used to refer to an existing package.  If the
package does not exist and the B<autofind> option is set, it will be
located automatically; if B<VERSION> is omitted, the latest available
version will be used.  If B<NAME> matches a previously-added package and
B<VERSION> is omitted, the latest existing version is used, except when
the documentation for the command specifically says that it affects all
versions or operates on sets of packages, in which case all versions
are affected.  Examples: C<wget>, C<gcc/3.2.2>, C<openssl/0.9.7b>

=item I<NAME>B</>I<VERSION>B</>I<BUILDNUM>

This syntax is used to refer to an existing build of an existing package.
Builds are numbered consecutively starting from 1.  Many commands don't
accept individual builds as arguments; the usage information for those
commands that do accept builds always uses the term I<BUILD> explicitlly.
Examples: C<xdaliclock/2.19/1>, C<glibc/2.3.2/4>.

=item S<[ I<NAME>B</>I<VERSION>B<:> ] I<URL>>

This syntax is most often used to implicitly add a new package by
URL, though many commands also allow it to be used to refer to an
existing package.  If the package name and version are omitted,
they will be guessed based on the filename portion of the URL; if
the package already exists, it will be found only if the guessed
name and version match those used to add it.  An error will occur
if the given package exists but has different URLs.  Examples:
C<ftp://alpha.gnu.org/gnu/tar/tar-1.13.25.tar.gz>, S<C<ps/3.1.8:
http://procps.sf.net/procps-3.1.8.tar.gz>>.

=item S<[ I<NAME>B</>I<VERSION>B<:> ] I<PATH>>

This syntax can be used to add a new package from a local file.
The given path is automatically translated into an absolute file URL.
Unlike a file URL, the path will be checked as soon as it is parsed
to ensure that it refers to a readable file; if it does not, a fatal
parse error will occur and the entire command will not be invoked,
even if previous arguments were parsed without error, the package
already exists, or the B<stoponerror> option is disabled.  Examples:
S<C<myprog/0.1test: myprog.zip>>, C</home/anandam/gdb-5.3.tar.gz>,
C<../../mnt/ain/ain/opt/stow/xplanet/xplanet-1.0.1.tar.gz>.

=item S<[ I<NAME>B</>I<VERSION>B<:> ] B<[> I<URL> | I<PATH> ... B<]>>

This syntax can be used to add a package that requires multiple URLs
and/or local files by grouping them between literal square brackets.
As with the previous two forms, the name and version number may be
omitted, in which case they will be guessed from the given filenames.
If the filenames are very dissimilar, only the first will be
used to guess the package name and version number.  Otherwise,
the order of URLs and/or paths is not significant.  Examples: C<[
http://www.kernel.org/pub/linux/kernel/v2.4/linux-2.4.20.tar.bz2
linux-2.4.20-config.tgz ssh://vulture/home/matt/linux-2.4.20.patch ]>,
S<C<[ http://ftp.gnu.org/gnu/glibc/glibc-{,linuxthreads-}2.3.2.tar.bz2 ]>>,
S<C<XFree86/4.3.0: [ X430src-[1-7].tgz ]>>.  (The last two examples
respectively involve brace and glob expansion performed by your shell).

=back

Every command that accepts a I<PACKAGE> argument will accept several
I<PACKAGE> arguments in sequence, so multiple files or URLs will always
be treated as distinct packages unless they are explicitly grouped into
a single package using square brackets as shown above.  For instance,
S<C<toast add *>> puts each file in the current directory in its own
package, while S<C<toast add [ * ]>> tries to combine them all into a
single package.

=head2 Options

=over 4

=item B<--storedir=>I<STOREDIR>

Defines the root of the directory tree B<toast> uses to store and build
all packages.  I<STOREDIR> must be given as an absolute path or a fatal
error will result.  B<toast add> and commands that explicitly invoke it
will create I<STOREDIR> if it doesn't already exist.  Default: C</toast>
if invoked by root, C<I<$HOME>/.toast> otherwise.

=item B<--armdir=>I<ARMDIR>

Defines the directory under which B<toast arm> creates symlinks to
compiled package files in I<STOREDIR>.  B<toast build> also tries to use
this value as a prefix when compiling most packages.  With few exceptions,
I<ARMDIR> should point to the same directory when arming a given package
that was used when building that package.  If I<ARMDIR> is not given as
an absolute path, it is taken to be relative to I<STOREDIR>.  I<ARMDIR>
and should probably not contain I<STOREDIR>, and should probably not be
contained by I<STOREDIR> either unless I<ARMDIR> is C<armed>, though these
restrictions are not enforced.  It's usually a good idea for I<ARMDIR>
to be C</usr> or C</usr/local> if feasible, since some broken packages
may not work if installed in a different location.  Default: C</usr/local>
if invoked by root, C<armed> otherwise.

=item B<--altarmdirs=>I<ALTARMDIR>[:I<ALTARMDIR>]...

Specifies an optional colon-separated list of alternate directories to
search for armed packages after searching I<ARMDIR>.  It is strongly
recommended that this list include any directory where a package is
likely to be armed.  is searched to determine whether a package is
currently armed.  When disarming a package, links will be removed from
each I<ALTARMDIR> in addition to I<ARMDIR> itself.  If an I<ALTARMDIR>
is not an absolute path, it is taken to be relative to I<STOREDIR>.
Default: empty list.

=item B<--username=>I<USER>

When invoked as root, B<toast build> will unpack, compile, and install
packages under I<USER>'s UID and GID as returned by C<getpwnam(3)>.
Note that any additional groups (such as those in C</etc/groups>) will
be ignored, as will I<USER>'s password, home directory, shell, and so on.
Default: C<toast>.

=item B<--fallbackuid=>I<UID>

If B<toast> is invoked as root and needs to do something as a non-root
user, it normally runs as the user given by the B<username> option.
However, if no such user exists, B<toast> will search for an unused
UID to use instead, starting at I<UID>.  Use 0 to disable this feature.
Default: C<23>.

=item B<--nice=>I<N>

If I<N> is a nonzero integer, the build subprocess spawned by B<toast
build> will silently attempt to adjust its sheduling priority ("niceness")
by the given delta.  In keeping with wacky Unix tradition, positive I<N>
causes the build process to run at a lower priority, while negative I<N>
denotes a higher priority.  Negative I<N> works only when B<toast> is
invoked as root.  Usually I<N> ought to be between 20 and -20, but other
values might be useful if B<toast> is invoked on a strange platform or at
an unusual initial priority.  Note that B<toast> will not fail or even
warn if I<N> is non-numeric, or too small, or if the priority cannot
be adjusted for any other reason, except that if I<N> is too large,
it will be silently demoted to the largest useful value.  Default: 10.

=item B<--postarmprog=>I<PROG>

If I<PROG> is non-empty, B<toast arm> and B<toast disarm> will execute
it immediately after arming or disarming one or more packages.  I<PROG>
can contain multiple words and/or shell metacharacters and will be parsed
and executed according to Perl's usual conventions, so it can actually
refer to more than one program.  If I<PROG> returns non-zero (failure),
the command will also fail.  Default: C</sbin/ldconfig> if invoked by
root, empty string otherwise.

=item B<--defaultcmd=>I<COMMAND>

Sets an implicit command to be assumed if B<toast> is invoked with
at least one command-line option or argument but no explicit command.
I<COMMAND> may be the name of any valid toast command.  As a special
case, the value C<help> causes B<toast> to print an error message and
a list of valid commands if no explicit command is given.  Note that
invoking B<toast> without command-line options or arguments is always
equivalent to running B<toast help>, regardless of this option's setting.
Default: C<help>.

=item B<--stickyopts=>I<OPTNAMES>

Sets the list of per-package command-line options implicitly stored
in B<storedir> for automatic re-use by later invocations of B<toast>.
I<OPTNAMES> is either a whitespace- and/or punctuation-separated list
of option names.  The word C<all> may also appear on the list; it
stands for the names of all options except for the B<stickyopts> option
itself.  The empty list is allowed.  Case is not significant.  Note that
B<stickyopts> only determines which options are stored (or removed from
storage); it can not be used to prevent previously stored options from
being implicitly loaded and re-used.  B<toast> will implicitly store
an option listed in I<OPTNAMES> only if it is specifically mentioned
on the command line; options read from the environment or from files on
disk are never implicitly stored.  If the value explicitly given on the
command line is the same value that would otherwise have been used if
no command-line options had been given and no per-package options were
stored, and that option is already stored, the option is removed from
storage instead of being stored.  If B<crossversion> is enabled, this
option writes to a file that applies equally to all same-name packages,
regardless of version number; otherwise, this option writes to a different
file that applies only to a single package name and version number taken
together.  Values stored in the more specific file (name and version)
always override values stored in the less-specific file (name only).
Default: C<reconfigure confappend makeappend>.

=item B<--findsites=>I<SITELIST>

Set the list of web sites or other locations searched by B<toast
find> for packages that have not already been added.  I<SITELIST>
is a space-separated list of URLs and/or special words taken from the
following list: C<freshmeat>, C<sourceforge>, C<gnu>, C<cpan>, or C<all>
(which stands for all of the preceding words in the order given).
The C<*> character will be replaced by the name of the package to find
wherever it occurs.  If you want a literal C<*> character, too bad.
Default: C<all>.

=item B<--httpproxy=>I<URL>

If I<URL> is non-empty, B<toast get> will use the given URL as the
proxy server for C<http> and C<https> URLs.  When using B<wget> or
B<GET>, the given URL will be exported in the C<http_proxy> environment
variable without further checking if non-empty.  When using built-in
HTTP, the proxy URL should be of the form C<I<hostname>:I<port>> or
C<http://I<hostname>:I<port>/>; other forms may also work.  Note that
using an empty URL will not cause C<http_proxy> to be removed from the
environment of B<wget> or B<GET>.  The proxy string is not exported
during B<toast build>.  Default: the current value of the C<http_proxy>
environment variable, or the empty string if that variable is not set.

=item B<--ftpproxy=>I<URL>

The B<ftpproxy> option is just like the B<httpproxy> option, but applies
to C<ftp> URLs.  Note that this really refers to an FTP-to-HTTP gateway,
rather than a true FTP proxy server.  Default: the current value of the
B<ftp_proxy> environment variable, or the empty string if that variable
is not set.

=item B<--confappend=>I<ARGS>

Specifies additional arguments for B<toast build> to pass to a package's
C<configure> script or equivalent, if any.  This should never be necessary
in order to build a package correctly (if it is, send me a bug report!),
but it can be awfully handy at times.  The I<ARGS> string is treated
as a list of space-separated words, each of which may be optionally
quoted with single or double quotes with backslash acting as an escape
character; the resulting words are added to the end of the command line.
Note that by default, this option's value may be saved with the package
and reused by future invocations of B<toast>; see the B<stickyopts>
option for details.  Default: empty string.

=item B<--makeappend=>I<ARGS>

The B<makeappend> option is just like the B<confappend> option except
that it applies to the C<make> command or commands (if any) invoked
by B<toast build>.  As with B<confappend>, use of this option should
never be necessary; if you find a package that won't build without it,
please send me a bug report!  Default: empty string.

=item S<B<--quiet> | B<--noquiet>>

When B<quiet> is enabled, most commands will produce output only on
failure.  Some commands, such as B<toast status>, are not affected by
this flag.  Default: disabled.

=item S<B<--expand> | B<--noexpand>>

When B<expand> is enabled, any URL ending in a slash encountered
while parsing the command line that will be treated as a pointer to a
directory listing whose contents are to be fetched, parsed, filtered, and
interpolated into the command line.  The filtering heuristic scans for
links that seem likely to be package URLs, without actually retrieving
anything other than the single directory URL given.  If a package name
and/or version number are given on the command line, those are taken
into account by the filter.  Use square brackets on the command line or
specify an explicit name or version number to force all of the resulting
URLs to be grouped into a single package, or omit brackets and name to
let B<toast> decide for itself whether and how to group the new URLs
into packages.  If B<expand> is disabled, URLs ending in slashes will not
receive any special treatment, and B<toast> will never attempt to fetch
anything from the network while it is still parsing the command line.
Default: enabled.

=item S<B<--autofind> | B<--noautofind>>

When B<autofind> is enabled, B<toast add> and other commands will
automatically look up package URLs as if by B<toast find> when none
have been added previously or given explicitly.  If no version number
is given either, the latest version found will be used.  Default: enabled.

=item S<B<--autochange> | B<--noautochange>>

When B<autochange> is enabled, B<toast get> may replace the URLs stored by
B<toast add> with the actual URLs of the files it downloaded.  When it is
disabled, URLs stored by B<toast add> will never change without warning.
This only matters in cases where the URL stored by B<toast add> actually
points to an HTML page or FTP directory, which used to happen all the time
back when the B<toast find> heuristic was more naive and the B<expand>
option didn't exist.  Enabling this option now seems more likely to
cause problems than to solve them.  Default: disabled.

=item S<B<--autorename> | B<--noautorename>>

When B<autorename> is enabled, B<toast get> may try to use information
gained after downloading files to attempt to guess a new name for any
implicitly added package for which no name and/or version number was
specified on the command line or could be guessed from the URLs given.
If B<autochange> is also enabled, new URLs are first used to try to
guess a new name; if this fails, the contents of the downloaded files
are examined.  If either method results in a new name being guessed,
the package is renamed automatically as if by B<toast rename>, and
any further processing continues under the new name.  If B<autorename>
is disabled, packages with unguessed or partially guessed names always
keep the unique names automatically assigned by B<toast add> based on
URLs alone (version number will be C<unknown> optionally followed by
a serial number for uniqueness; name may have been guessed or may also
be C<unknown>).  Default: enabled.

=item S<B<--autoenv> | B<--noautoenv>>

When B<autoenv> is enabled, B<toast> will automatically export the
environment variable settings printed by B<toast env> to any programs
invoked while building a package.  This may help the package being built
to locate other armed packages on which it depends.  Default: enabled.

=item S<B<--autoclean> | B<--noautoclean>>

When B<autoclean> is enabled, commands that create a new build for a
package (such as B<toast rebuild>) implicitly remove any pre-existing
broken builds from that package before creating the new build; also,
whenever a new build succeeds, it is implicitly cleaned as if by B<toast
clean>.  Note that newly created broken builds will not be immediately
cleaned or removed, even if this option is enabled, so as to make it
easier to diagnose build problems.  Default: enabled.

=item S<B<--autopurge> | B<--noautopurge>>

When B<autopurge> is enabled, an implicit B<toast purge> will be performed
on a package as soon as it is successfully built.  Default: disabled.

=item S<B<--autoarm> | B<--noautoarm>>

When B<autoarm> is enabled, B<toast upgrade> and B<toast rebuild> perform
an implicit B<toast arm> on every newly created non-broken build whose
package already contains another armed build.  Default: enabled.

=item S<B<--autodisarm> | B<--noautodisarm>>

When B<autodisarm> is enabled, B<toast arm>, B<toast demolish> and
B<toast remove> each perform an implicit B<toast disarm> on their armed
arguments or, in the case of B<toast arm>, on all builds belonging to
the same package as its arguments, or to any package with the same name
as its arguments if B<crossversion> is enabled.  Default: enabled.

=item S<B<--autodemolish> | B<--noautodemolish>>

When B<autodemolish> is enabled, B<toast rebuild> performs an implicit
B<toast demolish> on every other build belonging to the same package as
a newly-created, non-broken build.  If B<crossversion> is also enabled,
other packages with the same name will also be demolished.  Default:
enabled.

=item S<B<--autoremove> | B<--noautoremove>>

When both B<autoremove> and B<crossversion> are enabled, every time a
command creates a new non-broken build, it will also perform an implicit
B<toast remove> on every other package with the same name as the package
containing a newly-created, non-broken build.  If B<crossversion> is
disabled, this option has no effect.  Default: disabled.

=item S<B<--crossversion> | B<--nocrossversion>>

When B<crossversion> is enabled, the B<autodisarm>, B<autodemolish> and
B<autoremove> options will extend their effects to other packages with
the same name when appropriate.  See the descriptions of those options
for details.  Default: disabled.

=item S<B<--skipmismatched> | B<--noskipmismatched>>

When B<skipmismatched> is enabled, some operations will ignore any
pre-existing build that was built with a value of B<armdir> different
than the current one and is therefore reported as C<mismatched> by
B<toast status>.  Specifically, B<toast build> will ignore mismatched
builds when deciding whether or not to create a new build; B<toast
upgrade> will ignore mismatched builds when deciding whether to build or
arm the new version; and the B<autodemolish> option will not demolish
mismatched builds.  All other checks are unaffected by this option.
For example, B<toast remove> will never remove an armed build without
completely disarming it first, even if thie build is mismatched and this
option is enabled.  When B<skipmismatched> is disabled, mismatched builds
are never treated specially.  Default: enabled.

=item S<B<--ccache> | B<--noccache>>

When B<ccache> is enabled and a program called C<ccache> is present,
B<toast build> and B<toast rebuild> will try to use it to speed up
compilation of C/C++ programs.  Read about ccache at ccache.samba.org;
install it with C<toast arm ccache>.  If invoked as root, the cache
directory defaults to the C<ccache> subdirectory of B<storedir>; for
non-root users, the default is C<I<$HOME>/ccache>.  The location can
always be overridden by setting the C<CCACHE_DIR> environment variable.
If ccache is not installed, this option has no effect.  Disabling this
option prevents toast from taking any special steps to take advantage of
ccache, but it does not guarantee that ccache will not be used, though
it may prevent it from finding a user's home directory.  Default: enabled.

=item S<B<--preload> | B<--nopreload>>

When B<preload> is enabled, B<toast build> will attempt to compile a
shared library for use with C<LD_PRELOAD> during the C<make install>
phase.  This library may help some packages install themselves into the
correct location.  If B<preload> is disabled, B<toast build> will skip
this step.  Note that this may cause some packages to build incorrectly
in some situations.  To build the shared library only if a suitable
C compiler is present, leave this option enabled, but disable the
B<strictpreload> option.  Default: enabled.

=item S<B<--strictpreload> | B<--nostrictpreload>>

When B<strictpreload> is enabled, failure to build the shared library
described under the B<preload> option is treated as a fatal error.
When B<strictpreload> is disabled, a compile error while attempting
to build the shared library causes B<toast build> to behave as if the
B<preload> option were disabled.  This may allow B<toast build> to succeed
in the absence of a suitable C compiler, but it may allow some packages
to build incorrectly in some situations.  Default: enabled under Linux,
disabled elsewhere.

=item S<B<--useflock> | B<--nouseflock>>

When B<useflock> is enabled, some commands (such as B<toast arm>)
may try to use Perl's built-in flock() to prevent multiple concurrent
invocations of B<toast> from modifying the repository in ways that might
corrupt it.  Disabling this option is probably not a good idea, but may
be necessary in some environments.  Note that Perl's flock() will not
necessarily use C's flock() routine; see the Perl manual for details.
Note also that B<toast>'s locking strategy probably isn't foolproof,
especially under NFS.  Default: disabled under Cygwin, enabled elsewhere.

=item S<B<--reconfigure> | B<--noreconfigure>>

When B<reconfigure> is enabled, B<toast build> may attempt to pass extra
arguments to a package's C<configure> script (such as B<--enable-shared>)
and/or C<Makefile> (such as B<install.man>) in order to build or install
extra files that the package itself might not build or install by default.
This produces improved results for many specific packages (such as QT
and XFree86), and may make subsequent packages more likely to build, but
it can sometimes break things (usually in a straightforward way), or it
may be undesirable for other reasons.  If B<reconfigure> is disabled,
B<toast build> does not try to do anything beyond the minimum steps
required to correctly build and install whatever files the package builds
and installs by default.  Note that by default, this option's value may
be saved with the package and reused by future invocations of B<toast>;
see the B<stickyopts> option for details.  Default: enabled.

=item S<B<--fixliblinks> | B<--nofixliblinks>>

When B<fixliblinks> is enabled, B<toast build> may create symbolic links
to shared libraries whose names contain version numbers and follow a
certain naming convention.  For example, when built under Linux with
the B<reconfigure> option enabled, zlib version 1.2.1 creates a shared
library called C<libz.so.1.2.1> along with two symbolic links that
point back to that file: C<libz.so> (required to link new packages with
the shared library) and C<libz.so.1> (required to run programs linked
with the shared library).  When this option is enabled, B<toast build>
will create a third link called C<libz.so.1.2>, which happens to be
completely useless, but if the other two links had been missing for
whatever reason, it would have created them as well.  Binary packages
that contain shared libraries are especially likely to benefit from
this behavior.  Default: enabled.

=item S<B<--interactive> | B<--nointeractive>>

When B<interactive> is enabled, B<toast upgrade> will display a list of
candidates (the same information as B<toast find>, but presented in a
different form) and prompt the user to choose one of them.  If B<autofind>
is enabled, B<toast add> and other commands do the same thing.  Note that
if only one candidate is found, that candidate will be used automatically,
without prompting.  Default: disabled.

=item S<B<--stoponerror> | B<--nostoponerror>>

When B<stoponerror> is enabled, B<toast> aborts and returns failure as
soon as any error occurs.  If B<stoponerror> is disabled, only the
processing of the current command argument is aborted; any subsequent
arguments will still be processed, but B<toast> still issues an error
message and returns failure after processing the last argument, even if
the last argument was processed successfully.  Note that certain types
of errors, such as errors parsing the command line, will always cause
B<toast> to abort completely, before processing the first argument,
regardless of this setting.  Default: enabled.

=item S<B<--ignorecase> | B<--noignorecase>>

If B<ignorecase> is enabled, package names and version numbers given on
the command line are always case-sensitive.  If B<ignorecase> is disabled,
package names and version numbers that refer to existing packages are
treated as if they were case-insensitive only when failing to do so would
cause an error.  Note that case is always preserved in URLs and when
explicitly naming new packages.  Note also that it is always legal for
two distinct packages to have names and/or version numbers that differ
only in case, and that such packages are never treated as if they were
related, even if B<crossversion> is enabled.  Default: enabled.

=item S<B<--showurls> | B<--noshowurls>>

When B<showurls> is enabled, B<toast status> always displays the stored
URLs associated with each displayed package.  If B<showurls> is disabled,
B<toast status> only displays a package's URLs if a different list of URLs
for that package was given explicitly on the command line.  Default:
enabled.

=item S<B<--showopts> | B<--noshowopts>>

When B<showopts> is enabled, B<toast status> always displays any stored
options associated with each displayed package.  If B<showopts> is
disabled, B<toast status> never displays this information.  Default:
enabled.

=item S<B<--infodir> | B<--noinfodir>>

When B<infodir> is enabled, B<toast arm> and B<toast disarm> will create
a file in B<armdir> called C<info/dir>; if the file already exists,
it will be replaced with an updated version.  When this option is set,
B<toast env> sets C<INFODIR> to point to this file, so that the "info"
command can display a list of installed info pages.  If B<infodir> is
disabled, B<toast arm> and B<toast disarm> will delete the C<info/dir>
file, if present, instead of rebuilding it.  Default: enabled.

=item S<B<--xmlcatalog> | B<--noxmlcatalog>>

When B<xmlcatalog> is enabled, B<toast arm> and B<toast disarm> will
maintain a catalog file in B<armdir> called C<etc/xml/toast-xml-catalog>,
whose presence and contents depend on the contents of B<armdir>'s
C<share/xml> and C<etc/xml> subdirectories.  If the catalog already
exists, it may be overwritten or deleted.  The B<toast env> command will
set C<XML_CATALOG_FILES> to point to this file when this option is set,
which helpds things like DocBook operate correctly.  If B<xmlcatalog>
is disabled, B<toast arm> and B<toast disarm> will delete the
C<toast-xml-catalog> file, if present, instead of rebuilding it.
Default: enabled.

=item S<B<--hspkg> | B<--nohspkg>>

When B<hspkg> is enabled, B<toast build> will generate various terrible
wrapper scripts for ghc and related commands, and B<toast arm> and
B<toast disarm> will maintain a Haskell package database B<armdir> called
C<etc/xml/toast-hs-package.conf>, whose presence and contents depend on
the contents of B<armdir>'s C<hspkg> subdirectory, which in turn will be
automatically populated by a wrapper script whenever a Haskell library
built via B<toast build> tries to register itself in the package database.
If the package database already exists, it may be overwritten or deleted.
The B<toast env> command will set C<GHC_PKG_PATH> to point to this file
when this option is set, which will cause wrapper scripts installed with
ghc and/or Haskell libraries to insert a --package-conf argument into
the command lines of some of the appropriate programs.  This approach
has many flaws and is not unlikely to cause more problems than it solves.
If B<hspkg> is disabled, B<toast build> will not attempt to generate any
Haskell-specific wrapper scripts (which may prevent Haskell libraries
from building, at least with GHC 6.4); B<toast arm> and B<toast disarm>
will delete the C<toast-hs-package.conf> file, if present, instead of
rebuilding it.  Poorly tested against GHC 6.4 only.  Default: disabled.

=item S<B<--protect> | B<--noprotect>>

If B<protect> is enabled, B<toast build> will make some of the directories
it creates in B<storedir> read-only, and B<toast arm> will attempt
to ensure that B<armdir> and all of its subdirectories are read-only,
changing existing modes if necessary.  If B<protect> is disabled, B<toast
build> will create read-write directories in storedir (though existing
subdirectories will be unaffected), and B<toast arm> will make B<armdir>
and its subdirectories read-write, assuming the current umask allows it.
This option never affects the permissions of files or symbolic links.
Default: disabled.

=item S<B<--relative>> | B<--norelative>>

If B<relative> is enabled, symbolic links created by B<toast arm>
will use canonical relative paths computed from the actual layout of
the filesystem when the command runs.  If B<relative> is disabled,
the target of each symbolic link will start with the absolute path to
B<storedir>, exactly as given on the command line (or configuration file
or whatnot), even if the resulting path is not canonical.  A "canonical
path" means a path that follows the "real" filesystem layout without going
through any links.  Both methods should work just fine except in unusual
situations, so feel free to use whichever setting you think looks nicer.
This option only affects newly-created links, never existing links, even
when an existing link is moved to change the stacking order of a package.
Default: disabled.

=item S<B<--debugrewrite> | B<--nodebugrewrite>>

If B<debugrewrite> is enabled, B<toast build> will always generate broken
builds.  The builds will contain extra debugging information that can be
used to help diagnose problems involving packages that build correctly
outside of B<toast>, but refuse to build or build incorrect files due
to bugs in B<toast>'s path-rewriting mechanism.  This option currently
requires that the C<strace> program be available (or C<ktrace> for *BSD).
Default: disabled.

=back

Each option's value is taken from the first of the following sources
that assigns it a value:

=over 4

=item 1.

The command line.  All options support standard B<-->I<NAME>B<=>I<VALUE>
and S<B<-->I<NAME> I<VALUE>> syntax.  For boolean options, I<VALUE> can
be B<true>, B<yes>, B<on>, B<enabled>, or B<1> to enable the option or
B<false>, B<no>, B<off>, B<disabled>, or B<0> to disable it.  Alternately,
B<-->I<NAME> can be used to enable a boolean option or B<--no>I<NAME>
to disable it.  In all cases, the leading double dash (B<-->) may
be replaced by a single dash (B<->), and I<NAME> is case-insensitive
(as is the B<no> prefix used to disable boolean options).  I<VALUE>
is case-sensitive, except for boolean options.

=item 2.

Package-specific configuration files.  If they exist at all, these
files are normally created and updated by B<toast>.  Package-specific
configuration files can live in two different places: the first applies
to a specific package with a given name and version number, the second
applies to all packages with the given name.  If both files exist, both
are checked in that order, and the first one to supply a value for the
option in question wins.  See the B<stickyopts> option for details.

=item 3.

The environment.  If option I<NAME> is not given a value on the command
line, will be read from the environment variable B<TOAST_>I<NAME> (all
uppercase) if it exists.  Note that environment variables whose names
contain lowercase letters will be silently ignored!  In the case of a
boolean option, one of the explicit values listed in item 1 must be given.

=item 4.

The main configuration file.  If option I<NAME> has not been assigned a value
through any of the above methods, its value will be taken from a line of
the form I<NAME>B<=>I<VALUE> in the configuration file, if such a line
exists.  I<NAME> is case-insensitive in this context.  Any whitespace
before or after I<NAME> or I<VALUE> will be ignored, as will any blank
line, any line containing only whitespace, and any line with B<#> as its
first non-whitespace character.  B<toast> looks for its configuration
file in C<I<$HOME>/.toast/conf>, C</toast/conf>, C</etc/toast.conf>,
and C</usr/local/etc/toast.conf>; if any of those files exist, only the
first is used.  (Here, C<I<$HOME>> specifically represents the value of
the C<HOME> environment variable.)  If a configuration file exists but
cannot be read or has invalid syntax, an invalid I<NAME>, or an illegal
I<VALUE> for a boolean option (an explicit value must be given; see item
1 for allowed forms), B<toast> will normally give an error message at
startup and refuse to execute any commands.

=item 5.

The built-in default value.  See the full list of options elsewhere in
this document for the specific default value used for each option.

=back

Any I<COMMAND> can also be written as if it were a command-line option by
preceding it with one or two dashes.  For example, S<B<toast --help>> and
S<B<toast help>> mean the same thing.  Commands do not behave like options
in the environment or the configuration file, but see the B<defaultcmd>
option above for an alternative.

=head1 ENVIRONMENT

Environment variables whose names start with C<TOAST_> may be interpreted
as option settings as described above.  In addition, various standard
environment variables such as C<PATH>, C<LD_LIBRARY_PATH>, C<CFLAGS>
and others may directly or indirectly influence B<toast>'s behavior,
especially when building new packages.

=head1 FILES

By default, when invoked by a non-root user, B<toast> writes only to
the C<I<$HOME>/.toast> directory, which will be created automatically
if needed.

=head1 AVAILABILITY

B<toast> may be downloaded from C<http://toastball.net/toast/> under
the terms of the GNU GPL.

=head1 BUGS

Please report any bugs, unexpected behavior, unsurprising but inconvenient
failures, feature requests, comments, and so on to C<toast-bugs> at the
hostname of the B<toast> distribution site, C<toastball.net>.

Known bugs:

  - autofind hangs in httphead() when going through tinyproxy?
  - gtk+ doesn't seem to build properly when it is already armed
  - opera and sleepycat db refuse to build when already armed
  - gimp will load plugins from other armed versions despite .off suffix
  - "toast upgrade gcc" doesn't work (ftp site has a subdir per version)
  - find fails for: sleepycat db, gcc, latex, GNU arch (?), ogle
  - autofind chooses "libraries only" version of xfig
  - build fails for: jikes, sirc, netcat, lcab, gv, bittorrent, xmlcatmgr
  - "toast edit" leaves things in an odd state if you hang up on it
  - "toast rename" is more case-sensitive than it ought to be
  - "toast get" prevents wget from truncating output if transfer restarts
  - "toast env" doesn't set PYTHONPATH
  - "toast build linux" may fail during install phase w/o --nopreload

Wish list:

  - deal better with missing gcc: clearer error msg? (email 7/21/04)
  - error messages that explain command usage (gale 2004-05-06 17:08:20)
  - convenient way to specify storedir, etc. during first time setup
  - work around lack of getenv(), mkdir(), etc. in microperl...?
  - "toast upgrade" w/o args should imply --nostoponerror or something
  - "toast arm" should move armed packages to top of stacking order
  - "toast status" should give information about stacking order
  - "toast rename" should rename armed packages by rewriting symlinks
  - "toast clean" should optionally remove old versions/builds
  - add "toast check": verify storedir and armdir integrity (and fix?)
  - toast get could be more robust w/r/t failures and concurrency
  - configure packages to use alternate /etc, /var, etc. when possible
  - share rewriting code between command wrappers and shared library
  - come up with a better way to deal with gnome (guess dependencies?)
  - figure out where to go with "toast edit" (or document it as-is)
  - let the user give a hash for each explicit URL; verify hashes
  - find, download, and verify hashes, PGP signatures, etc.
  - store checksums after build for later tripwire-like verification
  - find a way to rebuild indices for apropos by default
  - allow package name/version as URL; expand w/ autofind iff missing
  - optionally have toast add imply change, then make get+build smarter
  - toast status/env should allow multiple read-only storedirs/armdirs
  - toast get should support cvs, svn (e.g. GNU Emacs, Xapian, Ruby)
  - have toast status show/sort by size/timestamp
  - fold archives by URL and/or hash?
  - zsh completions!

Questions left unanswered by this documentation:

  - What are some realistic examples of toast commands?
  - How are storedir and armdir structured?
  - How does this tool differ from similar tools?
  - How can I address common problems not directly caused by toast?
  - How might I set up toast in a multi-architecture environment?

=head1 SEE ALSO

  /package       http://cr.yp.to/slashpackage/management.html
  Alien          http://kitenet.net/programs/alien/
  autopackage    http://autopackage.org/
  CheckInstall   http://asic-linux.com.mx/~izto/checkinstall
  Debian         http://www.debian.org/
  Encap          http://www.encap.org/
  fakeroot       http://packages.debian.org/stable/utils/fakeroot.html
  FreeBSD Ports  http://www.freebsd.org/ports/
  GAR            http://www.lnx-bbc.org/garchitecture.html
  GARStow        http://offog.org/code/garstow.html
  Gentoo         http://www.gentoo.org/
  GNU stow       http://www.gnu.org/software/stow/
  Graft          http://www.gormand.com.au/peters/tools/graft/graft.html
  LFS            http://www.linuxfromscratch.org/
  Linuxports     http://linuxports.sourceforge.net/
  RPM            http://www.rpm.org/
  Source Mage    http://www.sourcemage.org/
  spasm          http://www.linux.org/apps/AppId_6909.html

=head1 AUTHOR

Jacques Frechet

=head1 COPYRIGHT

This manual is part of B<toast>.  Copyright (C) 2003-2005 Jacques Frechet.

B<toast> is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the
Free Software Foundation; either version 2 of the License, or (at your
option) any later version.

B<toast> is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
for more details.

You should have received a copy of the GNU General Public License
along with B<toast>; if not, write to the Free Software Foundation, Inc.,
59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

=cut

__END__