Remove the debug die at startup. :(

[buildfarm-client.git] / run_branches

#!/usr/bin/perl

=comment

Copyright (c) 2003-2010, Andrew Dunstan

See accompanying License file for license details

=cut

use vars qw($VERSION); $VERSION = 'REL_0.1';

use strict;
use warnings;
use 5.010;

use Fcntl qw(:flock :seek);
use File::Basename;
use FindBin qw($RealBin);
use Cwd;

use lib $RealBin;
use EximBuild::Options;

sub branch_last_sort;

# Complain on old-style use (.pl extension), but only if a
# terminal is available.
if ($0 =~ /(.*)\.pl$/) {
    die "$0: Please use `@{[join ' ' => $1, @ARGV]}' instead.\n"
        if -t;
    exec $1, @ARGV;
}

# Most of the client code assumes that our working directory
# is the client code directory.
chdir $RealBin or die "$0: Can't chdir to '$RealBin': $!\n";
say "Changed working directory to '$RealBin'" if -t;

my %branch_last;
my $run_build = './run_build';

my($run_all, $run_one);
my %extra_options =(
    'run-all' => \$run_all,
    'run-one' => \$run_one,
);

# process the command line
EximBuild::Options::fetch_options(%extra_options);

# no non-option args allowed here
die("$0: non-option arguments not permitted")
  if @ARGV;

die "$0: only one of --run-all and --run-one permitted"
  if ($run_all && $run_one);

die "$0: need one of --run-all and --run-one"
  unless ($run_all || $run_one);

# common mistake
die "$0: need group searchable homedir"
  unless (stat($ENV{HOME}) & 0550 == 0550);

# set up a "branch" variable for processing the config file
use vars qw($branch);
$branch = 'global';

#
# process config file
#
require $buildconf;

# Check if auto-update is wanted and possible
if (not exists $EximBuild::Conf{auto_update} or $EximBuild::Conf{auto_update})
{
    die "$0: auto-update not possible: need write permissions in @{[cwd]}\n"
        if not -w '.';
    # http://stackoverflow.com/questions/3258243/check-if-pull-needed-in-git
    system('git remote update') == 0 or die $? >> 8;
    my ($upstream, $local, $base) = qx'git rev-parse ...@{upstream}';   die $? >> 8 if $?;
    $base =~ s/^\^//;

    if ($upstream ne $local) {
        die "$0: the merge base is not local anymore. Refusing to `git pull`\n"
            if $base ne $local;

        # if we're the merge base, the ff-only should workkkkkk
        system 'git pull --ff-only'
    }
}

unless (
    (
        ref $EximBuild::conf{branches_to_build} eq 'ARRAY'
        &&@{$EximBuild::conf{branches_to_build}}
    )
    ||$EximBuild::conf{branches_to_build} =~
    /^(ALL|HEAD_PLUS_LATEST|HEAD_PLUS_LATEST2)$/
  )
{
    die "no branches_to_build specified in $buildconf";
}

my @branches;
if (ref $EximBuild::conf{branches_to_build})
{
    @branches = @{$EximBuild::conf{branches_to_build}};
}
elsif ($EximBuild::conf{branches_to_build} =~
    /^(ALL|HEAD_PLUS_LATEST|HEAD_PLUS_LATEST2)$/ )
{

    # Need to set the path here so we make sure we pick up the right perl.
    # It has to be the perl that the build script would choose
    # i.e. specially *not* the MinGW SDK perl that is invoked for the
    # build script, which means we need to put the path back the way it was
    # when we're done
    local $ENV{PATH} = $EximBuild::conf{build_env}->{PATH}
      if ($EximBuild::conf{build_env}->{PATH});
    (my $url = $EximBuild::conf{target}) =~s/cgi-bin.*/branches_of_interest.txt/;
    my $branches_of_interest = `perl -MLWP::Simple -e "getprint(q{$url})"`;
    die "getting branches of interest" unless $branches_of_interest;
    push(@branches,$_)foreach (split(/\s+/,$branches_of_interest));
    #splice(@branches,0,-2)
    #  if $EximBuild::conf{branches_to_build} eq 'HEAD_PLUS_LATEST';
    #splice(@branches,0,-3)
    #  if $EximBuild::conf{branches_to_build} eq 'HEAD_PLUS_LATEST2';
}

@branches = apply_throttle(@branches);

my $global_lock_dir =
    $EximBuild::conf{global_lock_dir}
  ||$EximBuild::conf{build_root}
  ||'';

unless ($global_lock_dir && -d $global_lock_dir)
{
    die "no global lock directory: $global_lock_dir";
}

# acquire the lock

my $lockfile;

my $lockfilename = "$global_lock_dir/GLOBAL.lck";

open($lockfile, ">$lockfilename") || die "opening lockfile: $!";

if ( !flock($lockfile,LOCK_EX|LOCK_NB) )
{
    print "Another process holds the lock on " ."$lockfilename. Exiting.\n"
      if ($verbose);
    exit(0);
}

if ($run_all)
{
    foreach my $brnch(@branches)
    {
        run_branch($brnch);
    }
}
elsif ($run_one)
{

    # sort the branches by the order in which they last did actual work
    # then try running them in that order until one does some work

    %branch_last = map {$_ => find_last_status($_)} @branches;
    foreach my $brnch(sort branch_last_sort @branches)
    {
        run_branch($brnch);
        my $new_status = find_last_status($brnch);
        last if $new_status != $branch_last{$brnch};
    }
}

exit 0;

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

sub run_branch
{
    my $branch = shift;
    my @args = ($run_build,EximBuild::Options::standard_option_list(), $branch);

    # Explicitly use perl from the path (and not this perl, so don't use $^X)
    # This script needs to run on Cygwin with non-cygwin perl if it's running
    # in tandem with AS/MinGW perl, since Cygwin perl doesn't honor locks
    # the samne way, and the global lock fails. But the build script needs
    # to run with the native perl, even on Cygwin, which it picks up from
    # the path. (Head exploding yet?).
    system("perl",@args);
}

sub branch_last_sort
{
    return $branch_last{$a} <=> $branch_last{$b};
}

sub find_last_status
{
    my $brnch = shift;
    my $status_file =
      "$EximBuild::conf{build_root}/$brnch/$EximBuild::conf{animal}.last.status";
    return 0 unless (-e  $status_file);
    my $handle;
    open($handle,$status_file) || dir $!;
    my $ts = <$handle>;
    chomp $ts;
    close($handle);
    return $ts + 0;
}

sub apply_throttle
{
    my @branches = @_;
    return @branches unless exists $EximBuild::conf{throttle};
    my @result;
    my %throttle = %{$EximBuild::conf{throttle}};

    # implement throttle keywords ALL !HEAD and !RECENT
    my @candidates;
    my $replacement;
    if (exists $throttle{ALL})
    {
        @candidates = @branches;
        $replacement = $throttle{ALL};
    }
    elsif (exists  $throttle{'!HEAD'})
    {
        @candidates = grep { $_ ne 'HEAD' } @branches;
        $replacement = $throttle{'!HEAD'};
    }
    elsif (exists  $throttle{'!RECENT'})
    {

        # sort branches, make sure we get numeric major version sorting right
        my @stable = grep { $_ ne 'HEAD' } @branches;
        s/^REL(\d)_/0$1/ foreach (@stable);
        @stable = sort @stable;
        s/^REL0/REL/ foreach (@stable);
        pop @stable; # remove latest
        @candidates = @stable;
        $replacement = $throttle{'!RECENT'};
    }
    foreach my $cand (@candidates)
    {

        # only supply this for the branch if there isn't already
        # a throttle
        $throttle{$cand} ||= $replacement;
    }

    # apply throttle filters
    foreach my $branch(@branches)
    {
        my $this_throttle =  $throttle{$branch};
        unless (defined $this_throttle)
        {
            push(@result,$branch);
            next;
        }
        my $minh = $this_throttle->{min_hours_since};
        my $ts = find_last_status($branch);
        next
          if ( $ts
            && (defined $minh)
            &&($minh && $minh < ((time - $ts) / 3600.0)));
        if (exists $this_throttle->{allowed_hours})
        {
            my @allowed_hours = split(/,/,$this_throttle->{allowed_hours});
            my $hour = (localtime(time))[2];
            next unless grep {$_ == $hour} @allowed_hours;
        }
        push(@result,$branch);
    }

    return @result;
}