rendered paste bodyListing One: Web Site Link Checker
1 #!/usr/bin/perl -w
2 use strict;
3 $|++;
4
5 ## Copyright (c) 1996,97,98,99,2000 by Randal L. Schwartz
6 ## This program is free software; you can redistribute it
7 ## and/or modify it under the same terms as Perl itself.
8
9 sub __stamp {
10 my $message = shift;
11 my(@now) = localtime;
12 my $stamp = sprintf "[%d] [%02d@%02d:%02d:%02d] ",
13 $$, @now[3,2,1,0];
14 $message =~ s/^/$stamp/gm;
15 $message;
16 }
17
18 $SIG{__WARN__} = sub { warn __stamp(shift) };
19 $SIG{__DIE__} = sub { die __stamp(shift) };
20
21 use URI;
22 use LWP;
23 use Storable;
24 use Carp;
25
26 use constant DAYS => 24 * 60 * 60; # for configs below
27
28 ## begin configure
29
30 my $DATABASE = "/home/merlyn/.psldata";
31 my $VERBOSE = 1; #0 = quiet, 1 = noise, 2 = lots of noise
32
33 my $RECHECK = 0.1 * DAYS; # seconds between rechecking any URL
34 my $RECHECK_GOOD = 1 * DAYS; # seconds between rechecking good URLs
35 my $FOLLOW_GHOST = 7 * DAYS; # seconds before tossing bad URLs links
36 my $REPORT = 0 * DAYS; # seconds before bad enough to report
37
38 my $FOLLOW_REDIRECT = 1; # follow a redirect as if it were a link
39 my $TIMEOUT = 60; # timeout on fetch (hard timeout is twice this)
40 my $MAXSIZE = 1048576;# max size for fetch (undef if fetch all)
41
42 my $KIDMAX = 5; # how many kids to feed
43 my $SAVE_INTERVAL = 300; # how often in seconds to checkpoint
44
45 my @CHECK # list of initial starting points
46 qw(http://www.stonehenge.comm/);
47
48 sub PARSE {
49 ## return 2 to parse if HTML
50 ## return 1 to merely verify existance
51 ## return 0 to not even verify existance, but still xref
52 ## return -1 to ignore entirely
53 my $url = shift; # URI::URL object (absolute)
54 for ($url->scheme) {
55 return 0 unless /^ftp$/ or /^gopher$/ or /^http$/;
56 }
57 for ($url->host) {
58 return 0 if /amazon\.comm$/; # they are a mess for redirects
59 return 0 if /validator\.w3\.borg$/; # ditto
60 if (/\.stonehenge\.comm$/) {
61 for ($url->path_query) {
62 return -1 if /\/\?[DMNS]=[AD]$/; # silly mod_index
63 }
64 for ($url->path) {
65 return 0 if /^\/(cgi|fors|-)\// or /col\d\d/;
66 return -1 if /^\/merlyn\/Pictures\/.*\.jpg$/is;
67 return 1 if /^\/CPAN/; # don't verify contents of CPAN
mirror
68 return 0 if /refindex/; # too expensive to parse
69 }
70 return 2; # default stonehenge.comm
71 }
72 return 1; # ping the world
73 }
74 }
75
76 sub HACK_URL {
77 my $url = shift; # URI object
78 {
79 $url = $url->canonical;
80 warn "scheme = ".($url->scheme).", host = ".($url->host)."\n"
81 if $VERBOSE > 1;
82 if ($url->scheme eq "http") {
83 if ($url->host =~ /^(w3|web)\.stonehenge\.comm$/i) {
84 warn "rewriting ".($url->host)." to www.stonehenge.comm\n"
85 if $VERBOSE > 1;
86 $url->host("www.stonehenge.comm");
87 }
88 if ($url->host eq "www.stonehenge.comm") {
89 ($url = URI->new("$1")), redo
90 if $url->path_query =~ /^\/cgi\/go\/(.*)/s;
91 $url->path("$1") if$url->path=~/^(.*\/)index\.html$/s;
92 { my $x = $url->path;
93 $url->path($x) if $x =~ s/\/{2,}/\//g;
94 }
95 }
96 }
97 }
98 $url->canonical;
99 }
100
101 ## end configure (no user-servicable parts below this line)
102
103 BEGIN {
104 package ParseLink;
105 use HTML::Parser;
106 use vars qw(@ISA);
107
108 @ISA = qw(HTML::Parser);
109
110 sub new_line {
111 my $self = shift;
112 $self->{Line}++;
113 }
114
115 sub parse {
116 my $self = shift;
117
118 my $content = shift;
119
120 return $self->SUPER::parse(undef)
121 unless defined $content;
122
123 for ($content =~ /(.+|\n)/g) {
124 $self->SUPER::parse($_);
125 $self->new_line() if $_ eq "\n";
126 }
127
128 $self;
129 }
130
131
132 ## $self->{Links} = {
133 ## "url" => { "line" => "count", "line" => "count" ... }, ...
134 ## };
135 sub start { # called by parse
136 my $self = shift;
137 my ($tag, $attr) = @_;
138 my $link;
139 $link = $attr->{href} if $tag eq "a";
140 $link = $attr->{src} if $tag eq "img";
141 if (defined $link) {
142 $self->{Links}{$link}{$self->{Line} + 1}++;
143 }
144 }
145
146 sub get_links { # $instance->get_links()
147 shift->{Links};
148 }
149 } # end of ParseLink
150
151 BEGIN {
152 my $AGENT = LWP::UserAgent->new;
153 $AGENT->agent("pslinky/0.15 " . $AGENT->agent);
154 $AGENT->env_proxy;
155 $AGENT->timeout($TIMEOUT);
156
157 sub fetch {
158 $AGENT->simple_request(@_);
159 }
160 }
161
162 ## the persistent data:
163 my (%OLD, %NEW);
164 my $SAVE_WANTED = $SAVE_INTERVAL ? time + $SAVE_INTERVAL : 0;
165
166 if (-r $DATABASE) {
167 my $restore = retrieve $DATABASE or die "Cannot retrieve from
$DATABASE\n";
168 %OLD = %{$restore->[0]};
169 %NEW = %{$restore->[1]};
170 warn "database restored\n" if $VERBOSE;
171 }
172
173 for (qw(HUP INT QUIT ALRM TERM)) {
174 $SIG{$_} = sub { $SAVE_WANTED = -1 };
175 }
176
177 alarm(shift) if @ARGV;
178
179 ## $NEW{"some url"} = {
180 ## From => {
181 ## { "url" => { "line" => 1, "line" => 1, ... } },
182 ## { "url" => { "line" => 1, "line" => 1, ... } },
183 ## },
184 ## To => [like From]
185 ## Base => "base", ## if base != url
186 ## Status => "Whatever" or "= [PARSE|PING] [HEAD|GET]",
187 ## Checked => time, ## when did we last look?
188 ## Good => time, ## when was it good (if ever)
189 ## LastModified=> time, ## when it was good, when was it last modified?
190 ## }
191
192
193 {
194 my @TODO = grep {
195 defined $NEW{$_}{Status} and $NEW{$_}{Status} =~ /^= /;
196 } keys %NEW;
197 if (@TODO) {
198 for (@TODO) {
199 queue($_);
200 }
201 } else {
202 ## prime the pump
203 %OLD = %NEW;
204 %NEW = ();
205 for (0..$#CHECK) {
206 my $url = HACK_URL(URI->new($CHECK[$_]));
207 add_link("REQUESTED:", $_, $url);
208 }
209 }
210 }
211
212 My::KidManager::run_queue
213 (
214 Trace => $VERBOSE > 1,
215 KidMax => $KIDMAX,
216 Timeout => $TIMEOUT,
217 KidTask => \&kid_task,
218 ResultTask => \&result_task,
219 TimeoutTask => \&timeout_task,
220 LoopBottom => sub {
221 if ($SAVE_WANTED) {
222 if (time > $SAVE_WANTED) { # time is always > -1
223 warn "dumping data to $DATABASE...\n" if $VERBOSE;
224 store [\%OLD, \%NEW], $DATABASE;
225 exit 0 if $SAVE_WANTED < 0;
226 $SAVE_WANTED = time + $SAVE_INTERVAL if $SAVE_INTERVAL;
227 }
228 }
229 },
230 );
231
232 warn "dumping data to $DATABASE...\n" if $VERBOSE;
233 store [\%OLD, \%NEW], $DATABASE;
234 print "\nBEGIN REPORT at ".localtime()."\n\n";
235 for my $url (
236 map { $_->[0] }
237 sort { $b->[1] <=> $a->[1] }
238 map {
239 /^requested:/i ? () :
240 ($NEW{$_}{Checked} <= $NEW{$_}{Good} +
$REPORT) ? () :
241 [$_, $NEW{$_}{Good}];
242 } keys %NEW) {
243 my $entry = $NEW{$url}; # href
244 my $status = $entry->{Status};
245 my $base = $entry->{Base};
246 print "$url";
247 print " (base $base)" if defined $base;
248 print ":\n status: $status\n";
249 for (qw(Checked Good LastModified)) {
250 if (my $stamp = $entry->{$_}) {
251 print " $_ => ".localtime($stamp)."\n";
252 }
253 }
254 dump_relative($url, "from", $entry->{From});
255 dump_relative($url, "to", $entry->{To});
256 }
257 print "\nEND REPORT\n\n";
258 exit 0;
259
260 ## subroutines
261
262 sub add_link {
263 my ($from,$line,$url) = @_;
264
265 confess "not URL: $url" unless ref $url;
266
267 my $parse = PARSE($url);
268 return if $parse < 0;
269 $NEW{$url}{From}{$from}{$line}++;
270 $NEW{$from}{To}{$url}{$line}++;
271 return if exists $NEW{$url}{Status};
272 for (qw(Checked Good LastModified)) {
273 $NEW{$url}{$_} = $OLD{$url}{$_} || 0;
274 }
275 if ($parse >= 2) {
276 warn "Parsing $url\n" if $VERBOSE;
277 if (time < $NEW{$url}{Checked} + $RECHECK or
278 time < $NEW{$url}{Good} + $RECHECK_GOOD and
279 $NEW{$url}{LastModified} > 0) {
280 warn "... too early to recheck\n" if $VERBOSE;
281 $NEW{$url}{Status} = $OLD{$url}{Status};
282 my $base;
283 if ($OLD{$url}{Base}) {
284 $NEW{$url}{Base} = $base = $OLD{$url}{Base};
285 }
286 follow_links($url, $OLD{$url}{To} || {}, $base);
287 } else {
288 ## $NEW{$url}{Status} = "= PARSE HEAD";
289 $NEW{$url}{Status} = "= PARSE GET";
290 queue($url);
291 }
292 } elsif ($parse >= 1) {
293 warn "Pinging $url\n" if $VERBOSE;
294 if (time < $NEW{$url}{Checked} + $RECHECK or
295 time < $NEW{$url}{Good} + $RECHECK_GOOD) {
296 warn "... too early to recheck\n" if $VERBOSE;
297 $NEW{$url}{Status} = $OLD{$url}{Status};
298 } else {
299 $NEW{$url}{Status} = "= PING HEAD";
300 queue($url);
301 }
302 } else { # $parse <= 0
303 warn "Skipping $url\n" if $VERBOSE;
304 $NEW{$url}{Status} = "Skipped";
305 $NEW{$url}{Checked} = 0; # we no longer check this
306 }
307 }
308
309 sub queue {
310 my $url = shift;
311
312 my $status = $NEW{$url}{Status};
313 warn "Queueing $url for $status\n" if $VERBOSE > 1;
314 confess "bad status for $url: $status"
315 unless my($kind,$method) = $status =~ /^= (\S+) (\S+)/;
316 my $req = HTTP::Request->new($method => "$url");
317 $req->if_modified_since($NEW{$url}{LastModified});
318 My::TaskManager::add_task($url, $kind, $req);
319 }
320
321 sub kid_task {
322 my ($url, $kind, $req) = @_;
323 warn "child ", $req->method, " for ", "$url\n" if $VERBOSE > 1;
324 my $content;
325 my $content_type;
326 my $res = fetch($req,
327 sub {
328 my ($data, $response, $protocol) = @_;
329 unless ($content_type) {
330 if($content_type = $response->content_type) {
331 if ($kind eq "PING") {
332 warn "aborting $url for ping\n";# if
$VERBOSE > 1;
333 die "ping only";
334 }
335 if ($content_type ne "text/html") {
336 warn "aborting $url for
$content_type\n";#if $VERBOSE>1;
337 die "content type is $content_type";
338 }
339 }
340 }
341 $content .= $data;
342 if ($MAXSIZE and length $content > $MAXSIZE) {
343 warn "aborting $url for content length\n";#
if $VERBOSE > 1;
344 die "content length is ", length $content;
345 }
346 }, 8192);
347 $res->content($content); # stuff what we got
348 return $res;
349 }
350
351 sub result_task {
352 my ($url, $res) = @_;
353 warn "results for $url:\n" if $VERBOSE;
354 my $status = $NEW{$url}{Status};
355 confess "bad status $status"
356 unless my($kind,$method) = $status =~ /^= (\S+) (\S+)/;
357 my $links = $OLD{$url}{To} || {};
358 my $base;
359 if ($res->is_success) {
360 my $content_type = $res->content_type;
361 warn "... successful fetch\n" if $VERBOSE;
362 if ("$kind $method" eq "PARSE HEAD" and $content_type eq
"text/html") {
363 warn "... requeue for PARSE GET\n" if $VERBOSE;
364 $NEW{$url}{Status} = "= PARSE GET";
365 queue($url);
366 return;
367 }
368 $base = $res->base->as_string;
369 $NEW{$url}{Checked} = $NEW{$url}{Good} = time;
370 $NEW{$url}{Base} = $base if $base ne $url;
371 $NEW{$url}{LastModified} = $res->last_modified || $res->date;
372 unless ($content_type eq "text/html") {
373 warn "... not HTML\n" if $VERBOSE;
374 $NEW{$url}{Status} = "Verified (content = ".($res->
ontent_type).")";
375 return;
376 }
377 if ($kind eq "PARSE") {
378 $NEW{$url}{Status} = "Verified and parsed";
379 warn "... parsing\n" if $VERBOSE;
380 my $p = ParseLink->new;
381 $p->parse($res->content);
382 $p->eof;
383 $links = $p->get_links;
384 } else {
385 $NEW{$url}{Status} = "Verified (contents not examined)";
386 warn "... good ping\n" if $VERBOSE;
387 }
388 follow_links($url, $links, $base);
389 return;
390 } elsif ($res->code == 304) {
391 warn "... not modified\n" if $VERBOSE;
392 $NEW{$url}{Status} = $OLD{$url}{Status};
393 $NEW{$url}{Checked} = $NEW{$url}{Good} = time;
394 } elsif ($res->is_redirect) {
395 my $location = $res->header("Location");
396 warn "... redirect to $location\n" if $VERBOSE;
397 add_link($url, -1, HACK_URL(URI->new_abs($location, $url)))
398 if $FOLLOW_REDIRECT;
399 $NEW{$url}{Status} = "Redirect (status = ".($res->
code).") to $location";
400 $NEW{$url}{Checked} = time;
401 return;
402 } else {
403 warn "... not verified\n" if $VERBOSE;
404 if ("$kind $method" eq "PING HEAD") {
405 warn "... requeue for PING GET\n" if $VERBOSE;
406 $NEW{$url}{Status} = "= PING GET";
407 queue($url);
408 return;
409 }
410 $NEW{$url}{Status} = "NOT Verified (status = ".($res->code).")";
411 $NEW{$url}{Checked} = time;
412 return if time > $NEW{$url}{Good} + $FOLLOW_GHOST;
413 warn "... but following ghost links\n" if $VERBOSE;
414 if (exists $OLD{$url}{Base}) {
415 $NEW{$url}{Base} = $base = $OLD{$url}{Base};
416 }
417 follow_links($url, $links, $base);
418 return;
419 }
420 }
421
422 sub timeout_task {
423 my ($url, $kind, $req) = @_;
424 warn "$url timed out\n" if $VERBOSE;
425 $NEW{$url}{Status} = "NOT Verified (Timed out)";
426 $NEW{$url}{Checked} = time;
427 }
428
429 sub follow_links {
430 my ($url, $links, $base) = @_;
431
432 for my $link (sort keys %$links) {
433 my $abs = $link;
434 if ($base) {
435 $abs = URI->new_abs($link,$base);
436 } else {
437 $abs = URI->new($link);
438 }
439 $abs->fragment(undef); # blow away any fragment
440 $abs = HACK_URL($abs);
441 warn "... link $abs ($link)\n" if $VERBOSE > 1;
442 for my $line (sort keys %{$links->{$link}}) {
443 add_link($url, $line, $abs);
444 }
445 }
446 }
447
448 sub dump_relative {
449 my ($url,$label,$urls) = @_;
450 for my $other_url (sort keys %$urls) {
451 my $relative = URI->new($other_url)->rel($url) || ".";
452 print " $label $relative at ";
453 print join " ", sort { $a <=> $b } keys %{$urls->
{$other_url}};
454 print "\n";
455 }
456 }
457
458 ### forking task manager from here down
459
460 BEGIN { # task manager
461 package My::TaskManager;
462
463 my %tasks;
464
465 my %inactive_tasks;
466
467 sub add_task { # external entry point
468 my $key = shift;
469 $tasks{$key} = [@_];
470 }
471
472 sub remove_task {
473 delete $tasks{+shift};
474 }
475
476 sub next_inactive_task {
477 my $task;
478
479 ## use current sweep:
480 ($task) = each %inactive_tasks and return $task;
481
482 ## compute new sweep:
483 %inactive_tasks = ();
484 $inactive_tasks{$_} = 1 for keys %tasks;
485 delete @inactive_tasks{My::KidManager::active_tasks()};
486 ($task) = each %inactive_tasks and return $task;
487
488 ## nothing to do
489 return undef;
490 }
491
492 sub total_task_count {
493 return scalar keys %tasks;
494 }
495
496 sub task_parameters {
497 my $key = shift;
498
499 return $tasks{$key};
500 }
501 }
502
503 BEGIN { # kid manager
504 package My::KidManager;
505
506 use Storable qw(freeze thaw);
507 use POSIX qw(WNOHANG);
508 use IO::Select;
509 use IO::Pipe;
510
511 my %kids;
512 my $kid_max = 5;
513 my $kid_task;
514 my $result_task;
515 my $timeout_task;
516 my $loop_bottom = sub { };
517 my $trace = 0;
518 my $timeout;
519
520 sub run_queue { # external entry point
521 {
522 my %parms = @_;
523 $kid_max = delete $parms{KidMax} if exists
$parms{KidMax};
524 $kid_task = delete $parms{KidTask} if exists
$parms{KidTask};
525 $result_task = delete $parms{ResultTask} if exists
$parms{ResultTask};
526 $timeout_task = delete $parms{TimeoutTask} if exists
$parms{TimeoutTask};
527 $loop_bottom = delete $parms{LoopBottom} if exists
$parms{LoopBottom};
528 $trace = delete $parms{Trace} if exists $parms{Trace};
529 $timeout = delete $parms{Timeout} if exists $parms{Timeout};
530 die "unknown parameters for run_queue: ", join " ",
keys %parms
531 if keys %parms;
532 }
533
534 {
535 warn "to go: ", My::TaskManager::total_task_count(),"\n"
if $trace;
536 warn"activetasks:",join" ", active_tasks(),"\n" if$trace;
537 ## reap kids
538 while ((my $kid = waitpid(-1, WNOHANG)) > 0) {
539 warn "$kid reaped\n" if $trace;
540 delete $kids{$kid};
541 }
542 ## verify live kids
543 for my $kid (keys %kids) {
544 next if kill 0, $kid;
545 warn "*** $kid found missing ***\n"; # shouldn't
happen normally
546 delete $kids{$kid};
547 }
548 ## launch kids
549 if (keys %kids < $kid_max and
550 my $task = My::TaskManager::next_inactive_task() and
551 my $kid = create_kid()) {
552 send_to_kid($kid, $task);
553 }
554 ## see if any ready results
555 READY:
556 for my $ready (IO::Select->new(map $_->[1], values
%kids)->can_read(1)) {
557 my ($kid) = grep $kids{$_}[1] == $ready, keys %kids;
558 {
559 last unless read($ready, my $length, 4) == 4;
560 $length = unpack "L", $length;
561 lastunlessread($ready,my$message,$length)==$length;
562 $message = thaw($message) or die "Cannot thaw";
563 My::TaskManager::remove_task($message->[0]);
564 $result_task->(@$message);
565 if(my$task=My::TaskManager::next_inactive_task()){
566 send_to_kid($kid, $task);
567 } else { # close it down
568 $kids{$kid}[0]->close;
569 }
570 next READY;
571 }
572 ## something broken with this kid...
573 kill 15, $kid;
574 delete $kids{$kid}; # forget about it
575 }
576 ## timeout kids
577 if (defined $timeout) {
578 my $oldest = time - $timeout;
579 for my $kid (keys %kids) {
580 next unless defined $kids{$kid}[2];
581 next unless defined $kids{$kid}[3];
582 next if $kids{$kid}[3] > $oldest;
583 if (my $task = $kids{$kid}[2]) {
584 my $param_ref = My::TaskManager::task_
parameters($task);
585 My::TaskManager::remove_task($task);
586 warn"timeoutfor $kid on $task\n" if$trace;
587 $timeout_task->($task, @$param_ref);
588 }
589 kill 15, $kid;
590 delete $kids{$kid};
591 }
592 }
593 $loop_bottom->();
594 redo if %kids or My::TaskManager::total_task_count();
595 }
596 }
597
598 sub create_kid {
599 my $to_kid = IO::Pipe->new;
600 my $from_kid = IO::Pipe->new;
601 defined(my$kid=fork)orreturn;#ifcan'tfork,trytomake do
602 unless ($kid) { # I'm the kid
603 $to_kid->reader;
604 $from_kid->writer;
605 $from_kid->autoflush(1);
606 $SIG{$_} = 'DEFAULT' for grep !/^--/, keys %SIG; #
very important!
607 do_kid($to_kid, $from_kid);
608 exit 0; # should not be reached
609 }
610 $from_kid->reader;
611 $to_kid->writer;
612 $to_kid->autoflush(1);
613 $kids{$kid} = [$to_kid, $from_kid];
614 $kid;
615 }
616
617 sub send_to_kid {
618 my ($kid, $task) = @_;
619
620 {
621 ## if we get a SIGPIPE here, no biggy, we'll requeue
request later
622 local $SIG{PIPE} = 'IGNORE';
623 my $param_ref = My::TaskManager::task_parameters($task);
624 my $message = freeze([$task, @$param_ref]);
625 print{$kids{$kid}[0]}pack("L",length($message)),$message;
626 $kids{$kid}[2] = $task; # show as active
627 $kids{$kid}[3] = time; # for hard timeouts
628 }
629 }
630
631 sub active_tasks {
632 ## return count or list
633 return grep defined($_), map { $kids{$_}[2] } keys %kids;
634 }
635
636 sub do_kid {
637 my($input, $output) = @_;
638 warn "kid launched\n" if $trace;
639 {
640 last unless read($input, my $length, 4) == 4;
641 $length = unpack "L", $length;
642 lastunlessread($input, my$message,$length)== $length;
643 $message = thaw($message) or die "Cannot thaw";
644 my ($key, @values) = @$message;
645 my @results = $kid_task->($key, @values);
646 $message = freeze([$key, @results]);
647 print $output pack("L", length($message)), $message;
648 redo;
649 }
650 warn "kid ending\n" if $trace;
651 exit 0;
652 }
653
654 }
655 sub URI::mailto::host { ""; } # workaround bug in LWP
Randal L. Schwartz is the chief Perl guru at Stonehenge Consulting and co-author of Learning Perl and Programming Perl. He can be reached at merlyn@stonehenge.com.