21 my @opt = <<'=back' =~ /B<--(\S+)>/g;
27 Makes a local copy in ramdisk, works with that perl, copies back to
28 NFS after smoking. Thus avoids to run the perl directly from NFS. The
29 perl path stays but becomes a symlink during the relocated phase.
30 Stopped working reliably between 2012-09-22 and -26 after having
31 worked well for 17 days.
35 Instead of smoking we just try to list the current potential bbcs and
40 Does not run the command, just tells what it would do.
44 Run this smoker without caring about other smokers running. Do not
45 watch other logfiles, do not suggest a compare-megalog commandline.
46 Just the smoke, maam. Usually we combine this with the --perl option.
54 Defaults to true. By setting --noreport we tell loop-over to turn
59 Path to the perl we want to smoke. Default is the most recently built
60 perl according to C<installed-perls-overview.pl>.
68 Defaults to 36000. Timeout in seconds per distro.
84 use lib
"$FindBin::Bin/../lib";
90 use File
::Basename
qw(dirname);
91 use File
::Path
qw(mkpath);
94 use File
::Rsync
::Mirror
::Recent
; # needed by loop-over-recent in this basesmoker role
96 use Hash
::Util
qw(lock_keys);
97 use List
::Util
qw(maxstr);
98 use Pod
::Usage
qw(pod2usage);
100 use Time
::HiRes
qw(sleep);
103 lock_keys
%Opt, map { /([^=|!]+)/ } @opt;
111 $Opt{ramdisk
} = 1 unless defined $Opt{ramdisk
};
113 $Opt{timeout
} = 36000 unless defined $Opt{timeout
};
114 $Opt{reporting
} //= 1;
118 $SIG{INT
} = sub { warn "\n\n****Received SIGNAL " . shift() . ", please be patient****\n\n"; $SIGNAL = 1 };
120 sub most_recent_megalog
() {
121 opendir my $dh, "." or die "Couldn't opendir .: $!";
122 my $megalog = maxstr
grep { /megalog-\d+-\d+-\d+T\d+:\d+:\d+.log$/ } readdir $dh or die "Did not find a single megalog file";
126 sub most_recent_megalog_but
($) {
128 opendir my $dh, "." or die "Couldn't opendir .: $!";
129 return maxstr
grep { /megalog-\d+-\d+-\d+T\d+:\d+:\d+.log$/ && $_ lt $limit } readdir $dh;
132 sub counting_sleep
($) {
134 my $eta = time+$sleep;
137 my $left = $eta - time;
139 printf "\rSleeping %d: %d ", $sleep, $left;
146 sub other_smoker_running
($) {
148 my $size0 = -s
$file;
149 for my $i (0..9) { # arbitrary
150 my $sleep = 6; # arbitrary
152 my $size1 = -s
$file;
153 die "Something's wrong, most recent megalog has only 0 bytes" if $size0==0 && $size1==0;
154 return 1 if $size1 > $size0;
159 sub dot_d_needs_work
($) {
160 my $megalogfile = shift;
161 my $megalogdir = $megalogfile;
162 $megalogdir =~ s/\.log/.d/;
163 # look into the dir whether it is newer for all
164 return 1 unless -e
$megalogdir;
165 opendir my $dh, $megalogdir or die "Could not open '$megalogdir': $!";
166 my @stat_file = stat $megalogfile;
167 for my $dirent (readdir $dh) {
168 next if $dirent =~ /^\./;
169 my $path = "$megalogdir/$dirent";
170 my @stat_path = stat $path;
171 return 1 if $stat_path[9] < $stat_file[9];
176 sub most_recent_perl
() {
177 open my $fh, "-|", $^X
, "$FindBin::Bin/installed-perls-overview.pl", "--max=1";
179 OVLINE
: while (<$fh>) {
180 my($perl) = split " ", $_, 2;
181 die "ALERT: Found directory of a hidden-locked smoker: '$perl'. We try smoking twice???" if $perl =~ /hilo/; # placeholder of a running smoker (hidden locked)
182 my $hostname = Sys
::Hostname
::hostname
;
183 $hostname =~ s/\..*//;
185 if ($hostname eq "k83") {
186 die "Panic: as far as I understood we do not want to run smokers on k83 anymore???";
187 $perl_or_host = "perl";
189 $perl_or_host = "host/$hostname";
191 # Can't exec "/home/sand/src/perl/repoperls/installed-perls/perl/v5.23.7-35-g6002757/3bd2/bin/perl": No such...
192 $absperl = sprintf "/home/sand/src/perl/repoperls/installed-perls/%s/%s/bin/perl", $perl_or_host, $perl;
195 close $fh; # breaking a pipe?
199 sub megalog_contains_perl
($$) {
202 open my $fh, '<', $file or die "Could not open '$file': $!";
211 sub suggest_cmp_megalogdir
($) {
212 my($megalogfile) = @_;
213 my $secondmegalogfile = most_recent_megalog_but
($megalogfile);
214 if (dot_d_needs_work
($secondmegalogfile)) {
215 warn "Note: second newest logfile '$secondmegalogfile' has no .d counterpart\n";
216 # cannot make a suggestion, code below would die
219 my @mdir = map { s/\.log$/.d/r } $secondmegalogfile, $megalogfile;
221 while ( substr($mdir[0],length($pairglob),1)
222 eq substr($mdir[1],length($pairglob),1) ) {
223 $pairglob .= substr($mdir[0],length($pairglob),1);
225 my $pairgloblength = length $pairglob;
228 my @dates = map { substr($_,$pairgloblength,$i) } @mdir;
229 my $dates = join ",", @dates;
230 my $glob = "$pairglob\{$dates\}*.d";
235 } elsif ($i > length($dates[0])) {
236 die sprintf "globbing on '%s' yields '%s', not trying any longer", $glob, join(",",@g);
240 my $system = "perl ~/src/andk/andk-cpan-tools/bin/compare-megalogdirs.pl --annofile ~/src/andk/andk-cpan-tools/annotate.txt --skipanno --bbc $pairglob";
241 warn "====> MAYBE you want to run '$system'\n";
245 sub make_a_dot_d
($) {
246 my($megalogfile) = @_;
250 "$FindBin::Bin/colorout-to-dir-3.pl",
254 die "no success running system[@system]" unless 0 == system @system;
257 sub squirrel_away
($) {
258 my($perl) = @_; # /mnt/k75/homesand/src/perl/repoperls/installed-perls/perl/v5.16.0/127e/bin/perl
259 my $original_torelocate_perl = dirname dirname
$perl; # OP
260 die "Could not make directory .lock in '$original_torelocate_perl': $!"
261 unless mkdir "$original_torelocate_perl/.lock";
263 my $intempdir_relocated_perl =
264 File
::Temp
::tempdir
("basesmoker-reloperl-XXXX", DIR
=> "/tmp"); # RP
265 warn sprintf "About to rsync I perl to /tmp at %s\n", scalar(localtime);
266 0 == system rsync
=> "-ax", "$original_torelocate_perl/", "$intempdir_relocated_perl/"
267 or die "error while trying to (early) rsync"; # LP => RP
268 my $hidden_locked_perl = ""; # LP
269 while (!$hidden_locked_perl) {
270 my $trynum = int rand 10000;
271 my $trydir = File
::Spec
->catdir(dirname
($original_torelocate_perl), "hilo$trynum");
272 if (rename $original_torelocate_perl, $trydir) {
273 warn sprintf "WARNING[%s]: perl[%s] now hidden,unaccessible\n",
274 scalar localtime, $original_torelocate_perl;
275 $hidden_locked_perl = $trydir;
277 die "too many tries failed, last one was with OP[$original_torelocate_perl]trydir[$trydir]\$![$!], giving up" if ++$cnt > 100;
281 warn sprintf "About to rsync II perl to /tmp at %s\n", scalar(localtime);
282 0 == system rsync
=> "-ax", "$hidden_locked_perl/", "$intempdir_relocated_perl/"
283 or die "error while trying to (final)rsync"; # LP => RP
284 symlink $intempdir_relocated_perl, $original_torelocate_perl; # RP => OP
285 warn sprintf "WARNING[%s]: perl[%s] now accessible again (relocated)\n",
286 scalar localtime, $original_torelocate_perl;
289 original_torelocate_perl
=> $original_torelocate_perl,
290 hidden_locked_perl
=> $hidden_locked_perl,
291 intempdir_relocated_perl
=> $intempdir_relocated_perl,
295 sub squirrel_back
($) {
297 my($original_torelocate_perl,$hidden_locked_perl,$intempdir_relocated_perl) =
298 @
{$handle}{"original_torelocate_perl","hidden_locked_perl","intempdir_relocated_perl"};
299 warn sprintf "About to rsync I perl back from %s/ -> %s/ at %s\n",
300 $intempdir_relocated_perl, $hidden_locked_perl, scalar(localtime);
301 0 == system rsync
=> "-ax", "--omit-dir-times", "--no-inc-recursive", "$intempdir_relocated_perl/", "$hidden_locked_perl/"
302 or die "error while trying to (first)rsync back";
303 unlink $original_torelocate_perl
304 or die "Could not unlink '$original_torelocate_perl': $!"; # OP
305 warn sprintf "WARNING[%s]: perl[%s] now hidden,unaccessible\n",
306 scalar localtime, $original_torelocate_perl;
307 warn sprintf "About to rsync II perl back from /tmp at %s\n", scalar(localtime);
308 0 == system rsync
=> "-ax", "$intempdir_relocated_perl/", "$hidden_locked_perl/"
309 or die "error while trying to (first)rsync back";
310 rename $hidden_locked_perl, $original_torelocate_perl
311 or die "Could not rename back: $!"; # LP => OP
312 warn sprintf "WARNING[%s]: perl[%s] now accessible (moved back)\n",
313 scalar localtime, $original_torelocate_perl;
314 rmdir "$original_torelocate_perl/.lock" or die "Could not rmdir: $!";
315 File
::Path
::remove_tree
($intempdir_relocated_perl, { safe
=> 0 });
318 # check whether this perl is completed; we do not want to
319 # smoke when generate_recent is still running;
320 sub has_test_reporter_transport_metabase
{
323 $mib =~ s
|perl
$|module_info
|;
325 if (0==system($mib,"Test::Reporter::Transport::Metabase")) {
328 } elsif (! -e
$perl) {
329 warn "Warning: perl '$perl' not found";
331 } elsif (0==system($perl,"-MV=Test::Reporter::Transport::Metabase")) {
341 $megalogfile = most_recent_megalog
();
343 if ($Opt{bbccheck
}) {
344 make_a_dot_d
($megalogfile);
345 my $system = suggest_cmp_megalogdir
($megalogfile);
346 warn "Running that now";
348 } elsif (!$Opt{extra
} && other_smoker_running
($megalogfile)) {
349 warn "Info: other smoker '$megalogfile' is running" if $Opt{verbose
};
350 counting_sleep
1800; # arbitrary
352 my $perl = $Opt{perl
} || most_recent_perl
();
354 if (dot_d_needs_work
($megalogfile)) {
355 make_a_dot_d
($megalogfile);
357 suggest_cmp_megalogdir
($megalogfile);
358 if (megalog_contains_perl
($megalogfile,$perl)) {
360 warn "Nothing to smoke, newest perl '$perl' already smoked";
362 counting_sleep
1200; # arbitrary: if too short we
363 # write the console too full; I'd
364 # like to have a watcher for a
365 # new perl here such that we exit
366 # as soon as a new perl shows up
370 my $date = `date +%FT%T`;
373 if (! $Opt{reporting
}) {
374 push @more, "--config_test_report=0";
378 map { />/ ?
$_ : "\"$_\"" } # quote all arguments except redirects
382 "$ENV{HOME}/src/andk/rersyncrecent/lib",
383 "$ENV{HOME}/src/andk/andk-cpan-tools/bin/loop-over-recent.pl",
385 "--transient_build_dir",
387 "--timeout=$Opt{timeout}",
393 if ($Opt{"dry-run"}) {
394 warn "Would run system[$system]";
397 warn "About to run '$system'\n";
399 while ($Opt{report
} and !has_test_reporter_transport_metabase
($perl)) {
400 warn "Waiting for 'Test::Reporter::Transport::Metabase' for perl '$perl' installed\n";
401 counting_sleep
180; # arbitrary
406 $rphandle = squirrel_away
($perl); # relocated perl handle
409 unless (0 == system $system){
410 warn "no success running system[$system], check content of 'megalog-$date.log'";
415 warn "Trying to squirrel perl[$perl] back";
416 } elsif ($Opt{ramdisk
}) {
417 warn "Ouch, we probably just lost a perl[$perl]";
419 warn "it seems we received a signal while perl is '$perl'";
423 squirrel_back
($rphandle) if $rphandle;
425 warn "Alert: exit code[$exitcode]";
434 # cperl-indent-level: 4