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 = @_;

  for my $file_name (@FILES) {
    open my $file, '<', $file_name or die "$0: $file_name: $!";
    print "# $file_name\n";
    
    my $test;
    my $mode = 'data';
    while (<$file>) {
      s/\x0D\x0A/\x0A/;
      if (/^#data$/) {
        undef $test;
        $test->{data} = '';
        $mode = 'data';
        $test->{parse_as} = 'xml';
      } elsif (/^#data html$/) {
        undef $test;
        $test->{data} = '';
        $mode = 'data';
        $test->{parse_as} = 'html';
      } elsif (/^#errors$/) {
        $test->{errors} = [];
        $mode = 'errors';
        $test->{data} =~ s/\x0D?\x0A\z//;       
      } elsif (defined $test->{errors} and /^$/) {
        test ($test);
        undef $test;
      } else {
        if ($mode eq 'data') {
          $test->{$mode} .= $_;
        } elsif ($mode eq 'errors') {
          tr/\x0D\x0A//d;
          push @{$test->{errors}}, $_;
        }
      }
    }
  } # @FILES
} # test_files

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

  my $doc;
  if ($test->{parse_as} eq 'xml') {
    open my $fh, '<', \($test->{data});
    $doc = Message::DOM::XMLParserTemp->parse_byte_stream
      ($fh => $dom, sub { }, 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_string ($test->{data} => $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}}), $test->{data};
} # 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:31:46 $
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			for my $file_name (@FILES) {
17			open my $file, '<', $file_name or die "$0: $file_name: $!";
18			print "# $file_name\n";
19
20			my $test;
21			my $mode = 'data';
22			while (<$file>) {
23			s/\x0D\x0A/\x0A/;
24			if (/^#data$/) {
25			undef $test;
26			$test->{data} = '';
27			$mode = 'data';
28			$test->{parse_as} = 'xml';
29			} elsif (/^#data html$/) {
30			undef $test;
31			$test->{data} = '';
32			$mode = 'data';
33			$test->{parse_as} = 'html';
34			} elsif (/^#errors$/) {
35			$test->{errors} = [];
36			$mode = 'errors';
37			$test->{data} =~ s/\x0D?\x0A\z//;
38			} elsif (defined $test->{errors} and /^$/) {
39			test ($test);
40			undef $test;
41			} else {
42			if ($mode eq 'data') {
43			$test->{$mode} .= $_;
44			} elsif ($mode eq 'errors') {
45			tr/\x0D\x0A//d;
46			push @{$test->{errors}}, $_;
47			}
48			}
49			}
50			} # @FILES
51			} # test_files
52
53			my $dom = Message::DOM::DOMImplementation->new;
54			sub test ($) {
55			my $test = shift;
56
57			my $doc;
58			if ($test->{parse_as} eq 'xml') {
59			open my $fh, '<', \($test->{data});
60			$doc = Message::DOM::XMLParserTemp->parse_byte_stream
61			($fh => $dom, sub { }, charset => 'utf-8');
62			$doc->input_encoding (undef);
63			## NOTE: There should be no well-formedness error; if there is,
64			## then it is an error of the test case itself.
65			} else {
66			$doc = Whatpm::NanoDOM::Document->new;
67			Whatpm::HTML->parse_string ($test->{data} => $doc);
68			}
69
70			my @error;
71			Whatpm::ContentChecker->check_element
72			($doc->document_element, sub {
73			my %opt = @_;
74			if ($opt{type} =~ /^status:/ and $opt{level} eq 'i') {
75			#
76			} else {
77			push @error, get_node_path ($opt{node}) . ';' . $opt{type} .
78			(defined $opt{text} ? ';' . $opt{text} : '') .
79			(defined $opt{level} ? ';'.$opt{level} : '');
80			}
81			}, sub {
82			my $opt = shift;
83			push @error, get_node_path ($opt->{container_node}) . ';SUBDOC';
84			});
85
86			ok join ("\n", sort {$a cmp $b} @error),
87			join ("\n", sort {$a cmp $b} @{$test->{errors}}), $test->{data};
88			} # test
89
90			sub get_node_path ($) {
91			my $node = shift;
92			my @r;
93			while (defined $node) {
94			my $rs;
95			if ($node->node_type == 1) {
96			$rs = $node->manakai_local_name;
97			$node = $node->parent_node;
98			} elsif ($node->node_type == 2) {
99			$rs = '@' . $node->manakai_local_name;
100			$node = $node->owner_element;
101			} elsif ($node->node_type == 3) {
102			$rs = '"' . $node->data . '"';
103			$node = $node->parent_node;
104			} elsif ($node->node_type == 9) {
105			$rs = '';
106			$node = $node->parent_node;
107			} else {
108			$rs = '#' . $node->node_type;
109			$node = $node->parent_node;
110			}
111			unshift @r, $rs;
112			}
113			return join '/', @r;
114			} # get_node_path
115
116			=head1 NAME
117
118			content-checker.pl - Test engine for document conformance checking
119
120			=head1 DESCRIPTION
121
122			The C<content-checker.pl> script implements a test engine for the
123			conformance checking modules, directly or indirectly referenced from
124			L<Whatpm::ContentChecker>.
125
126			This script is C<require>d by various test scripts, including
127	wakaba	1.2	C<ContentCheker.t>, C<ContentChecker-Atom.t>, and C<LangTag.t>.
128	wakaba	1.1
129			=head1 AUTHOR
130
131			Wakaba <w@suika.fam.cx>.
132
133			=head1 LICENSE
134
135			Public Domain.
136
137			=cut
138
139	wakaba	1.2	1; ## $Date: 2008/09/18 05:31:46 $