File Coverage

blib/lib/HTML/ExtractText.pm

Criterion	Covered	Total	%
statement	114	116	98.2
branch	42	52	80.7
condition	23	32	71.8
subroutine	24	25	96.0
pod	6	6	100.0
total	209	231	90.4

package HTML::ExtractText;

use strict;
use warnings;

our $VERSION = '1.002004'; # VERSION

use Try::Tiny;
use Scalar::Util qw/blessed/;
use Carp qw/croak/;
use Devel::TakeHashArgs;
use Mojo::DOM;
use overload q|""|  => sub { shift->error        },
             q|%{}| => sub { shift->last_results };

sub new {
    my $self = bless [], shift;
    get_args_as_hash( \@_, \ my %args,
        {   # these are optional with defaults
            separator        => "\n",
            ignore_not_found => 1,
        },
        [ ], # these are mandatory (none, ATM)
        [ qw/separator ignore_not_found/ ], # only these args are valid ones
    ) or croak $@;

    $self->$_( $args{$_} ) for keys %args;

    return $self;
}

sub extract {
    my ( $self, $what, $html, $obj ) = @_;

    $self->error( undef );
    $self->last_results( undef );

    ref $what eq 'HASH'
        or return $self->_set_error('First argument to '
                . 'extract_text() must be a hashref');

    defined $html
        or return $self->_set_error('Second argument to extract_text() is '
                    . 'an undef, expected HTML');

    if ( defined $obj ) {
        blessed $obj
           or return $self->_set_error('Third argument must be an object');

        for ( keys %$what ) {
            $obj->can($_)
                or return $self->_set_error(
                    'The object your provided does not implement the ->'
                    . $_ . '() method that you requested in the first'
                    . ' argument',
                );
        }
    }


    my $dom = Mojo::DOM->new( $html );

    my $did_have_error = 0;
    for my $selector ( sort keys %$what ) {
        my $result;

        try {
            my @results = $self->_extract( $dom, $selector, $what, );
            die "NOT FOUND\n"
                if not @results and not $self->ignore_not_found;

            if ( defined (my $sep = $self->separator) ) {
                $result = join $sep, @results;
            }
            else {
                $result = [ @results ];
            }

        } catch {
            chomp($_);
            $self->error("ERROR: [$selector]: $_");
            $result = "ERROR: $_";
            $did_have_error = 1;
        };

        $what->{ $selector } = $result;
    }

    if ( defined $obj ) {
        for ( keys %$what ) {
            $obj->$_( $what->{ $_ } );
        }
    }

    $self->last_results( $what );

    if ( $did_have_error ) {
        return;
    }
    else {
        return $what;
    }
}

sub separator {
    my $self = shift;
    if ( @_ ) { $self->[0]->{SEPARATOR} = shift; }
    return $self->[0]->{SEPARATOR};
}

sub ignore_not_found {
    my $self = shift;
    if ( @_ ) { $self->[0]->{IGNORE_NOT_FOUND} = shift; }
    return $self->[0]->{IGNORE_NOT_FOUND};
}

sub last_results {
    my $self = shift;
    if ( @_ ) { $self->[0]->{LAST_RESULTS} = shift; }
    return $self->[0]->{LAST_RESULTS};
}

sub error {
    my $self = shift;
    if ( @_ ) { $self->[0]->{ERROR} = shift; }
    return $self->[0]->{ERROR};
}

sub _set_error {
    my ( $self, $error ) = @_;
    $self->error( $error );
    return;
}

sub _process {
    my $tag = $_->tag;
    return _all_text($_) unless $tag =~ /input|img/;

    return $_->attr('alt')//''
        if $tag eq 'img' or
        ($tag eq 'input' and ($_->attr('type')//'') eq 'image');

    return $_->attr('value')//'';
}

sub _extract {
    my ( $self, $dom, $selector, $what ) = @_;
    return $dom->find( $what->{ $selector } )
        ->map( sub { $self->_process( @_ ) } )->each;
}

# The _all_text & _text functions copied from Mojo::DOM 6.66.
sub _all_text {
    my ( $dom ) = @_;
    my $trim = 1;

    # Detect "pre" tag
    my $tree = $dom->tree;
    map { $_->[1] eq 'pre' and $trim = 0 } Mojo::DOM::_ancestors( $dom ), $tree
        if $trim && $tree->[0] ne 'root';

    return _text( [Mojo::DOM::_nodes($tree)], $trim );
}

sub _text {
    my ( $nodes, $trim ) = @_;

    # Merge successive text nodes.
    my $i = 0;
    while ( my $next = $nodes->[$i + 1] ) {
       ++$i and next unless $nodes->[$i][0] eq 'text' && $next->[0] eq 'text';
       splice @$nodes, $i, 2, ['text', $nodes->[$i][1] . $next->[1]];
    }

    my $text = '';
    for my $node ( @$nodes ) {
        my $type = $node->[0];
        my $chunk = '';

        # Text.
        if ( $type eq 'text' ) {
            $chunk = $node->[1];
            if ( $trim ) {
                $chunk =~ s/^\s+//;
                $chunk =~ s/\s+$//;
                $chunk =~ s/\s+/ /g;
            }
        }
        # CDATA or raw text.
        elsif ( $type eq 'cdata' || $type eq 'raw' ) {
            $chunk = $node->[1];
        }
        # Nested tag.
        elsif ( $type eq 'tag' ) {
           no warnings 'recursion';
           $chunk = _text( [Mojo::DOM::_nodes($node)], 1, $node->[1] eq 'pre' ? 0 : $trim );
        }

        # Add leading whitespace if punctuation allows it.
        $chunk = " $chunk" if $text =~ /\S\z/ && $chunk =~ /^[^.!?,;:\s]+/;

        # Trim whitespace blocks.
        $text .= $chunk if $chunk =~ /\S+/ || !$trim;
    }

    return $text;
}


q|
Programming is 10% science, 20% ingenuity,
and 70% getting the ingenuity to work with the science.
|;

__END__