Perl meta-programming in anger.

meta.pl

#!/usr/bin/perl -w

use strict;
use sigtrap qw(die normal-signals error-signals);
use Carp;
use Config;
use Fcntl qw(:flock);
use File::Basename;
use File::Copy;
use File::Path;
use IO::File;
use List::Util qw(reduce);
use POSIX qw(setpgid);
use Sys::Hostname;
use Sys::Syslog;
use Time::Local;

# The machine and account that manage automated builds.
#
sub buildMaster       () { 'build.fnord.com'; }
sub buildRobot        () { 'builder'; }

sub releasesRoot      () { '/releases'; }
sub releasesLocks     () { '/releases/locks'; }
sub installersArchive () { '/releases/archived-installers'; }

# Where build launcher state is shared on buildMaster.
#
sub buildLock         () { '/releases/build/lock'; }
sub buildState        () { '/releases/build/state'; }

# Run this to make a new release build.
#
sub makeRelease       () { '/usr/local/bin/make-release.sh'; }

sub depotNameForBranch { my ($b) = @_; "//fnord/$b"; }

# Return the depot name of the builds.conf.global file for $branch.
#
sub buildConfGlobalForBranch {
  my ($branch) = @_;
  my $depot = depotNameForBranch($branch);
  return "$depot/tools/builds.conf.global";
}

# Show some extra output on STDERR when true.
#
my $debug;

# Make output pretty and help parse old --foo=bar syntax.
#
my $indent = ' ' x 4;
my $dash = '--';

# Debug the format of dumps for debugging ... more easily.
# my ($aMark, $bMark, $cMark, $dMark, $eMark, $fMark) = qw(A B C D E F);
#
my ($aMark, $bMark, $cMark, $dMark, $eMark, $fMark) = ('', '', '', '', '', '');


# Return an array of hashes describing commands ordered by use
# frequency.
#
sub getCommandInfo {
  my ($me) = @_;
  my $separator = "\n$indent";
  my @serverOptions = ("${dash}<platform>-server=<server>",
                       "And <platform> is one of 'win32', 'linux', ...",
                       "    and so on, as reported by '$me status'");
  my $serverOptions = join $separator, @serverOptions;
  my @lockDescription =
    ('Request exclusive use of <server> for <reason>.',
     'Send mail when <server> is available if already locked.');
  my $lockDescription = join $separator, @lockDescription;
  my @addDescription =
    ('Reconfigure <branch> with <options>s to use for builds.',
     'Forget any prior configuration of <branch>.');
  my $addDescription = join $separator, @addDescription;
  my @addWhere = ('<option> is any of',
                  "${dash}save-days=<N>",
                  'Save builds for at least <N> days.',
                  "${dash}mail='tom dick harry'",
                  'Send status mail to tom, dick and harry.');
  my $addWhere = join $separator, @addWhere;
  my @deleteDescription =
    ('Forget about <branch>.',
     "Use '$me add <branch>' to reconfigure <branch>");
  my $deleteDescription = join $separator, @deleteDescription;
  my @keys = qw(COMMAND ARGUMENTS DESCRIPTION WHERE);
  my @commands =
    ([
      'status', '',
      'Report status of build servers.',],
     [
      'force', '<branch> [<server-option>]',
      'Build <branch> using the specified servers.',
      "<server-option> is $serverOptions"],
     [
      'kill', '<branch> [<branch> ...]',
      'Fail any unfinished build of <branch>.'],
     [
      'unforce', '<branch> [<branch> ...]',
      'Cancel any pending force request for <branch>.'],
     [
      'enable', '<branch> [<branch> ...]',
      'Build <branch> whenever it changes.'],
     [
      'disable', '<branch> [<branch> ...]',
      "Do not build <branch> without ${dash}force."],
     [
      'lock', '<server> [<reason>]',
      $lockDescription],
     [
      'cancel-locks', '',
      'Cancel your pending lock requests.'],
     [
      'unlock', '<server> [<server> ...]',
      'Relinquish exclusive use of server.'],
     [
      'add', '<branch> [<option> ...]',
      $addDescription,
      $addWhere],
     [
      'delete', '<branch> [<branch> ...]',
      $deleteDescription],
     [
      'disable-builds', '<reason>',
      'Disable the builder for <reason> so no one can run it.'],
     [
      'enable-builds', '',
      'Enable the builder so it can be run again.'],
     [
      'run', '',
      'Start any requested builds.'],
     [
      'servers', '<platform> <server> [<server> ...]',
      'Specify list of <server>s prioritized for <platform>.'],
     [
      'list-branches', '',
      'Summarize the state of known branches.'],
     [
      'list-builds', '',
      'Show running builds sorted by branch name.'],
     [
      'list-reapable-builds', '',
      'Show a list of reapable builds sorted by partition.']
    );
  my @result;
  for (@commands) {
    my $commandName = $_->[0];
    my @words = split '-', $commandName;
    my $subName = 'do' . join('', map(ucfirst, @words)) . 'Command';
    my %command; @command{'SUBNAME', @keys} = ($subName, @$_);
    push @result, \%command;
  }
  return @result;
}


# cleanup(sub { ... }) sets up ... to run at process exit when
# runCleanupSubs() is called.
#
# cleanup() code runs when the process exits or is interrupted because
# the use sigtrap pragma above sets a die handler for normal-signals.
#
# HACK: $beginPidHack avoids running the END block from two different
# processes when exec() fails after a fork().
#
{
  my $beginPidHack = $$;
  my @cleanupStack = ();
  sub cleanup { push @cleanupStack, @_; }
  sub runCleanupSubs () { while ($_ = pop @cleanupStack) { $_->(); } }
  END {
    runCleanupSubs() if ($beginPidHack == $$);
  }
}


# ignoreInterrupts() sets the handlers for the @ints signals to
# 'IGNORE'.  restoreInterrupts() restores the @ints handlers to
# what they were last time ignoreInterrupts() was called.
#
{
  my @signalHandlersStack = ();
  sub ignoreInterrupts () {
    my @ints = qw(TERM PIPE HUP INT);
    my %shs; @shs{@ints} = @SIG{@ints};
    push @signalHandlersStack, sub { @SIG{@ints} = @shs{@ints}; };
    @SIG{@ints} = ('IGNORE') x @ints;
  }
  sub restoreInterrupts () {
    if (@signalHandlersStack) {
      my $restoreHandlers = pop @signalHandlersStack;
      $restoreHandlers->();
    }
  }
}


# Show a usage message on STDERR and exit.
#
sub showUsage {
  my ($me) = @_;
  my $usage = "Usage: $me <command> [<argument> ...]";
  my $where = ('Where: <branch> is a branch name such as "//fnord/trunk/".'
               . "\n" .
               '       <server> is a build server hostname.');
  my @lines = ($usage, $where);
  my @commands = getCommandInfo($me);
  for my $command (@commands) {
    push(@lines, "",
         "$me $command->{COMMAND} $command->{ARGUMENTS}",
         "$indent$command->{DESCRIPTION}");
    push(@lines, "Where: $command->{WHERE}") if ($command->{WHERE});
  }
  print(STDERR "$_\n") for @lines;
  exit 1;
}


# Open $name according to $mode, lock it for exclusive access,
# and return a filehandle on it.  Prefer flock to close status.
#
# For $mode:     READ   WRITE   APPEND   TRUNCATE   CREATE
#            <   read   -----   ------   --------   ------   <
#            >   ----   write   ------   truncate   create   >
#            >>  ----   write   append   --------   create   >>
#           +<   read   write   ------   --------   ------  +<
#           +>   read   write   ------   truncate   create  +>
#           +>>  read   -----   append   --------   create  +>>
#
sub lockFile {
  my ($mode, $name) = @_;
  if (open(my $file, $mode, $name)) {
    if (flock($file, LOCK_EX)) {
      return $file;
    } else {
      my $flockStatus = $!;
      close $file;
      $! = $flockStatus;
    }
  }
  return undef;
}


# Unlock and close the file on the filehandle $fh.
#
sub unlockFile {
  my ($fh) = @_;
  close $fh;
}


# Return 'central/trunk' for '//fnord/central/trunk/' ... or
# '//x/central/trunk' or '//fnord/central/trunk/' for that matter.
#
sub branchNameNoDepot {
  my ($branch) = @_;
  my $result = $branch;
  $result =~ s%^//[^/]+/([^/]+)%$1%o;
  $result =~ s%^/+%%o;
  $result =~ s%/+$%%o;
  return $result;
}


# Return the first part of the $server hostname in lowercase.
#
sub serverNameNoDomain {
  my ($server) = @_;
  my @parts = split /\./, $server;
  return lc $parts[0];
}


# Return the name of the lock file for $server.
#
sub getLockFileForServer {
  my ($server) = @_;
  my $directory = releasesLocks;
  my $name = serverNameNoDomain($server);
  return "$directory/BUILD-LOCK-$name";
}


# Return a local timestamp string like '2010-06-28-144746'
# (YYYY-MM-DD-HHMMSS) for $time -- or now without $time.
#
sub makeTimeStamp {
  my ($time) = @_;
  $time = time unless ($time);
  my ($second, $minute, $hour, $mday, $month, $year, $wday, $yday, $isdst) =
    localtime($time);
  $year += 1900;
  $month += 1;
  my $result = sprintf("%4d-%02d-%02d-%02d%02d%02d",
                       $year, $month, $mday, $hour, $minute, $second);
  return $result;
}


# Return 0 on error or the time parsed from the time $stamp such as
# '2009-09-22-211935'.  That is 'YYYY-MM-DD-HHMMSS'.  Return a regular
# expression to match a timeStamp if no $stamp;
#
sub parseTimeStamp {
  my ($stamp) = @_;
  my $result = 0;
  return '\d{4}-\d{2}-\d{2}-\d{6}' unless ($stamp);
  my @data = $stamp =~ /^(\d{4})-(\d{2})-(\d{2})-(\d{2})(\d{2})(\d{2})$/o;
  if (@data == 6) {
    my ($year, $month, $day, $hour, $minute, $second) = @data;
    $month -= 1;
    $year -= 1900;
    $result = timelocal($second, $minute, $hour, $day, $month, $year);
  }
  return $result;
}


# Run @command on behalf of $me returning its output and status.  If
# @command runs longer than $timeout seconds, kill TERM it.  Return
# the @command's exit status, and line counts of STDOUT and STDERR
# followed by the lines it wrote to STDOUT and STDERR.  A 0 $timeout
# means don't time out the @command.
#
# HACK: A false $me means run @command in a new process group.
#
# my ($status, $outs, $errs, @output) = runProgram('me', 0, @command);
# my @stdout = splice(@output, 0, $outs);
# my @stderr = splice(@output, $outs, $errs);
#
sub runProgram {
  my ($me, $timeout, @command) = @_;
  my (@result, $parentStdout, $stdout);
  pipe $parentStdout, $stdout;
  my $stderr = IO::File->new_tmpfile or die "$me: Cannot open tmpfile.\n";
  my $child = fork;
  if ($child == 0) {
    close $parentStdout;
    close STDOUT;
    open(STDOUT, '>&', $stdout) or die "$me: Cannot open STDOUT: $!";
    select STDOUT; $| = 1;
    close STDERR;
    open(STDERR, '>&', $stderr) or die "$me: Cannot open STDERR: $!";
    select STDERR; $| = 1;
    setpgid(0, 0) unless ($me);
    exec { $command[0] } @command;
    die "$me: exec '@command' failed: $!";
  } elsif ($child) {
    close $stdout;
    eval {
      local $SIG{ALRM} = sub { kill 'TERM', $child; };
      alarm $timeout;
      my @out = <$parentStdout>;
      alarm 0;
      my @err = <$stderr>;
      unlockFile($stderr);
      @result = (scalar @out, scalar @err, @out, @err);
    };
    waitpid $child, 0;
    unshift @result, $?;
  } else {
    die "$me Cannot fork: $!";
  }
  return @result;
}


# Return the ssh command line @args prefixed with options to tame ssh
# and run as $as.  This works around some filesystem permission
# mapping problems that occur from time to time.
#
sub sshCommand {
  my ($me, $as, @args) = @_;
  my @result = qw(/usr/bin/ssh -q -c 3des -oBatchMode=yes
                  -oProtocol=1 -oFallBackToRsh=no -oForwardAgent=no
                  -oForwardX11=no -oStrictHostKeyChecking=no);
  if ($as eq buildRobot) {
    my $id = "/tmp/$as-ssh-identity-$<";
    if (! -r $id) {
      ignoreInterrupts();
      my $mask = umask 077;
      copy("/user/$as/.ssh/identity", $id) or die "$me: Cannot make $id: $!";
      umask $mask;
      cleanup(sub { unlink $id; });
      restoreInterrupts();
    }
    push @result, '-i', $id;
  }
  push @result, '-l', $as, @args;
  return @result;
}


# Send @message in email to $to with @subject.
#
sub sendMail {
  my ($me, $to, $subject, @message) = @_;
  my @args = (qw(/usr/bin/Mail -s), $subject, $to);
  if (open my $mail, '|-', @args) {
    print $mail @message, "\n";
    close $mail;
  } else {
    syslog('err', "Cannot @args");
    die "$me: Cannot @args";
  }
  return 1;
}


# Return @_ as a single line with newlines replaced by / characters.
#
sub singleLineSlashify {
  my $result = "@_";
  $result =~ s%\s*\n\s*%/%go;
  return $result;
}


# Take the build lock to prevent builder from running.  Return a
# handle on the locked file and its contents or die if the file can
# not be locked.  Caller must eventually close the result.
#
sub disableBuilds {
  my ($me, $user, @reasons) = @_;
  my $lock = buildLock;
  my @content = ();
  open(my $file, '+>>', $lock) or croak("$me: Open '$lock' failed with: $!");
  my $flag="lock timeout $$";
  my $limit = 5;
  my $report = "$me: locked, waiting $limit ";
  for (0..$limit) {
    eval {
      local $SIG{ALRM} = sub { die $flag };
      alarm 10;
      flock $file, LOCK_EX;
      alarm 0;
    };
    if ($@) {
      croak("$me: Unexpected signal: $@") unless $@ eq $flag;
    } else {
      seek $file, 0, 0;
      @content = <$file>;
      if (0 == @content) {
        seek $file, 0, 0;
        truncate $file, 0;
        print $file "$me disabled by $user ";
        print $file "from process $$ at ", makeTimeStamp(), "\n";
        print $file "Reason: @reasons\n";
        seek $file, 0, 0;
        return ($file, <$file>);
      } else {
        print STDERR $report;
        $report = $limit - $_ - 1; $report = "$report ";
        sleep 1;
      }
    }
  }
  close $file;
  print STDERR "done\n";
  my $content = singleLineSlashify(@content);
  syslog('debug', "Cannot run because %s", $content);
  die "$me: Cannot run: @content";
  return 0;
}


# This implements ~~ for arrays which is not supported in old Perls.
# Return true if $a and $b refer to arrays with equivalent content.
# Return false if the arrays differ in any element or their size.
#
sub arraysEqual {
  my ($a, $b) = @_;
  return 0 if (@$a != @$b);
  for (my $n = 0; $n < @$a; ++$n) {
    return 0 if ($a->[$n] ne $b->[$n]);
  }
  return 1;
}


# Return with builds re-enabled.  If $file then check its actual
# contents against the @expected contents, and unlink (then close to
# unlock) the file if they agree.  Otherwise just unlink the file.
#
sub enableBuilds {
  my ($me, $file, @expected) = @_;
  my $lock = buildLock;
  if ($file && @expected) {
    seek $file, 0, 0;
    my @actual = <$file>;
    if (arraysEqual(\@actual, \@expected)) {
      unlink $lock or croak("$me: Cannot remove $lock");
      close $file;
    } else {
      my $actual = singleLineSlashify(@actual);
      syslog('err', "Unexpected $lock: $actual");
      die "$me: Unexpected $lock:\n", @actual;
    }
  } else {
    my $file = lockFile('<', $lock);
    if ($file) {
      print <$file>;
      print STDERR "$me: Deleting $lock ...";
      if (unlink $lock) {
        unlockFile($file);
        print STDERR " done.\n";
      } elsif (-e $lock) {
        syslog('err', "Cannot remove $lock");
        die "\n$me: Cannot remove $lock";
      }
    }
  }
}


# Return a hash of $options by turning
#     '--a|--nob|--c=d|--e=|f=|g|noh|i=j|'
# into
#     ('a' => 'true', 'b' => 'false', 'c' => d,       'e' => '',
#      'f' => '',     'g' => 'true',  'h' => 'false', 'i' => j)
#
# Necessary only to support old state file syntax.
#
sub parseOptions {
  my ($options) = @_;
  my %result;
  for my $option (split /\|/, $options) {
    $option =~ s/^$dash//o;
    my ($name, $value) = ($option =~ m/^(.*)=(.*)$/o);
    if ($name) {
      $result{$name} = $value;
    } else {
      my ($no, $name) = ($option =~ m/^(no|)(.*)$/o);
      $result{$name} = ($no? 'false': 'true') if ($name);
    }
  }
  return %result;
}

# Return an option string from %options by inverting parseOptions().
#
# Necessary only to support old state file syntax.
#
sub unparseOptions {
  my %options = @_;
  my $result = '';
  my $separator = '';
  for my $name (sort keys %options) {
    my $value = $options{$name};
    if ($value eq 'true') {
      $result = "$result$separator$dash$name";
    } elsif ($value eq 'false') {
      $result = "$result$separator$dash" . "no$name";
    } else {
      $result = "$result$separator$dash$name=$value";
    }
    $separator = '|';
  }
  return $result;
}


# Read the state file at $name and return a hash of its content.
#
sub readBuildStateFile {
  my ($me, $name) = @_;
  my $generation = 0;
  my %options;
  my %branches;
  my %servers;
  my @warnings;
  my %locks;
  my $count = 0;
  my $file = lockFile('<', $name) or die "$me: Cannot read '$name': $!.";
  for (<$file>) {
    ++$count;
    next if m/^\s*#/o;
    if (my $number = m/^\s*generation\s+(\d+)/o) { # generation 23
      $generation = $number;
    } elsif (my ($globalOptions) = m/^\s*option\s+(.*)\s*$/o) {
      # option --nobuild-unchanged
      my %news = parseOptions($globalOptions);
      my @keys = keys %news;
      @options{@keys} = @news{@keys};
    } elsif (my ($platform, $servers) = m/^\s*servers\s+(\S+)\s+(.*)\s*$/o) {
      # servers win32 axe zerg
      my @servers = split /\s+/, $servers;
      $servers{$platform} = \@servers;
    } elsif (my ($branch, $options) = m/^\s*branch\s+(\S+)\s+(.*)$/o) {
      # branch central/trunk --disabled|--mail='tbl builder'
      my %options = parseOptions($options);
      $branches{$branch} = \%options;
    } elsif (my ($warning) = m/^\s*warning\s+(.*)\s*$/o) {
      # warning <kind> <args> ...
      push @warnings, $warning;
    } elsif (my ($us, $stuff) = m%^\s*lock\s+([^/\s]+/[^/\s]+)\s+(.+)$%o) {
      # lock tbl/axe --reason=test|--server=axe|--time=1277322564
      my %options = parseOptions($stuff);
      $locks{$us} = \%options;
    } else {
      carp("$me: Ignoring line $count in $name: $_");
    }
  }
  unlockFile($file);
  my %result = (GENERATION => $generation,
                OPTIONS    => \%options,
                SERVERS    => \%servers,
                BRANCHES   => \%branches,
                WARNINGS   => \@warnings,
                LOCKS      => \%locks);
  return %result;
}


# Write %state out to file named $name with interrupts disabled.
#
sub writeBuildStateFile {
  my ($me, $user, $name, %state) = @_;
  my $time = makeTimeStamp();
  my $generation = 1 + $state{GENERATION};
  my %servers = %{$state{SERVERS}};
  my %branches = %{$state{BRANCHES}};
  my %locks = %{$state{LOCKS}};
  ignoreInterrupts();
  my $file = lockFile('>', $name) or die "$me: Cannot write '$name': $!.";
  print $file "# Written by $user at $time with $0 @ARGV\n";
  print $file "generation $generation\n";
  for (split(/\|/, unparseOptions(%{$state{OPTIONS}}))) {
    print $file "option $_\n";
  }
  for my $platform (sort keys %servers) {
    my @servers = @{$servers{$platform}};
    print $file "servers $platform @servers\n";
  }
  for my $name (sort keys %branches) {
    my %options = %{$branches{$name}};
    my $options = unparseOptions(%options);
    print $file "branch $name $options\n";
  }
  for (@{$state{WARNINGS}}) {
    print $file "warning $_\n";
  }
  for my $us (sort keys %locks) {
    my %options = %{$locks{$us}};
    my $options = unparseOptions(%options);
    print $file "lock $us $options\n";
  }
  unlockFile($file);
  restoreInterrupts();
}


# For @_ with (x y ...)  or (--x y ...),  return x or (x).
# For @_ with (x= y ...) or (--x= y ...), return x or (x, '').
# For @_ with (x=y ...)  or (--x=y ...),  return x or (x, y).
# For @_ empty, return undef.
# Always leave y, and '', in @_;
#
# Necessary only to support old command line syntax.
#
sub getNextNameValue {
  my ($argsRef) = @_;
  if (my $scalarResult = shift @$argsRef) {
    my @arrayResult;
    if (my ($name, $value) = $scalarResult =~ m/^([^=]+)=([^=]*)$/o) {
      $scalarResult = $name;
      @arrayResult = ($value);
      unshift @$argsRef, $value;
    }
    $scalarResult =~ s/^$dash//o;
    unshift @arrayResult, $scalarResult;
    return wantarray? @arrayResult: $scalarResult;
  }
  return undef;
}


# Collect status of the %servers from their lock files.
#
sub collectServerLockStatus {
  my (%servers) = @_;
  my %result = ();
  my @tags = doStatusCommand();
  for my $platform (keys %servers) {
    my @servers;
    for my $server (@{$servers{$platform}}) {
      my %status; @status{@tags} = ($server, '-', '-', '-');
      my $lock = getLockFileForServer($server);
      my $file = lockFile('<', $lock);
      if ($file) {
        $status{LOCK} = $lock;
        $status{BRANCH} = 'unspecified';
        for (<$file>) {
          if (my ($start) = m/^start:\s+(.*) ....\s*$/o) {
            $status{START} = $start;
          } elsif (my ($user) = m/^username:\s+(\S+)\s*$/o) {
            $status{USERNAME} = $user;
          } elsif (my ($branch) = m/^branch:\s+(\S+)\s*$/o) {
            $status{BRANCH} = $branch;
          } elsif (my ($comment) = m/^comment:\s+(.*)\s*$/o) {
            $status{COMMENT} = $comment;
          }
        }
        unlockFile($file);
      }
      push @servers, \%status;
    }
    $result{$platform} = \@servers;
  }
  return %result;
}


# Print server status in hash on $infoRef to STDOUT in @tags order
# according to $format and $indent.
#
sub printServerStatus {
  my ($infoRef, $format, $indent, @tags) = @_;
  my $autoComment = makeAutomaticBuildServerLockReasons();
  return $autoComment unless ($infoRef);
  my %info = %{$infoRef};
  my @platforms = reverse sort keys %info;
  my $line = '-' x 80;
  print "\nStatus for platforms: @platforms\n\n";
  printf $format, map(ucfirst lc, @tags);
  for my $platform (@platforms) {
    print "$line\n";
    for my $server (@{$info{$platform}}) {
      my %status = %{$server};
      printf $format, @status{@tags};
      if (exists $status{COMMENT}) {
        my $c = $status{COMMENT};
        if ($c ne $autoComment) {
          print ' ' x $indent, " COMMENT: $c\n";
        }
      }
    }
  }
  print "$line\n\n";
}


# Show status of SERVERS on STDOUT.
#
# FIXME: Ping for reachable/unreachable in parallel rather than in
# series such that timeouts expire concurrently.
#
sub doStatusCommand {
  my ($me, $user) = @_;
  my $file = buildState;
  my %state = readBuildStateFile($me, $file);
  my @tags = qw(SERVER USERNAME BRANCH START);
  return @tags unless ($me);
  my %servers = %{$state{SERVERS}};
  if (!%servers) {
    die "$me: No servers! Run '$me servers ...' to add servers.\n";
  }
  my %info = collectServerLockStatus(%servers);
  for my $platform (keys %info) {
    my @servers = @{$info{$platform}};
    for my $server (@servers) {
      if ($server->{START} eq '-') {
        my $hostname = $server->{SERVER};
        my @in = ($me, 'available', $$, $hostname);
        my $re = '/'. join('\s*', @in) . '/';
        my @ssh = sshCommand($me, buildRobot, $hostname, 'echo', @in);
        my ($s, $outs, $errs, @output) = runProgram($me, 13, @ssh);
        my @out = splice(@output, 0, $outs);
        my $reachable = $s == 0 && @out && grep($re, @out);
        $server->{START} = $reachable? 'available': 'unreachable';
      }
    }
    $info{$platform} = \@servers;
  }
  my $indent = 15;
  my $format = "%-${indent}s %-11s %-30s %-6s\n";
  printServerStatus(\%info, $format, $indent, @tags);
  return 1;
}


# Show unknown $branch and how to fix it.
#
sub showUnknownBranch {
  my ($me, $branch) = @_;
  print STDERR "$me: Unknown branch: $branch\n";
  print STDERR "$me: To fix that run: $me add $branch\n";
}


# Force branch to build using options parsed from @args.
# FIXME: Just add some new 'force' records to the state file.
#
sub doForceCommand {
  my ($me, $user, $branch, @args) = @_;
  my $result = 1;
  my $name = branchNameNoDepot($branch);
  my %forceOptions = ('time', time(), 'user', $user);
  for (@args) {
    my %parsed = parseOptions($_);
    @forceOptions{keys %parsed} = values %parsed;
  }
  my $file = buildState;
  my ($lock, @content) = disableBuilds($me, $user, @ARGV, "\n");
  cleanup(sub { enableBuilds($me, $lock, @content); });
  my %state = readBuildStateFile($me, $file);
  my %branches = %{$state{BRANCHES}};
  if (exists $branches{$name}) {
    my %options = %{$branches{$name}};
    @options{keys %forceOptions} = values %forceOptions;
    $branches{$name} = \%options;
    $state{BRANCHES} = \%branches;
    writeBuildStateFile($me, $user, $file, %state);
  } else {
    showUnknownBranch($me, $name);
    $result = 0;
  }
  return $result;
}


# Dump the @rows from getReportHashes() as a Perl literal.
#
sub dumpReportHash {
  my ($columnsRef, @rows) = @_;
  my @columns = @$columnsRef;
  print STDERR "${aMark}[[@columns]";
  my $aSep = ",\n ${bMark}{";
  for (@rows) {
    print STDERR $aSep;
    $aSep = ",\n ${bMark}{";
    my %row = %{$_};
    my $bSep = '';
    for my $column (@columns) {
      if (my $value = $row{$column}) {
        print STDERR "$bSep'$column' => '$row{$column}'";
        $bSep = ",\n  ";
      }
    }
    print STDERR "}${bMark}";
  }
  print STDERR "]${aMark}\n";
}


# Run @_ and parse the standard output into an array of rows hashed by
# column headers.
#
# For example, if @_ is qw(/bin/ps x), return something like:
#
# ([ PID, TIME, COMMAND ],
#  { PID => 13135, TIME => 0:00, COMMAND => '/bin/ps x'                 },
#  { PID => 22656, TIME => 0:16, COMMAND => 'bash -i'                   },
#  { PID => 30467, TIME => 1:07, COMMAND => 'perl -w build.pl kill ...' })
#
# If there are more fields than column headers, tack the remaining
# fields onto the last hash key.
#
sub getReportHashes {
  my @result;
  my @columns;
  open(my $out, '-|', @_);
  for (<$out>) {
    s/^\s+//o;
    s/\s+$//o;
    if (@columns) {
      my (%row); @row{@columns} = split /\s+/, $_, @columns;
      push @result, \%row;
    } else {
      @columns = split;
      push @result, \@columns;
    }
  }
  close $out;
  dumpReportHash(@result) if ($debug);
  return @result;
}


# Kill any build processes for @branches: Find all top-level (PPID=>1)
# makeRelease processes owned by buildRobot.  Signal the process group
# if the makeRelease command line is for any of @branches.
#
# Use /bin/kill because Perl's own 'kill -TERM $pgid' doesn't work.
#
sub doKillCommand {
  my ($me, $user, @rest) = @_;
  my @branches = map branchNameNoDepot($_), @rest;
  my %topPgids;
  my $mtr = makeRelease;
  my @ps = getReportHashes(qw(/bin/ps j w w U), buildRobot); shift @ps;
  for (@ps) {
    my %info = %$_;
    my ($ppid, $pgid, $c) = @info{qw(PPID PGID COMMAND)};
    my ($b) = $c =~ m%\s+$mtr --branch (.*) --root /releases/%;
    $topPgids{$b} = $pgid if ($b && $pgid && $ppid && $ppid == 1);
  }
  my @victims;
  for my $branch (@branches) {
    if (exists $topPgids{$branch}) {
      push @victims, "-$topPgids{$branch}";
    } else {
      print STDERR "$me: No '$mtr' process for branch '$branch'.\n";
      print STDERR "$me: Try again if a '$branch' build just started.\n";
    }
  }
  if (@victims) {
    my @kill = (qw(/bin/kill -s TERM --), @victims);
    syslog('info', "Running: @kill");
    my @ssh = sshCommand($me, buildRobot, buildMaster, @kill);
    my ($status, $outs, $errs, @output) = runProgram($me, 0, @ssh);
    if ($status != 0) {
      my $output = singleLineSlashify(@output);
      syslog('err', "'@kill' failed with $status: $output");
      print STDERR "$me: '@kill' failed with $status: @output\n";
      return 0;
    }
  }
  return 1;
}


# Remove any force options from @branches.
# Return all keys set by doForceCommand() when not $me.
# FIXME: Just delete new 'force' records from the state file.
#
sub doUnforceCommand {
  my ($me, $user, @branches) = @_;
  my $result = 1;
  my @bs = map branchNameNoDepot($_), @branches;
  my $file = buildState;
  my @forceKeys =
    qw(time user linux-server mac-ppc-server mac-x86-server win32-server);
  return @forceKeys if (!$me);
  my ($lock, @content) = disableBuilds($me, $user, @ARGV, "\n");
  cleanup(sub { enableBuilds($me, $lock, @content); });
  my %state = readBuildStateFile($me, $file);
  my %branches = %{$state{BRANCHES}};
  for (@bs) {
    if (exists $branches{$_}) {
      my %options = %{$branches{$_}};
      delete @options{@forceKeys};
      $branches{$_} = \%options;
    } else {
      showUnknownBranch($me, $_);
      $result = 0;
    }
  }
  $state{BRANCHES} = \%branches;
  writeBuildStateFile($me, $user, $file, %state);
  return $result;
}


# Enable automated building by removing the --disabled option from
# @branches.
#
sub doEnableCommand {
  my ($me, $user, @branches) = @_;
  my $result = 1;
  my @bs = map branchNameNoDepot($_), @branches;
  my $file = buildState;
  my ($lock, @content) = disableBuilds($me, $user, @ARGV, "\n");
  cleanup(sub { enableBuilds($me, $lock, @content); });
  my %state = readBuildStateFile($me, $file);
  my %branches = %{$state{BRANCHES}};
  for (@bs) {
    if (exists $branches{$_}) {
      delete $branches{$_}->{'disabled'};
    } else {
      showUnknownBranch($me, $_);
      $result = 0;
    }
  }
  writeBuildStateFile($me, $user, $file, %state);
  return $result;
}


# Disable automated building by adding the --disabled option to
# @branches (and removing any potential --enabled) option.
#
sub doDisableCommand {
  my ($me, $user, @branches) = @_;
  my $result = 1;
  my @bs = map branchNameNoDepot($_), @branches;
  my $file = buildState;
  my ($lock, @content) = disableBuilds($me, $user, @ARGV, "\n");
  cleanup(sub { enableBuilds($me, $lock, @content); });
  my %state = readBuildStateFile($me, $file);
  my %branches = %{$state{BRANCHES}};
  for (@bs) {
    if (exists $branches{$_}) {
      $branches{$_}->{'disabled'} = 'true';
      delete $branches{$_}->{'enabled'};
    } else {
      showUnknownBranch($me, $_);
      $result = 0;
    }
  }
  writeBuildStateFile($me, $user, $file, %state);
  return $result;
}


# Save 'lock <user>/<server> ...<options>...' in the state file.
#
sub recordPendingLock {
  my ($me, $user, $server, @reasons) = @_;
  my $file = buildState;
  my ($lock, @content) = disableBuilds($me, $user, @ARGV, "\n");
  cleanup(sub { enableBuilds($me, $lock, @content); });
  my %state = readBuildStateFile($me, $file);
  my %locks = %{$state{LOCKS}};
  my %options;
  $options{'time'} = time();
  $options{'server'} = $server;
  $options{'reason'} = "@reasons";
  $locks{"$user/$server"} = \%options;
  $state{LOCKS} = \%locks;
  writeBuildStateFile($me, $user, $file, %state);
  syslog('info', "Lock $server pending for $user");
  print "$me: You will receive mail when $server is free to use.\n";
  print "$me: To cancel your request run: $me cancel-locks\n";
}


# If $server is already locked, show content of its lock file and
# record a lock request in the state file if $me.  Otherwise create a
# new lockfile for $server containing @reasons.
#
sub doLockCommand {
  my ($me, $user, $server, @reasons) = @_;
  my $lock = getLockFileForServer($server);
  my $file = lockFile('<', $lock);
  if ($file && $me) {
    print "$me: Server '$server' is already locked.\n";
    print <$file>;
    unlockFile($file);
    recordPendingLock($me, $user, $server, @reasons);
    return undef;
  }
  $file = lockFile('>', $lock);
  if ($file) {
    print $file 'start: ' . localtime, "\n";
    print $file "username: $user\n";
    print $file "\ncomment: @reasons\n";
    unlockFile($file);
    syslog('info', "Locked $server for $user");
    return 1;
  }
  return undef;
}


# Cancel any locks pending for $user by removing any LOCKS records
# hashed by $user/$server.
#
sub doCancelLocksCommand {
  my ($me, $user) = @_;
  my $file = buildState;
  my ($lock, @content) = disableBuilds($me, $user, @ARGV, "\n");
  cleanup(sub { enableBuilds($me, $lock, @content); });
  my %state = readBuildStateFile($me, $file);
  my %locks = %{$state{LOCKS}};
  my @servers;
  for (keys %locks) {
    my ($u, $s) = m%^([^/\s]+)/([^/\s]+)$%o;
    push(@servers, $s) if ($u eq $user);
  }
  if (@servers) {
    print "$me: Canceling lock on: @servers\n";
    delete $locks{"$user/$_"} for @servers;
    $state{LOCKS} = \%locks;
  }
  writeBuildStateFile($me, $user, $file, %state);
  return 1;
}


# Reboot $server as necessary for its platform.
#
my %rebootersCacheForRebootBuildServerHackHack;
sub rebootBuildServerHack {
  my ($me, $server) = @_;
  my %reboot = %rebootersCacheForRebootBuildServerHackHack;
  if (!%reboot) {
    my %state = readBuildStateFile($me, buildState);
    my %servers = %{$state{SERVERS}};
    for my $platform (keys %servers) {
      my @hosts = @{$servers{$platform}};
      for (@hosts) {
        my @command;
        if ($platform =~ /^win32/o) {
          @command = qw(/usr/bin/shutdown -r now);
        } elsif ($platform =~ /^mac-/o) {
          @command = qw(sudo /sbin/shutdown -r now);
        }
        $reboot{$_} = \@command if (@command);
      }
    }
  }
  if (exists $reboot{$server}) {
    my @command = @{$reboot{$server}};
    my @ssh = sshCommand($me, buildRobot, $server, @command);
    my ($status, $outs, $errs, @output) = runProgram($me, 99, @ssh);
    if ($status != 0) {
      my $output = singleLineSlashify(@output);
      syslog('err', "'@command' failed with $status: $output");
      print STDERR "$me: '@command' failed with $status: @output\n";
      return 0;
    }
  }
  return 1;
}


# Unlock @servers by deleting their lock files and rebooting them.
#
# Skip dumping the lock file and rebooting the server if called for
# internal use (from a void context) to release servers reserved for a
# build that is later called off.
#
sub doUnlockCommand {
  my ($me, $user, @servers) = @_;
  my $result = 1;
  for my $server (@servers) {
    my $lock = getLockFileForServer($server);
    my $file = lockFile('<', $lock);
    if ($file) {
      if (defined wantarray) {
        print "\n$me: Unlocking server '$server'.\n";
        print <$file>;
        $result = 0 if (!rebootBuildServerHack($me, $server));
      }
      if (!unlink($lock) && -e $lock) {
        syslog('err', "Cannot remove file '$lock'");
        print STDERR "\n$me: Cannot remove file '$lock'.";
        $result = 0;
      }
      unlockFile($file);
    }
  }
  return $result;
}


# Use options from @args for $branch in the buildState file.
#
sub doAddCommand {
  my ($me, $user, $branch, @args) = @_;
  my %options = ();
  for (@args) {
    my %parsed = parseOptions($_);
    @options{keys %parsed} = values %parsed;
  }
  my $name = branchNameNoDepot($branch);
  if (my ($partIgnored, $availIgnored) = getPartitionInfo($name)) {
    my $file = buildState;
    my ($lock, @content) = disableBuilds($me, $user, @ARGV, "\n");
    cleanup(sub { enableBuilds($me, $lock, @content); });
    my %state = readBuildStateFile($me, $file);
    my %branches = %{$state{BRANCHES}};
    $branches{$name} = \%options;
    $state{BRANCHES} = \%branches;
    writeBuildStateFile($me, $user, $file, %state);
    return 1;
  }
  print STDERR "$me: No build partition for branch '$name'.\n";
  print STDERR "$me: Did you use create-personal-branch?\n";
  return 0;
}


# Remove each branch in @branches from buildState file.
#
sub doDeleteCommand {
  my ($me, $user, @branches) = @_;
  my $result = 1;
  my @bs = map branchNameNoDepot($_), @branches;
  my $file = buildState;
  my ($lock, @content) = disableBuilds($me, $user, @ARGV, "\n");
  cleanup(sub { enableBuilds($me, $lock, @content); });
  my %state = readBuildStateFile($me, $file);
  my %branches = %{$state{BRANCHES}};
  for (@bs) {
    if (exists $branches{$_}) {
      delete $branches{$_};
    } else {
      showUnknownBranch($me, $_);
      $result = 0;
    }
  }
  $state{BRANCHES} = \%branches;
  writeBuildStateFile($me, $user, $file, %state);
  return $result;
}


# Disable builds by writing @reasons into the lock file.
#
sub doDisableBuildsCommand {
  my ($me, $user, @reasons) = @_;
  my ($lock, @content) =
    disableBuilds($me, $user, $me, @ARGV, "\n", @reasons, "\n");
  print @content;
  return 1;
}


# Enable builds by removing the lock file after showing its contents.
#
sub doEnableBuildsCommand {
  my ($me, $user) = @_;
  enableBuilds($me);
  return 1;
}


# For each unlocked server in %locks, send mail to the waiting user.
# Return the lock requests for which mail was sent.
#
sub handleLocksForRun {
  my ($me, %locks) = @_;
  my %result = ();
  for my $us (sort keys %locks) {
    if (my ($user, $server) = $us =~ m%^([^/\s]+)/([^/\s]+)$%o) {
      next if -e getLockFileForServer($server);
      my %options = %{$locks{$us}};
      $result{$us} = \%options;
      my $reason = $options{'reason'};
      $reason = '<reason>' unless ($reason);
      my $subject = "$server is now free to use.";
      my @message =
        ("The build server '$server' is now free to use.\n",
         "Run '$me lock $server $reason' to lock $server.\n");
      sendMail($me, $user, $subject, @message);
    }
  }
  return %result;
}


# Remove any %doneLocks from the locks records at $newLocksRef
# and return the remaining locks in the hash.
#
sub updateLocksForRun {
  my ($newLocksRef, %doneLocks) = @_;
  my %result = %{$newLocksRef};
  for my $us (keys %doneLocks) {
    if (exists $result{$us}) {
      my %doneOptions = %{$doneLocks{$us}};
      my %newOptions = %{$result{$us}};
      my $doneTime = $doneOptions{'time'};
      my $newTime = $newOptions{'time'};
      delete $result{$us} if ($doneTime == $newTime);
    }
  }
  return %result;
}


# Add Perforce CHANGE numbers for $branch to the %builds hash at
# $builds for builds named like this: 'fnord-2010-02-25-112206'.
# Return the most recent change submitted to $branch and the
# change number from the latest build.
#
# The //fnord/trunk/ branch is a special case ($noTrunk) just to
# make life difficult apparently.
#
sub addChangesToBuilds {
  my ($me, $branch, $builds) = @_;
  my ($submit, $latest) = (0, 0);
  my $depot = depotNameForBranch($branch);
  my @p4 = qw(/usr/local/perforce/libexec/p4 changes -s submitted -m 99);
  my @command = (@p4, "$depot/...");
  my ($status, $outs, $errs, @output) = runProgram($me, 0, @command);
  if ($status ne '0' || $errs > 0) {
    my @stderr = splice(@output, $outs, $errs);
    my $stderr = singleLineSlashify(@stderr);
    syslog('err', "'@command' failed with $status: $stderr");
    print "$me: '@command' failed with $status: @stderr\n";
  } else {
    my @stdout = splice(@output, 0, $outs);
    my $noTrunk = join('-', split(/\//, $branch));
    my %changeMap;
    for (@stdout) {
      my @match = m%^Change\s+(\d+)\s+on\s+.*by\s+(\S+)@(\S+)\s+%o;
      if (3 == @match) {
        my ($change, $user, $client) = @match;
        if ($user eq buildRobot) {
          $client =~ s%^fnord-$noTrunk-%fnord-% if ('trunk' ne $branch);
          $changeMap{$client} = $change;
        } else {
          $submit = $change unless $submit;
        }
      }
    }
    for (keys %{$builds}) {
      if (exists $changeMap{$_}) {
        my $change = $changeMap{$_};
        $builds->{$_}->{CHANGE} = $change;
        $latest = $change if ($change > $latest);
      }
    }
  }
  return ($submit, $latest);
}


# Return the result of following the symbolic link in $result.
#
sub snapSymbolicLink {
  my ($result) = @_;
  while (my $link = readlink($result)) {
    my $directory = dirname $result;
    $link =~ s%/$%%o;
    if ($link =~ m%^/%o || $directory eq '.') {
      $result = $link;
    } else {
      $result = "$directory/$link";
    }
  }
  return $result;
}


# Return a hash of info about a $build $directory for $branch.
# FIXME: Remove dangling links after reporting them.
#
sub scanBuildDirectory {
  my ($me, $branch, $build, $directory) = @_;
  my %result;
  if (-l $directory) {
    my $link = snapSymbolicLink($directory);
    if (-d $link) {
      $result{LINK} = $link;
    } else {
      syslog('debug', "Removing $directory as a dangling link");
      print STDERR "$me: Removing $directory as a dangling link.\n";
      my $ok = unlink $directory;
      if (!$ok) {
        syslog('err', "Cannot remove dangling link '$directory'");
        print STDERR "$me: Cannot remove '$directory'.\n";
      }
      return ();
    }
  }
  @result{qw(BRANCH BUILD DIRECTORY)} = ($branch, $build, $directory);
  my $time = $build; $time =~ s/^fnord-//o;
  if ($time ne $build) {
    $result{START} = parseTimeStamp($time);
    if (my $space = lockFile('<', "$directory/.space")) {
      my $line = <$space>;
      if ($line) {
        chomp $line;
        $result{SPACE} = $line;
      } else {
        print STDERR "$me: Bad .space file in: $directory\n";
      }
      unlockFile($space);
    }
    for (qw(BUILD-SUCCEEDED BUILD-SUCCEEDED-REDUNDANT FAILED-ACCEPTED)) {
      $result{OK} = $result{$_} = $_ if (-e "$directory/$_");
    }
    for (qw(FAILED PRESERVE)) {
      $result{$_} = $_ if (-e "$directory/$_");
    }
  }
  return %result;
}


# Dump the result of scanReleasesForBuilds() as a Perl literal.
#
sub dumpReleasesForDebugging {
  my %releases = @_;
  print STDERR "${aMark}{";
  my $aSep = "";
  for my $branch (sort keys %releases) {
    my %branchInfo = %{$releases{$branch}};
    print STDERR "$aSep'$branch' => ${bMark}{";
    $aSep = ",\n ";
    my $bSep = "\n    ";
    for (qw(LATEST SUBMIT)) {
      if (exists $branchInfo{$_}) {
        print STDERR "$bSep$_ => '$branchInfo{$_}'";
        $bSep = ",\n    ";
      }
    }
    if (my %options = %{$branchInfo{OPTIONS}}) {
      print STDERR "$bSep" . "OPTIONS => ${cMark}{";
      my $cSep = "\n        ";
      for (sort keys %options) {
        print STDERR "$cSep'$_' => '$options{$_}'";
        $cSep = ",\n        ";
      }
      print STDERR "}${cMark}";
      $bSep = ",\n    ";
    }
    if (my %builds = %{$branchInfo{BUILDS}}) {
      print STDERR "$bSep" . "BUILDS => ${cMark}{";
      my $cSep = "\n        ";
      for (sort keys %builds) {
        my %info = %{$builds{$_}};
        print STDERR "$cSep'$_' => ${dMark}{";
        $cSep = ",\n        ";
        my $dSep = "\n            ";
        for (sort keys %info) {
          print STDERR "$dSep$_ => '$info{$_}'";
          $dSep = ",\n            ";
        }
        print STDERR "}${dMark}";
      }
      print STDERR "}${cMark}";
    }
    print STDERR "}${bMark}";
  }
  print STDERR "}${aMark}\n";
}


# Return a hash describing the build content of releasesRoot.
# Update and run dumpReleasesForDebugging() to update this comment.
# Cache %branches options in result using $saveDays as a default.
#
# {'andrew/6' => {
#     LATEST => '183442',
#     SUBMIT => '183442',
#     BUILDS => {
#         'fnord-2009-06-09-112643' => {
#             BRANCH => 'andrew/6',
#             BUILD => 'fnord-2009-06-09-112643',
#             BUILD-SUCCEEDED => 'BUILD-SUCCEEDED',
#             CHANGE => '183442',
#             DIRECTORY => '/releases/andrew/6/fnord-2009-06-09-112643',
#             OK => 'BUILD-SUCCEEDED',
#             PRESERVE => 'PRESERVE',
#             START => '1244561203'},
#         'current' => {
#             BRANCH => 'andrew/6',
#             BUILD => 'current',
#             DIRECTORY => '/releases/andrew/6/current',
#             LINK => '/releases/andrew/6/fnord-2009-06-09-112643'}}}, ...
#  'andrew/trunk' => {
#     LATEST => '192694',
#     SUBMIT => '192694',
#     BUILDS => { ...
#         'fnord-2010-06-17-230206' => {
#             BRANCH => 'andrew/trunk',
#             BUILD => 'fnord-2010-06-17-230206',
#             CHANGE => '192685',
#             DIRECTORY => '/releases/andrew/trunk/fnord-2010-06-17-230206',
#             FAILED => 'FAILED',
#             START => '1276830126'}, ... } ... } ... }
#
sub scanReleasesForBuilds {
  my ($me, $saveDays, %branches) = @_;
  my %result;
  my $root = releasesRoot;
  for my $branch (keys %branches) {
    my %builds = ();
    if (opendir(my $dh, "$root/$branch")) {
      while (my $build = readdir $dh) {
        next if ($build =~ m/^\.$/o || $build =~ m/^\.\.$/o);
        my $directory = "$root/$branch/$build";
        next if (! -l $directory && ! -d $directory);
        my %info = scanBuildDirectory($me, $branch, $build, $directory);
        $builds{$build} = \%info if (%info);
      }
      closedir($dh);
    }
    my %options = %{$branches{$branch}};
    $options{'save-days'} = $saveDays unless ($options{'save-days'});
    my %info; @info{qw(BUILDS OPTIONS)} = (\%builds, \%options);
    if (not exists $options{'disabled'}) {
      my ($submit, $latest) = addChangesToBuilds($me, $branch, \%builds);
      @info{qw(SUBMIT LATEST)} = ($submit, $latest);
    }
    $result{$branch} = \%info;
  }
  dumpReleasesForDebugging(%result) if ($debug);
  return %result;
}


# Return a list of forced %branches sorted by force time.
#
sub getForcedBranches {
  my %branches = @_;
  my %forced;
  for my $branch (keys %branches) {
    my %options = %{$branches{$branch}};
    $forced{$branch} = $options{'time'} if exists $options{'time'};
  }
  my @result;
  if (%forced) {
    @result = sort { $forced{$a} <=> $forced{$b} } keys %forced;
  }
  return @result;
}


# Return the branches in %releases that have valid 'building' links
# hashed to their build directories.
#
sub getBuildingBranches {
  my %releases = @_;
  my %result;
  for my $branch (sort keys %releases) {
    my $buildsRef = $releases{$branch}->{BUILDS};
    if (exists $buildsRef->{'building'}) {
      if (exists $buildsRef->{'building'}->{LINK}) {
        my $buildDirectory = $buildsRef->{'building'}->{LINK};
        $result{$branch} = $buildDirectory if (-d $buildDirectory);
      }
    }
  }
  return %result;
}


# Return the enabled branches in %releases that have changed
# prioritized by change number.
#
sub getChangedBranches {
  my %releases = @_;
  my %branches;
  for (keys %releases) {
    my %info = %{$releases{$_}};
    if (exists $info{LATEST} && exists $info{SUBMIT}) {
      my $latest = $info{LATEST};
      my $submit = $info{SUBMIT};
      if ($submit && $submit > $latest) {
        $branches{$_} = $info{SUBMIT};
      }
    }
  }
  my @result = sort { $branches{$a} <=> $branches{$b} } keys %branches;
  return @result;
}


# Return a list of the disabled branches in %branches.
#
sub getDisabledBranches {
  my %branches = @_;
  my @result = ();
  for (keys %branches) {
    my %options = %{$branches{$_}};
    if (exists $options{'disabled'}) {
      push(@result, $_) if ('true' eq $options{'disabled'});
    }
  }
  return @result;
}


# Return candidate branches to build in priority order.  The first
# candidates are forced branches that are not already building.  Then
# follow any changed branches that are not disabled and are not
# already candidates.  Changed branches are prioritized by the age of
# their most recent submitted change.  Older changes have priority.
#
sub getBuildCandidates {
  my ($me, $branchesRef, $releasesRef) = @_;
  my %branches = %$branchesRef;
  my %releases = %$releasesRef;
  my @disabled = getDisabledBranches(%branches);
  my @forced = getForcedBranches(%branches);
  my %building = getBuildingBranches(%releases);
  my @changed = getChangedBranches(%releases);
  my %seen = map { $_ => 1 } keys %building;
  my @result = grep { ! $seen{$_} } @forced;
  @seen{keys %seen, @forced} = (values %seen, (1) x @forced);
  @seen{keys %seen, @disabled} = (values %seen, (1) x @disabled);
  push @result, grep { ! $seen{$_} } @changed;
  if (@result) {
    syslog('info', "Branches ready to build: @result");
  } else {
    syslog('info', "Found no branches ready to build.");
  }
  return @result;
}


# Dump the result of getBranchConfigurations() as a Perl literal.
#
sub dumpBranchConfigurationForDebugging {
  my ($branch, %configuration) = @_;
  print STDERR "BRANCH: $branch\n${aMark}{";
  my $aSep = "";
  for my $platform (sort keys %configuration) {
    my %conf = %{$configuration{$platform}};
    print STDERR "$aSep'$platform' => ${bMark}{";
    $aSep = ",\n ";
    my $bSep = "\n    ";
    for (sort keys %conf) {
      print STDERR "$bSep$_ => '$conf{$_}'";
      $bSep = ",\n    ";
    }
    print STDERR "}${bMark}";
  }
  print STDERR "}${aMark}\n";
}


# Return the build configuration for $branch hashed by server
# platform.
#
sub getBranchConfiguration {
  my ($me, $branch) = @_;
  my %result;
  my $file = buildConfGlobalForBranch($branch);
  my @p4 = (qw(/usr/local/perforce/libexec/p4 print -q), $file);
  my ($status, $outs, $errs, @output) = runProgram($me, 0, @p4, $file);
  if ($status ne '0' || $errs > 0) {
    my @stderr = splice(@output, $outs, $errs);
    my $stderr = singleLineSlashify(@stderr);
    syslog('err', "'@p4' failed with $status: $stderr");
    print STDERR "$me: '@p4' failed with $status: @stderr\n";
  } else {
    my @stdout = splice(@output, 0, $outs);
    for (@stdout) {
      next if m/^\s*            #/o;
        next if m/^\s*$/o;
      if (my @match = m/^\s*(\S+)\s+(\S+)\s+(\S+)\s+(.*)\s*$/o) {
        if (4 == @match) {
          my %configuration;
          @configuration{qw(BRANCH BUILD PLATFORM OPTIONS)} = @match;
          if ($branch eq $configuration{BRANCH}) {
            $result{$configuration{PLATFORM}} = \%configuration;
          }
        }
      }
    }
  }
  if (!%result) {
    for (qw(linux win32)) {
      my %default;
      @default{qw(BRANCH BUILD PLATFORM)} = ($branch, $_, $_);
      $result{$_} = \%default;
    }
  }
  return %result;
}


# Return the 'Mounted' partition and 'Available' value for $branch if
# one is specified, or return hashes describing all local mounts
# indexed by 'Mounted'.
#
sub getPartitionInfo {
  my ($branch) = @_;
  my $releases = releasesRoot;
  my @df = qw(/bin/df -k -l -P);
  push(@df, "$releases/$branch") if ($branch);
  my @report = getReportHashes(@df); shift @report;
  if (1 == @report) {
    my %df = %{$report[0]};
    return ($df{'Mounted'}, $df{'Available'});
  }
  return map { $_->{'Mounted'} => $_ } @report;
}


# Dump the result of getReapableBuilds() as a Perl literal.
#
sub dumpReapableBuilds {
  my %reapables = @_;
  print STDERR "${aMark}{";
  my $aSep = "";
  for my $partition (sort keys %reapables) {
    print STDERR "$aSep'$partition' => ${bMark}[";
    $aSep = ",\n ";
    my $bSep = "\n    ";
    for my $build (@{$reapables{$partition}}) {
      print STDERR "$bSep'$build'";
      $bSep = ",\n    ";
    }
    print STDERR "]${bMark}";
  }
  print STDERR "}${aMark}\n";
}


# Return a hash referencing arrays of unPRESERVEd directories from
# %builds older than $saveDays: one of FAILED builds and another of
# builds that SUCCEEDED ordered from earliest to most recent.  Save
# the most recent of each though.  Also return BUILDING directories
# to prevent them from getting reaped while in use.
#
sub getReapableBuildsForBranch {
  my ($saveDays, %builds) = @_;
  my (@building, @failed, @succeeded);
  for my $build (sort keys %builds) {
    my %info = %{$builds{$build}};
    push(@building, $info{LINK}) if ('building' eq $build);
    next if (exists $info{PRESERVE} || exists $info{LINK});
    if (exists $info{OK}) {
      next if ($info{START} + ($saveDays * 60 * 60 * 24) > time);
      push @succeeded, $info{DIRECTORY};
    } else {
      push @failed, $info{DIRECTORY};
    }
  }
  my %result; pop @failed; pop @succeeded;
  if (@failed || @succeeded) {
    $result{BUILDING}  = \@building;
    $result{FAILED}    = \@failed;
    $result{SUCCEEDED} = \@succeeded;
  }
  return %result;
}


# Return a hash mapping partitions to lists of build directories there
# that can be removed to free up space on the partition according to
# the following policy.
#
# A PRESERVEd or 'building' build can never be removed.  Failed builds
# should be removed oldest first.  After any failed builds, successful
# (OK) builds can be removed -- again, oldest first.  Always retain
# the most recent successful and failed builds, and any build younger
# than the save-days option for its branch.
#
sub getReapableBuilds {
  my (%releases) = @_;
  my %partitions;
  for my $branch (keys %releases) {
    my $saveDays = $releases{$branch}->{OPTIONS}->{'save-days'};
    my %builds = %{$releases{$branch}->{BUILDS}};
    my %reapable = getReapableBuildsForBranch($saveDays, %builds);
    if (%reapable) {
      if (my ($part, $availableIgnored) = getPartitionInfo($branch)) {
        my %info = $partitions{$part}? %{$partitions{$part}}: ();
        for (keys %reapable) {
          push @{$info{$_}}, @{$reapable{$_}};
        }
        $partitions{$part} = \%info;
      }
    }
  }
  my %result;
  for (keys %partitions) {
    my %info = %{$partitions{$_}};
    my @builds = (@{$info{FAILED}}, @{$info{SUCCEEDED}});
    my %building = map { $_ => 1 } @{$info{BUILDING}};
    my @reapable = grep { !$building{$_} } @builds;
    $result{$_} = \@reapable;
  }
  dumpReapableBuilds(%result) if ($debug);
  return %result;
}


# Return the most recent OK build for $branch in %releases.  The most
# recent build is the one linked as 'current' or the last one named
# with a time stamp.
#
sub getCurrentBuildForBranch {
  my ($branch, %releases) = @_;
  my %result;
  if (exists $releases{$branch} && $releases{$branch}->{BUILDS}) {
    my %builds = %{$releases{$branch}->{BUILDS}};
    if (exists $builds{'current'}) {
      my %current = %{$builds{'current'}};
      if (exists $current{LINK}) {
        my $link = $current{LINK};
        my $name = basename $link;
        if (exists $builds{$name}) {
          my %build = %{$builds{$name}};
          %result = %build if ($build{OK});
        }
      }
    }
    if (!%result) {
      my $timeStampRe = parseTimeStamp;
      for (sort keys %builds) {
        next unless m/^fnord-$timeStampRe$/o;
        my %build = %{$builds{$_}};
        %result = %build if ($build{OK});
      }
    }
  }
  return %result;
}


# Return the size reported by 'du -s $directory'.
#
sub getDirectorySpace {
  my ($me, $directory) = @_;
  my $result;
  my @du = qw(/usr/bin/du -s);
  my @duReport = getReportHashes(@du, $directory);
  if (@duReport && 1 == @duReport) {
    my @field = @{$duReport[0]};
    if (2 == @field && $field[1] eq $directory) {
      $result = $field[0];
    }
  }
  if (!defined $result) {
    syslog('err', "Cannot get size of directory '$directory'");
    print STDERR "$me: Cannot get size of directory '$directory'.";
  }
  return $result;
}


# Return the size of the most recent OK build for $branch in
# %releases.  Return some default if there is no OK build.  Use the
# build's SPACE information if it is available.  Otherwise read the
# size from the filesystem.
#
sub getCurrentSpacePerBuild {
  my ($me, $branch, %releases) = @_;
  my $result = 17000000;        # from /releases/official/7.0.4/
  my %build = getCurrentBuildForBranch($branch, %releases);
  if (%build) {
    if (exists $build{SPACE}) {
      $result = $build{SPACE};
    } else {
      my $directory = $build{DIRECTORY};
      $result = getDirectorySpace($me, $directory);
      syslog('info', "Caching $result in '$directory/.space'");
      if (my $file = lockFile('>', "$directory/.space")) {
        print $file "$result\n";
        close $file;
      }
    }
  }
  return $result;
}


# Return the reasons for locking a server for an automated build of
# $branch.
#
sub makeAutomaticBuildServerLockReasons {
  my ($branch, $user) = @_;
  my $comment = 'This is a build by the AUTOMATIC build scripts';
  return $comment unless ($branch);
  my $releases = releasesRoot;
  my $directory = "$releases/$branch";
  my $buildHost = buildMaster;
  my @lines = ($comment,
               '',
               "branch: $branch",
               "directory: $directory",
               '',
               "build host: $buildHost");
  my $result = join "\n", @lines;
  return ($result);
}


# Return a hash of platforms to build configurations including the
# SERVERS hostnames locked to build $branch if all the necessary
# servers can be locked.
#
# Return false unless all the necessary servers can be locked.
#
sub lockServersForBuild {
  my ($me, $user, $branch, %state) = @_;
  my %servers = %{$state{SERVERS}};
  my %branches = %{$state{BRANCHES}};
  my %options = %{$branches{$branch}};
  my %result = getBranchConfiguration($me, $branch);
  my %serverLocks = collectServerLockStatus(%servers);
  my @locked = ();
 PLATFORM: for my $platform (keys %result) {
    my @servers = @{$serverLocks{$platform}};
    my $forceOption = "$platform-server";
    if (exists $options{$forceOption}) {
      my $forced = $options{$forceOption};
      syslog('debug', "$user forced $branch on $forced for $platform");
      @servers = grep { $_->{SERVER} eq $forced } @servers;
      @servers = {SERVER => $forced} unless @servers;
    }
    for my $server (@servers) {
      next if (exists $server->{LOCK});
      my @reasons = makeAutomaticBuildServerLockReasons($branch);
      my $hostname = $server->{SERVER};
      if (doLockCommand('', $user, $hostname, @reasons)) {
        push @locked, $hostname;
        $result{$platform}->{SERVER} = $hostname;
        next PLATFORM;
      }
    }
  }
  dumpBranchConfigurationForDebugging($branch, %result) if ($debug);
  return %result if (keys %result == @locked);
  if (@locked) {
    syslog('debug', "Servers unlocked for $branch: @locked");
    doUnlockCommand($me, $user, @locked);
  }
  return ();
}


# Copy all installers under $build to $archive.
# Return 1 on success or 0 on failure.
#
sub copyInstallersFromBuildTree {
  my ($me, $build, $archive) = @_;
  my $ok = opendir(my $dh, $build);
  if (!$ok) {
    syslog('err', "Cannot open '$build': %m");
    print STDERR "$me: Cannot open '$build'\n";
    return 0;
  }
  while (my $platform = readdir $dh) {
    next if ($platform =~ m/^\.$/o || $platform =~ m/^\.\.$/o);
    next if (-l "$build/$platform");
    next if (! -d "$build/$platform");
    my $unsigned = "$build/$platform/installers/unsigned";
    my @sources = glob("$unsigned/fnord-*");
    if (@sources) {
      my $directory = "$archive/$platform";
      eval { mkpath $directory }; my $message = $@;
      if (! -d $directory) {
        syslog('err', "Cannot make '$directory': $message");
        print STDERR "$me: Cannot make '$directory': $message\n";
        return 0;
      }
      for my $src (@sources) {
        my $dst = $directory . "/" . basename $src;
        if (!copy($src, $dst)) {
          syslog('err', "Cannot copy '$src' to '$dst': %m");
          print STDERR "$me: Cannot copy '$src' to '$dst': $!.\n";
          return 0;
        }
      }
      if (@sources) {
        my @installers = map basename($_), @sources;
        syslog('info', "$build archived in $archive: @installers");
      }
    } else {
      syslog('info', "No installers to archive for $build");
    }
  }
  return 1;
}


# Copy any installers from $directory if $branch is not for a user.
# Return true on success or false on failure.
#
sub archiveInstallers {
  my ($me, $directory) = @_;
  my $root = releasesRoot;
  return 1 if ($directory =~ m%^$root/user/%o);
  my $build = "$directory/build";
  if (! -d $build) {
    syslog('err', "No $build directory to archive");
    return 1;
  }
  my $archiveRoot = installersArchive;
  my $rootless = $directory;
  $rootless =~ s%^$root/%%o;
  my $archive = "$archiveRoot/$rootless";
  if (-d $archive) {
    syslog('err', "Archive '$archive' exists");
    print STDERR "$me: Archive '$archive' exists.\n";
    return 0;
  }
  return copyInstallersFromBuildTree($me, $build, $archive);
}


# Unlock the Perforce $client spec so it can be deleted.
# Old build scripts lock auto clients to make life difficult.
#
# FIXME: Remove when all the old auto clients are gone. =tbl
#
sub unlockOldPerforceClientSpecHack {
  my ($me, $client) = @_;
  my @p4 = (qw(/usr/local/perforce/libexec/p4 client -o), $client);
  my ($status, $outs, $errs, @output) = runProgram($me, 0, @p4);
  my $result = $status == 0;
  if ($result) {
    @p4 = qw(/usr/local/perforce/libexec/p4 client -i);
    $result = open my $spec, '|-', @p4;
    if ($result) {
      for (@output) {
        s/^(Options:\s+.*\s+)locked(\s+.*)$/${1}unlocked${2}/o;
        print STDERR "$me p4 client -i: $_" if ($debug);
        print $spec $_;
      }
      close $spec;
    }
  }
  if (!$result) {
    my $output = singleLineSlashify(@output);
    syslog('err', "Problem with '@p4': $output");
    print STDERR "$me: Problem with '@p4': @output\n";
  }
  return $result;
}


# Find and delete the Perforce client spec for $directory.
#
sub deletePerforceClientSpecForBuild {
  my ($me, $directory) = @_;
  my $root = releasesRoot;
  my $build = basename $directory; $build =~ s%^fnord-%%o;
  my $client = dirname $directory;
  $client =~ s%^$root/%%o; $client =~ s%/%-%go;
  $client = "fnord-$client-$build";
  unlockOldPerforceClientSpecHack($me, $client);
  my @p4 = (qw(/usr/local/perforce/libexec/p4 client -d), $client);
  my ($status, $outs, $errs, @output) = runProgram($me, 0, @p4);
  my $result = $status == 0;
  if (!$result) {
    my $output = singleLineSlashify(@output);
    syslog('err', "Problem with '@p4': $output");
    print STDERR "$me: Problem with '@p4': @output\n";
  }
  return $result;
}


# Reap the build in $directory for $branch after archiving its
# installers.  Return size freed.
#
sub reapBuildDirectory {
  my ($me, $directory) = @_;
  syslog('info', "Reaping $directory");
  my $size = getDirectorySpace($me, $directory);
  my $ok = $size;
  if ($ok) {
    my $ok = archiveInstallers($me, $directory);
    if ($ok) {
      syslog('info', "Remove build '$directory' to free $size");
      $ok = rmtree($directory);
      if ($ok) {
        deletePerforceClientSpecForBuild($me, $directory);
      } else {
        syslog('err', "Cannot remove $directory");
      }
    } else {
      syslog('err', "Cannot archive installers from $directory");
    }
  }
  return $ok? $size: 0;
}


# Return an estimate of how many builds the partition for $branch will
# accommodate.  If the estimate is less than 1, attempt to free up
# some space on the partition by deleting up to $limit builds.  Return
# when $limit is reached, there is enough space, or there are no more
# builds to delete.
#
# The larger the $limit the more damage each run can do (erroneously
# deleting build trees, for example) if there is a bug or some other
# build launcher problem.  A larger $limit also means each build
# launcher run may take longer to complete because potentially more
# build trees will be cleaned up, installers archived, and so on.  If
# $limit is small, the build launcher might need more runs to purge
# enough builds that there is enough space to start a new one -- with
# the result that it takes longer for builds to get started.
#
my %reapableCacheForEnsureSpaceForBuildHack;
sub ensureSpaceForBuild {
  my ($me, $branch, %releases) = @_;
  my $result = 0;
  my $limit = 4;
  my %reapable = %reapableCacheForEnsureSpaceForBuildHack;
  while ($result < 1) {
    if (my ($partition, $available) = getPartitionInfo($branch)) {
      my $space = getCurrentSpacePerBuild($me, $branch, %releases);
      $result = int($available / $space);
      if ($result < 1) {
        if (!%reapable) {
          %reapable = getReapableBuilds(%releases) or last;
          %reapableCacheForEnsureSpaceForBuildHack = %reapable;
        }
        my $directory = pop @{$reapable{$partition}};
        if ($directory && -d $directory) {
          last unless $limit > 0;
          --$limit;
          reapBuildDirectory($me, $directory);
        } else {
          syslog('info', "No more reapable builds on: $partition");
          last;
        }
      }
    } else {
      syslog('err', "Cannot get filesystem partition for '$branch'");
      print STDERR "$me: Cannot get filesystem partition for '$branch'";
      last;
    }
  }
  syslog('info', "$branch space for $result builds with limit $limit");
  return $result;
}


# Start a build of $branch (with options at $options) for $user with
# the configuration in %config.  Return $branch on success or '' if
# the build was not started.  Run subprogram in a new process group.
#
sub startBuild {
  my ($me, $user, $branch, $options, %config) = @_;
  my @result = ();
  my $root = releasesRoot;
  my $build = "$root/$branch";
  my $maker = makeRelease;
  my @cmd = ($maker, '--branch', $branch, '--root', $build, '--user', $user);
  for (keys %config) {
    push @cmd, "--$_-server", $config{$_}->{SERVER};
  }
  for (qw(failure-mail success-mail)) {
    if (exists $options->{$_}) {
      push(@cmd, "--$_",  $options->{$_});
    } elsif (exists $options->{'mail'}) {
      push(@cmd, "--$_",  $options->{'mail'})
    }
  }
  syslog('info', "Starting build @cmd");
  print STDERR "$me: Starting build @cmd\n" if ($debug);
  my ($status, $outs, $errs, @output) = runProgram('', 0, @cmd);
  return $branch if ($status == 0);
  my $output = singleLineSlashify(@output);
  syslog('err', "Build '@cmd' failed with $status: $output");
  print STDERR "$me: '@cmd' failed with $status: @output\n";
  return '';
}


# Start builds on any %branches parsed from %state that are ready, and
# return the names of branches for which builds were launched.
#
sub handleBranchesForRun {
  my ($me, $defaultUser, %state) = @_;
  my @result = ();
  my $days = 7;
  if (exists $state{OPTIONS}->{'save-days'}) {
    $days = $state{OPTIONS}->{'save-days'}
  }
  my %releases = scanReleasesForBuilds($me, $days, %{$state{BRANCHES}});
  my @candidates = getBuildCandidates($me, $state{BRANCHES}, \%releases);
  for my $candidate (@candidates) {
    my $options = $state{BRANCHES}->{$candidate};
    my $user = $defaultUser;
    $user = $options->{'user'} if (exists $options->{'user'});
    syslog('info', "Considering build candidate $candidate");
    my %config = lockServersForBuild($me, $user, $candidate, %state);
    if (%config) {
      my @servers = map $_->{SERVER}, values %config;
      syslog('info', "Build $candidate locked: @servers");
      my $count = ensureSpaceForBuild($me, $candidate, %releases);
      if ($count > 0) {
        my $ok = startBuild($me, $user, $candidate, $options, %config);
        push(@result, $candidate) if ($ok);
      } else {
        syslog('debug', "No space to build $candidate on: @servers");
        doUnlockCommand($me, $user, @servers);
      }
    } else {
      syslog('debug', "Cannot get builders for branch '$candidate'");
    }
  }
  return @result;
}


# Do whatever the state file requires.  Process pending lock requests.
# Build any forced branches or enabled branches that have changed, and
# remove force options from any branches for which a build is started.
# Write out a new build state file.
#
sub doRunCommand {
  my ($me, $user) = @_;
  my $file = buildState;
  my ($lock, @content) = disableBuilds($me, $user, @ARGV, "\n");
  cleanup(sub { enableBuilds($me, $lock, @content); });
  my %state = readBuildStateFile($me, $file);
  my %doneLocks = handleLocksForRun($me, %{$state{LOCKS}});
  my %locks = updateLocksForRun($state{LOCKS}, %doneLocks);
  $state{LOCKS} = \%locks;
  my @branchesBuilt = handleBranchesForRun($me, $user, %state);
  my %branches = %{$state{BRANCHES}};
  for (@branchesBuilt) {
    my %options = %{$branches{$_}};
    delete @options{doUnforceCommand()};
    $branches{$_} = \%options;
  }
  $state{BRANCHES} = \%branches;
  writeBuildStateFile($me, $user, $file, %state);
  return 1;
}


# Write 'servers $platform @servers' into the state file.
#
sub doServersCommand {
  my ($me, $user, $platform, @servers) = @_;
  my @builders = map serverNameNoDomain($_), @servers;
  my $file = buildState;
  my ($lock, @content) = disableBuilds($me, $user, @ARGV, "\n");
  cleanup(sub { enableBuilds($me, $lock, @content); });
  my %state = readBuildStateFile($me, $file);
  my %servers = %{$state{SERVERS}};
  if (@builders) {
    $servers{$platform} = \@builders;
  } else {
    delete $servers{$platform};
  }
  $state{SERVERS} = \%servers;
  writeBuildStateFile($me, $user, $file, %state);
  return 1;
}


# List /releases directories with building links like the old
# build-launcher.
#
sub doListBuildsCommand {
  my ($me, $user) = @_;
  my %state = readBuildStateFile($me, buildState);
  my %releases = scanReleasesForBuilds($me, 7, %{$state{BRANCHES}});
  if (%releases) {
    my %building = getBuildingBranches(%releases);
    if (%building) {
      my @branches = sort keys %building;
      my $max = reduce { $a < length $b ? length $b : $a } 0, @branches;
      my $width = length 'fnord-' . makeTimeStamp;
      my $fmt = "%-${max}s %-${width}s %s\n";
      my @headers = qw(Branch Build Directory);
      printf $fmt, @headers;
      printf $fmt, map { '-' x length $_ } @headers;
      for (@branches) {
        my $directory = $building{$_};
        printf $fmt, $_, basename($directory), dirname($directory);
      }
      return 1;
    }
  }
  print "$me: No running builds\n";
  return 1;
}


# Summarize branch state like the old build-launcher.
#
sub doListBranchesCommand {
  my ($me, $user) = @_;
  my %state = readBuildStateFile($me, buildState);
  my %releases = scanReleasesForBuilds($me, 7, %{$state{BRANCHES}});
  my @ready = getBuildCandidates($me, $state{BRANCHES}, \%releases);
  my %ready; $ready{$ready[$_]} = $_ for (0..$#ready);
  my @branches = sort keys %releases;
  my $max = reduce { $a < length $b ? length $b : $a } 0, @branches;
  my $width = length makeTimeStamp; my $none = ' ' x $width;
  my $format = "%-${max}s %2s %-${width}s %-${width}s %s\n";
  my @h = ('Branch', '##', 'Running (fnord-*)', 'Current (fnord-*)', 'Options');
  printf $format, @h;
  printf $format, map { '-' x length $_ } @h;
  for my $branch (@branches) {
    my ($order, $building, $current, $options) = ('--', $none, $none, '');
    if (exists $ready{$branch}) {
      $order = $ready{$branch};
      $order = " $order" if length($order) < 2;
    }
    if (my %builds = %{$releases{$branch}{BUILDS}}) {
      if ($builds{'building'} && $builds{'building'}{LINK}) {
        $building = basename $builds{'building'}{LINK};
        $building =~ s/^fnord-//o;
      }
      if ($builds{'current'} && $builds{'current'}{LINK}) {
        $current = basename $builds{'current'}{LINK};
        $current =~ s/^fnord-//o;
      }
    }
    if (my %options = %{$state{BRANCHES}->{$branch}}) {
      $options = unparseOptions(%options);
      $options =~ s/\|/ /go;
    }
    printf $format, $branch, $order, $building, $current, $options;
  }
  return 1;
}


# Show a list of reapable builds like the old build-launcher.
#
sub doListReapableBuildsCommand {
  my ($me, $user) = @_;
  my $file = buildState;
  my %state = readBuildStateFile($me, $file);
  my %options = %{$state{OPTIONS}};
  my %branches = %{$state{BRANCHES}};
  my $saveDays = 7;
  $saveDays = $options{'save-days'} if (exists $options{'save-days'});
  my %releases = scanReleasesForBuilds($me, $saveDays, %branches);
  my %reapable = getReapableBuilds(%releases);
  my $root = releasesRoot;
  for my $partition (sort keys %reapable) {
    my @builds = @{$reapable{$partition}};
    my $count = @builds;
    print "\nReapable builds on $partition ($count):\n\n";
    for (@builds) {
      s%^$root/%%o;
      print "  $_\n";
    }
  }
  return 1;
}

# Handle the --user and --usagename options provided by the setuid
# wrapper program.
#
# Necessary only to support old setuid wrapper command line syntax.
#
sub handleOldUserAndUsagenameOptions {
  my ($me, $user, @args) = @_;
  my ($meResult, $userResult, @argsResult) = ($me, $user, @args);
  my ($userOpt, $userVal, $usagenameOpt, $usagenameVal, @rest) = @args;
  if ($userOpt && $userOpt eq '--user' && $usagenameOpt eq '--usagename') {
    $meResult = $usagenameVal;
    $userResult = $userVal;
    @argsResult = @rest;
  }
  return ($meResult, $userResult, @argsResult);
}


# Return 1 if the command $name is running with the correct
# credentials on the correct host.  Otherwise, return 0.
#
# FIXME: The old build-launcher enforced this, but it would be better
# to improve the script so it can run anywhere.  =tbl
#
sub commandOkHere {
  my ($me, $user, $name) = @_;
  my $robot = buildRobot;
  my $robotOk = grep /^$name$/, qw(list-reapable-builds run status unlock);
  if ($user eq $robot && !$robotOk) {
    print STDERR "$me: Run '$name' as yourself instead of '$robot'.\n";
    return 0;
  }
  my $host = hostname;
  my $master = buildMaster;
  my $hostOk = grep /^$name$/, qw(status);
  if ($host ne $master && !$hostOk) {
    $host = serverNameNoDomain($host);
    $master = serverNameNoDomain($master);
    print STDERR "$me: Run '$name' on '$master' instead of '$host'.\n";
    return 0;
  }
  return 1;
}


# Parse @argv for valid commands and run them or complain.
# A command is guaranteed at least one argument if it expects some.
#
sub main {
  my @argv = @_;
  my $me = basename $0;
  openlog($me, 'ndelay,nofatal,pid', 'local2');
  my $user = getpwuid($<);
  my $bannerForBeginEnd = time . " $me $user $0 @argv";
  syslog('info', "BEGIN $bannerForBeginEnd");
  cleanup(sub { syslog('info', "END $bannerForBeginEnd"); });
  ($me, $user, @argv) = handleOldUserAndUsagenameOptions($me, $user, @argv);
  if (@argv > 0) {
    my @commandInfo = getCommandInfo($me);
    my %commandMap = map { $_->{COMMAND} => $_ } @commandInfo;
    my $name = getNextNameValue(\@argv);
    if (exists $commandMap{$name}) {
      return 0 if (!commandOkHere($me, $user, $name));
      my $command = $commandMap{$name};
      if (@argv == 0 xor $command->{ARGUMENTS}) {
        no strict 'refs';
        my $result = &{$command->{SUBNAME}}($me, $user, @argv);
        return $result;
      }
    }
  }
  showUsage($me);
  return 0;
}

# This bypasses the Perforce proxy when it has problems to connect
# directly to the depot server.
#
# $ENV{P4PORT} = 'perforce.fnord.com:6666'; # HACK!  =tbl

exit 0 if main(@ARGV);
exit 1;