whatpm/t/content-checker.pl

use strict;

## ISSUE: Currently we require manakai XML parser to test arbitrary XML tree.
use lib qw[/home/wakaba/work/manakai2/lib];

use Test;
require Whatpm::ContentChecker;
require Message::DOM::DOMImplementation;
require Message::DOM::XMLParserTemp;
require Whatpm::HTML;
require Whatpm::NanoDOM;

sub test_files (@) {
  my @FILES = @_;

  require 't/testfiles.pl';
  execute_test ($_, {
    errors => {is_list => 1},
  }, \&test) for @FILES;
} # test_files

my $dom = Message::DOM::DOMImplementation->new;
sub test ($) {
  my $test = shift;

  $test->{parse_as} = 'xml';
  $test->{parse_as} = 'html'
      if $test->{data}->[1] and $test->{data}->[1]->[0] eq 'html';

  unless ($test->{data}) {
    warn "No #data field\n";
  } elsif (not $test->{errors}) {
    warn "No #errors field ($test->{data}->[0])\n";
  }

  my $doc;
  if ($test->{parse_as} eq 'xml') {
    open my $fh, '<', \($test->{data}->[0]);
    $doc = Message::DOM::XMLParserTemp->parse_byte_stream
      ($fh => $dom, sub {
        warn "Document: " . $test->{data}->[0];
      }, charset => 'utf-8');
    $doc->input_encoding (undef);
    ## NOTE: There should be no well-formedness error; if there is,
    ## then it is an error of the test case itself.
  } else {
    $doc = Whatpm::NanoDOM::Document->new;
    Whatpm::HTML->parse_char_string ($test->{data}->[0] => $doc);
  }

  my @error;
  Whatpm::ContentChecker->check_element
    ($doc->document_element, sub {
       my %opt = @_;
       if ($opt{type} =~ /^status:/ and $opt{level} eq 'i') {
         #
       } else {
         push @error, get_node_path ($opt{node}) . ';' . $opt{type} .
             (defined $opt{text} ? ';' . $opt{text} : '') .
             (defined $opt{level} ? ';'.$opt{level} : '');
       }
     }, sub {
       my $opt = shift;
       push @error, get_node_path ($opt->{container_node}) . ';SUBDOC';
     });
  
  ok join ("\n", sort {$a cmp $b} @error),
    join ("\n", sort {$a cmp $b} @{$test->{errors}->[0]}), $test->{data}->[0];
} # test

sub get_node_path ($) {
  my $node = shift;
  my @r;
  while (defined $node) {
    my $rs;
    if ($node->node_type == 1) {
      $rs = $node->manakai_local_name;
      $node = $node->parent_node;
    } elsif ($node->node_type == 2) {
      $rs = '@' . $node->manakai_local_name;
      $node = $node->owner_element;
    } elsif ($node->node_type == 3) {
      $rs = '"' . $node->data . '"';
      $node = $node->parent_node;
    } elsif ($node->node_type == 9) {
      $rs = '';
      $node = $node->parent_node;
    } else {
      $rs = '#' . $node->node_type;
      $node = $node->parent_node;
    }
    unshift @r, $rs;
  }
  return join '/', @r;
} # get_node_path

=head1 NAME

content-checker.pl - Test engine for document conformance checking

=head1 DESCRIPTION

The C<content-checker.pl> script implements a test engine for the
conformance checking modules, directly or indirectly referenced from
L<Whatpm::ContentChecker>.

This script is C<require>d by various test scripts, including
C<ContentCheker.t>, C<ContentChecker-Atom.t>, and C<LangTag.t>.

=head1 AUTHOR

Wakaba <w@suika.fam.cx>.

=head1 LICENSE

Public Domain.

=cut

1; ## $Date: 2008/09/18 05:49:13 $
1	wakaba	1.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	wakaba	1.3	require 't/testfiles.pl';
17			execute_test ($_, {
18			errors => {is_list => 1},
19			}, \&test) for @FILES;
20	wakaba	1.1	} # test_files
21
22			my $dom = Message::DOM::DOMImplementation->new;
23			sub test ($) {
24			my $test = shift;
25
26	wakaba	1.3	$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	wakaba	1.1	my $doc;
37			if ($test->{parse_as} eq 'xml') {
38	wakaba	1.3	open my $fh, '<', \($test->{data}->[0]);
39	wakaba	1.1	$doc = Message::DOM::XMLParserTemp->parse_byte_stream
40	wakaba	1.3	($fh => $dom, sub {
41			warn "Document: " . $test->{data}->[0];
42			}, charset => 'utf-8');
43	wakaba	1.1	$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	wakaba	1.3	Whatpm::HTML->parse_char_string ($test->{data}->[0] => $doc);
49	wakaba	1.1	}
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	wakaba	1.3	join ("\n", sort {$a cmp $b} @{$test->{errors}->[0]}), $test->{data}->[0];
69	wakaba	1.1	} # 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	wakaba	1.2	C<ContentCheker.t>, C<ContentChecker-Atom.t>, and C<LangTag.t>.
109	wakaba	1.1
110			=head1 AUTHOR
111
112			Wakaba <w@suika.fam.cx>.
113
114			=head1 LICENSE
115
116			Public Domain.
117
118			=cut
119
120	wakaba	1.3	1; ## $Date: 2008/09/18 05:49:13 $