whatpm/t/ContentChecker.t

#!/usr/bin/perl
use strict;

use Test;
BEGIN { plan tests => 34 }

my @FILES = qw[t/content-model-1.dat t/content-model-2.dat];

require Whatpm::ContentChecker;

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

my $dom = $Message::DOM::DOMImplementationRegistry->get_dom_implementation;
my $parser = $dom->create_ls_parser (1);

for my $file_name (@FILES) {
  open my $file, '<', $file_name or die "$0: $file_name: $!";

  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') {
    $doc = $parser->parse ({string_data => $test->{data}});
    ## 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;
  my $cc = Whatpm::ContentChecker->new;
  $cc->check_element
    ($doc->document_element, sub {
       my %opt = @_;
       push @error, get_node_path ($opt{node}) . ';' . $opt{type};
     });
  
  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: 2007/05/19 03:49:58 $
1	wakaba	1.1	#!/usr/bin/perl
2			use strict;
3
4			use Test;
5			BEGIN { plan tests => 34 }
6
7	wakaba	1.3	my @FILES = qw[t/content-model-1.dat t/content-model-2.dat];
8	wakaba	1.1
9			require Whatpm::ContentChecker;
10
11			## ISSUE: Currently we require manakai XML parser to test arbitrary XML tree.
12			use lib qw[/home/wakaba/work/manakai/lib];
13			require Message::DOM::DOMCore;
14			require Message::DOM::XMLParser;
15	wakaba	1.4	require Whatpm::HTML;
16			require Whatpm::NanoDOM;
17	wakaba	1.1
18			my $dom = $Message::DOM::DOMImplementationRegistry->get_dom_implementation;
19			my $parser = $dom->create_ls_parser (1);
20
21			for my $file_name (@FILES) {
22			open my $file, '<', $file_name or die "$0: $file_name: $!";
23
24			my $test;
25			my $mode = 'data';
26			while (<$file>) {
27			s/\x0D\x0A/\x0A/;
28			if (/^#data$/) {
29			undef $test;
30			$test->{data} = '';
31			$mode = 'data';
32	wakaba	1.4	$test->{parse_as} = 'xml';
33			} elsif (/^#data html$/) {
34			undef $test;
35			$test->{data} = '';
36			$mode = 'data';
37			$test->{parse_as} = 'html';
38	wakaba	1.1	} elsif (/^#errors$/) {
39			$test->{errors} = [];
40			$mode = 'errors';
41			$test->{data} =~ s/\x0D?\x0A\z//;
42			} elsif (defined $test->{errors} and /^$/) {
43			test ($test);
44			undef $test;
45			} else {
46			if ($mode eq 'data') {
47			$test->{$mode} .= $_;
48			} elsif ($mode eq 'errors') {
49			tr/\x0D\x0A//d;
50			push @{$test->{errors}}, $_;
51			}
52			}
53			}
54			} # @FILES
55
56			sub test ($) {
57			my $test = shift;
58
59	wakaba	1.4	my $doc;
60			if ($test->{parse_as} eq 'xml') {
61			$doc = $parser->parse ({string_data => $test->{data}});
62			## NOTE: There should be no well-formedness error; if there is,
63			## then it is an error of the test case itself.
64			} else {
65			$doc = Whatpm::NanoDOM::Document->new;
66			Whatpm::HTML->parse_string ($test->{data} => $doc);
67			}
68	wakaba	1.1
69			my @error;
70			my $cc = Whatpm::ContentChecker->new;
71			$cc->check_element
72			($doc->document_element, sub {
73			my %opt = @_;
74			push @error, get_node_path ($opt{node}) . ';' . $opt{type};
75			});
76
77			ok join ("\n", sort {$a cmp $b} @error),
78			join ("\n", sort {$a cmp $b} @{$test->{errors}}), $test->{data};
79			} # test
80
81			sub get_node_path ($) {
82			my $node = shift;
83			my @r;
84			while (defined $node) {
85			my $rs;
86			if ($node->node_type == 1) {
87			$rs = $node->manakai_local_name;
88	wakaba	1.4	$node = $node->parent_node;
89	wakaba	1.3	} elsif ($node->node_type == 2) {
90			$rs = '@' . $node->manakai_local_name;
91	wakaba	1.4	$node = $node->owner_element;
92	wakaba	1.1	} elsif ($node->node_type == 3) {
93			$rs = '"' . $node->data . '"';
94	wakaba	1.4	$node = $node->parent_node;
95	wakaba	1.1	} elsif ($node->node_type == 9) {
96			$rs = '';
97	wakaba	1.4	$node = $node->parent_node;
98	wakaba	1.1	} else {
99			$rs = '#' . $node->node_type;
100	wakaba	1.4	$node = $node->parent_node;
101	wakaba	1.1	}
102			unshift @r, $rs;
103			}
104			return join '/', @r;
105			} # get_node_path
106
107			## License: Public Domain.
108	wakaba	1.4	## $Date: 2007/05/19 03:49:58 $