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 # Check if auto-update is wanted and possible
  76 if (not exists $EximBuild::Conf{auto_update} or $EximBuild::Conf{auto_update})
  77 {
  78     die "$0: auto-update not possible: need write permissions in @{[cwd]}\n"
  79         if not -w '.';
  80     # http://stackoverflow.com/questions/3258243/check-if-pull-needed-in-git
  81     system('git remote update') == 0 or die $? >> 8;
  82     my ($upstream, $local, $base) = qx'git rev-parse ...@{upstream}';   die $? >> 8 if $?;
  83     $base =~ s/^\^//;
  84
  85     if ($upstream ne $local) {
  86         die "$0: the merge base is not local anymore. Refusing to `git pull`\n"
  87             if $base ne $local;
  88
  89         # if we're the merge base, the ff-only should workkkkkk
  90         system 'git pull --ff-only'
  91     }
  92 }
  93
  94 unless (
  95     (
  96         ref $EximBuild::conf{branches_to_build} eq 'ARRAY'
  97         &&@{$EximBuild::conf{branches_to_build}}
  98     )
  99     ||$EximBuild::conf{branches_to_build} =~
 100     /^(ALL|HEAD_PLUS_LATEST|HEAD_PLUS_LATEST2)$/
 101   )
 102 {
 103     die "no branches_to_build specified in $buildconf";
 104 }
 105
 106 my @branches;
 107 if (ref $EximBuild::conf{branches_to_build})
 108 {
 109     @branches = @{$EximBuild::conf{branches_to_build}};
 110 }
 111 elsif ($EximBuild::conf{branches_to_build} =~
 112     /^(ALL|HEAD_PLUS_LATEST|HEAD_PLUS_LATEST2)$/ )
 113 {
 114
 115     # Need to set the path here so we make sure we pick up the right perl.
 116     # It has to be the perl that the build script would choose
 117     # i.e. specially *not* the MinGW SDK perl that is invoked for the
 118     # build script, which means we need to put the path back the way it was
 119     # when we're done
 120     local $ENV{PATH} = $EximBuild::conf{build_env}->{PATH}
 121       if ($EximBuild::conf{build_env}->{PATH});
 122     (my $url = $EximBuild::conf{target}) =~s/cgi-bin.*/branches_of_interest.txt/;
 123     my $branches_of_interest = `perl -MLWP::Simple -e "getprint(q{$url})"`;
 124     die "getting branches of interest" unless $branches_of_interest;
 125     push(@branches,$_)foreach (split(/\s+/,$branches_of_interest));
 126     #splice(@branches,0,-2)
 127     #  if $EximBuild::conf{branches_to_build} eq 'HEAD_PLUS_LATEST';
 128     #splice(@branches,0,-3)
 129     #  if $EximBuild::conf{branches_to_build} eq 'HEAD_PLUS_LATEST2';
 130 }
 131
 132 @branches = apply_throttle(@branches);
 133
 134 my $global_lock_dir =
 135     $EximBuild::conf{global_lock_dir}
 136   ||$EximBuild::conf{build_root}
 137   ||'';
 138
 139 unless ($global_lock_dir && -d $global_lock_dir)
 140 {
 141     die "no global lock directory: $global_lock_dir";
 142 }
 143
 144 # acquire the lock
 145
 146 my $lockfile;
 147
 148 my $lockfilename = "$global_lock_dir/GLOBAL.lck";
 149
 150 open($lockfile, ">$lockfilename") || die "opening lockfile: $!";
 151
 152 if ( !flock($lockfile,LOCK_EX|LOCK_NB) )
 153 {
 154     print "Another process holds the lock on " ."$lockfilename. Exiting.\n"
 155       if ($verbose);
 156     exit(0);
 157 }
 158
 159 if ($run_all)
 160 {
 161     foreach my $brnch(@branches)
 162     {
 163         run_branch($brnch);
 164     }
 165 }
 166 elsif ($run_one)
 167 {
 168
 169     # sort the branches by the order in which they last did actual work
 170     # then try running them in that order until one does some work
 171
 172     %branch_last = map {$_ => find_last_status($_)} @branches;
 173     foreach my $brnch(sort branch_last_sort @branches)
 174     {
 175         run_branch($brnch);
 176         my $new_status = find_last_status($brnch);
 177         last if $new_status != $branch_last{$brnch};
 178     }
 179 }
 180
 181 exit 0;
 182
 183 ##########################################################
 184
 185 sub run_branch
 186 {
 187     my $branch = shift;
 188     my @args = ($run_build,EximBuild::Options::standard_option_list(), $branch);
 189
 190     # Explicitly use perl from the path (and not this perl, so don't use $^X)
 191     # This script needs to run on Cygwin with non-cygwin perl if it's running
 192     # in tandem with AS/MinGW perl, since Cygwin perl doesn't honor locks
 193     # the samne way, and the global lock fails. But the build script needs
 194     # to run with the native perl, even on Cygwin, which it picks up from
 195     # the path. (Head exploding yet?).
 196     system("perl",@args);
 197 }
 198
 199 sub branch_last_sort
 200 {
 201     return $branch_last{$a} <=> $branch_last{$b};
 202 }
 203
 204 sub find_last_status
 205 {
 206     my $brnch = shift;
 207     my $status_file =
 208       "$EximBuild::conf{build_root}/$brnch/$EximBuild::conf{animal}.last.status";
 209     return 0 unless (-e  $status_file);
 210     my $handle;
 211     open($handle,$status_file) || dir $!;
 212     my $ts = <$handle>;
 213     chomp $ts;
 214     close($handle);
 215     return $ts + 0;
 216 }
 217
 218 sub apply_throttle
 219 {
 220     my @branches = @_;
 221     return @branches unless exists $EximBuild::conf{throttle};
 222     my @result;
 223     my %throttle = %{$EximBuild::conf{throttle}};
 224
 225     # implement throttle keywords ALL !HEAD and !RECENT
 226     my @candidates;
 227     my $replacement;
 228     if (exists $throttle{ALL})
 229     {
 230         @candidates = @branches;
 231         $replacement = $throttle{ALL};
 232     }
 233     elsif (exists  $throttle{'!HEAD'})
 234     {
 235         @candidates = grep { $_ ne 'HEAD' } @branches;
 236         $replacement = $throttle{'!HEAD'};
 237     }
 238     elsif (exists  $throttle{'!RECENT'})
 239     {
 240
 241         # sort branches, make sure we get numeric major version sorting right
 242         my @stable = grep { $_ ne 'HEAD' } @branches;
 243         s/^REL(\d)_/0$1/ foreach (@stable);
 244         @stable = sort @stable;
 245         s/^REL0/REL/ foreach (@stable);
 246         pop @stable; # remove latest
 247         @candidates = @stable;
 248         $replacement = $throttle{'!RECENT'};
 249     }
 250     foreach my $cand (@candidates)
 251     {
 252
 253         # only supply this for the branch if there isn't already
 254         # a throttle
 255         $throttle{$cand} ||= $replacement;
 256     }
 257
 258     # apply throttle filters
 259     foreach my $branch(@branches)
 260     {
 261         my $this_throttle =  $throttle{$branch};
 262         unless (defined $this_throttle)
 263         {
 264             push(@result,$branch);
 265             next;
 266         }
 267         my $minh = $this_throttle->{min_hours_since};
 268         my $ts = find_last_status($branch);
 269         next
 270           if ( $ts
 271             && (defined $minh)
 272             &&($minh && $minh < ((time - $ts) / 3600.0)));
 273         if (exists $this_throttle->{allowed_hours})
 274         {
 275             my @allowed_hours = split(/,/,$this_throttle->{allowed_hours});
 276             my $hour = (localtime(time))[2];
 277             next unless grep {$_ == $hour} @allowed_hours;
 278         }
 279         push(@result,$branch);
 280     }
 281
 282     return @result;
 283 }