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