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