File Coverage

blib/lib/HTML/HTML5/Parser.pm

Criterion	Covered	Total	%
statement	140	191	73.3
branch	40	82	48.7
condition	15	33	45.4
subroutine	23	30	76.6
pod	15	15	100.0
total	233	351	66.3

package HTML::HTML5::Parser;

## skip Test::Tabs
use 5.008001;
use strict;
use warnings;

our $AUTOLOAD;
our $VERSION = '0.992';

use Carp;
use HTML::HTML5::Parser::Error;
use HTML::HTML5::Parser::TagSoupParser;
use Scalar::Util qw(blessed);
use URI::file;
use Encode qw(encode_utf8);
use XML::LibXML;

BEGIN {
	croak "Please upgrade to XML::LibXML 1.94"
		if XML::LibXML->VERSION =~ /^1\.9[12]/;
}

sub new
{
	my $class = shift;
    my %p = @_;
	my $self  = bless {
		errors => [],
        parser => HTML::HTML5::Parser::TagSoupParser->new(%p),
		}, $class;
	return $self;
}

sub parse_file
{
	require HTML::HTML5::Parser::UA;

	my $self   = shift;
	my $file   = shift;
	my $opts   = shift || {};

	unless (blessed($file) and $file->isa('URI'))
	{
		if ($file =~ /^[a-z][a-z0-9_\.\+-]+:\S+$/i)
			{ $file = URI->new($file); }
		else
			{ $file = URI::file->new_abs($file); }
	}

	my $response = HTML::HTML5::Parser::UA->get($file, $opts->{user_agent});
	croak "HTTP response code was not 200 OK. (Set \$opts{ignore_http_response_code} to ignore this error.)"
		unless ($response->{success} || $opts->{ignore_http_response_code});

	my $content = $response->{decoded_content};
	my $c_type  = $response->{headers}{'content-type'};

	$opts->{'response'} = $response;

	if ($c_type =~ /xml/i and not $opts->{'force_html'})
	{
		$opts->{'parser_used'} = 'XML::LibXML::Parser';
		my $xml_parser = XML::LibXML->new;
		$xml_parser->validation(0);
		$xml_parser->recover(2);
		$xml_parser->base_uri($response->base);
		$xml_parser->load_catalog($opts->{'xml_catalogue'})
			if -r $opts->{'xml_catalogue'};
		return $xml_parser->parse_string($content);
	}

	return $self->parse_string($content, $opts);
}
*parse_html_file = \&parse_file;

sub parse_fh
{
	my $self   = shift;
	my $handle = shift;
	my $opts   = shift || {};

	my $string = '';
	while (<$handle>)
	{
		$string .= $_;
	}

	return $self->parse_string($string, $opts);
}
*parse_html_fh = \&parse_fh;

sub parse_string
{
	my $self = shift;
	my $text = shift;
	my $opts = shift || {};

	$self->{'errors'} = [];
	$opts->{'parser_used'} = 'HTML::HTML5::Parser';
	my $dom = XML::LibXML::Document->createDocument;

	if (defined $opts->{'encoding'}||1)
	{
        # XXX AGAIN DO THIS TO STOP ENORMOUS MEMORY LEAKS
        if (utf8::is_utf8($text)) {
            $text = encode_utf8($text);
        }
        my ($errh, $errors) = @{$self}{qw(error_handler errors)};
        $self->{parser}->parse_byte_string(
            $opts->{'encoding'}, $text, $dom,
            sub {
                my $err = HTML::HTML5::Parser::Error->new(@_);
                $errh->($err) if $errh;
                push @$errors, $err;
			});
	}
	else
	{
		$self->{parser}->parse_char_string($text, $dom, sub{
			my $err = HTML::HTML5::Parser::Error->new(@_);
			$self->{error_handler}->($err) if $self->{error_handler};
			push @{$self->{'errors'}}, $err;
			});
	}

	return $dom;
}
*parse_html_string = \&parse_string;

# TODO: noembed, noframes, noscript
my %within = (
	html       => [qw/html/],
	frameset   => [qw/html frameset/],
	frame      => [qw/html frameset frame/],
	head       => [qw/html head/],
	title      => [qw/html head title/],
	style      => [qw/html head style/],
	(map { $_  => undef }
		qw/base link meta basefont bgsound/),
	body       => [qw/html body/],
	script     => [qw/html body script/],
	div        => [qw/html body div/],
	(map { $_  => [qw/html body div/, $_] }
		qw/a abbr acronym address applet area article aside big blockquote
		button center code details dir dl em fieldset figure font
		footer form h1 h2 h3 h4 h5 h6 header hgroup i iframe
		listing marquee menu nav nobr object ol p plaintext pre
		ruby s section small strike strong tt u ul xmp/),
	(map { $_  => undef }
		qw/br col command datagrid embed hr img input keygen
		param wbr/),
	dd         => [qw/html body dl dd/],
	dd         => [qw/html body dl dt/],
	figcaption => [qw/html body figure/],
	li         => [qw/html body ul li/],
	ul__li     => [qw/html body ul li/],
	ol__li     => [qw/html body ol li/],
	optgroup   => [qw/html body form div select/],
	option     => [qw/html body form div select/],
	rp         => [qw/html body div ruby/],
	rt         => [qw/html body div ruby/],
	select     => [qw/html body form div select/],
	summary    => [qw/html body div details/],
	table      => [qw/html body table/],
	(map { $_  => [qw/html body table/, $_] }
		qw/thead tfoot tbody tr caption colgroup/),
	(map { $_  => [qw/html body table tbody tr/, $_] }
		qw/td th/),
	textarea   => [qw/html body form div textarea/],
);

sub parse_balanced_chunk
{
	my ($self, $chunk, $o) = @_;
	my %options = %{ $o || {} };

	$options{as} = 'default' unless defined $options{as};

	my $w = $options{force_within} || $options{within} || 'div';
	my $ancestors = $within{ lc $w };
	croak "Cannot parse chunk as if within $w."
		if !defined $ancestors;

	my $parent = $ancestors->[-1];
	my $n      = scalar(@$ancestors) - 2;
	my @a      = $n ? @$ancestors[0 .. $n] : ();

	my $uniq = sprintf('rand_id_%09d', int rand 1_000_000_000);
	my $document =
		"\n".
		(join q{}, map { "<$_>" } @a).
		"<$parent id='$uniq'>".
		$chunk.
	''.#	"".
	'';#	(join q{}, map { "" } reverse @a);

	my $dom = $self->parse_html_string($document);
	$parent = $dom->findnodes("//*[\@id='$uniq']")->get_node(1);

	if ($options{debug})
	{
		if (exists &Test::More::diag)
		{
			Test::More::diag($document);
			Test::More::diag($dom->toString);
		}
		else
		{
			warn $document."\n";
			warn $dom->toString."\n";
		}
	}

	my @results = $parent->childNodes;

	unless ($options{force_within})
	{
		while ($parent)
		{
			my $sibling = $parent->nextSibling;
			while ($sibling)
			{
				unless ($sibling->nodeName =~ /^(head|body)$/)
				{
					$sibling->setAttribute('data-perl-html-html5-parser-outlier', 1)
						if $options{mark_outliers}
						&& $sibling->can('setAttribute');
					push @results, $sibling;
				}
				$sibling = $sibling->nextSibling;
			}

			$sibling = $parent->previousSibling;
			while ($sibling)
			{
				unless ($sibling->nodeName =~ /^(head|body)$/)
				{
					$sibling->setAttribute('data-perl-html-html5-parser-outlier', 1)
						if $options{mark_outliers}
						&& $sibling->can('setAttribute');
					unshift @results, $sibling;
				}
				$sibling = $sibling->previousSibling;
			}

			$parent = $parent->parentNode;
		}
	}

	my $frag = XML::LibXML::DocumentFragment->new;
	$frag->appendChild($_) foreach @results;

	if (lc $options{as} eq 'list')
	{
		return wantarray ? @results : XML::LibXML::NodeList->new(@results);
	}

	return wantarray ? @results : $frag;
}

sub load_html
{
	my $class_or_self = shift;

	my %args = map { ref($_) eq 'HASH' ? (%$_) : $_ } @_;
	my $URI = delete($args{URI});
	$URI = "$URI" if defined $URI; # stringify in case it is an URI object
	my $parser = ref($class_or_self)
		? $class_or_self
		: $class_or_self->new;

	my $dom;
	if ( defined $args{location} )
		{ $dom = $parser->parse_file( "$args{location}" ) }
	elsif ( defined $args{string} )
		{ $dom = $parser->parse_string( $args{string}, $URI ) }
	elsif ( defined $args{IO} )
		{ $dom = $parser->parse_fh( $args{IO}, $URI ) }
	else
		{ croak("HTML::HTML5::Parser->load_html: specify location, string, or IO"); }

	return $dom;
}

sub load_xml
{
	my $self = shift;
	my $dom;
	eval {
		$dom = XML::LibXML->load_xml(@_);
	};
	return $dom if blessed($dom);
	return $self->load_html(@_);
}

sub AUTOLOAD
{
	my $self = shift;
	my $func = $AUTOLOAD;
	$func =~ s/.*://;

	# LibXML Push Parser.
	if ($func =~ /^( parse_chunk | start_push | push | finish_push )$/xi)
	{
		croak "Push parser ($func) not implemented by HTML::HTML5::Parser.";
	}

	# Misc LibXML functions with no compatible interface provided.
	if ($func =~ /^( parse_balanced_chunk | parse_xml_chunk |
		process_?xincludes | get_last_error )$/xi)
	{
		croak "$func not implemented by HTML::HTML5::Parser.";
	}

	# Fixed options which are true.
	if ($func =~ /^( recover | recover_silently | expand_entities |
		keep_blanks | no_network )$/xi)
	{
		my $set = shift;
		if ((!$set) && defined $set)
		{
			carp "Option $func cannot be switched off.";
		}
		return 1;
	}

	# Fixed options which are false.
	if ($func =~ /^( validation | pedantic_parser | line_numbers
		load_ext_dtd | complete_attributes | expand_xinclude |
		load_catalog | base_uri | gdome_dom | clean_namespaces )$/xi)
	{
		my $set = shift;
		if (($set) && defined $set)
		{
			carp "Option $func cannot be switched on.";
		}
		return 0;
	}

	carp "HTML::HTML5::Parser doesn't understand '$func'." if length $func;
}

sub error_handler
{
	my $self = shift;
	$self->{error_handler} = shift if @_;
	return $self->{error_handler};
}

sub errors
{
	my $self = shift;
	return @{ $self->{errors} };
}

sub compat_mode
{
	my $self = shift;
	my $node = shift;

	return $self->{parser}->_data($node)->{'manakai_compat_mode'};
}

sub charset
{
	my $self = shift;
	my $node = shift;

	return $self->{parser}->_data($node)->{'charset'};
}

sub dtd_public_id
{
	my $self = shift;
	my $node = shift;

	return $self->{parser}->_data($node)->{'DTD_PUBLIC_ID'};
}

sub dtd_system_id
{
	my $self = shift;
	my $node = shift;

	return $self->{parser}->_data($node)->{'DTD_SYSTEM_ID'};
}

sub dtd_element
{
	my $self = shift;
	my $node = shift;

	return $self->{parser}->_data($node)->{'DTD_ELEMENT'};
}

sub source_line
{
	my $self = shift;
	my $node = shift;

    my $data = ref $self ? $self->{parser}->_data($node) :
        HTML::HTML5::Parser::TagSoupParser::DATA($node);
	my $line = $data->{'manakai_source_line'};

	if (wantarray)
	{
		return (
			$line,
			$data->{'manakai_source_column'},
			($data->{'implied'} || 0),
			);
	}
	else
	{
		return $line;
	}
}

sub DESTROY {}

__END__