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 Whatpm::XML::Parser;
require Whatpm::HTML;
require Whatpm::NanoDOM;
require Message::URI::URIReference;
require Message::DOM::Atom::AtomElement;
*Whatpm::NanoDOM::Element::rel
    = \&Message::DOM::Atom::AtomElement::AtomLinkElement::rel;

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

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

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') {
    $doc = Whatpm::NanoDOM::Document->new;
    Whatpm::XML::Parser->parse_char_string ($test->{data}->[0] => $doc);
    ## 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);
  }
  $doc->document_uri (q<thismessage:/>);

  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/20 07:00:53 $
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	wakaba	1.4
8	wakaba	1.1	require Whatpm::ContentChecker;
9	wakaba	1.4	require Whatpm::XML::Parser;
10	wakaba	1.1	require Whatpm::HTML;
11			require Whatpm::NanoDOM;
12	wakaba	1.4	require Message::URI::URIReference;
13			require Message::DOM::Atom::AtomElement;
14			*Whatpm::NanoDOM::Element::rel
15			= \&Message::DOM::Atom::AtomElement::AtomLinkElement::rel;
16	wakaba	1.1
17			sub test_files (@) {
18			my @FILES = @_;
19
20	wakaba	1.3	require 't/testfiles.pl';
21			execute_test ($_, {
22			errors => {is_list => 1},
23			}, \&test) for @FILES;
24	wakaba	1.1	} # test_files
25
26			sub test ($) {
27			my $test = shift;
28
29	wakaba	1.3	$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	wakaba	1.1	my $doc;
40			if ($test->{parse_as} eq 'xml') {
41	wakaba	1.4	$doc = Whatpm::NanoDOM::Document->new;
42			Whatpm::XML::Parser->parse_char_string ($test->{data}->[0] => $doc);
43	wakaba	1.1	## 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	wakaba	1.3	Whatpm::HTML->parse_char_string ($test->{data}->[0] => $doc);
48	wakaba	1.1	}
49	wakaba	1.4	$doc->document_uri (q<thismessage:/>);
50	wakaba	1.1
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.4	1; ## $Date: 2008/09/20 07:00:53 $