mozilla
/
pjs
зеркало из https://github.com/mozilla/pjs.git
1
0
Форкнуть 0
Код Задачи Пакеты Проекты Релизы Вики Активность
pjs/webtools/tinderbox3/client/tinderclient.pl

1354 строки
38 KiB
Perl
Исходник Обычный вид История

Make branches work, make recursive kill work more cross-platform
2003-02-08 03:55:13 +03:00
#!/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, "ps -eo 'pid,ppid,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;
$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; 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[^>]*>(.*)<\/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] /) {
$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 = <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;
}