run_branches.pl

   1 #!/usr/bin/perl
   2
   3 =comment
   4
   5 Copyright (c) 2003-2010, Andrew Dunstan
   6
   7 See accompanying License file for license details
   8
   9 =cut
  10
  11 use vars qw($VERSION); $VERSION = 'REL_0.1';
  12
  13 use strict;
  14 use warnings;
  15 use Fcntl qw(:flock :seek);
  16 use EximBuild::Options;
  17 use File::Basename;
  18
  19 my %branch_last;
  20 sub branch_last_sort;
  21
  22 my $run_build;
  23 ($run_build = $0) =~ s/run_branches/run_build/;
  24
  25 my($run_all, $run_one);
  26 my %extra_options =(
  27     'run-all' => \$run_all,
  28     'run-one' => \$run_one,
  29 );
  30
  31 # process the command line
  32 EximBuild::Options::fetch_options(%extra_options);
  33
  34 # no non-option args allowed here
  35 die("$0: non-option arguments not permitted")
  36   if @ARGV;
  37
  38 die "only one of --run-all and --run-one permitted"
  39   if ($run_all && $run_one);
  40
  41 die "need one of --run-all and --run-one"
  42   unless ($run_all || $run_one);
  43
  44 # common mistake
  45 die "need group searchable homedir"
  46   unless (stat($ENV{HOME}) & 0550 == 0550);
  47
  48 # set up a "branch" variable for processing the config file
  49 use vars qw($branch);
  50 $branch = 'global';
  51
  52 #
  53 # process config file
  54 #
  55 require $buildconf;
  56
  57 unless (
  58     (
  59         ref $EximBuild::conf{branches_to_build} eq 'ARRAY'
  60         &&@{$EximBuild::conf{branches_to_build}}
  61     )
  62     ||$EximBuild::conf{branches_to_build} =~
  63     /^(ALL|HEAD_PLUS_LATEST|HEAD_PLUS_LATEST2)$/
  64   )
  65 {
  66     die "no branches_to_build specified in $buildconf";
  67 }
  68
  69 my @branches;
  70 if (ref $EximBuild::conf{branches_to_build})
  71 {
  72     @branches = @{$EximBuild::conf{branches_to_build}};
  73 }
  74 elsif ($EximBuild::conf{branches_to_build} =~
  75     /^(ALL|HEAD_PLUS_LATEST|HEAD_PLUS_LATEST2)$/ )
  76 {
  77
  78     # Need to set the path here so we make sure we pick up the right perl.
  79     # It has to be the perl that the build script would choose
  80     # i.e. specially *not* the MinGW SDK perl that is invoked for the
  81     # build script, which means we need to put the path back the way it was
  82     # when we're done
  83     my $save_path = $ENV{PATH};
  84     $ENV{PATH} = $EximBuild::conf{build_env}->{PATH}
  85       if ($EximBuild::conf{build_env}->{PATH});
  86     (my $url = $EximBuild::conf{target}) =~s/cgi-bin.*/branches_of_interest.txt/;
  87     my $branches_of_interest = `perl -MLWP::Simple -e "getprint(q{$url})"`;
  88     die "getting branches of interest" unless $branches_of_interest;
  89     $ENV{PATH} = $save_path;
  90     push(@branches,$_)foreach (split(/\s+/,$branches_of_interest));
  91     #splice(@branches,0,-2)
  92     #  if $EximBuild::conf{branches_to_build} eq 'HEAD_PLUS_LATEST';
  93     #splice(@branches,0,-3)
  94     #  if $EximBuild::conf{branches_to_build} eq 'HEAD_PLUS_LATEST2';
  95 }
  96
  97 @branches = apply_throttle(@branches);
  98
  99 my $global_lock_dir =
 100     $EximBuild::conf{global_lock_dir}
 101   ||$EximBuild::conf{build_root}
 102   ||'';
 103
 104 unless ($global_lock_dir && -d $global_lock_dir)
 105 {
 106     die "no global lock directory: $global_lock_dir";
 107 }
 108
 109 # acquire the lock
 110
 111 my $lockfile;
 112
 113 my $lockfilename = "$global_lock_dir/GLOBAL.lck";
 114
 115 open($lockfile, ">$lockfilename") || die "opening lockfile: $!";
 116
 117 if ( !flock($lockfile,LOCK_EX|LOCK_NB) )
 118 {
 119     print "Another process holds the lock on " ."$lockfilename. Exiting.\n"
 120       if ($verbose);
 121     exit(0);
 122 }
 123
 124 if ($run_all)
 125 {
 126     foreach my $brnch(@branches)
 127     {
 128         run_branch($brnch);
 129     }
 130 }
 131 elsif ($run_one)
 132 {
 133
 134     # sort the branches by the order in which they last did actual work
 135     # then try running them in that order until one does some work
 136
 137     %branch_last = map {$_ => find_last_status($_)} @branches;
 138     foreach my $brnch(sort branch_last_sort @branches)
 139     {
 140         run_branch($brnch);
 141         my $new_status = find_last_status($brnch);
 142         last if $new_status != $branch_last{$brnch};
 143     }
 144 }
 145
 146 exit 0;
 147
 148 ##########################################################
 149
 150 sub run_branch
 151 {
 152     my $branch = shift;
 153     my @args = ($run_build,EximBuild::Options::standard_option_list(), $branch);
 154
 155     # Explicitly use perl from the path (and not this perl, so don't use $^X)
 156     # This script needs to run on Cygwin with non-cygwin perl if it's running
 157     # in tandem with AS/MinGW perl, since Cygwin perl doesn't honor locks
 158     # the samne way, and the global lock fails. But the build script needs
 159     # to run with the native perl, even on Cygwin, which it picks up from
 160     # the path. (Head exploding yet?).
 161     system("perl",@args);
 162 }
 163
 164 sub branch_last_sort
 165 {
 166     return $branch_last{$a} <=> $branch_last{$b};
 167 }
 168
 169 sub find_last_status
 170 {
 171     my $brnch = shift;
 172     my $status_file =
 173       "$EximBuild::conf{build_root}/$brnch/$EximBuild::conf{animal}.last.status";
 174     return 0 unless (-e  $status_file);
 175     my $handle;
 176     open($handle,$status_file) || dir $!;
 177     my $ts = <$handle>;
 178     chomp $ts;
 179     close($handle);
 180     return $ts + 0;
 181 }
 182
 183 sub apply_throttle
 184 {
 185     my @branches = @_;
 186     return @branches unless exists $EximBuild::conf{throttle};
 187     my @result;
 188     my %throttle = %{$EximBuild::conf{throttle}};
 189
 190     # implement throttle keywords ALL !HEAD and !RECENT
 191     my @candidates;
 192     my $replacement;
 193     if (exists $throttle{ALL})
 194     {
 195         @candidates = @branches;
 196         $replacement = $throttle{ALL};
 197     }
 198     elsif (exists  $throttle{'!HEAD'})
 199     {
 200         @candidates = grep { $_ ne 'HEAD' } @branches;
 201         $replacement = $throttle{'!HEAD'};
 202     }
 203     elsif (exists  $throttle{'!RECENT'})
 204     {
 205
 206         # sort branches, make sure we get numeric major version sorting right
 207         my @stable = grep { $_ ne 'HEAD' } @branches;
 208         s/^REL(\d)_/0$1/ foreach (@stable);
 209         @stable = sort @stable;
 210         s/^REL0/REL/ foreach (@stable);
 211         pop @stable; # remove latest
 212         @candidates = @stable;
 213         $replacement = $throttle{'!RECENT'};
 214     }
 215     foreach my $cand (@candidates)
 216     {
 217
 218         # only supply this for the branch if there isn't already
 219         # a throttle
 220         $throttle{$cand} ||= $replacement;
 221     }
 222
 223     # apply throttle filters
 224     foreach my $branch(@branches)
 225     {
 226         my $this_throttle =  $throttle{$branch};
 227         unless (defined $this_throttle)
 228         {
 229             push(@result,$branch);
 230             next;
 231         }
 232         my $minh = $this_throttle->{min_hours_since};
 233         my $ts = find_last_status($branch);
 234         next
 235           if ( $ts
 236             && (defined $minh)
 237             &&($minh && $minh < ((time - $ts) / 3600.0)));
 238         if (exists $this_throttle->{allowed_hours})
 239         {
 240             my @allowed_hours = split(/,/,$this_throttle->{allowed_hours});
 241             my $hour = (localtime(time))[2];
 242             next unless grep {$_ == $hour} @allowed_hours;
 243         }
 244         push(@result,$branch);
 245     }
 246
 247     return @result;
 248 }