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