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