run_branches

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