[perl5.git] / Porting / checkURL.pl

#!perl
use strict;
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 github
        next
            if $uri =~ m{^https?://(?:www\.)?github\.com/[pP]erl/perl5/issues/\d+$};

        # no need to hit rt.cpan.org
        next
            if $uri =~ m{^https?://rt.cpan.org/Public/Bug/Display.html?id=\d+$};

        # no need to hit google groups (weird redirect LWP does not like)
        next
            if $uri =~ m{^http://groups\.google\.com/};

        push @{ $uris{$uri} }, $filename;
    }
    $extract_progress += -s $filename;
}

my $bw = Parallel::Fork::BossWorkerAsync->new(
    work_handler   => \&work_alarmed,
    global_timeout => 120,
    worker_count   => 20,
);

foreach my $uri ( keys %uris ) {
    my @filenames = @{ $uris{$uri} };
    $bw->add_work( { uri => $uri, filenames => \@filenames } );
}

undef $extract_progress;

my $fetch_progress = Term::ProgressBar::Simple->new(
    {   count => scalar( keys %uris ),
        name  => 'Fetching URIs',
    }
);

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 };
        }
    }
    $fetch_progress++;
}
$bw->shut_down();

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;

say 'Finished, see uris.txt';

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';

    }
    return $conf;
}

sub work {
    my $conf      = shift;
    my $uri       = $conf->{uri};
    my @filenames = @{ $conf->{filenames} };

    if ( $uri =~ /^http/ ) {
        my $uri_without_fragment = URI->new($uri);
        my $fragment             = $uri_without_fragment->fragment(undef);
        my $response             = $ua->head($uri_without_fragment);

        $conf->{is_success} = $response->is_success;
        $conf->{message}    = $response->status_line;
        return $conf;
    } else {

        my $uri_object = URI->new($uri);
        my $host       = $uri_object->host;
        my $path       = $uri_object->path;
        my ( $volume, $directories, $filename )
            = File::Spec->splitpath($path);

        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;
        }

        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;
        }

        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
http://www.openzaurus.org/
http://Casbah.org/
http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/nmake15.exe
http://www.pvhp.com/~pvhp/
http://www.pvhp.com/%7Epvhp/
http://www.pvhp.com/%7epvhp/
http://www.leo.org
http://www.madgoat.com
http://www.mks.com/s390/gnu/
http://www.research.att.com/sw/tools/uwin/
http://www.tpj.com/
http://safaribooksonline.com/
http://use.perl.org/~autrijus/journal/25768
http://www.s390.ibm.com/products/oe/bpxqp1.html
http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01396.html
http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01489.html
http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01491.html
http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01608.html
http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg02144.html
http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg02998.html
http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1999-03/msg00520.html
http://www.w3.org/Security/Faq/

# 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&amp;p=2
http://link.included.here?o=1&amp;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.
Commit	Line	Data
23c4d79e	1	#!perl
6e7dc4a9	2	use strict;
23c4d79e LB	3	use warnings;
	4	use autodie;
	5	use feature qw(say);
d4b5f70a NC	6	require File::Find::Rule;
	7	require File::Slurp;
	8	require File::Spec;
	9	require IO::Socket::SSL;
23c4d79e	10	use List::Util qw(sum);
d4b5f70a NC	11	require LWP::UserAgent;
	12	require Net::FTP;
	13	require Parallel::Fork::BossWorkerAsync;
	14	require Term::ProgressBar::Simple;
	15	require URI::Find::Simple;
23c4d79e LB	16	$\| = 1;
	17
	18	my %ignore;
	19	while ( my $line = <main::DATA> ) {
	20	chomp $line;
	21	next if $line =~ /^#/;
	22	next unless $line;
	23	$ignore{$line} = 1;
	24	}
6e7dc4a9	25
7c509e8a	26	my $ua = LWP::UserAgent->new(ssl_opts => { verify_hostname => 0 });
23c4d79e LB	27	$ua->timeout(58);
23c4d79e LB	28	$ua->env_proxy;
6e7dc4a9	29
23c4d79e LB	30	my @filenames = @ARGV;
	31	@filenames = sort grep { $_ !~ /^\.git/ } File::Find::Rule->new->file->in('.')
	32	unless @filenames;
	33
	34	my $total_bytes = sum map {-s} @filenames;
	35
	36	my $extract_progress = Term::ProgressBar::Simple->new(
	37	{ count => $total_bytes,
	38	name => 'Extracting URIs',
	39	}
	40	);
6e7dc4a9	41
23c4d79e LB	42	my %uris;
	43	foreach my $filename (@filenames) {
	44	next if $filename =~ /uris\.txt/;
	45	next if $filename =~ /check_uris/;
	46	next if $filename =~ /\.patch$/;
7c509e8a LB	47	next if $filename =~ 'cpan/Pod-Simple/t/perlfaqo?\.pod';
7c509e8a LB	48	next if $filename =~ /checkURL\.pl$/;
d4b5f70a NC	49	my $contents = File::Slurp::read_file($filename);
d4b5f70a NC	50	my @uris = URI::Find::Simple::list_uris($contents);
23c4d79e LB	51	foreach my $uri (@uris) {
	52	next unless $uri =~ /^(http\|ftp)/;
	53	next if $ignore{$uri};
6e7dc4a9	54
23c4d79e LB	55	# no need to hit rt.perl.org
23c4d79e LB	56	next
3ef6a87a	57	if $uri =~ m{^https?://rt.perl.org/(?:rt3/)?Ticket/Display.html?id=\d+$};
6e7dc4a9	58
b4285b0d DB	59	# no need to hit github
	60	next
	61	if $uri =~ m{^https?://(?:www\.)?github\.com/[pP]erl/perl5/issues/\d+$};
	62
23c4d79e LB	63	# no need to hit rt.cpan.org
23c4d79e LB	64	next
7c509e8a LB	65	if $uri =~ m{^https?://rt.cpan.org/Public/Bug/Display.html?id=\d+$};
	66
	67	# no need to hit google groups (weird redirect LWP does not like)
	68	next
	69	if $uri =~ m{^http://groups\.google\.com/};
	70
23c4d79e LB	71	push @{ $uris{$uri} }, $filename;
	72	}
	73	$extract_progress += -s $filename;
	74	}
	75
	76	my $bw = Parallel::Fork::BossWorkerAsync->new(
	77	work_handler => \&work_alarmed,
	78	global_timeout => 120,
	79	worker_count => 20,
	80	);
	81
	82	foreach my $uri ( keys %uris ) {
	83	my @filenames = @{ $uris{$uri} };
	84	$bw->add_work( { uri => $uri, filenames => \@filenames } );
	85	}
	86
	87	undef $extract_progress;
	88
	89	my $fetch_progress = Term::ProgressBar::Simple->new(
	90	{ count => scalar( keys %uris ),
	91	name => 'Fetching URIs',
	92	}
	93	);
	94
	95	my %filenames;
	96	while ( $bw->pending() ) {
	97	my $response = $bw->get_result();
	98	my $uri = $response->{uri};
	99	my @filenames = @{ $response->{filenames} };
	100	my $is_success = $response->{is_success};
	101	my $message = $response->{message};
	102
	103	unless ($is_success) {
	104	foreach my $filename (@filenames) {
	105	push @{ $filenames{$filename} },
	106	{ uri => $uri, message => $message };
6e7dc4a9 JH	107	}
6e7dc4a9 JH	108	}
23c4d79e	109	$fetch_progress++;
6e7dc4a9	110	}
23c4d79e	111	$bw->shut_down();
6e7dc4a9	112
23c4d79e LB	113	my $fh = IO::File->new('> uris.txt');
	114	foreach my $filename ( sort keys %filenames ) {
	115	$fh->say("* $filename");
	116	my @bits = @{ $filenames{$filename} };
	117	foreach my $bit (@bits) {
	118	my $uri = $bit->{uri};
	119	my $message = $bit->{message};
	120	$fh->say(" $uri");
	121	$fh->say(" $message");
0d6d7233 JH	122	}
0d6d7233 JH	123	}
23c4d79e	124	$fh->close;
0d6d7233	125
23c4d79e	126	say 'Finished, see uris.txt';
6e7dc4a9	127
23c4d79e LB	128	sub work_alarmed {
	129	my $conf = shift;
	130	eval {
	131	local $SIG{ALRM} = sub { die "alarm\n" }; # NB: \n required
	132	alarm 60;
	133	$conf = work($conf);
	134	alarm 0;
	135	};
	136	if ($@) {
	137	$conf->{is_success} = 0;
	138	$conf->{message} = 'Timed out';
0d6d7233	139
23c4d79e LB	140	}
23c4d79e LB	141	return $conf;
0d6d7233 JH	142	}
0d6d7233 JH	143
23c4d79e LB	144	sub work {
	145	my $conf = shift;
	146	my $uri = $conf->{uri};
	147	my @filenames = @{ $conf->{filenames} };
0d6d7233	148
23c4d79e LB	149	if ( $uri =~ /^http/ ) {
	150	my $uri_without_fragment = URI->new($uri);
	151	my $fragment = $uri_without_fragment->fragment(undef);
	152	my $response = $ua->head($uri_without_fragment);
0d6d7233	153
23c4d79e LB	154	$conf->{is_success} = $response->is_success;
	155	$conf->{message} = $response->status_line;
	156	return $conf;
	157	} else {
0d6d7233	158
23c4d79e LB	159	my $uri_object = URI->new($uri);
	160	my $host = $uri_object->host;
	161	my $path = $uri_object->path;
	162	my ( $volume, $directories, $filename )
	163	= File::Spec->splitpath($path);
0d6d7233	164
23c4d79e LB	165	my $ftp = Net::FTP->new( $host, Passive => 1, Timeout => 60 );
	166	unless ($ftp) {
	167	$conf->{is_succcess} = 0;
	168	$conf->{message} = "Can not connect to $host: $@";
	169	return $conf;
	170	}
0d6d7233	171
23c4d79e LB	172	my $can_login = $ftp->login( "anonymous", '-anonymous@' );
	173	unless ($can_login) {
	174	$conf->{is_success} = 0;
	175	$conf->{message} = "Can not login ", $ftp->message;
	176	return $conf;
6e7dc4a9 JH	177	}
6e7dc4a9 JH	178
23c4d79e LB	179	my $can_binary = $ftp->binary();
	180	unless ($can_binary) {
	181	$conf->{is_success} = 0;
	182	$conf->{message} = "Can not binary ", $ftp->message;
	183	return $conf;
	184	}
	185
	186	my $can_cwd = $ftp->cwd($directories);
	187	unless ($can_cwd) {
	188	$conf->{is_success} = 0;
	189	$conf->{message} = "Can not cwd to $directories ", $ftp->message;
	190	return $conf;
	191	}
	192
	193	if ($filename) {
	194	my $can_size = $ftp->size($filename);
	195	unless ($can_size) {
	196	$conf->{is_success} = 0;
	197	$conf->{message}
	198	= "Can not size $filename in $directories",
	199	$ftp->message;
	200	return $conf;
	201	}
	202	} else {
	203	my ($can_dir) = $ftp->dir;
	204	unless ($can_dir) {
	205	my ($can_ls) = $ftp->ls;
	206	unless ($can_ls) {
	207	$conf->{is_success} = 0;
	208	$conf->{message}
	209	= "Can not dir or ls in $directories ",
	210	$ftp->message;
	211	return $conf;
	212	}
	213	}
	214	}
	215
	216	$conf->{is_success} = 1;
	217	return $conf;
6e7dc4a9 JH	218	}
	219	}
	220
23c4d79e LB	221	__DATA__
	222	# these are fine but give errors
	223	ftp://ftp.stratus.com/pub/vos/posix/ga/ga.html
	224	ftp://ftp.stratus.com/pub/vos/utility/utility.html
	225
7c509e8a	226	# these are missing, sigh
23c4d79e LB	227	ftp://ftp.sco.com/SLS/ptf7051e.Z
23c4d79e LB	228	http://perlmonks.thepen.com/42898.html
7c509e8a LB	229	http://svn.mutatus.co.uk/wsvn/Scalar-List-Utils/trunk/
	230	http://public.activestate.com/cgi-bin/perlbrowse
	231	http://svn.mutatus.co.uk/browse/libnet/tags/libnet-1.17/ChangeLog
	232	http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631
	233	http://my.smithmicro.com/mac/stuffit/
	234	http://www.wg.omron.co.jp/cgi-bin/j-e/jfriedl.html
	235	http://persephone.cps.unizar.es/general/gente/spd/gzip/gzip.html
05558683 MM	236	http://www.openzaurus.org/
	237	http://Casbah.org/
	238	http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/nmake15.exe
	239	http://www.pvhp.com/~pvhp/
	240	http://www.pvhp.com/%7Epvhp/
	241	http://www.pvhp.com/%7epvhp/
	242	http://www.leo.org
	243	http://www.madgoat.com
	244	http://www.mks.com/s390/gnu/
	245	http://www.research.att.com/sw/tools/uwin/
	246	http://www.tpj.com/
	247	http://safaribooksonline.com/
	248	http://use.perl.org/~autrijus/journal/25768
	249	http://www.s390.ibm.com/products/oe/bpxqp1.html
	250	http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01396.html
	251	http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01489.html
	252	http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01491.html
	253	http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01608.html
	254	http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg02144.html
	255	http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg02998.html
	256	http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1999-03/msg00520.html
	257	http://www.w3.org/Security/Faq/
7c509e8a LB	258
7c509e8a LB	259	# these are URI extraction bugs
23c4d79e LB	260	http://www.perl.org/E
	261	http://en.wikipedia.org/wiki/SREC_(file_format
	262	http://somewhere.else',-type=/
	263	ftp:passive-mode
	264	ftp:
	265	http:[-
	266	http://search.cpan.org/src/KWILLIAMS/Module-Build-0.30/lib/Module/Build/Platform/Windows.pm:split_like_shell
	267	http://www.xray.mpe.mpg.de/mailing-lists/perl5-
	268	http://support.microsoft.com/support/kb/articles/Q280/3/41.ASP:
7c509e8a LB	269	http://perl.come/
7c509e8a LB	270	http://www.perl.come/
23c4d79e LB	271
	272	# these are used as an example
	273	http://example.com/
	274	http://something.here/
	275	http://users.perl5.git.perl.org/~yourlogin/
	276	http://github.com/USERNAME/perl/tree/orange
	277	http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi
	278	http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar
	279	http://somewhere.else$/
	280	http://somewhere.else$/
	281	http://somewhere.else/bin/foo&bar',-Type=
	282	http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi
	283	http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar
	284	http://www.perl.org/test.cgi
	285	http://cpan2.local/
	286	http://search.cpan.org/perldoc?
	287	http://cpan1.local/
	288	http://cpan.dev.local/CPAN
	289	http:///
	290	ftp://
	291	ftp://myurl/
	292	ftp://ftp.software.ibm.com/aix/fixes/v4/other/vac.C.5.0.2.6.bff
	293	http://www14.software.ibm.com/webapp/download/downloadaz.jsp
	294	http://www.cpan.org/modules/by-module/Archive/Archive-Zip-*.tar.gz
	295	http://www.unicode.org/Public/MAPPINGS/ISO8859/8859-*.TXT
	296	http://localhost/tmp/index.txt
	297	http://example.com/foo/bar.html
	298	http://example.com/Text-Bastardize-1.06.tar.gz
	299	ftp://example.com/sources/packages.txt
	300	http://example.com/sources/packages.txt
	301	http://example.com/sources
	302	ftp://example.com/sources
	303	http://some.where.com/dir/file.txt
	304	http://some.where.com/dir/a.txt
	305	http://foo.com/X.tgz
	306	ftp://foo.com/X.tgz
	307	http://foo/
	308	http://www.foo.com:8000/
	309	http://mysite.com/cgi-bin/log.cgi/http://www.some.other.site/args
	310	http://decoded/mirror/path
	311	http://a/b/c/d/e/f/g/h/i/j
	312	http://foo/bar.gz
	313	ftp://ftp.perl.org
	314	http://purl.org/rss/1.0/modules/taxonomy/
	315	ftp://ftp.sun.ac.za/CPAN/CPAN/
	316	ftp://ftp.cpan.org/pub/mirror/index.txt
	317	ftp://cpan.org/pub/mirror/index.txt
	318	http://example.com/~eh/
	319	http://plagger.org/.../rss
	320	http://umn.dl.sourceforge.net/mingw/gcc-g++-3.4.5-20060117-1.tar.gz
	321	http://umn.dl.sourceforge.net/mingw/binutils-2.16.91-20060119-1.tar.gz
	322	http://umn.dl.sourceforge.net/mingw/mingw-runtime-3.10.tar.gz
	323	http://umn.dl.sourceforge.net/mingw/gcc-core-3.4.5-20060117-1.tar.gz
	324	http://umn.dl.sourceforge.net/mingw/w32api-3.6.tar.gz
	325	http://search.cpan.org/CPAN/authors/id/S/SH/SHAY/dmake-4.5-20060619-SHAY.zip
	326	http://module-build.sourceforge.net/META-spec-new.html
	327	http://module-build.sourceforge.net/META-spec-v1.4.html
	328	http://www.cs.vu.nl/~tmgil/vi.html
	329	http://perlcomposer.sourceforge.net/vperl.html
	330	http://www.perl.com/CPAN/authors/Tom_Christiansen/scripts/rep
	331	http://w4.lns.cornell.edu/~pvhp/ptk/ptkTOC.html
	332	http://world.std.com/~aep/ptkdb/
	333	http://www.castlelink.co.uk/object_system/
	334	http://www.fh-wedel.de/elvis/
335	ftp://ftp.blarg.net/users/amol/zsh/
336	ftp://ftp.funet.fi/pub/languages/perl/CPAN
337	http://search.cpan.org/CPAN/authors/id/S/SH/SHAY/dmake-4.5-20060619-SHAY.zip
7c509e8a LB	338	http://users.perl5.git.perl.org/~USERNAME
	339	http://foo/x//y/script.cgi/a//b
	340	http://xxx/script.cgi/http://foo
	341	http://foo/./x//z/script.cgi/a/../b//c
	342	http://somewhere.else/in/movie/land
	343	http://somewhere.else/finished.html
	344	http://somewhere.else/bin/foo&bar$
	345	http://somewhere.else/
	346	http://proxy:8484/
	347	http://proxy/
	348	http://myrepo.example.com/
	349	http://remote/source
	350	https://example.com/
	351	http://example.com:1024/
	352	http:///path?foo=bar
	353	http://[::]:1024/
	354	http://([/
	355	http://example.com:9000/index.html
	356	http://proxy.example.com:8080/
	357	http:///index.html
	358	http://[www.json::pp.org]/
	359	http://localhost/
	360	http://foo.example.com/
	361	http://abc.com/a.js
	362	http://whatever/man/1/crontab
	363	http://abc.com/c.js
	364	http://whatever/Foo%3A%3ABar
	365	http://abc.com/b.js
	366	http://remote.server.com/jquery.css
	367	http://some.other.com/page.html
	368	https://text.com/1/2
	369	https://text.com/1/2
	370	http://link.included.here?o=1&p=2
	371	http://link.included.here?o=1&p=2
	372	http://link.included.here?o=1&p=2
	373	http://link.included.here/
	374	http://foo/x//y/script.cgi/a//b
	375	http://xxx/script.cgi/http://foo
	376	http://foo/./x//z/script.cgi/a/../b//c
	377	http://somewhere.else/in/movie/land
	378	http://somewhere.else/finished.html
	379	http://webproxy:3128/
	380	http://www/
23c4d79e LB	381
	382	# these are used to generate or match URLs
	383	http://www.cpan.org/modules/by-authors/id/$1/$1$2/$dist
	384	http://www.cpantesters.org/show/%s.yaml
	385	ftp://(.?)/(.)/(.*
	386	ftp://(.?)/(.)/(.*
	387	ftp://(.?)/(.)/(.*
	388	ftp://ftp.foo.bar/
	389	http://$host/
	390	http://wwwe%3C46/
	391	ftp:/
7c509e8a LB	392	http://$addr/mark?commit=$
	393	http://search.cpan.org/~
	394	http:/
	395	ftp:%5Cn$url
	396	http://www.ietf.org/rfc/rfc$2.txt
	397	http://search.cpan.org/~
	398	ftp:%5Cn$url
23c4d79e LB	399
	400	# weird redirects that LWP doesn't like
	401	http://www.theperlreview.com/community_calendar
	402	http://www.software.hp.com/portal/swdepot/displayProductInfo.do?productNumber=PERL
7c509e8a	403	http://sunsolve.sun.com
23c4d79e LB	404
	405	# broken webserver that doesn't like HEAD requests
	406	http://docs.sun.com/app/docs/doc/816-5168/syslog-3c?a=view
7c509e8a	407	http://www.w3.org/TR/html4/loose.dtd
23c4d79e LB	408
	409	# these have been reported upstream to CPAN authors
	410	http://www.gnu.org/manual/tar/html_node/tar_139.html
	411	http://www.w3.org/pub/WWW/TR/Wd-css-1.html
	412	http://support.microsoft.com/support/kb/articles/Q280/3/41.ASP
	413	http://msdn.microsoft.com/workshop/author/dhtml/httponly_cookies.asp
	414	http://search.cpan.org/search?query=Module::Build::Convert
	415	http://www.refcnt.org/papers/module-build-convert
	416	http://csrc.nist.gov/cryptval/shs.html
	417	http://msdn.microsoft.com/workshop/author/dhtml/reference/charsets/charset4.asp
	418	http://www.debian.or.jp/~kubota/unicode-symbols.html.en
	419	http://www.mail-archive.com/perl5-porters@perl.org/msg69766.html
	420	http://www.debian.or.jp/~kubota/unicode-symbols.html.en
	421	http://rfc.net/rfc2781.html
	422	http://www.icu-project.org/charset/
	423	http://ppewww.ph.gla.ac.uk/~flavell/charset/form-i18n.html
	424	http://www.rfc-editor.org/
	425	http://www.rfc.net/
	426	http://www.oreilly.com/people/authors/lunde/cjk_inf.html
	427	http://www.oreilly.com/catalog/cjkvinfo/
	428	http://www.cpan.org/modules/by-author/Damian_Conway/Filter-Simple.tar.gz
	429	http://www.csse.monash.edu.au/~damian/CPAN/Filter-Simple.tar.gz
	430	http://www.egt.ie/standards/iso3166/iso3166-1-en.html
	431	http://www.bsi-global.com/iso4217currency
	432	http://www.plover.com/~mjd/perl/Memoize/
	433	http://www.plover.com/~mjd/perl/MiniMemoize/
	434	http://www.sysadminmag.com/tpj/issues/vol5_5/
	435	ftp://ftp.tpc.int/tpc/server/UNIX/
	436	http://www.nara.gov/genealogy/
	437	http://home.utah-inter.net/kinsearch/Soundex.html
	438	http://www.nara.gov/genealogy/soundex/soundex.html
	439	http://rfc.net/rfc3461.html
	440	ftp://ftp.cs.pdx.edu/pub/elvis/
	441	http://www.fh-wedel.de/elvis/
7d0fb9b8	442	http://lists.perl.org/list/perl-mvs.html
7c509e8a LB	443	http://www.cpan.org/ports/os2/
	444	http://github.com/dagolden/cpan-meta-spec
	445	http://github.com/dagolden/cpan-meta-spec/issues
	446	http://www.opensource.org/licenses/lgpl-license.phpt
	447	http://reality.sgi.com/ariel
	448	http://www.chiark.greenend.org.uk/pipermail/ukcrypto/1999-February/003538.html
	449	http://www.chiark.greenend.org.uk/pipermail/ukcrypto/1999-February/003538.html
	450	http://www.nsrl.nist.gov/testdata/
	451	http://public.activestate.com/cgi-bin/perlbrowse/p/31194
	452	http://public.activestate.com/cgi-bin/perlbrowse?patch=16173
	453	http://public.activestate.com/cgi-bin/perlbrowse?patch=16049
	454	http://www.li18nux.org/docs/html/CodesetAliasTable-V10.html
	455	http://aspn.activestate.com/ASPN/Mail/Message/perl5-porters/3486118
	456	http://lxr.mozilla.org/seamonkey/source/intl/uconv/ucvlatin/vps.ut
	457	http://lxr.mozilla.org/seamonkey/source/intl/uconv/ucvlatin/vps.uf
	458	http://github.com/schwern/extutils-makemaker
	459	https://github.com/dagolden/cpanpm/compare/master...private%2Fuse-http-lite
	460	http://www.json.org/JSON::PP_checker/
	461	ftp://ftp.kiae.su/pub/unix/fido/
	462	http://www.gallistel.net/nparker/weather/code/
	463	http://www.javaworld.com/javaworld/jw-09-2001/jw-0928-ntmessages.html
	464	ftp://ftp-usa.tpc.int/pub/tpc/server/UNIX/
	465	http://www.cis.ohio-state.edu/htbin/rfc/rfc959.html
	466	http://public.activestate.com/cgi-bin/perlbrowse/p/33567
	467	http://public.activestate.com/cgi-bin/perlbrowse/p/33566
	468	http://www.dsmit.com/cons/
	469	http://www.makemaker.org/wiki/index.cgi?ModuleBuildConversionGuide
23c4d79e	470
6e7dc4a9	471	__END__
23c4d79e LB	472
	473	=head1 NAME
	474
	475	checkURL.pl - Check that all the URLs in the Perl source are valid
	476
	477	=head1 DESCRIPTION
	478
	479	This program checks that all the URLs in the Perl source are valid. It
	480	checks HTTP and FTP links in parallel and contains a list of known
	481	bad example links in its source. It takes 4 minutes to run on my
	482	machine. The results are written to 'uris.txt' and list the filename,
	483	the URL and the error:
	484
	485	* ext/Locale-Maketext/lib/Locale/Maketext.pod
	486	http://sunsite.dk/RFC/rfc/rfc2277.html
	487	404 Not Found
	488	...
	489
	490	It should be run every so often and links fixed and upstream authors
	491	notified.
	492
	493	Note that the web is unstable and some websites are temporarily down.