HTML::Feature::Engine::LDRFullFeed - WedataにあるLDR Full FeedのSITEINFOを使ってWebページの本文を抽出するPerlモジュール

LDR Full FeedのSITEINFOがWedataに移動して便利になったので、そろそろHTML::Featureのエンジンが必要だと思って書いてみた。HTML::FeatureについてはHTML::Feature - 重要部分を抽出するモジュール - - download_takeshi’s diaryを、エンジンの拡張についてはHTML::Featureはエンジンをいろいろ拡張できるよ！ - download_takeshi’s diaryを参照ください。

HTML::Feature::Engine::LDRFullFeed

koyachiさんのWebService::Wedataを使ってWedataからSITEINFOを取得、そのSITEINFOをpriority順にソートして、最初にURLがマッチしたSITEINFOのXPathでHTML::Elementをとってくるという仕組み。LDRFullFeedの今の実装みてないのでかなり適当な気もするけど、動いてるので多分大丈夫。priority→typeの仕様変更に対応。

package HTML::Feature::Engine::LDRFullFeed;
use strict;
use warnings;
use base qw(HTML::Feature::Engine);
use HTML::Feature::Result;
use HTML::TreeBuilder;
use HTML::TreeBuilder::XPath;
use WebService::Wedata;

sub run {
    my ($self, $c, $html_ref, $opt) = @_;
        
    die unless $opt->{url};
    return $self->_extract($c, $html_ref, $opt->{url});
} 

sub _tag_cleaning {
    my ($self, $html) = @_;
    return unless $html;
    # preprocessing
    $html =~ s{<!-.*?->}{}xmsg;
    $html =~ s{<script[^>]*>.*?<\/script>}{}xmgs;
    $html =~ s{&nbsp;}{ }xmg;
    $html =~ s{&quot;}{\'}xmg;
    $html =~ s{\r\n}{\n}xmg;
    $html =~ s{^\s*(.+)$}{$1}xmg;
    $html =~ s{^\t*(.+)$}{$1}xmg;
    # control code ( 0x00 - 0x1f, and 0x7f on ascii)
    for ( 0 .. 31 ) {
        my $control_code = '\x' . sprintf( "%x", $_ );
        $html =~ s{$control_code}{}xmg;
    }
    $html =~ s{\x7f}{}xmg;
    return $html;
}

sub _extract {
    my ($self, $c, $html_ref, $url) = @_;
    my $result = HTML::Feature::Result->new;

    my $root = HTML::TreeBuilder::XPath->new_from_content($$html_ref);
   
    my @contents;
    my $siteinfo = $self->_detect_siteinfo($c, $url);
    if ($siteinfo) {
        @contents = $self->_xpath2elems($siteinfo->{data}->{xpath}, $root);
        return unless (@contents);
        if (my @title = $self->_xpath2elems('//title', $root)) {
            $result->title($title[0]->as_text);
        }
    }
    else {
        return;
    }
    
    my $element = HTML::TreeBuilder->new_from_content(
        $self->_tag_cleaning(
            join '', map {$_->as_HTML('<>"&')} @contents
        )
    );
    $root->delete;
    $result->element($element);
    return $result;
}

sub _xpath2elems {
    my ($self, $xpath, $context) = @_;

    my $nodes;
    if (eval {
        $nodes = $context->findnodes($xpath);        
    }) {
        return $nodes->get_nodelist;
    }
    return;
}

sub _detect_siteinfo {
    my ($self, $c, $url) = @_;
   
    my $wedata = WebService::Wedata->new;
    $wedata->{ua} = $c->user_agent;
    
    my $i = 0;
    my %priority = qw/
        SBM 1000
        INDIVIDUAL 100
        IND 100
        SUBGENERAL 10
        SUB 10
        GENERAL 1
        GEN 1
    /;
    
    my $db = $wedata->get_database('LDRFullFeed');
    for my $item (
        sort {
            $a->{data}->{priority} <=> $b->{data}->{priority}
        }
        map {
            $_->{data}->{priority} ||= ($_->{data}->{type})
                ? $priority{$_->{data}->{type}}
                : 0; $_;
        } @{$db->get_items}
    ) {
        if (($item->{data}->{url}) && ($url =~ /$item->{data}->{url}/)) {
            return $item;
        }
    }
    return;
}
1;

HTML::Featureをちょっといじる

HTML::Featureはデフォではuser_agentが変更できないのと、Engineが自分の処理してるページのURLを知る事ができないって仕様になってて、特に後者はSITEINFOを使う上で致命的になる。ので$self->engine->runにオプションも渡せるようにして、HTML::Feature::Engine::LDRFullFeed側でそこからURLを貰ってくるという実装にしてます。でもこれだとHTML::Feature::parseにURLを2個渡さなくちゃいけなくてださいので、なんとかしてほしいなー＞id:download_takeshi

package HTML::Feature_;
use base qw/HTML::Feature/;
sub user_agent {_user_agent(@_)};
sub _user_agent {
    my $self = shift;
    return $self->{user_agent} ||= SUPER->_user_agent;
}

sub _run {
    my ($self, $html_ref, $opts) = @_;
    $opts ||= {};

    local $self->{element_flag} = exists $opts->{element_flag} ? $opts->{element_flag} : $self->{element_flag};
    $self->engine->run($self, $html_ref, $opts);
}

extract.pl

今の仕様だとテスト書くのがめんどくさかったので、とりあえず適当にコマンドラインで使えるサンプルをオレオレtsubuanをベースに書いた。たぶんCGIでもうごきます。CGIで動かしたときの仕様はtsubuan互換、コマンドラインでの実行例は以下のようなかんじ。SITEINFOが存在しなかったときにはデフォルトEngineのTagStructureが動くようにしてます。

% perl extract.pl http://d.hatena.ne.jp/fuba/20070401/1175418910
LDRFullFeed
<html><head></head><body><p><a class="keyword" href="http://d.hatena.ne.jp/keyword/%c3%e6%b3%d8%c0%b8">中学生</a>からは<a class="keyword" href="http://d.hatena.ne.jp/keyword/%a4%cf%a4%c6%a4%ca%a5%a2%a5%f3%a5%c6%a5%ca">はてなアンテナ</a>！ <a class="keyword" href="http://d.hatena.ne.jp/keyword/%a4%cf%a4%c6%a4%ca%a5%a2%a5%f3%a5%c6%a5%ca%cd%df%a4%b7%a4%a4%a1%aa">はてなアンテナ欲しい！</a><p class="sectionfooter"><a href="/fuba/20070401/1175418910">Permalink</a> | <a href="/fuba/20070401/1175418910#c">コメント(0)</a> | <a href="/fuba/20070401/1175418910#tb">トラックバック(0)</a> | 18:15</body></html>