| 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 |
require Whatpm::ContentChecker; |
| 8 |
require Message::DOM::DOMImplementation; |
| 9 |
require Message::DOM::XMLParserTemp; |
| 10 |
require Whatpm::HTML; |
| 11 |
require Whatpm::NanoDOM; |
| 12 |
|
| 13 |
sub test_files (@) { |
| 14 |
my @FILES = @_; |
| 15 |
|
| 16 |
require 't/testfiles.pl'; |
| 17 |
execute_test ($_, { |
| 18 |
errors => {is_list => 1}, |
| 19 |
}, \&test) for @FILES; |
| 20 |
} # test_files |
| 21 |
|
| 22 |
my $dom = Message::DOM::DOMImplementation->new; |
| 23 |
sub test ($) { |
| 24 |
my $test = shift; |
| 25 |
|
| 26 |
$test->{parse_as} = 'xml'; |
| 27 |
$test->{parse_as} = 'html' |
| 28 |
if $test->{data}->[1] and $test->{data}->[1]->[0] eq 'html'; |
| 29 |
|
| 30 |
unless ($test->{data}) { |
| 31 |
warn "No #data field\n"; |
| 32 |
} elsif (not $test->{errors}) { |
| 33 |
warn "No #errors field ($test->{data}->[0])\n"; |
| 34 |
} |
| 35 |
|
| 36 |
my $doc; |
| 37 |
if ($test->{parse_as} eq 'xml') { |
| 38 |
open my $fh, '<', \($test->{data}->[0]); |
| 39 |
$doc = Message::DOM::XMLParserTemp->parse_byte_stream |
| 40 |
($fh => $dom, sub { |
| 41 |
warn "Document: " . $test->{data}->[0]; |
| 42 |
}, charset => 'utf-8'); |
| 43 |
$doc->input_encoding (undef); |
| 44 |
## NOTE: There should be no well-formedness error; if there is, |
| 45 |
## then it is an error of the test case itself. |
| 46 |
} else { |
| 47 |
$doc = Whatpm::NanoDOM::Document->new; |
| 48 |
Whatpm::HTML->parse_char_string ($test->{data}->[0] => $doc); |
| 49 |
} |
| 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/18 05:49:13 $ |
Parent Directory
| 
Revision Log