Thu, 04 Dec 2003

Automatic Trackback

Trackback の Auto-Discovery と 送信 を組み合わせれば、自動で Trackback を送ることもできます。今回は、ある URL を渡すと、リンクしている URL に自動で Trackback 送信するスクリプトを書いてみます。

HTML::LinkExtor

HTML 内からのリンク抽出には HTML::LinkExtor を使用します。HTML::LinkExtor は、HTML::Parser のサブクラスで、リンク要素が見つかった際に呼び出される callback サブルーチンを設定しておくことによって、ある HTML 内のリンク URL に対して特定のアクションを起こすことができます。

サンプルコード

早速コードを見てみましょう。List 1 のようなスクリプトになります。このスクリプトは、
  1. URL から HTML の取得
  2. HTML からリンク URL を抽出
  3. リンク URL から Trackback Auto-Discovery
  4. 見つかった場合には、Trackback Ping 送信
という流れになっています。 

use HTML::LinkExtor;
use HTTP::Request::Common;
use Encode;
use LWP::UserAgent;
use Net::TrackBack;
use URI;
使用するモジュールをロードします。リンク抽出用に HTML::LinkExtor, Trackback Discovery 用に Net::TrackBack を使用しています。 

our $IgnoreLinks   = qr/movabletype\.org/;
our $Debug         = 1;
$IgnoreLinks には、リンクとして見つかっても実際には無視するドメインを正規表現で記述しています。$Debug を true にしておくと、実際には Trackback Ping を送信せず、動作確認のログが流れますので、テストしてみる場合にはこれを 1 にしておくとよいでしょう。 

my $ua = LWP::UserAgent->new();
   $ua->agent("autotrack/$VERSION");
my $html = fetch_content($ua, $url) or die "Can't GET $url";
LWP::UserAgent オブジェクトを new し、fetch_content で HTML を Unicode 文字列として取得します。エラーがあれば終了します。 

sub fetch_content {
    my($ua, $url) = @_;

    my $request = HTTP::Request->new(GET => $url);
    my $response = $ua->request($request);
    return unless $response->is_success;

    my $content_type = $response->header('Content-Type');
    my $charset = ($content_type =~ /charset=([\w\-]*)/)[0] || "utf-8";
    return decode($charset, $response->content);
}
fetch_content では、HTTP レスポンスの Content-Type から charset を調べて Encode モジュールで decode しています(*1)。 

my @links = find_links($html, $url);
for my $link (@links) {
    warn "[Debug] finding Ping URL in $link\n" if $Debug;
    my $ping_url = find_ping_url($link);
    if ($ping_url) {
        warn "[Debug] Found Ping URL $ping_url\n" if $Debug;
        send_ping($ua, $ping_url, $html, $url);
    }
}
find_links で、HTML 内のリンクを抽出し、find_ping_url で Trackback Ping URL を Auto-Discovery し、見つかったものについて send_ping で Ping を送信します。 

sub find_links {
    my($html, $url) = @_;
    my $domain = URI->new($url)->host;

    my @links;
    my $cb = sub {
        my($tag, %attr) = @_;
        push @links, $attr{href}
            if $tag eq 'a' && $attr{href} &&
               $attr{href} =~ /https?:/ &&
               $attr{href} !~ /$domain/ &&
               $attr{href} !~ $IgnoreLinks;
    };

    my $p = HTML::LinkExtor->new($cb);
       $p->parse($html);

    return @links;
}
HTML::LinkExtor モジュールで HTML からリンクを取り出します。コールバック関数 $cb では、
  1. a タグであり
  2. href が空でなく
  3. href が絶対 URL で
  4. href が同一ドメインでなく
  5. href が $IgnoreLinks にマッチしない
という条件のもののみ、抽出するようにしています。 

sub find_ping_url {
    my $link = shift;
    my $p = Net::TrackBack->new();
    my @ping_url = $p->discover($link);
    return @ping_url ? $ping_url[0] : undef;
}
Trackback Auto-Discovery では、自前のコードで Auto-Discovery を実装しましたが、ここでは再発明を避けるため CPAN モジュール Net::TrackBack でカンタンに実装しています。 

sub send_ping {
    my($ua, $ping_url, $html, $url) = @_;
    my $title = title_for($html, $url);
    my %data = (
        url       => $url,
        blog_name => $title,
        title     => $title,
        charset   => "utf-8",
    );
send_ping で実際に Ping を送信します。HTML と URL から、Ping に送信するデータ %data を作成しています。ここでは、title_for で取得したページのタイトルを blog_name と title に共用し、excerpt については送らない実装としています(*2)。 

sub title_for {
    my($html, $url) = @_;
    my $title_part = ($html =~ m!<title>(.*)</title>!is)[0];
    return $title_part || URI->new($url)->host;
}
title_for は HTML の title タグを抽出しています。抽出に失敗した場合には、URL のドメイン部分で代用します。 

    if ($Debug) {
        print "[Debug] Send ping to $ping_url with:\n";
        print map { "  $_ => $data{$_}\n" } keys %data;
    } else {
        my $request = POST $ping_url, [ \%data ];
        my $response = $ua->request($request);
        my $status = $response->is_success
            ? "successful" : "failure";
        print "Sent ping to $ping_url: $status\n";
    }
$Debug が true の場合には、送信内容を表示するだけで、false の場合には実際に Trackback Ping を送信しています(*3)。

Running the Hack

http://blog.bulknews.net/mt/archives/000582.html を対象にして、このスクリプトを実行してみます。テストのため $Debug = 1 のままとしておきます(*4)。 

% ./autotrack.pl http://blog.bulknews.net/mt/archives/000582.html
[Debug] finding Ping URL in http://fenrir.naruoka.org/archives/000106.html
[Debug] Found Ping URL http://fenrir.naruoka.org/mt/mt-tb.cgi/103
[Debug] Send ping to http://fenrir.naruoka.org/mt/mt-tb.cgi/103 with:
  blog_name => blog.bulknews.net: MT Plugin Development
  url => http://blog.bulknews.net/mt/archives/000582.html
  charset => utf-8
  title => blog.bulknews.net: MT Plugin Development

Hacking the Hack

今回は URL を指定して単体で動くツールとして実装しましたが、MovableType や Blosxom といった Blog ツールのプラグインなどとして実装する方が面白そうです。その場合、エントリの Permalink や Blog URL はツールから取得するように実装すればよいでしょう。

実際に、blosxom では autotrack プラグイン、また 最近のバージョンの MovableType では自動で Trackback Ping URL を探して Ping するオプション(*5)がデフォルトで用意されています。

今回のコードでは、一度送信した URL に対して二度送らないなどの処理を入れていません。実際に利用する際には、キャッシュを作成するなどして、そうした面もケアする必要があるでしょう。

See Also

Listings

List 1: autotrack.pl 
#!/usr/local/bin/perl -w
# autotrack - Automatic Trackback Pinger

use strict;
use HTML::LinkExtor;
use HTTP::Request::Common;
use Encode;
use LWP::UserAgent;
use Net::TrackBack;
use URI;

our $VERSION       = "1.0";
our $IgnoreLinks   = qr/movabletype\.org/;
our $Debug         = 1;

my $url = shift;

my $ua = LWP::UserAgent->new();
   $ua->agent("autotrack/$VERSION");
my $html = fetch_content($ua, $url) or die "Can't GET $url";

my @links = find_links($html, $url);
for my $link (@links) {
    warn "[Debug] finding Ping URL in $link\n" if $Debug;
    my $ping_url = find_ping_url($link);
    if ($ping_url) {
        warn "[Debug] Found Ping URL $ping_url\n" if $Debug;
        send_ping($ua, $ping_url, $html, $url);
    }
}

sub fetch_content {
    my($ua, $url) = @_;

    my $request = HTTP::Request->new(GET => $url);
    my $response = $ua->request($request);
    return unless $response->is_success;

    my $content_type = $response->header('Content-Type');
    my $charset = ($content_type =~ /charset=([\w\-]*)/)[0] || "utf-8";
    return decode($charset, $response->content);
}

sub find_links {
    my($html, $url) = @_;
    my $domain = URI->new($url)->host;

    my @links;
    my $cb = sub {
        my($tag, %attr) = @_;
        push @links, $attr{href}
            if $tag eq 'a' && $attr{href} &&
               $attr{href} =~ /https?:/ &&
               $attr{href} !~ /$domain/ &&
               $attr{href} !~ $IgnoreLinks;
    };

    my $p = HTML::LinkExtor->new($cb);
       $p->parse($html);

    return @links;
}

sub find_ping_url {
    my $link = shift;
    my $p = Net::TrackBack->new();
    my @ping_url = $p->discover($link);
    return @ping_url ? $ping_url[0] : undef;
}

sub send_ping {
    my($ua, $ping_url, $html, $url) = @_;
    my $title = title_for($html, $url);
    my %data = (
        url       => $url,
        blog_name => $title,
        title     => $title,
        charset   => "utf-8",
    );

    if ($Debug) {
        print "[Debug] Send ping to $ping_url with:\n";
        print map { "  $_ => $data{$_}\n" } keys %data;
    } else {
        my $request = POST $ping_url, [ \%data ];
        my $response = $ua->request($request);
        my $status = $response->is_success
            ? "successful" : "failure";
        print "Sent ping to $ping_url: $status\n";
    }
}

sub title_for {
    my($html, $url) = @_;
    my $title_part = ($html =~ m!<title>(.*)</title>!is)[0];
    return $title_part || URI->new($url)->host;
}
*1) 必要なら meta タグのスキャンや、Encode::Guess による自動判定も入れると、より robust になるでしょう。
*2) 実際には blog_name は必須でない実装が多いので送らなくても平気かもしれません。
*3) Net::TrackBack がらみで warning が出ますが無視して問題ありません。
*4) Trackback Ping は取り消すことができないため、実際にこのスクリプトで送ることはオススメしません。コードの参考程度にしておいてください。
*5) autodiscover_links という項目です。

posted at: 06:00 by miyagawa | category: Trackback Pings | permalink
Trackback (1) | Printer Friendly | Email this blog

Prev: Trackback Ping 一覧を RSS 出力する
Next: Trackback Ping を送信する

About This Blog

Weblog まわりのテクノロジーをネタにして、プログラミングテクニックを Cookbook 形式で紹介しています。

Site Search


WWW This Site
Archive of All Entries
Syndicate this site (XML)

©2003- Tatsuhiko Miyagawa. Japan. All rights reserved.