whatpm/t/ContentChecker.t

#!/usr/bin/perl
use strict;

use Test;
BEGIN { plan tests => 2646 }

my @FILES = qw[
  t/content-model-1.dat
  t/content-model-2.dat
  t/content-model-3.dat
  t/content-model-4.dat
  t/content-model-5.dat
  t/content-model-6.dat
  t/content-model-7.dat
  t/table-1.dat
  t/content-model-atom-1.dat
  t/content-model-atom-2.dat
  t/content-model-atom-threading-1.dat
];

require Whatpm::ContentChecker;

## ISSUE: Currently we require manakai XML parser to test arbitrary XML tree.
use lib qw[/home/wakaba/work/manakai2/lib];
require Message::DOM::DOMImplementation;
require Message::DOM::XMLParserTemp;
require Whatpm::HTML;
require Whatpm::NanoDOM;

my $dom = Message::DOM::DOMImplementation->new;

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

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

## License: Public Domain.
## $Date: 2008/08/30 10:26:39 $
1	wakaba	1.1	#!/usr/bin/perl
2			use strict;
3
4			use Test;
5	wakaba	1.31	BEGIN { plan tests => 2646 }
6	wakaba	1.1
7	wakaba	1.5	my @FILES = qw[
8			t/content-model-1.dat
9			t/content-model-2.dat
10			t/content-model-3.dat
11	wakaba	1.13	t/content-model-4.dat
12	wakaba	1.24	t/content-model-5.dat
13	wakaba	1.29	t/content-model-6.dat
14	wakaba	1.32	t/content-model-7.dat
15	wakaba	1.15	t/table-1.dat
16	wakaba	1.19	t/content-model-atom-1.dat
17			t/content-model-atom-2.dat
18	wakaba	1.28	t/content-model-atom-threading-1.dat
19	wakaba	1.5	];
20	wakaba	1.1
21			require Whatpm::ContentChecker;
22
23			## ISSUE: Currently we require manakai XML parser to test arbitrary XML tree.
24	wakaba	1.23	use lib qw[/home/wakaba/work/manakai2/lib];
25	wakaba	1.12	require Message::DOM::DOMImplementation;
26			require Message::DOM::XMLParserTemp;
27	wakaba	1.4	require Whatpm::HTML;
28			require Whatpm::NanoDOM;
29	wakaba	1.1
30	wakaba	1.20	my $dom = Message::DOM::DOMImplementation->new;
31	wakaba	1.1
32			for my $file_name (@FILES) {
33			open my $file, '<', $file_name or die "$0: $file_name: $!";
34	wakaba	1.19	print "# $file_name\n";
35	wakaba	1.1
36			my $test;
37			my $mode = 'data';
38			while (<$file>) {
39			s/\x0D\x0A/\x0A/;
40			if (/^#data$/) {
41			undef $test;
42			$test->{data} = '';
43			$mode = 'data';
44	wakaba	1.4	$test->{parse_as} = 'xml';
45			} elsif (/^#data html$/) {
46			undef $test;
47			$test->{data} = '';
48			$mode = 'data';
49			$test->{parse_as} = 'html';
50	wakaba	1.1	} elsif (/^#errors$/) {
51			$test->{errors} = [];
52			$mode = 'errors';
53			$test->{data} =~ s/\x0D?\x0A\z//;
54			} elsif (defined $test->{errors} and /^$/) {
55			test ($test);
56			undef $test;
57			} else {
58			if ($mode eq 'data') {
59			$test->{$mode} .= $_;
60			} elsif ($mode eq 'errors') {
61			tr/\x0D\x0A//d;
62			push @{$test->{errors}}, $_;
63			}
64			}
65			}
66			} # @FILES
67
68			sub test ($) {
69			my $test = shift;
70
71	wakaba	1.4	my $doc;
72			if ($test->{parse_as} eq 'xml') {
73	wakaba	1.12	open my $fh, '<', \($test->{data});
74			$doc = Message::DOM::XMLParserTemp->parse_byte_stream
75			($fh => $dom, sub { }, charset => 'utf-8');
76	wakaba	1.23	$doc->input_encoding (undef);
77	wakaba	1.4	## NOTE: There should be no well-formedness error; if there is,
78			## then it is an error of the test case itself.
79			} else {
80			$doc = Whatpm::NanoDOM::Document->new;
81			Whatpm::HTML->parse_string ($test->{data} => $doc);
82			}
83	wakaba	1.1
84			my @error;
85	wakaba	1.10	Whatpm::ContentChecker->check_element
86	wakaba	1.1	($doc->document_element, sub {
87			my %opt = @_;
88	wakaba	1.26	if ($opt{type} =~ /^status:/ and $opt{level} eq 'i') {
89			#
90			} else {
91			push @error, get_node_path ($opt{node}) . ';' . $opt{type} .
92	wakaba	1.31	(defined $opt{text} ? ';' . $opt{text} : '') .
93	wakaba	1.26	(defined $opt{level} ? ';'.$opt{level} : '');
94			}
95	wakaba	1.25	}, sub {
96			my $opt = shift;
97	wakaba	1.27	push @error, get_node_path ($opt->{container_node}) . ';SUBDOC';
98	wakaba	1.1	});
99
100			ok join ("\n", sort {$a cmp $b} @error),
101			join ("\n", sort {$a cmp $b} @{$test->{errors}}), $test->{data};
102			} # test
103
104			sub get_node_path ($) {
105			my $node = shift;
106			my @r;
107			while (defined $node) {
108			my $rs;
109			if ($node->node_type == 1) {
110			$rs = $node->manakai_local_name;
111	wakaba	1.4	$node = $node->parent_node;
112	wakaba	1.3	} elsif ($node->node_type == 2) {
113			$rs = '@' . $node->manakai_local_name;
114	wakaba	1.4	$node = $node->owner_element;
115	wakaba	1.1	} elsif ($node->node_type == 3) {
116			$rs = '"' . $node->data . '"';
117	wakaba	1.4	$node = $node->parent_node;
118	wakaba	1.1	} elsif ($node->node_type == 9) {
119			$rs = '';
120	wakaba	1.4	$node = $node->parent_node;
121	wakaba	1.1	} else {
122			$rs = '#' . $node->node_type;
123	wakaba	1.4	$node = $node->parent_node;
124	wakaba	1.1	}
125			unshift @r, $rs;
126			}
127			return join '/', @r;
128			} # get_node_path
129
130			## License: Public Domain.
131	wakaba	1.32	## $Date: 2008/08/30 10:26:39 $