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