| 1 |
#!/usr/bin/perl |
| 2 |
use strict; |
| 3 |
|
| 4 |
my $DEBUG = $ENV{DEBUG}; |
| 5 |
|
| 6 |
use lib qw[/home/wakaba/work/manakai2/lib]; |
| 7 |
my $test_dir_name = 't/'; |
| 8 |
my $dir_name = 't/tree-construction/'; |
| 9 |
|
| 10 |
use Test; |
| 11 |
BEGIN { plan tests => 4935 } |
| 12 |
|
| 13 |
use Data::Dumper; |
| 14 |
$Data::Dumper::Useqq = 1; |
| 15 |
sub Data::Dumper::qquote { |
| 16 |
my $s = shift; |
| 17 |
$s =~ s/([^\x20\x21-\x26\x28-\x5B\x5D-\x7E])/sprintf '\x{%02X}', ord $1/ge; |
| 18 |
return q<qq'> . $s . q<'>; |
| 19 |
} # Data::Dumper::qquote |
| 20 |
|
| 21 |
if ($DEBUG) { |
| 22 |
my $not_found = {%{$Whatpm::HTML::Debug::cp or {}}}; |
| 23 |
$Whatpm::HTML::Debug::cp_pass = sub { |
| 24 |
my $id = shift; |
| 25 |
delete $not_found->{$id}; |
| 26 |
}; |
| 27 |
|
| 28 |
END { |
| 29 |
for my $id (sort {$a <=> $b || $a cmp $b} keys %$not_found) { |
| 30 |
print "# checkpoint $id is not reached\n"; |
| 31 |
} |
| 32 |
} |
| 33 |
} |
| 34 |
|
| 35 |
my @FILES = grep {$_} split /\s+/, qq[ |
| 36 |
${test_dir_name}tokenizer-test-2.dat |
| 37 |
${test_dir_name}tokenizer-test-3.dat |
| 38 |
${dir_name}tests1.dat |
| 39 |
${dir_name}tests2.dat |
| 40 |
${dir_name}tests3.dat |
| 41 |
${dir_name}tests4.dat |
| 42 |
${dir_name}tests5.dat |
| 43 |
${dir_name}tests6.dat |
| 44 |
${dir_name}tests7.dat |
| 45 |
${dir_name}tests8.dat |
| 46 |
${dir_name}tests9.dat |
| 47 |
${dir_name}tests10.dat |
| 48 |
${dir_name}tests11.dat |
| 49 |
${dir_name}tests12.dat |
| 50 |
${test_dir_name}tree-test-1.dat |
| 51 |
${test_dir_name}tree-test-2.dat |
| 52 |
${test_dir_name}tree-test-3.dat |
| 53 |
${test_dir_name}tree-test-void.dat |
| 54 |
${test_dir_name}tree-test-flow.dat |
| 55 |
${test_dir_name}tree-test-phrasing.dat |
| 56 |
${test_dir_name}tree-test-form.dat |
| 57 |
${test_dir_name}tree-test-foreign.dat |
| 58 |
]; |
| 59 |
|
| 60 |
require 't/testfiles.pl'; |
| 61 |
execute_test ($_, { |
| 62 |
errors => {is_list => 1}, |
| 63 |
shoulds => {is_list => 1}, |
| 64 |
document => {is_prefixed => 1}, |
| 65 |
'document-fragment' => {is_prefixed => 1}, |
| 66 |
}, \&test) for @FILES; |
| 67 |
|
| 68 |
use Whatpm::HTML; |
| 69 |
use Whatpm::NanoDOM; |
| 70 |
use Whatpm::Charset::UnicodeChecker; |
| 71 |
use Whatpm::HTML::Dumper qw/dumptree/; |
| 72 |
|
| 73 |
sub test ($) { |
| 74 |
my $test = shift; |
| 75 |
|
| 76 |
if ($test->{'document-fragment'}) { |
| 77 |
if (@{$test->{'document-fragment'}->[1]}) { |
| 78 |
## NOTE: Old format. |
| 79 |
$test->{element} = $test->{'document-fragment'}->[1]->[0]; |
| 80 |
$test->{document} ||= $test->{'document-fragment'}; |
| 81 |
} else { |
| 82 |
## NOTE: New format. |
| 83 |
$test->{element} = $test->{'document-fragment'}->[0]; |
| 84 |
} |
| 85 |
} |
| 86 |
|
| 87 |
my $doc = Whatpm::NanoDOM::Document->new; |
| 88 |
my @errors; |
| 89 |
my @shoulds; |
| 90 |
|
| 91 |
$SIG{INT} = sub { |
| 92 |
print scalar dumptree ($doc); |
| 93 |
exit; |
| 94 |
}; |
| 95 |
|
| 96 |
my $onerror = sub { |
| 97 |
my %opt = @_; |
| 98 |
if ($opt{level} eq 's') { |
| 99 |
push @shoulds, join ':', $opt{line}, $opt{column}, $opt{type}; |
| 100 |
} else { |
| 101 |
push @errors, join ':', $opt{line}, $opt{column}, $opt{type}; |
| 102 |
} |
| 103 |
}; |
| 104 |
|
| 105 |
my $chk = sub { |
| 106 |
return Whatpm::Charset::UnicodeChecker->new_handle ($_[0], 'html5'); |
| 107 |
}; # $chk |
| 108 |
|
| 109 |
my $result; |
| 110 |
unless (defined $test->{element}) { |
| 111 |
Whatpm::HTML->parse_char_string |
| 112 |
($test->{data}->[0] => $doc, $onerror, $chk); |
| 113 |
$result = dumptree ($doc); |
| 114 |
} else { |
| 115 |
my $el = $doc->create_element_ns |
| 116 |
('http://www.w3.org/1999/xhtml', [undef, $test->{element}]); |
| 117 |
Whatpm::HTML->set_inner_html ($el, $test->{data}->[0], $onerror, $chk); |
| 118 |
$result = dumptree ($el); |
| 119 |
} |
| 120 |
|
| 121 |
warn "No #errors section ($test->{data}->[0])" unless $test->{errors}; |
| 122 |
|
| 123 |
ok scalar @errors, scalar @{$test->{errors}->[0] or []}, |
| 124 |
'Parse error: ' . Data::Dumper::qquote ($test->{data}->[0]) . '; ' . |
| 125 |
join (', ', @errors) . ';' . join (', ', @{$test->{errors}->[0] or []}); |
| 126 |
ok scalar @shoulds, scalar @{$test->{shoulds}->[0] or []}, |
| 127 |
'SHOULD-level error: ' . Data::Dumper::qquote ($test->{data}->[0]) . '; ' . |
| 128 |
join (', ', @shoulds) . ';' . join (', ', @{$test->{shoulds}->[0] or []}); |
| 129 |
|
| 130 |
$test->{document}->[0] .= "\x0A" if length $test->{document}->[0]; |
| 131 |
ok $result, $test->{document}->[0], |
| 132 |
'Document tree: ' . Data::Dumper::qquote ($test->{data}->[0]); |
| 133 |
} # test |
| 134 |
|
| 135 |
## License: Public Domain. |
| 136 |
## $Date: 2008/10/14 07:40:52 $ |
Parent Directory
| 
Revision Log