bin/loop-over-recent.pl

   1 #!/usr/bin/perl -- -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
   2
   3 # /home/src/perl/repoperls/installed-perls/perl/p5B38YI/perl-5.10.0@35088/bin/perl /home/k/sources/CPAN/ghub/cpanpm/bin/loop-over-recent.pl
   4
   5 =head1 NAME
   6
   7 loop-over-recent.pl -
   8
   9 =head1 SYNOPSIS
  10
  11  loop-over-recent.pl [OPTIONS]
  12
  13 =head1 OPTIONS
  14
  15 =over 8
  16
  17 =cut
  18
  19
  20 my $optpod = <<'=back';
  21
  22 =item B<--action=s>
  23
  24 Defaults to C<install>. Other supported values are
  25
  26   test
  27   force install
  28
  29 =item B<--bisect!>
  30
  31 Takes one argument of the form C<v5.15.7-109-g035b682,v5.15.5>.
  32 Incompatible with C<--perlglob>.
  33
  34 NOT IMPLEMENTED. Needs more work to find out whether a child had
  35 success with its task.
  36
  37 =item B<--config_test_report=s>
  38
  39 Defaults to C<1>. By setting it to anything, we set
  40 $CPAN::Config->{test_report} to that value. Note that this string will
  41 be passed to a subprocess, so will be subject to an evaluation there.
  42
  43 =item B<--debug!>
  44
  45 More verbose.
  46
  47 =item B<--distro=s@>
  48
  49 Completely different beast than the original program design: instead
  50 of looping over recent we only run these CPAN shell object identifiers
  51 against all perls in this config and stop after that. If combined with
  52 --historical-excursions-arraysize, the latter is ignored.
  53
  54 Bonus feature: when the string contains dash(es) and no slash, then
  55 dashes are turned into double colons, turning eg. C<Text-PO-Parser>
  56 into C<Text::PO::Parser>.
  57
  58 Another bonus feature: string is split on comma and whitespace and
  59 then converted to multiple --distro arguments.
  60
  61 Third bonus feature: if an argument looks like an http URL, it is
  62 shortened to a distro argument.
  63
  64 =item B<--dotcpanhome=s>
  65
  66 defaults to C< $ENV{HOME}/.cpan >. The place passed to every
  67 smoker-perl where it should pick the MyConfig from.
  68
  69 =item B<--help|h!>
  70
  71 This help
  72
  73 =item B<--historical-excursions-arraysize=i>
  74
  75 Defaults to 0, so no historical excursions are being done. If set,
  76 whenever all work is done, we pick some random distro from the N most
  77 recent distros to keep the CPU busy.
  78
  79 =item B<--hostname=s>
  80
  81 when determining the config file, use this hostname.
  82
  83 =item B<--initial-backlog=i>
  84
  85 That many recentfiles we are trying to process iff this is a proper
  86 loop run (no --distro arg). Defaults to 4096.
  87
  88 =item B<--log!>
  89
  90 Turn logging on. Defaults to off.
  91
  92 =item B<--makeperl!>
  93
  94 Boolean. Build new perls on demand. When we encounter a perl path that
  95 does not exist, we try to get a hold of that corresponding directory
  96 with a lock for competing processes and then call this program with
  97 the usual parameters. When that other program finishes and we have no
  98 perl, we log this in the corresponding directory and give up. The
  99 logfile will then prevent further attempts.
 100
 101 If this option is used together with the --perlglob option, the result
 102 depends on the results of the glob which may in turn depend on perls
 103 already present, so may become confusing to debug. But it's OK to use
 104 when the glob returns one or more not-existing perls, so we usually
 105 bootstrap with one perl we want to have for all the following
 106 operations.
 107
 108 =item B<--max=i>
 109
 110 Perform not more loops than this many.
 111
 112 =item B<--monitoring=s>
 113
 114 Defaults to the string C<default>, which means the parent process
 115 printd a line like this every second:
 116
 117     ==========monitoring proc 28683 perl /home/src/perl/repoperls/installed-perls/perl/v5.16.3/a2da secs 6.0000=======
 118
 119 Other possible values:
 120
 121   silent       parent prints nothing
 122
 123 =item B<--mydistrobundles!>
 124
 125 Shortcut for several frequently used --distro=... options. Hardcoded
 126 in the program. RTFS.
 127
 128 =item B<--parallel=i>
 129
 130 Defaults to 1 which means we never have more than one job running.
 131 Specifies how many children we spawn when there is enough work to do.
 132
 133 =item B<--perlglob=s@>
 134
 135 Instead of using the perls from the configuration, use those specified
 136 in the glob expression. Repeatable. Incompatible with C<--bisect>.
 137
 138 =item B<--randomskip=f>
 139
 140 Value between 0 and 1. Defaults to 0 which means no test will be
 141 skipped. A value of 0.25 will skip on average every fourth activity, a
 142 value of 1 would skip all activities.
 143
 144 =item B<--reduce-perls-on-excursions!>
 145
 146 Boolean. Defaults to false. If true, we will only test with less perls
 147 than we have parallel processes. The idea here is that hanging distros
 148 do not let the whole machine go stale.
 149
 150 =item B<--skip_sanity_check!>
 151
 152 Normally we allocate big files every now and then to verify we have
 153 disk space available.
 154
 155 =item B<--sleep=f>
 156
 157 Sleep that many seconds after every build.
 158
 159 =item B<--statefile=s>
 160
 161 File holding a timestamp of the most recent distro we have processed.
 162
 163 =item B<--test!>
 164
 165 do not install, only test. Equivalent to
 166
 167   --action=test
 168
 169 =item B<--timeout=i>
 170
 171 Defaults to 45 minutes. Time allowed for one whole process of
 172 installing/testing/running one job with one perl. When timeout
 173 is reached the child process is killed and reaped.
 174
 175 =item B<--tmpdir=s>
 176
 177 In the two places where we use a temporary file or directory, use
 178 this directory as base.
 179
 180 =item B<--transient_build_dir!>
 181
 182 If true, a new build_dir is provided for every cpan run. Intended to
 183 make concurrent invocations easy. Note: the most annoying interaction
 184 with other users of the same homedirectory ist the lock around the
 185 FTPstats.yml file. TODO: there needs to be a way to disallow download
 186 statistics.
 187
 188 =back
 189
 190 =head1 DESCRIPTION
 191
 192 Picks the 4096 (--initial-backlog) most recent uploads, filters out
 193 outdated stuff, and installs the not outdated parts into a (sample of)
 194 perl(s). The order goes from oldest to newest distro. After every
 195 upload it writes a status kind of timestamp into something like
 196 ~/.cpan/loop-over-recent.state file (grep for $statefile). The status
 197 item is the epoch according to the RECENT files. This ensures that a
 198 new run of this program will not retry more than one distro from the
 199 last run.
 200
 201 =head1 AUTHOR
 202
 203 %AUTHOR%
 204
 205 =cut
 206
 207 use strict;
 208 use warnings;
 209 our $HAVE_SHUFFLE = eval { require Algorithm::Numerical::Shuffle };
 210 use BSD::Resource;
 211 use CPAN::DistnameInfo;
 212 use Cwd;
 213 use Fcntl qw( :flock :seek O_RDONLY O_RDWR O_CREAT );
 214 use File::Basename qw(fileparse dirname);
 215 use File::Path qw(mkpath rmtree);
 216 use File::Spec;
 217 use File::Temp;
 218 use Getopt::Long;
 219 Getopt::Long::Configure("no_auto_abbrev");
 220 use Pod::Usage qw(pod2usage);
 221 use List::MoreUtils qw(uniq);
 222 use POSIX ":sys_wait_h";
 223 use Sys::Hostname qw(hostname);
 224 use Time::HiRes qw(sleep);
 225 use Sys::Syslog;
 226 our $HAVE_DD = eval { require Data::Dump };
 227
 228 # indirect dependencies:
 229 use Sort::Versions;
 230 use BSD::Resource;
 231
 232 if (-e "/home/k/sources/rersyncrecent/lib/") {
 233   require lib;
 234   lib->import("/home/k/sources/rersyncrecent/lib/");
 235   lib->unimport(".");
 236 }
 237 our $HAVE_RRR = eval { require File::Rsync::Mirror::Recent };
 238
 239 our $Signal = 0;
 240 my @opt = $optpod =~ /B<--(\S+)>/g;
 241 our %Opt;
 242 GetOptions
 243     (
 244      \%Opt,
 245      @opt,
 246     ) or pod2usage(1);
 247
 248 pod2usage(0) if $Opt{help};
 249 pod2usage(1) if @ARGV;
 250
 251 if ($Opt{"historical-excursions-arraysize"} && $Opt{distro}) {
 252   warn "WARNING: Found option --distro and option --historical-excursions-arraysize; ignoring the latter";
 253   $Opt{"historical-excursions-arraysize"}=0;
 254 }
 255 if ($Opt{"historical-excursions-arraysize"} && !$HAVE_SHUFFLE) {
 256   warn "WARNING: will fail soonish because Shuffle missing, better install Algorithm::Numerical::Shuffle now";
 257   sleep 2;
 258 }
 259 $Opt{tmpdir} ||= "/tmp";
 260 $Opt{timeout} ||= 45*60; # PDL
 261 $Opt{dotcpanhome} ||= "$ENV{HOME}/.cpan";
 262 $Opt{parallel} ||= 1;
 263 $Opt{action} ||= "install";
 264 $Opt{monitoring} ||= "default";
 265 $Opt{config_test_report} //= "1";
 266 if (defined $Opt{randomskip} && ($Opt{randomskip} < 0 || $Opt{randomskip} > 1)) {
 267   die "option --randomskip must be between 0 and 1 (inclusive); is $Opt{randomskip}\n";
 268 }
 269 if ($Opt{log}) {
 270   require Log::ger;
 271   Log::ger->import;
 272   require Log::ger::Util;
 273   Log::ger::Util::set_level("debug");
 274   require Log::ger::Output;
 275   require Time::Piece;
 276   my $t = Time::Piece::localtime();$t->date_separator("");$t->time_separator("");
 277   my $ts = $t->datetime;
 278   mkpath "$ENV{HOME}/var/log";
 279   Log::ger::Output->set(File => (path => "$ENV{HOME}/var/log/loop-over-$ts.log", lazy => 1));
 280   require Log::ger::Layout;
 281   Log::ger::Layout->import(Pattern => (format => '%d %H %P %p %c %L%% %m'));
 282   log_debug("Starting with opts: %s", \%Opt);
 283 } else {
 284   *log_debug = sub { };
 285 }
 286 if (my $d = $Opt{distro}) {
 287   my @d2;
 288   for my $d0 (@$d) {
 289     # comma operations
 290     push @d2, split /[,\s]+/, $d0;
 291   }
 292   $d = $Opt{distro} = \@d2;
 293   for (@$d) {
 294     if (/-/ and not m|/|) {
 295       s/-/::/g;
 296     } else {
 297       s|^https?://.+?/authors/id/[A-Z]/[A-Z]{2}/||;
 298     }
 299   }
 300 } elsif (! $HAVE_RRR) {
 301   die "this perl ($^X) has no File::Rsync::Mirror::Recent available, so we must have a --distro option specified";
 302 }
 303 if ($Opt{perlglob} && $Opt{bisect}) {
 304   die "The options perlglob and bisect cannot be used together";
 305 }
 306 if ($Opt{mydistrobundles}) {
 307   $Opt{distro} ||= [];
 308   my $date = "2011_10_21";
 309   my @snaps = glob "$Opt{dotcpanhome}/Bundle/Snapshot_${date}_*.pm";
 310   for my $s (@snaps) {
 311     my($n) = $s =~ /Snapshot_${date}_(\d+)/;
 312     push @{$Opt{distro}}, "Bundle::Snapshot_${date}_$n";
 313   }
 314 }
 315 $SIG{INT} = sub {
 316   my $sig = shift;
 317   warn "Cought $sig";
 318   $Signal=1;
 319 };
 320
 321 sub determine_perls {
 322   my($perls_config_file) = @_;
 323   my @perls;
 324   return unless $perls_config_file;
 325   return unless -e $perls_config_file;
 326   my $hostname = $Opt{hostname} || hostname();
 327   my $path_slice_for_perl = $hostname eq "k83" ? "perl" : "host/$hostname";
 328   if (open my $fh2, $perls_config_file) {
 329     while (<$fh2>) {
 330       chomp;
 331       s/#.*//; # remove comments
 332       next if /^\s*$/; # remove empty/white lines
 333       unless (m|/.+/|) {
 334         s|^|/home/sand/src/perl/repoperls/installed-perls/$path_slice_for_perl/|;
 335         s|$|/bin/perl|;
 336       }
 337       next if ! -x $_ && ! $Opt{makeperl};
 338       push @perls, $_;
 339     }
 340   }
 341   unless (@perls) {
 342     @perls = $^X;
 343   }
 344   \@perls;
 345 }
 346
 347 sub single_child_parental_control {
 348   my($pid,$system,$perl,$upload) = @_;
 349   my $start = my $sleep_to = Time::HiRes::time;
 350  SUPERVISE: while (waitpid($pid, WNOHANG) <= 0) {
 351     $sleep_to++;
 352     my $this_sleep = $sleep_to - Time::HiRes::time;
 353     $this_sleep = 0.1 if $this_sleep < 0.1; # maybe to enable ^C at all (?)
 354     sleep($this_sleep);
 355     if ($Signal) {
 356       log_debug("Killing %s with -15", $pid);
 357       kill -15, $pid;
 358       for my $c (qw(k i l l e d)) {
 359         warn "_ $c _ " x 19;
 360         sleep 0.06;
 361       }
 362       if ($Signal>=2) {
 363         return;
 364       }
 365       $Signal = 0;
 366       sleep 0.5; # give them a chance to ^C immediately again
 367       my $ret = waitpid($pid, WNOHANG);
 368       if ($ret && $?) {
 369         warn "Warning: process $ret returned \$\?=$?.
 370
 371 Command was '@$system'
 372 ";
 373         sleep 6;
 374       }
 375       return;
 376     }
 377     my $have_waited = $sleep_to-$start;
 378     if ($Opt{monitoring} eq "default") {
 379       warn sprintf "==========monitoring proc %d perl %s secs %.4f=======\n", $pid, $perl, $have_waited;
 380     } elsif ($Opt{monitoring} eq "silent") {
 381       # do nothing
 382     }
 383     if ($have_waited >= $Opt{timeout}) {
 384       log_debug("Killing with -15 %s", { pid =>$pid, upload => $upload });
 385       kill -15, $pid;
 386       for my $c (qw(k i l l e d)) {
 387         warn "_ $c _ " x 19;
 388         sleep 0.05;
 389       }
 390       if (kill(0, $pid)) {
 391         log_debug("Killing with -9 %s", { pid =>$pid, upload => $upload });
 392         kill -9, $pid;
 393       }
 394       my $sleep = 2;
 395       warn "ATTN-ATTN-ATTN-ATTN-ATTN-ATTN-ATTN-ATTN-ATTN-ATTN-ATTN-ATTN\n";
 396       warn "      Something went wrong during\n";
 397       warn "      $perl\n";
 398       warn "      $upload->{path}\n";
 399       warn "      have_waited='$have_waited' Opt{timeout}=$Opt{timeout}'\n";
 400       warn "      (sleeping $sleep)\n";
 401       warn "ATTN-ATTN-ATTN-ATTN-ATTN-ATTN-ATTN-ATTN-ATTN-ATTN-ATTN-ATTN\n";
 402       sleep $sleep;
 403     }
 404   }
 405   log_debug("End of job %s", {pid => $pid, upload => $upload});
 406   if ($Opt{sleep}) {
 407     warn "Sleeping $Opt{sleep} seconds now\n";
 408     sleep $Opt{sleep};
 409   }
 410 }
 411
 412 sub some_forks {
 413   my($chldr,$action,$distro,$perl,$upload,$combo,$cmbsn) = @_;
 414  FORK: {
 415     my $pid = fork;
 416     if (! defined $pid) { # contention
 417       warn "Contention '$!', sleeping 2";
 418       sleep 2;
 419       redo FORK;
 420     } elsif ($pid) { # parent
 421       push @$chldr, $pid;
 422       while (@$chldr >= $Opt{parallel}){
 423         for (my $i = $#$chldr; $i>=0; $i--){
 424           if (waitpid($chldr->[$i], WNOHANG) > 0){
 425             openlog "smoke", "pid", "local0";
 426             syslog "info", "reaped proc|->$chldr->[$i]";
 427             closelog;
 428             splice @$chldr, $i, 1;
 429           }
 430         }
 431         sleep 0.01; # wait until some job finishes, we are at maximum
 432       }
 433     } else { # child
 434       one_fork($action,$distro,$perl,$upload,$combo);
 435       exit;
 436     }
 437   } # FORK
 438   if ($Signal>=2) {
 439     return;
 440   }
 441   $cmbsn->{$perl,$upload->{path}} = $upload->{epoch};
 442 }
 443
 444 sub one_fork {
 445   my($action,$distro,$perl,$upload,$combo) = @_;
 446   log_debug("Entering one_fork %s",
 447       {
 448        action   => $action,
 449        distro   => $distro,
 450        perl     => $perl,
 451        upload   => $upload,
 452       });
 453   my @system = (
 454                 $perl,
 455                 # "-Ilib",
 456                 "-I$Opt{dotcpanhome}",
 457                 "-M-lib='.'",
 458                 "-MCPAN::MyConfig",
 459                 "-MCPAN",
 460                 "-e",
 461                );
 462   my $bdir; # build directory
 463   my $func;
 464   {
 465     my @actions = split " ", $action;
 466     push @actions, $distro;
 467     my $f = shift @actions;
 468     $func = sprintf "%s(%s)", $f, join(",",map {"q{$_}"} @actions);
 469   }
 470   my $commonshellcmd = qq{
 471 \$SIG{XCPU} = sub { warn sprintf "%s: Caught inner SIGXCPU after %d seconds running\n", scalar localtime, time-\$^T };
 472 \$CPAN::Config->{test_report}=$Opt{config_test_report}; \$CPAN::Suppress_readline=1; $func};
 473   if ($Opt{transient_build_dir}) {
 474     $bdir = File::Temp::tempdir(
 475                                 "loop_over_bdir-$$-XXXXXX",
 476                                 DIR => $Opt{tmpdir},
 477                                 CLEANUP => 0, # we clean up ourselves
 478                                               # much earlier than
 479                                               # *this* program exit
 480                                ) or die $!;
 481     warn "DEBUG: bdir[$bdir] \$\$[$$]\n";
 482     push @system, "\$CPAN::Config->{build_dir}=q{$bdir}; $commonshellcmd",
 483   } else {
 484     push @system, "\$CPAN::Config->{build_dir_reuse}=0; $commonshellcmd",
 485   }
 486   # 0==system @system or die;
 487  ONEFORK: while () {
 488     my $pid = fork;
 489     if (! defined $pid) { # contention
 490       warn "Contention '$!', sleeping 2";
 491       sleep 2;
 492     } elsif ($pid) { # parent
 493       single_child_parental_control($pid,\@system,$perl,$upload);
 494       if ($bdir) {
 495         warn sprintf "%s: About to rmtree '%s'", scalar localtime, $bdir;
 496         rmtree $bdir;
 497       }
 498       if ($Signal>=2) {
 499         return;
 500       }
 501       last ONEFORK;
 502     } else { # child
 503       openlog "smoke", "pid", "local0";
 504       syslog "info", "$combo\nproc|->$$";
 505       closelog;
 506       POSIX::setsid();
 507       my ($soft, $hard) = BSD::Resource::getrlimit(+BSD::Resource::RLIMIT_CPU);
 508       unless ($soft > 0) {
 509         BSD::Resource::setrlimit(+BSD::Resource::RLIMIT_CPU, 0.9*3600, 1*3600);
 510       }
 511       exec @system or sleep 1; # give them a chance to ^C immediately again
 512     }
 513   }
 514 }
 515
 516 sub makeperl {
 517   my($mperl) = @_;
 518   # '-Dprefix=/home/src/perl/repoperls/installed-perls/perl/v5.19.1/165a -Dmyhostname=k83 -Dinstallusrbinperl=n -Uversiononly -Dusedevel -des -Ui_db -DDEBUGGING=-g';
 519   # (have removed:) -Uuseithreads -Uuselongdouble
 520   # perl ~/src/andk/andk-cpan-tools/bin/makeperl.pl -j=4 --ud=UD --report --module=Moose
 521   my($perlroot) = $mperl =~ m|(.+)/bin/perl$|;
 522   unless (-d $perlroot) {
 523     File::Path::make_path($perlroot, { verbose => 1, mode => 0755 });
 524   }
 525   my($lockfile) = File::Spec->catfile($perlroot,"LOGCK");
 526   my $lfh;
 527   unless (open $lfh, "+<", $lockfile) {
 528     unless ( open $lfh, ">>", $lockfile ) {
 529       die "ALERT: Could not open >> '$lockfile': $!"; # XXX should not die
 530     }
 531     unless ( open $lfh, "+<", $lockfile ) {
 532       die "ALERT: Could not open +< '$lockfile': $!"; # XXX should not die
 533     }
 534   }
 535   if (flock $lfh, LOCK_EX|LOCK_NB) {
 536     warn "Info[$$]: Got the lock, continuing";
 537   } else {
 538     warn "FATAL[$$]: lockfile '$lockfile' locked by a different process; skipping this perl";
 539     return;
 540   }
 541   my(%map) =
 542       (
 543        "127e" => ["--ud=UD"],
 544        "165a" => ["--ud=UU"],
 545        "a2da" => ["--ud=DD"],
 546        "9980" => ["--ud=DU"],
 547        "8378" => ["--ud=UD", "--nodebugging"],
 548        "9ab7" => ["--ud=UU", "--nodebugging"],
 549        "7e7a" => ["--ud=DD", "--nodebugging"],
 550        "8005" => ["--ud=DU", "--nodebugging"],
 551        # with 2016 libswanted:
 552        "8942" => ["--ud=UD"],
 553        "79cc" => ["--ud=UU"],
 554        "109d" => ["--ud=DD"],
 555        "f7bf" => ["--ud=DU"],
 556        "8d81" => ["--ud=UD", "--nodebugging"],
 557        "f991" => ["--ud=UU", "--nodebugging"],
 558        "de40" => ["--ud=DD", "--nodebugging"],
 559        "13e0" => ["--ud=DU", "--nodebugging"],
 560        # k93msid
 561        "f11c" => ["--ud=DU"],
 562        "89ad" => ["--ud=UU"],
 563        "5ea4" => ["--ud=DD"],
 564        "2d7c" => ["--ud=UD"],
 565        "d2d1" => ["--ud=UU", "--debuggingoption=DEBUGGING=both"],
 566        "a1a1" => ["--ud=DD", "--debuggingoption=DEBUGGING=both"],
 567        "276a" => ["--ud=DU", "--debuggingoption=DEBUGGING=both"],
 568        "0a29" => ["--ud=UD", "--debuggingoption=DEBUGGING=both"],
 569        # note 2015-03-08: Today I succeeded for 5.8.9 with just the current hints/linux.sh
 570        # and that's why we now have a perl-5.8.9/165a
 571        # 2015-03-08 07:12  git checkout perl-5.8.9
 572        # 2015-03-08 07:31  git fetch
 573        # 2015-03-08 07:32  git show FETCH_HEAD:hints/linux.sh >| hints/linux.sh
 574        # 2015-03-08 07:32  perl /home/sand/src/andk/andk-cpan-tools/bin/makeperl.pl --j=6 --ud=rand --report --module=PAUSE::Packages
 575        "5da8" => ["--ud=UU",
 576                   "-j=1",
 577                   "--addopts=Dusedl",
 578                   "--addopts=Ddlsrc=dl_dlopen.xs",
 579                   "--addopts=Dlibs=-lnsl -ldb -ldl -lm -lcrypt -lutil -lc",
 580                   "--addopts=Dlibpth=/usr/lib/x86_64-linux-gnu /usr/local/lib /lib /usr/lib",
 581                  ],
 582       );
 583   my($hash,$pdir) = fileparse($perlroot); # ("127e","/home/sand/src/....")
 584   $pdir =~ s|/$||;
 585   my($tag) = fileparse($pdir);
 586   my $opts = $map{$hash};
 587   unless ($opts) {
 588      print $lfh "Could not determine arguments for hash[$hash] mperl[$mperl]\n";
 589      return;
 590   }
 591   my $bindir = dirname(__FILE__);
 592   my @system2 =
 593       (
 594        $^X,
 595        "$bindir/makeperl.pl",
 596        "--j=4",
 597        @$opts,
 598        "--report",
 599        "--notest", # TODO: FIXME: should only turn off testing when necessary
 600       );
 601   warn "prepare a clone to run system[@system2]";
 602   my $clonedir = File::Temp::tempdir
 603       (
 604        "loop_over_clonedir-$$-XXXXXX",
 605        DIR => $Opt{tmpdir},
 606        CLEANUP => 1, # we clean up
 607        # ourselves much earlier than *this* program exit
 608       );
 609   unless ($clonedir) {
 610      print $lfh "Could not create a clonedir: $!\n";
 611      return;
 612   }
 613   # cd /tmp && git clone /home/sand/src/perl/repoperls/perl5.git.perl.org/perl --no-single-branch perl-clone-$$ && cd perl-clone-$$/
 614   my $cwd = Cwd::cwd();
 615   chdir $clonedir or die "Could not chdir to $clonedir: $!"; # XXX should not die
 616   warn "Info: now in $clonedir";
 617   0==system("git", "clone", "/home/sand/src/perl/repoperls/perl5.git.perl.org/perl", "--no-single-branch", ".") # XXX hardcoded sand
 618       or die "problem building a clone"; # XXX should not die
 619   warn "Info: now have checked out perl";
 620   0==system("git", "checkout", $tag) or die "problem checking out tag '$tag'";
 621   warn "Info: checked out $tag";
 622   0==system @system2
 623       or die sprintf
 624       (
 625        "Alert: %s: problem building perl %s/%s with '%s'",
 626        scalar localtime,
 627        $tag,
 628        $hash,
 629        join(" ", @system2),
 630       );
 631   chdir $cwd or die "could not chdir back to '$cwd': $!"; # XXX should not die
 632   File::Path::remove_tree($clonedir);
 633 }
 634
 635 sub read_recent_events {
 636   my($rf,$rx,$max) = @_;
 637   $max ||= $Opt{"initial-backlog"} ||= 4096;
 638   my $recent_events = $rf->news(max => $max);
 639   $recent_events = [ grep { $_->{path} =~ $rx and $_->{type} eq "new" } @$recent_events ];
 640   {
 641     my %seen;
 642     $recent_events = [ grep {
 643       my $path = $_->{path};
 644       my $d = CPAN::DistnameInfo->new($path);
 645       my $dist = $d->dist;
 646       # warn "no dist for path[$path]" unless $dist;
 647       $dist ? !$seen{$dist}++ : "";
 648     } @$recent_events ];
 649   }
 650   $recent_events;
 651 }
 652
 653 sub iterate_over_perls {
 654   my($perls, $upload, $cmbsn, $action, $chldr) = @_;
 655   my @perlset = @$perls;
 656  PERL: while (@perlset) {
 657     my $perl = shift @perlset;
 658     last PERL if $Signal;
 659     unless (-e $perl) {
 660       # cautious code location. Once we have this robust, we would
 661       # prefer to move it into the forked process; but the
 662       # downside is that we do not know whether this process will
 663       # provide this perl;
 664       if ($Opt{"makeperl"}) {
 665         makeperl($perl);
 666       }
 667     }
 668     next PERL unless -e $perl;
 669     my $perl_version =
 670         do { open my $fh, "$perl -e \"print \$]\" |" or die "Couldn't open $perl: $!";
 671              <$fh>;
 672            };
 673     unless ($perl_version) {
 674       warn "Alert: could not determine perl version of '$perl', skipping";
 675       sleep 0.33;
 676       next PERL;
 677     }
 678     if ($Opt{randomskip} && rand() <= $Opt{randomskip}) {
 679       require Term::ANSIColor;
 680       warn Term::ANSIColor::colored (["green on_magenta"], "skipping due to randomskip = $Opt{randomskip}\n");
 681       sleep 0.33;
 682       next PERL;
 683     }
 684     my $testtime = localtime;
 685     my($upload_epoch,$epoch_as_localtime);
 686     if ($upload->{epoch}){
 687       $upload_epoch = $upload->{epoch};
 688       $epoch_as_localtime = scalar localtime $upload->{epoch};
 689     } else {
 690       $epoch_as_localtime = $upload_epoch = "N/A";
 691     }
 692     my $combo = "perl|-> $perl (=$perl_version)\npath|-> $upload->{path}\n".
 693         "recv|-> $epoch_as_localtime (=$upload_epoch)\ntime|-> $testtime";
 694     if (0) {
 695     } elsif ($cmbsn->{$perl,$upload->{path}}){
 696       warn "dead horses combo $combo";
 697       sleep 2;
 698       next PERL;
 699     } else {
 700       warn "\n\n$combo\n\n\n";
 701       $ENV{PERL_MM_USE_DEFAULT} = 1;
 702       $ENV{AUTOMATED_TESTING} = 1 unless defined $ENV{AUTOMATED_TESTING} && length $ENV{AUTOMATED_TESTING};
 703       $ENV{PERL_CANARY_STABILITY_NOPROMPT}=1;
 704       # How do I make sure this DISPLAY is running?
 705       # while true; do date ; if ! ps auxww | grep -v grep | grep -q Xvfb ; then Xvfb :121 & fi; echo -n 'sleeping 60 '; sleep 60; done
 706       # alternatives: vncserver, Xnest, etc.
 707       $ENV{DISPLAY} = ":121";
 708       my $distro = $upload->{path};
 709       $distro =~ s|^id/||;
 710       if ($Opt{parallel} <= 1) {
 711         one_fork($action,$distro,$perl,$upload,$combo);
 712       } else {
 713         some_forks($chldr,$action,$distro,$perl,$upload,$combo,$cmbsn);
 714       } # if/else parallel
 715       if ($Signal>=2) {
 716         return;
 717       }
 718     } # if/else cmbsn
 719   } # PERL
 720 }
 721
 722 my $recentfile = "/home/ftp/pub/PAUSE/authors/RECENT.recent";
 723 MAIN : {
 724   # local is for reading the recentfiles, localroot is for reading the
 725   # files. one should go away.
 726   my $rf;
 727   $rf = File::Rsync::Mirror::Recent->new
 728       (
 729        localroot => "/home/ftp/pub/PAUSE/authors/",
 730        local => $recentfile,
 731       ) if $HAVE_RRR;
 732   my $hostname = $Opt{hostname} || hostname();
 733   if ($hostname =~ s/\..*//) {
 734     warn "Warning: hostname contained a dot, shortening to '$hostname'";
 735   }
 736   my $perls_config_file;
 737   if ($hostname eq "k75") {
 738     $perls_config_file = "$0.otherperls";
 739   } elsif ($Opt{perlglob} || $Opt{bisect}) {
 740     # deciding below
 741   } else {
 742     $perls_config_file = "$0.otherperls.$hostname";
 743     if (-f $perls_config_file) {
 744       warn "Using perls config '$perls_config_file'";
 745     } else {
 746       die "Could not find '$perls_config_file'";
 747     }
 748   }
 749   my $statefile;
 750   if ($Opt{statefile}) {
 751     $statefile = $Opt{statefile};
 752   } else {
 753     my $bbname = fileparse($0,qr{\.pl});
 754     $statefile = "$ENV{HOME}/.cpan/$bbname.state";
 755   }
 756   my $rx = qr!\.(tar.gz|tar.bz2|zip|tgz|tbz)$!;
 757   my $max_epoch_worked_on = 0;
 758   if (-e $statefile) {
 759     local $/;
 760     my $state = do { open my $fh, $statefile or die "Couldn't open '$statefile': $!";
 761                      <$fh>;
 762                    };
 763     chomp $state;
 764     $state ||= 0;
 765     $state += 0;
 766     $max_epoch_worked_on = $state if $state;
 767   }
 768   warn "max_epoch_worked_on[$max_epoch_worked_on] statefile[$statefile]";
 769   BSD::Resource::setrlimit(BSD::Resource::RLIMIT_CORE(),  40*1024*1024, 45*1024*1024);
 770   if ($Opt{distro}) {
 771     # whenever we do not run in an endless loop, we want to limit globally
 772     BSD::Resource::setrlimit(+BSD::Resource::RLIMIT_CPU,   2.5*3600,     3*3600);
 773     $SIG{XCPU} = sub { warn sprintf "%s: Caught SIGXCPU after %d seconds running\n", scalar localtime, time-$^T };
 774   }
 775   # 2012-07-12: we had several oom-killer experiences that locked the
 776   # klatt machine up. oom killed the wrong processes first. The right
 777   # one would have been a perl with 3387649 kB:
 778   BSD::Resource::setrlimit(BSD::Resource::RLIMIT_RSS(),   3_000_000_000, 4_000_000_000);
 779   # 2012-07-29: the above limit to RSS did not prevent the OOM but the
 780   # following AS did:
 781   BSD::Resource::setrlimit(BSD::Resource::RLIMIT_AS(),   3_000_000_000, 4_000_000_000);
 782   # file size to X
 783   # BSD::Resource::setrlimit(BSD::Resource::RLIMIT_FSIZE(), 4_000_000_000, 4_000_000_000);
 784   my $cmbsn = {}; # was: %comboseen
 785   my $count_uploaditem = 0;
 786   my $chldr = []; # was: @children
 787  ITERATION: while () {
 788     last if $Signal;
 789     my $optdstrs = $Opt{distro}||[]; # was: @distro
 790     my $iteration_start = time;
 791     my $recent_events;
 792     my $historical_excursion = 0;
 793     if (@$optdstrs) {
 794       $recent_events = [map {+{path => $_}} @$optdstrs];
 795     } else {
 796       $recent_events = read_recent_events($rf,$rx);
 797       # $DB::single=1;
 798       if ($Opt{"historical-excursions-arraysize"}) {
 799         if ($max_epoch_worked_on >= $recent_events->[0]{epoch}) {
 800           $historical_excursion = 1;
 801           $recent_events = read_recent_events($rf,$rx,$Opt{"historical-excursions-arraysize"});
 802           while (! $HAVE_SHUFFLE){
 803             warn "Note: this perl ($^X) has no Algorithm::Numerical::Shuffle, sleeping 60, then retry\n";
 804             sleep 60;
 805             last if $Signal;
 806             $HAVE_SHUFFLE = eval { require Algorithm::Numerical::Shuffle };
 807           }
 808           Algorithm::Numerical::Shuffle::shuffle($recent_events);
 809         } else {
 810           warn sprintf "DEBUG: \$max_epoch_worked_on '%s' >= \$recent_events->[0] '%s'\n", $max_epoch_worked_on, $HAVE_DD ? Data::Dump::pp($recent_events->[0]) : $recent_events->[0];
 811           @$recent_events = reverse @$recent_events;
 812         }
 813       } else {
 814         @$recent_events = reverse @$recent_events;
 815       }
 816     }
 817     last if $Signal;
 818     my $perls;
 819     if ($Opt{perlglob}) {
 820       my @globs = @{$Opt{perlglob}};
 821       my @allperls;
 822       for my $glob (@globs) {
 823         my @perls = glob $glob;
 824         push @allperls, @perls;
 825       }
 826       $perls = \@allperls;
 827     }
 828  UPLOADITEM: for my $upload (@$recent_events) {
 829       last if $Signal;
 830       unless (@$optdstrs) {
 831         next  UPLOADITEM unless $upload->{path} =~ $rx;
 832         next  UPLOADITEM unless $upload->{type} eq "new";
 833         next  UPLOADITEM if $upload->{path} =~ m|/perl-5\.[12]\d|;
 834         next  UPLOADITEM if $upload->{path} =~ m|A/AN/ANDK/.*CPAN-Test-Dummy-Perl5-|;
 835         if ($historical_excursion) {
 836           if ($cmbsn->{"ALL",$upload->{path}}) {
 837             if ($upload->{epoch} > $max_epoch_worked_on) {
 838               # we never know whether what was the mtime of the
 839               # latest is still the same one; we know, that pause may
 840               # touch a file (for unknown reasons)
 841               $max_epoch_worked_on = $upload->{epoch};
 842             }
 843             next UPLOADITEM;
 844           }
 845         } elsif ($upload->{epoch} < $max_epoch_worked_on) {
 846           warn sprintf "Already done: %s %.1f\n", substr($upload->{path},8), $upload->{epoch} unless keys %$cmbsn;
 847           sleep 0.03;
 848           next UPLOADITEM;
 849         } elsif ($upload->{epoch} == $max_epoch_worked_on) {
 850           if ($cmbsn->{"ALL",$upload->{path}}) {
 851             next UPLOADITEM;
 852           }
 853           warn "Maybe already worked on, we'll retry them: $upload->{path}";
 854         }
 855         if ($historical_excursion) {
 856           for (qw(h i s t o r i c a l)) {
 857             print "_$_" x 39;
 858             print "\n";
 859             sleep 0.1;
 860           }
 861         } else {
 862           {
 863             open my $fh, ">", $statefile or die "Could not open >$statefile\: $!";
 864             print $fh $upload->{epoch}, "\n";
 865             close $fh or die "Could not write: $!\nTry\n  echo '$upload->{epoch}' > '$statefile'\n ";
 866           }
 867           $max_epoch_worked_on = $upload->{epoch};
 868         }
 869       }
 870       if ($Opt{max} && ++$count_uploaditem > $Opt{max}){
 871         log_debug("Reached last loop %d", $count_uploaditem);
 872         last ITERATION;
 873       }
 874       sanity_check();
 875       $perls ||= determine_perls($perls_config_file) || [];
 876       my $action = $Opt{action};
 877       if ($upload->{path} =~ m{^D/DA/DAGOLDEN/CPAN-Reporter-\d+\.\d+_
 878                                /CPAN-Distribution-\d
 879                               }x){
 880         $action = "test";
 881       } elsif ($Opt{test}) {
 882         $action = "test";
 883       } elsif ($historical_excursion) {
 884         if ($action ne "test") {
 885           require CPAN;
 886           my $do = eval { CPAN::Shell->expand('Distribution', $upload->{path}) };
 887           if (!$do) {
 888             warn "Warning: '$upload->{path}' not in the index, will not install";
 889             $action = "test";
 890           }
 891         }
 892         if ($Opt{"reduce-perls-on-excursions"}) {
 893           while (@$perls > $Opt{parallel} + 1) {
 894             my $splice = rand scalar @$perls;
 895             splice @$perls, $splice, 1;
 896           }
 897         }
 898       }
 899
 900       # XXX: we should compute exceptions for every distro that has a
 901       # higher numbered developer release. Say Foo-1.4801 is released
 902       # but we have already 1.48_51 installed. We do not want this
 903       # stable stuff. Test yes, so we should 'make test' instead of
 904       # 'make install'. The problem with this is that we do not know
 905       # what exactly is in the distro. So we must go through
 906       # CPAN::DistnameInfo somehow. It gets even more complicated when
 907       # the item here gets passed to a queuerunner because then the
 908       # decision if test or install shall be called cannot be made now,
 909       # it must be made when the job is actually started.
 910
 911       # Update 2017-07-04:
 912       # https://github.com/eserte/srezic-misc/blob/master/scripts/cpan_recent_uploads2#L225
 913       # how slaven decides to limit operations on indexed distros (we
 914       # talked about the gotcha with downgrading XML::LibXML::Common)
 915       # Update 2017-09-06: commit
 916       # 6d12ff99b9b4a60494f7ab1bd959e1811cc3030b introduced this
 917       # algorithm
 918
 919       if (@$optdstrs) {
 920         # need no sanity check on path or anything
 921       } else {
 922         my $abs = File::Spec->catfile($rf->localroot, $upload->{path});
 923         {
 924           local $| = 1;
 925           my $max = 1200;
 926           my $slept = 0;
 927           while (! -f $abs) {
 928             print ",";
 929             $slept += sleep 0.5;
 930             if ($slept > $max) {
 931               warn "Giving up waiting for '$abs', maybe already deleted?";
 932               next UPLOADITEM;
 933             }
 934           }
 935         }
 936       }
 937       iterate_over_perls($perls, $upload, $cmbsn, $action, $chldr);
 938       if ($Signal>=2) {
 939         last ITERATION;
 940       }
 941       $cmbsn->{"ALL",$upload->{path}} = $upload->{epoch};
 942       if (@$optdstrs) {
 943         next UPLOADITEM; # nothing can change that would influence us
 944       } elsif ($historical_excursion) {
 945         sleep 1;
 946         next ITERATION;
 947       } else {
 948         next ITERATION; # see what is new before simply going through the ordered list
 949       }
 950     } # UPLOADITEM
 951     if (@$optdstrs) {
 952       last ITERATION; # nothing left to do
 953     }
 954     my $minimum_time_per_loop = 15;
 955     while (time - $iteration_start < $minimum_time_per_loop) {
 956       my @stat = stat($recentfile);
 957       last if $stat[9] > $iteration_start;
 958       last if $Signal;
 959       sleep 1;
 960     }
 961     for my $k (keys %$cmbsn) {
 962       delete $cmbsn->{$k} if $cmbsn->{$k} < time - 60*60*24*2;
 963     }
 964     { local $| = 1; print "."; } # painting dots
 965   } # ITERATION
 966
 967   log_debug("End of Iteration. Left-over children %d", scalar @$chldr);
 968   while (@$chldr){
 969     for (my $i = $#$chldr; $i; $i--){
 970       if (waitpid($chldr->[$i], WNOHANG) > 0){
 971         openlog "smoke", "pid", "local0";
 972         syslog "info", "reaped proc|->$chldr->[$i]";
 973         closelog;
 974         splice @$chldr, $i, 1;
 975       }
 976     }
 977     if ($Signal) {
 978       warn "giving up on signal";
 979       last;
 980     }
 981     warn "will have to wait for children[@$chldr]";
 982     while (my $c = pop @$chldr){
 983       if (waitpid($c, 0) > 0){
 984         warn "Finished child: $c";
 985         openlog "smoke", "pid", "local0";
 986         syslog "info", "reaped proc|->$c";
 987         closelog;
 988       }
 989     }
 990   }
 991   log_debug("all children reaped");
 992   print "all children reaped\n";
 993
 994 }
 995
 996 sub sanity_check {
 997   # cleanup => 1 only active at program exit, not at scope exit!
 998   return if $Opt{skip_sanity_check};
 999  DFTEST: while () {
1000     my $cannotcontinuenow = 0;
1001     for my $dir ($Opt{tmpdir},
1002                  ".",
1003                  "/var/tmp", # these bloody testers write everywhere,
1004                              # sometimes in /var/lib/ for databases,
1005                              # this is a proxy for this case
1006                 ) {
1007       my $tmpdir = eval { File::Temp::tempdir(
1008                                        "loop-over-recent-XXXXXX",
1009                                        DIR => $dir,
1010                                       ) } or die "Could not create tempdir in '$dir': $!";
1011       my $ttt = "$tmpdir/testfreespace";
1012       open my $fh, ">", $ttt or die "Could not open > '$ttt': $!";
1013       for (1..100) {
1014         # 32 bytes times 2**15 equals 1 MB
1015         print $fh "f r e e e e s p a c e <%-1/8-\> " x 2**15;
1016         print $fh "\n";
1017       }
1018       my $success = 0;
1019       $success = close $fh;
1020       rmtree $tmpdir;
1021       unless ($success){
1022         warn "Couldn't close '$ttt': $!";
1023         $cannotcontinuenow = 1;
1024       }
1025     }
1026     if ($cannotcontinuenow) {
1027       warn "$$: n o   f r e e s p a c e\n" for 1..8;
1028       sleep(30 + rand(180));
1029     } else {
1030       last DFTEST;
1031     }
1032   }
1033   open my $fh, "-|", "ipcs -m" or die "Could not fork ipcs -m: $!";
1034   my $shared_mem_segments = 0;
1035   while (<$fh>) {
1036     next unless /sand/;
1037     $shared_mem_segments++;
1038   }
1039   if ($shared_mem_segments > 4000) {
1040     die sprintf "Too many shared memory segments (%d) for further testing, try something like\n  %s\n", $shared_mem_segments, q{ipcs -m|grep sand|head -1004|awk '{print $2}'|xargs -n 1 ipcrm -m};
1041   } elsif ($shared_mem_segments > 1000) {
1042     warn sprintf "Info: (%s) allocated shared mem segments now: %d\n", $0, $shared_mem_segments;
1043   }
1044 }
1045
1046 __END__
1047
1048 # Local Variables:
1049 # mode: cperl
1050 # cperl-indent-level: 2
1051 # End: