| 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 |
|
| 92 |
ok join ("\n", @errors), join ("\n", @{$test->{errors}->[0] or []}), |
| 93 |
'Parse error: ' . Data::Dumper::qquote ($test->{data}->[0]) . '; ' . |
| 94 |
join (', ', @errors) . ';' . join (', ', @{$test->{errors}->[0] or []}); |
| 95 |
|
| 96 |
$test->{document}->[0] .= "\x0A" if length $test->{document}->[0]; |
| 97 |
ok $result, $test->{document}->[0], |
| 98 |
'Document tree: ' . Data::Dumper::qquote ($test->{data}->[0]); |
| 99 |
} # test |
| 100 |
|
| 101 |
my @FILES = grep {$_} split /\s+/, qq[ |
| 102 |
${test_dir_name}elements-1.dat |
| 103 |
${test_dir_name}cdata-1.dat |
| 104 |
${test_dir_name}attrs-1.dat |
| 105 |
${test_dir_name}tree-1.dat |
| 106 |
${test_dir_name}ns-attrs-1.dat |
| 107 |
${test_dir_name}doctypes-1.dat |
| 108 |
]; |
| 109 |
|
| 110 |
require 't/testfiles.pl'; |
| 111 |
execute_test ($_, { |
| 112 |
errors => {is_list => 1}, |
| 113 |
document => {is_prefixed => 1}, |
| 114 |
'document-fragment' => {is_prefixed => 1}, |
| 115 |
}, \&test) for @FILES; |
| 116 |
|
| 117 |
## License: Public Domain. |
| 118 |
## $Date: 2008/10/14 10:36:33 $ |
Parent Directory
| 
Revision Log