#!/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"; print "
\n"; print "リンクの有効性を確認したいアンカー記述<A>があるページのアドレス
\n"; print "\n"; print "\n"; print "
\n"; print "※リンクが多い場合は時間がかかります。\n"; 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/\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 } sub end_msg { print <<"EOF";

EOF }