ページ更新: 2009-06-30 (火) (429日前)

(2001-09-14 作成、2005-01-29 Wikiに移動して説明をちょっと修正)

HTMLの外部リンクチェック

HTMLのリンク切れを調べるPerlスクリプトを書いてみました。

開発+テスト環境は Windows2000 + ActivePerl v5.6.1-Build628、本番は Debian GNU/Linux Woody kernel 2.2.19 です。

目次

[編集]

参考文献 #

  • 河馬屋二千年堂's Page
    • lwpcook - libwww-perl クックブック
    • LWP - PerlでのWWWアクセスのためのライブラリ
    • LWP::UserAgent - WWW ユーザ・エージェント クラス
    • HTTP::Request - HTTPリクエストをカプセル化するクラス
    • HTTP::Response - HTTPレスポンスをカプセル化するクラス
↑
[編集]

仕様と方針 #

  • 他のサイトへのリンク先にHTTPで接続して、応答を調べる。
  • ディレクトリを指定し、その階層以下の HTML ファイル (*.html, *.htm, *.shtml) を対象とする。
    • File::Find を使う
  • HTMLのなかの <A href=....> タグを対象とする。
    • HTML::LinkExtor で良さそう
  • 自分のサイト内へのリンクは検査しない。
    • そういうのはDreamweaverなり、なんなりで出来ると思うし。
    • 相対パスは検査しない。（../path/to/file の形式に対しては手を抜く）
    • 指定した絶対パス（=自分のサイトのトップ) で始まるURLは検査しない。
  • 結果は標準出力に出す……当面は。cronで実行すれば結果がメールで届くし。
    • この方がデバッグが楽だ。CVS,XML,RSS化するのは後でよい。
  • 自分のPCやホスト(!=共有レンタル)で使うので、一般的なモジュールは全部使って良い（debianのパッケージ、ActivePerlのppm、CPAN）。これらを使って短時間で作成する。
    • 結局、1+2+1=4時間かかった。perlのオブジェクトに慣れてないのが敗因か
↑
[編集]

スクリプト #

#!/usr/bin/perl

use strict;

use File::Find ();
require HTML::LinkExtor;
use LWP::Simple;

 ## begin configration

    my $documentroot= '/var/www';
    my $siteurl= 'http://example.jp';

 ## end configration

 ## listup HTML documents

    use vars qw/*name *dir *prune/;
    *name  = *File::Find::name;
    *dir   = *File::Find::dir;
    *prune = *File::Find::prune;

    my @filelist;

sub callback_filefind {
    push @filelist, $name if /\.s?html?$/s;
}

    File::Find::find({wanted => \&callback_filefind}, $documentroot);

 ## extract link, and check link

    my @linklist;

sub callback_linkextor {
    my($tag, %links) = @_;
    if( $tag eq 'a'
    and ($links{'href'} =~ m!^http://!)
    and ($links{'href'} !~ m!^$siteurl!) ) {
        push @linklist, $links{'href'};
    }
}

    my @resultlist;

    for my $file (@filelist) { 
        print "\nfile: $file\n";

        @linklist = ();
        my $p = HTML::LinkExtor->new(\&callback_linkextor);
        $p->parse_file($file);

        for my $url (@linklist) { 
            if (head($url)) {
                print "    exist(HEAD) $url\n";
                push @resultlist, { file => $file, url => $url, result => 'exist(HEAD)' };
            } else {
                sleep 3;
                if (get($url)) {  # for @nifty, etc.
                    print "    exist(GET) $url\n";
                    push @resultlist, { file => $file, url => $url, result => 'exist(GET)' };
                } else {
                    print "    not exist: $url\n";
                    push @resultlist, { file => $file, url => $url, result => 'not exist' };
                }
            }
        }
    }

 ##

    print '='x70,"\n";
    for (@resultlist) {
        if( $_->{result} =~ /not exist/ ) {
            my $url= $_->{url};
            my $file= $_->{file};
            print "$file: $url\n";
        }
    }


 ## end
↑
[編集]

課題 #

Windows2000 + ActivePerlで動かしてリンクチェックは完了。普段はサーバ側でcronで起動するようにしたけど、もう少しましなものにしたい。

  1. User-Agent は入れた方がよいだろう。メールアドレスのヘッダもついでに。
  2. 同じURLが存在するとその数だけ検査してしまうので、検査結果をメモリにキャッシュしておく。
  3. もちろん、URLの#以後をカットしてから処理する。
  4. HTTPのエラーコードも調べる
  5. HEAD → GET の順で取得しているが、これを HEAD 数回 → GET にする。
  6. 所要時間を計測する。（timeとかtimesを入れればいいのだ）
  7. せっかく HEAD/GET 使ってるのだから、リンク先の更新日時を収集するようにしてもいいかも。
  8. time(from epoch) とURLとHTMLファイルのパス、そして前回の実行日時を記録しておけばいいだろう。
  9. 検査結果をファイルに取っておき、連続でリンク切れが生じているものを区別できるようにする。
  10. (2001.11.03追加) <A>〜</A>の中身も取得する、HTMLエディタ（ホームページビルダーなど）を使うときに便利なので。

……というわけで、そういったコードの断片。未テスト。

use LWP::UserAgent;

my $agentname  = 'OuterLinkChecker/0.1 http://example.jp/';  #1
my $mailaddress= 'webmaster@example.jp';                       #1
my @urlcache;

sub myHeadGet {
    my ($method, $url) = @_;

  # urlから#を取る
    $url =~ s/^(.*?)#.*$/$1/;                                  #3

  # キャッシュを調べる

  # UserAgent組み立て
    my $useragent = LWP::UserAgent->new;
    $useragent->agent("$agentname $useragent->agent");         #1
    $useragent->from($mailaddress);                            #1

  # ヘッダ組み立て
    my $request;
    if( $method eq 'GET' ) {
        $request = HTTP::Request->new(GET => $url);
    } else {
        $request = HTTP::Request->new(HEAD => $url);
    }
    $request->header('Accept' => 'text/html');

  # リクエストの送信
    my $response= $useragent->request($request);

  # 出力
    if( wantarray ) {
        return ($response->code, $response->headers->last_modified);  #4,7
    } else {
        return $response->is_success;
    }
}

sub head { myHeadGet('HEAD', @_); }
sub get { myHeadGet('GET', @_); }
↑
[編集]

同様の機能を持ってるっぽいソフトウェア #