From: Jarkko Hietaniemi <jhi@iki.fi>
Date: Thu, 29 Nov 2001 00:05:19 +0000 (+0000)
Subject: Add Abigail's link checker with the following tweaks:
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=6e7dc4a9869194bb3f662df909b6e96efc33ebf0;p=p5sagit%2Fp5-mst-13.2.git

Add Abigail's link checker with the following tweaks:
- known dummy URLs (Peter Prymmer)
- do also READMEs and INSTALL (Michael Schwern)
- do also ftp URLs
- add fork retry loop in case the allowed number
  of processes per user is low

p4raw-id: //depot/perl@13344
---

diff --git a/Porting/checkURL.pl b/Porting/checkURL.pl
new file mode 100644
index 0000000..1d81cac
--- /dev/null
+++ b/Porting/checkURL.pl
@@ -0,0 +1,76 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings 'all';
+
+use LWP::Simple qw /$ua getstore/;
+use Errno;
+
+my $out = "links.out";
+my %urls;
+
+my @dummy = qw(
+	   http://something.here
+	   http://www.pvhp.com
+	      );
+my %dummy;
+
+@dummy{@dummy} = ();
+
+foreach my $file (<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{$&}) {
+            my $url = $&;
+            $url =~ s/\.$//;
+            $urls {$url} ||= { };
+            $urls {$url} {$file} = 1;
+        }
+    }
+    close $fh;
+}
+
+my @urls = keys %urls;
+
+while (@urls) {
+    my @list = splice @urls, 0, 10;
+    my $pid;
+    my $retry;
+    my $retrymax = 3;
+    my $nap = 5;
+    do {
+	$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) {
+        # Child.
+        foreach my $url (@list) {
+            my $code = getstore $url, "/dev/null";
+            next if $code == 200;
+            my $f = join ", " => keys %{$urls {$url}};
+            printf "%03d  %s: %s\n" => $code, $url, $f;
+        }
+
+        exit;
+    }
+}
+
+1 until -1 == wait;
+
+
+__END__