File Coverage

blib/lib/HTML/TreeBuilder/LibXML.pm
Criterion Covered Total %
statement 13 15 86.6
branch n/a
condition n/a
subroutine 5 5 100.0
pod n/a
total 18 20 90.0


line stmt bran cond sub pod time code
1             package HTML::TreeBuilder::LibXML;
2 21     21   381009 use strict;
  21         32  
  21         622  
3 21     21   78 use warnings;
  21         23  
  21         640  
4             our $VERSION = '0.24';
5 21     21   80 use Carp ();
  21         25  
  21         258  
6 21     21   69 use base 'HTML::TreeBuilder::LibXML::Node';
  21         24  
  21         8521  
7 21     21   18672 use XML::LibXML;
  0            
  0            
8             use 5.008001;
9              
10             sub new {
11             my $class = shift;
12             bless {}, $class;
13             }
14              
15             sub new_from_content {
16             my $class = shift;
17             my $self = $class->new;
18             for my $content (@_) {
19             $self->parse($content);
20             }
21             $self->eof;
22              
23             return $self;
24             }
25              
26             sub new_from_file {
27             my $class = shift;
28             my $self = $class->new;
29             $self->parse_file(@_);
30             return $self;
31             }
32              
33             my $PARSER;
34             sub _parser {
35             unless ($PARSER) {
36             $PARSER = XML::LibXML->new();
37             $PARSER->recover(1);
38             $PARSER->recover_silently(1);
39             $PARSER->keep_blanks(0);
40             $PARSER->expand_entities(1);
41             $PARSER->no_network(1);
42             }
43             $PARSER;
44             }
45              
46             sub parse {
47             my ($self, $html) = @_;
48             $self->{_content} .= $html;
49             }
50              
51             sub parse_content {
52             my $self = shift;
53             $self->parse($_[0]);
54             $self->eof;
55             }
56              
57             sub parse_file {
58             my $self = shift;
59             open (my $fh, '<', $_[0]) or die "Can't open $_[0]: $!\n";
60             my $content = do { local $/; <$fh> };
61             $self->parse_content($content);
62             }
63              
64             sub eof {
65             my ($self, ) = @_;
66             $self->{_content} = ' ' if defined $self->{_content} && $self->{_content} eq ''; # HACK
67             $self->{_implicit_html} = 1 unless $self->{_content} =~ / was inserted
68             $self->{_implicit_doctype} = 1 unless $self->{_content} =~ /
69             my $doc = $self->_parser->parse_html_string($self->{_content});
70             $self->{node} = $self->_documentElement($doc);
71             }
72              
73             sub _documentElement {
74             my($self, $doc) = @_;
75             return $doc->documentElement || do {
76             my $elem = $doc->createElement("html");
77             $elem->appendChild($doc->createElement("body"));
78             $elem;
79             };
80             }
81              
82             sub elementify {
83             bless shift, 'HTML::TreeBuilder::LibXML::Node';
84             }
85              
86             sub guts {
87             my ($self, $destructive) = @_;
88              
89             my @out = $self->{_implicit_html} ? map { $_->nonBlankChildNodes } $self->{node}->findnodes('/html/head | /html/body')
90             : $self->{node};
91              
92             if ($destructive && @out > 0) {
93             my $doc = XML::LibXML->createDocument;
94             if (!$self->{_implicit_doctype} && (my $dtd = $out[0]->ownerDocument->internalSubset)) {
95             $doc->createInternalSubset( $dtd->getName, $dtd->publicId, $dtd->systemId );
96             }
97             $doc->setDocumentElement($out[0]); # 1st child
98             $out[0]->addSibling($_) foreach @out[1..$#out];
99             }
100            
101             return map { HTML::TreeBuilder::LibXML::Node->new($_) } @out if wantarray; # one simple normal case.
102             return unless @out;
103            
104             my $doc = XML::LibXML->createDocument;
105             if (!$self->{_implicit_doctype} && (my $dtd = $out[0]->ownerDocument->internalSubset)) {
106             $doc->createInternalSubset( $dtd->getName, $dtd->publicId, $dtd->systemId );
107             }
108              
109             if (@out == 1) {
110             $doc->adoptNode($out[0]);
111             $doc->setDocumentElement($out[0]);
112             return HTML::TreeBuilder::LibXML::Node->new($out[0]);
113             }
114            
115             my $div = $doc->createElement('div'); # TODO put the _implicit flag somewhere, to be compatible with HTML::TreeBuilders
116             $doc->setDocumentElement($div);
117             $div->appendChild($_) for @out;
118            
119             return HTML::TreeBuilder::LibXML::Node->new($div);
120             }
121              
122             sub disembowel {
123             my ($self) = @_;
124             $self->guts(1);
125             }
126              
127             sub replace_original {
128             require HTML::TreeBuilder::XPath;
129              
130             my $orig = HTML::TreeBuilder::XPath->can('new');
131              
132             no warnings 'redefine';
133             *HTML::TreeBuilder::XPath::new = sub {
134             HTML::TreeBuilder::LibXML->new();
135             };
136              
137             if (defined wantarray) {
138             return HTML::TreeBuilder::LibXML::Destructor->new(
139             sub { *HTML::TreeBuilder::XPath::new = $orig } );
140             }
141             return;
142             }
143              
144             # The HTML::TreeBuilder has this method and it is needed to us for web-scraper module
145             sub store_comments { }
146             sub ignore_unknown { }
147              
148             package # hide from cpan
149             HTML::TreeBuilder::LibXML::Destructor;
150              
151             sub new {
152             my ( $class, $callback ) = @_;
153             bless { cb => $callback }, $class;
154             }
155              
156             sub DESTROY {
157             my $self = shift;
158             $self->{cb}->();
159             }
160              
161             1;
162             __END__