Add debugging aid for failed git checkout
[buildfarm-client.git] / 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-update. 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 = $EximBuild::conf{global_lock_dir}
163   // $EximBuild::conf{build_root}
164   // die "$0: need global_lock_dir\n";
165
166 die "$0: need r/w permissions for directory '$global_lock_dir'\n"
167     if not -d -w $global_lock_dir;
168
169 # acquire the lock
170
171 my $lockfile;
172
173 my $lockfilename = "$global_lock_dir/GLOBAL.lck";
174
175 open($lockfile, ">$lockfilename") || die "opening lockfile: $!";
176
177 if ( !flock($lockfile,LOCK_EX|LOCK_NB) )
178 {
179     print "Another process holds the lock on " ."$lockfilename. Exiting.\n"
180       if ($verbose);
181     exit(0);
182 }
183
184 if ($run_all)
185 {
186     foreach my $brnch(@branches)
187     {
188         run_branch($brnch);
189     }
190 }
191 elsif ($run_one)
192 {
193
194     # sort the branches by the order in which they last did actual work
195     # then try running them in that order until one does some work
196
197     %branch_last = map {$_ => find_last_status($_)} @branches;
198     foreach my $brnch(sort branch_last_sort @branches)
199     {
200         run_branch($brnch);
201         my $new_status = find_last_status($brnch);
202         last if $new_status != $branch_last{$brnch};
203     }
204 }
205
206 exit 0;
207
208 ##########################################################
209
210 sub run_branch
211 {
212     my $branch = shift;
213     my @args = ($run_build,EximBuild::Options::standard_option_list(), $branch);
214
215     # Explicitly use perl from the path (and not this perl, so don't use $^X)
216     # This script needs to run on Cygwin with non-cygwin perl if it's running
217     # in tandem with AS/MinGW perl, since Cygwin perl doesn't honor locks
218     # the same way, and the global lock fails. But the build script needs
219     # to run with the native perl, even on Cygwin, which it picks up from
220     # the path. (Head exploding yet?).
221     system(perl => @args);
222 }
223
224 sub branch_last_sort
225 {
226     return $branch_last{$a} <=> $branch_last{$b};
227 }
228
229 sub find_last_status
230 {
231     my $brnch = shift;
232     my $status_file =
233       "$EximBuild::conf{build_root}/$brnch/$EximBuild::conf{animal}.last.status";
234     return 0 unless (-e  $status_file);
235     my $handle;
236     open($handle,$status_file) || dir $!;
237     my $ts = <$handle>;
238     chomp $ts;
239     close($handle);
240     return $ts + 0;
241 }
242
243 sub apply_throttle
244 {
245     my @branches = @_;
246     return @branches unless exists $EximBuild::conf{throttle};
247     my @result;
248     my %throttle = %{$EximBuild::conf{throttle}};
249
250     # implement throttle keywords ALL !HEAD and !RECENT
251     my @candidates;
252     my $replacement;
253     if (exists $throttle{ALL})
254     {
255         @candidates = @branches;
256         $replacement = $throttle{ALL};
257     }
258     elsif (exists  $throttle{'!HEAD'})
259     {
260         @candidates = grep { $_ ne 'HEAD' } @branches;
261         $replacement = $throttle{'!HEAD'};
262     }
263     elsif (exists  $throttle{'!RECENT'})
264     {
265
266         # sort branches, make sure we get numeric major version sorting right
267         my @stable = grep { $_ ne 'HEAD' } @branches;
268         s/^REL(\d)_/0$1/ foreach (@stable);
269         @stable = sort @stable;
270         s/^REL0/REL/ foreach (@stable);
271         pop @stable; # remove latest
272         @candidates = @stable;
273         $replacement = $throttle{'!RECENT'};
274     }
275     foreach my $cand (@candidates)
276     {
277
278         # only supply this for the branch if there isn't already
279         # a throttle
280         $throttle{$cand} ||= $replacement;
281     }
282
283     # apply throttle filters
284     foreach my $branch(@branches)
285     {
286         my $this_throttle =  $throttle{$branch};
287         unless (defined $this_throttle)
288         {
289             push(@result,$branch);
290             next;
291         }
292         my $minh = $this_throttle->{min_hours_since};
293         my $ts = find_last_status($branch);
294         next
295           if ( $ts
296             && (defined $minh)
297             &&($minh && $minh < ((time - $ts) / 3600.0)));
298         if (exists $this_throttle->{allowed_hours})
299         {
300             my @allowed_hours = split(/,/,$this_throttle->{allowed_hours});
301             my $hour = (localtime(time))[2];
302             next unless grep {$_ == $hour} @allowed_hours;
303         }
304         push(@result,$branch);
305     }
306
307     return @result;
308 }