1## skip Test::Tabs
2use Test::More;
3use HTML::HTML5::Parser;
4
5BEGIN {
6	eval { require Moo; 1 } or plan skip_all => 'Need Moo!'
7};
8
9{
10	package XML::LibXML::Document;
11	sub pythonDebug
12	{
13		my $self = shift;
14		my ($indent, $parser) = @_;
15		$indent = '' unless defined $indent;
16
17		my $return;
18
19		my $element = $parser->dtd_element($self);
20		my $public  = $parser->dtd_public_id($self) || '';
21		my $system  = $parser->dtd_system_id($self) || '';
22
23		if (defined $element)
24		{
25			$return = sprintf(
26				"| <!DOCTYPE %s%s%s>\n",
27				$element,
28				(($public||$system) ? " \"$public\"" : ""),
29				(($public||$system) ? " \"$system\"" : ""),
30				);
31		}
32
33		$return .= $_->pythonDebug(q{| }, $parser) foreach $self->childNodes;
34		return $return;
35	}
36}
37
38{
39	package XML::LibXML::DocumentFragment;
40	sub pythonDebug
41	{
42		my $self = shift;
43		my ($indent, $parser) = @_;
44		$indent = '' unless defined $indent;
45
46		$self->normalize;
47
48		my $return;
49		foreach ($self->childNodes)
50		{
51			$return .= $_->pythonDebug($indent . q{| }, $parser);
52		}
53		return $return;
54	}
55}
56
57{
58	package XML::LibXML::Element;
59	sub pythonDebug
60	{
61		my $self = shift;
62		my ($indent, $parser) = @_;
63		$indent = '' unless defined $indent;
64
65		$self->normalize;
66
67		my $nsbit  = '';
68		$nsbit = 'svg ' if $self->namespaceURI =~ /svg/i;
69		$nsbit = 'math ' if $self->namespaceURI =~ /math/i;
70		my $return = sprintf("%s<%s%s>\n", $indent, $nsbit, $self->localname);
71
72		my @attribs =
73			sort { $a->localname cmp $b->localname }
74			grep { not $_->isa('XML::LibXML::Namespace') }
75			$self->attributes;
76		foreach (@attribs)
77		{
78			$return .= $_->pythonDebug($indent . q{  }, $parser);
79		}
80
81		if ($self->localname eq 'noscript')
82		{
83			my $innerHTML = join q{}, map { $_->toString } $self->childNodes;
84			$return .= $indent . q{  "} . $innerHTML . "\"\n";
85		}
86		else
87		{
88			foreach ($self->childNodes)
89			{
90				$return .= $_->pythonDebug($indent . q{  }, $parser);
91			}
92		}
93
94		return $return;
95	}
96}
97
98{
99	package XML::LibXML::Text;
100	sub pythonDebug
101	{
102		my $self = shift;
103		my ($indent, $parser) = @_;
104		$indent = '' unless defined $indent;
105
106		return sprintf("%s\"%s\"\n", $indent, $self->data);
107	}
108}
109
110{
111	package XML::LibXML::Comment;
112	sub pythonDebug
113	{
114		my $self = shift;
115		my ($indent, $parser) = @_;
116		$indent = '' unless defined $indent;
117
118		return sprintf("%s<!-- %s -->\n", $indent, $self->data);
119	}
120}
121
122{
123	package XML::LibXML::Attr;
124	sub pythonDebug
125	{
126		my $self = shift;
127		my ($indent, $parser) = @_;
128		$indent = '' unless defined $indent;
129
130		return sprintf("%s%s %s=\"%s\"\n", $indent, split(/:/, $self->nodeName), $self->value)
131			if $self->namespaceURI && $self->nodeName=~/:/;
132		return sprintf("%s%s=\"%s\"\n", $indent, $self->localname, $self->value);
133	}
134}
135
136{
137	package Local::HTML5Lib::Test;
138
139	use Moo;
140
141	has test_file         => (is => 'rw');
142	has test_number       => (is => 'rw');
143	has data              => (is => 'rw');
144	has errors            => (is => 'rw');
145	has document          => (is => 'rw');
146	has document_fragment => (is => 'rw');
147	has parser            => (is => 'lazy', builder => '_build_parser');
148
149	sub test_id
150	{
151		my $self = shift;
152		if ($self->test_file->filename =~ m{ / ([^/]+) $ }x)
153		{
154			sprintf('%s:%s', $1, $self->test_number||1);
155		}
156	}
157
158	sub dom
159	{
160		my ($self) = @_;
161
162		if ($self->document_fragment)
163		{
164			return $self->parser->parse_balanced_chunk(
165				$self->data,
166				{within => $self->document_fragment},
167			);
168		}
169
170		return eval {
171			$self->parser->parse_string($self->data);
172		} || do {
173			my $e   = $@;
174			my $xml = 'XML::LibXML::Document'->new('1.0', 'utf-8');
175			$xml->setDocumentElement( $xml->createElementNS('http://www.w3.org/1999/xhtml', 'html') );
176			$xml->documentElement->appendText("ERROR: $e");
177			$xml;
178		}
179	}
180
181	sub _build_parser
182	{
183		require HTML::HTML5::Parser;
184		'HTML::HTML5::Parser'->new;
185	}
186
187	sub __uniscape
188	{
189		my $str = shift;
190		eval {
191			$str =~ s{ ([^\n\x20-\x7E]) }{ sprintf('\x{%04X}', ord($1)) }gex;
192		};
193		$str;
194	}
195
196	sub run
197	{
198		my ($self) = @_;
199		my $expected = $self->document."\n";
200		my $got      = $self->dom->pythonDebug(undef, $self->parser);
201		utf8::decode($got);
202
203		local $Test::Builder::Level = $Test::Builder::Level + 1;
204
205		SKIP: {
206			my $excuse = $::SKIP->{ $self->test_id };
207			Test::More::skip($excuse, 1) if defined $excuse;
208
209			if ($got eq $expected)
210			{
211				Test::More::pass("DATA: ".$self->data);
212				return 1;
213			}
214			else
215			{
216				Test::More::fail("DATA: ".$self->data);
217				Test::More::diag("ID: ".$self->test_id);
218				Test::More::diag("GOT:\n" . __uniscape $got);
219				Test::More::diag("EXPECTED:\n" . __uniscape $expected);
220				return 0;
221			}
222		}
223	}
224}
225
226{
227	package Local::HTML5Lib::TestFile;
228
229	use Moo;
230
231	has filename   => (is => "rw");
232	has tests      => (is => "rw");
233	has last_score => (is => "rw");
234
235	sub read_file
236	{
237		my ($class, $filename) = @_;
238
239		my $self = $class->new(
240			filename  => $filename,
241			);
242
243		my @tests;
244
245		open my $fh, '<', $filename;
246		push @tests, (my $current_test = { test_file=>$self });
247		my $current_key;
248		my @lines = <$fh>; # sometimes we need to peek at the next line;
249		while (defined ($_ = shift @lines))
250		{
251			no warnings;
252
253			if (!/\S/ and (!defined $lines[0] or $lines[0]=~ /^\#data/))
254			{
255				$current_test->{test_number} = @tests;
256				chomp $current_test->{$current_key} if defined $current_key;
257				$current_test = { test_file=>$self };
258				$current_key  = undef;
259				push @tests, $current_test;
260				next;
261			}
262
263			if (/^\#(.+)/)
264			{
265				chomp $current_test->{$current_key} if defined $current_key;
266				($current_key = $1) =~ s/-/_/g;
267				next;
268			}
269
270			$current_test->{$current_key} .= $_;
271		}
272
273		chomp $current_test->{$current_key};
274
275		$self->tests([ map {
276			utf8::decode($_->{document});
277			utf8::decode($_->{data});
278			Local::HTML5Lib::Test->new(%$_);
279			} @tests]);
280		return $self;
281	}
282
283	sub run
284	{
285		local $Test::Builder::Level = $Test::Builder::Level + 1;
286
287		my $self = shift;
288		$self->{last_score} = 0;
289		Test::More::subtest(
290			sprintf("Test file: %s", $self->filename),
291			sub {	$self->{last_score} += ($_->run ? 1 : 0) for @{ $self->tests } },
292			);
293	}
294}
295
296package main;
297
298our $SKIP = {
299	'tests26.dat:10'
300		=> 'requires HTML parser to construct a DOM tree which is illegal in libxml (bad attribute name)',
301	'webkit01.dat:14'
302		=> 'requires HTML parser to construct a DOM tree which is illegal in libxml (bad element name)',
303	'webkit01.dat:42'
304		=> 'requires HTML parser to construct a DOM tree which is illegal in libxml (bad attribute name)',
305	'webkit02.dat:4'
306		=> 'I basically just disagree with this test.',
307	'html5test-com.dat:1'
308		=> 'requires HTML parser to construct a DOM tree which is illegal in libxml (bad element name)',
309	'html5test-com.dat:2'
310		=> 'requires HTML parser to construct a DOM tree which is illegal in libxml (bad attribute name)',
311	'html5test-com.dat:4'
312		=> 'requires HTML parser to construct a DOM tree which is illegal in libxml (bad attribute name)',
313	};
314
315my @fails;
316my @passes;
317
318unless (@ARGV)
319{
320	@ARGV = <t/html5lib-pass/*.dat>;
321}
322
323plan tests => scalar(@ARGV);
324
325while (my $f = shift)
326{
327	my $F = Local::HTML5Lib::TestFile->read_file($f);
328	if ($F->run)
329	{
330		push @passes, $F;
331	}
332	else
333	{
334		push @fails, $F;
335	}
336}
337
338if (@fails)
339{
340	diag "FAILED:";
341	diag sprintf("  %s [%d/%d]", $_->filename, $_->last_score, scalar(@{$_->tests}))
342		for @fails;
343}
344
345if (@passes)
346{
347	diag "PASSED:";
348	diag sprintf("  %s [%d/%d]", $_->filename, $_->last_score, scalar(@{$_->tests}))
349		for @passes;
350}
351
352=head1 PURPOSE
353
354Tests from html5lib's testdata/tree-construction.
355
356=head1 SEE ALSO
357
358L<http://code.google.com/p/html5lib/source/browse/testdata/tree-construction>.
359
360=head1 AUTHOR
361
362Toby Inkster, E<lt>tobyink@cpan.orgE<gt>
363
364=head1 COPYRIGHT AND LICENCE
365
366Copyright (C) 2012 by Toby Inkster
367
368This library is free software; you can redistribute it and/or modify
369it under the same terms as Perl itself.
370