Localise temporary FHs in the EU::Constant tests
[perl.git] / Porting / checkURL.pl
1 #!perl
2 use strict;
3 use warnings;
4 use autodie;
5 use feature qw(say);
6 use File::Find::Rule;
7 use File::Slurp;
8 use File::Spec;
9 use IO::Socket::SSL;
10 use List::Util qw(sum);
11 use LWP::UserAgent;
12 use Net::FTP;
13 use Parallel::Fork::BossWorkerAsync;
14 use Term::ProgressBar::Simple;
15 use URI::Find::Simple qw( list_uris );
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 }
25
26 my $ua = LWP::UserAgent->new;
27 $ua->timeout(58);
28 $ua->env_proxy;
29
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 );
41
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$/;
47     my $contents = read_file($filename);
48     my @uris     = list_uris($contents);
49     foreach my $uri (@uris) {
50         next unless $uri =~ /^(http|ftp)/;
51         next if $ignore{$uri};
52
53         # no need to hit rt.perl.org
54         next
55             if $uri =~ m{^http://rt.perl.org/rt3/Ticket/Display.html?id=\d+$};
56
57         # no need to hit rt.cpan.org
58         next
59             if $uri =~ m{^http://rt.cpan.org/Public/Bug/Display.html?id=\d+$};
60         push @{ $uris{$uri} }, $filename;
61     }
62     $extract_progress += -s $filename;
63 }
64
65 my $bw = Parallel::Fork::BossWorkerAsync->new(
66     work_handler   => \&work_alarmed,
67     global_timeout => 120,
68     worker_count   => 20,
69 );
70
71 foreach my $uri ( keys %uris ) {
72     my @filenames = @{ $uris{$uri} };
73     $bw->add_work( { uri => $uri, filenames => \@filenames } );
74 }
75
76 undef $extract_progress;
77
78 my $fetch_progress = Term::ProgressBar::Simple->new(
79     {   count => scalar( keys %uris ),
80         name  => 'Fetching URIs',
81     }
82 );
83
84 my %filenames;
85 while ( $bw->pending() ) {
86     my $response   = $bw->get_result();
87     my $uri        = $response->{uri};
88     my @filenames  = @{ $response->{filenames} };
89     my $is_success = $response->{is_success};
90     my $message    = $response->{message};
91
92     unless ($is_success) {
93         foreach my $filename (@filenames) {
94             push @{ $filenames{$filename} },
95                 { uri => $uri, message => $message };
96         }
97     }
98     $fetch_progress++;
99 }
100 $bw->shut_down();
101
102 my $fh = IO::File->new('> uris.txt');
103 foreach my $filename ( sort keys %filenames ) {
104     $fh->say("* $filename");
105     my @bits = @{ $filenames{$filename} };
106     foreach my $bit (@bits) {
107         my $uri     = $bit->{uri};
108         my $message = $bit->{message};
109         $fh->say("  $uri");
110         $fh->say("    $message");
111     }
112 }
113 $fh->close;
114
115 say 'Finished, see uris.txt';
116
117 sub work_alarmed {
118     my $conf = shift;
119     eval {
120         local $SIG{ALRM} = sub { die "alarm\n" };    # NB: \n required
121         alarm 60;
122         $conf = work($conf);
123         alarm 0;
124     };
125     if ($@) {
126         $conf->{is_success} = 0;
127         $conf->{message}    = 'Timed out';
128
129     }
130     return $conf;
131 }
132
133 sub work {
134     my $conf      = shift;
135     my $uri       = $conf->{uri};
136     my @filenames = @{ $conf->{filenames} };
137
138     if ( $uri =~ /^http/ ) {
139         my $uri_without_fragment = URI->new($uri);
140         my $fragment             = $uri_without_fragment->fragment(undef);
141         my $response             = $ua->head($uri_without_fragment);
142
143         $conf->{is_success} = $response->is_success;
144         $conf->{message}    = $response->status_line;
145         return $conf;
146     } else {
147
148         my $uri_object = URI->new($uri);
149         my $host       = $uri_object->host;
150         my $path       = $uri_object->path;
151         my ( $volume, $directories, $filename )
152             = File::Spec->splitpath($path);
153
154         my $ftp = Net::FTP->new( $host, Passive => 1, Timeout => 60 );
155         unless ($ftp) {
156             $conf->{is_succcess} = 0;
157             $conf->{message}     = "Can not connect to $host: $@";
158             return $conf;
159         }
160
161         my $can_login = $ftp->login( "anonymous", '-anonymous@' );
162         unless ($can_login) {
163             $conf->{is_success} = 0;
164             $conf->{message} = "Can not login ", $ftp->message;
165             return $conf;
166         }
167
168         my $can_binary = $ftp->binary();
169         unless ($can_binary) {
170             $conf->{is_success} = 0;
171             $conf->{message} = "Can not binary ", $ftp->message;
172             return $conf;
173         }
174
175         my $can_cwd = $ftp->cwd($directories);
176         unless ($can_cwd) {
177             $conf->{is_success} = 0;
178             $conf->{message} = "Can not cwd to $directories ", $ftp->message;
179             return $conf;
180         }
181
182         if ($filename) {
183             my $can_size = $ftp->size($filename);
184             unless ($can_size) {
185                 $conf->{is_success} = 0;
186                 $conf->{message}
187                     = "Can not size $filename in $directories",
188                     $ftp->message;
189                 return $conf;
190             }
191         } else {
192             my ($can_dir) = $ftp->dir;
193             unless ($can_dir) {
194                 my ($can_ls) = $ftp->ls;
195                 unless ($can_ls) {
196                     $conf->{is_success} = 0;
197                     $conf->{message}
198                         = "Can not dir or ls in $directories ",
199                         $ftp->message;
200                     return $conf;
201                 }
202             }
203         }
204
205         $conf->{is_success} = 1;
206         return $conf;
207     }
208 }
209
210 __DATA__
211 # these are fine but give errors
212 ftp://ftp.stratus.com/pub/vos/posix/ga/ga.html
213 ftp://ftp.stratus.com/pub/vos/utility/utility.html
214
215 # this is missing, sigh
216 ftp://ftp.sco.com/SLS/ptf7051e.Z
217 http://perlmonks.thepen.com/42898.html
218
219 # this are URI extraction bugs
220 http://www.perl.org/E
221 http://en.wikipedia.org/wiki/SREC_(file_format
222 http://somewhere.else',-type=/
223 ftp:passive-mode
224 ftp:
225 http:[-
226 http://search.cpan.org/src/KWILLIAMS/Module-Build-0.30/lib/Module/Build/Platform/Windows.pm:split_like_shell
227 http://www.xray.mpe.mpg.de/mailing-lists/perl5-
228 http://support.microsoft.com/support/kb/articles/Q280/3/41.ASP:
229
230 # these are used as an example
231 http://example.com/
232 http://something.here/
233 http://users.perl5.git.perl.org/~yourlogin/
234 http://github.com/USERNAME/perl/tree/orange
235 http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi
236 http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar
237 http://somewhere.else$/
238 http://somewhere.else$/
239 http://somewhere.else/bin/foo&bar',-Type=
240 http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi
241 http://the.good.ship.lollypop.com:8080/cgi-bin/foo.cgi/somewhere/else?game=chess;game=checkers;weather=dull;foo=bar
242 http://www.perl.org/test.cgi
243 http://cpan2.local/
244 http://search.cpan.org/perldoc?
245 http://cpan1.local/
246 http://cpan.dev.local/CPAN
247 http:///
248 ftp://
249 ftp://myurl/
250 ftp://ftp.software.ibm.com/aix/fixes/v4/other/vac.C.5.0.2.6.bff
251 http://www14.software.ibm.com/webapp/download/downloadaz.jsp
252 http://www.cpan.org/modules/by-module/Archive/Archive-Zip-*.tar.gz
253 http://www.unicode.org/Public/MAPPINGS/ISO8859/8859-*.TXT
254 http://localhost/tmp/index.txt
255 http://example.com/foo/bar.html
256 http://example.com/Text-Bastardize-1.06.tar.gz
257 ftp://example.com/sources/packages.txt
258 http://example.com/sources/packages.txt
259 http://example.com/sources
260 ftp://example.com/sources
261 http://some.where.com/dir/file.txt
262 http://some.where.com/dir/a.txt
263 http://foo.com/X.tgz
264 ftp://foo.com/X.tgz
265 http://foo/
266 http://www.foo.com:8000/
267 http://mysite.com/cgi-bin/log.cgi/http://www.some.other.site/args
268 http://decoded/mirror/path
269 http://a/b/c/d/e/f/g/h/i/j
270 http://foo/bar.gz
271 ftp://ftp.perl.org
272 http://purl.org/rss/1.0/modules/taxonomy/
273 ftp://ftp.sun.ac.za/CPAN/CPAN/
274 ftp://ftp.cpan.org/pub/mirror/index.txt
275 ftp://cpan.org/pub/mirror/index.txt
276 http://example.com/~eh/
277 http://plagger.org/.../rss
278 http://umn.dl.sourceforge.net/mingw/gcc-g++-3.4.5-20060117-1.tar.gz
279 http://umn.dl.sourceforge.net/mingw/binutils-2.16.91-20060119-1.tar.gz
280 http://umn.dl.sourceforge.net/mingw/mingw-runtime-3.10.tar.gz
281 http://umn.dl.sourceforge.net/mingw/gcc-core-3.4.5-20060117-1.tar.gz
282 http://umn.dl.sourceforge.net/mingw/w32api-3.6.tar.gz
283 http://search.cpan.org/CPAN/authors/id/S/SH/SHAY/dmake-4.5-20060619-SHAY.zip  
284 http://module-build.sourceforge.net/META-spec-new.html
285 http://module-build.sourceforge.net/META-spec-v1.4.html
286 http://www.cs.vu.nl/~tmgil/vi.html
287 http://perlcomposer.sourceforge.net/vperl.html
288 http://www.perl.com/CPAN/authors/Tom_Christiansen/scripts/rep
289 http://w4.lns.cornell.edu/~pvhp/ptk/ptkTOC.html
290 http://world.std.com/~aep/ptkdb/
291 http://www.castlelink.co.uk/object_system/
292 http://www.fh-wedel.de/elvis/
293 ftp://ftp.blarg.net/users/amol/zsh/
294 ftp://ftp.funet.fi/pub/languages/perl/CPAN
295 http://search.cpan.org/CPAN/authors/id/S/SH/SHAY/dmake-4.5-20060619-SHAY.zip
296
297 # these are used to generate or match URLs
298 http://www.cpan.org/modules/by-authors/id/$1/$1$2/$dist
299 http://www.cpantesters.org/show/%s.yaml
300 ftp://(.*?)/(.*)/(.*
301 ftp://(.*?)/(.*)/(.*
302 ftp://(.*?)/(.*)/(.*
303 ftp://ftp.foo.bar/
304 http://$host/
305 http://wwwe%3C46/
306 ftp:/
307
308 # weird redirects that LWP doesn't like
309 http://www.theperlreview.com/community_calendar
310 http://www.software.hp.com/portal/swdepot/displayProductInfo.do?productNumber=PERL
311 http://groups.google.com/
312 http://groups.google.com/group/comp.lang.perl.misc/topics
313 http://groups.google.co.uk/group/perl.perl5.porters/browse_thread/thread/b4e2b1d88280ddff/630b667a66e3509f?#630b667a66e3509f
314 http://groups.google.com/group/comp.sys.sgi.admin/msg/3ad8353bc4ce3cb0
315 http://groups.google.com/group/perl.module.build/browse_thread/thread/c8065052b2e0d741
316 http://groups.google.com/group/perl.perl5.porters/browse_thread/thread/adaffaaf939b042e/20dafc298df737f0%2320dafc298df737f0?sa=X&oi=groupsr&start=0&num=3
317
318 # broken webserver that doesn't like HEAD requests
319 http://docs.sun.com/app/docs/doc/816-5168/syslog-3c?a=view
320
321 # these have been reported upstream to CPAN authors
322 http://www.gnu.org/manual/tar/html_node/tar_139.html
323 http://www.w3.org/pub/WWW/TR/Wd-css-1.html
324 http://support.microsoft.com/support/kb/articles/Q280/3/41.ASP
325 http://msdn.microsoft.com/workshop/author/dhtml/httponly_cookies.asp
326 http://search.cpan.org/search?query=Module::Build::Convert
327 http://www.refcnt.org/papers/module-build-convert
328 http://csrc.nist.gov/cryptval/shs.html
329 http://msdn.microsoft.com/workshop/author/dhtml/reference/charsets/charset4.asp
330 http://www.debian.or.jp/~kubota/unicode-symbols.html.en
331 http://www.mail-archive.com/perl5-porters@perl.org/msg69766.html
332 http://www.debian.or.jp/~kubota/unicode-symbols.html.en
333 http://rfc.net/rfc2781.html
334 http://www.icu-project.org/charset/
335 http://ppewww.ph.gla.ac.uk/~flavell/charset/form-i18n.html
336 http://www.rfc-editor.org/
337 http://www.rfc.net/
338 http://www.oreilly.com/people/authors/lunde/cjk_inf.html
339 http://www.oreilly.com/catalog/cjkvinfo/
340 http://www.cpan.org/modules/by-author/Damian_Conway/Filter-Simple.tar.gz
341 http://www.csse.monash.edu.au/~damian/CPAN/Filter-Simple.tar.gz
342 http://www.egt.ie/standards/iso3166/iso3166-1-en.html
343 http://www.bsi-global.com/iso4217currency
344 http://www.plover.com/~mjd/perl/Memoize/
345 http://www.plover.com/~mjd/perl/MiniMemoize/
346 http://www.sysadminmag.com/tpj/issues/vol5_5/
347 ftp://ftp.tpc.int/tpc/server/UNIX/
348 http://www.nara.gov/genealogy/
349 http://home.utah-inter.net/kinsearch/Soundex.html
350 http://www.nara.gov/genealogy/soundex/soundex.html
351 http://rfc.net/rfc3461.html
352 ftp://ftp.cs.pdx.edu/pub/elvis/
353 http://www.fh-wedel.de/elvis/
354
355 __END__
356
357 =head1 NAME
358
359 checkURL.pl - Check that all the URLs in the Perl source are valid
360
361 =head1 DESCRIPTION
362
363 This program checks that all the URLs in the Perl source are valid. It
364 checks HTTP and FTP links in parallel and contains a list of known
365 bad example links in its source. It takes 4 minutes to run on my
366 machine. The results are written to 'uris.txt' and list the filename,
367 the URL and the error:
368
369   * ext/Locale-Maketext/lib/Locale/Maketext.pod
370     http://sunsite.dk/RFC/rfc/rfc2277.html
371       404 Not Found
372   ...
373
374 It should be run every so often and links fixed and upstream authors
375 notified.
376
377 Note that the web is unstable and some websites are temporarily down.