From 05b8f51c0662a249f0698d0d796bc56915bdb11d Mon Sep 17 00:00:00 2001 From: johnkeis Date: Sat, 8 Feb 2003 00:55:13 +0000 Subject: [PATCH] Make branches work, make recursive kill work more cross-platform --- webtools/tinderbox3/client/tinderclient.pl | 2671 ++++++++++---------- 1 file changed, 1353 insertions(+), 1318 deletions(-) diff --git a/webtools/tinderbox3/client/tinderclient.pl b/webtools/tinderbox3/client/tinderclient.pl index d6201516278..8a172655d91 100644 --- a/webtools/tinderbox3/client/tinderclient.pl +++ b/webtools/tinderbox3/client/tinderclient.pl @@ -1,1318 +1,1353 @@ -#!/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 <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} =~ /]+\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() !~ //; - 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() !~ //; - 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); - } -} - -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, "ps aux|"; - while () { - 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; - } - sleep(3); - next; - } - $last_read_time = time; - - $this->print_log($grep_sub ? &$grep_sub($buffer) : $buffer); - - { - # Send status and check whether we need to kill every 3 minutes - 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 ($success) { - if ($this->eat_command("kick")) { - $this->kill_command($pid); - $please_send_status = 301; - } - } - } - } - } - 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 .= $_; - } - } - close MOZCONFIG; - } elsif (open MOZCONFIG, ".mozconfig") { - while () { - $mozconfig .= $_; - } - close MOZCONFIG; - } elsif (open MOZCONFIG, "~/.mozconfig") { - while () { - $mozconfig .= $_; - } - close MOZCONFIG; - } - return $mozconfig; -} - -sub print_build_info { - my $this = shift; - $this->start_section("PRINTING CONFIGURATION"); - $this->print_log(<{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 () { $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; for os's to override -# -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; - - 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 - - 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>/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"); - if ($config->{usepatches}) { - $build_vars->{PATCHES} = []; - while (${$content_ref} =~ /]+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; - - # - # Checkout client.mk if necessary - # - my $please_checkout = 0; - if (! -f "mozilla/client.mk") { - $client->do_command("cvs -d$config->{cvsroot} co mozilla/client.mk", $init_tree_status, undef, $max_cvs_idle_time); - $please_checkout = 1; - } - if (-f "mozilla/client.mk") { - 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(); - 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(<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] /) { - $build_vars->{SHOULD_BUILD} = 1; - } - if ($config->{lowbandwidth} && $_[0] =~ /\? /) { - 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/) { - return $_[0]; - } - if ($_[0] =~ /^\S+$/) { - return $_[0]; - } - return ""; - } : - undef); - } else { - $client->print_log("Skipping build because no changes were made\n"); - } - - 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 = ; - 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; -} +#!/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 <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} =~ /]+\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() !~ //; + 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() !~ //; + 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, "ps -eo 'pid,ppid,command'|"; + while () { + 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; + + $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 .= $_; + } + } + close MOZCONFIG; + } elsif (open MOZCONFIG, ".mozconfig") { + while () { + $mozconfig .= $_; + } + close MOZCONFIG; + } elsif (open MOZCONFIG, "~/.mozconfig") { + while () { + $mozconfig .= $_; + } + close MOZCONFIG; + } + return $mozconfig; +} + +sub print_build_info { + my $this = shift; + $this->start_section("PRINTING CONFIGURATION"); + $this->print_log(<{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 () { $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; for os's to override +# +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; + + 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 + + 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>/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} =~ /]+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 () { + 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(<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] /) { + $build_vars->{SHOULD_BUILD} = 1; + } + if ($config->{lowbandwidth} && $_[0] =~ /\? /) { + 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/) { + 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 = ; + 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; +}