-#!/usr/bin/perl
-
+#!perl
use strict;
-use warnings 'all';
+use warnings;
+use autodie;
+use feature qw(say);
+require File::Find::Rule;
+require File::Slurp;
+require File::Spec;
+require IO::Socket::SSL;
+use List::Util qw(sum);
+require LWP::UserAgent;
+require Net::FTP;
+require Parallel::Fork::BossWorkerAsync;
+require Term::ProgressBar::Simple;
+require URI::Find::Simple;
+$| = 1;
+
+my %ignore;
+while ( my $line = <main::DATA> ) {
+ chomp $line;
+ next if $line =~ /^#/;
+ next unless $line;
+ $ignore{$line} = 1;
+}
+
+my $ua = LWP::UserAgent->new(ssl_opts => { verify_hostname => 0 });
+$ua->timeout(58);
+$ua->env_proxy;
+
+my @filenames = @ARGV;
+@filenames = sort grep { $_ !~ /^\.git/ } File::Find::Rule->new->file->in('.')
+ unless @filenames;
+
+my $total_bytes = sum map {-s} @filenames;
+
+my $extract_progress = Term::ProgressBar::Simple->new(
+ { count => $total_bytes,
+ name => 'Extracting URIs',
+ }
+);
+
+my %uris;
+foreach my $filename (@filenames) {
+ next if $filename =~ /uris\.txt/;
+ next if $filename =~ /check_uris/;
+ next if $filename =~ /\.patch$/;
+ next if $filename =~ 'cpan/Pod-Simple/t/perlfaqo?\.pod';
+ next if $filename =~ /checkURL\.pl$/;
+ my $contents = File::Slurp::read_file($filename);
+ my @uris = URI::Find::Simple::list_uris($contents);
+ foreach my $uri (@uris) {
+ next unless $uri =~ /^(http|ftp)/;
+ next if $ignore{$uri};
+
+ # no need to hit rt.perl.org
+ next
+ if $uri =~ m{^https?://rt.perl.org/rt3/Ticket/Display.html?id=\d+$};
+
+ # no need to hit rt.cpan.org
+ next
+ if $uri =~ m{^https?://rt.cpan.org/Public/Bug/Display.html?id=\d+$};
-use LWP::Simple qw /$ua getstore/;
+ # no need to hit google groups (weird redirect LWP does not like)
+ next
+ if $uri =~ m{^http://groups\.google\.com/};
-my %urls;
+ push @{ $uris{$uri} }, $filename;
+ }
+ $extract_progress += -s $filename;
+}
+
+my $bw = Parallel::Fork::BossWorkerAsync->new(
+ work_handler => \&work_alarmed,
+ global_timeout => 120,
+ worker_count => 20,
+);
-my @dummy = qw(
- http://something.here
- http://www.pvhp.com
- );
-my %dummy;
+foreach my $uri ( keys %uris ) {
+ my @filenames = @{ $uris{$uri} };
+ $bw->add_work( { uri => $uri, filenames => \@filenames } );
+}
+
+undef $extract_progress;
-@dummy{@dummy} = ();
+my $fetch_progress = Term::ProgressBar::Simple->new(
+ { count => scalar( keys %uris ),
+ name => 'Fetching URIs',
+ }
+);
-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;
+my %filenames;
+while ( $bw->pending() ) {
+ my $response = $bw->get_result();
+ my $uri = $response->{uri};
+ my @filenames = @{ $response->{filenames} };
+ my $is_success = $response->{is_success};
+ my $message = $response->{message};
+
+ unless ($is_success) {
+ foreach my $filename (@filenames) {
+ push @{ $filenames{$filename} },
+ { uri => $uri, message => $message };
}
}
- close $fh;
+ $fetch_progress++;
}
+$bw->shut_down();
-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 $fh = IO::File->new('> uris.txt');
+foreach my $filename ( sort keys %filenames ) {
+ $fh->say("* $filename");
+ my @bits = @{ $filenames{$filename} };
+ foreach my $bit (@bits) {
+ my $uri = $bit->{uri};
+ my $message = $bit->{message};
+ $fh->say(" $uri");
+ $fh->say(" $message");
}
}
+$fh->close;
-my @urls = keys %urls;
+say 'Finished, see uris.txt';
-fisher_yates_shuffle(\@urls);
+sub work_alarmed {
+ my $conf = shift;
+ eval {
+ local $SIG{ALRM} = sub { die "alarm\n" }; # NB: \n required
+ alarm 60;
+ $conf = work($conf);
+ alarm 0;
+ };
+ if ($@) {
+ $conf->{is_success} = 0;
+ $conf->{message} = 'Timed out';
-sub todo {
- warn "(", scalar @urls, " URLs)\n";
+ }
+ return $conf;
}
-my $MAXPROC = 40;
-my $MAXURL = 10;
-my $MAXFORK = $MAXPROC < $MAXURL ? 1 : $MAXPROC / $MAXURL;
+sub work {
+ my $conf = shift;
+ my $uri = $conf->{uri};
+ my @filenames = @{ $conf->{filenames} };
-select(STDERR); $| = 1;
-select(STDOUT); $| = 1;
+ if ( $uri =~ /^http/ ) {
+ my $uri_without_fragment = URI->new($uri);
+ my $fragment = $uri_without_fragment->fragment(undef);
+ my $response = $ua->head($uri_without_fragment);
-while (@urls) {
- my @list;
- my $pid;
- my $i;
+ $conf->{is_success} = $response->is_success;
+ $conf->{message} = $response->status_line;
+ return $conf;
+ } else {
- todo();
+ my $uri_object = URI->new($uri);
+ my $host = $uri_object->host;
+ my $path = $uri_object->path;
+ my ( $volume, $directories, $filename )
+ = File::Spec->splitpath($path);
- for ($i = 0; $i < $MAXFORK; $i++) {
- $list[$i] = [ splice @urls, 0, $MAXURL ];
- $pid = fork;
- die "Failed to fork: $!\n" unless defined $pid;
- last unless $pid; # Child.
- }
+ my $ftp = Net::FTP->new( $host, Passive => 1, Timeout => 60 );
+ unless ($ftp) {
+ $conf->{is_succcess} = 0;
+ $conf->{message} = "Can not connect to $host: $@";
+ return $conf;
+ }
- if ($pid) {
- # Parent.
- warn "(waiting)\n";
- 1 until -1 == wait; # Reap.
- } else {
- # Child.
- foreach my $url (@{$list[$i]}) {
- my $code = getstore $url, "/dev/null";
- next if $code == 200;
- my $f = join ", " => keys %{$urls {$url}};
- printf "%03d %s: %s\n" => $code, $url, $f;
+ my $can_login = $ftp->login( "anonymous", '-anonymous@' );
+ unless ($can_login) {
+ $conf->{is_success} = 0;
+ $conf->{message} = "Can not login ", $ftp->message;
+ return $conf;
+ }
+
+ my $can_binary = $ftp->binary();
+ unless ($can_binary) {
+ $conf->{is_success} = 0;
+ $conf->{message} = "Can not binary ", $ftp->message;
+ return $conf;
}
- exit;
+ my $can_cwd = $ftp->cwd($directories);
+ unless ($can_cwd) {
+ $conf->{is_success} = 0;
+ $conf->{message} = "Can not cwd to $directories ", $ftp->message;
+ return $conf;
+ }
+
+ if ($filename) {
+ my $can_size = $ftp->size($filename);
+ unless ($can_size) {
+ $conf->{is_success} = 0;
+ $conf->{message}
+ = "Can not size $filename in $directories",
+ $ftp->message;
+ return $conf;
+ }
+ } else {
+ my ($can_dir) = $ftp->dir;
+ unless ($can_dir) {
+ my ($can_ls) = $ftp->ls;
+ unless ($can_ls) {
+ $conf->{is_success} = 0;
+ $conf->{message}
+ = "Can not dir or ls in $directories ",
+ $ftp->message;
+ return $conf;
+ }
+ }
+ }
+
+ $conf->{is_success} = 1;
+ return $conf;
}
}
+__DATA__
+# these are fine but give errors
+ftp://ftp.stratus.com/pub/vos/posix/ga/ga.html
+ftp://ftp.stratus.com/pub/vos/utility/utility.html
+
+# these are missing, sigh
+ftp://ftp.sco.com/SLS/ptf7051e.Z
+http://perlmonks.thepen.com/42898.html
+http://svn.mutatus.co.uk/wsvn/Scalar-List-Utils/trunk/
+http://public.activestate.com/cgi-bin/perlbrowse
+http://svn.mutatus.co.uk/browse/libnet/tags/libnet-1.17/ChangeLog
+http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631
+http://my.smithmicro.com/mac/stuffit/
+http://www.wg.omron.co.jp/cgi-bin/j-e/jfriedl.html
+http://persephone.cps.unizar.es/general/gente/spd/gzip/gzip.html
+
+# these are URI extraction bugs
+http://www.perl.org/E
+http://en.wikipedia.org/wiki/SREC_(file_format
+http://somewhere.else',-type=/
+ftp:passive-mode
+ftp:
+http:[-
+http://search.cpan.org/src/KWILLIAMS/Module-Build-0.30/lib/Module/Build/Platform/Windows.pm:split_like_shell
+http://www.xray.mpe.mpg.de/mailing-lists/perl5-
+http://support.microsoft.com/support/kb/articles/Q280/3/41.ASP:
+http://perl.come/
+http://www.perl.come/
+
+# these are used as an example
+http://example.com/
+http://something.here/
+http://users.perl5.git.perl.org/~yourlogin/
+http://github.com/USERNAME/perl/tree/orange
+http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi
+http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar
+http://somewhere.else$/
+http://somewhere.else$/
+http://somewhere.else/bin/foo&bar',-Type=
+http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi
+http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar
+http://www.perl.org/test.cgi
+http://cpan2.local/
+http://search.cpan.org/perldoc?
+http://cpan1.local/
+http://cpan.dev.local/CPAN
+http:///
+ftp://
+ftp://myurl/
+ftp://ftp.software.ibm.com/aix/fixes/v4/other/vac.C.5.0.2.6.bff
+http://www14.software.ibm.com/webapp/download/downloadaz.jsp
+http://www.cpan.org/modules/by-module/Archive/Archive-Zip-*.tar.gz
+http://www.unicode.org/Public/MAPPINGS/ISO8859/8859-*.TXT
+http://localhost/tmp/index.txt
+http://example.com/foo/bar.html
+http://example.com/Text-Bastardize-1.06.tar.gz
+ftp://example.com/sources/packages.txt
+http://example.com/sources/packages.txt
+http://example.com/sources
+ftp://example.com/sources
+http://some.where.com/dir/file.txt
+http://some.where.com/dir/a.txt
+http://foo.com/X.tgz
+ftp://foo.com/X.tgz
+http://foo/
+http://www.foo.com:8000/
+http://mysite.com/cgi-bin/log.cgi/http://www.some.other.site/args
+http://decoded/mirror/path
+http://a/b/c/d/e/f/g/h/i/j
+http://foo/bar.gz
+ftp://ftp.perl.org
+http://purl.org/rss/1.0/modules/taxonomy/
+ftp://ftp.sun.ac.za/CPAN/CPAN/
+ftp://ftp.cpan.org/pub/mirror/index.txt
+ftp://cpan.org/pub/mirror/index.txt
+http://example.com/~eh/
+http://plagger.org/.../rss
+http://umn.dl.sourceforge.net/mingw/gcc-g++-3.4.5-20060117-1.tar.gz
+http://umn.dl.sourceforge.net/mingw/binutils-2.16.91-20060119-1.tar.gz
+http://umn.dl.sourceforge.net/mingw/mingw-runtime-3.10.tar.gz
+http://umn.dl.sourceforge.net/mingw/gcc-core-3.4.5-20060117-1.tar.gz
+http://umn.dl.sourceforge.net/mingw/w32api-3.6.tar.gz
+http://search.cpan.org/CPAN/authors/id/S/SH/SHAY/dmake-4.5-20060619-SHAY.zip
+http://module-build.sourceforge.net/META-spec-new.html
+http://module-build.sourceforge.net/META-spec-v1.4.html
+http://www.cs.vu.nl/~tmgil/vi.html
+http://perlcomposer.sourceforge.net/vperl.html
+http://www.perl.com/CPAN/authors/Tom_Christiansen/scripts/rep
+http://w4.lns.cornell.edu/~pvhp/ptk/ptkTOC.html
+http://world.std.com/~aep/ptkdb/
+http://www.castlelink.co.uk/object_system/
+http://www.fh-wedel.de/elvis/
+ftp://ftp.blarg.net/users/amol/zsh/
+ftp://ftp.funet.fi/pub/languages/perl/CPAN
+http://search.cpan.org/CPAN/authors/id/S/SH/SHAY/dmake-4.5-20060619-SHAY.zip
+http://users.perl5.git.perl.org/~USERNAME
+http://foo/x//y/script.cgi/a//b
+http://xxx/script.cgi/http://foo
+http://foo/./x//z/script.cgi/a/../b//c
+http://somewhere.else/in/movie/land
+http://somewhere.else/finished.html
+http://somewhere.else/bin/foo&bar$
+http://somewhere.else/
+http://proxy:8484/
+http://proxy/
+http://myrepo.example.com/
+http://remote/source
+https://example.com/
+http://example.com:1024/
+http:///path?foo=bar
+http://[::]:1024/
+http://([/
+http://example.com:9000/index.html
+http://proxy.example.com:8080/
+http:///index.html
+http://[www.json::pp.org]/
+http://localhost/
+http://foo.example.com/
+http://abc.com/a.js
+http://whatever/man/1/crontab
+http://abc.com/c.js
+http://whatever/Foo%3A%3ABar
+http://abc.com/b.js
+http://remote.server.com/jquery.css
+http://some.other.com/page.html
+https://text.com/1/2
+https://text.com/1/2
+http://link.included.here?o=1&p=2
+http://link.included.here?o=1&p=2
+http://link.included.here?o=1&p=2
+http://link.included.here/
+http://foo/x//y/script.cgi/a//b
+http://xxx/script.cgi/http://foo
+http://foo/./x//z/script.cgi/a/../b//c
+http://somewhere.else/in/movie/land
+http://somewhere.else/finished.html
+http://webproxy:3128/
+http://www/
+
+# these are used to generate or match URLs
+http://www.cpan.org/modules/by-authors/id/$1/$1$2/$dist
+http://www.cpantesters.org/show/%s.yaml
+ftp://(.*?)/(.*)/(.*
+ftp://(.*?)/(.*)/(.*
+ftp://(.*?)/(.*)/(.*
+ftp://ftp.foo.bar/
+http://$host/
+http://wwwe%3C46/
+ftp:/
+http://$addr/mark?commit=$
+http://search.cpan.org/~
+http:/
+ftp:%5Cn$url
+http://www.ietf.org/rfc/rfc$2.txt
+http://search.cpan.org/~
+ftp:%5Cn$url
+
+# weird redirects that LWP doesn't like
+http://www.theperlreview.com/community_calendar
+http://www.software.hp.com/portal/swdepot/displayProductInfo.do?productNumber=PERL
+http://sunsolve.sun.com
+
+# broken webserver that doesn't like HEAD requests
+http://docs.sun.com/app/docs/doc/816-5168/syslog-3c?a=view
+http://www.w3.org/TR/html4/loose.dtd
+
+# these have been reported upstream to CPAN authors
+http://www.gnu.org/manual/tar/html_node/tar_139.html
+http://www.w3.org/pub/WWW/TR/Wd-css-1.html
+http://support.microsoft.com/support/kb/articles/Q280/3/41.ASP
+http://msdn.microsoft.com/workshop/author/dhtml/httponly_cookies.asp
+http://search.cpan.org/search?query=Module::Build::Convert
+http://www.refcnt.org/papers/module-build-convert
+http://csrc.nist.gov/cryptval/shs.html
+http://msdn.microsoft.com/workshop/author/dhtml/reference/charsets/charset4.asp
+http://www.debian.or.jp/~kubota/unicode-symbols.html.en
+http://www.mail-archive.com/perl5-porters@perl.org/msg69766.html
+http://www.debian.or.jp/~kubota/unicode-symbols.html.en
+http://rfc.net/rfc2781.html
+http://www.icu-project.org/charset/
+http://ppewww.ph.gla.ac.uk/~flavell/charset/form-i18n.html
+http://www.rfc-editor.org/
+http://www.rfc.net/
+http://www.oreilly.com/people/authors/lunde/cjk_inf.html
+http://www.oreilly.com/catalog/cjkvinfo/
+http://www.cpan.org/modules/by-author/Damian_Conway/Filter-Simple.tar.gz
+http://www.csse.monash.edu.au/~damian/CPAN/Filter-Simple.tar.gz
+http://www.egt.ie/standards/iso3166/iso3166-1-en.html
+http://www.bsi-global.com/iso4217currency
+http://www.plover.com/~mjd/perl/Memoize/
+http://www.plover.com/~mjd/perl/MiniMemoize/
+http://www.sysadminmag.com/tpj/issues/vol5_5/
+ftp://ftp.tpc.int/tpc/server/UNIX/
+http://www.nara.gov/genealogy/
+http://home.utah-inter.net/kinsearch/Soundex.html
+http://www.nara.gov/genealogy/soundex/soundex.html
+http://rfc.net/rfc3461.html
+ftp://ftp.cs.pdx.edu/pub/elvis/
+http://www.fh-wedel.de/elvis/
+http://lists.perl.org/list/perl-mvs.html
+http://www.cpan.org/ports/os2/
+http://github.com/dagolden/cpan-meta-spec
+http://github.com/dagolden/cpan-meta-spec/issues
+http://www.opensource.org/licenses/lgpl-license.phpt
+http://reality.sgi.com/ariel
+http://www.chiark.greenend.org.uk/pipermail/ukcrypto/1999-February/003538.html
+http://www.chiark.greenend.org.uk/pipermail/ukcrypto/1999-February/003538.html
+http://www.nsrl.nist.gov/testdata/
+http://public.activestate.com/cgi-bin/perlbrowse/p/31194
+http://public.activestate.com/cgi-bin/perlbrowse?patch=16173
+http://public.activestate.com/cgi-bin/perlbrowse?patch=16049
+http://www.li18nux.org/docs/html/CodesetAliasTable-V10.html
+http://aspn.activestate.com/ASPN/Mail/Message/perl5-porters/3486118
+http://lxr.mozilla.org/seamonkey/source/intl/uconv/ucvlatin/vps.ut
+http://lxr.mozilla.org/seamonkey/source/intl/uconv/ucvlatin/vps.uf
+http://github.com/schwern/extutils-makemaker
+https://github.com/dagolden/cpanpm/compare/master...private%2Fuse-http-lite
+http://www.json.org/JSON::PP_checker/
+ftp://ftp.kiae.su/pub/unix/fido/
+http://www.gallistel.net/nparker/weather/code/
+http://www.javaworld.com/javaworld/jw-09-2001/jw-0928-ntmessages.html
+ftp://ftp-usa.tpc.int/pub/tpc/server/UNIX/
+http://www.cis.ohio-state.edu/htbin/rfc/rfc959.html
+http://public.activestate.com/cgi-bin/perlbrowse/p/33567
+http://public.activestate.com/cgi-bin/perlbrowse/p/33566
+http://www.dsmit.com/cons/
+http://www.makemaker.org/wiki/index.cgi?ModuleBuildConversionGuide
+
__END__
+
+=head1 NAME
+
+checkURL.pl - Check that all the URLs in the Perl source are valid
+
+=head1 DESCRIPTION
+
+This program checks that all the URLs in the Perl source are valid. It
+checks HTTP and FTP links in parallel and contains a list of known
+bad example links in its source. It takes 4 minutes to run on my
+machine. The results are written to 'uris.txt' and list the filename,
+the URL and the error:
+
+ * ext/Locale-Maketext/lib/Locale/Maketext.pod
+ http://sunsite.dk/RFC/rfc/rfc2277.html
+ 404 Not Found
+ ...
+
+It should be run every so often and links fixed and upstream authors
+notified.
+
+Note that the web is unstable and some websites are temporarily down.
https://perl5.git.perl.org / perl5.git / blobdiff