/[suikacvs]/markup/html/whatpm/t/HTML-tree.t
Suika

Diff of /markup/html/whatpm/t/HTML-tree.t

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

revision 1.1 by wakaba, Mon Apr 30 14:12:02 2007 UTC revision 1.42 by wakaba, Tue Oct 14 07:40:52 2008 UTC
# Line 1  Line 1 
1  #!/usr/bin/perl  #!/usr/bin/perl
2  use strict;  use strict;
3    
4  my $dir_name;  my $DEBUG = $ENV{DEBUG};
5  BEGIN {  
6    my $test_dir_name = 't/';  use lib qw[/home/wakaba/work/manakai2/lib];
7    $dir_name = 't/tree-construction/';  my $test_dir_name = 't/';
8    my $skip = "You don't have make command";  my $dir_name = 't/tree-construction/';
   eval q{  
          system ("cd $test_dir_name; make tree-construction-files") == 0 or die  
            unless -f $dir_name.'tests1.dat';  
          $skip = '';  
         };  
   if ($skip) {  
     print "1..1\n";  
     print "ok 1 # $skip\n";  
     exit;  
   }  
 }  
9    
10  use Test;  use Test;
11  BEGIN { plan tests => 67 }  BEGIN { plan tests => 4935 }
12    
13  use Data::Dumper;  use Data::Dumper;
14  $Data::Dumper::Useqq = 1;  $Data::Dumper::Useqq = 1;
# Line 29  sub Data::Dumper::qquote { Line 18  sub Data::Dumper::qquote {
18    return q<qq'> . $s . q<'>;    return q<qq'> . $s . q<'>;
19  } # Data::Dumper::qquote  } # Data::Dumper::qquote
20    
21  for my $file_name (qw[  if ($DEBUG) {
22                        tests1.dat    my $not_found = {%{$Whatpm::HTML::Debug::cp or {}}};
23                        tests2.dat    $Whatpm::HTML::Debug::cp_pass = sub {
24                        tests3.dat      my $id = shift;
25                        tests4.dat      delete $not_found->{$id};
26                       ]) {    };
27    open my $file, '<', $dir_name.$file_name  
28      or die "$0: $dir_name$file_name: $!";    END {
29        for my $id (sort {$a <=> $b || $a cmp $b} keys %$not_found) {
30    my $test;        print "# checkpoint $id is not reached\n";
   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 (/^#document$/) {  
       $test->{document} = '';  
       $mode = 'document';  
     } elsif (/^$/) {  
       test ($test) if $test->{errors};  
       undef $test;  
     } else {  
       if ($mode eq 'data' or $mode eq 'document') {  
         $test->{$mode} .= $_;  
       } elsif ($mode eq 'errors') {  
         tr/\x0D\x0A//d;  
         push @{$test->{errors}}, $_;  
       }  
31      }      }
32    }    }
   test ($test) if $test->{errors};  
33  }  }
34    
35  use What::HTML;  my @FILES = grep {$_} split /\s+/, qq[
36                          ${test_dir_name}tokenizer-test-2.dat
37                          ${test_dir_name}tokenizer-test-3.dat
38                          ${dir_name}tests1.dat
39                          ${dir_name}tests2.dat
40                          ${dir_name}tests3.dat
41                          ${dir_name}tests4.dat
42                          ${dir_name}tests5.dat
43                          ${dir_name}tests6.dat
44                          ${dir_name}tests7.dat
45                          ${dir_name}tests8.dat
46                          ${dir_name}tests9.dat
47                          ${dir_name}tests10.dat
48                          ${dir_name}tests11.dat
49                          ${dir_name}tests12.dat
50                          ${test_dir_name}tree-test-1.dat
51                          ${test_dir_name}tree-test-2.dat
52                          ${test_dir_name}tree-test-3.dat
53                          ${test_dir_name}tree-test-void.dat
54                          ${test_dir_name}tree-test-flow.dat
55                          ${test_dir_name}tree-test-phrasing.dat
56                          ${test_dir_name}tree-test-form.dat
57                          ${test_dir_name}tree-test-foreign.dat
58                         ];
59    
60    require 't/testfiles.pl';
61    execute_test ($_, {
62      errors => {is_list => 1},
63      shoulds => {is_list => 1},
64      document => {is_prefixed => 1},
65      'document-fragment' => {is_prefixed => 1},
66    }, \&test) for @FILES;
67    
68    use Whatpm::HTML;
69    use Whatpm::NanoDOM;
70    use Whatpm::Charset::UnicodeChecker;
71    
72  sub test ($) {  sub test ($) {
73    my $test = shift;    my $test = shift;
74    
75    my $s = $test->{data};    if ($test->{'document-fragment'}) {
76        if (@{$test->{'document-fragment'}->[1]}) {
77    my $p = What::HTML->new;        ## NOTE: Old format.
78    my $i = 0;        $test->{element} = $test->{'document-fragment'}->[1]->[0];
79    $p->{set_next_input_character} = sub {        $test->{document} ||= $test->{'document-fragment'};
80      my $self = shift;      } else {
81      $self->{next_input_character} = -1 and return if $i >= length $s;        ## NOTE: New format.
82      $self->{next_input_character} = ord substr $s, $i++, 1;        $test->{element} = $test->{'document-fragment'}->[0];
       
     if ($self->{next_input_character} == 0x000D) { # CR  
       if ($i >= length $s) {  
         #  
       } else {  
         my $next_char = ord substr $s, $i++, 1;  
         if ($next_char == 0x000A) { # LF  
           #  
         } else {  
           push @{$self->{char}}, $next_char;  
         }  
       }  
       $self->{next_input_character} = 0x000A; # LF # MUST  
     } elsif ($self->{next_input_character} > 0x10FFFF) {  
       $self->{next_input_character} = 0xFFFD; # REPLACEMENT CHARACTER # MUST  
     } elsif ($self->{next_input_character} == 0x0000) { # NULL  
       $self->{next_input_character} = 0xFFFD; # REPLACEMENT CHARACTER # MUST  
83      }      }
84    };    }
85      
86      my $doc = Whatpm::NanoDOM::Document->new;
87    my @errors;    my @errors;
88    $p->{parse_error} = sub {    my @shoulds;
     my $msg = shift;  
     push @errors, $msg;  
   };  
89        
90    $SIG{INT} = sub {    $SIG{INT} = sub {
91      print scalar serialize ($p->{document});      print scalar serialize ($doc);
92      exit;      exit;
93    };    };
94    
95      my $onerror = sub {
96        my %opt = @_;
97        if ($opt{level} eq 's') {
98          push @shoulds, join ':', $opt{line}, $opt{column}, $opt{type};
99        } else {
100          push @errors, join ':', $opt{line}, $opt{column}, $opt{type};
101        }
102      };
103    
104      my $chk = sub {
105        return Whatpm::Charset::UnicodeChecker->new_handle ($_[0], 'html5');
106      }; # $chk
107    
108      my $result;
109      unless (defined $test->{element}) {
110        Whatpm::HTML->parse_char_string
111            ($test->{data}->[0] => $doc, $onerror, $chk);
112        $result = serialize ($doc);
113      } else {
114        my $el = $doc->create_element_ns
115          ('http://www.w3.org/1999/xhtml', [undef, $test->{element}]);
116        Whatpm::HTML->set_inner_html ($el, $test->{data}->[0], $onerror, $chk);
117        $result = serialize ($el);
118      }
119        
120    $p->_initialize_tokenizer;    warn "No #errors section ($test->{data}->[0])" unless $test->{errors};
121    $p->_initialize_tree_constructor;      
122    $p->_construct_tree;    ok scalar @errors, scalar @{$test->{errors}->[0] or []},
123    $p->_terminate_tree_constructor;      'Parse error: ' . Data::Dumper::qquote ($test->{data}->[0]) . '; ' .
124        join (', ', @errors) . ';' . join (', ', @{$test->{errors}->[0] or []});
125    ok scalar @errors, scalar @{$test->{errors}},    ok scalar @shoulds, scalar @{$test->{shoulds}->[0] or []},
126      'Parse error: ' . $test->{data} . '; ' .      'SHOULD-level error: ' . Data::Dumper::qquote ($test->{data}->[0]) . '; ' .
127      join (', ', @errors) . ';' . join (', ', @{$test->{errors}});      join (', ', @shoulds) . ';' . join (', ', @{$test->{shoulds}->[0] or []});
128    
129    my $doc = $p->{document};    $test->{document}->[0] .= "\x0A" if length $test->{document}->[0];
130    my $doc_s = serialize ($doc);    ok $result, $test->{document}->[0],
131    ok $doc_s, $test->{document}, 'Document tree: ' . $test->{data};        'Document tree: ' . Data::Dumper::qquote ($test->{data}->[0]);
132  } # test  } # test
133    
134    ## NOTE: Spec: <http://wiki.whatwg.org/wiki/Parser_tests>.
135  sub serialize ($) {  sub serialize ($) {
136    my $node = shift;    my $node = shift;
137    my $r = '';    my $r = '';
138    
139      my $ns_id = {
140        q<http://www.w3.org/1999/xhtml> => 'html',
141        q<http://www.w3.org/2000/svg> => 'svg',
142        q<http://www.w3.org/1998/Math/MathML> => 'math',
143        q<http://www.w3.org/1999/xlink> => 'xlink',
144        q<http://www.w3.org/XML/1998/namespace> => 'xml',
145        q<http://www.w3.org/2002/xmlns/> => 'xmlns',
146      };
147    
148    my @node = map { [$_, ''] } @{$node->child_nodes};    my @node = map { [$_, ''] } @{$node->child_nodes};
149    while (@node) {    while (@node) {
150      my $child = shift @node;      my $child = shift @node;
151      my $nt = $child->[0]->node_type;      my $nt = $child->[0]->node_type;
152      if ($nt == $child->[0]->ELEMENT_NODE) {      if ($nt == $child->[0]->ELEMENT_NODE) {
153        $r .= '| ' . $child->[1] . '<' . $child->[0]->tag_name . ">\x0A"; ## ISSUE: case?        my $ns = $child->[0]->namespace_uri;
154          unless (defined $ns) {
155            $ns = '{} ';
156          } elsif ($ns eq q<http://www.w3.org/1999/xhtml>) {
157            $ns = '';
158          } elsif ($ns_id->{$ns}) {
159            $ns = $ns_id->{$ns} . ' ';
160          } else {
161            $ns = '{' . $ns . '} ';
162          }
163          $r .= $child->[1] . '<' . $ns . $child->[0]->manakai_local_name . ">\x0A";
164    
165        for my $attr (sort {$a->[1] cmp $b->[1]} map { [$_->name, $_->value] }        for my $attr (sort {$a->[0] cmp $b->[0]} map { [do {
166                          my $ns = $_->namespace_uri;
167                          unless (defined $ns) {
168                            $ns = '';
169                          } elsif ($ns_id->{$ns}) {
170                            $ns = $ns_id->{$ns} . ' ';
171                          } else {
172                            $ns = '{' . $ns . '} ';
173                          }
174                          $ns . $_->manakai_local_name;
175                        }, $_->value] }
176                      @{$child->[0]->attributes}) {                      @{$child->[0]->attributes}) {
177          $r .= '| ' . $child->[1] . '  ' . $attr->[0] . '="'; ## ISSUE: case?          $r .= $child->[1] . '  ' . $attr->[0] . '="'; ## ISSUE: case?
178          $r .= $attr->[1] . '"' . "\x0A";          $r .= $attr->[1] . '"' . "\x0A";
179        }        }
180                
181        unshift @node,        unshift @node,
182          map { [$_, $child->[1] . '  '] } @{$child->[0]->child_nodes};          map { [$_, $child->[1] . '  '] } @{$child->[0]->child_nodes};
183      } elsif ($nt == $child->[0]->TEXT_NODE) {      } elsif ($nt == $child->[0]->TEXT_NODE) {
184        $r .= '| ' . $child->[1] . '"' . $child->[0]->data . '"' . "\x0A";        $r .= $child->[1] . '"' . $child->[0]->data . '"' . "\x0A";
185      } elsif ($nt == $child->[0]->COMMENT_NODE) {      } elsif ($nt == $child->[0]->COMMENT_NODE) {
186        $r .= '| ' . $child->[1] . '<!-- ' . $child->[0]->data . " -->\x0A";        $r .= $child->[1] . '<!-- ' . $child->[0]->data . " -->\x0A";
187      } elsif ($nt == $child->[0]->DOCUMENT_TYPE_NODE) {      } elsif ($nt == $child->[0]->DOCUMENT_TYPE_NODE) {
188        $r .= '| ' . $child->[1] . '<!DOCTYPE ' . $child->[0]->name . ">\x0A";        $r .= $child->[1] . '<!DOCTYPE ' . $child->[0]->name;
189          my $pubid = $child->[0]->public_id;
190          my $sysid = $child->[0]->system_id;
191          if (length $pubid or length $sysid) {
192            $r .= ' "' . $pubid . '"';
193            $r .= ' "' . $sysid . '"';
194          }
195          $r .= ">\x0A";
196      } else {      } else {
197        $r .= '| ' . $child->[1] . $child->[0]->node_type . "\x0A"; # error        $r .= $child->[1] . $child->[0]->node_type . "\x0A"; # error
198      }      }
199    }    }
200        
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.42
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24