File Coverage

blib/lib/HTML/ExtractMain.pm

Criterion	Covered	Total	%
statement	4	6	66.6
branch			n/a
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	6	8	75.0

#!perl

package HTML::ExtractMain;
use Carp qw( carp );
use HTML::TreeBuilder;
use Object::Destroyer 2.0;
use Scalar::Util qw( blessed refaddr );
use base qw( Exporter );
use strict;
use warnings;

our @EXPORT_OK = qw( extract_main_html );

sub extract_main_html {
    my $arg = shift;

    unless ( defined $arg ) {
        carp 'extract_main_html requires HTML content as an argument';
        return;
    }

    my $tree;
    if ( ref $arg and blessed $arg and $arg->isa('HTML::TreeBuilder') ) {
        $tree = $arg;
    } else {
        my $raw_html = $arg;

        $tree = eval { HTML::TreeBuilder->new_from_content($raw_html) };
        if ( !$tree ) {
            carp 'check HTML input, could not create new HTML::TreeBuilder';
            return;
        }
    }

    my %options = @_;
    if ( defined $options{output_type} ) {
        $options{output_type} = lc( $options{output_type} );
    } else {
        $options{output_type} = "xhtml";
    }

    # Remove any lingering circular references. Details at:
    # http://www.perl.com/pub/2007/06/07/better-code-through-destruction.html
    my $sentry = Object::Destroyer->new( $tree, 'delete' );

    # Use the Readability algorithm, inspired by:
    # http://lab.arc90.com/experiments/readability/js/readability.js

    # Study all the paragraphs and find the chunk that has the best score.
    # A score is determined by things like: Number of 's, commas,
    #  class names, etc.

    my %parents;
    foreach my $p ( $tree->find_by_tag_name('p') ) {
        my $parent    = $p->parent;
        my $parent_id = refaddr($parent);

        if ( !defined $parents{$parent_id} ) {
            $parents{$parent_id}->{element}     = $parent;
            $parents{$parent_id}->{readability} = 0;

            my $text_to_scan = join q{ },
                grep {defined}
                ( $parent->attr('class'), $parent->attr('id') );

            if ( $text_to_scan =~ m/\b(?:comment|meta|footer|footnote)\b/ ) {
                $parents{$parent_id}->{readability} -= 50;
            } elsif ( $text_to_scan
                =~ m/\b(post|hentry|entry[-]?(content|text|body)?|article[-]?(content|text|body)?)\b/
                ) {
                $parents{$parent_id}->{readability} += 25;
            }
        }

        # add point for each para found
        $parents{$parent_id}->{readability}++;

        # add a point for each comma found in the paragraph
        foreach my $text_ref ( $p->content_refs_list ) {
            my $num_commas = ( ${$text_ref} =~ m/,/g );
            $parents{$parent_id}->{readability} += $num_commas;
        }
    }

    my $best_parent;
    foreach my $id ( keys %parents ) {
        if (   !$best_parent
             || $parents{$id}->{readability} > $best_parent->{readability} ) {
            $best_parent = $parents{$id};
        }
    }

    if ($best_parent) {
        my $best_parent_element = $best_parent->{element};
        $best_parent_element->detach;

        my $output;
        if ( $options{output_type} eq 'tree' ) {
            $output = $best_parent_element;
        } elsif ( $options{output_type} eq 'html' ) {
            $output = $best_parent_element->as_HTML;
        } else {
            $output = $best_parent_element->as_XML;
        }

        unless ( $options{output_type} eq 'tree' ) {
            $output =~ s{^(.*)\s*$}{$1}s;  # kill wrapping
            $best_parent_element->delete;
        }

        return $output;
    } else {
        return;
    }
}

=head1 NAME

HTML::ExtractMain - Extract the main content of a web page

=head1 VERSION

Version 0.63

=cut

our $VERSION = '0.63';

=head1 SYNOPSIS

    use HTML::ExtractMain qw( extract_main_html );

    my $html = <<'END';
    Header
    Home

        Foo
        Baz

    Footer
    END

    my $main_html = extract_main_html($html, output_type => 'xhtml');
    if (defined $main_html) {
	# do something with $main_html here
        # $main_html is 'FooBaz'
    }

=head1 EXPORT

C is optionally exported

=head1 FUNCTIONS

=head2 extract_main_html

C takes HTML content, and uses the Readability
algorithm to detect the main body of the page, usually skipping
headers, footers, navigation, etc.

The first argument is either an HTML string, or an
HTML::TreeBuilder tree. (If passed a tree, the tree will be modified
and destroyed.)

Remaining arguments are optional and represent key/value options. The
available options are:

=head3 output_type

This determines what format to return data in. If not specified then
xhtml format will be used. Valid formats are:

=over 4

=item C

=item C

=item C

=back

If C is selected, then an L object will be
returned instead of a string.

If the HTML's main content is found, it's returned in the chosen
output format. The returned HTML/XHTML will I look like what you put
in. (Source formatting, e.g. indentation, will be removed.)

If a most relevant block of content is not found, C
returns undef.

=cut

=head1 AUTHOR

Anirvan Chatterjee, C<<  >>

=head1 BUGS

Please report any bugs or feature requests to
C, or through the web interface
at L.
I will be notified, and then you'll automatically be notified of
progress on your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc HTML::ExtractMain

You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L

=item * AnnoCPAN: Annotated CPAN documentation

L

=item * CPAN Ratings

L

=item * Search CPAN

L

=back

=head1 SEE ALSO

=over 4

=item * C

=item * C

=back

=head1 ACKNOWLEDGEMENTS

The Readability algorithm is ported from Arc90's JavaScript original,
built as part of the excellent Readability application, online at
L, repository at
L.

=head1 COPYRIGHT & LICENSE

Copyright 2009-2013 Anirvan Chatterjee, Rupert Lane, kryde, all rights
reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1;    # End of HTML::ExtractMain

# Local Variables:
# mode: perltidy
# End: