bin/basesmoker.pl

   1 #!/usr/bin/perl
   2
   3 # use 5.010;
   4 use strict;
   5 use warnings;
   6
   7 =head1 NAME
   8
   9
  10
  11 =head1 SYNOPSIS
  12
  13
  14
  15 =head1 OPTIONS
  16
  17 =over 8
  18
  19 =cut
  20
  21 my @opt = <<'=back' =~ /B<--(\S+)>/g;
  22
  23 =item B<--ramdisk!>
  24
  25 Defaults to true.
  26
  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.
  32
  33 =item B<--bbccheck!>
  34
  35 Instead of smoking we just try to list the current potential bbcs and
  36 exit.
  37
  38 =item B<--dry-run|n!>
  39
  40 Does not run the command, just tells what it would do.
  41
  42 =item B<--extra>
  43
  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.
  47
  48 =item B<--help|h!>
  49
  50 This help
  51
  52 =item B<--reporting!>
  53
  54 Defaults to true. By setting --noreport we tell loop-over to turn
  55 reporting off.
  56
  57 =item B<--perl=s>
  58
  59 Path to the perl we want to smoke. Default is the most recently built
  60 perl according to C<installed-perls-overview.pl>.
  61
  62 =item B<--report!>
  63
  64 Defaults to true.
  65
  66 =item B<--timeout=f>
  67
  68 Defaults to 36000. Timeout in seconds per distro.
  69
  70 =item B<--verbose|v!>
  71
  72 Verbose!
  73
  74 =back
  75
  76 =head1 DESCRIPTION
  77
  78
  79
  80 =cut
  81
  82
  83 use FindBin;
  84 use lib "$FindBin::Bin/../lib";
  85 BEGIN {
  86     push @INC, qw(       );
  87 }
  88
  89 use Dumpvalue;
  90 use File::Basename qw(dirname);
  91 use File::Path qw(mkpath);
  92 use File::Spec;
  93 use File::Temp;
  94 use File::Rsync::Mirror::Recent; # needed by loop-over-recent in this basesmoker role
  95 use Getopt::Long;
  96 use Hash::Util qw(lock_keys);
  97 use List::Util qw(maxstr);
  98 use Pod::Usage qw(pod2usage);
  99 use Sys::Hostname ();
 100 use Time::HiRes qw(sleep);
 101
 102 our %Opt;
 103 lock_keys %Opt, map { /([^=|!]+)/ } @opt;
 104 GetOptions(\%Opt,
 105            @opt,
 106           ) or pod2usage(1);
 107 if ($Opt{help}) {
 108     pod2usage(0);
 109 }
 110 $Opt{extra} ||= 0;
 111 $Opt{ramdisk} = 1 unless defined $Opt{ramdisk};
 112 $Opt{report} //= 1;
 113 $Opt{timeout} = 36000 unless defined $Opt{timeout};
 114 $Opt{reporting} //= 1;
 115
 116 our $SIGNAL = 0;
 117
 118 $SIG{INT} = sub { warn "\n\n****Received SIGNAL " . shift() . ", please be patient****\n\n"; $SIGNAL = 1 };
 119
 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";
 123     return $megalog;
 124 }
 125
 126 sub most_recent_megalog_but ($) {
 127     my($limit) = @_;
 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;
 130 }
 131
 132 sub counting_sleep ($) {
 133     my $sleep = shift;
 134     my $eta = time+$sleep;
 135     local($|)=1;
 136     while () {
 137         my $left = $eta - time;
 138         last if $left < 0;
 139         printf "\rSleeping %d: %d    ", $sleep, $left;
 140         sleep 1;
 141         last if $SIGNAL;
 142     }
 143     print "\n";
 144 }
 145
 146 sub other_smoker_running ($) {
 147     my $file = shift;
 148     my $size0 = -s $file;
 149     for my $i (0..9) { # arbitrary
 150         my $sleep = 6; # arbitrary
 151         sleep $sleep;
 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;
 155     }
 156     return;
 157 }
 158
 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];
 172     }
 173     return 0;
 174 }
 175
 176 sub most_recent_perl () {
 177     open my $fh, "-|", $^X, "$FindBin::Bin/installed-perls-overview.pl", "--max=1";
 178     my $absperl;
 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/\..*//;
 184         my $perl_or_host;
 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";
 188         } else {
 189             $perl_or_host = "host/$hostname";
 190         }
 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;
 193         last OVLINE;
 194     }
 195     close $fh; # breaking a pipe?
 196     return $absperl;
 197 }
 198
 199 sub megalog_contains_perl ($$) {
 200     my $file = shift;
 201     my $perl = shift;
 202     open my $fh, '<', $file or die "Could not open '$file': $!";
 203     while (<$fh>) {
 204         if (/\Q$perl\E/) {
 205             return 1;
 206         }
 207     }
 208     return 0;
 209 }
 210
 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
 217         return;
 218     }
 219     my @mdir = map { s/\.log$/.d/r } $secondmegalogfile, $megalogfile;
 220     my $pairglob = "";
 221     while (    substr($mdir[0],length($pairglob),1)
 222                eq substr($mdir[1],length($pairglob),1) ) {
 223         $pairglob .= substr($mdir[0],length($pairglob),1);
 224     }
 225     my $pairgloblength = length $pairglob;
 226     my $i = 0;
 227     while () {
 228         my @dates = map { substr($_,$pairgloblength,$i) } @mdir;
 229         my $dates = join ",", @dates;
 230         my $glob = "$pairglob\{$dates\}*.d";
 231         my @g = glob $glob;
 232         if (@g == 2){
 233             $pairglob = $glob;
 234             last;
 235         } elsif ($i > length($dates[0])) {
 236             die sprintf "globbing on '%s' yields '%s', not trying any longer", $glob, join(",",@g);
 237         }
 238         $i++;
 239     }
 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";
 242     return $system;
 243 }
 244
 245 sub make_a_dot_d ($) {
 246     my($megalogfile) = @_;
 247     my @system =
 248         (
 249          $^X,
 250          "$FindBin::Bin/colorout-to-dir-3.pl",
 251          "--html",
 252          $megalogfile,
 253         );
 254     die "no success running system[@system]" unless 0 == system @system;
 255 }
 256
 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";
 262     my $cnt = 0;
 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;
 276         } else {
 277             die "too many tries failed, last one was with OP[$original_torelocate_perl]trydir[$trydir]\$![$!], giving up" if ++$cnt > 100;
 278             sleep 0.1;
 279         }
 280     }
 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;
 287     return
 288         {
 289          original_torelocate_perl => $original_torelocate_perl,
 290          hidden_locked_perl => $hidden_locked_perl,
 291          intempdir_relocated_perl => $intempdir_relocated_perl,
 292         };
 293 }
 294
 295 sub squirrel_back ($) {
 296     my($handle) = @_;
 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 });
 316 }
 317
 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 {
 321     my($perl) = @_;
 322     my $mib = $perl;
 323     $mib =~ s|perl$|module_info|;
 324     if (-e $mib) {
 325         if (0==system($mib,"Test::Reporter::Transport::Metabase")) {
 326             return 1;
 327         }
 328     } elsif (! -e $perl) {
 329         warn "Warning: perl '$perl' not found";
 330         return 0;
 331     } elsif (0==system($perl,"-MV=Test::Reporter::Transport::Metabase")) {
 332         return 1;
 333     } else {
 334         return 0;
 335     }
 336 }
 337
 338 MAIN: {
 339     my $megalogfile;
 340     if (!$Opt{extra}) {
 341         $megalogfile = most_recent_megalog();
 342     }
 343     if ($Opt{bbccheck}) {
 344         make_a_dot_d($megalogfile);
 345         my $system = suggest_cmp_megalogdir($megalogfile);
 346         warn "Running that now";
 347         system $system;
 348     } elsif (!$Opt{extra} && other_smoker_running($megalogfile)) {
 349         warn "Info: other smoker '$megalogfile' is running" if $Opt{verbose};
 350         counting_sleep 1800; # arbitrary
 351     } else {
 352         my $perl = $Opt{perl} || most_recent_perl();
 353         if (!$Opt{extra}) {
 354             if (dot_d_needs_work($megalogfile)) {
 355                 make_a_dot_d($megalogfile);
 356             }
 357             suggest_cmp_megalogdir($megalogfile);
 358             if (megalog_contains_perl($megalogfile,$perl)) {
 359                 if ($Opt{verbose}) {
 360                     warn "Nothing to smoke, newest perl '$perl' already smoked";
 361                 }
 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
 367                 exit;
 368             }
 369         }
 370         my $date = `date +%FT%T`;
 371         chomp $date;
 372         my @more;
 373         if (! $Opt{reporting}) {
 374             push @more, "--config_test_report=0";
 375         }
 376         my $system =
 377             join " ",
 378             map { />/ ? $_ : "\"$_\"" } # quote all arguments except redirects
 379             (
 380              $^X,
 381              "-I",
 382              "$ENV{HOME}/src/andk/rersyncrecent/lib",
 383              "$ENV{HOME}/src/andk/andk-cpan-tools/bin/loop-over-recent.pl",
 384              "--perlglob=$perl",
 385              "--transient_build_dir",
 386              "--mydistrobundles",
 387              "--timeout=$Opt{timeout}",
 388              @more,
 389              ">",
 390              "megalog-$date.log",
 391              "2>&1",
 392             );
 393         if ($Opt{"dry-run"}) {
 394             warn "Would run system[$system]";
 395         } else {
 396             if ($Opt{verbose}) {
 397                 warn "About to run '$system'\n";
 398             }
 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
 402                 last if $SIGNAL;
 403             }
 404             my $rphandle;
 405             if ($Opt{ramdisk}) {
 406                 $rphandle = squirrel_away($perl); # relocated perl handle
 407             }
 408             my $exitcode = 0;
 409             unless (0 == system $system){
 410                 warn "no success running system[$system], check content of 'megalog-$date.log'";
 411                 $exitcode |= 1;
 412             }
 413             if ($SIGNAL) {
 414                 if ($rphandle) {
 415                     warn "Trying to squirrel perl[$perl] back";
 416                 } elsif ($Opt{ramdisk}) {
 417                     warn "Ouch, we probably just lost a perl[$perl]";
 418                 } else {
 419                     warn "it seems we received a signal while perl is '$perl'";
 420                 }
 421                 $exitcode |= 2;
 422             }
 423             squirrel_back($rphandle) if $rphandle;
 424             if ($exitcode) {
 425                 warn "Alert: exit code[$exitcode]";
 426                 exit $exitcode;
 427             }
 428         }
 429     }
 430 }
 431
 432 # Local Variables:
 433 # mode: cperl
 434 # cperl-indent-level: 4
 435 # End: