syswrite() wasn't reporting a warning when writing to a filehandle

[perl5.git] / Porting / checkURL.pl

diff --git a/Porting/checkURL.pl b/Porting/checkURL.pl
index 1d81cac..db55c49 100644 (file)
--- a/Porting/checkURL.pl
+++ b/Porting/checkURL.pl
@@ -4,9 +4,7 @@ use strict;
 use warnings 'all';
 
 use LWP::Simple qw /$ua getstore/;
-use Errno;
 
-my $out = "links.out";
 my %urls;
 
 my @dummy = qw(
@@ -17,7 +15,7 @@ my %dummy;
 
 @dummy{@dummy} = ();
 
-foreach my $file (<pod/*.pod README README.* INSTALL>) {
+foreach my $file (<*/*.pod */*/*.pod */*/*/*.pod README README.* INSTALL>) {
     open my $fh => $file or die "Failed to open $file: $!\n";
     while (<$fh>) {
         if (m{(?:http|ftp)://(?:(?!\w<)[-\w~?@=.])+} && !exists $dummy{$&}) {
@@ -30,36 +28,51 @@ foreach my $file (<pod/*.pod README README.* INSTALL>) {
     close $fh;
 }
 
+sub fisher_yates_shuffle {
+    my $deck = shift;  # $deck is a reference to an array
+    my $i = @$deck;
+    while (--$i) {
+       my $j = int rand ($i+1);
+       @$deck[$i,$j] = @$deck[$j,$i];
+    }
+}
+
 my @urls = keys %urls;
 
+fisher_yates_shuffle(\@urls);
+
+sub todo {
+    warn "(", scalar @urls, " URLs)\n";
+}
+
+my $MAXPROC = 40;
+my $MAXURL  = 10;
+my $MAXFORK = $MAXPROC < $MAXURL ? 1 : $MAXPROC / $MAXURL;
+
+select(STDERR); $| = 1;
+select(STDOUT); $| = 1;
+
 while (@urls) {
-    my @list = splice @urls, 0, 10;
+    my @list;
     my $pid;
-    my $retry;
-    my $retrymax = 3;
-    my $nap = 5;
-    do {
+    my $i;
+
+    todo();
+
+    for ($i = 0; $i < $MAXFORK; $i++) {
+       $list[$i] = [ splice @urls, 0, $MAXURL ];
        $pid = fork;
-       unless (defined $pid) {
-           if ($!{EAGAIN}) {
-               warn "Failed to fork: $!\n";
-               if ($retry++ < $retrymax) {
-                   warn "(sleeping...)\n";
-                   sleep $nap;
-               } else {
-                   $nap  *= 2;
-                   $retry = 0;
-               }
-               redo;
-           } else {
-               die "Failed to fork: $!\n" unless defined $pid;
-           }
-       }
-    } until (defined $pid);
-
-    unless ($pid) {
+       die "Failed to fork: $!\n" unless defined $pid;
+       last unless $pid; # Child.
+    }
+
+    if ($pid) {
+        # Parent.
+       warn "(waiting)\n";
+       1 until -1 == wait; # Reap.
+    } else {
         # Child.
-        foreach my $url (@list) {
+        foreach my $url (@{$list[$i]}) {
             my $code = getstore $url, "/dev/null";
             next if $code == 200;
             my $f = join ", " => keys %{$urls {$url}};
@@ -70,7 +83,4 @@ while (@urls) {
     }
 }
 
-1 until -1 == wait;
-
-
 __END__