git.exim.org Git - buildfarm-client.git/blob

1 #!/usr/bin/perl

3 =comment

7 See accompanying License file for license details

9 =cut

11 use vars qw($VERSION); $VERSION = 'REL_0.1';

13 use strict;

14 use warnings;

15 use 5.010;

17 use Fcntl qw(:flock :seek);

18 use File::Basename;

19 use FindBin qw($RealBin);

20 use Cwd;

22 use lib $RealBin;

23 use EximBuild::Options;

25 sub branch_last_sort;

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 }

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;

45 my %branch_last;

46 my $run_build = './run_build';

48 my($run_all, $run_one);

49 my %extra_options =(

50 'run-all' => \$run_all,

51 'run-one' => \$run_one,

52 );

54 # process the command line

55 EximBuild::Options::fetch_options(%extra_options);

57 # no non-option args allowed here

58 die("$0: non-option arguments not permitted")

59 if @ARGV;

61 die "$0: only one of --run-all and --run-one permitted"

62 if ($run_all && $run_one);

64 die "$0: need one of --run-all and --run-one"

65 unless ($run_all || $run_one);

67 # common mistake

68 die "$0: need group searchable homedir"

69 unless (stat($ENV{HOME}) & 0550 == 0550);

71 # set up a "branch" variable for processing the config file

72 use vars qw($branch);

73 $branch = 'global';

75 #

76 # process config file

77 #

78 require $buildconf;

80 # Check if auto-update is wanted and possible

81 if (not exists $EximBuild::Conf{auto_update} or $EximBuild::Conf{auto_update})

82 {

83 my $remote = $EximBuild::Conf{auto_update} // 'origin';

85 die "$0: auto-update not possible: need write permissions in @{[cwd]}\n"

86 if not -w '.';

88 # Get information about our remote and calculate the chance for a

89 # successfull auto-updat. Based on:

90 # http://stackoverflow.com/questions/3258243/check-if-pull-needed-in-git

91 system("git fetch $remote") == 0 or die $? >> 8;

92 my ($upstream, $local, $base) = qx'git rev-parse ...@{upstream}'; die $? >> 8 if $?;

93 $base =~ s/^\^//;

95 if ($upstream ne $local) {

97 if ($base ne $local) {

98 warn "$0: the merge base is not local anymore. Refusing to `git pull`\n"

99 }

100 else {

101 # if we're the merge base, the ff-only should work

102 system 'git pull --ff-only' == 0 or die $? >> 8;

103 say "$0: re-execute after update";

104 chdir $CALLED{cwd} or die "$0: Can't chdir to $CALLED{cwd}: $!\n";

105 exec $CALLED{argv0}, @{$CALLED{argv}};

106 die "Can't re-exec\n";

107 }

108 }

109 }

110

111 unless (

112 (

113 ref $EximBuild::conf{branches_to_build} eq 'ARRAY'

114 &&@{$EximBuild::conf{branches_to_build}}

115 )

116 ||$EximBuild::conf{branches_to_build} =~

117 /^(ALL|HEAD_PLUS_LATEST|HEAD_PLUS_LATEST2)$/

118 )

119 {

120 die "no branches_to_build specified in $buildconf";

121 }

122

123 my @branches;

124 if (ref $EximBuild::conf{branches_to_build})

125 {

126 @branches = @{$EximBuild::conf{branches_to_build}};

127 }

128 elsif ($EximBuild::conf{branches_to_build} =~

129 /^(ALL|HEAD_PLUS_LATEST|HEAD_PLUS_LATEST2)$/ )

130 {

131

132 # Need to set the path here so we make sure we pick up the right perl.

133 # It has to be the perl that the build script would choose

134 # i.e. specially *not* the MinGW SDK perl that is invoked for the

135 # build script, which means we need to put the path back the way it was

136 # when we're done

137 local $ENV{PATH} = $EximBuild::conf{build_env}->{PATH}

138 if ($EximBuild::conf{build_env}->{PATH});

139 (my $url = $EximBuild::conf{target}) =~s/cgi-bin.*/branches_of_interest.txt/;

140 my $branches_of_interest = `perl -MLWP::Simple -e "getprint(q{$url})"`;

141 die "getting branches of interest" unless $branches_of_interest;

142 push(@branches,$_)foreach (split(/\s+/,$branches_of_interest));

143 #splice(@branches,0,-2)

144 # if $EximBuild::conf{branches_to_build} eq 'HEAD_PLUS_LATEST';

145 #splice(@branches,0,-3)

146 # if $EximBuild::conf{branches_to_build} eq 'HEAD_PLUS_LATEST2';

147 }

148

149 @branches = apply_throttle(@branches);

150

151 my $global_lock_dir =

152 $EximBuild::conf{global_lock_dir}

153 ||$EximBuild::conf{build_root}

154 ||'';

155

156 unless ($global_lock_dir && -d $global_lock_dir)

157 {

158 die "no global lock directory: $global_lock_dir";

159 }

160

161 # acquire the lock

162

163 my $lockfile;

164

165 my $lockfilename = "$global_lock_dir/GLOBAL.lck";

166

167 open($lockfile, ">$lockfilename") || die "opening lockfile: $!";

168

169 if ( !flock($lockfile,LOCK_EX|LOCK_NB) )

170 {

171 print "Another process holds the lock on " ."$lockfilename. Exiting.\n"

172 if ($verbose);

173 exit(0);

174 }

175

176 if ($run_all)

177 {

178 foreach my $brnch(@branches)

179 {

180 run_branch($brnch);

181 }

182 }

183 elsif ($run_one)

184 {

185

186 # sort the branches by the order in which they last did actual work

187 # then try running them in that order until one does some work

188

189 %branch_last = map {$_ => find_last_status($_)} @branches;

190 foreach my $brnch(sort branch_last_sort @branches)

191 {

192 run_branch($brnch);

193 my $new_status = find_last_status($brnch);

194 last if $new_status != $branch_last{$brnch};

195 }

196 }

197

198 exit 0;

199

200 ##########################################################

201

202 sub run_branch

203 {

204 my $branch = shift;

205 my @args = ($run_build,EximBuild::Options::standard_option_list(), $branch);

206

207 # Explicitly use perl from the path (and not this perl, so don't use $^X)

208 # This script needs to run on Cygwin with non-cygwin perl if it's running

209 # in tandem with AS/MinGW perl, since Cygwin perl doesn't honor locks

210 # the samne way, and the global lock fails. But the build script needs

211 # to run with the native perl, even on Cygwin, which it picks up from

212 # the path. (Head exploding yet?).

213 system("perl",@args);

214 }

215

216 sub branch_last_sort

217 {

218 return $branch_last{$a} <=> $branch_last{$b};

219 }

220

221 sub find_last_status

222 {

223 my $brnch = shift;

224 my $status_file =

225 "$EximBuild::conf{build_root}/$brnch/$EximBuild::conf{animal}.last.status";

226 return 0 unless (-e $status_file);

227 my $handle;

228 open($handle,$status_file) || dir $!;

229 my $ts = <$handle>;

230 chomp $ts;

231 close($handle);

232 return $ts + 0;

233 }

234

235 sub apply_throttle

236 {

237 my @branches = @_;

238 return @branches unless exists $EximBuild::conf{throttle};

239 my @result;

240 my %throttle = %{$EximBuild::conf{throttle}};

241

242 # implement throttle keywords ALL !HEAD and !RECENT

243 my @candidates;

244 my $replacement;

245 if (exists $throttle{ALL})

246 {

247 @candidates = @branches;

248 $replacement = $throttle{ALL};

249 }

250 elsif (exists $throttle{'!HEAD'})

251 {

252 @candidates = grep { $_ ne 'HEAD' } @branches;

253 $replacement = $throttle{'!HEAD'};

254 }

255 elsif (exists $throttle{'!RECENT'})

256 {

257

258 # sort branches, make sure we get numeric major version sorting right

259 my @stable = grep { $_ ne 'HEAD' } @branches;

260 s/^REL(\d)_/0$1/ foreach (@stable);

261 @stable = sort @stable;

262 s/^REL0/REL/ foreach (@stable);

263 pop @stable; # remove latest

264 @candidates = @stable;

265 $replacement = $throttle{'!RECENT'};

266 }

267 foreach my $cand (@candidates)

268 {

269

270 # only supply this for the branch if there isn't already

271 # a throttle

272 $throttle{$cand} ||= $replacement;

273 }

274

275 # apply throttle filters

276 foreach my $branch(@branches)

277 {

278 my $this_throttle = $throttle{$branch};

279 unless (defined $this_throttle)

280 {

281 push(@result,$branch);

282 next;

283 }

284 my $minh = $this_throttle->{min_hours_since};

285 my $ts = find_last_status($branch);

286 next

287 if ( $ts

288 && (defined $minh)

289 &&($minh && $minh < ((time - $ts) / 3600.0)));

290 if (exists $this_throttle->{allowed_hours})

291 {

292 my @allowed_hours = split(/,/,$this_throttle->{allowed_hours});

293 my $hour = (localtime(time))[2];

294 next unless grep {$_ == $hour} @allowed_hours;

295 }

296 push(@result,$branch);

297 }

298

299 return @result;

300 }