This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add Abigail's link checker with the following tweaks:
[perl5.git] / Porting / checkURL.pl
1 #!/usr/bin/perl
2
3 use strict;
4 use warnings 'all';
5
6 use LWP::Simple qw /$ua getstore/;
7 use Errno;
8
9 my $out = "links.out";
10 my %urls;
11
12 my @dummy = qw(
13            http://something.here
14            http://www.pvhp.com
15               );
16 my %dummy;
17
18 @dummy{@dummy} = ();
19
20 foreach my $file (<pod/*.pod README README.* INSTALL>) {
21     open my $fh => $file or die "Failed to open $file: $!\n";
22     while (<$fh>) {
23         if (m{(?:http|ftp)://(?:(?!\w<)[-\w~?@=.])+} && !exists $dummy{$&}) {
24             my $url = $&;
25             $url =~ s/\.$//;
26             $urls {$url} ||= { };
27             $urls {$url} {$file} = 1;
28         }
29     }
30     close $fh;
31 }
32
33 my @urls = keys %urls;
34
35 while (@urls) {
36     my @list = splice @urls, 0, 10;
37     my $pid;
38     my $retry;
39     my $retrymax = 3;
40     my $nap = 5;
41     do {
42         $pid = fork;
43         unless (defined $pid) {
44             if ($!{EAGAIN}) {
45                 warn "Failed to fork: $!\n";
46                 if ($retry++ < $retrymax) {
47                     warn "(sleeping...)\n";
48                     sleep $nap;
49                 } else {
50                     $nap  *= 2;
51                     $retry = 0;
52                 }
53                 redo;
54             } else {
55                 die "Failed to fork: $!\n" unless defined $pid;
56             }
57         }
58     } until (defined $pid);
59
60     unless ($pid) {
61         # Child.
62         foreach my $url (@list) {
63             my $code = getstore $url, "/dev/null";
64             next if $code == 200;
65             my $f = join ", " => keys %{$urls {$url}};
66             printf "%03d  %s: %s\n" => $code, $url, $f;
67         }
68
69         exit;
70     }
71 }
72
73 1 until -1 == wait;
74
75
76 __END__