File Coverage

blib/lib/App/scrape.pm

Criterion	Covered	Total	%
statement	70	70	100.0
branch	18	18	100.0
condition	4	10	40.0
subroutine	7	7	100.0
pod	0	1	0.0
total	99	106	93.4

package App::scrape;
use strict;
use URI;
use HTML::TreeBuilder::XPath;
use HTML::Selector::XPath 'selector_to_xpath';
use Exporter 'import';

use vars qw($VERSION @EXPORT_OK);
$VERSION = '0.05';

@EXPORT_OK = qw;

=head1 NAME

App::scrape - simple HTML scraping

=head1 ABSTRACT

This is a simple module to extract data from HTML by
specifying CSS3 or XPath selectors.

=head1 SYNOPSIS

    use App::scrape 'scrape';
    use LWP::Simple 'get';
    use Data::Dumper;

    my $html = get('http://perlmonks.org');
    my @posts = scrape(
        $html,
        ['a','a@href'],
        {
            absolute => [qw[href src rel]],
            base => 'http://perlmonks.org',
        },
    );
    print Dumper \@posts;

    my @posts = scrape(
        $html,
        {
          title => 'a',
          url   => 'a@href',
        },
        {
            absolute => [qw[href src rel]],
            base => 'http://perlmonks.org',
        },
    );
    print Dumper \@posts;

=head1 DESCRIPTION

This module implements yet another scraping engine
to extract data from HTML.

This engine does not (yet) support nested data
structures. For an engine that supports nesting, see
L.

=cut

sub scrape {
    my ($html, $selectors, $options) = @_;

    $options ||= {};
    my $delete_tree;
    if (! ref $options->{tree}) {
        $options->{tree} = HTML::TreeBuilder::XPath->new;
        $options->{tree}->parse($html);
        $options->{tree}->eof;
        $delete_tree = 1;
    };
    my $tree = $options->{tree};

    $options->{make_uri} ||= {};
    my %make_uri = %{$options->{make_uri}};

    # now fetch all "rows" from the page. We do this once to avoid
    # fetching a page multiple times
    my @rows;

    my %known_uri = (
        'href' => 1, # a@href
        'src'  => 1, # img@src , script@src
    );

    my @selectors;
    if (ref $selectors eq 'ARRAY') {
        @selectors = @$selectors
    } else {
        @selectors = map { $selectors->{ $_ } } sort keys %$selectors;
    };

    my $rowidx=0;
    for my $selector (@selectors) {
        my ($attr);
        my $s = $selector;
        if ($selector =~ s!/?\@(\w+)$!!) {
            $attr = $1;
        };
        if ($selector !~ m!^\.?/!) {
            $selector = selector_to_xpath( $selector );
        };
        # We always make the selector relative to the current node:
        $selector = ".$selector" unless $selector =~ /^\./;
        my @nodes;
        if (! defined $attr) {
            @nodes = map { $_->as_trimmed_text } $tree->findnodes($selector);
        } else {
            $make_uri{ $rowidx } ||= (($known_uri{ lc $attr }) and ! $options->{no_known_uri});
            @nodes = $tree->findvalues("$selector/\@$attr");
        };
        if ($make_uri{ $rowidx }) {
            @nodes = map { URI->new_abs( $_, $options->{base} )->as_string } @nodes;
        };
        push @rows, \@nodes;
        $rowidx++;
    };

    # Now convert the result from rows to columns
    my @result;
    for my $idx (0.. $#{ $rows[0] }) {
        push @result, [ map {
                $rows[$_]->[$idx]
        } 0..$#rows ];
    };

    # Now check what the user wants, array or hash:
    if( ref $selectors eq 'HASH') {
        @result = map {
                my $arr = $_;
                my $i = 0;
                $_ = +{
                    map { $_ => $arr->[$i++] } sort keys %$selectors
                      };
            } @result
    };

    $tree->delete
        if $delete_tree;
    @result
};

=head1 SEE ALSO

L - the scraper inspiring this module

=head1 REPOSITORY

The public repository of this module is
L.

=head1 SUPPORT

The public support forum of this program is
L.

=head1 AUTHOR

Max Maischein C

=head1 COPYRIGHT (c)

Copyright 2011-2011 by Max Maischein C.

=head1 LICENSE

This module is released under the same terms as Perl itself.

=cut