File Coverage

blib/lib/HTML/Feature.pm

Criterion	Covered	Total	%
statement	78	113	69.0
branch	14	34	41.1
condition	5	10	50.0
subroutine	18	24	75.0
pod	8	8	100.0
total	123	189	65.0

package HTML::Feature;
use strict;
use warnings;
use vars qw($VERSION $UserAgent $engine @EXPORT_OK);
use Exporter qw(import);
use Carp;
use HTTP::Response::Encoding;
use Encode::Guess;
use List::Util qw(first);
use Scalar::Util qw(blessed);
use UNIVERSAL::require;
use URI;

$VERSION   = '2.00004_00';
@EXPORT_OK = qw(feature);

sub new {
    my $class = shift;
    my %arg   = @_;
    $class = ref $class || $class;
    my $self = bless \%arg, $class;

    $self->{enc_type} ||= 'utf8';

    return $self;
}

sub parse {
    my $self = shift;
    my $obj  = shift;

    if (! $obj) {
        croak('Usage: parse( $uri | $http_response | $html_ref )');
    }

    my $pkg  = blessed($obj);
    if (! $pkg) {
        if (my $ref = ref $obj) {
            # if it's a scalar reference, then we've been passed a piece of
            # HTML code.
            if ($ref eq 'SCALAR') {
                return $self->parse_html( $obj, @_ );
            }

            # Otherwise we don't know how to handle
            croak('Usage: parse( $uri | $http_response | $html_ref )');
        }

        # We seemed to have an unblessed scalar. Assume it's a URI
        $pkg = 'URI';
        $obj = URI->new($obj);
    }

    # If it's an object, then we can handle URI or HTTP::Response
    if ($pkg->isa('URI')) {
        return $self->parse_url( $obj, @_ );
    } elsif ($pkg->isa('HTTP::Response')) {
        return $self->parse_response( $obj, @_ );
    } else {
        croak('Usage: parse( $uri | $http_response | $html_ref )');
    }
}

sub parse_url {
    my $self = shift;
    my $url  = shift;
    my $ua   = $self->_user_agent();
    my $res  = $ua->get($url);
    $self->parse_response($res, @_);
}

sub parse_response {
    my $self = shift;
    my $res  = shift;
    my $content = $self->_decode_response($res);
    $self->_run( \$content, @_ );
}

sub parse_html {
    my $self = shift;
    my $html = shift;
    my $html_ref = ref $html ? $html : \$html;
    $self->_decode_htmlref( $html_ref );
    $self->_run( $html_ref, @_ );
}

sub engine
{
    my $self   = shift;
    my $engine = $self->{engine};
    if (! $engine) {
        my $engine_module = $self->{engine} ? $self->{engine} : 'TagStructure';
        my $class = __PACKAGE__ . '::Engine::' . $engine_module;
        $class->require or die $@;
        $engine = $class->new;
        $self->{engine} = $engine;
    }
    return $engine;
}

sub _run {
    my $self     = shift;
    my $html_ref = shift;
    my $opts     = shift || {};

    local $self->{element_flag} = exists $opts->{element_flag} ? $opts->{element_flag} : $self->{element_flag};
    local $self->{cache} = exists $opts->{cache} ? $opts->{cache} : 1;
    $self->engine->run($self, $html_ref);
}

sub _decode_response
{
    my $self = shift;
    my $res  = shift;

    my @encoding = (
        $res->encoding,
        # XXX - falling back to latin-1 may be risky. See Data::Decode
        # could be multiple because HTTP response and META might be different
        ( $res->header('Content-Type') =~ /charset=([\w\-]+)/g ),
        "latin-1",
    );
    my $encoding =
        first { defined $_ && Encode::find_encoding($_) } @encoding;
    return Encode::decode( $encoding, $res->content );
}

sub _decode_htmlref
{
    my $self = shift;
    my $html_ref = shift;

    local $Encode::Guess::NoUTFAutoGuess = 1;
    my $guess =
        Encode::Guess::guess_encoding( $$html_ref,
            ( 'shiftjis', 'euc-jp', '7bit-jis', 'utf8' ) );
    unless ( ref $guess ) {
        $$html_ref = Encode::decode( "latin-1", $$html_ref );
    } else {
        eval { $$html_ref = $guess->decode($$html_ref); };
    }
}

sub _user_agent {
    my $self = shift;
    require LWP::UserAgent;
    $UserAgent ||= LWP::UserAgent->new();
    $self->{http_proxy} and $UserAgent->proxy( ['http'], $self->{http_proxy} );
    return $UserAgent;
}

sub feature {
    my $self   = __PACKAGE__->new;
    my $result = $self->parse(@_);
    my %ret    = (
        text    => $result->text,
        title   => $result->title,
        desc    => $result->desc,
        element => $result->element
    );
    return wantarray ? %ret : $ret{text};
}

sub extract {
    warn
"HTML::Feature::extract() has been deprecated. Use HTML::Feature::parse() instead";
    my $self   = shift;
    my %args   = @_;
    my $result = $self->parse( $args{string} ? \$args{string} : $args{url} );
    my $ret    = {
        title       => $result->title,
        description => $result->desc,
        block       => [ { contents => $result->text } ],
    };
    return $ret;
}

1;

__END__