1 |
use strict; |
2 |
|
3 |
## ISSUE: Currently we require manakai XML parser to test arbitrary XML tree. |
4 |
use lib qw[/home/wakaba/work/manakai2/lib]; |
5 |
|
6 |
use Test; |
7 |
|
8 |
require Whatpm::ContentChecker; |
9 |
require Whatpm::XML::Parser; |
10 |
require Whatpm::HTML; |
11 |
require Whatpm::NanoDOM; |
12 |
require Message::URI::URIReference; |
13 |
require Message::DOM::Atom::AtomElement; |
14 |
*Whatpm::NanoDOM::Element::rel |
15 |
= \&Message::DOM::Atom::AtomElement::AtomLinkElement::rel; |
16 |
|
17 |
sub test_files (@) { |
18 |
my @FILES = @_; |
19 |
|
20 |
require 't/testfiles.pl'; |
21 |
execute_test ($_, { |
22 |
errors => {is_list => 1}, |
23 |
}, \&test) for @FILES; |
24 |
} # test_files |
25 |
|
26 |
sub test ($) { |
27 |
my $test = shift; |
28 |
|
29 |
$test->{parse_as} = 'xml'; |
30 |
$test->{parse_as} = 'html' |
31 |
if $test->{data}->[1] and $test->{data}->[1]->[0] eq 'html'; |
32 |
|
33 |
unless ($test->{data}) { |
34 |
warn "No #data field\n"; |
35 |
} elsif (not $test->{errors}) { |
36 |
warn "No #errors field ($test->{data}->[0])\n"; |
37 |
} |
38 |
|
39 |
my $doc; |
40 |
if ($test->{parse_as} eq 'xml') { |
41 |
$doc = Whatpm::NanoDOM::Document->new; |
42 |
Whatpm::XML::Parser->parse_char_string ($test->{data}->[0] => $doc); |
43 |
## NOTE: There should be no well-formedness error; if there is, |
44 |
## then it is an error of the test case itself. |
45 |
} else { |
46 |
$doc = Whatpm::NanoDOM::Document->new; |
47 |
Whatpm::HTML->parse_char_string ($test->{data}->[0] => $doc); |
48 |
} |
49 |
$doc->document_uri (q<thismessage:/>); |
50 |
|
51 |
my @error; |
52 |
Whatpm::ContentChecker->check_element |
53 |
($doc->document_element, sub { |
54 |
my %opt = @_; |
55 |
if ($opt{type} =~ /^status:/ and $opt{level} eq 'i') { |
56 |
# |
57 |
} else { |
58 |
push @error, get_node_path ($opt{node}) . ';' . $opt{type} . |
59 |
(defined $opt{text} ? ';' . $opt{text} : '') . |
60 |
(defined $opt{level} ? ';'.$opt{level} : ''); |
61 |
} |
62 |
}, sub { |
63 |
my $opt = shift; |
64 |
push @error, get_node_path ($opt->{container_node}) . ';SUBDOC'; |
65 |
}); |
66 |
|
67 |
ok join ("\n", sort {$a cmp $b} @error), |
68 |
join ("\n", sort {$a cmp $b} @{$test->{errors}->[0]}), $test->{data}->[0]; |
69 |
} # test |
70 |
|
71 |
sub get_node_path ($) { |
72 |
my $node = shift; |
73 |
my @r; |
74 |
while (defined $node) { |
75 |
my $rs; |
76 |
if ($node->node_type == 1) { |
77 |
$rs = $node->manakai_local_name; |
78 |
$node = $node->parent_node; |
79 |
} elsif ($node->node_type == 2) { |
80 |
$rs = '@' . $node->manakai_local_name; |
81 |
$node = $node->owner_element; |
82 |
} elsif ($node->node_type == 3) { |
83 |
$rs = '"' . $node->data . '"'; |
84 |
$node = $node->parent_node; |
85 |
} elsif ($node->node_type == 9) { |
86 |
$rs = ''; |
87 |
$node = $node->parent_node; |
88 |
} else { |
89 |
$rs = '#' . $node->node_type; |
90 |
$node = $node->parent_node; |
91 |
} |
92 |
unshift @r, $rs; |
93 |
} |
94 |
return join '/', @r; |
95 |
} # get_node_path |
96 |
|
97 |
=head1 NAME |
98 |
|
99 |
content-checker.pl - Test engine for document conformance checking |
100 |
|
101 |
=head1 DESCRIPTION |
102 |
|
103 |
The C<content-checker.pl> script implements a test engine for the |
104 |
conformance checking modules, directly or indirectly referenced from |
105 |
L<Whatpm::ContentChecker>. |
106 |
|
107 |
This script is C<require>d by various test scripts, including |
108 |
C<ContentCheker.t>, C<ContentChecker-Atom.t>, and C<LangTag.t>. |
109 |
|
110 |
=head1 AUTHOR |
111 |
|
112 |
Wakaba <w@suika.fam.cx>. |
113 |
|
114 |
=head1 LICENSE |
115 |
|
116 |
Public Domain. |
117 |
|
118 |
=cut |
119 |
|
120 |
1; ## $Date: 2008/09/20 07:00:53 $ |