File Coverage

blib/lib/HTML/ExtractContent.pm

Criterion	Covered	Total	%
statement	115	131	87.7
branch	31	50	62.0
condition			n/a
subroutine	19	19	100.0
pod	4	4	100.0
total	169	204	82.8

package HTML::ExtractContent;
use strict;
use warnings;
use utf8;

# core
use List::Util qw(reduce);

# cpan
use Class::Accessor::Lite (
    rw => [qw(opt content)],
);

# lib
use HTML::ExtractContent::Util;

our $VERSION = '0.12';

sub new {
    my ($class, $opt) = @_;
    my $self = bless {}, $class;
    $self->{opt} = {
        threshold          => 60,   # threhold for score of clusters
        min_length         => 30,   # minimum length of blocks
        decay_factor       => 0.75, # decay factor for block scores
        no_body_factor     => 0.72,
        continuous_factor  => 1.62, # continuous factor for block scores
        punctuation_weight => 10,   # score weight for punctuations
        punctuations => qr/(?:[。、．，！？]|\.[^A-Za-z0-9]|,[^0-9]|!|\?)/is,
        waste_expressions => qr/Copyright|All\s*Rights?\s*Reserved?/is,
            # characteristic keywords including footer
        affiliate_expressions =>
            qr/amazon[a-z0-9\.\/\-\?&]+-22/is,
        block_separator => qr/<\/?(?:div|center|td)[^>]*>|]*class\s*=\s*["']?(?:posted|plugin-\w+)['"]?[^>]*>/is,
#         nocontent => qr/<\/frameset>|]*url/is,
        nocontent => qr/<\/frameset>/is,
        min_nolink => 8,
        nolist_ratio => 0.2,
        debug => 0
    };
    $self->{pattern} = {
        a         => qr/]*>.*?<\/a\s*>/is,
        href      => qr/
        list      => qr/<(ul|dl|ol)(.+)<\/\1>/is,
        li        => qr/(?:]*>|]*>)/is,
        title     => qr/]*>(.*?)<\/title\s*>/is,
        headline  => qr/(\s*(.*?)\s*<\/h\d\s*>)/is,
        head      => qr/]*>.*?<\/head\s*>/is,
        comment   => qr{ (?:
             |
            # remove invisible elements
            < ( [\w:.-]+ ) \s [^>]*? style \s* = [^>]*? \b
                (?: display \s* : \s* none | visibility \s* : \s* hidden )
            \b [^>]* > .*?
        ) }xis,
        special   => qr//is,
        useless   => [
            qr/<(script|style|select|noscript)[^>]*>.*?<\/\1\s*>/is,
            qr/]*(?:id|class)\s*=\s*['"]?\S*(?:more|menu|side|navi)\S*["']?[^>]*>/is,
        ],
    };
    return bless $self, $class;
}

sub as_text {
    my $self = shift;
    return to_text $self->content;
}

sub as_html {
    my $self = shift;
    return $self->content;
}

sub extract {
    my $self = shift;;
    $self->content(shift);
    if ($self->content =~ $self->opt->{nocontent}) {
        # frameset or redirect
        $self->content('');
        return $self;
    }
    $self->_extract_title;
    $self->_eliminate_head;

    $self->_eliminate_useless_symbols;
    $self->_eliminate_useless_tags;

    my ($factor, $continuous);
    $factor = $continuous = 1.0;
    my $body = '';
    my $score = 0;
    my $best = {
        content => "",
        score => 0,
    };
    my @list = split $self->opt->{block_separator}, $self->content;
    my $flag = 0;
    for my $block (@list) {
        $block = strip $block;
        next unless decode $block;
        $continuous /= $self->opt->{continuous_factor} if length $body;

        # ignore link list block
        my $nolink = $self->_eliminate_links($block);
        my $nolinklen = length $nolink;
        next if $nolinklen < $self->opt->{min_length};

        # score
        my $c = $self->_score($nolink, $factor);
        $factor *= $self->opt->{decay_factor};

        # anti-scoring factors
        my $no_body_rate = $self->_no_body_rate($block);

        $c *= ($self->opt->{no_body_factor} ** $no_body_rate);
        my $c1 = $c * $continuous;

        # cluster scoring
        if ($c1 > $self->opt->{threshold}) {
            $flag = 1;
            print "\n---- continue $c*$continuous=$c1 $nolinklen\n\n$block\n"
                if $self->opt->{debug};
            $body .= $block . "\n";
            $score += $c1;
            $continuous = $self->opt->{continuous_factor};
        } elsif ($c > $self->opt->{threshold}) {
            $flag = 1;
            print "\n---- end of cluster: $score\n" if $self->opt->{debug};
            if ($score > $best->{score}) {
                print "!!!! best: score=$score\n" if $self->opt->{debug};
                $best = {
                    content => $body,
                    score => $score,
                };
            }
            print "\n" if $self->opt->{debug};
            $body = $block . "\n";
            $score = $c;
            $continuous = $self->opt->{continuous_factor};
            print "\n---- continue $c*$continuous=$c1 $nolinklen\n\n$block\n"
                if $self->opt->{debug};
        } else {
            $factor /= $self->opt->{decay_factor} if !$flag;
            print "\n>> reject $c*$continuous=$c1 $nolinklen\n$block\n",
                "<< reject\n" if $self->opt->{debug};
        }
    }
    print "\n---- end of cluster: $score\n" if $self->opt->{debug};
    if ($best->{score} < $score) {
        print "!!!! best: score=$score\n" if $self->opt->{debug};
        $best = {
            content =>$body,
            score => $score,
        };
    }
    $self->content($best->{content});

    return $self;
}

sub _score {
    my ($self, $nolink, $factor) = @_;
    return ((length $nolink)
                + (match_count $nolink, $self->opt->{punctuations})
                    * $self->opt->{punctuation_weight})
        * $factor;
}

sub _no_body_rate {
    my ($self, $block) = @_;
    return (match_count $block,$self->opt->{waste_expressions})
        + (match_count $block,$self->opt->{affiliate_expressions})/2.0;
}

sub _extract_title {
    my $self = shift;
    my $title;
    if ($self->content =~ $self->{pattern}->{title}) {
        $title = strip (strip_tags $1);
        if (length $title) {
            my $pat = $self->{pattern}->{headline};
            $self->{content} =~ s/$pat/
                (index $title, strip(strip_tags($2))) >= 0 ? "$2<\/div>" : "$1"/igse;
        }
    }
}

sub _eliminate_head {
    my $self = shift;
    my $pat = $self->{pattern}->{head};
    $self->{content} =~ s/$pat//is;
}

sub _eliminate_useless_symbols {
    my $self = shift;
    my $comment = $self->{pattern}->{comment};
    my $special = $self->{pattern}->{special};
    $self->{content} =~ s/$comment//igs;
    $self->{content} =~ s/$special//igs;
}

sub _eliminate_useless_tags {
    my $self = shift;
    my @useless = @{$self->{pattern}->{useless}};
    for my $pat (@useless) {
        $self->{content} =~ s/$pat//igs;
    }
}

sub _eliminate_links {
    my ($self, $block) = @_;
    my $count = match_count $block, $self->{pattern}->{a};
    my $nolink = to_text (eliminate_forms (eliminate_links $block));
    return '' if length $nolink < $self->opt->{min_nolink} * $count;
    return '' if $self->_is_linklist($block);
    return $nolink;
}

sub _is_linklist {
    my ($self, $block) = @_;
    my $listpat = $self->{pattern}->{list};
    if ($block =~ $listpat) {
        my $list = $2;
        my @fragments = split($listpat, $block, 2);
        my $nolist = $list;
        $nolist =~ s/$listpat//igs;
        $nolist = to_text(join($nolist, @fragments));
        my @listitems = split $self->{pattern}->{li}, $list;
        shift @listitems;
        my $rate = 0;
        for my $li (@listitems) {
            $rate++ if $li =~ $self->{pattern}->{href};
        }
        $rate = 1.0 * $rate / ($#listitems+1) if $#listitems+1;
        $list = to_text $list;
        my $limit = ($self->opt->{nolist_ratio}*$rate)
            * ($rate * (length $list));
        return length $nolist < $limit;
    }
    return 0;
}

1;
__END__