| 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/xml/'; |
| 8 |
|
| 9 |
use Test; |
| 10 |
BEGIN { plan tests => 4935 } |
| 11 |
|
| 12 |
use Data::Dumper; |
| 13 |
$Data::Dumper::Useqq = 1; |
| 14 |
sub Data::Dumper::qquote { |
| 15 |
my $s = shift; |
| 16 |
$s =~ s/([^\x20\x21-\x26\x28-\x5B\x5D-\x7E])/sprintf '\x{%02X}', ord $1/ge; |
| 17 |
return q<qq'> . $s . q<'>; |
| 18 |
} # Data::Dumper::qquote |
| 19 |
|
| 20 |
if ($DEBUG) { |
| 21 |
my $not_found = {%{$Whatpm::HTML::Debug::cp or {}}}; |
| 22 |
$Whatpm::HTML::Debug::cp_pass = sub { |
| 23 |
my $id = shift; |
| 24 |
delete $not_found->{$id}; |
| 25 |
}; |
| 26 |
|
| 27 |
END { |
| 28 |
for my $id (sort {$a <=> $b || $a cmp $b} keys %$not_found) { |
| 29 |
print "# checkpoint $id is not reached\n"; |
| 30 |
} |
| 31 |
} |
| 32 |
} |
| 33 |
|
| 34 |
use Whatpm::XML::Parser; |
| 35 |
use Whatpm::NanoDOM; |
| 36 |
use Whatpm::Charset::UnicodeChecker; |
| 37 |
use Whatpm::HTML::Dumper qw/dumptree/; |
| 38 |
|
| 39 |
sub test ($) { |
| 40 |
my $test = shift; |
| 41 |
|
| 42 |
if ($test->{'document-fragment'}) { |
| 43 |
if (@{$test->{'document-fragment'}->[1]}) { |
| 44 |
## NOTE: Old format. |
| 45 |
$test->{element} = $test->{'document-fragment'}->[1]->[0]; |
| 46 |
$test->{document} ||= $test->{'document-fragment'}; |
| 47 |
} else { |
| 48 |
## NOTE: New format. |
| 49 |
$test->{element} = $test->{'document-fragment'}->[0]; |
| 50 |
} |
| 51 |
} |
| 52 |
|
| 53 |
my $doc = Whatpm::NanoDOM::Document->new; |
| 54 |
my @errors; |
| 55 |
|
| 56 |
$SIG{INT} = sub { |
| 57 |
print scalar dumptree ($doc); |
| 58 |
exit; |
| 59 |
}; |
| 60 |
|
| 61 |
my $onerror = sub { |
| 62 |
my %opt = @_; |
| 63 |
push @errors, join ';', |
| 64 |
$opt{token}->{line} || $opt{line}, |
| 65 |
$opt{token}->{column} || $opt{column}, |
| 66 |
$opt{type}, |
| 67 |
defined $opt{text} ? $opt{text} : '', |
| 68 |
defined $opt{value} ? $opt{value} : '', |
| 69 |
$opt{level}; |
| 70 |
}; |
| 71 |
|
| 72 |
my $chk = sub { |
| 73 |
return $_[0]; |
| 74 |
#return Whatpm::Charset::UnicodeChecker->new_handle ($_[0], 'html5'); |
| 75 |
}; # $chk |
| 76 |
|
| 77 |
my $p = Whatpm::XML::Parser->new; |
| 78 |
my $result; |
| 79 |
unless (defined $test->{element}) { |
| 80 |
$p->parse_char_string ($test->{data}->[0] => $doc, $onerror, $chk); |
| 81 |
$result = dumptree ($doc); |
| 82 |
} else { |
| 83 |
## TODO: ... |
| 84 |
my $el = $doc->create_element_ns |
| 85 |
('http://www.w3.org/1999/xhtml', [undef, $test->{element}]); |
| 86 |
Whatpm::HTML->set_inner_html ($el, $test->{data}->[0], $onerror, $chk); |
| 87 |
$result = dumptree ($el); |
| 88 |
} |
| 89 |
|
| 90 |
warn "No #errors section ($test->{data}->[0])" unless $test->{errors}; |
| 91 |
|
| 92 |
@errors = sort {$a cmp $b} @errors; |
| 93 |
@{$test->{errors}->[0]} = sort {$a cmp $b} @{$test->{errors}->[0] ||= []}; |
| 94 |
|
| 95 |
ok join ("\n", @errors), join ("\n", @{$test->{errors}->[0] or []}), |
| 96 |
'Parse error: ' . Data::Dumper::qquote ($test->{data}->[0]); |
| 97 |
|
| 98 |
if ($test->{'xml-version'}) { |
| 99 |
ok $doc->xml_version, $test->{'xml-version'}->[0], |
| 100 |
'XML version: ' . Data::Dumper::qquote ($test->{data}->[0]); |
| 101 |
} |
| 102 |
|
| 103 |
if ($test->{'xml-encoding'}) { |
| 104 |
if ($test->{'xml-encoding'}->[1]->[0] eq 'null') { |
| 105 |
ok $doc->xml_encoding, undef, |
| 106 |
'XML encoding: ' . Data::Dumper::qquote ($test->{data}->[0]); |
| 107 |
} else { |
| 108 |
ok $doc->xml_encoding, $test->{'xml-encoding'}->[0], |
| 109 |
'XML encoding: ' . Data::Dumper::qquote ($test->{data}->[0]); |
| 110 |
} |
| 111 |
} |
| 112 |
|
| 113 |
if ($test->{'xml-standalone'}) { |
| 114 |
ok $doc->xml_standalone ? 1 : 0, |
| 115 |
$test->{'xml-standalone'}->[1]->[0] eq 'true' ? 1 : 0, |
| 116 |
'XML standalone: ' . Data::Dumper::qquote ($test->{data}->[0]); |
| 117 |
} |
| 118 |
|
| 119 |
if ($test->{entities}) { |
| 120 |
my @e; |
| 121 |
for (keys %{$p->{ge}}) { |
| 122 |
my $ent = $p->{ge}->{$_}; |
| 123 |
my $v = '<!ENTITY ' . $ent->{name} . ' "'; |
| 124 |
$v .= $ent->{value} if defined $ent->{value}; |
| 125 |
$v .= '" "'; |
| 126 |
$v .= $ent->{pubid} if defined $ent->{pubid}; |
| 127 |
$v .= '" "'; |
| 128 |
$v .= $ent->{sysid} if defined $ent->{sysid}; |
| 129 |
$v .= '" '; |
| 130 |
$v .= $ent->{notation} if defined $ent->{notation}; |
| 131 |
$v .= '>'; |
| 132 |
push @e, $v; |
| 133 |
} |
| 134 |
for (keys %{$p->{pe}}) { |
| 135 |
my $ent = $p->{pe}->{$_}; |
| 136 |
my $v = '<!ENTITY % ' . $ent->{name} . ' "'; |
| 137 |
$v .= $ent->{value} if defined $ent->{value}; |
| 138 |
$v .= '" "'; |
| 139 |
$v .= $ent->{pubid} if defined $ent->{pubid}; |
| 140 |
$v .= '" "'; |
| 141 |
$v .= $ent->{sysid} if defined $ent->{sysid}; |
| 142 |
$v .= '" '; |
| 143 |
$v .= $ent->{notation} if defined $ent->{notation}; |
| 144 |
$v .= '>'; |
| 145 |
push @e, $v; |
| 146 |
} |
| 147 |
ok join ("\x0A", @e), $test->{entities}->[0], |
| 148 |
'Entities: ' . Data::Dumper::qquote ($test->{data}->[0]); |
| 149 |
} |
| 150 |
|
| 151 |
$test->{document}->[0] .= "\x0A" if length $test->{document}->[0]; |
| 152 |
ok $result, $test->{document}->[0], |
| 153 |
'Document tree: ' . Data::Dumper::qquote ($test->{data}->[0]); |
| 154 |
} # test |
| 155 |
|
| 156 |
my @FILES = grep {$_} split /\s+/, qq[ |
| 157 |
${test_dir_name}elements-1.dat |
| 158 |
${test_dir_name}attrs-1.dat |
| 159 |
${test_dir_name}texts-1.dat |
| 160 |
${test_dir_name}cdata-1.dat |
| 161 |
${test_dir_name}charref-1.dat |
| 162 |
${test_dir_name}comments-2.dat |
| 163 |
${test_dir_name}pis-1.dat |
| 164 |
${test_dir_name}pis-2.dat |
| 165 |
${test_dir_name}xmldecls-1.dat |
| 166 |
${test_dir_name}tree-1.dat |
| 167 |
${test_dir_name}ns-elements-1.dat |
| 168 |
${test_dir_name}ns-attrs-1.dat |
| 169 |
${test_dir_name}doctypes-1.dat |
| 170 |
${test_dir_name}doctypes-2.dat |
| 171 |
${test_dir_name}eldecls-1.dat |
| 172 |
${test_dir_name}attlists-1.dat |
| 173 |
${test_dir_name}entities-1.dat |
| 174 |
${test_dir_name}entities-2.dat |
| 175 |
${test_dir_name}notations-1.dat |
| 176 |
${test_dir_name}entrefs-1.dat |
| 177 |
${test_dir_name}entrefs-2.dat |
| 178 |
]; |
| 179 |
|
| 180 |
require 't/testfiles.pl'; |
| 181 |
execute_test ($_, { |
| 182 |
errors => {is_list => 1}, |
| 183 |
document => {is_prefixed => 1}, |
| 184 |
'document-fragment' => {is_prefixed => 1}, |
| 185 |
entities => {is_prefixed => 1}, |
| 186 |
}, \&test) for @FILES; |
| 187 |
|
| 188 |
## License: Public Domain. |
| 189 |
## $Date: 2008/10/19 09:25:21 $ |
Parent Directory
| 
Revision Log