/[suikacvs]/markup/html/whatpm/t/ContentChecker.t
Suika

Diff of /markup/html/whatpm/t/ContentChecker.t

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.5 by wakaba, Sat May 19 14:29:09 2007 UTC revision 1.39 by wakaba, Fri Dec 12 05:05:20 2008 UTC
# Line 1  Line 1 
1  #!/usr/bin/perl  #!/usr/bin/perl
2  use strict;  use strict;
3    
4  use Test;  BEGIN {
5  BEGIN { plan tests => 34 }    require 't/content-checker.pl';
6      plan (tests => 4464);
7    }
8    
9  my @FILES = qw[  test_files (qw[
10    t/content-model-1.dat    t/content-model-1.dat
11    t/content-model-2.dat    t/content-model-7.dat
12    t/content-model-3.dat    t/table-1.dat
13  ];    t/dom-conformance/html-1.dat
14      t/dom-conformance/html-global-1.dat
15  require Whatpm::ContentChecker;    t/dom-conformance/html-dataset.dat
16      t/dom-conformance/html-metadata-1.dat
17  ## ISSUE: Currently we require manakai XML parser to test arbitrary XML tree.    t/dom-conformance/html-flows-1.dat
18  use lib qw[/home/wakaba/work/manakai/lib];    t/dom-conformance/html-texts-1.dat
19  require Message::DOM::DOMCore;    t/dom-conformance/html-links-1.dat
20  require Message::DOM::XMLParser;    t/dom-conformance/html-objects-1.dat
21  require Whatpm::HTML;    t/dom-conformance/html-tables-1.dat
22  require Whatpm::NanoDOM;    t/dom-conformance/html-forms-1.dat
23      t/dom-conformance/html-form-input-1.dat
24  my $dom = $Message::DOM::DOMImplementationRegistry->get_dom_implementation;    t/dom-conformance/html-form-label.dat
25  my $parser = $dom->create_ls_parser (1);    t/dom-conformance/html-form-datalist.dat
26      t/dom-conformance/html-form-textarea.dat
27  for my $file_name (@FILES) {    t/dom-conformance/html-interactive-1.dat
28    open my $file, '<', $file_name or die "$0: $file_name: $!";    t/dom-conformance/html-repetitions.dat
29      t/dom-conformance/html-datatemplate.dat
30    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  
31    
32  ## License: Public Domain.  ## License: Public Domain.
33  ## $Date$  ## $Date$
Legend:
Removed from v.1.5  
changed lines
  Added in v.1.39
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24