run_branches

   1 #!/usr/bin/env 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 my %CALLED = (
  38     cwd => cwd(),
  39     argv0 => $0,
  40     argv => [@ARGV],    # get a copy!
  41 );
  42 chdir $RealBin or die "$0: Can't chdir to '$RealBin': $!\n";
  43 say "Changed working directory to '$RealBin'" if -t;
  44
  45 my %branch_last;
  46 my $run_build = './run_build';
  47
  48 my($run_all, $run_one);
  49 my %extra_options =(
  50     'run-all' => \$run_all,
  51     'run-one' => \$run_one,
  52 );
  53
  54 # process the command line
  55 EximBuild::Options::fetch_options(%extra_options);
  56
  57 # no non-option args allowed here
  58 die("$0: non-option arguments not permitted")
  59   if @ARGV;
  60
  61 die "$0: only one of --run-all and --run-one permitted"
  62   if ($run_all && $run_one);
  63
  64 die "$0: need one of --run-all and --run-one"
  65   unless ($run_all || $run_one);
  66
  67 # common mistake
  68 die "$0: need group searchable homedir"
  69   unless (stat($ENV{HOME}) & 0550 == 0550);
  70
  71 # set up a "branch" variable for processing the config file
  72 use vars qw($branch);
  73 $branch = 'global';
  74
  75 #
  76 # process config file
  77 #
  78 require $buildconf;
  79
  80 # Check if auto-update is wanted and possible
  81 eval {
  82     if (not exists $EximBuild::Conf{auto_update} or $EximBuild::Conf{auto_update})
  83     {
  84         my $remote = $EximBuild::Conf{auto_update} // 'origin';
  85
  86         die "auto-update not possible: need write permissions in @{[cwd]}\n"
  87             if not -w '.';
  88
  89         # Get information about our remote and calculate the chance for a
  90         # successfull auto-updat. Based on:
  91         # http://stackoverflow.com/questions/3258243/check-if-pull-needed-in-git
  92         system("git fetch $remote") == 0 or die "'git fetch $remote' failed\n";
  93         my ($upstream, $local, $base) = qx'git rev-parse ...@{upstream}' or die "'git rev-parse' failed\n";
  94
  95         $base =~ s/^\^//;
  96
  97         if ($upstream ne $local) {
  98
  99             if ($base ne $local) {
 100                 die "the merge base is not local anymore. Refusing to `git pull`\n"
 101             }
 102
 103             # if we're the merge base, the ff-only should work
 104             # except if there are local changes. We won't stop, if we
 105             # fail to update, but we'll issue a warning
 106             system("git pull --ff-only $remote") == 0 or die "git pull --ff-only\n";
 107
 108             say "re-execute after update";
 109             chdir $CALLED{cwd} or die "Can't chdir to $CALLED{cwd}: $!\n";
 110             exec $CALLED{argv0}, @{$CALLED{argv}};
 111             die "Can't re-exec\n";
 112         }
 113     }
 114 };
 115
 116 if ($@) {
 117     chomp $@;
 118     warn "Automatic updated failed with `$@'\n"
 119         ."Continue anyway\n";
 120 }
 121
 122 unless (
 123     (
 124         ref $EximBuild::conf{branches_to_build} eq 'ARRAY'
 125         &&@{$EximBuild::conf{branches_to_build}}
 126     )
 127     ||$EximBuild::conf{branches_to_build} =~
 128     /^(ALL|HEAD_PLUS_LATEST|HEAD_PLUS_LATEST2)$/
 129   )
 130 {
 131     die "no branches_to_build specified in $buildconf";
 132 }
 133
 134 my @branches;
 135 if (ref $EximBuild::conf{branches_to_build})
 136 {
 137     @branches = @{$EximBuild::conf{branches_to_build}};
 138 }
 139 elsif ($EximBuild::conf{branches_to_build} =~
 140     /^(ALL|HEAD_PLUS_LATEST|HEAD_PLUS_LATEST2)$/ )
 141 {
 142
 143     # Need to set the path here so we make sure we pick up the right perl.
 144     # It has to be the perl that the build script would choose
 145     # i.e. specially *not* the MinGW SDK perl that is invoked for the
 146     # build script, which means we need to put the path back the way it was
 147     # when we're done
 148     local $ENV{PATH} = $EximBuild::conf{build_env}->{PATH}
 149       if ($EximBuild::conf{build_env}->{PATH});
 150     (my $url = $EximBuild::conf{target}) =~s/cgi-bin.*/branches_of_interest.txt/;
 151     my $branches_of_interest = `perl -MLWP::Simple -e "getprint(q{$url})"`;
 152     die "getting branches of interest" unless $branches_of_interest;
 153     push(@branches,$_)foreach (split(/\s+/,$branches_of_interest));
 154     #splice(@branches,0,-2)
 155     #  if $EximBuild::conf{branches_to_build} eq 'HEAD_PLUS_LATEST';
 156     #splice(@branches,0,-3)
 157     #  if $EximBuild::conf{branches_to_build} eq 'HEAD_PLUS_LATEST2';
 158 }
 159
 160 @branches = apply_throttle(@branches);
 161
 162 my $global_lock_dir =
 163     $EximBuild::conf{global_lock_dir}
 164   ||$EximBuild::conf{build_root}
 165   ||'';
 166
 167 unless ($global_lock_dir && -d $global_lock_dir)
 168 {
 169     die "no global lock directory: $global_lock_dir";
 170 }
 171
 172 # acquire the lock
 173
 174 my $lockfile;
 175
 176 my $lockfilename = "$global_lock_dir/GLOBAL.lck";
 177
 178 open($lockfile, ">$lockfilename") || die "opening lockfile: $!";
 179
 180 if ( !flock($lockfile,LOCK_EX|LOCK_NB) )
 181 {
 182     print "Another process holds the lock on " ."$lockfilename. Exiting.\n"
 183       if ($verbose);
 184     exit(0);
 185 }
 186
 187 if ($run_all)
 188 {
 189     foreach my $brnch(@branches)
 190     {
 191         run_branch($brnch);
 192     }
 193 }
 194 elsif ($run_one)
 195 {
 196
 197     # sort the branches by the order in which they last did actual work
 198     # then try running them in that order until one does some work
 199
 200     %branch_last = map {$_ => find_last_status($_)} @branches;
 201     foreach my $brnch(sort branch_last_sort @branches)
 202     {
 203         run_branch($brnch);
 204         my $new_status = find_last_status($brnch);
 205         last if $new_status != $branch_last{$brnch};
 206     }
 207 }
 208
 209 exit 0;
 210
 211 ##########################################################
 212
 213 sub run_branch
 214 {
 215     my $branch = shift;
 216     my @args = ($run_build,EximBuild::Options::standard_option_list(), $branch);
 217
 218     # Explicitly use perl from the path (and not this perl, so don't use $^X)
 219     # This script needs to run on Cygwin with non-cygwin perl if it's running
 220     # in tandem with AS/MinGW perl, since Cygwin perl doesn't honor locks
 221     # the samne way, and the global lock fails. But the build script needs
 222     # to run with the native perl, even on Cygwin, which it picks up from
 223     # the path. (Head exploding yet?).
 224     system("perl",@args);
 225 }
 226
 227 sub branch_last_sort
 228 {
 229     return $branch_last{$a} <=> $branch_last{$b};
 230 }
 231
 232 sub find_last_status
 233 {
 234     my $brnch = shift;
 235     my $status_file =
 236       "$EximBuild::conf{build_root}/$brnch/$EximBuild::conf{animal}.last.status";
 237     return 0 unless (-e  $status_file);
 238     my $handle;
 239     open($handle,$status_file) || dir $!;
 240     my $ts = <$handle>;
 241     chomp $ts;
 242     close($handle);
 243     return $ts + 0;
 244 }
 245
 246 sub apply_throttle
 247 {
 248     my @branches = @_;
 249     return @branches unless exists $EximBuild::conf{throttle};
 250     my @result;
 251     my %throttle = %{$EximBuild::conf{throttle}};
 252
 253     # implement throttle keywords ALL !HEAD and !RECENT
 254     my @candidates;
 255     my $replacement;
 256     if (exists $throttle{ALL})
 257     {
 258         @candidates = @branches;
 259         $replacement = $throttle{ALL};
 260     }
 261     elsif (exists  $throttle{'!HEAD'})
 262     {
 263         @candidates = grep { $_ ne 'HEAD' } @branches;
 264         $replacement = $throttle{'!HEAD'};
 265     }
 266     elsif (exists  $throttle{'!RECENT'})
 267     {
 268
 269         # sort branches, make sure we get numeric major version sorting right
 270         my @stable = grep { $_ ne 'HEAD' } @branches;
 271         s/^REL(\d)_/0$1/ foreach (@stable);
 272         @stable = sort @stable;
 273         s/^REL0/REL/ foreach (@stable);
 274         pop @stable; # remove latest
 275         @candidates = @stable;
 276         $replacement = $throttle{'!RECENT'};
 277     }
 278     foreach my $cand (@candidates)
 279     {
 280
 281         # only supply this for the branch if there isn't already
 282         # a throttle
 283         $throttle{$cand} ||= $replacement;
 284     }
 285
 286     # apply throttle filters
 287     foreach my $branch(@branches)
 288     {
 289         my $this_throttle =  $throttle{$branch};
 290         unless (defined $this_throttle)
 291         {
 292             push(@result,$branch);
 293             next;
 294         }
 295         my $minh = $this_throttle->{min_hours_since};
 296         my $ts = find_last_status($branch);
 297         next
 298           if ( $ts
 299             && (defined $minh)
 300             &&($minh && $minh < ((time - $ts) / 3600.0)));
 301         if (exists $this_throttle->{allowed_hours})
 302         {
 303             my @allowed_hours = split(/,/,$this_throttle->{allowed_hours});
 304             my $hour = (localtime(time))[2];
 305             next unless grep {$_ == $hour} @allowed_hours;
 306         }
 307         push(@result,$branch);
 308     }
 309
 310     return @result;
 311 }