#!/bin/sh

##############################################################################
#                                                                            #
# This entire file is toast, a program for installing and managing software. #
# Copyright (C) 2003-2004 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") }
}

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

my($rcsid) = q$Id: toast,v 1.304 2004/02/27 00:15:37 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-2004 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 error(@)
{
  die(join('', @_) || "assertion failed", "\n[" . trace . "]\n");
}

sub warning(@)
{
  warn(join('', @_) || "warning", "\n[" . trace . "]\n");
}

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

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

sub emptytoundef(@) { map { defined($_) && $_ eq "" ? undef : $_ } @_; }
sub undeftoempty(@) { 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 dirname($) { my($arg) = @_; $arg =~ s|/[^/]*$|| ? $arg : "."; }
sub basename($) { my($arg) = @_; $arg =~ s|.*/||g; $arg; }
sub stripext($) { my($arg) = @_; $arg =~ s/(\.tar)?(\.[a-z]\w*)?$//i; $arg; }
sub stripquery($) { my($arg) = @_; $arg =~ s/\?.*$//; $arg; }

sub path(@)
{
  defined($_) || error("undefined path component in @_") foreach @_;
  local($_) = join("/", @_);
  m|//| && error("double slash in path(@_): $_");
  m|/$| && error("final slash in path(@_): $_");
  $_;
}

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",
    "postarmprog" => superuser ? "/sbin/ldconfig" : "",
    "editprog" => "",
    "defaultcmd" => "help",
    "httpproxy" => exists($ENV{http_proxy}) ? $ENV{http_proxy} : "",
    "ftpproxy" => exists($ENV{ftp_proxy}) ? $ENV{ftp_proxy} : "",
    "quiet" => "false",
    "autofind" => "true",
    "autochange" => "true",
    "autorename" => "true",
    "autoclean" => "true",
    "autopurge" => "false",
    "autoarm" => "true",
    "autodisarm" => "true",
    "autodemolish" => "true",
    "autoremove" => "false",
    "crossversion" => "false",
    "skipmismatched" => "true",
    "strictpreload" => "true",
    "useflock" => $^O =~ /win/i ? "false" : "true",
    "reconfigure" => "true",
    "fixliblinks" => "true",
    "stoponerror" => "true",
    "ignorecase" => "true",
    "showurls" => "true",
    "infodir" => "true",
    "protect" => "true",
    "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");
  }

  sub loadopt($)
  {
    my($name) = @_;
    error unless isopt($name);
    return $optloaded{$name} if %optloaded;
    $optloaded{1} = 1;
    return unless $ENV{HOME};
    my($dotfile) = "$ENV{HOME}/.$myname/conf";
    return unless -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\"");
      $optloaded{$name} = $val;
      true;
    } $dotfile;
    $optloaded{$name};
  }

  my(%optcurrent);

  sub setopt($$)
  {
    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);
      }
    }
    $optcurrent{$name} = $val;
  }

  sub getopt($)
  {
    my($name) = @_;
    setopt($name, firstdef(envopt($name), loadopt($name), $optdefault{$name}))
        unless exists($optcurrent{$name});
    return $optcurrent{$name};
  }

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

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

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" }

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

sub explain(@)
{
  print("# @_\n") unless quiet;
}

sub announce(@)
{
  print("@_\n") unless quiet;
}

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

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: $!");
  readdir(DIR) eq "." || error;
  readdir(DIR) eq ".." || error;
  while(defined($_ = readdir(DIR)) && &$sub($_)) { }
  closedir(DIR);
  !defined($_);
}

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 optln($$)
{
  my($source, $target) = @_;
  ln($source, $target) unless -e($target) || -l($target);
}

sub relln($$)
{
  my($src, $target) = @_;
  ln($src =~ m|^/| ? findrelpath(dirname($target), $src) : $src, $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 optrm(@) { rm(grep(-e || -l, @_)) }
sub optrmall(@) { rmall(grep(-e || -l, @_)) }

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

sub nice($)
{
  eval { setpriority(0, 0, min(getpriority(0, 0) + $_[0], 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) = $? & 0xff;
  my($sig) = ($? >> 8) & 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 optcdrun($@)
{
  my($dir, @prog) = @_;
  announce("(cd $dir; @prog)");
  my($pid);
  if($pid = fork) # parent
  {
    waitpid($pid, 0);
    return !$?;
  }
  else # child
  {
    defined($pid) || error("fork: $!");
    chdir($dir) || error("chdir $dir: $!");
    safeexec(@prog);
  }
}

sub cdrun($@)
{
  my($dir, @prog) = @_;
  optcdrun($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+))?([^:]+)(:(\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) = @_;
  openhttp(*HANDLE, $url, undef, $proxy);
  local($_);
  $_ = <HANDLE>;
  s/\r?\n?$//;
  m|^HTTP/[\w\.]+ 200 | || error("$url: $_");
  while(<HANDLE>) { last if /^\r?\n?$/ }
  return true;
}

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;

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

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

  local(*SOURCE, *DEST);
  explain("creating $dest");
  safeopen(*DEST, ">", $dest);
  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: $!");
}

sub linksfromstring($$)
{
  my($html, $url) = @_;
  $url =~ m!^(((\w+:)//[^/]+)[^\?]*/)([^/\?](\?|$))?!
      || error("bad url: $url");
  my($proto, $host, $parent) = ($3, $2, $1);
  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 @links;
}

sub linksfromurl($)
{
  my($url) = @_;
  local(*HANDLE);
  openurl(*HANDLE, $url);
  my(@links) = linksfromstream(*HANDLE, $url);
  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 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/[^a-z0-9\+]+$//i; # allow e.g. gtk+
  $word =~ s/[\.-]?(source|src)$//i; # e.g. mozilla, libjpeg, minicom, XFree86
  $word eq "" ? undef : $word;
}

sub guessnv(@)
{
  my(@urls) = @_;
  my($base) = collapse(map(stripext(basename(stripquery($_))), @urls));
  $base =~ /^([\w]+[\w\-]*[a-z]+)[-_]v?(\d[\w\.\+\-]+)$/i  # Cryptix_src_3-1-1
      || $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
  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; } @_);
}

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

sub getuidgid()
{
  my($username) = username;
  my($name, $passwd, $uid, $gid) = getpwnam($username);
  error("getpwnam $username: $!") unless defined($name);
  return ($uid, $gid);
}

sub dropprivs()
{
  return unless superuser;
  my($username) = username;
  explain("running as user $username");
  my($uid, $gid) = getuidgid;
  $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 findperl()
{
  if($^X !~ m!/!) # 5.8.2 doesn't need all this, but 5.6.1 seems to
  {
    for(split(/:/, $ENV{"PATH"}))
    {
      my($path) = path($_, $^X);
      return $path if -x($path);
    }
  }
  return abspath($^X);
}

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

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

sub showprebuildinfo($$$)
{
  my($name, $version, $build) = @_;
  explain("$myname $myversion building " . pkgname($name, $version, $build));
  explain("$^X $0 $] $^O");
  optrun("uname", "-a");
  optrun(findperl, "-V");
  optrun("printenv");
  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;
}

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" ? "bzip2" : "gzip";
    open(STDIN, "$prog -cd |") || 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
  {
    chdir($outdir) || error("chdir $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 . "gzip -cd $arg | ", "-") if s/\.gz$//i;
  ($cmd, $arg) = ($cmd . "bzip2 -cd $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 -1";

  explain($cmd);

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

  chomp $result;
  $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) = @_;
  @urls && error;

  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)://!;
  return false if $url =~ m/\#/;
  my($noquery) = stripquery($url);
  return false unless $noquery =~ m!\.\w+$!;
  return false if $noquery =~ m!\.(html?|php)$!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($url);
  if($lcname eq $myname)
  {
    $url = $myurl;
  }
  else
  {
    local(*XML, $_);
    my($sitename) = "freshmeat.net";
    openurl(*XML, "http://freshmeat.net/projects-xml/$lcname/$lcname.xml");
    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;

    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]+)/m ||
        error("unexpected response from $redirurl");
    $url = $1;
    # wget can't always get FTP directory listing correctly w/o trailing slash
    $url .= "/" unless basename(stripquery($url)) =~ /\./; # e.g. atop
  }

  for(1..3)
  {
    if(lookslikepkgurl($url))
    {
      (undef, $version) = guessnv($url) unless defined($version);
      return ($name, $version, $url);
    }

    my(@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($_); $n eq $name } @matches;
      @matches = @namematches if @namematches;

      my($matchver) = $version;
      if(!defined($matchver))
      {
        my(@versions) = map { my(undef, $v) = guessnv($_); $v } @matches;
        @versions = grep(defined($_), @versions);
        if(@versions)
        {
          @versions = reverse sort cmpab @versions;
          $matchver = $versions[0];
          @matches = grep
          {
            my(undef, $v) = guessnv($_);
            defined($v) && $v eq $matchver;
          } @matches;
        }
      }

      return ($name, $matchver, $matches[0]) if @matches;
    }

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

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

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 add(@)
{
  my($name, $version, $build, @urls) = @_;

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

  ($name, $version, @urls) = findnewpkg($name, $version)
      unless @urls || !autofind;
  @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);

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

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

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

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

    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, $url));
      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{$_};
        }
      }
    }
    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;

  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) = abswhiledir { -d && !defined($subdir) && ($subdir = $_) } $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);
  my($perl) = findperl;
  error("can't find perl: $perl") unless -x($perl);
  writescript(path($helperdir, "$cmd.helper"), "#!$perl\n# $genby\n", q[
$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)($|/)!)
    {
      $rewritten = 1;
      s!^\Q$armdir\E($|/)!$1!;
      my($dir, $elem) = "";
      for $component (split(/\//, $_))
      {
        $dir ne "" && mkdir("$rootdir$dir", 0777) &&
            print("$myname: created directory $rootdir$dir\n");
        $dir .= "/$component";
      }
      $_ = "$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 helplib($$$)
{
  my($srcdir, $rootdir, $helperdir) = @_;

  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 result = strncmp(s, prefix, strlen(prefix)) == 0;
  /* 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);
    }

    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);
    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(@socc) = qw[gcc -shared -Wall];
  push(@socc, qw[-Werror]) if strictpreload;
  my(@sol) = ();
  push(@sol, qw[-ldl]) if $^O =~ /linux/i;

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

  return path($helperdir, "rewrite.so")
      if optcdrun($helperdir, @socc, qw[dummy.c -o rewrite.so])
      && optcdrun($helperdir, @socc, qw[rewrite.c -o rewrite.so.helper], @sol);

  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
(cd $makedir; tar cf - include/linux include/asm/.) | (cd $rootdir; tar xf -)
]);

  return $makehome;
}

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

  md($helperdir);

  helprewrite($srcdir, $rootdir, $helperdir, $_, false)
      foreach (qw[mkdir rmdir touch cp rm ln install chmod test ranlib gzip],
      "[");
  helprewrite($srcdir, $rootdir, $helperdir, $_, true)
      foreach (qw[mv]);
  helpnop($helperdir, $_) foreach (qw[chown ldconfig install-info]);
  $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 configure($$)
{
  my($dir, $prefix) = @_;

  # find a configure script
  my($cfg);
  #            usual     Perl          elm
  for $cfg (qw[configure configure.gnu Configure])
  {
    my($confprog) = path($dir, $cfg);
    if(-x($confprog))
    {
      my($self) = false;
      my($builddir) = false;
      my($bogus) = false;
      my($twowordprefix) = false;
      my($noprefix) = false;
      my(%confopts);

      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
        $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
        if(reconfigure)
        {
          s/^\s*AUTOTHREAD=no\s+\#+ leave off for now/\#$&/; # qt multithreaded
          my($opt); # glibc; libjpeg; others?
          for $opt (qw[--enable-add-ons --enable-shared])
          {
            $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

      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))));
        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");
        }
      }

      cdrun($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) &&
        cdrun($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");
  return $dir if -r($imf) && cdrun($dir, "xmkmf");

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

  # Terrible, terrible hack to allow glibc+linuxthreads to compile:
  # Look for a situation where we have multiple subdirectories, but no files,
  # and only one of the subdirectories contains an executable configure script
  # that actually does something.  If that happens, move the other directories
  # into the directory with the non-broken configure script and run that.
  # Otherwise one of the rules below will grab a Makefile from a random
  # subdirectory and try to use it, which doesn't work.
  my($newdir);
  my(@addons);
  my($addonsok) = whiledir
  {
    push(@addons, $_);
    my($abs) = path($dir, $_);
    return false if !-d($abs) || -l($abs);
    my($cfg) = path($abs, "configure");
    if(-x($cfg))
    {
      return true if whilefile { /^\s*(\#|exit|$)/ } $cfg;
      return false if $newdir;
      $newdir = $abs;
      pop(@addons);
    }
    true;
  } $dir;
  if($addonsok && @addons && $newdir)
  {
    mv(path($dir, $_), path($newdir, $_)) foreach @addons;
    return &configure($newdir, $prefix);
  }

  # 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])
  {
    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
      } $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;
    }
  }

  # 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")
      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 the Linux kernel
  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

  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$!;
  } $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;
  @targets = "World" if $xf86;
  @targets = qw[world opt] if $ocaml;
  @targets = $please if $please;

  return cdrun($dir, @prog) unless @targets;
  cdrun($dir, @prog, $_) foreach @targets;
  return true;
}

sub install($$)
{
  my($makedir, $rootdir) = @_;
  my($mf) = makefile($makedir) || error("no Makefile found");
  my(@trace, $man, $subdir, $netpbm, $usedestdir, $cdrtools);
  @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";
  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!
    $cdrtools ||= / Due to a bug in SunPRO make we need special rules /;
    true
  } $mf;
  $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
  @targets = ("package", "pkgdir=$netpbm") if $netpbm;
  @targets = "upgrade" if -r(path($makedir, "postfix-install")); # postfix
  push(@targets, "DESTDIR=$rootdir") if $usedestdir;
  push(@targets, "install_root=$rootdir") if $usedestdir; # glibc
  push(@targets, "PREFIX=$rootdir") if $usedestdir; # busybox
  push(@targets, "INS_BASE=$rootdir") if $cdrtools;
  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 sbin share src var],
      map(path("man", "man$_"), 1..9), path(qw[var spool]),
      path(qw[var run]), # hotplug/2004_01_05
      path(qw[share aclocal])); # librep/0.16.1
  sort(@result);
}

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

sub rootlinks()
{
  my(@result) = stdlinks;
  push(@result, $_, "/$_") foreach (qw[dev proc tmp]);
  @result;
}

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

sub compilebin($$)
{
  my($srcdir, $rootdir) = @_;
  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 ? 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);
    safechmod(0777, $libdir) if %liblinks;
    optln($liblinks{$_}, path($libdir, $_)) for sort(keys(%liblinks));
    safechmod($mode, $libdir);
  }
}

sub compile($$$)
{
  my($srcdir, $rootdir, $helperdir) = @_;
  compilebin($srcdir, $rootdir) || compilehelp($srcdir, $rootdir, $helperdir);
  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);
  $name || error;
  $version || error;

  clean($name, $version) if autoclean;

  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);
  if(superuser)
  {
    my($uid, $gid) = getuidgid;
    announce("chown", username, $builddir);
    chown($uid, $gid, $builddir) || error("chown $uid:$gid $builddir: $!");
  }

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

    my(@times) = gettimes;

    open(STDERR, ">&STDOUT") || error("dup stdout: $!");
    setopt("quiet", false);
    nice(10);
    dropprivs;
    showprebuildinfo($name, $version, $build);
    yes;

    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;
    print("  $_\n") unless quiet;
  }

  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 replace($)
{
  my($on) = @_;
  rm($on);
  my($off);
  while(-e($off = addoff($on)))
  {
    mv($off, $on);
    $on = $off;
  }
  true;
}

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);
  safechmod(0777, $dir);

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

  safechmod($mode, $dir);
}

sub postarm(;$$)
{
  my($armdir, $postarmprog) = @_;
  $armdir = armdir unless defined($armdir);
  $postarmprog = postarmprog unless defined($postarmprog);
  rebuildinfodir($armdir);
  run($postarmprog) if $postarmprog;
  return true;
}

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(755, $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]);
      optmd($dir);
      safechmod(0777, $dir);
    },
    sub
    {
      my($target) = displace(optpath(armdir, $_[0]));
      relative ? relln($_, $target) : ln($_, $target);
    },
    sub { safechmod($mode, optpath(armdir, $_[0])) }
  );

  postarm;

  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);
  for $armdir (@armdirs)
  {
    lock($armdir);

    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));
            safechmod(0777, $armsubdir);
          }
          return true;
        },
        sub
        {
          my($rel) = @_;
          my($armfile) = path($armdir, $rel); # BUG: $rel is sometimes undef?
          while(-e($armfile) || -l($armfile))
          {
            return replace($armfile) if optsamefile($armfile, $_);
            $armfile = addoff($armfile);
          }
          return true;
        },
        sub
        {
          my($rel) = @_;
          my($armsubdir) = optpath($armdir, $rel);
          if(-d($armsubdir) && !-l($armsubdir))
          {
            my($mode) = pop(@dirmodes);
            isempty($armsubdir) ? rd($armsubdir) : safechmod($mode, $armsubdir);
          }
          return true;
        }
      );
      error if @dirmodes;
      return true;
    } @nvb; # can't replace @nvb with ($n, $v, $b) due to perl 5.6.1 bug (?)

    postarm($armdir, ++$i == scalar(@armdirs) ? postarmprog : "");
    unlock($armdir);
  }

  return true;
}

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

sub upgrade(@)
{
  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)
  {
    m!^((http|ftp)://[^\?]+/)([^\?/]*)(\?.*)?$!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);
    }
  }

  my($newver);
  for(reverse(sort cmpab keys(%candidates)))
  {
    my($candidate) = $_;
    my($ok) = true;
    for(@newurls)
    {
      next unless ref;
      my(%vermap) = %$_;
      if(!exists($vermap{$candidate}))
      {
        $ok = false;
        last;
      }
    }
    if($ok)
    {
      $newver = $candidate;
      last;
    }
  }

  my($pkgname) = pkgname($name, $version);
  error("URLs for $pkgname don't look version-specific") unless $hasver;
  error("can't find consistent URLs for $pkgname") unless defined($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;

  for(@newurls)
  {
    next unless ref;
    my(%vermap) = %$_;
    $_ = $vermap{$newver};
  }

  my(@cmdargs) = ($name, $newver, undef, @newurls);
  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 status(@)
{
  my($name, $version, $build, @urls) = @_;
  my($result) = true;

  my(@armdirs) = allarmdirs;

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

    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;
        }
      }

      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);

  if(superuser)
  {
    my($uid, $gid) = getuidgid;
    announce("chown", username, $olddir, $newdir);
    chown($uid, $gid, $olddir, $newdir) ||
        error("chown $uid:$gid $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 printenvcmd($$;$)
{
  my($varname, $subdirs, $default) = @_;
  my(@dirs) = map(path(armdir, $_), split(/:/, $subdirs));
  my($exists) = exists($ENV{$varname});
  my($current) = $exists ? $ENV{$varname} : $default;
  my($export) = $exists ? "" : " export $varname;";

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

  push(@dirs, $current) if defined($current);
  print("$varname=" . shellescape(join(":", @dirs)) . ";$export\n");
}

sub env(@)
{
  @_ && error;

  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/;
  }

  printenvcmd("PATH", "sbin:bin");
  printenvcmd("MANPATH", "man", $defaultman);
  printenvcmd("INFOPATH", "info", "");
  printenvcmd("CPATH", "include");
  printenvcmd("LIBRARY_PATH", "lib");
  # there's also a LIBRARY_RUN_PATH or something that affects ld somehow...

  return true;
}

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

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 =~ s!^(ftp://[^/:]+):21(/|$)!$1$2!; # wget emits redundant ftp port no.
  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(@result) = ();
  while(@_)
  {
    local($_) = shift;
    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: \"$_\"");
        @_ || error("expected file or URL after \"$_\"");
        $_ = shift;
      }
      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 && @_) || error("expected file after \"[\"");
          $_ = shift;
        }
      }

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

        my($url);
        if(/^\w+:/)
        {
          $url = cleanurl($_);
        }
        else
        {
          (-r && !-d) || error("unable to read file: $_");
          $url = fileurl($_);
        }
        push(@urls, $url);

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

      @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(@)
{
  print("parsed ", scalar(@_), " argument(s)\n");
  my($index) = 0;
  for(parse(@_))
  {
    my($name, $version, $build, @urls) = @$_;
    print("argument ", ++$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 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_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);
  while(($opt = shift) && $opt =~ /^-/ && $opt ne "--")
  {
    $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\"");
    }
  }

  my(@result) = @_;
  unshift(@result, $opt) if defined($opt) && $opt ne "--";
  unshift(@result, $cmd) if $cmd;
  return @result;
}

sub cmd(@)
{
  my($cmd, @args) = @_;
  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))
  {
    $result = false unless eval { &$doer(@$_) };
    if($@)
    {
      die($@) 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;
warning("$myname: returning failure ($result)") if $result != 0;
  close(STDOUT) || error("close stdout: $!");
  exit($result);
}

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

sub selfconfigure(@)
{
  setopt("quiet", false);

  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 $(manpage)

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

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

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 ($size ? 512 - ($size % 512) : 0);
  $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 is known to work with Perl 5.005_03 through 5.8.x under
Linux, FreeBSD, Solaris, 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 uses telnet.

  wget -O- http://toastball.net/toast/toast|perl -x - arm toast
  GET http://toastball.net/toast/toast|perl -x - arm toast
  echo GET /toast/toast|telnet toastball.net 80|perl -x - arm toast

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 in root's home directory specifying an alternate username (C<fred>
in this example) by running the following command as root:

  mkdir ~/.toast && echo 'username=fred' > ~/.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 changing them
later is very tedious:

  mkdir -p ~/.toast
  echo 'storedir=/path/to/use/to/store/files'
  echo 'armdir=/place/to/put/symlinks/to/armed/packages'

Once the C<toast> user and/or C<~/.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 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>.

=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; gzip and
cpio usually suffice.  Similarly, only gzip and 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 <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>/sbin> and 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), 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 unnecessary 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<--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<--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 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<--autofind> | B<--noautofind>>

When B<autofind> is enabled, B<toast add> and other commands will
automatically look up package URLs on freshmeat.net when none have
been added previously or given explicitly.  If no version number is
given either, the latest version listed on freshmeat.net 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.
This matters if an URL given on the command line points to an HTML page or
FTP directory rather than to an actual archive to be extracted and built.
In order to ensure consistent results, it is often desirable to store the
more specific URLs, especially if B<autopurge> is enabled.  If this option
is disabled, B<toast get> will still follow links in the usual way, but
stored URLs will be left untouched, and future invocations of B<toast get>
may end up downloading different files for the same package if new files
or links have since been added to a page or directory.  Default: enabled.

=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<--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.  See also the B<disarmmismatched> option.
Default: enabled.

=item S<B<--strictpreload> | B<--nostrictpreload>>

When B<strictpreload> is enabled, B<toast build> will fail unless it
can successfully compile a shared library for use with C<LD_PRELOAD>
during the C<make install> phase.  If B<strictpreload> is disabled,
B<toast build> still tries to build and use the shared library, but will
do the best it can otherwise.  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.

=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.  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<--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 show> always displays the stored
URLs associated with each displayed package.  If B<showurls> is disabled,
B<toast show> 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<--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.  The "info" command uses this file to
display a list of installed info pages.  This is normally the only regular
file in B<armdir>; all the other files are symbolic links.  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<--protect> | B<--noprotect>>

If B<protect> is enabled, B<toast arm> will attempt to ensure that
B<armdir> and its subdirectories are read-only, changing existing modes
if necessary.  If B<protect> is disabled, 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: enabled.

=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.

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 3.

The 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>, if such a line exists, in
C<I<$HOME>/.toast/conf>, if that file exists.  (C<I<$HOME>> specifically
represents the value of the C<HOME> environment variable.)  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.  If the 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 4.

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?
  - autofind mishandles http redirects (e.g. http://toastball.net/toast)
  - 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)
  - autofind fails for: sleepycat db, gcc, latex, gv, GNU arch (?), ogle,
      wxpython
  - autofind chooses Linux binaries over source for doxygen
  - build fails for: jikes, sirc, netcat, lcab, gv, bittorrent

Wish list:

  - when building linux, default to using /proc/kconfig.gz if present?
  - 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.
  - find a way to rebuild indices for apropos by default
  - 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-2004 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__