bin/generate-recent.pl

   1 #!/usr/bin/perl
   2
   3 # use 5.010;
   4 use strict;
   5 use warnings;
   6
   7 =head1 NAME
   8
   9 generate-recent.pl -
  10
  11 =head1 SYNOPSIS
  12
  13  generate-recent.pl [OPTIONS]
  14
  15 =head1 OPTIONS
  16
  17 =over 8
  18
  19 =cut
  20
  21 my @opt = <<'=back' =~ /B<--(\S+)>/g;
  22
  23 =item B<--help|h!>
  24
  25 This help
  26
  27 =item B<--jobs|j=i>
  28
  29 Parameter to pass to 'makeperl.pl'. Defaults to 1 which is usually
  30 what we want. But in rare situations, when for example TEST produces a
  31 fail but harness produces a pass, this comes in handy.
  32
  33 =item B<--keepfilesonerror!>
  34
  35 Do not do any cleanup on error, just bail out with an error.
  36
  37 =back
  38
  39 =head1 DESCRIPTION
  40
  41 Runs makeperl.pl in a loop. Stops when no patches have arrived.
  42
  43 The loop is to run installed-perls-overview and inspect the list from
  44 top to bottom. It is expected that the list is based on I<git
  45 describe> and sorted like the trunk. And when the current 'git
  46 describe' matches the first line, then we have nothing to do.
  47
  48 We set --jobs to 1 because at the moment we are much faster (>100
  49 times) than the smoker and sleep long times between invocations. If we
  50 were yet faster we would only waste both disk and CPU.
  51
  52 =cut
  53
  54
  55 use FindBin;
  56 use lib "$FindBin::Bin/../lib";
  57 BEGIN {
  58     push @INC, qw(       );
  59 }
  60
  61 use Dumpvalue;
  62 use File::Basename qw(dirname);
  63 use File::Path qw(mkpath);
  64 use File::Spec;
  65 use File::Temp;
  66 use Getopt::Long;
  67 use Hash::Util qw(lock_keys);
  68 use Pod::Usage;
  69
  70 our %Opt;
  71 lock_keys %Opt, map { /([^=!\|]+)/ } @opt;
  72 GetOptions(\%Opt,
  73            @opt,
  74           ) or pod2usage(1);
  75
  76 if ( $Opt{help} ) {
  77     pod2usage(0);
  78 }
  79 $Opt{jobs} //= 1;
  80
  81 use YAML::Syck;
  82 use POSIX;
  83 use Sys::Hostname ();
  84
  85 my @valid_debuggingoptions = ("EBUGGING=both", "EBUGGING=-g", "EBUGGING=none");
  86
  87 my $waitabit = 0;
  88 LOOP: while () {
  89     if ( $waitabit > time ) {
  90         my $sleep = $waitabit - time;
  91         $sleep = 1 if $sleep < 1;
  92         sleep $sleep;
  93     } else {
  94         $waitabit = time +120; # arbitrary
  95     }
  96     open my $fh, "-|", $^X, "$FindBin::Bin/installed-perls-overview.pl", "--max=100", "--minperl=v5.15.7";
  97     my(@perls,%perls_seen);
  98  OVLINE: while (<$fh>) {
  99         my($perl) = split " ", $_, 2;
 100         my $hostname = Sys::Hostname::hostname;
 101         $hostname =~ s/\..*//;
 102         my $perl_or_host;
 103         if ($hostname eq "k83") {
 104             $perl_or_host = "perl";
 105         } else {
 106             $perl_or_host = "host/$hostname";
 107         }
 108         # Can't exec "/home/sand/src/perl/repoperls/installed-perls/perl/v5.23.7-35-g6002757/3bd2/bin/perl": No such...
 109         my $absperl = sprintf "/home/sand/src/perl/repoperls/installed-perls/%s/%s/bin/perl", $perl_or_host, $perl;
 110         open my $fh2, "-|", $absperl, "-V:useithreads|uselongdouble";
 111         my @stat = stat $absperl;
 112         my $mtime = POSIX::strftime "%FT%TZ", gmtime $stat[9];
 113         my %conf;
 114         while (<$fh2>) {
 115             my($k,$v) = /(\w+)='(\w*)';/;
 116             $conf{$k} = $v || 'undef';
 117         }
 118         next OVLINE if $perls_seen{join ",", @conf{qw(useithreads uselongdouble)}}++;
 119         push @perls, +{ perl => $perl, mtime => $mtime, %conf };
 120         last OVLINE if @perls >= 4;
 121     }
 122     warn YAML::Syck::Dump \@perls;
 123     my @system_git = (git => "pull");
 124     while () {
 125         last if 0 == system @system_git;
 126         warn sprintf "%s UTC: git poll has failed, sleeping 900 for the next retry\n", scalar gmtime;
 127         sleep 900; # arbitrary
 128     }
 129     my $describe = `git describe`;
 130     warn $describe;
 131     chomp $describe;
 132     if ($describe eq
 133         substr($perls[0]{perl},0,index($perls[0]{perl},"/"))) {
 134         my $sleep = 2700; # arbitrary
 135         my $eta = time+$sleep;
 136         local($|)=1;
 137         while () {
 138             my $left = $eta - time;
 139             last if $left < 0;
 140             printf "\r%d    ", $left;
 141             sleep 1;
 142         }
 143         print "\n";
 144         next LOOP;
 145     }
 146     my $ud;
 147     if (@perls >= 4) {
 148         $ud = sprintf "%s%s",
 149             uc(substr($perls[3]{useithreads}||qw(D U)[int rand 2], 0, 1)),
 150                 uc(substr($perls[3]{uselongdouble}||qw(D U)[int rand 2], 0, 1));
 151     } else {
 152         my %pickud = map { $_ => 1 } qw(UU UD DU DD);
 153         for my $p (@perls) {
 154             my $thisud = sprintf "%s%s",
 155             uc(substr($p->{useithreads}, 0, 1)),
 156                 uc(substr($p->{uselongdouble}, 0, 1));
 157             delete $pickud{$thisud};
 158         }
 159         $ud = (keys %pickud)[int rand scalar keys %pickud];
 160     }
 161     my $debuggingoption = $valid_debuggingoptions[int rand scalar @valid_debuggingoptions];
 162     my @system_mp =
 163         ($^X,
 164          $DB::VERSION ? ("-d") : (),
 165          "$FindBin::Bin/makeperl.pl",
 166          "--jobs=$Opt{jobs}",
 167          "--ud=$ud",
 168          "--report",
 169          "--debuggingoption=$debuggingoption",
 170          $Opt{keepfilesonerror} ? "--keepfilesonerror" : (),
 171         );
 172     warn YAML::Syck::Dump \@system_mp;
 173     sleep 3; # just so that the message can be seen
 174     0 == system @system_mp or die "Alert: problem running system[@system_mp]";
 175 }
 176
 177 # Local Variables:
 178 # mode: cperl
 179 # cperl-indent-level: 4
 180 # End: