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 bis xxxx
 561        "f11c" => ["--ud=DU"],
 562        "89ad" => ["--ud=UU"],
 563        "5ea4" => ["--ud=DD"],
 564        "2d7c" => ["--ud=UD"],
 565        "ea6b" => ["--ud=UD", "--debuggingoption=EBUGGING=none"],
 566        "d2d1" => ["--ud=UU", "--debuggingoption=EBUGGING=both"],
 567        "a1a1" => ["--ud=DD", "--debuggingoption=EBUGGING=both"],
 568        "276a" => ["--ud=DU", "--debuggingoption=EBUGGING=both"],
 569        "0a29" => ["--ud=UD", "--debuggingoption=EBUGGING=both"],
 570        # k93msid ab xxxx
 571        "1e0c" => ["--ud=DU"],
 572        "da1c" => ["--ud=UU"],
 573        "8854" => ["--ud=DD"],
 574        "af11" => ["--ud=UD"],
 575        #??? "" => ["--ud=UD", "--debuggingoption=EBUGGING=none"],
 576        "bb7f" => ["--ud=UU", "--debuggingoption=EBUGGING=both"],
 577        "ac75" => ["--ud=DD", "--debuggingoption=EBUGGING=both"],
 578        "29fb" => ["--ud=DU", "--debuggingoption=EBUGGING=both"],
 579        "fc43" => ["--ud=UD", "--debuggingoption=EBUGGING=both"],
 580        # note 2015-03-08: Today I succeeded for 5.8.9 with just the current hints/linux.sh
 581        # and that's why we now have a perl-5.8.9/165a
 582        # 2015-03-08 07:12  git checkout perl-5.8.9
 583        # 2015-03-08 07:31  git fetch
 584        # 2015-03-08 07:32  git show FETCH_HEAD:hints/linux.sh >| hints/linux.sh
 585        # 2015-03-08 07:32  perl /home/sand/src/andk/andk-cpan-tools/bin/makeperl.pl --j=6 --ud=rand --report --module=PAUSE::Packages
 586        "5da8" => ["--ud=UU",
 587                   "-j=1",
 588                   "--addopts=Dusedl",
 589                   "--addopts=Ddlsrc=dl_dlopen.xs",
 590                   "--addopts=Dlibs=-lnsl -ldb -ldl -lm -lcrypt -lutil -lc",
 591                   "--addopts=Dlibpth=/usr/lib/x86_64-linux-gnu /usr/local/lib /lib /usr/lib",
 592                  ],
 593       );
 594   my($hash,$pdir) = fileparse($perlroot); # ("127e","/home/sand/src/....")
 595   $pdir =~ s|/$||;
 596   my($tag) = fileparse($pdir);
 597   my $opts = $map{$hash};
 598   unless ($opts) {
 599      print $lfh "Could not determine arguments for hash[$hash] mperl[$mperl]\n";
 600      return;
 601   }
 602   my $bindir = dirname(__FILE__);
 603   my @system2 =
 604       (
 605        $^X,
 606        "$bindir/makeperl.pl",
 607        "--j=4",
 608        @$opts,
 609        "--report",
 610        "--notest", # TODO: FIXME: should only turn off testing when necessary
 611       );
 612   warn "prepare a clone to run system[@system2]";
 613   my $clonedir = File::Temp::tempdir
 614       (
 615        "loop_over_clonedir-$$-XXXXXX",
 616        DIR => $Opt{tmpdir},
 617        CLEANUP => 1, # we clean up
 618        # ourselves much earlier than *this* program exit
 619       );
 620   unless ($clonedir) {
 621      print $lfh "Could not create a clonedir: $!\n";
 622      return;
 623   }
 624   # cd /tmp && git clone /home/sand/src/perl/repoperls/perl5.git.perl.org/perl --no-single-branch perl-clone-$$ && cd perl-clone-$$/
 625   my $cwd = Cwd::cwd();
 626   chdir $clonedir or die "Could not chdir to $clonedir: $!"; # XXX should not die
 627   warn "Info: now in $clonedir";
 628   0==system("git", "clone", "/home/sand/src/perl/repoperls/perl5.git.perl.org/perl", "--no-single-branch", ".") # XXX hardcoded sand
 629       or die "problem building a clone"; # XXX should not die
 630   warn "Info: now have checked out perl";
 631   0==system("git", "checkout", $tag) or die "problem checking out tag '$tag'";
 632   warn "Info: checked out $tag";
 633   0==system @system2
 634       or die sprintf
 635       (
 636        "Alert: %s: problem building perl %s/%s with '%s'",
 637        scalar localtime,
 638        $tag,
 639        $hash,
 640        join(" ", @system2),
 641       );
 642   chdir $cwd or die "could not chdir back to '$cwd': $!"; # XXX should not die
 643   File::Path::remove_tree($clonedir);
 644 }
 645
 646 sub read_recent_events {
 647   my($rf,$rx,$max) = @_;
 648   $max ||= $Opt{"initial-backlog"} ||= 4096;
 649   my $recent_events = $rf->news(max => $max);
 650   $recent_events = [ grep { $_->{path} =~ $rx and $_->{type} eq "new" } @$recent_events ];
 651   {
 652     my %seen;
 653     $recent_events = [ grep {
 654       my $path = $_->{path};
 655       my $d = CPAN::DistnameInfo->new($path);
 656       my $dist = $d->dist;
 657       # warn "no dist for path[$path]" unless $dist;
 658       $dist ? !$seen{$dist}++ : "";
 659     } @$recent_events ];
 660   }
 661   $recent_events;
 662 }
 663
 664 sub iterate_over_perls {
 665   my($perls, $upload, $cmbsn, $action, $chldr) = @_;
 666   my @perlset = @$perls;
 667  PERL: while (@perlset) {
 668     my $perl = shift @perlset;
 669     last PERL if $Signal;
 670     unless (-e $perl) {
 671       # cautious code location. Once we have this robust, we would
 672       # prefer to move it into the forked process; but the
 673       # downside is that we do not know whether this process will
 674       # provide this perl;
 675       if ($Opt{"makeperl"}) {
 676         makeperl($perl);
 677       }
 678     }
 679     next PERL unless -e $perl;
 680     my $perl_version =
 681         do { open my $fh, "$perl -e \"print \$]\" |" or die "Couldn't open $perl: $!";
 682              <$fh>;
 683            };
 684     unless ($perl_version) {
 685       warn "Alert: could not determine perl version of '$perl', skipping";
 686       sleep 0.33;
 687       next PERL;
 688     }
 689     if ($Opt{randomskip} && rand() <= $Opt{randomskip}) {
 690       require Term::ANSIColor;
 691       warn Term::ANSIColor::colored (["green on_magenta"], "skipping due to randomskip = $Opt{randomskip}\n");
 692       sleep 0.33;
 693       next PERL;
 694     }
 695     my $testtime = localtime;
 696     my($upload_epoch,$epoch_as_localtime);
 697     if ($upload->{epoch}){
 698       $upload_epoch = $upload->{epoch};
 699       $epoch_as_localtime = scalar localtime $upload->{epoch};
 700     } else {
 701       $epoch_as_localtime = $upload_epoch = "N/A";
 702     }
 703     my $combo = "perl|-> $perl (=$perl_version)\npath|-> $upload->{path}\n".
 704         "recv|-> $epoch_as_localtime (=$upload_epoch)\ntime|-> $testtime";
 705     if (0) {
 706     } elsif ($cmbsn->{$perl,$upload->{path}}){
 707       warn "dead horses combo $combo";
 708       sleep 2;
 709       next PERL;
 710     } else {
 711       warn "\n\n$combo\n\n\n";
 712       $ENV{PERL_MM_USE_DEFAULT} = 1;
 713       $ENV{AUTOMATED_TESTING} = 1 unless defined $ENV{AUTOMATED_TESTING} && length $ENV{AUTOMATED_TESTING};
 714       $ENV{PERL_CANARY_STABILITY_NOPROMPT}=1;
 715       # How do I make sure this DISPLAY is running?
 716       # while true; do date ; if ! ps auxww | grep -v grep | grep -q Xvfb ; then Xvfb :121 & fi; echo -n 'sleeping 60 '; sleep 60; done
 717       # alternatives: vncserver, Xnest, etc.
 718       $ENV{DISPLAY} = ":121";
 719       my $distro = $upload->{path};
 720       $distro =~ s|^id/||;
 721       if ($Opt{parallel} <= 1) {
 722         one_fork($action,$distro,$perl,$upload,$combo);
 723       } else {
 724         some_forks($chldr,$action,$distro,$perl,$upload,$combo,$cmbsn);
 725       } # if/else parallel
 726       if ($Signal>=2) {
 727         return;
 728       }
 729     } # if/else cmbsn
 730   } # PERL
 731 }
 732
 733 my $recentfile = "/home/ftp/pub/PAUSE/authors/RECENT.recent";
 734 MAIN : {
 735   # local is for reading the recentfiles, localroot is for reading the
 736   # files. one should go away.
 737   my $rf;
 738   $rf = File::Rsync::Mirror::Recent->new
 739       (
 740        localroot => "/home/ftp/pub/PAUSE/authors/",
 741        local => $recentfile,
 742       ) if $HAVE_RRR;
 743   my $hostname = $Opt{hostname} || hostname();
 744   if ($hostname =~ s/\..*//) {
 745     warn "Warning: hostname contained a dot, shortening to '$hostname'";
 746   }
 747   my $perls_config_file;
 748   if ($hostname eq "k75") {
 749     $perls_config_file = "$0.otherperls";
 750   } elsif ($Opt{perlglob} || $Opt{bisect}) {
 751     # deciding below
 752   } else {
 753     $perls_config_file = "$0.otherperls.$hostname";
 754     if (-f $perls_config_file) {
 755       warn "Using perls config '$perls_config_file'";
 756     } else {
 757       die "Could not find '$perls_config_file'";
 758     }
 759   }
 760   my $statefile;
 761   if ($Opt{statefile}) {
 762     $statefile = $Opt{statefile};
 763   } else {
 764     my $bbname = fileparse($0,qr{\.pl});
 765     $statefile = "$ENV{HOME}/.cpan/$bbname.state";
 766   }
 767   my $rx = qr!\.(tar.gz|tar.bz2|zip|tgz|tbz)$!;
 768   my $max_epoch_worked_on = 0;
 769   if (-e $statefile) {
 770     local $/;
 771     my $state = do { open my $fh, $statefile or die "Couldn't open '$statefile': $!";
 772                      <$fh>;
 773                    };
 774     chomp $state;
 775     $state ||= 0;
 776     $state += 0;
 777     $max_epoch_worked_on = $state if $state;
 778   }
 779   warn "max_epoch_worked_on[$max_epoch_worked_on] statefile[$statefile]";
 780   BSD::Resource::setrlimit(BSD::Resource::RLIMIT_CORE(),  40*1024*1024, 45*1024*1024);
 781   if ($Opt{distro}) {
 782     # whenever we do not run in an endless loop, we want to limit globally
 783     BSD::Resource::setrlimit(+BSD::Resource::RLIMIT_CPU,   2.5*3600,     3*3600);
 784     $SIG{XCPU} = sub { warn sprintf "%s: Caught SIGXCPU after %d seconds running\n", scalar localtime, time-$^T };
 785   }
 786   # 2012-07-12: we had several oom-killer experiences that locked the
 787   # klatt machine up. oom killed the wrong processes first. The right
 788   # one would have been a perl with 3387649 kB:
 789   BSD::Resource::setrlimit(BSD::Resource::RLIMIT_RSS(),   3_000_000_000, 4_000_000_000);
 790   # 2012-07-29: the above limit to RSS did not prevent the OOM but the
 791   # following AS did:
 792   BSD::Resource::setrlimit(BSD::Resource::RLIMIT_AS(),   3_000_000_000, 4_000_000_000);
 793   # file size to X
 794   # BSD::Resource::setrlimit(BSD::Resource::RLIMIT_FSIZE(), 4_000_000_000, 4_000_000_000);
 795
 796   # 2017-12-22 saw a fork bomb in action, but NPROC is not the right
 797   # answer, at least no on this scale. The smoker produced many cannot
 798   # fork reports these days.
 799
 800   # BSD::Resource::setrlimit(BSD::Resource::RLIMIT_NPROC(), 256, 512);
 801
 802   my $cmbsn = {}; # was: %comboseen
 803   my $count_uploaditem = 0;
 804   my $chldr = []; # was: @children
 805  ITERATION: while () {
 806     last if $Signal;
 807     my $optdstrs = $Opt{distro}||[]; # was: @distro
 808     my $iteration_start = time;
 809     my $recent_events;
 810     my $historical_excursion = 0;
 811     if (@$optdstrs) {
 812       $recent_events = [map {+{path => $_}} @$optdstrs];
 813     } else {
 814       $recent_events = read_recent_events($rf,$rx);
 815       # $DB::single=1;
 816       if ($Opt{"historical-excursions-arraysize"}) {
 817         if ($max_epoch_worked_on >= $recent_events->[0]{epoch}) {
 818           $historical_excursion = 1;
 819           $recent_events = read_recent_events($rf,$rx,$Opt{"historical-excursions-arraysize"});
 820           while (! $HAVE_SHUFFLE){
 821             warn "Note: this perl ($^X) has no Algorithm::Numerical::Shuffle, sleeping 60, then retry\n";
 822             sleep 60;
 823             last if $Signal;
 824             $HAVE_SHUFFLE = eval { require Algorithm::Numerical::Shuffle };
 825           }
 826           Algorithm::Numerical::Shuffle::shuffle($recent_events);
 827         } else {
 828           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];
 829           @$recent_events = reverse @$recent_events;
 830         }
 831       } else {
 832         @$recent_events = reverse @$recent_events;
 833       }
 834     }
 835     last if $Signal;
 836     my $perls;
 837     if ($Opt{perlglob}) {
 838       my @globs = @{$Opt{perlglob}};
 839       my @allperls;
 840       for my $glob (@globs) {
 841         my @perls = glob $glob;
 842         push @allperls, @perls;
 843       }
 844       $perls = \@allperls;
 845     }
 846  UPLOADITEM: for my $upload (@$recent_events) {
 847       last if $Signal;
 848       unless (@$optdstrs) {
 849         next  UPLOADITEM unless $upload->{path} =~ $rx;
 850         next  UPLOADITEM unless $upload->{type} eq "new";
 851         next  UPLOADITEM if $upload->{path} =~ m|/perl-5\.[12]\d|;
 852         next  UPLOADITEM if $upload->{path} =~ m|A/AN/ANDK/.*CPAN-Test-Dummy-Perl5-|;
 853         if ($historical_excursion) {
 854           if ($cmbsn->{"ALL",$upload->{path}}) {
 855             if ($upload->{epoch} > $max_epoch_worked_on) {
 856               # we never know whether what was the mtime of the
 857               # latest is still the same one; we know, that pause may
 858               # touch a file (for unknown reasons)
 859               $max_epoch_worked_on = $upload->{epoch};
 860             }
 861             next UPLOADITEM;
 862           }
 863         } elsif ($upload->{epoch} < $max_epoch_worked_on) {
 864           warn sprintf "Already done: %s %.1f\n", substr($upload->{path},8), $upload->{epoch} unless keys %$cmbsn;
 865           sleep 0.03;
 866           next UPLOADITEM;
 867         } elsif ($upload->{epoch} == $max_epoch_worked_on) {
 868           if ($cmbsn->{"ALL",$upload->{path}}) {
 869             next UPLOADITEM;
 870           }
 871           warn "Maybe already worked on, we'll retry them: $upload->{path}";
 872         }
 873         if ($historical_excursion) {
 874           for (qw(h i s t o r i c a l)) {
 875             print "_$_" x 39;
 876             print "\n";
 877             sleep 0.1;
 878           }
 879         } else {
 880           {
 881             open my $fh, ">", $statefile or die "Could not open >$statefile\: $!";
 882             print $fh $upload->{epoch}, "\n";
 883             close $fh or die "Could not write: $!\nTry\n  echo '$upload->{epoch}' > '$statefile'\n ";
 884           }
 885           $max_epoch_worked_on = $upload->{epoch};
 886         }
 887       }
 888       if ($Opt{max} && ++$count_uploaditem > $Opt{max}){
 889         log_debug("Reached last loop %d", $count_uploaditem);
 890         last ITERATION;
 891       }
 892       sanity_check();
 893       $perls ||= determine_perls($perls_config_file) || [];
 894       my $action = $Opt{action};
 895       if ($upload->{path} =~ m{^D/DA/DAGOLDEN/CPAN-Reporter-\d+\.\d+_
 896                                /CPAN-Distribution-\d
 897                               }x){
 898         $action = "test";
 899       } elsif ($Opt{test}) {
 900         $action = "test";
 901       } elsif ($historical_excursion) {
 902         if ($action ne "test") {
 903           require CPAN;
 904           my $do = eval { CPAN::Shell->expand('Distribution', $upload->{path}) };
 905           if (!$do) {
 906             warn "Warning: '$upload->{path}' not in the index, will not install";
 907             $action = "test";
 908           }
 909         }
 910         if ($Opt{"reduce-perls-on-excursions"}) {
 911           while (@$perls > $Opt{parallel} + 1) {
 912             my $splice = rand scalar @$perls;
 913             splice @$perls, $splice, 1;
 914           }
 915         }
 916       }
 917
 918       # XXX: we should compute exceptions for every distro that has a
 919       # higher numbered developer release. Say Foo-1.4801 is released
 920       # but we have already 1.48_51 installed. We do not want this
 921       # stable stuff. Test yes, so we should 'make test' instead of
 922       # 'make install'. The problem with this is that we do not know
 923       # what exactly is in the distro. So we must go through
 924       # CPAN::DistnameInfo somehow. It gets even more complicated when
 925       # the item here gets passed to a queuerunner because then the
 926       # decision if test or install shall be called cannot be made now,
 927       # it must be made when the job is actually started.
 928
 929       # Update 2017-07-04:
 930       # https://github.com/eserte/srezic-misc/blob/master/scripts/cpan_recent_uploads2#L225
 931       # how slaven decides to limit operations on indexed distros (we
 932       # talked about the gotcha with downgrading XML::LibXML::Common)
 933       # Update 2017-09-06: commit
 934       # 6d12ff99b9b4a60494f7ab1bd959e1811cc3030b introduced this
 935       # algorithm
 936
 937       if (@$optdstrs) {
 938         # need no sanity check on path or anything
 939       } else {
 940         my $abs = File::Spec->catfile($rf->localroot, $upload->{path});
 941         {
 942           local $| = 1;
 943           my $max = 1200;
 944           my $slept = 0;
 945           while (! -f $abs) {
 946             print ",";
 947             $slept += sleep 0.5;
 948             if ($slept > $max) {
 949               warn "Giving up waiting for '$abs', maybe already deleted?";
 950               next UPLOADITEM;
 951             }
 952           }
 953         }
 954       }
 955       iterate_over_perls($perls, $upload, $cmbsn, $action, $chldr);
 956       if ($Signal>=2) {
 957         last ITERATION;
 958       }
 959       $cmbsn->{"ALL",$upload->{path}} = $upload->{epoch};
 960       if (@$optdstrs) {
 961         next UPLOADITEM; # nothing can change that would influence us
 962       } elsif ($historical_excursion) {
 963         sleep 1;
 964         next ITERATION;
 965       } else {
 966         next ITERATION; # see what is new before simply going through the ordered list
 967       }
 968     } # UPLOADITEM
 969     if (@$optdstrs) {
 970       last ITERATION; # nothing left to do
 971     }
 972     my $minimum_time_per_loop = 15;
 973     while (time - $iteration_start < $minimum_time_per_loop) {
 974       my @stat = stat($recentfile);
 975       last if $stat[9] > $iteration_start;
 976       last if $Signal;
 977       sleep 1;
 978     }
 979     for my $k (keys %$cmbsn) {
 980       delete $cmbsn->{$k} if $cmbsn->{$k} < time - 60*60*24*2;
 981     }
 982     { local $| = 1; print "."; } # painting dots
 983   } # ITERATION
 984
 985   log_debug("End of Iteration. Left-over children %d", scalar @$chldr);
 986   while (@$chldr){
 987     for (my $i = $#$chldr; $i; $i--){
 988       if (waitpid($chldr->[$i], WNOHANG) > 0){
 989         openlog "smoke", "pid", "local0";
 990         syslog "info", "reaped proc|->$chldr->[$i]";
 991         closelog;
 992         splice @$chldr, $i, 1;
 993       }
 994     }
 995     if ($Signal) {
 996       warn "giving up on signal";
 997       last;
 998     }
 999     warn "will have to wait for children[@$chldr]";
1000     while (my $c = pop @$chldr){
1001       if (waitpid($c, 0) > 0){
1002         warn "Finished child: $c";
1003         openlog "smoke", "pid", "local0";
1004         syslog "info", "reaped proc|->$c";
1005         closelog;
1006       }
1007     }
1008   }
1009   log_debug("all children reaped");
1010   print "all children reaped\n";
1011
1012 }
1013
1014 sub sanity_check {
1015   # cleanup => 1 only active at program exit, not at scope exit!
1016   return if $Opt{skip_sanity_check};
1017  DFTEST: while () {
1018     my $cannotcontinuenow = 0;
1019     for my $dir ($Opt{tmpdir},
1020                  ".",
1021                  "/var/tmp", # these bloody testers write everywhere,
1022                              # sometimes in /var/lib/ for databases,
1023                              # this is a proxy for this case
1024                 ) {
1025       my $tmpdir = eval { File::Temp::tempdir(
1026                                        "loop-over-recent-XXXXXX",
1027                                        DIR => $dir,
1028                                       ) } or die "Could not create tempdir in '$dir': $!";
1029       my $ttt = "$tmpdir/testfreespace";
1030       open my $fh, ">", $ttt or die "Could not open > '$ttt': $!";
1031       for (1..100) {
1032         # 32 bytes times 2**15 equals 1 MB
1033         print $fh "f r e e e e s p a c e <%-1/8-\> " x 2**15;
1034         print $fh "\n";
1035       }
1036       my $success = 0;
1037       $success = close $fh;
1038       rmtree $tmpdir;
1039       unless ($success){
1040         warn "Couldn't close '$ttt': $!";
1041         $cannotcontinuenow = 1;
1042       }
1043     }
1044     if ($cannotcontinuenow) {
1045       warn "$$: n o   f r e e s p a c e\n" for 1..8;
1046       last if $Signal;
1047       sleep(30 + rand(180));
1048     } else {
1049       last DFTEST;
1050     }
1051   }
1052   open my $fh, "-|", "ipcs -m" or die "Could not fork ipcs -m: $!";
1053   my $shared_mem_segments = 0;
1054   while (<$fh>) {
1055     next unless /sand/;
1056     $shared_mem_segments++;
1057   }
1058   if ($shared_mem_segments > 4000) {
1059     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};
1060   } elsif ($shared_mem_segments > 1000) {
1061     warn sprintf "Info: (%s) allocated shared mem segments now: %d\n", $0, $shared_mem_segments;
1062   }
1063 }
1064
1065 __END__
1066
1067 # Local Variables:
1068 # mode: cperl
1069 # cperl-indent-level: 2
1070 # End: