HTML::Feature::Engine::TsubuanLike

Tsubuanが死んでて困ってるところにHTML::Featureが来てこれで勝つる！とおもったけどHTML::Elementで返してくれるのがやっぱり欲しいので、TsubuanっぽいアルゴリズムでEngineを実装してみた。Tsubuanの基礎となるタグ／テキスト比をつかったアルゴリズムはブログの記事本文を抽出するスクリプトをつくってみたを参照。Elementを結果として返したい都合上ちょっと違いますが、まあTsubuanとだいたい似たような結果になります。
使い方としては、$result->{element}でHTML::Elementがとれて、そのas_HTMLは$result->{html}にも入っています。ちなみにあのアルゴリズムは空文字列を返すこともあるんですが、このモジュールでは何もとれなかった場合はHTML::TreeBuilderのルートがかえってきます。ちなみにちょっと試してみたところH::F::Engine::TagStructureのほうが性能いい感じなので、あのアルゴリズムでHTML::Elementで返してくれるのもあるとうれしいと思いました。

USAGE

use HTML::Feature;

my $feature = HTML::Feature->new(
    engine => 'TsubuanLike'
);
my $result = $feature->parse(shift);

unless ($result->{success}) {
    $result->{element} # root
}

$result->{element} # HTML::Element
$result->{html}    # HTML strings
$result->{text}    # default attributes: 'text', 'description' and 'title'

HTML/Feature/Engine/TsubuanLike.pm

package HTML::Feature::Engine::TsubuanLike;
use strict;
use warnings;
use base qw(HTML::Feature::Engine);
use HTML::TreeBuilder;

sub run {
    my $self = shift;
    my $c = shift;
    $self->_tag_cleaning($c);
    $self->_score($c);
    return $self;
} 

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

sub _score {
    my $self = shift;
    my $c = shift;
    my $root = HTML::TreeBuilder->new;
    $root->parse( $c->{html} );
    
    if (my $title = $root->find("title")) {
        $self->{title} = $title->as_text;
    }

    if (my $desc = $root->look_down(
        _tag => 'meta',
        name => 'description'
    )) {
        my $string = $desc->attr('content');
        $string =~ s{<br>}{}xms;
        $self->{desc} = $string;
    }

    my @tsubuan_score = grep {
        ($self->_tag_text_frac($_) > 0)
        && ($self->_tag_text_frac($_) < 0.1)
    } $root->descendants;
    
    my $target;
    if (@tsubuan_score) {
        @tsubuan_score = sort {
            length($b->as_text) <=> length($a->as_text)
        } @tsubuan_score;
        $self->{success} = 1;
        $target = $tsubuan_score[0];
    }
    else {
        $self->{success} = 0;
        $target = $root;
    }
    
    $self->{html} = $target->as_HTML;
    $self->{text} = $target->as_text;
    $self->{element} = $target;
    delete $self->{tag_text_frac};
    
    if ( $c->{enc_type} ) {
        map {
            Encode::encode( $c->{enc_type}, $self->{$_} )
        } qw/title desc text html/;
    }
}

sub _tag_text_frac {
    my ($self, $elem) = @_;
    
    unless ($self->{tag_text_frac}) {
        $self->{tag_text_frac} = {};
    }
    
    unless (defined($self->{tag_text_frac}->{$elem->idf})) {
        my $text = $elem->as_text;
        my @objs = $elem->descendants;
        
        $self->{tag_text_frac}->{$elem->idf} =
            (@objs * 2)
            / (length($text) + 1);
    }
    
    return $self->{tag_text_frac}->{$elem->idf};
}

1;