Listing 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.