pjs/webtools/tinderbox3/client/tinderclient.pl

#!/usr/bin/perl -w

use strict;

use Getopt::Long;

# XXX do we really need this?
$| = 1;

# Save original arguments so we can send them to the new script if we upgrade
# ourselves
my @original_args = @ARGV;

#
# Catch these signals
#
$SIG{INT} = sub { print "SIGINT\n"; die; };
$SIG{TERM} = sub { print "SIGTERM\n"; die; };

#
# PROGRAM START
#
# Get arguments
#
our %args;
$args{trust} = 1;
$args{throttle} = 60;
$args{statusinterval} = 15;
GetOptions(\%args, "throttle:i", "url:s",
                   "trust!", "usepatches!", "usecommands!", "usemozconfig!",
                   "upgrade!", "upgrade_url:s",
                   "branch:s", "cvs_co_date:s", "cvsroot:s", "tests:s",
                   "clobber!", "lowbandwidth!", "statusinterval:s",
                   "upload_ssh_loc:s", "upload_ssh_dir:s", "upload_dir:s",
                   "uploaded_url:s", "distribute:s",
                   "help|h|?!");
if (!$args{url} || @ARGV != 2 || $args{help}) {
  print <<EOM;

Usage: tinderclient.pl [OPTIONS] [--help] Tree MachineName ...

Runs the build continuously, sending status to the url
Tree: the name of the tree this tinderbox is attached to
MachineName: the name of this machine (how it is identified and will show up on
             tinderbox)

--url: the url of the Tinderbox we will send status to
--throttle: minimum length of time between builds (if it is failing miserably,
            we don't want to continuously send crap to the server or even bother
            building).  Default is 60s.
--notrust: do not trust anything from the server, period--commands, cvs_co_date,
           mozconfig, patches or anything else
--nousecommands: don't obey commands from the server, such as kick or clobber
--noupgrade: do not upgrade tinderclient.pl automatically from server
--upgrade_url: url to upgrade from
--dir: the directory to work in
--lowbandwidth: transfer less verbose info to the server
--help: show this message

[Mozilla-specific options]
--nousemozconfig: do not get .mozconfig from the server
--nousepatches: do not bring down new patches from the tinderbox and apply them

The following options will be brought down from the server if not specified
here, unless --notrust is specified.  If --notrust is specified, defaults given
will be used instead.
--tests: the list of tests to run.  Defaults to "Tp,Ts,Txul"
--cvsroot: the cvsroot to grab Mozilla and friends from.  Defaults to
           ":pserver:anonymous\@cvs-mirror.mozilla.org:/cvsroot"
--branch the branch to check out
--cvs_co_date date to check out at, or blank (current) or "off".  If you do not
             set this, the server will control it.  Defaults to blank (current).
--clobber, --noclobber: clobber or depend build.  Defaults to --noclobber.
--upload_ssh_loc, --upload_ssh_dir: ssh server to upload finished builds to
                                    (jkeiser\@johnserver, public_html/builds)
--upload_dir: directory to copy finished builds to (another way to upload,
              through network drives or if you have a server locally)
--uploaded_url: url where the build can be found once uploaded (\%s will be
                replaced with the build name)
--distribute: the list of things to distribute.  Defaults to "build_zip".
              "raw_zip" is another useful one, that just zips up everything in
              the dist/bin directory (actually makes a .tgz).
--raw_zip_name: the project name of the raw build (defaults to "mozilla")

EOM
  exit(1);
}

$args{usecommands} = $args{trust} if !defined($args{usecommands});
$args{usemozconfig} = $args{trust} if !defined($args{usemozconfig});
$args{usepatches} = $args{trust} if !defined($args{usepatches});
$args{upgrade} = $args{trust} if !defined($args{upgrade});
if (!$args{trust}) {
  $args{tests} = "Tp,Ts,Txul" if !defined($args{tests});
  $args{cvsroot} = ':pserver:anonymous@cvs-mirror.mozilla.org:/cvsroot' if !defined($args{cvsroot});
  $args{cvs_co_date} = "" if !defined($args{cvs_co_date});
  $args{branch} = "" if !defined($args{branch});
  $args{clobber} = 0 if !defined($args{clobber});
  $args{distribute} = "build_zip" if !defined($args{distribute});
  $args{raw_zip_name} = "mozilla" if !defined($args{distribute});
}

if ($args{dir}) {
  chdir($args{dir});
}

my $client = new TinderClient(\%args, $ARGV[0], $ARGV[1], \@original_args);
while (1) {
  $client->build_iteration();
}



package TinderClient;

use strict;

use LWP::UserAgent;
use CGI;
use HTTP::Date qw(time2str);
use Cwd qw(abs_path);

our $VERSION;
our $PROTOCOL_VERSION;

sub new {
	my $class = shift;
	$class = ref($class) || $class;
	my $this = {};
	bless $this, $class;

  $VERSION = "0.1";
  $PROTOCOL_VERSION = "0.1";

  my ($args, $tree, $machine_name, $original_args) = @_;
  # The arguments hash
  $this->{ARGS} = $args;
  $this->{CONFIG} = { %{$args} };
  # The tree
  $this->{TREE} = $tree;
  # The machine
  $this->{MACHINE_NAME} = $machine_name;
  # The user agent object
  $this->{UA} = new LWP::UserAgent;
  $this->{UA}->agent("TinderboxClient/" . $TinderClient::PROTOCOL_VERSION);
  # the tinderclient.log out
  $this->{LOG_OUT} = undef;
  # the tinderclient.log in
  $this->{LOG_IN} = undef;
  # the un-dealt-with commands
  $this->{COMMANDS} = {};
  # system information
  $this->{SYSINFO} = TinderClient::SysInfo::get_sysinfo();
  # the original program arguments in case we have to upgrade
  $this->{ORIGINAL_ARGS} = $original_args;
  # persistent vars for the build modules
  $this->{PERSISTENT_VARS} = {};

  return $this;
}

sub get_patch {
  my $this = shift;
  my ($patch_id) = @_;
  if (! -f "tbox_patches/$patch_id.patch") {
    my $req = new HTTP::Request(GET => $this->{CONFIG}{url} . "/get_patch.pl?patch_id=$patch_id");
    my $res = $this->{UA}->request($req);
    if ($res->is_success) {
      if (! -d "fixes") {
        mkdir("fixes");
      }
      if (!open OUTFILE, ">tbox_patches/$patch_id.patch") {
        $this->print_log("ERROR: unable to create patchfile: $!\n");
        return "";
      }
      print OUTFILE ${$res->content_ref()};
      close OUTFILE;
    } else {
      $this->print_log("ERROR reaching $this->{CONFIG}{url}/get_patch.pl?patch_id=$patch_id ...\n");
      return "";
    }

  }
  return "tbox_patches/$patch_id.patch";
}

sub form_data_request {
  my $this = shift;
  my ($boundary, $name, $value) = @_;
  my $request_content;
  $request_content = "--" . $boundary . "\r\n";
  $request_content .= "Content-Disposition: form-data; name=\"$name\"\r\n\r\n";
  $request_content .= $value . "\r\n";
  return $request_content;
}

sub send_request {
  my $this = shift;
  my ($script, $params) = @_;

  my $boundary = "----------------------------------" . int(rand()*1000000000000);
  # Create a request
  my $req = new HTTP::Request(POST => $this->{CONFIG}{url} . "/xml/" . $script);
  #my $req = new HTTP::Request(POST => "http://www.mozilla.gr.jp:4321/");
  $req->content_type("multipart/form-data; boundary=$boundary");

  ${$req->content_ref} .= $this->form_data_request($boundary, 'tree', $this->{TREE});
  foreach my $param (keys %{$params}) {
    ${$req->content_ref} .= $this->form_data_request($boundary, $param, $params->{$param});
  }
  if (defined($this->{LOG_IN})) {
    my $started_sending = 0;
    my $log_in = $this->{LOG_IN};
    while (<$log_in>) {
      if (!$started_sending) {
        ${$req->content_ref} .= "--" . $boundary . "\r\n";
        ${$req->content_ref} .= "Content-Disposition: form-data; name=\"log\"; filename=\"log.txt\"\r\n";
        ${$req->content_ref} .= "Content-Type: text/plain\r\n\r\n";
        $started_sending = 1;
      }
      ${$req->content_ref} .= $_;
    }
    if ($started_sending) {
      ${$req->content_ref} .= "\r\n";
    }
  }
  ${$req->content_ref} .= "--" . $boundary . "--\r\n";
  print "----- REQUEST TO $this->{CONFIG}{url}/xml/$script -----\n";
  #print $req->content();
  #print "----- END REQUEST TO $this->{CONFIG}{url}/xml/$script -----\n";

  # Pass request to the user agent and get a response back
  return $this->{UA}->request($req);
}

sub parse_simple_tag {
  my $this = shift;
  my ($content_ref, $tagname) = @_;
  if (${$content_ref} =~ /<$tagname[^>]*>([^<]*)/) {
    return $1;
  }
  return "";
}

sub get_field {
  my $this = shift;
  my ($content_ref, $field) = @_;
  if (!exists($this->{ARGS}{$field})) {
    $this->{CONFIG}{$field} = $this->parse_simple_tag($content_ref, $field);
  }
}

sub parse_content {
  my $this = shift;
  my ($content_ref, $is_start) = @_;
  if ($this->{CONFIG}{usecommands}) {
    foreach (split(/,/, $this->parse_simple_tag($content_ref, "commands"))) {
      $this->print_log("---> New command $_! <---\n");
      $this->{COMMANDS}{$_} = 1;
    }
  }

  if ($is_start) {
    if (${$content_ref} =~ /<machine[^>]+\bid=['"](\d+)['"]>/) {
      $this->{MACHINE_ID} = $1;
    } else {
      return 0;
    }
    $this->get_field($content_ref, "upgrade_url");

    # Call cleanup
    foreach my $module ("init_tree", "build", "distribute", "tests") {
      $this->call_module($module, "get_config", $content_ref);
    }
  }

  return 1;
}

sub sysinfo {
  my $this = shift;
  return $this->{SYSINFO};
}

sub field_vars_hash {
  my $this = shift;
  my $retval = {};
  my $i = 0;
  while (my ($field, $field_val) = each %{$this->{BUILD_VARS}{fields}}) {
    if (ref($field_val) eq "ARRAY") {
      foreach my $val (@{$field_val}) {
        $retval->{"field_${i}"} = $field;
        $retval->{"field_${i}_val"} = $val;
        $i++;
      }
    } else {
      $retval->{"field_${i}"} = $field;
      $retval->{"field_${i}_val"} = $field_val;
      $i++;
    }
  }
  return %{$retval};
}

sub build_start {
  my $this = shift;

  # Check the outcome of the response
  my $res = $this->send_request("build_start.pl", { machine_name => $this->{MACHINE_NAME}, os => $this->{SYSINFO}{OS}, os_version => $this->{SYSINFO}{OS_VERSION}, compiler => $this->{SYSINFO}{COMPILER}, clobber => ($this->{CONFIG}{clobber} ? 1 : 0), $this->field_vars_hash() });
  my $success = $res->is_success || $res->content() !~ /<error>/;
  if ($success) {
    $this->{LAST_STATUS_SEND} = time;
    print "\nCONTENT: " . $res->content() . "\n";
    return $this->parse_content($res->content_ref(), 1);
  }
  return 0;
}

sub build_status {
  my $this = shift;
  my ($status) = @_;

  # Check the outcome of the response
  my $res = $this->send_request("build_status.pl", { machine_id => $this->{MACHINE_ID}, status => $status, $this->field_vars_hash() });
  my $success = $res->is_success || $res->content() !~ /<error>/;
  if ($success) {
    $this->{LAST_STATUS_SEND} = time;
    print "build_status success\n";
    print "\nCONTENT: " . $res->content() . "\n";
    return $this->parse_content($res->content_ref(), 0);
  }
  return 0;
}

sub build_finish {
  my $this = shift;
  my ($status) = @_;
  print "build_finish($status)\n";
  close $this->{LOG_OUT};
  my $retval = $this->build_status($status);
  close $this->{LOG_IN};
  return $retval;
}

sub print_log {
  my $this = shift;
  my ($line) = @_;
  print $line;
  my $log_out = $this->{LOG_OUT};
  print $log_out $line;
}

sub start_section {
  my $this = shift;
  my ($section) = @_;
  $this->print_log("---> TINDERBOX $section\n");
}

sub end_section {
  my $this = shift;
  my ($section) = @_;
  $this->print_log("<--- TINDERBOX FINISHED $section\n");
}

sub eat_command {
  my $this = shift;
  my ($command) = @_;
  if ($this->{COMMANDS}{$command}) {
    $this->print_log("---> Eating command $command! <---\n");
    delete $this->{COMMANDS}{$command};
    return 1;
  }
  return 0;
}

use Fcntl;
use POSIX qw(:errno_h);

sub set_nonblocking {
  my $this = shift;
  my ($handle) = @_;
  my $flags = 0;
  fcntl($handle, F_GETFL, $flags) or return;
  $flags |= O_NONBLOCK;
  fcntl($handle, F_SETFL, $flags) or return;
}

sub _kill_command {
  # Kill a command and its children
  my $this = shift;
  my ($pid, $children_of) = @_;
  $this->print_log("Killing $pid\n");
  kill('INT', $pid);
  foreach my $child_pid (@{$children_of->{$pid}}) {
    $this->_kill_command($child_pid, $children_of);
  }
}

sub kill_command {
  # Kill a command and its children (children first)
  my $this = shift;
  my ($pid) = @_;
  # Get the ps -aux table and pass it to _kill_command
  my %children_of;
  open PS_AUX, $this->sysinfo()->{PS_COMMAND} . "|";
  while (<PS_AUX>) {
    print;
    if (/\s*(\d+)\s*(\d+)/) {
      if (!exists($children_of{$2})) {
        $children_of{$2} = [];
      }
      push @{$children_of{$2}}, $1;
    }
  }
  close PS_AUX;
  $this->_kill_command($pid, \%children_of);
}

sub do_command {
  my $this = shift;
  my ($command, $status, $grep_sub, $max_idle_time) = @_;

  $this->start_section("RUNNING '$command'");

  my $please_send_status = 0;

  my $handle;
  my $pid = open $handle, "$command 2>&1|";
  if (!$pid) {
    $this->end_section("(FAILURE: could not start) RUNNING '$command'");
    return 200;
  }
  $this->set_nonblocking($handle);
  my $last_read_time = time;
  my $build_error;
  while (1) {
    #
    # Read from the buffer asynchronously
    #
    my $buffer;
    my $rv = sysread($handle, $buffer, 1024);
    # If nothing was read, we check if the process is OK
    if (!$rv) {
      #
      # Check if the process is dead
      #
      my $wait_pid = waitpid($pid, POSIX::WNOHANG());
      if (($wait_pid == $pid && POSIX::WIFEXITED($?)) || $wait_pid == -1) {
        $build_error = $?;
        last;
      }
      # Kill the process if it's still alive and hung
      if ($max_idle_time && (time - $last_read_time) > $max_idle_time) {
        $this->print_log("Command appears to have hanged!");
        $build_error = 1;
        $this->kill_command($pid);
        $please_send_status = 202;
      }
    }
    $last_read_time = time;

    if ($buffer) {
      $this->print_log($grep_sub ? &$grep_sub($buffer) : $buffer);
    }

    {
      # Send status every so often (this also gives us back new commands)
      my $current_time = time;
      my $elapsed = $current_time - $this->{LAST_STATUS_SEND};
      if ($elapsed > $this->{CONFIG}{statusinterval}) {
        my $log_out = $this->{LOG_OUT};
        flush $log_out;
        my $success = $this->build_status(1);
      }
      # If we tried to kill before and we're not dead, or if the kick command
      # is around, we kill again
      if ($please_send_status == 301 || $this->eat_command("kick")) {
        $this->kill_command($pid);
        $please_send_status = 301;
      }
    }
    # If nothing was actually read, we sleep to give the cpu a chance
    if (!$rv) {
      sleep(3);
      next;
    }
  }
  close $handle;

  if ($build_error) {
    $this->end_section("(FAILURE: $build_error) RUNNING '$command'");
  } else {
    $this->end_section("(SUCCESS) RUNNING '$command'");
  }

  if ($please_send_status) {
    return $please_send_status;
  } else {
    return $build_error ? 200 : 0;
  }
}

sub read_mozconfig {
  my $this = shift;
  my $mozconfig = "";
  if ($ENV{MOZCONFIG}) {
    if (open MOZCONFIG, $ENV{MOZCONFIG}) {
      while (<MOZCONFIG>) {
        $mozconfig .= $_;
      }
    }
    close MOZCONFIG;
  } elsif (open MOZCONFIG, ".mozconfig") {
    while (<MOZCONFIG>) {
      $mozconfig .= $_;
    }
    close MOZCONFIG;
  } elsif (open MOZCONFIG, "~/.mozconfig") {
    while (<MOZCONFIG>) {
      $mozconfig .= $_;
    }
    close MOZCONFIG;
  }
  return $mozconfig;
}

sub print_build_info {
  my $this = shift;
  $this->start_section("PRINTING CONFIGURATION");
  $this->print_log(<<EOM);
== Tinderbox Info
Time: @{[time2str(time)]}
OS: $this->{SYSINFO}{OS}
$this->{SYSINFO}{OS_VERSION}
Compiler: $this->{SYSINFO}{COMPILER} $this->{SYSINFO}{COMPILER_VERSION}
Tinderbox Client: $TinderClient::VERSION
Tinderbox Client Last Modified: @{[$this->get_prog_mtime()]}
Tinderbox Protocol: $TinderClient::PROTOCOL_VERSION
Arguments: @{[join ' ', @{$this->{ORIGINAL_ARGS}}]}
URL: $this->{CONFIG}{url}
Tree: $this->{TREE}
Commands: @{[join(' ', sort keys %{$this->{COMMANDS}})]}
Config:
@{[join("\n", map { $_ . " = '" . $this->{CONFIG}{$_} . "'" } sort keys %{$this->{CONFIG}})]}
== End Tinderbox Client Info
EOM
  $this->do_command("env", 1);
  $this->end_section("PRINTING CONFIGURATION");
}


sub maybe_throttle {
  my $this = shift;
  my $elapsed = time - $this->{BUILD_VARS}{START_TIME};
  if ($elapsed < $this->{CONFIG}{throttle}) {
    print "Throttling!  Sleeping " . ($this->{CONFIG}{throttle} - $elapsed) . "s\n";
    sleep($this->{CONFIG}{throttle} - $elapsed);
  }
}

sub get_prog_mtime {
  my @prog_stat = stat($0);
  my $prog_mtime = $prog_stat[9];
  my $time_str = time2str($prog_mtime);
}

sub maybe_upgrade {
  my $this = shift;
  if ($this->{CONFIG}{upgrade} && $this->{CONFIG}{upgrade_url}) {
    my $time_str = $this->get_prog_mtime();
    $this->start_section("CHECKING FOR UPGRADE");
    $this->print_log("URL: $this->{CONFIG}{upgrade_url}\n");
    $this->print_log("If-Modified-Since: $time_str\n");
    my $req = new HTTP::Request(GET => $this->{CONFIG}{upgrade_url});
    $req->header('If-Modified-Since' => $time_str);
    my $res = $this->{UA}->request($req);
    if ($res->code() == 200) {
      my $old_script = "";
      open PROG, $0;
      open PROG_BAK, ">$0.bak";
      while (<PROG>) { $old_script .= $_; print PROG_BAK; }
      close PROG;
      close PROG_BAK;
      open PROG, ">$0";
      print PROG $res->content();
      close PROG;
      $this->print_log("New version found:\n");
      $this->print_log($res->content());
      $this->print_log("Overwrote $0 (now modified " . $this->get_prog_mtime() . ")\n");
      $this->end_section("CHECKING FOR UPGRADE");
      # Check if old content and new content are the same.  If so, continue on;
      # something funky must be happening with the date.
      if ($old_script eq $res->content()) { 
        $this->print_log("---> HMM.  The script I just downloaded is the same as the one before. <---\n");
        $this->print_log("---> There must be a date problem on this machine.  I think I'll just stick <---\n");
        $this->print_log("---> my head in the sand and hope the problem goes away. <---\n");
        $this->print_log("---> ... continuing with build as if nothing untoward had happened ... <---\n");
      } else {
        $this->print_log("Executing newly upgraded script ...\n");
        print "UPGRADING!  Throttling just for fun first ...\n";
        $this->build_finish(303);
        eval {
          # Throttle just in case we get in an upgrade client loop
          $this->maybe_throttle();
          exec("perl", $0, @{$this->{ORIGINAL_ARGS}});
        };
        exit(0);
      }
    } elsif ($res->code() == 304) {
      $this->print_log("Perl script not modified\n");
    } else {
      $this->print_log("Connection or URL failure (" . $res->code() . ")\n");
    }
    $this->end_section("CHECKING FOR UPGRADE");
  }
}

sub call_module {
  my $this = shift;
  my ($module, $method, $content_ref) = @_;
  my $code = "TinderClient::Modules::${module}::${method}(\$this, \$this->{CONFIG}, \$this->{PERSISTENT_VARS}, \$this->{BUILD_VARS}, \$content_ref)";
  my $retval = eval $code;
  # Handle ctrl+c
  if ($@) {
    die;
  }
  return $retval;
}

sub build_iteration {
  my $this = shift;

  # Open the log
  open $this->{LOG_OUT}, ">tinderclient.log" or die "Could not output to tinder log";
  open $this->{LOG_IN}, "tinderclient.log" or die "Could not read tinder log";

  # Initialize transient variables
  $this->{BUILD_VARS} = { fields => {} };

  $this->{BUILD_VARS}{START_TIME} = time;

  #
  # Send build start notification
  #
  if (!$this->build_start()) {
    $this->maybe_throttle();
    return;
  }

  my $err = 0;
  eval {
    $this->maybe_upgrade();
    $this->print_build_info();

    # Build
    foreach my $module ("init_tree", "build", "distribute", "tests") {
      $err = $this->call_module($module, "do_action");
      last if $err;
    }

    # Call cleanup
    foreach my $module ("init_tree", "build", "distribute", "tests") {
      $this->call_module($module, "finish_build");
    }
  };

  # Handle ctrl+c
  if ($@) {
    $this->print_log("ERROR: $@\n");
    $this->build_finish(302);
    die;
  }

  # Send build finish notification
  $this->build_finish($err || 100);

  # Determine if we need to throttle
  $this->maybe_throttle();

  chdir(".."); #
}


package TinderClient::SysInfo;

use strict;

#
# Get the sysinfo object for this system
#
sub get_sysinfo {
  #
  # Decide which OS SysInfo instance to create
  # (largely copied from the old tinderbox client)
  #
  my $os = `uname -s`;
  my $os_ver = `uname -r`;
  my $os_alt_ver = `uname -v`;
  my $cpu = `uname -m`;
  chomp($os, $os_ver, $os_alt_ver, $cpu);

  #
  # Handle aliases and weird version numbers
  #
  my %os_aliases = (
    'BSD_OS' => 'BSD/OS',
    'IRIX64' => 'IRIX',
  );
  if ($os_aliases{$os}) {
    $os = $os_aliases{$os};
  }
  if ($os eq 'SCO_SV') {
    $os = 'SCOOS';
    $os_ver = '5.0';
  } elsif ($os eq 'QNX') {
    $os_ver = $os_alt_ver;
    $os_ver =~ s/^([0-9])([0-9]*)$/$1.$2/;
  } elsif ($os eq 'AIX') {
    $os_ver = "$os_alt_ver.$os_ver";
  } elsif ($os =~ /^CYGWIN_([^-]*)-(.*)$/) {
    $os = "WIN$1";
    $os_ver = $2;
  } elsif ($os eq "SunOS" && $cpu ne 'i86pc' && substr($os_ver, 0, 1) ne '4') {
    $cpu = 'sparc';
  }

  return new TinderClient::SysInfo($os, $os_ver, $cpu);
}

#
# Sets up the system info object
#
sub new {
	my $class = shift;
	$class = ref($class) || $class;
	my $this = {};
	bless $this, $class;

  my ($os, $os_ver, $cpu) = @_;
  $this->{OS} = $os;
  $this->{OS_VERSION} = $os_ver;
  $this->{CPU} = $cpu;

  #
  # Set up compiler
  #
  if ($os =~ /^WIN/) {
    $this->{COMPILER} = 'cl';
  } else {
    $this->{COMPILER} = 'gcc';
  }
  if ($this->{COMPILER} eq 'cl') {
    $this->{COMPILER_VERSION} = `cl 2>&1`;
  } elsif ($this->{COMPILER} eq 'gcc') {
    $this->{COMPILER_VERSION} = `gcc --version`;
  }
  # XXX figure out version for Windows compiler

  #
  # Set up ps
  #
  if ($this->{OS} =~ /^WIN/) {
    $this->{PS_COMMAND} = "ps aux";
  } else {
    $this->{PS_COMMAND} = "ps -eo 'pid,ppid,command'";
  }
  return $this;
}


package TinderClient::Modules::init_tree;

use strict;

use Cwd;

sub get_config {
  my ($client, $config, $persistent_vars, $build_vars, $content_ref) = @_;

  if ($config->{usemozconfig}) {
    if (${$content_ref} =~ /<mozconfig[^>]*>(.*)<\/mozconfig>/sm) {
      $build_vars->{MOZCONFIG} = $1;
    }
  }
  $client->get_field($content_ref, "cvs_co_date");
  $client->get_field($content_ref, "cvsroot");
  $client->get_field($content_ref, "clobber");
  $client->get_field($content_ref, "branch");
  if ($config->{usepatches}) {
    $build_vars->{PATCHES} = [];
    while (${$content_ref} =~ /<patch[^>]+id\s*=\s*['"](\d+)['"]/g) {
      push @{$build_vars->{PATCHES}}, $1;
    }
  }

  $persistent_vars->{LAST_CHECKOUT} = 0 if !exists($persistent_vars->{LAST_CHECKOUT});
}

sub finish_build {
  my ($client, $config, $persistent_vars, $build_vars) = @_;
  delete $ENV{MOZILLA_OFFICIAL};
  delete $ENV{BUILD_OFFICIAL};
  delete $ENV{MOZ_CO_DATE};
  delete $ENV{MOZ_OBJDIR};
}

sub do_action {
  my ($client, $config, $persistent_vars, $build_vars) = @_;
  my $init_tree_status = 1;
  my $max_cvs_idle_time = 90*60; # 90 minutes

  #
  # We will only build if:
  # - new patches were downloaded
  # - checkout brought something down
  # - the build command was specified
  #
  $build_vars->{SHOULD_BUILD} = 0;

  my $co_params = "";
  if ($config->{cvs_co_date} && $config->{cvs_co_date} ne "off") {
    $co_params .= " -D '$config->{cvs_co_date}'";
  }
  if ($config->{branch}) {
    $co_params .= " -r $config->{branch}";
  }
  #
  # Checkout client.mk if necessary
  #
  my $please_checkout = 0;
  if (! -f "mozilla/client.mk") {
    $client->do_command("cvs -d$config->{cvsroot} co$co_params mozilla/client.mk", $init_tree_status, undef, $max_cvs_idle_time);
    $please_checkout = 1;
  }
  if (-f "mozilla/client.mk") {
    #
    # If this is a branch, and client.mk is not the right entry type,
    # *update* client.mk (make sure branch is correct)
    #
    if (open ENTRIES, "mozilla/CVS/Entries") {
      while (<ENTRIES>) {
        next if /^D/;
        chomp;
        my @line = split /\//;
        if ($line[1] eq "client.mk" && substr($line[5], 1) ne $config->{branch}) {
          $client->do_command("rm -rf mozilla/*");
          $client->do_command("cvs -d$config->{cvsroot} co$co_params mozilla/client.mk");
          $please_checkout = 1;
          last;
        }
      }
      close ENTRIES;
    }
    chdir("mozilla");
  } else {
    die "Must be just above the mozilla/ directory!";
  }

  #
  # Create .mozconfig if necessary
  #
  # First read .mozconfig
  my $please_clobber = 0;
  my $mozconfig = $client->read_mozconfig();
  $mozconfig ||= "";
  print "@@@ mozconfig:\n$mozconfig\n@@@ network .mozconfig:\n$build_vars->{MOZCONFIG}\n";
  if ($build_vars->{MOZCONFIG}) {
    if ($mozconfig ne $build_vars->{MOZCONFIG}) {
      delete $ENV{MOZCONFIG};
      $client->start_section("CREATING MOZCONFIG");
      open MOZCONFIG, ">.mozconfig";
      print MOZCONFIG $build_vars->{MOZCONFIG};
      close MOZCONFIG;
      $mozconfig = $_;
      $client->print_log("(Will clobber this cycle)");
      $client->end_section("CREATING MOZCONFIG");
      $please_clobber = 1;
    }
  }

  #
  # Print build info
  #
  $client->start_section("PRINTING BUILD INFO");
  $client->print_log(<<EOM);
== .mozconfig
$mozconfig
== End .mozconfig
EOM
  $client->start_section("PRINTING BUILD INFO");

  #
  # Remove patches
  #
  my @old_patches;
  foreach my $patch (glob("tbox_patches/*.patch")) {
    $client->do_command("patch -Nt -Rp0 < $patch", $init_tree_status);
    if ($patch =~ /^tbox_patches\/(.+)\.patch$/) {
      push @old_patches, $1;
    }
  }

  #
  # Make build official
  #
  $client->start_section("SETTING MOZILLA_OFFICIAL=1,BUILD_OFFICIAL=1");
  $ENV{MOZILLA_OFFICIAL}=1;
  $ENV{BUILD_OFFICIAL}=1;
  $client->end_section("SETTING MOZILLA_OFFICIAL=1,BUILD_OFFICIAL=1");

  #
  # Set MOZ_OBJDIR
  #
  if (! -d "objdir") {
    $client->start_section("MAKING OBJDIR");
    if (!mkdir("objdir")) {
      $client->print_log("Unable to make objdir.");
      $client->end_section("MAKING OBJDIR");
      return 200;
    }
    $client->end_section("MAKING OBJDIR");
  }
  $client->start_section("SETTING OBJDIR");
  $ENV{MOZ_OBJDIR} = getcwd() . "/objdir";
  $client->print_log("Set to $ENV{MOZ_OBJDIR}\n");
  $client->end_section("SETTING MOZ_OBJDIR");

  #
  # Clean non-objdir stuff out to make an objdir build work
  #
  if (-f "Makefile") {
    $client->do_command("make distclean", $init_tree_status+2);
  }

  #
  # Checkout
  #
  # - If cvs co date is off, do nothing
  # - If cvs co date exists, and is the same as last time, we already checked
  #   out, so do nothing
  # - If it is blank, we check out every time
  # - If we are asked to do "checkout" or this is a new build, we check out
  #   regardless (and we *always* do a full checkout, not fast-update).
  my $err = 0;
  if ($client->eat_command("checkout")) {
    $please_checkout = 1;
  }
  if ($please_checkout ||
      ($config->{cvs_co_date} ne "off" &&
      !($config->{cvs_co_date} &&
        $config->{cvs_co_date} eq $persistent_vars->{LAST_CVS_CO_DATE}))) {
    if ($config->{cvs_co_date}) {
      # XXX $::ENV?
      $ENV{MOZ_CO_DATE} = $config->{cvs_co_date};
    }
    my $parsing_code = sub {
                         if ($_[0] =~ /^[UP] /m) {
                           $build_vars->{SHOULD_BUILD} = 1;
                         }
                         if ($config->{lowbandwidth} && $_[0] =~ /^\? /m) {
                           return "";
                         }
                         return $_[0];
                       };

    #
    # We only want to do a full, slow make -f client.mk checkout if:
    # - this is the first time this program has been called
    # - 24 hours have passed since the last checkout was done
    # - we were given a "checkout" command or this is the first checkout
    # - there is a cvs_co_date
    #
    # All other times we do fast-update.
    #
    if ($config->{cvs_co_date} || $please_checkout ||
        (time - $persistent_vars->{LAST_CHECKOUT}) >= (24*60*60)) {
      $err = $client->do_command("make -f client.mk checkout", $init_tree_status+1, $parsing_code, $max_cvs_idle_time);
      $persistent_vars->{LAST_CHECKOUT} = time;
    } else {
      $err = $client->do_command("make -f client.mk fast-update", $init_tree_status+1, $parsing_code, $max_cvs_idle_time);
    }
    if ($err) {
      $persistent_vars->{LAST_CHECKOUT} = 0;
    }

    $persistent_vars->{LAST_CVS_CO_DATE} = $config->{cvs_co_date};
  }

  #
  # Apply patches
  #
  if (!$err && @{$build_vars->{PATCHES}}) {
    #
    # If the set of patches is different, we need to rebuild
    #
    if (join(' ', sort @old_patches) ne join(' ', sort @{$build_vars->{PATCHES}})) {
      $build_vars->{SHOULD_BUILD} = 1;
    }
    $client->start_section("APPLYING PATCHES");
    foreach my $patch_id (@{$build_vars->{PATCHES}}) {
      my $patch = $client->get_patch($patch_id);
      $client->print_log("PATCH: $patch\n");
      if (! $patch) {
        $err = 200;
      } else {
        my $local_err = $client->do_command("patch --dry-run -Nt -p0 < $patch", $init_tree_status+2);
        if (!$local_err) {
          $local_err = $client->do_command("patch -Nt -p0 < $patch", $init_tree_status);
        }
        if ($local_err) {
          unlink($patch);
        }
      }
    }
    $client->end_section("APPLYING PATCHES");
  }

  #
  # Clobber
  #
  # We clobber:
  # - when we need to build and we are a clobber build
  # - when there is a clobber command in the queue or the mozconfig changed
  #
  if (!$err && (($build_vars->{SHOULD_BUILD} && $config->{clobber}) ||
      $client->eat_command("clobber") || $please_clobber)) {
    $client->do_command("rm -rf objdir", $init_tree_status+2);
    $build_vars->{SHOULD_BUILD} = 1;
  }

  #
  # If the build command is specified, we build no matter what
  #
  if ($client->eat_command("build")) {
    $build_vars->{SHOULD_BUILD} = 1;
  }

  return $err;
}


package TinderClient::Modules::build;

use strict;

sub get_config {
  my ($client, $config, $persistent_vars, $build_vars, $content_ref) = @_;
  $client->get_field($content_ref, "upload_ssh_loc");
  $client->get_field($content_ref, "upload_ssh_dir");
  $client->get_field($content_ref, "upload_dir");
  $client->get_field($content_ref, "uploaded_url");
}

sub finish_build {
  my ($client, $config, $persistent_vars, $build_vars) = @_;
  delete $ENV{MOZILLA_OFFICIAL};
  delete $ENV{BUILD_OFFICIAL};
  delete $ENV{MOZ_CO_DATE};
  delete $ENV{MOZ_OBJDIR};
}

sub do_action {
  my ($client, $config, $persistent_vars, $build_vars) = @_;

  #
  # Build
  #
  my $err = 0;
  if ($build_vars->{SHOULD_BUILD}) {
    $err = $client->do_command("make -f client.mk build", 10,
                               $config->{lowbandwidth} ?
        sub {
          if ($_[0] =~ s/^g?make.+Entering directory ['`"](.+)['`"]$/$1/mg) {
            return $_[0];
          }
          if ($_[0] =~ /^\S+$/) {
            return $_[0];
          }
          return "";
        } :
        undef);
  } else {
    $client->print_log("Skipping build because no changes were made\n");
  }

  if (!$build_vars->{SHOULD_BUILD}) {
    $err = 304;
  }
  return $err;
}

package TinderClient::Modules::distribute;

use strict;

sub get_config {
  my ($client, $config, $persistent_vars, $build_vars, $content_ref) = @_;
  $client->get_field($content_ref, "upload_ssh_loc");
  $client->get_field($content_ref, "upload_ssh_dir");
  $client->get_field($content_ref, "upload_dir");
  $client->get_field($content_ref, "uploaded_url");
  $client->get_field($content_ref, "distribute");
  foreach my $distribution (split(/,/, $config->{distribute})) {
    $client->call_module($distribution, "get_config", $content_ref);
  }
}

sub finish_build {
  my ($client, $config, $persistent_vars, $build_vars) = @_;
  foreach my $distribution (split(/,/, $config->{distribute})) {
    $client->call_module($distribution, "finish_build");
  }
}

sub do_action {
  my ($client, $config, $persistent_vars, $build_vars) = @_;

  #
  # Build and upload distribution
  #
  my $err = 0;
  $build_vars->{PACKAGES} = {};
  # Do not build distributions unless we built
  if ($build_vars->{SHOULD_BUILD}) {
    #
    # Build distributions
    #
    if (!$err) {
      foreach my $distribution (split(/,/, $config->{distribute})) {
        $err = $client->call_module($distribution, "do_action");
        last if $err;
      }
    }

    #
    # Upload installer or distribution
    #
    if (!$err) {
      # Get build id
      my $build_id = "";
      if (open BUILD_NUMBER, "objdir/config/build_number") {
        $build_id = <BUILD_NUMBER>;
        chomp $build_id;
        close BUILD_NUMBER;
      }
      if (!$build_id) {
        $build_id = time2str("%Y%m%d%H", time);
      }

      # Upload
      foreach my $field_name (keys %{$build_vars->{PACKAGES}}) {
        $build_vars->{PACKAGES}{$field_name} =~ /([^\/]*)$/;
        my $upload_file = $1;
        $upload_file =~ s/(\..*)$/-$build_id$1/;
        upload_build($config, $build_vars, $field_name, $build_vars->{PACKAGES}{$field_name}, $upload_file);
      }
    }
  } else {
    $client->print_log("Skipping distribution because no build was done\n");
  }

  return $err;
}

sub upload_build {
  my ($config, $build_vars, $field_name, $local_name, $upload_name) = @_;
  if ($config->{upload_ssh_loc} && `which scp`) {
    $config->{upload_ssh_dir} .= "/" if $config->{upload_ssh_dir} && $config->{upload_ssh_dir} !~ /\/$/;
    $client->do_command("scp $local_name $config->{upload_ssh_loc}:$config->{upload_ssh_dir}$upload_name");
    set_upload_dir($config, $field_name, $build_vars, $upload_name);
  }
  if ($config->{upload_dir}) {
    $config->{upload_dir} .= "/" if $config->{upload_dir} && $config->{upload_dir} !~ /\/$/;
    $client->do_command("cp $local_name $config->{upload_dir}$upload_name");
    set_upload_dir($config, $field_name, $build_vars, $upload_name);
  }
}

sub set_upload_dir {
  my ($config, $field_name, $build_vars, $upload_name) = @_;
  if ($config->{uploaded_url}) {
    my $url = $config->{uploaded_url};
    $url =~ s/\%s/$upload_name/g;
    if (!$build_vars->{fields}{$field_name}) {
      $build_vars->{fields}{$field_name} = [];
    }
    push @{$build_vars->{fields}{$field_name}}, $url;
  }
}


package TinderClient::Modules::installer;

sub get_config {
  my ($client, $config, $persistent_vars, $build_vars, $content_ref) = @_;
}

sub finish_build {
  my ($client, $config, $persistent_vars, $build_vars) = @_;
}

sub do_action {
  my ($client, $config, $persistent_vars, $build_vars) = @_;

  #  # We always do the installer if we can, to ensure that it compiles
  #  if ($client->sysinfo()->{OS} =~ /^WIN/) {
  #    if (chdir("xpinstall/wizard/windows/builder")) {
  #      $err = $client->do_command("perl build.pl", 12);
  #      chdir("../../../..");
  #    }
  #  }# elsif ($client->sysinfo()->{OS} =~ /Linux/) {
  #  #  if (chdir("xpinstall/packager/unix")) {
  #  #    $client->do_command("perl deliver.pl", 12);
  #  #    chdir("../../..");
  #  #  }
  #  #}
  
  #if ($local_file) {
  #  $build_vars->{PACKAGES}{build_zip} = $local_file;
  #}
  $client->print_log("---> installer is not supported until it works with objdir builds (bug 162079) <---\n");
  return 0;
}

package TinderClient::Modules::build_zip;

sub get_config {
  my ($client, $config, $persistent_vars, $build_vars, $content_ref) = @_;
}

sub finish_build {
  my ($client, $config, $persistent_vars, $build_vars) = @_;
}

sub do_action {
  my ($client, $config, $persistent_vars, $build_vars) = @_;

  $client->do_command("make -C objdir/xpinstall/packager", 11);

  # Find zipped build
  my ($local_file) = glob("objdir/dist/mozilla*.tgz");
  if (!$local_file) {
    ($local_file) = glob("objdir/dist/mozilla*.tar.gz");
  }
  if (!$local_file) {
    ($local_file) = glob("objdir/dist/mozilla*.zip");
  }
  if ($local_file) {
    $build_vars->{PACKAGES}{build_zip} = $local_file;
  }
  return 0;
}

package TinderClient::Modules::raw_zip;

sub get_config {
  my ($client, $config, $persistent_vars, $build_vars, $content_ref) = @_;
  $client->get_field($content_ref, "raw_zip_name");
}

sub finish_build {
  my ($client, $config, $persistent_vars, $build_vars) = @_;
}

sub do_action {
  my ($client, $config, $persistent_vars, $build_vars) = @_;

  my $sysinfo = $client->sysinfo();
  if (chdir("objdir/dist/bin")) {
    my $os = $sysinfo->{OS};
    $os =~ tr/A-Z/a-z/;
    $os =~ s/[^a-z]//g;
    $client->do_command("tar czvfh ../$config->{raw_zip_name}-$os.tar.gz *", 12);
    chdir("../../..");
    $build_vars->{PACKAGES}{raw_zip} = "objdir/dist/$config->{raw_zip_name}-$os.tar.gz";
  }
  return 0;
}

package TinderClient::Modules::tests;

use strict;

sub get_config {
  my ($client, $config, $persistent_vars, $build_vars, $content_ref) = @_;
  $client->get_field($content_ref, "tests");
  foreach my $module (split(/,/, $config->{tests})) {
    $client->call_module($module, "get_config", $content_ref);
  }
}

sub finish_build {
  my ($client, $config, $persistent_vars, $build_vars) = @_;
  foreach my $module (split(/,/, $config->{tests})) {
    $client->call_module($module, "finish_build");
  }
}

sub do_action {
  my ($client, $config, $persistent_vars, $build_vars) = @_;
  foreach my $module (split(/,/, $config->{tests})) {
    my $err = $client->call_module($module, "do_action");
    if ($err) {
      return $err;
    }
  }
  return 0;
}


package TinderClient::Modules::Tp;

use strict;

sub get_config {
  my ($client, $config, $persistent_vars, $build_vars, $content_ref) = @_;
  $client->parse_simple_tag($content_ref, "pageloader_url");
}

sub finish_build {
  my ($client, $config, $persistent_vars, $build_vars) = @_;
}

sub do_action {
  my ($client, $config, $persistent_vars, $build_vars) = @_;
  #my $err = $client->do_command("objdir/dist/bin/mozilla -CreateProfile tinder");
#dist/bin/mozilla -P tinder http://cowtools.mcom.com/page-loader/loader.pl?delay=1000\&nocache=0\&maxcyc=1\&timeout=15000\&auto=1
  #return $err;
  return 0;
}


package TinderClient::Modules::Txul;

use strict;

sub get_config {
  my ($client, $config, $persistent_vars, $build_vars, $content_ref) = @_;
}

sub finish_build {
  my ($client, $config, $persistent_vars, $build_vars) = @_;
}

sub do_action {
  my ($client, $config, $persistent_vars, $build_vars) = @_;
  return 0;
}


package TinderClient::Modules::Ts;

use strict;

sub get_config {
  my ($client, $config, $persistent_vars, $build_vars, $content_ref) = @_;
}

sub finish_build {
  my ($client, $config, $persistent_vars, $build_vars) = @_;
}

sub do_action {
  my ($client, $config, $persistent_vars, $build_vars) = @_;
  return 0;
}