#!/usr/bin/perl

use 5;

BEGIN { $^W = 1 } # use warnings
BEGIN { $SIG{'__DIE__'} = sub { warn(@_) } }
use strict; # if available
BEGIN { $SIG{'__DIE__'} = 'DEFAULT' }

# warn if "use warnings" and "use strict" are not both in effect
if($^V) # 5.0 emits spurious message
{
  { my($ok); { local $SIG{'__WARN__'} = sub { die };
      $ok = !eval('1 + "a"') } $ok || warn("use warnings"); }
  { eval('$foo = 1') && warn("use strict") }
}

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

sub trace($)
{
  my($i, $out, $prev) = (shift, "", "");
  while(my($package, $file, $line) = caller($i++))
  {
    $out .= ($prev eq $file ? "/" : $out ? "; $file: " : "$file: ") . $line;
    $prev = $file;
  }
  $out;
}

sub error(@)
{
  die(join('', @_) || "assertion failed", "\n[" . trace(1) . "]\n");
}

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

my($rcsid) = q$Id: toast,v 1.205 2003/09/16 20:47:02 zaphod Exp $;
$rcsid =~ /^Id: (.+),v (\S+) (\S+ \S+) (\S+) Exp (\S+ )?$/ || error;
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($genby) = "generated by $myname version $myversion [$myurl]";
$myname eq "toast" && $myauthor eq "zaphod" || error; # avoid accidents w/ CVS

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

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

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

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",
    "username" => "toast",
    "postarmprog" => superuser ? "/sbin/ldconfig" : "",
    "defaultcmd" => "help",
    "verbose" => true,
    "autofind" => true,
    "autochange" => true,
    "autorename" => true,
    "autoclean" => true,
    "autopurge" => false,
    "autoarm" => true,
    "autodisarm" => true,
    "autodemolish" => true,
    "autoremove" => false,
    "crossversion" => false,
    "strictpreload" => true,
    "reconfigure" => true,
    "stoponerror" => true,
    "ignorecase" => true,
    "showurls" => true,
    "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 isopt($name) && isboolean($optdefault{$name});
  }
  
  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;
    local(*DOTFILE, $_);
    return unless $ENV{HOME};
    my($dotfile) = "$ENV{HOME}/.$myname/conf";
    return unless -e($dotfile);
    open(DOTFILE, $dotfile) || error("open $dotfile for read: $!");
    while(<DOTFILE>)
    {
      s/^\s+//;
      s/\s+$//;
      next 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;
    }
    close(DOTFILE) || error("close $dotfile for read: $!");
    $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 urlfile() { "url" }
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") if verbose;
}

sub announce(@)
{
  print("@_\n") if verbose;
}

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

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 silentrm(@)
{
  unlink || error("rm $_: $!") foreach @_;
  true;
}

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

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

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

sub rmall(@)
{
  @_ || error;
  announce("rm", "-r", @_);
  dfs($_, sub { true }, sub { silentrm($_) }, sub { silentrd($_) }) foreach @_;
  true;
}

sub rmexisting(@)
{
  my(@existing) = grep(-e || -l, @_);
  rmall(@existing) if @existing;
  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 safechmod($@)
{
  my($mode, @files) = @_;
  $mode = $mode & ~umask;
  my($txtmode) = sprintf("%lo", $mode);
  (($mode | 01777) == 01777) || error("unsafe mode: $txtmode");
  announce("chmod", $txtmode, @files);
  chmod($mode, $_) || error("chmod $txtmode $_: $!") foreach @files;
  true;
}

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

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

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

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

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

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

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

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 nice($)
{
  eval { setpriority(0, 0, min(getpriority(0, 0) + $_[0], 20)) };
}

sub run(@)
{
  my(@prog) = @_;
  announce(@prog);
  system(@prog) == 0 || error("@prog returned $?");
}

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: $!");
    exec(@prog) || error("exec @prog: $!");
  }
}

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

sub openprog(*$@)
{
  local(*HANDLE) = shift;
  my($prog, @args) = @_;
  announce($prog, @args);
  return true if open(HANDLE, "$prog @args |");
  explain("failed to exec $prog: $!");
  return false;
}

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

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

sub openhttp(*$;$)
{
  local(*HANDLE) = shift;
  my($url, $method) = @_;
  $method ||= "GET";
  $url =~ m!^http://([\w\.]+)(:(\d+))?(/[\!-\~]*)?$! || error("bad url: $url");
  explain("fetching $url");
  my($host, $port, $path) = ($1, $3 || 80, $4 || '/');
  my($ip) = gethostbyname($host) || error("gethostbyname $host: $!");
  my($uagent) = "$myname/$myversion ($^O; $myurl)";
  my($request) = "$method $path HTTP/1.0\r\nHost: $host\r\n".
      "User-Agent: $uagent\r\nAccept: */*\r\n\r\n";
  socket(HANDLE, 2, 1, 0) || error("$!");
  connect(HANDLE, pack("Sna4x8", 2, $port, $ip)) ||
      error("connect $host:$port: $!");
  unbuffer(HANDLE);
  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) = @_;
  openhttp(*HANDLE, $url);
  local($_);
  $_ = <HANDLE>;
  s/\r?\n?$//;
  m|^HTTP/[\w\.]+ 200 | || error("$url: $_");
  while(<HANDLE>) { last if /^\r?\n?$/ }
  return true;
}

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");
  open(HANDLE, "<$source") || error("open $source for read: $!");
}

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 openwgeturl(*$)
{
  local(*HANDLE) = shift;
  my($url) = @_;
  openprog(*HANDLE, "wget", "-O-", $url);
}

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

  $proto eq "file" && openfileurl(*HANDLE, $url) ||
  $proto eq "ssh" && opensshurl (*HANDLE, $url) ||
  openwgeturl(*HANDLE, $url) ||
  $proto eq "http" && openhttpurl(*HANDLE, $url) ||
  error("unable to download: $url");
}

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

  local(*SOURCE, *DEST);
  explain("creating $dest");
  open(DEST, ">$dest") || error("open $dest for write: $!");
  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+)://!;
    push(@links, $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;
  return @links;
}

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

{
  my($pwd);

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

    my($env) = $ENV{PWD};
    return $pwd = $env if -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($)
{
  path(pwd, $_[0]);
}

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

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($)
{
  local($_) = @_;
  s/\:/_/g;
  s/^[\W_]+//;
  s/[\W_]+$//;
  $_ eq "" ? undef : $_;
}

sub guessnv(@)
{
  my(@sources) = @_;
  local($_) = stripext(basename(stripquery(collapse(@sources))));
  /^([\w]+[\w\-]*[a-z]+)[-_]v?(\d[\w\.\+\-]+)$/i || # Cryptix_src_3-1-1.zip
  /([^-]+)-(.*\d.+)/ ||                             # iputils-ss020124.tar.gz
  /^(\D+[^a-z])v(\d.*)$/ ||                         # TinyMAZEv2.4a.tar.gz
  /^(\D+)(\d.*)$/ ||                                # fceu019linux.tar.gz
  /^(.*)()$/;                                       # Xmerge.tar.gz
  my($name, $version) = ($1, $2);
  $name =~ s/\./_/g;
  (sanitize($name), sanitize($version));
}

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

sub pad40($)
{
  my($arg) = @_;
  my($len) = length($arg);
  $len > 40 ? $arg : (' ' x (40 - $len)) . $arg;
}

sub cmpab()
{
  my($na, $nb) = map { my($x) = $_; $x =~ s/\d+/pad40($&)/ge; $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 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 magicbufsize { 128 }

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 ".tar" if /^[^\x00]+(..)?\x00{5,}[\x00\s\d]*$/ || /\x00ustar[ \x00]/;
  return ".cpio" if /^07070[a-f\d]{30}/i;
  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);
  open(FILE, "<$file") || error("open $file for read: $!");
  my($buf);
  defined(read(FILE, $buf, magicbufsize)) || error("read $file: $!");
  close(FILE) || error("close $file for read: $!");
  return magicstring($buf);
}

sub readstdin($)
{
  my($len) = @_;
  my($buf);
  my($result) = read(STDIN, $buf, $len);
  defined($result) || error("read stdin: $!");
  $result == $len || error("read stdin: unexpected eof");
  $buf;
}

sub skipstdin($)
{
  my($len) = @_;
  return true if seek(STDIN, $len, 1);

  while($len > 0)
  {
    my($chunk) = min($len, 8192);
    readstdin($chunk);
    $len -= $chunk;
  }
  return true;
}

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

sub dumpstdin($)
{
  my($buf) = @_;
  print($buf);
  print($buf) while read(STDIN, $buf, 8192);
  exit(0);
}

sub extractstdin($);

sub autoextractstdin()
{
  my($buf) = readstdin(magicbufsize);
  forkstdin ? extractstdin(magicstring($buf)) : dumpstdin($buf);
}

sub rpmextractstdin()
{
  autoextractstdin if forkstdin;

  local($_) = readstdin(96);
  /^\xed\xab\xee\xdb[\x03\x04]/ || error("not rpm v3 or v4");

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

  dumpstdin($_);
}

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

  exec("tar", "xf", "-") || error("tar: $!") if $type eq ".tar";
  exec("cpio", "-di") || error("cpio: $!") if $type eq ".cpio";
  exec("/bin/sh") || error("/bin/sh: $!") if $type eq ".shar";
  exec("patch", "-p0") || error("patch: $!") if $type eq ".patch";

  rpmextractstdin if $type eq ".rpm";

  if($type =~ /^\.(Z|gz|bz2)$/)
  {
    my($prog) = $type eq ".bz2" ? "bzip2" : "gzip";
    open(STDIN, "$prog -cd |") || error("$prog: $!");
    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($pid) = fork;
  error("fork: $!") unless defined($pid);
  if($pid)
  {
    waitpid($pid, 0);
    $? && error("extract subprocess returned $?");
  }
  else
  {
    chdir($outdir) || error("chdir $outdir: $!");
    my($type) = magicfile($infile);
    exec("unzip", "-qo", $infile) || error("unzip: $!") if $type eq ".zip";
    open(STDIN, "<$infile") || error("open $infile for stdin: $!");
    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: $!");
  open(STDIN, "<$file") || error("open $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) = @_;
  -d(pkgpath($name));
}

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

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

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

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

sub latestbuild($;$$)
{
  my($name, $version, $build) = @_;
  lastitem(allbuilds($name, $version, $build));
}

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

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 isarmed(@)
{
  return !whilebuild
  {
    my($name, $version, $build) = @_;
    my($rootdir) = path(pkgpath($name, $version, $build), rootdir);
    my($armed) = -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 }
    );
    !$armed;
  } @_;
}

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

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?$!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);

  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 unless 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 rpm);
  $redirurl || error("no suitable URL for package $name on $sitename");

  my($redirhead) = httphead($redirurl);
  $redirhead =~ /^Location: ([^\r\n]+)/m ||
      error("unexpected response from $redirurl");
  my($url) = $1;

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

  my(@urls) = grep(lookslikepkgurl($_, $name, $version), linksfromurl($url));
  my(@exts) = (qw[.tar.bz2 .tar.gz .tgz .zip .rpm]);
  my($extpat) = '(' . join('|', map(quotemeta($_), @exts)) . ')$';
  @urls = grep(/$extpat/, @urls);

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

  my($ext);
  for $ext (@exts)
  {
    my(@matches) = grep(stripquery($_) =~ /\Q$ext\E$/i, @urls);
    return ($name, $version, $matches[0]) if @matches;
  }

  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);
  writefile($urlfile, map("$_\n", @urls));
}

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

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

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

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);
    open(FILE, "<$file") || error("open $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));
      for (@links)
      {
        $redir = $_ if !$redir && basename(stripquery($_)) eq $basename
            && !$visited{$_};
      }
      my($ext);
      for $ext (qw[.tar.bz2 .tar.gz .tgz .zip .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) = !defined($version) && autorename;

  ($name, $version) = 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);
}

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

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

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

sub extract($$)
{
  if($0 eq "-") # e.g. "perl - arm foo < toast"
  {
    close(STDIN); # this step apparently matters; ignore spurious error
    open(STDIN, "</dev/null") || error("open stdin: $!");
  }

  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($_) = @_;
  s/\\/\\\\/g;
  s/'/\\'/g;
  "'$_'";
}

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

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

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

sub helpnorewrite($$)
{
  my($helperdir, $cmd) = @_;
  my($path) = undeftoempty($ENV{PATH});
  my($preload) = undeftoempty($ENV{LD_PRELOAD});
  writescript(path($helperdir, "$cmd.helper"), qq[#!/bin/sh
PATH=$path
LD_PRELOAD=$preload
exec $cmd \"\$\@\"
]);
}

sub helprewrite($$$$$)
{
  my($srcdir, $rootdir, $helperdir, $cmd, $force) = @_;
  helpstub($helperdir, $cmd);
  writescript(path($helperdir, "$cmd.helper"), "#!$^X\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[;
$myname = ], quote($myname), q[;

# cleanse environment
$ENV{PATH} = $path;
delete $ENV{LD_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 <assert.h>
#include <dlfcn.h>
#include <errno.h>
#include <stdio.h>
#include <string.h>

#ifndef DEBUG
$defdebug
#endif

#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, void *foo);
    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");
  }

  assert(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];

  writefile(path($helperdir, "dummy.c"), "void ____toast_dummy_4u38291(){}\n");
  cdrun($helperdir, @socc, qw[dummy.c -o rewrite.so]);

  push(@socc, qw[-Werror]) if strictpreload;
  push(@socc, qw[rewrite.c -o rewrite.so.helper]);
  push(@socc, "-ldl") if $^O =~ /linux/i;

  writefile(path($helperdir, "rewrite.c"), $code);
  if(optcdrun($helperdir, @socc))
  {
    return path($helperdir, "rewrite.so");
  }
  else
  {
    error("unable to compile rewrite.so") if strictpreload;
    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], "[");
  helprewrite($srcdir, $rootdir, $helperdir, $_, true)
      foreach (qw[mv]);
  helpnop($helperdir, $_) foreach (qw[chown ldconfig]);
#  helpnorewrite($helperdir, $_) foreach (qw[gcc g++ cc]);
  $env{PATH} = "$helperdir:$env{PATH}";

  my($preload) = helplib($srcdir, $rootdir, $helperdir);
  $env{LD_PRELOAD} = $preload if $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);
  for $cfg (qw[configure configure.gnu])
  {
    my($confprog) = path($dir, $cfg);
    if(-x($confprog))
    {
      my(@confcmd) = ("./$cfg", "--prefix=$prefix");
      my($self) = false;
      my($builddir) = false;
      my($bogus) = false;
      my($notboth) = false; # mozilla
      my(%confopts);

      patch
      {
        $self ||= /this is toast 89a72ef9c34e1fd4927afa36c9be8b15/;
        $builddir ||= /error: you must configure in a separate build/; # glibc
        $bogus ||= /There is no .+configure.+ script .+Instead/i; # libpng
        s/(^\s*)read\s+(acceptance)(\s*$)/$1$2=yes$3/; # qt license
        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 --enable-static])
          {
            $confopts{$opt} ||= / \Q$opt\E\b/;
          }
          $notboth ||= /Only one of --enable-shared or --enable-static must /i;
        }
      } $confprog;

      if(!$self)
      {
        next if $bogus;

        if($notboth)
        {
          delete($confopts{"--enable-static"});
          delete($confopts{"--enable-shared"});
        }
        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
          optpatch { s/^use File::Compare;$/sub compare(\$\$){1}; #$genby/ }
              path($dir, "installperl");
        }
      }

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

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

  # look for Unixish or OS-specific Makefile in a subdir and mv it here
  # e.g. zip -> unix/Makefile; libpng -> scripts/makefile.linux
  return $dir unless dfs
  (
    $dir,
    sub { true },
    sub { !/makefile/i || !/$^O|\bunix/i || !mv($_, path($dir, "Makefile")); },
    sub { true }
  );

  # Sleepycat DB appears to demand the following in Unix-like environments:
  my($dbbuilddir) = path($dir, "build_unix");
  my($dbconfprog) = path($dir, "dist", "configure");
  return $dbbuilddir if -d($dbbuilddir) && -x($dbconfprog) &&
      cdrun($dbbuilddir, "../dist/configure", "--prefix=$prefix");

  # Maybe there's just an install script of some kind that we need to run.
  # Create an appropriate Makefile.
  for(qw[install.sh INSTALL])
  {
    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;
    }
  }

  # 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.
  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);
  }

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

  # 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($ok) = true;
  my($lk) = false; # blatant special case for the Linux kernel
  my($xf86) = false; # blatant special case for XFree86
  my($unzip) = false; # blatant special case for unzip
  my($please) = ""; # blatant special case for xdaliclock

  explain("examining $mf...");
  return false unless whilefile
  {
    $lk ||= /^do-it-all:.*\bvmlinux\b/;
    $xf86 ||= /Please use make World/i;
    $unzip ||= /If you're not sure about the characteristics of your system/;
    $please = $1 if /  please make one of: "([^"]+)"/;
    !/^all:[^\#]*\binstall\b/; # abort if all implies install (e.g. man-pages)
  } $mf;

  my(@prog) = "make";
  my(@targets);
  @targets = qw[oldconfig dep bzImage] if $lk;
  @targets = "World" if $xf86;
  @targets = $^O if $unzip;
  @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);
  @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 on command line due to libtiff
  local($ENV{install_root}) = $rootdir;
  announce("export", "$_=$ENV{$_}") foreach (qw[ROOT DESTDIR install_root]);
  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"$/;
    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
  cdrun($makedir, @trace, "make", @targets);
  run(@trace, qw[cp -R], glob("$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[share aclocal])); # librep/0.16.1
  sort(@result);
}

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

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 fixrootlink($)
{
  # XFree86 gets (understandably) confused by stdlinks and makes broken links
  my($link) = @_;
  my($dest) = readlink($link);
  defined($dest) || error("not a link: $link");
  explain("found broken symlink: $link");
  while($dest =~ s!\.\./!! && !-e($link))
  {
    rm($link);
    ln($dest, $link);
  }
  rm($link) unless -e($link);
  true;
}

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

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

  my($total, %count) = 0;
  dfs
  (
    $rootdir,
    sub { $count{$_} = $total; true },
    sub { fixrootlink($_) if -l && !-e; ++$total },
    sub { $count{$_} < $total || rd($_) }
  );
  $total || error("no files found in $rootdir");
}

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);
    rmexisting($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);
      rmexisting($archivedir);
    }
  }

  return true;
}

sub build(@)
{
  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: $!");

    open(STDERR, ">&STDOUT") || error("dup stdout: $!");
    setopt("verbose", true);
    nice(10);
    dropprivs;
    yes;

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

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

    exit(0);
  }

  $SIG{INT} = "IGNORE";
  my($tmplogname) = addtmp(path($builddir, buildlog));
  local(*LOG);
  open(LOG, ">$tmplogname") || error("open $tmplogname for write: $!");

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

  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)
        {
          my($source) = readlink;
          return (unlink || ($success = !($msg = "unlink $_: $!"))) &&
              (symlink($source, $_) ||
              ($success = !($msg = "symlink $source $_: $!")));
        }
        else
        {
          return chown(0, 0, $_) || ($success = !($msg = "chown $_: $!"))
        }
      },
      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 && isarmed($name, $version);

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

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

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

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);
    open(LOCK, "<$path") || error("open $path: $!");
    $locks{$path} = *LOCK{IO};
    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: $!"); # LOCK_UN
    close($lock) || error("close $path: $!");
    delete($locks{$path});
  }
}

sub arm(@)
{
  my($name, $version, $build, @urls) = @_;
  ($name, $version, $build) = build($name, $version, undef, @urls)
      if !isbuilt($name, $version, $build);

  isarmed($name, $version, $build) &&
      error(pkgname($name, $version, $build) . " is already armed");

  optmd(armdir);
  lock(armdir);

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

  $build || error;
  my($rootdir) = path(pkgpath($name, $version, $build), rootdir);
  dfs
  (
    $rootdir,
    sub { optmd(optpath(armdir, $_[0])) },
    sub { ln($_, displace(optpath(armdir, $_[0]))) },
    sub { true }
  );

  run(postarmprog) if postarmprog;

  unlock(armdir);

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

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

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

  lock(armdir);

  whilebuild
  {
    my($name, $version, $build) = @_;
    my($rootdir) = path(pkgpath($name, $version, $build), rootdir);
    -d($rootdir) && dfs  # ignore broken packages
    (
      $rootdir,
      sub { true },
      sub
      {
        my($rel) = @_;
        my($armfile) = path(armdir, $rel); # BUG: $rel is sometimes undefined?
        while(-e($armfile) || -l($armfile))
        {
          my($target) = readlink($armfile);
          return replace($armfile) if defined($target) && $target eq $_;
          $armfile = addoff($armfile);
        }
        return true;
      },
      sub
      {
        my($rel) = @_;
        my($armdir) = optpath(armdir, $rel);
        rd($armdir) if -d($armdir) && isempty($armdir);
        return true;
      }
    );
  } @_;

  run(postarmprog) if 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;

  my(%linkmap);
  my($verpat) = $version =~ /^\d/ ? '\d.*' : '.+';

  my(%candidates);
  my(@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(isarmed($name, $version) && autoarm)
  {
    return arm(@cmdargs);
  }
  elsif(isbuilt($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 verstatus($$)
{
  my($name, $version) = @_;
  return "stored" if isstored($name, $version);
  return false;
}

sub buildstatus($$$)
{
  my($name, $version, $build) = @_;
  return "broken" if isbroken($name, $version, $build);
  return "building" unless isbuilt($name, $version, $build);
  my($nc) = isclean($name, $version, $build) ? "" : " (not clean)";
  return "armed$nc" if isarmed($name, $version, $build);
  return "built$nc";
}

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

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

    for $version (allversions($name, $version))
    {
      my($vs) = verstatus($name, $version);
      print("  version $version", $vs ? ": $vs\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))
      {
        print("    build $build: ",
            buildstatus($name, $version, $build), "\n");
      }
    }
  }

  return $result;
}

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

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

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

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

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

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

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

BEGIN
{
  my($checkresult);

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

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

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

    # @todo check various

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

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

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

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

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

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

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

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

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

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

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

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

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

    $checkresult = true;

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

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

    return $checkresult;
  }
}

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

sub selfopen(*)
{
  local(*SCRIPT) = @_;
  my($package, $file) = caller(0);
  open(SCRIPT, "<$file") || error("open $file for read: $!");
}

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("\n$myname version $myversion -- $myurl\n\n");

  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($item, @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+)/)
      {
        $head{$item = $1} .= $_;
        push(@cmds, $item) unless $body{$item};
      }
      elsif(/^=item \S*-(\w+)/)
      {
        $head{$item = $1} .= $_;
        push(@opts, $item) unless $body{$item};
      }
      else
      {
        $body{$item} .= $_ if $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 urlescapechar($)
{
  my($char) = @_;
  my($hex) = hex(ord($char));
  $hex = "0$hex" if length($hex) == 1;
  "\%$hex";
}

sub cleanurl($)
{
  local($_) = @_;
  s/ /\+/g;
  s/[^\!-\~]/urlescapechar($&)/ge;
  $_;
}

sub fileurl($)
{
  local($_) = @_;
  $_ = abspath($_) unless m|^/|;
  s/[\%]/urlescapechar($&)/ge;
  cleanurl("file://localhost$_");
}

sub pkgname($;$$)
{
  my($name, $version, $build) = @_;
  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 isversion($name, $version);
  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 = false if -e;
      }
      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 uselatestbuild(@)
{
  my(@result);
  for(@_)
  {
    my($name, $version, $build, @urls) = @$_;
    $version = latestversion($name, $version)
        if isname($name);
    $build = latestbuild($name, $version, $build)
        if isversion($name, $version);
    push(@result, [$name, $version, $build, @urls]);
  }
  @result;
}

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

sub parse_add(@) { rejectempty(parse(@_)); }
sub parse_get(@) { rejectempty(uselatestversion(rejectbuilds(parse(@_)))); }
sub parse_build(@) { allowempty(uselatestversion(rejectbuilds(parse(@_)))); }
sub parse_clean(@) { allowempty(rejectmissing(parse(@_))); }
sub parse_arm(@) { rejectempty(uselatestbuild(parse(@_))); }
sub parse_upgrade(@) { rejectempty(rejectmissing(uselatestversion(rejectbuilds(parse(@_))))); }
sub parse_disarm(@) { rejectempty(rejectmissing(parse(@_))); }
sub parse_demolish(@) { rejectempty(rejectmissing(parse(@_))); }
sub parse_purge(@) { rejectempty(rejectmissing(rejectbuilds(parse(@_)))); }
sub parse_remove(@) { rejectempty(rejectmissing(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_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;
warn("$myname: returning failure ($result)") if $result != 0;
  close(STDOUT) || error("close stdout: $!");
  exit($result);
}

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

sub selfconfigure(@)
{
  setopt("verbose", true);

  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) $(bindir) $(man1dir)
  $(CP) $(prog) $(bindir)
  $(CP) $(manpage) $(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>));
    print TAR2GZIP
        tar("$namever/"),
        tar("$namever/$myname*", $contents),
        tar("$namever/configure@", $myname),
        tar;
    close(TAR2GZIP) && !$? or error("gzip filter subprocess returned $?");
  }
  else
  {
    local(*GZIP);
    open(GZIP, "gzip -c -9 |") || error("spawn gzip: $!");
    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);
  }
}

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

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

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

=head1 NAME

toast - build and install programs from source

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

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

Downloads the given packages' files into the repository.  Implies B<toast
add>.  After this command completes successfully, other commands will
be able to operate on the package without downloading any additional
files from the network.

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

Creates a new build for one or more packages.  This may involve
implicitly invoking B<toast add>, extracting archives, applying patch
files, compiling a new build of the package and "installing" it in
a build-specific directory tree.  Each package can have any number of
independent builds.  Builds for a given package are automatically assigned
sequential numbers starting from 1.  If the package is not stored, or
if URLs are given, B<toast get> is implied.  Many options can influence
this command's behavior; see the options reference for complete details.

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

Deletes and intermediate files created by B<toast build>.  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.
The B<toast build> command may perform this step automatically for some
kinds of binary packages that do not involve intermediate files, as well
as for other packages if the B<autoclean> option is enabled.  Only builds
that are not in the C<building> state (as reported by B<toast status>) may
be cleaned.  If no arguments are given, all eligible builds are cleaned.

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

Creates symbolic links to each file in a build.  This step is normally
required before a package can be used.  The links are typically created
under a directory such as C</usr/local>.  Existing links to other builds
are moved out of the way if necessary, and the corresponding builds are
still considered to be armed.  A build must be in the C<built> state (as
reported by B<toast status>) before it can be armed.  If no explicit build
number is supplied on the command line, this command implicitly creates
a new build (as if by B<toast build>) if the package has no builds, or
arms the latest C<built> build if such a build exists and was created
later (numbered higher) than the latest C<armed> build for that package
(if any).  If the latest build is already armed, the command fails; you
probably meant to invoke B<toast build> with the C<autoarm> option set.

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

Checks for a later version of an 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 <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 the new package will never be
armed 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.  If no build number is given, all C<armed> builds are
disarmed.  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 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> (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> 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>.  Attempting to rename an armed package causes B<toast rename>
to report an error.  Otherwise, renaming a package that contains builds
should be OK, though it could conceivably break ill-behaved packages.
This command can also be used to renumber builds.

=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>
is still running), C<broken> (if it failed), C<built> (if it succeeded),
or C<armed> (by B<toast arm>).  In the last two cases, the build will
be marked C<(not clean)> if intermediate files created by B<toast build>
have not yet been removed by C<toast clean>.

=item S<B<toast 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<--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 S<B<--verbose> | B<--noverbose>>

Enables or disables verbose command output.  When disabled, most commands
will produce output only on failure.  Some commands, such as B<toast
status>, are not affected by this flag.  Default: enabled.

=item S<B<--autofind> | B<--noautofind>>

When B<autofind> is enabled, B<toast add> and other commands will
automatically look up package URLs 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, B<toast build> performs an implicit B<toast
clean> on every newly created non-broken build.  Default: enabled.

=item S<B<--autopurge> | B<--noautopurge>>

When B<autopurge> is enabled, B<toast build> performs an implicit
B<toast purge> on every package with a newly created non-broken build.
Default: disabled.

=item S<B<--autoarm> | B<--noautoarm>>

When B<autoarm> is enabled, B<toast build> performs 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 build> performs an implicit
B<toast demolish> on every other build belonging to the same package
as a newly-created, non-broken build.  Default: disabled.

=item S<B<--autoremove> | B<--noautoremove>>

When both B<autoremove> and B<crossversion> are enabled, B<toast build>
performs an implicit B<toast remove> on every other package with the
same name as the package containing a newly-created, non-broken build.
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<--strictpreload> | B<--nostrictpreload>>

When B<strictpreload> is enabled, B<toast build> will fail unless it can
successfully compile a shared library for use with LD_PRELOAD during the
"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<--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 may not build or install itself
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
includes by default.  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.

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

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

=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<$HOME/.toast/conf>, if that file exists.  (C<$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 AUTHOR

Jacques Frechet

=cut

# questions still unanswered by man page:
# what protocols and archive formats are supported?
# what kinds of packages can be expected to build?
# how are storedir and armdir structured?
# how does this tool differ from similar tools?
# how might people actually use this thing?

# other ideas (stolen from real man pages observed in the wild):
# RETURN VALUE
# TIPS
# NOTES
# AVAILABILITY
# URL
# ENVIRONMENT
# FILES
# SEE ALSO
# DIAGNOSTICS
# BUGS
# VERSIONS