File Coverage

blib/lib/Web/Query.pm

Criterion	Covered	Total	%
statement	430	434	99.0
branch	125	138	90.5
condition	37	83	44.5
subroutine	76	76	100.0
pod	47	49	95.9
total	715	780	91.6

package Web::Query;
our $AUTHORITY = 'cpan:TOKUHIROM';
# ABSTRACT: Yet another scraping library like jQuery
$Web::Query::VERSION = '1.00';
use strict;
use warnings;
use 5.008001;
use parent qw/Exporter/;
use HTML::TreeBuilder::XPath;
use LWP::UserAgent;
use HTML::Selector::XPath 0.20 qw/selector_to_xpath/;
use Scalar::Util qw/blessed refaddr/;
use HTML::Entities qw/encode_entities/;

use List::Util 1.44 qw/ reduce uniq /;
use Scalar::Util qw/ refaddr /;

our @EXPORT = qw/wq/;

our $RESPONSE;

sub wq { Web::Query->new(@_) }

our $UserAgent;

sub __ua { $UserAgent ||= LWP::UserAgent->new }

sub _build_tree {
    my( $self, $options ) = @_;

    my $no_space_compacting = ref $self ? $self->{no_space_compacting}
    : ref $options eq 'HASH' ? $options->{no_space_compacting} : 0;

    my $tree = HTML::TreeBuilder::XPath->new(
        no_space_compacting => $no_space_compacting
    );
    $tree->ignore_unknown(0);
    $tree->store_comments(1);
    $tree;
}

sub new {
    my ($class, $stuff, $options) = @_;

    my $self = $class->_resolve_new($stuff,$options)
        or return undef;

    $self->{indent} = $options->{indent} if $options->{indent};

    $self->{no_space_compacting} = $options->{no_space_compacting};

    return $self;
}

sub _resolve_new {
    my( $class, $stuff, $options) = @_;

    return $class->new_from_element([],undef,$options) unless defined $stuff;

    if (blessed $stuff) {
        return $class->new_from_element([$stuff],undef,$options)
            if $stuff->isa('HTML::Element');

        return $class->new_from_url($stuff->as_string,$options)
            if $stuff->isa('URI');

        return $class->new_from_element($stuff->{trees}, undef, $options)
            if $stuff->isa($class);

        die "Unknown source type: $stuff";
    }

    return $class->new_from_element($stuff,undef,$options) if ref $stuff eq 'ARRAY';

    return $class->new_from_url($stuff,$options) if $stuff =~ m{^(?:https?|file)://};

    return $class->new_from_html($stuff,$options) if $stuff =~ /<.*?>/;

    return $class->new_from_file($stuff,$options) if $stuff !~ /\n/ && -f $stuff;

    die "Unknown source type: $stuff";
}

sub new_from_url {
    my ($class, $url,$options) = @_;

    $RESPONSE = __ua()->get($url);

    no warnings 'uninitialized';

    unless( $RESPONSE->is_success ) {
        die "failed to retrieve '$url', " . $RESPONSE->code. " "
            . $RESPONSE->message."\n";
    };

    return $class->new_from_html($RESPONSE->decoded_content,$options);
}

sub new_from_file {
    my ($class, $fname, $options) = @_;
    my $tree = $class->_build_tree($options);
    $tree->parse_file($fname);
    my $self = $class->new_from_element([$tree->disembowel],undef,$options);
    $self->{need_delete}++;
    return $self;
}

sub new_from_html {
    my ($class, $html,$options) = @_;
    my $tree = $class->_build_tree($options);
    $tree->parse_content($html);
    my $self = $class->new_from_element([
            map {
                ref $_ ? $_ : bless { _content => $_ }, 'HTML::TreeBuilder::XPath::TextNode'
            } $tree->disembowel
    ],undef,$options);
    $self->{need_delete}++;
    return $self;
}

sub new_from_element {
    my $self_or_class = shift;

    my $trees = ref $_[0] eq 'ARRAY' ? $_[0] : [$_[0]];

    return bless { trees => [ @$trees ], before => $_[1] },
        ref $self_or_class || $self_or_class;
}

sub end {
    my $self = shift;
    return $self->{before};
}

sub size {
    my $self = shift;
    return scalar(@{$self->{trees}});
}

sub parent {
    my $self = shift;

    my @new = map { $_->parent } @{$self->{trees}};

    return (ref $self || $self)->new_from_element(\@new, $self);
}

sub first {
    my $self = shift;
    return $self->eq(0);
}

sub last {
    my $self = shift;
    return $self->eq(-1);
}

sub get {
    my ($self, $index) = @_;
    return $self->{trees}[$index];
}

sub eq {
    my ($self, $index) = @_;
    return (ref $self || $self)->new_from_element([$self->{trees}[$index] || ()], $self);
}

sub find {
    my ($self, $selector) = @_;

    my $xpath = ref $selector ? $$selector : selector_to_xpath($selector, root => './');
    my @new = map { eval{ $_->findnodes($xpath) } } @{$self->{trees}};

    return (ref $self || $self)->new_from_element(\@new, $self);
}

sub contents {
    my ($self, $selector) = @_;

    my @new = map { $_->content_list } @{$self->{trees}};

    if ($selector) {
        my $xpath = ref $selector ? $$selector : selector_to_xpath($selector);
        @new = grep { $_->matches($xpath) } @new;
    }

    return (ref $self || $self)->new_from_element(\@new, $self);
}

sub as_html {
    my $self = shift;
    my %args = @_;

    my @html = map {
        ref $_ ? ( $_->isa('HTML::TreeBuilder::XPath::TextNode') || $_->isa('HTML::TreeBuilder::XPath::CommentNode' ) )
                        ? $_->getValue
                        : $_->as_HTML( q{&<>'"}, $self->{indent}, {} )
               : $_
    } @{$self->{trees}};

    return join $args{join}, @html if defined $args{join};

    return wantarray ? @html : $html[0];
}

sub html {
    my $self = shift;

    if (@_) {
        map {
            $_->delete_content;
            my $tree = $self->_build_tree;

            $tree->parse_content($_[0]);
            $_->push_content($tree->disembowel);
        } @{$self->{trees}};
        return $self;
    }

    my @html;
    for my $t ( @{$self->{trees}} ) {
        push @html, join '', map {
            ref $_ ? $_->as_HTML( q{&<>'"}, $self->{indent}, {})
                   : encode_entities($_)
        } eval { $t->content_list };
    }

    return wantarray ? @html : $html[0];
}

sub text {
    my $self = shift;

    if (@_) {
        map { $_->delete_content; $_->push_content($_[0]) } @{$self->{trees}};
        return $self;
    }

    my @html = map {
        ref $_ ? $_->as_text : $_
    } @{$self->{trees}};
    return wantarray ? @html : $html[0];
}

sub attr {
    my $self = shift;

    if ( @_ == 1 ) { # getter
        return wantarray
            ? map { $_->attr(@_) } @{$self->{trees}}
            : eval { $self->{trees}[0]->attr(@_) }
            ;
    }

    while( my( $attr, $value ) = splice @_, 0, 2 ) {
        my $code = ref $value eq 'CODE' ? $value : undef;

        for my $t ( @{$self->{trees}} ) {
            if ( $code ) {
                no warnings 'uninitialized';
                my $orig = $_ = $t->attr($attr);
                $code->();
                next if $orig eq $_;
                $value = $_;
            }
            $t->attr($attr => $value);
        }
    }

    return $self;
}

sub id {
    my $self = shift;

    if ( @_ ) {  # setter
        my $new_id = shift;

        return $self if $self->size == 0;

        return $self->each(sub{
            $_->attr( id => $new_id->(@_) )
        }) if ref $new_id eq 'CODE';

        if ( $self->size == 1 ) {
            $self->attr( id => $new_id );
        }
        else {
            return $self->first->attr( id => $new_id );
        }
    }
    else { # getter

        # the eval is there in case there is no tree
        return wantarray
            ? map { $_->attr('id') } @{$self->{trees}}
            : eval { $self->{trees}[0]->attr('id') }
            ;
    }
}

sub name {
    my $self = shift;
    $self->attr( 'name', @_ );
}

sub data {
    my $self = shift;
    my $name = shift;
    $self->attr( join( '-', 'data', $name ), @_ );
}

sub tagname {
    my $self = shift;
    my @retval = map { $_ eq '~comment' ? '#comment' : $_ }
                 map { ref $_ eq 'HTML::TreeBuilder::XPath::TextNode'    ? '#text'
                     : ref $_ eq 'HTML::TreeBuilder::XPath::CommentNode' ? '#comment'
                     : ref $_ ? $_->tag(@_)
                     : '#text'
                     ;
                } @{$self->{trees}};
    return wantarray ? @retval : $retval[0];
}

sub each {
    my ($self, $code) = @_;
    my $i = 0;

    # make a copy such that if we modify the list via 'delete',
    # it won't change from under our feet (see t/each-and-delete.t
    # for a case where it can)
    my @trees = @{ $self->{trees} };
    for my $tree ( @trees ) {
        local $_ = (ref $self || $self)->new_from_element([$tree], $self);
        $code->($i++, $_);
    }
    return $self;
}

sub map {
    my ($self, $code) = @_;
    my $i = 0;
    return +[map {
        my $tree = $_;
        local $_ = (ref $self || $self)->new($tree);
        $code->($i++, $_);
    } @{$self->{trees}}];
}

sub filter {
    my $self = shift;

    my @new;

    if (ref($_[0]) eq 'CODE') {
        my $code = $_[0];
        my $i = 0;
        @new = grep {
            my $tree = $_;
            local $_ = (ref $self || $self)->new_from_element($tree);
            $code->($i++, $_);
        } @{$self->{trees}};
    }
    else {
        my $xpath = ref $_[0] ? ${$_[0]} : selector_to_xpath($_[0]);
        @new = grep { eval { $_->matches($xpath) } } @{$self->{trees}};
    }

    return (ref $self || $self)->new_from_element(\@new, $self);
}

sub _is_same_node {
    refaddr($_[1]) == refaddr($_[2]);
}

sub remove {
    my $self = shift;
    my $before = $self->end;

    while (defined $before) {
        @{$before->{trees}} = grep {
            my $el = $_;
            not grep { $self->_is_same_node( $el, $_ ) } @{$self->{trees}};
        } @{$before->{trees}};

        $before = $before->end;
    }

    $_->delete for @{$self->{trees}};
    @{$self->{trees}} = ();

    $self;
}

sub replace_with {
    my ( $self, $replacement ) = @_;

    my $i = 0;
    for my $node ( @{ $self->{trees} } ) {
        my $rep = $replacement;

        if ( ref $rep eq 'CODE' ) {
            local $_ = (ref $self || $self)->new($node);
            $rep = $rep->( $i++ => $_ );
        }

        $rep = (ref $self || $self)->new_from_html( $rep )
            unless ref $rep;



        my $r = $rep->{trees}->[0];
        { no warnings;
            $r = $r->clone if ref $r;
        }
        $r->parent( $node->parent ) if ref $r and $node->parent;

        $node->replace_with( $r );
    }

    $replacement->remove if ref $replacement eq (ref $self || $self);

    return $self;
}

sub append {
    my ($self, $stuff) = @_;
    $stuff = (ref $self || $self)->new($stuff);

    foreach my $t (@{$self->{trees}}) {
        $t->push_content($_) for ref($t)->clone_list(@{$stuff->{trees}});
    }

    $self;
}

sub prepend {
    my ($self, $stuff) = @_;
    $stuff = (ref $self || $self)->new($stuff);

    foreach my $t (@{$self->{trees}}) {
        $t->unshift_content($_) for ref($t)->clone_list(@{$stuff->{trees}});
    }

    $self;
}


sub before {
    my ($self, $stuff) = @_;
    $stuff = (ref $self || $self)->new($stuff);

    foreach my $t (@{$self->{trees}}) {
        $t->preinsert(ref($t)->clone_list(@{$stuff->{trees}}));
    }

    $self;
}


sub after {
    my ($self, $stuff) = @_;
    $stuff = (ref $self || $self)->new($stuff);

    foreach my $t (@{$self->{trees}}) {
        $t->postinsert(ref($t)->clone_list(@{$stuff->{trees}}));
    }

    $self;
}


sub insert_before {
    my ($self, $target) = @_;

    foreach my $t (@{$target->{trees}}) {
        $t->preinsert(ref($t)->clone_list(@{$self->{trees}}));
    }

    $self;
}

sub insert_after {
    my ($self, $target) = @_;

    foreach my $t (@{$target->{trees}}) {
        $t->postinsert(ref($t)->clone_list(@{$self->{trees}}));
    }

    $self;
}

sub detach {
    my ($self) = @_;
    $_->detach for @{$self->{trees}};
    $self;
}

sub add_class {
    my ($self, $class) = @_;

    for (my $i = 0; $i < @{$self->{trees}}; $i++) {
        my $t = $self->{trees}->[$i];
        my $current_class = $t->attr('class') || '';

        my $classes = ref $class eq 'CODE' ? $class->($i, $current_class, $t) : $class;
        my @classes = split /\s+/, $classes;

        foreach (@classes) {
            $current_class .= " $_" unless $current_class =~ /(?:^|\s)$_(?:\s|$)/;
        }

        $current_class =~ s/(?:^\s*|\s*$)//g;
        $current_class =~ s/\s\s+/ /g;

        $t->attr('class', $current_class);
    }

    $self;
}


sub remove_class {
    my ($self, $class) = @_;

    for (my $i = 0; $i < @{$self->{trees}}; $i++) {
        my $t = $self->{trees}->[$i];
        my $current_class = $t->attr('class');
        next unless defined $current_class;

        my $classes = ref $class eq 'CODE' ? $class->($i, $current_class, $t) : $class;
        my @remove_classes = split /\s+/, $classes;
        my @final = grep {
            my $existing_class = $_;
            not grep { $existing_class eq $_} @remove_classes;
        } split /\s+/, $current_class;

        $t->attr('class', join ' ', @final);
    }

    $self;

}

sub toggle_class {
    my $self = shift;

    my @classes = uniq @_;

    $self->each(sub{
        for my $class ( @classes ) {
            my $method = $_->has_class($class) ? 'remove_class' : 'add_class';
            $_->$method($class);
        }
    });
}

sub has_class {
    my ($self, $class) = @_;

    foreach my $t (@{$self->{trees}}) {
        no warnings 'uninitialized';
        return 1 if $t->attr('class') =~ /(?:^|\s)$class(?:\s|$)/;
    }

    return undef;
}

sub clone {
    my ($self) = @_;
    my @clones = map { $_->clone } @{$self->{trees}};
    return (ref $self || $self)->new_from_element(\@clones);
}

sub add {
    my ($self, @stuff) = @_;
    my @nodes;

    # add(selector, context)
    if (@stuff == 2 && !ref $stuff[0] && $stuff[1]->isa('HTML::Element')) {
        my $xpath = ref $stuff[0] ? ${$stuff[0]} : selector_to_xpath($stuff[0]);
        push @nodes, $stuff[1]->findnodes( $xpath, root => './');
    }
    else {
        # handle any combination of html string, element object and web::query object
        push @nodes, map {
            $self->{need_delete} = 1 if $_->{need_delete};
            delete $_->{need_delete};
            @{$_->{trees}};
        } map { (ref $self || $self)->new($_) } @stuff;
    }

    my %ids = map { $self->_node_id($_) => 1 } @{ $self->{trees} };

    $self->new_from_element( [
        @{$self->{trees}}, grep { ! $ids{ $self->_node_id($_) } } @nodes
    ], $self );
}

sub _node_id {
    my( undef, $node ) = @_;
    refaddr $node;
}

sub prev {
    my $self = shift;
    my @new;
    for my $tree (@{$self->{trees}}) {
        push @new, $tree->getPreviousSibling;
    }
    return (ref $self || $self)->new_from_element(\@new, $self);
}

sub next {
    my $self = shift;

    my @new = grep { $_ } map { $_->getNextSibling } @{ $self->{trees} };

    return (ref $self || $self)->new_from_element(\@new, $self);
}

sub match {
    my( $self, $selector ) = @_;

    my $xpath = ref $selector ? $$selector : selector_to_xpath($selector);

    my $results = $self->map(sub{
            my(undef,$e) = @_;
        return 0 unless ref $e;  # it's a string
        return !!$e->get(0)->matches($xpath);
    });

    return wantarray ? @$results : $results->[0];
}

sub not {
    my( $self, $selector ) = @_;

    my $class = ref $self;

    my $xpath = ref $selector ? $$selector : selector_to_xpath($selector);
    $self->filter(sub { ! grep { $_->matches($xpath) } grep { ref $_ } $class->new($_)->{trees}[0] } );
}

sub and_back {
    my $self = shift;

    $self->add( $self->end );
}

sub next_until {
    my( $self, $selector ) = @_;

    my $class = ref $self;
    my $collection = $class->new_from_element([],$self);

    my $next = $self->next->not($selector);
    while( $next->size ) {
       $collection = $collection->add($next);
       $next = $next->next->not( $selector );
    }

    # hide the loop from the outside world
    $collection->{before} = $self;

    return $collection;
}

sub split {
    my( $self, $selector, %args ) = @_;

    my @current;
    my @list;

    $self->contents->each(sub{
            my(undef,$e)=@_;

            if( $e->match($selector) ) {
                push @list, [ @current ];
                @current = ( $e );
            }
            else {
                if ( $current[1] ) {
                    $current[1] = $current[1]->add($e);
                }
                else {
                    $current[1] = $e;
                }
            }
    });
    push @list, [ @current ];

    if( $args{skip_leading} ) {
        @list = grep { $_->[0] } @list;
    }

    unless ( $args{pairs} ) {
        @list = map { reduce { $a->add($b) } grep { $_ } @$_ } @list;
    }

    return @list;
}

sub last_response {
    return $RESPONSE;
}

sub DESTROY {
    return unless $_[0]->{need_delete};

    # avoid memory leaks
    local $@;
    eval { $_->delete } for @{$_[0]->{trees}};
}

1;

__END__