summaryrefslogtreecommitdiff
path: root/Porting
diff options
context:
space:
mode:
authorJarkko Hietaniemi <jhi@iki.fi>2001-11-29 00:05:19 +0000
committerJarkko Hietaniemi <jhi@iki.fi>2001-11-29 00:05:19 +0000
commit6e7dc4a9869194bb3f662df909b6e96efc33ebf0 (patch)
treea49964640a3f4a65b4e7d4612c76637d49250934 /Porting
parenta6596f262dc1e678047991a47da7123947ebae11 (diff)
downloadperl-6e7dc4a9869194bb3f662df909b6e96efc33ebf0.tar.gz
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
Diffstat (limited to 'Porting')
-rw-r--r--Porting/checkURL.pl76
1 files changed, 76 insertions, 0 deletions
diff --git a/Porting/checkURL.pl b/Porting/checkURL.pl
new file mode 100644
index 0000000000..1d81cac781
--- /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__