| 1 |
wakaba |
1.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 $result; |
| 78 |
|
|
unless (defined $test->{element}) { |
| 79 |
|
|
Whatpm::XML::Parser->parse_char_string |
| 80 |
|
|
($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 |
wakaba |
1.5 |
|
| 92 |
|
|
@errors = sort {$a cmp $b} @errors; |
| 93 |
|
|
@{$test->{errors}->[0]} = sort {$a cmp $b} @{$test->{errors}->[0] ||= []}; |
| 94 |
wakaba |
1.1 |
|
| 95 |
|
|
ok join ("\n", @errors), join ("\n", @{$test->{errors}->[0] or []}), |
| 96 |
wakaba |
1.7 |
'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 |
wakaba |
1.1 |
|
| 119 |
|
|
$test->{document}->[0] .= "\x0A" if length $test->{document}->[0]; |
| 120 |
|
|
ok $result, $test->{document}->[0], |
| 121 |
|
|
'Document tree: ' . Data::Dumper::qquote ($test->{data}->[0]); |
| 122 |
|
|
} # test |
| 123 |
|
|
|
| 124 |
|
|
my @FILES = grep {$_} split /\s+/, qq[ |
| 125 |
wakaba |
1.4 |
${test_dir_name}elements-1.dat |
| 126 |
wakaba |
1.5 |
${test_dir_name}attrs-1.dat |
| 127 |
|
|
${test_dir_name}texts-1.dat |
| 128 |
wakaba |
1.2 |
${test_dir_name}cdata-1.dat |
| 129 |
wakaba |
1.6 |
${test_dir_name}charref-1.dat |
| 130 |
wakaba |
1.7 |
${test_dir_name}pis-1.dat |
| 131 |
|
|
${test_dir_name}xmldecls-1.dat |
| 132 |
wakaba |
1.2 |
${test_dir_name}tree-1.dat |
| 133 |
wakaba |
1.3 |
${test_dir_name}ns-attrs-1.dat |
| 134 |
wakaba |
1.4 |
${test_dir_name}doctypes-1.dat |
| 135 |
wakaba |
1.2 |
]; |
| 136 |
wakaba |
1.1 |
|
| 137 |
|
|
require 't/testfiles.pl'; |
| 138 |
|
|
execute_test ($_, { |
| 139 |
|
|
errors => {is_list => 1}, |
| 140 |
|
|
document => {is_prefixed => 1}, |
| 141 |
|
|
'document-fragment' => {is_prefixed => 1}, |
| 142 |
|
|
}, \&test) for @FILES; |
| 143 |
|
|
|
| 144 |
|
|
## License: Public Domain. |
| 145 |
wakaba |
1.7 |
## $Date: 2008/10/14 15:25:50 $ |
Parent Directory
| 
Revision Log