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__