File Coverage

blib/lib/HTML/TreeBuilder/LibXML.pm

Criterion	Covered	Total	%
statement	96	97	98.9
branch	23	26	88.4
condition	9	15	60.0
subroutine	25	26	96.1
pod	0	13	0.0
total	153	177	86.4

package HTML::TreeBuilder::LibXML;
use strict;
use warnings;
our $VERSION = '0.28';
use Carp ();
use base 'HTML::TreeBuilder::LibXML::Node';
use XML::LibXML;
use 5.008001;

sub new {
    my $class = shift;
    bless {}, $class;
}

sub new_from_content {
    my $class = shift;
    my $self  = $class->new;
    for my $content (@_) {
        $self->parse($content);
    }
    $self->eof;

    return $self;
}

sub new_from_file {
    my $class = shift;
    my $self  = $class->new;
    $self->parse_file(@_);
    return $self;
}

my $PARSER;
sub _parser {
    unless ($PARSER) {
        $PARSER = XML::LibXML->new();
        $PARSER->recover(1);
        $PARSER->recover_silently(1);
        $PARSER->keep_blanks(1);
        $PARSER->expand_entities(1);
        $PARSER->no_network(1);
    }
    $PARSER;
}

sub parse {
    my ($self, $html) = @_;
    $self->{_content} .= $html;
}

sub parse_content {
    my $self = shift;
    $self->parse($_[0]);
    $self->eof;
}

sub parse_file {
    my $self = shift;
    open (my $fh, '<', $_[0]) or die "Can't open $_[0]: $!\n";
    my $content = do { local $/;  <$fh> };
    $self->parse_content($content);
}

sub eof {
    my ($self, ) = @_;
    $self->{_content} = ' ' if defined $self->{_content} && $self->{_content} eq ''; # HACK
    $self->{_implicit_html} = 1 unless $self->{_content} =~ / was inserted
    $self->{_implicit_doctype} = 1 unless $self->{_content} =~ /
    my $doc = $self->_parser->parse_html_string($self->{_content});
    $self->{node} = $self->_documentElement($doc);
}

sub _documentElement {
    my($self, $doc) = @_;
    return $doc->documentElement || do {
        my $elem = $doc->createElement("html");
        $elem->appendChild($doc->createElement("body"));
        $elem;
    };
}

sub elementify {
    bless shift, 'HTML::TreeBuilder::LibXML::Node';
}

sub guts {
    my ($self, $destructive) = @_;

    my @out = $self->{_implicit_html} ? map { $_->nonBlankChildNodes } $self->{node}->findnodes('/html/head | /html/body')
                                      : $self->{node};

    if ($destructive && @out > 0) {
        my $doc = XML::LibXML->createDocument;
        if (!$self->{_implicit_doctype} && (my $dtd = $out[0]->ownerDocument->internalSubset)) {
            $doc->createInternalSubset( $dtd->getName, $dtd->publicId, $dtd->systemId );
        }
        $doc->setDocumentElement($out[0]); # 1st child
        $out[0]->addSibling($_) foreach @out[1..$#out];
    }

    return map { HTML::TreeBuilder::LibXML::Node->new($_) } @out if wantarray;    # one simple normal case.
    return unless @out;

    my $doc = XML::LibXML->createDocument;
    if (!$self->{_implicit_doctype} && (my $dtd = $out[0]->ownerDocument->internalSubset)) {
        $doc->createInternalSubset( $dtd->getName, $dtd->publicId, $dtd->systemId );
    }

    if (@out == 1) {
        $doc->adoptNode($out[0]);
        $doc->setDocumentElement($out[0]);
        return HTML::TreeBuilder::LibXML::Node->new($out[0]);
    }

    my $div = $doc->createElement('div'); # TODO put the _implicit flag somewhere, to be compatible with HTML::TreeBuilders
    $doc->setDocumentElement($div);
    $div->appendChild($_) for @out;

    return HTML::TreeBuilder::LibXML::Node->new($div);
}

sub disembowel {
    my ($self) = @_;
    $self->guts(1);
}

sub replace_original {
    require HTML::TreeBuilder::XPath;

    my $orig = HTML::TreeBuilder::XPath->can('new');

    no warnings 'redefine';
    *HTML::TreeBuilder::XPath::new = sub {
        HTML::TreeBuilder::LibXML->new();
    };

    if (defined wantarray) {
        return HTML::TreeBuilder::LibXML::Destructor->new(
            sub { *HTML::TreeBuilder::XPath::new = $orig } );
    }
    return;
}

# The HTML::TreeBuilder has this method and it is needed to us for web-scraper module
sub store_comments { }
sub ignore_unknown { }

package # hide from cpan
    HTML::TreeBuilder::LibXML::Destructor;

sub new {
    my ( $class, $callback ) = @_;
    bless { cb => $callback }, $class;
}

sub DESTROY {
    my $self = shift;
    $self->{cb}->();
}

1;
__END__