#!/usr/bin/perl # リンクチェッカー v1.00 # for Perl5 and LWP # # 参考文献・引用元 http://www.foo.gr.jp/netprog/linkchecker.html # Copyright(c) 1999-2002 Kamiyashiki Laboratory # 利用許可 2002/3/9 # # CGI移植 by CGI-RESCUE use LWP::UserAgent; use HTML::LinkExtor; read(STDIN,$buffer,$ENV{'CONTENT_LENGTH'}); if ($buffer eq "") { &head_msg; print "
\n";
&end_msg;
exit;
}
@pairs = split(/&/,$buffer);
foreach $pair (@pairs) {
($name,$value) = split(/=/,$pair);
$value =~ tr/+/ /;
$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
$value =~ s/&/&/g;
$value =~ s/"/"/g;
$value =~ s/</g;
$value =~ s/>/>/g;
$value =~ s/\n//g;
$value =~ s/\r//g;
$value =~ s/\f//g;
$value =~ s/\t//g;
$in{$name} = $value;
}
$ua = LWP::UserAgent->new;
$ua->timeout( 15 );
$url = $in{'target'};
$req = HTTP::Request->new( GET => $url );
$res = $ua->request( $req );
&head_msg;
if( $res->is_success ) {
$parser = HTML::LinkExtor->new( \&callback, $url );
$parser->parse( $res->content );
}
else { print "Error: " . $res->status_line . "\n"; }
&end_msg;
exit;
sub callback() {
my($tag, %links) = @_;
if ( $tag eq "a" ) {
foreach $key ( keys(%links) ) {
my($ref) = $links{$key};
my($url) = $ref->as_string;
if ( $url =~ /^http/ ) { checklink( $url ); }
}
}
}
sub checklink() {
my($url) = @_;
my($req) = HTTP::Request->new( HEAD => $url );
my($res) = $ua->request( $req );
if ( $res->is_success ) { print "OK: " . $url . "
\n"; }
else {
my($req) = HTTP::Request->new( GET => $url );
my($res) = $ua->request( $req );
if( $res->is_success ) { print "OK: " . $url . "
\n"; }
else { print "NG: " . $url . " (" . $res->status_line . ")
\n"; }
}
}
sub head_msg {
print "HTTP/1.0 200 OK\r\n";
print "Content-type: text/html\r\n\r\n";
print <<"EOF";
EOF }