1 #!/usr/bin/perl -- -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
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
11 loop-over-recent.pl [OPTIONS]
20 my $optpod = <<'=back';
24 Defaults to C<install>. Other supported values are
31 Takes one argument of the form C<v5.15.7-109-g035b682,v5.15.5>.
32 Incompatible with C<--perlglob>.
34 NOT IMPLEMENTED. Needs more work to find out whether a child had
35 success with its task.
37 =item B<--config_test_report=s>
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.
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.
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>.
58 Another bonus feature: string is split on comma and whitespace and
59 then converted to multiple --distro arguments.
61 Third bonus feature: if an argument looks like an http URL, it is
62 shortened to a distro argument.
64 =item B<--dotcpanhome=s>
66 defaults to C< $ENV{HOME}/.cpan >. The place passed to every
67 smoker-perl where it should pick the MyConfig from.
73 =item B<--historical-excursions-arraysize=i>
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.
81 when determining the config file, use this hostname.
83 =item B<--initial-backlog=i>
85 That many recentfiles we are trying to process iff this is a proper
86 loop run (no --distro arg). Defaults to 4096.
90 Turn logging on. Defaults to off.
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.
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
110 Perform not more loops than this many.
112 =item B<--monitoring=s>
114 Defaults to the string C<default>, which means the parent process
115 printd a line like this every second:
117 ==========monitoring proc 28683 perl /home/src/perl/repoperls/installed-perls/perl/v5.16.3/a2da secs 6.0000=======
119 Other possible values:
121 silent parent prints nothing
123 =item B<--mydistrobundles!>
125 Shortcut for several frequently used --distro=... options. Hardcoded
126 in the program. RTFS.
128 =item B<--parallel=i>
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.
133 =item B<--perlglob=s@>
135 Instead of using the perls from the configuration, use those specified
136 in the glob expression. Repeatable. Incompatible with C<--bisect>.
138 =item B<--randomskip=f>
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.
144 =item B<--reduce-perls-on-excursions!>
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.
150 =item B<--skip_sanity_check!>
152 Normally we allocate big files every now and then to verify we have
153 disk space available.
157 Sleep that many seconds after every build.
159 =item B<--statefile=s>
161 File holding a timestamp of the most recent distro we have processed.
165 do not install, only test. Equivalent to
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.
177 In the two places where we use a temporary file or directory, use
178 this directory as base.
180 =item B<--transient_build_dir!>
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
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
209 our $HAVE_SHUFFLE = eval { require Algorithm
::Numerical
::Shuffle
};
211 use CPAN
::DistnameInfo
;
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);
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);
226 our $HAVE_DD = eval { require Data
::Dump
};
228 # indirect dependencies:
232 if (-e
"/home/k/sources/rersyncrecent/lib/") {
234 lib
->import("/home/k/sources/rersyncrecent/lib/");
237 our $HAVE_RRR = eval { require File
::Rsync
::Mirror
::Recent
};
240 my @opt = $optpod =~ /B<--(\S+)>/g;
248 pod2usage
(0) if $Opt{help
};
249 pod2usage
(1) if @ARGV;
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;
255 if ($Opt{"historical-excursions-arraysize"} && !$HAVE_SHUFFLE) {
256 warn "WARNING: will fail soonish because Shuffle missing, better install Algorithm::Numerical::Shuffle now";
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";
272 require Log
::ger
::Util
;
273 Log
::ger
::Util
::set_level
("debug");
274 require Log
::ger
::Output
;
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);
284 *log_debug
= sub { };
286 if (my $d = $Opt{distro
}) {
290 push @d2, split /[,\s]+/, $d0;
292 $d = $Opt{distro
} = \
@d2;
294 if (/-/ and not m
|/|) {
297 s
|^https?
://.+?
/authors/id/[A-Z]/[A
-Z
]{2}/||;
300 } elsif (! $HAVE_RRR) {
301 die "this perl ($^X) has no File::Rsync::Mirror::Recent available, so we must have a --distro option specified";
303 if ($Opt{perlglob
} && $Opt{bisect
}) {
304 die "The options perlglob and bisect cannot be used together";
306 if ($Opt{mydistrobundles
}) {
308 my $date = "2011_10_21";
309 my @snaps = glob "$Opt{dotcpanhome}/Bundle/Snapshot_${date}_*.pm";
311 my($n) = $s =~ /Snapshot_${date}_(\d+)/;
312 push @
{$Opt{distro
}}, "Bundle::Snapshot_${date}_$n";
321 sub determine_perls
{
322 my($perls_config_file) = @_;
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) {
331 s/#.*//; # remove comments
332 next if /^\s*$/; # remove empty/white lines
334 s
|^|/home/sand
/src/perl
/repoperls/installed
-perls
/$path_slice_for_perl/|;
337 next if ! -x
$_ && ! $Opt{makeperl
};
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) {
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 (?)
356 log_debug
("Killing %s with -15", $pid);
358 for my $c (qw(k i l l e d)) {
366 sleep 0.5; # give them a chance to ^C immediately again
367 my $ret = waitpid($pid, WNOHANG
);
369 warn "Warning: process $ret returned \$\?=$?.
371 Command was '@$system'
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") {
383 if ($have_waited >= $Opt{timeout
}) {
384 log_debug
("Killing with -15 %s", { pid
=>$pid, upload
=> $upload });
386 for my $c (qw(k i l l e d)) {
391 log_debug
("Killing with -9 %s", { pid
=>$pid, upload
=> $upload });
395 warn "ATTN-ATTN-ATTN-ATTN-ATTN-ATTN-ATTN-ATTN-ATTN-ATTN-ATTN-ATTN\n";
396 warn " Something went wrong during\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";
405 log_debug
("End of job %s", {pid
=> $pid, upload
=> $upload});
407 warn "Sleeping $Opt{sleep} seconds now\n";
413 my($chldr,$action,$distro,$perl,$upload,$combo,$cmbsn) = @_;
416 if (! defined $pid) { # contention
417 warn "Contention '$!', sleeping 2";
420 } elsif ($pid) { # parent
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]";
428 splice @
$chldr, $i, 1;
431 sleep 0.01; # wait until some job finishes, we are at maximum
434 one_fork
($action,$distro,$perl,$upload,$combo);
441 $cmbsn->{$perl,$upload->{path
}} = $upload->{epoch
};
445 my($action,$distro,$perl,$upload,$combo) = @_;
446 log_debug
("Entering one_fork %s",
456 "-I$Opt{dotcpanhome}",
462 my $bdir; # build directory
465 my @actions = split " ", $action;
466 push @actions, $distro;
467 my $f = shift @actions;
468 $func = sprintf "%s(%s)", $f, join(",",map {"q{$_}"} @actions);
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",
477 CLEANUP
=> 0, # we clean up ourselves
479 # *this* program exit
481 warn "DEBUG: bdir[$bdir] \$\$[$$]\n";
482 push @system, "\$CPAN::Config->{build_dir}=q{$bdir}; $commonshellcmd",
484 push @system, "\$CPAN::Config->{build_dir_reuse}=0; $commonshellcmd",
486 # 0==system @system or die;
489 if (! defined $pid) { # contention
490 warn "Contention '$!', sleeping 2";
492 } elsif ($pid) { # parent
493 single_child_parental_control
($pid,\
@system,$perl,$upload);
495 warn sprintf "%s: About to rmtree '%s'", scalar localtime, $bdir;
503 openlog
"smoke", "pid", "local0";
504 syslog
"info", "$combo\nproc|->$$";
507 my ($soft, $hard) = BSD
::Resource
::getrlimit
(+BSD
::Resource
::RLIMIT_CPU
);
509 BSD
::Resource
::setrlimit
(+BSD
::Resource
::RLIMIT_CPU
, 0.9*3600, 1*3600);
511 exec @system or sleep 1; # give them a chance to ^C immediately again
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 });
525 my($lockfile) = File
::Spec
->catfile($perlroot,"LOGCK");
527 unless (open $lfh, "+<", $lockfile) {
528 unless ( open $lfh, ">>", $lockfile ) {
529 die "ALERT: Could not open >> '$lockfile': $!"; # XXX should not die
531 unless ( open $lfh, "+<", $lockfile ) {
532 die "ALERT: Could not open +< '$lockfile': $!"; # XXX should not die
535 if (flock $lfh, LOCK_EX
|LOCK_NB
) {
536 warn "Info[$$]: Got the lock, continuing";
538 warn "FATAL[$$]: lockfile '$lockfile' locked by a different process; skipping this perl";
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"],
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",
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",
584 my($hash,$pdir) = fileparse
($perlroot); # ("127e","/home/sand/src/....")
586 my($tag) = fileparse
($pdir);
587 my $opts = $map{$hash};
589 print $lfh "Could not determine arguments for hash[$hash] mperl[$mperl]\n";
592 my $bindir = dirname
(__FILE__
);
596 "$bindir/makeperl.pl",
600 "--notest", # TODO: FIXME: should only turn off testing when necessary
602 warn "prepare a clone to run system[@system2]";
603 my $clonedir = File
::Temp
::tempdir
605 "loop_over_clonedir-$$-XXXXXX",
607 CLEANUP
=> 1, # we clean up
608 # ourselves much earlier than *this* program exit
611 print $lfh "Could not create a clonedir: $!\n";
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";
626 "Alert: %s: problem building perl %s/%s with '%s'",
632 chdir $cwd or die "could not chdir back to '$cwd': $!"; # XXX should not die
633 File
::Path
::remove_tree
($clonedir);
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 ];
643 $recent_events = [ grep {
644 my $path = $_->{path
};
645 my $d = CPAN
::DistnameInfo
->new($path);
647 # warn "no dist for path[$path]" unless $dist;
648 $dist ?
!$seen{$dist}++ : "";
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;
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
665 if ($Opt{"makeperl"}) {
669 next PERL
unless -e
$perl;
671 do { open my $fh, "$perl -e \"print \$]\" |" or die "Couldn't open $perl: $!";
674 unless ($perl_version) {
675 warn "Alert: could not determine perl version of '$perl', skipping";
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");
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
};
691 $epoch_as_localtime = $upload_epoch = "N/A";
693 my $combo = "perl|-> $perl (=$perl_version)\npath|-> $upload->{path}\n".
694 "recv|-> $epoch_as_localtime (=$upload_epoch)\ntime|-> $testtime";
696 } elsif ($cmbsn->{$perl,$upload->{path
}}){
697 warn "dead horses combo $combo";
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
};
711 if ($Opt{parallel
} <= 1) {
712 one_fork
($action,$distro,$perl,$upload,$combo);
714 some_forks
($chldr,$action,$distro,$perl,$upload,$combo,$cmbsn);
723 my $recentfile = "/home/ftp/pub/PAUSE/authors/RECENT.recent";
725 # local is for reading the recentfiles, localroot is for reading the
726 # files. one should go away.
728 $rf = File
::Rsync
::Mirror
::Recent
->new
730 localroot
=> "/home/ftp/pub/PAUSE/authors/",
731 local => $recentfile,
733 my $hostname = $Opt{hostname
} || hostname
();
734 if ($hostname =~ s/\..*//) {
735 warn "Warning: hostname contained a dot, shortening to '$hostname'";
737 my $perls_config_file;
738 if ($hostname eq "k75") {
739 $perls_config_file = "$0.otherperls";
740 } elsif ($Opt{perlglob
} || $Opt{bisect
}) {
743 $perls_config_file = "$0.otherperls.$hostname";
744 if (-f
$perls_config_file) {
745 warn "Using perls config '$perls_config_file'";
747 die "Could not find '$perls_config_file'";
751 if ($Opt{statefile
}) {
752 $statefile = $Opt{statefile
};
754 my $bbname = fileparse
($0,qr{\.pl});
755 $statefile = "$ENV{HOME}/.cpan/$bbname.state";
757 my $rx = qr!\.(tar.gz|tar.bz2|zip|tgz|tbz)$!;
758 my $max_epoch_worked_on = 0;
761 my $state = do { open my $fh, $statefile or die "Couldn't open '$statefile': $!";
767 $max_epoch_worked_on = $state if $state;
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);
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
};
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
782 BSD
::Resource
::setrlimit
(BSD
::Resource
::RLIMIT_AS
(), 3_000_000_000
, 4_000_000_000
);
784 # BSD::Resource::setrlimit(BSD::Resource::RLIMIT_FSIZE(), 4_000_000_000, 4_000_000_000);
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.
790 # BSD::Resource::setrlimit(BSD::Resource::RLIMIT_NPROC(), 256, 512);
792 my $cmbsn = {}; # was: %comboseen
793 my $count_uploaditem = 0;
794 my $chldr = []; # was: @children
795 ITERATION
: while () {
797 my $optdstrs = $Opt{distro
}||[]; # was: @distro
798 my $iteration_start = time;
800 my $historical_excursion = 0;
802 $recent_events = [map {+{path
=> $_}} @
$optdstrs];
804 $recent_events = read_recent_events
($rf,$rx);
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";
814 $HAVE_SHUFFLE = eval { require Algorithm
::Numerical
::Shuffle
};
816 Algorithm
::Numerical
::Shuffle
::shuffle
($recent_events);
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;
822 @
$recent_events = reverse @
$recent_events;
827 if ($Opt{perlglob
}) {
828 my @globs = @
{$Opt{perlglob
}};
830 for my $glob (@globs) {
831 my @perls = glob $glob;
832 push @allperls, @perls;
836 UPLOADITEM
: for my $upload (@
$recent_events) {
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
};
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;
857 } elsif ($upload->{epoch
} == $max_epoch_worked_on) {
858 if ($cmbsn->{"ALL",$upload->{path
}}) {
861 warn "Maybe already worked on, we'll retry them: $upload->{path}";
863 if ($historical_excursion) {
864 for (qw(h i s t o r i c a l)) {
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 ";
875 $max_epoch_worked_on = $upload->{epoch
};
878 if ($Opt{max
} && ++$count_uploaditem > $Opt{max
}){
879 log_debug
("Reached last loop %d", $count_uploaditem);
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
889 } elsif ($Opt{test
}) {
891 } elsif ($historical_excursion) {
892 if ($action ne "test") {
894 my $do = eval { CPAN
::Shell
->expand('Distribution', $upload->{path
}) };
896 warn "Warning: '$upload->{path}' not in the index, will not install";
900 if ($Opt{"reduce-perls-on-excursions"}) {
901 while (@
$perls > $Opt{parallel
} + 1) {
902 my $splice = rand scalar @
$perls;
903 splice @
$perls, $splice, 1;
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.
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
928 # need no sanity check on path or anything
930 my $abs = File
::Spec
->catfile($rf->localroot, $upload->{path
});
939 warn "Giving up waiting for '$abs', maybe already deleted?";
945 iterate_over_perls
($perls, $upload, $cmbsn, $action, $chldr);
949 $cmbsn->{"ALL",$upload->{path
}} = $upload->{epoch
};
951 next UPLOADITEM
; # nothing can change that would influence us
952 } elsif ($historical_excursion) {
956 next ITERATION
; # see what is new before simply going through the ordered list
960 last ITERATION
; # nothing left to do
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;
969 for my $k (keys %$cmbsn) {
970 delete $cmbsn->{$k} if $cmbsn->{$k} < time - 60*60*24*2;
972 { local $| = 1; print "."; } # painting dots
975 log_debug
("End of Iteration. Left-over children %d", scalar @
$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]";
982 splice @
$chldr, $i, 1;
986 warn "giving up on signal";
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";
999 log_debug
("all children reaped");
1000 print "all children reaped\n";
1005 # cleanup => 1 only active at program exit, not at scope exit!
1006 return if $Opt{skip_sanity_check
};
1008 my $cannotcontinuenow = 0;
1009 for my $dir ($Opt{tmpdir
},
1011 "/var/tmp", # these bloody testers write everywhere,
1012 # sometimes in /var/lib/ for databases,
1013 # this is a proxy for this case
1015 my $tmpdir = eval { File
::Temp
::tempdir
(
1016 "loop-over-recent-XXXXXX",
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': $!";
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;
1027 $success = close $fh;
1030 warn "Couldn't close '$ttt': $!";
1031 $cannotcontinuenow = 1;
1034 if ($cannotcontinuenow) {
1035 warn "$$: n o f r e e s p a c e\n" for 1..8;
1037 sleep(30 + rand(180));
1042 open my $fh, "-|", "ipcs -m" or die "Could not fork ipcs -m: $!";
1043 my $shared_mem_segments = 0;
1046 $shared_mem_segments++;
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;
1059 # cperl-indent-level: 2