[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.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/
05558683 MM	245	http://www.tpj.com/
	246	http://safaribooksonline.com/
	247	http://use.perl.org/~autrijus/journal/25768
	248	http://www.s390.ibm.com/products/oe/bpxqp1.html
	249	http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01396.html
	250	http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01489.html
	251	http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01491.html
	252	http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg01608.html
	253	http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg02144.html
	254	http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1998-02/msg02998.html
	255	http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/1999-03/msg00520.html
	256	http://www.w3.org/Security/Faq/
7c509e8a LB	257
7c509e8a LB	258	# these are URI extraction bugs
23c4d79e LB	259	http://www.perl.org/E
	260	http://en.wikipedia.org/wiki/SREC_(file_format
	261	http://somewhere.else',-type=/
	262	ftp:passive-mode
	263	ftp:
	264	http:[-
	265	http://search.cpan.org/src/KWILLIAMS/Module-Build-0.30/lib/Module/Build/Platform/Windows.pm:split_like_shell
	266	http://www.xray.mpe.mpg.de/mailing-lists/perl5-
	267	http://support.microsoft.com/support/kb/articles/Q280/3/41.ASP:
7c509e8a LB	268	http://perl.come/
7c509e8a LB	269	http://www.perl.come/
23c4d79e LB	270
	271	# these are used as an example
	272	http://example.com/
	273	http://something.here/
	274	http://users.perl5.git.perl.org/~yourlogin/
	275	http://github.com/USERNAME/perl/tree/orange
	276	http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi
	277	http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar
	278	http://somewhere.else$/
	279	http://somewhere.else$/
	280	http://somewhere.else/bin/foo&bar',-Type=
	281	http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi
	282	http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar
	283	http://www.perl.org/test.cgi
	284	http://cpan2.local/
	285	http://search.cpan.org/perldoc?
	286	http://cpan1.local/
	287	http://cpan.dev.local/CPAN
	288	http:///
	289	ftp://
	290	ftp://myurl/
	291	ftp://ftp.software.ibm.com/aix/fixes/v4/other/vac.C.5.0.2.6.bff
	292	http://www14.software.ibm.com/webapp/download/downloadaz.jsp
	293	http://www.cpan.org/modules/by-module/Archive/Archive-Zip-*.tar.gz
	294	http://www.unicode.org/Public/MAPPINGS/ISO8859/8859-*.TXT
	295	http://localhost/tmp/index.txt
	296	http://example.com/foo/bar.html
	297	http://example.com/Text-Bastardize-1.06.tar.gz
	298	ftp://example.com/sources/packages.txt
	299	http://example.com/sources/packages.txt
	300	http://example.com/sources
	301	ftp://example.com/sources
	302	http://some.where.com/dir/file.txt
	303	http://some.where.com/dir/a.txt
	304	http://foo.com/X.tgz
	305	ftp://foo.com/X.tgz
	306	http://foo/
	307	http://www.foo.com:8000/
	308	http://mysite.com/cgi-bin/log.cgi/http://www.some.other.site/args
	309	http://decoded/mirror/path
	310	http://a/b/c/d/e/f/g/h/i/j
	311	http://foo/bar.gz
	312	ftp://ftp.perl.org
	313	http://purl.org/rss/1.0/modules/taxonomy/
	314	ftp://ftp.sun.ac.za/CPAN/CPAN/
	315	ftp://ftp.cpan.org/pub/mirror/index.txt
	316	ftp://cpan.org/pub/mirror/index.txt
	317	http://example.com/~eh/
	318	http://plagger.org/.../rss
	319	http://umn.dl.sourceforge.net/mingw/gcc-g++-3.4.5-20060117-1.tar.gz
	320	http://umn.dl.sourceforge.net/mingw/binutils-2.16.91-20060119-1.tar.gz
	321	http://umn.dl.sourceforge.net/mingw/mingw-runtime-3.10.tar.gz
	322	http://umn.dl.sourceforge.net/mingw/gcc-core-3.4.5-20060117-1.tar.gz
	323	http://umn.dl.sourceforge.net/mingw/w32api-3.6.tar.gz
	324	http://search.cpan.org/CPAN/authors/id/S/SH/SHAY/dmake-4.5-20060619-SHAY.zip
	325	http://module-build.sourceforge.net/META-spec-new.html
	326	http://module-build.sourceforge.net/META-spec-v1.4.html
	327	http://www.cs.vu.nl/~tmgil/vi.html
	328	http://perlcomposer.sourceforge.net/vperl.html
	329	http://www.perl.com/CPAN/authors/Tom_Christiansen/scripts/rep
	330	http://w4.lns.cornell.edu/~pvhp/ptk/ptkTOC.html
	331	http://world.std.com/~aep/ptkdb/
	332	http://www.castlelink.co.uk/object_system/
	333	http://www.fh-wedel.de/elvis/
334	ftp://ftp.blarg.net/users/amol/zsh/
335	ftp://ftp.funet.fi/pub/languages/perl/CPAN
336	http://search.cpan.org/CPAN/authors/id/S/SH/SHAY/dmake-4.5-20060619-SHAY.zip
7c509e8a LB	337	http://users.perl5.git.perl.org/~USERNAME
	338	http://foo/x//y/script.cgi/a//b
	339	http://xxx/script.cgi/http://foo
	340	http://foo/./x//z/script.cgi/a/../b//c
	341	http://somewhere.else/in/movie/land
	342	http://somewhere.else/finished.html
	343	http://somewhere.else/bin/foo&bar$
	344	http://somewhere.else/
	345	http://proxy:8484/
	346	http://proxy/
	347	http://myrepo.example.com/
	348	http://remote/source
	349	https://example.com/
	350	http://example.com:1024/
	351	http:///path?foo=bar
	352	http://[::]:1024/
	353	http://([/
	354	http://example.com:9000/index.html
	355	http://proxy.example.com:8080/
	356	http:///index.html
	357	http://[www.json::pp.org]/
	358	http://localhost/
	359	http://foo.example.com/
	360	http://abc.com/a.js
	361	http://whatever/man/1/crontab
	362	http://abc.com/c.js
	363	http://whatever/Foo%3A%3ABar
	364	http://abc.com/b.js
	365	http://remote.server.com/jquery.css
	366	http://some.other.com/page.html
	367	https://text.com/1/2
	368	https://text.com/1/2
	369	http://link.included.here?o=1&p=2
	370	http://link.included.here?o=1&p=2
	371	http://link.included.here?o=1&p=2
	372	http://link.included.here/
	373	http://foo/x//y/script.cgi/a//b
	374	http://xxx/script.cgi/http://foo
	375	http://foo/./x//z/script.cgi/a/../b//c
	376	http://somewhere.else/in/movie/land
	377	http://somewhere.else/finished.html
	378	http://webproxy:3128/
	379	http://www/
23c4d79e LB	380
	381	# these are used to generate or match URLs
	382	http://www.cpan.org/modules/by-authors/id/$1/$1$2/$dist
	383	http://www.cpantesters.org/show/%s.yaml
	384	ftp://(.?)/(.)/(.*
	385	ftp://(.?)/(.)/(.*
	386	ftp://(.?)/(.)/(.*
	387	ftp://ftp.foo.bar/
	388	http://$host/
	389	http://wwwe%3C46/
	390	ftp:/
7c509e8a LB	391	http://$addr/mark?commit=$
	392	http://search.cpan.org/~
	393	http:/
	394	ftp:%5Cn$url
	395	http://www.ietf.org/rfc/rfc$2.txt
	396	http://search.cpan.org/~
	397	ftp:%5Cn$url
23c4d79e LB	398
	399	# weird redirects that LWP doesn't like
	400	http://www.theperlreview.com/community_calendar
	401	http://www.software.hp.com/portal/swdepot/displayProductInfo.do?productNumber=PERL
7c509e8a	402	http://sunsolve.sun.com
23c4d79e LB	403
	404	# broken webserver that doesn't like HEAD requests
	405	http://docs.sun.com/app/docs/doc/816-5168/syslog-3c?a=view
7c509e8a	406	http://www.w3.org/TR/html4/loose.dtd
23c4d79e LB	407
	408	# these have been reported upstream to CPAN authors
	409	http://www.gnu.org/manual/tar/html_node/tar_139.html
	410	http://www.w3.org/pub/WWW/TR/Wd-css-1.html
	411	http://support.microsoft.com/support/kb/articles/Q280/3/41.ASP
	412	http://msdn.microsoft.com/workshop/author/dhtml/httponly_cookies.asp
	413	http://search.cpan.org/search?query=Module::Build::Convert
	414	http://www.refcnt.org/papers/module-build-convert
	415	http://csrc.nist.gov/cryptval/shs.html
	416	http://msdn.microsoft.com/workshop/author/dhtml/reference/charsets/charset4.asp
	417	http://www.debian.or.jp/~kubota/unicode-symbols.html.en
	418	http://www.mail-archive.com/perl5-porters@perl.org/msg69766.html
	419	http://www.debian.or.jp/~kubota/unicode-symbols.html.en
	420	http://rfc.net/rfc2781.html
	421	http://www.icu-project.org/charset/
	422	http://ppewww.ph.gla.ac.uk/~flavell/charset/form-i18n.html
	423	http://www.rfc-editor.org/
	424	http://www.rfc.net/
	425	http://www.oreilly.com/people/authors/lunde/cjk_inf.html
	426	http://www.oreilly.com/catalog/cjkvinfo/
	427	http://www.cpan.org/modules/by-author/Damian_Conway/Filter-Simple.tar.gz
	428	http://www.csse.monash.edu.au/~damian/CPAN/Filter-Simple.tar.gz
	429	http://www.egt.ie/standards/iso3166/iso3166-1-en.html
	430	http://www.bsi-global.com/iso4217currency
	431	http://www.plover.com/~mjd/perl/Memoize/
	432	http://www.plover.com/~mjd/perl/MiniMemoize/
	433	http://www.sysadminmag.com/tpj/issues/vol5_5/
	434	ftp://ftp.tpc.int/tpc/server/UNIX/
	435	http://www.nara.gov/genealogy/
	436	http://home.utah-inter.net/kinsearch/Soundex.html
	437	http://www.nara.gov/genealogy/soundex/soundex.html
	438	http://rfc.net/rfc3461.html
	439	ftp://ftp.cs.pdx.edu/pub/elvis/
	440	http://www.fh-wedel.de/elvis/
7d0fb9b8	441	http://lists.perl.org/list/perl-mvs.html
7c509e8a LB	442	http://www.cpan.org/ports/os2/
	443	http://github.com/dagolden/cpan-meta-spec
	444	http://github.com/dagolden/cpan-meta-spec/issues
	445	http://www.opensource.org/licenses/lgpl-license.phpt
	446	http://reality.sgi.com/ariel
	447	http://www.chiark.greenend.org.uk/pipermail/ukcrypto/1999-February/003538.html
	448	http://www.chiark.greenend.org.uk/pipermail/ukcrypto/1999-February/003538.html
	449	http://www.nsrl.nist.gov/testdata/
	450	http://public.activestate.com/cgi-bin/perlbrowse/p/31194
	451	http://public.activestate.com/cgi-bin/perlbrowse?patch=16173
	452	http://public.activestate.com/cgi-bin/perlbrowse?patch=16049
	453	http://www.li18nux.org/docs/html/CodesetAliasTable-V10.html
	454	http://aspn.activestate.com/ASPN/Mail/Message/perl5-porters/3486118
	455	http://lxr.mozilla.org/seamonkey/source/intl/uconv/ucvlatin/vps.ut
	456	http://lxr.mozilla.org/seamonkey/source/intl/uconv/ucvlatin/vps.uf
	457	http://github.com/schwern/extutils-makemaker
	458	https://github.com/dagolden/cpanpm/compare/master...private%2Fuse-http-lite
	459	http://www.json.org/JSON::PP_checker/
	460	ftp://ftp.kiae.su/pub/unix/fido/
	461	http://www.gallistel.net/nparker/weather/code/
	462	http://www.javaworld.com/javaworld/jw-09-2001/jw-0928-ntmessages.html
	463	ftp://ftp-usa.tpc.int/pub/tpc/server/UNIX/
	464	http://www.cis.ohio-state.edu/htbin/rfc/rfc959.html
	465	http://public.activestate.com/cgi-bin/perlbrowse/p/33567
	466	http://public.activestate.com/cgi-bin/perlbrowse/p/33566
	467	http://www.dsmit.com/cons/
	468	http://www.makemaker.org/wiki/index.cgi?ModuleBuildConversionGuide
23c4d79e	469
6e7dc4a9	470	__END__
23c4d79e LB	471
	472	=head1 NAME
	473
	474	checkURL.pl - Check that all the URLs in the Perl source are valid
	475
	476	=head1 DESCRIPTION
	477
	478	This program checks that all the URLs in the Perl source are valid. It
	479	checks HTTP and FTP links in parallel and contains a list of known
	480	bad example links in its source. It takes 4 minutes to run on my
	481	machine. The results are written to 'uris.txt' and list the filename,
	482	the URL and the error:
	483
	484	* ext/Locale-Maketext/lib/Locale/Maketext.pod
	485	http://sunsite.dk/RFC/rfc/rfc2277.html
	486	404 Not Found
	487	...
	488
	489	It should be run every so often and links fixed and upstream authors
	490	notified.
	491
	492	Note that the web is unstable and some websites are temporarily down.