whatpm/t/ContentChecker.t

#!/usr/bin/perl
use strict;

use Test;
BEGIN { plan tests => 34 }

my @FILES = qw[t/content-model-1.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;

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';
    } 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 Message::DOM::Element::ManakaiDOMElement::manakai_element_type_match {
    my ($self, $nsuri, $ln) = @_;
    if (defined $nsuri) {
      if (defined $self->namespace_uri and $self->namespace_uri eq $nsuri) {
        if ($self->manakai_local_name eq $ln) {
          return 1;
        } else {
          return 0;
        }
      } else {
        return 0;
      }
    } else {
      if (not defined $self->namespace_uri) {
        return $self->manakai_local_name eq $ln;
      } else {
        return 0;
      }
    }
}

sub test ($) {
  my $test = shift;

  my $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.

  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;
    } elsif ($node->node_type == 3) {
      $rs = '"' . $node->data . '"';
    } elsif ($node->node_type == 9) {
      $rs = '';
    } else {
      $rs = '#' . $node->node_type;
    }
    unshift @r, $rs;
    $node = $node->parent_node;
  }
  return join '/', @r;
} # get_node_path

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