/[suikacvs]/messaging/manakai/bin/domtest2perl.pl
Suika

Diff of /messaging/manakai/bin/domtest2perl.pl

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

revision 1.4 by wakaba, Sat Oct 16 13:34:56 2004 UTC revision 1.9 by wakaba, Thu Oct 6 10:53:34 2005 UTC
# Line 1  Line 1 
1  #!/usr/bin/perl -w  #!/usr/bin/perl -w
 use lib q<../lib>;  
2  use strict;  use strict;
3  BEGIN { require 'manakai/genlib.pl' }  BEGIN { require 'manakai/genlib.pl' }
4    
5  use Message::Util::QName::General [qw/ExpandedURI/], {  use Message::Util::QName::Filter {
6    ManakaiDOMLS2003    ManakaiDOMLS2003 => q<http://suika.fam.cx/~wakaba/archive/2004/9/27/mdom-old-ls#>,
     => q<http://suika.fam.cx/~wakaba/archive/2004/9/27/mdom-old-ls#>,  
7  };  };
8  use Message::DOM::ManakaiDOMLS2003;  use Message::DOM::ManakaiDOMLS2003;
9  use Message::DOM::DOMLS qw/MODE_SYNCHRONOUS/;  use Message::DOM::DOMLS qw/MODE_SYNCHRONOUS/;
 use Getopt::Long;  
10    
11  require 'dommemlist.pl.tmp'; ## Generated by mkdommemlist.pl  require 'dommemlist.pl.tmp'; ## Generated by mkdommemlist.pl
12    
13  my $output_filename;  use Getopt::Long;
14  my $output_file;  use Pod::Usage;
15    my %Opt = ();
16  GetOptions (  GetOptions (
17    'output-file=s' => \$output_filename,    'debug' => \$Opt{debug},
18  );    'help' => \$Opt{help},
19  if (defined $output_filename) {    'output-file-name=s' => \$Opt{output_file_name},
20    open $output_file, '>', $output_filename or die "$0: $output_filename: $!";    'verbose!' => \$Opt{verbose},
21  } else {  ) or pod2usage (2);
22    $output_file = \*STDOUT;  pod2usage ({-exitval => 0, -verbose => 1}) if $Opt{help};
23    $Opt{file_name} = shift;
24    pod2usage ({-exitval => 2, -verbose => 0}) unless $Opt{file_name};
25    $Message::DOM::DOMFeature::DEBUG = 1 if $Opt{debug};
26    
27    sub status_msg ($) {
28      my $s = shift;
29      $s .= "\n" unless $s =~ /\n$/;
30      print STDERR $s;
31    }
32    
33    sub status_msg_ ($) {
34      my $s = shift;
35      print STDERR $s;
36    }
37    
38    sub verbose_msg ($) {
39      my $s = shift;
40      $s .= "\n" unless $s =~ /\n$/;
41      print STDERR $s if $Opt{verbose};
42  }  }
43    
44    sub verbose_msg_ ($) {
45      my $s = shift;
46      print STDERR $s if $Opt{verbose};
47    }
48    
49    my $start_time;
50    BEGIN { $start_time = time }
51    
52    
53    
54  our $Method;  our $Method;
55  our $IFMethod;  our $IFMethod;
56  our $Attr;  our $Attr;
57  my $Assert = {  my $Assert = {
58    qw/assertDOMException 1    qw/assertDOMException 1
59         assertEquals 1
60       assertFalse 1       assertFalse 1
61         assertInstanceOf 1
62       assertNotNull 1       assertNotNull 1
63       assertNull 1       assertNull 1
64         assertSame 1
65       assertSize 1       assertSize 1
66       assertTrue 1/       assertTrue 1
67         assertURIEquals 1/
68  };  };
69  my $Misc = {  my $Misc = {
70    qw/if 1    qw/append 1
71         assign 1
72         decrement 1
73         fail 1
74         if 1
75       implementationAttribute 1       implementationAttribute 1
76       var 1/       increment 1
77         for 1
78         plus 1
79         var 1
80         while 1/
81  };  };
82  my $Condition = {  my $Condition = {
83    qw/condition 1    qw/condition 1
84       contains 1       contains 1
85       contentType 1       contentType 1
86         equals 1
87         greater 1
88         greaterOrEquals 1
89       hasSize 1       hasSize 1
90       implementationAttribute 1       implementationAttribute 1
91         instanceOf 1
92         isNull 1
93         less 1
94         lessOrEquals 1
95       not 1       not 1
96         notEquals 1
97       notNull 1       notNull 1
98       or 1/       or 1/
99  };  };
100    
101  my $Status = {Number => 0, our => {Info => 1}};  my $Status = {Number => 0, our => {Info => 1}};
102    
 ## Defined in genlib.pl but redefined.  
 sub output_result ($) {  
   print $output_file shift;  
 }  
   
103  sub to_perl_value ($;%) {  sub to_perl_value ($;%) {
104    my ($s, %opt) = @_;    my ($s, %opt) = @_;
105    if (defined $s) {    if (defined $s) {
106      if ($s =~ /^(?!\d)\w+$/) {      if ($s =~ /^(?!\d)\w+$/) {
107        return perl_var (type => '$', local_name => $s);        if ({true => 1, false => 1}->{$s}) {
108            return {true => '1', false => '0'}->{$s};
109          } else {
110            return perl_var (type => '$', local_name => $s);
111          }
112      } else {      } else {
113        return $s;        return $s;
114      }      }
# Line 76  sub to_perl_value ($;%) { Line 122  sub to_perl_value ($;%) {
122  sub body2code ($) {  sub body2code ($) {
123    my $parent = shift;    my $parent = shift;
124    my $result = '';    my $result = '';
125    my $children = $parent->childNodes;    my $children = $parent->child_nodes;
126    for (my $i = 0; $i < $children->length; $i++) {    for (my $i = 0; $i < $children->length; $i++) {
127      my $child = $children->item ($i);      my $child = $children->item ($i);
128      if ($child->nodeType == $child->ELEMENT_NODE) {      if ($child->node_type == $child->ELEMENT_NODE) {
129        my $ln = $child->localName;        my $ln = $child->local_name;
130        if ($Method->{$ln} or $Attr->{$ln} or        if ($Method->{$ln} or $Attr->{$ln} or
131            $Assert->{$ln} or $Misc->{$ln}) {            $Assert->{$ln} or $Misc->{$ln}) {
132          $result .= node2code ($child);          $result .= node2code ($child);
133        } else {        } else {
134          valid_err q<Unknown element type: >.$child->localName,          valid_err q<Unknown element type: >.$child->local_name,
135            node => $child;            node => $child;
136        }        }
137      } elsif ($child->nodeType == $child->COMMENT_NODE) {      } elsif ($child->node_type == $child->COMMENT_NODE) {
138        $result .= perl_comment $child->data;        $result .= perl_comment $child->data;
139      } elsif ($child->nodeType == $child->TEXT_NODE) {      } elsif ($child->node_type == $child->TEXT_NODE) {
140        if ($child->data =~ /\S/) {        if ($child->data =~ /\S/) {
141          valid_err q<Unknown character data: >.$child->data,          valid_err q<Unknown character data: >.$child->data,
142            node => $child;            node => $child;
143        }        }
144      } else {      } else {
145        valid_err q<Unknown type of node: >.$child->nodeType,        valid_err q<Unknown type of node: >.$child->node_type,
146          node => $child;          node => $child;
147      }      }
148    }    }
# Line 107  sub condition2code ($;%) { Line 153  sub condition2code ($;%) {
153    my ($parent, %opt) = @_;    my ($parent, %opt) = @_;
154    my $result = '';    my $result = '';
155    my @result;    my @result;
156    my $children = $parent->childNodes;    my $children = $parent->child_nodes;
157    for (my $i = 0; $i < $children->length; $i++) {    for (my $i = 0; $i < $children->length; $i++) {
158      my $child = $children->item ($i);      my $child = $children->item ($i);
159      if ($child->nodeType == $child->ELEMENT_NODE) {      if ($child->node_type == $child->ELEMENT_NODE) {
160        my $ln = $child->localName;        my $ln = $child->local_name;
161        if ($Condition->{$ln}) {        if ($Condition->{$ln}) {
162          push @result, node2code ($child);          push @result, node2code ($child);
163        } else {        } else {
164          valid_err q<Unknown element type: >.$child->localName,          valid_err q<Unknown element type: >.$child->local_name,
165            node => $child;            node => $child;
166        }        }
167      } elsif ($child->nodeType == $child->COMMENT_NODE) {      } elsif ($child->node_type == $child->COMMENT_NODE) {
168        $result .= perl_comment $child->data;        $result .= perl_comment $child->data;
169      } elsif ($child->nodeType == $child->TEXT_NODE) {      } elsif ($child->node_type == $child->TEXT_NODE) {
170        if ($child->data =~ /\S/) {        if ($child->data =~ /\S/) {
171          valid_err q<Unknown character data: >.$child->data,          valid_err q<Unknown character data: >.$child->data,
172            node => $child;            node => $child;
173        }        }
174      } else {      } else {
175        valid_err q<Unknown type of node: >.$child->nodeType,        valid_err q<Unknown type of node: >.$child->node_type,
176          node => $child;          node => $child;
177      }      }
178    }    }
# Line 142  sub node2code ($); Line 188  sub node2code ($);
188  sub node2code ($) {  sub node2code ($) {
189    my $node = shift;    my $node = shift;
190    my $result = '';    my $result = '';
191    if ($node->nodeType != $node->ELEMENT_NODE) {    if ($node->node_type != $node->ELEMENT_NODE) {
192      if ($node->nodeType == $node->COMMENT_NODE) {      if ($node->node_type == $node->COMMENT_NODE) {
193        $result .= perl_comment $node->data;        $result .= perl_comment $node->data;
194      } elsif ($node->nodeType == $node->TEXT_NODE) {      } elsif ($node->node_type == $node->TEXT_NODE) {
195        if ($node->data =~ /\S/) {        if ($node->data =~ /\S/) {
196          valid_err q<Unknown character data: >.$node->data,          valid_err q<Unknown character data: >.$node->data,
197            node => $node;            node => $node;
198        }        }
199      } else {      } else {
200        valid_err q<Unknown type of node: >.$node->nodeType,        valid_err q<Unknown type of node: >.$node->node_type,
201          node => $node;          node => $node;
202      }      }
203      return $result;      return $result;
204    }    }
205    my $ln = $node->localName;    my $ln = $node->local_name;
206    
207    if ($ln eq 'var') {    if ($ln eq 'var') {
208      my $name = $node->getAttributeNS (undef, 'name');      my $name = $node->get_attribute_ns (undef, 'name');
209      $result .= perl_statement      my $var = perl_var
                    perl_var  
210                       local_name => $name,                       local_name => $name,
211                       scope => 'my',                       scope => 'my',
212                       type => '$';                       type => '$';
213      if ($node->getAttributeNS (undef, 'value')) {      my $type = $node->get_attribute_ns (undef, 'type');
214        valid_err q<Attribute "value" not supported>, node => $node;      $result .= perl_comment $type;
215        if ($node->has_attribute_ns (undef, 'isNull') and
216            $node->get_attribute_ns (undef, 'isNull') eq 'true') {
217          $result .= perl_statement perl_assign $var => 'undef';
218        } elsif ($node->has_attribute_ns (undef, 'value')) {
219          $result .= perl_statement
220                       perl_assign
221                            $var
222                         => to_perl_value ($node->get_attribute_ns (undef, 'value'));
223        } else {
224          if ($type eq 'List' or $type eq 'Collection') {
225            my @member;
226            my $children = $node->child_nodes;
227            for (my $i = 0; $i < $children->length; $i++) {
228              my $child = $children->item ($i);
229              if ($child->node_type == $child->ELEMENT_NODE) {
230                if ($child->local_name eq 'member') {
231                  push @member, perl_code_literal
232                                  (to_perl_value ($child->text_content));
233                } else {
234                  valid_err q<Unsupported element type>, node => $child;
235                }
236              } elsif ($child->node_type == $child->COMMENT_NODE) {
237                $result .= perl_comment $child->data;
238              }
239            }
240            $result .= perl_statement
241                         perl_assign
242                              $var
243                           => perl_list \@member;
244          } elsif ($type =~ /Monitor/) {
245            valid_err qq<Type $type not supported>, node => $node;
246          } elsif ($node->has_child_nodes) {
247            valid_err q<Children not supported>, node => $node;
248          } else {
249            $result .= perl_statement $var;
250          }
251      }      }
252      $Status->{var}->{$name}->{type} = $node->getAttributeNS (undef, 'type');      $Status->{var}->{$name}->{type} = $node->get_attribute_ns (undef, 'type');
253    } elsif ($ln eq 'load') {    } elsif ($ln eq 'load') {
254        $result .= perl_statement        $result .= perl_statement
255                     perl_assign                     perl_assign
256                       perl_var                       perl_var
257                         (type => '$',                         (type => '$',
258                          local_name => $node->getAttributeNS (undef, 'var'))                          local_name => $node->get_attribute_ns (undef, 'var'))
259                     => 'load (' .                     => 'load (' .
260                        perl_literal ($node->getAttributeNS (undef, 'href')).                        perl_literal ($node->get_attribute_ns (undef, 'href')).
261                        ')';                        ')';
262      } elsif ($Method->{$ln}) {    } elsif ($ln eq 'hasFeature' and
263               not $node->has_attribute_ns (undef, 'var')) {
264        ## If there is a "hasFeature" element in "body" and
265        ## it does not have "var" attribute, then it is part of the
266        ## implementation condition.
267        $result .= perl_statement 'hasFeature ('.
268                           to_perl_value ($node->get_attribute_ns (undef, 'feature'),
269                                          default => 'undef') . ', '.
270                           to_perl_value ($node->get_attribute_ns (undef, 'version'),
271                                          default => 'undef') . ')';
272      } elsif ($Method->{$ln} or $Attr->{$ln}) {
273      MA: {
274        M: {
275          last M unless $Method->{$ln};
276        $result .= perl_var (type => '$',        $result .= perl_var (type => '$',
277                             local_name => $node->getAttributeNS (undef, 'var')).                             local_name => $node->get_attribute_ns (undef, 'var')).
278                   ' = '                   ' = '
279          if $node->hasAttributeNS (undef, 'var');          if $node->has_attribute_ns (undef, 'var');
280        my $param;        my $param;
281        if ($node->hasAttributeNS (undef, 'interface')) {        if ($node->has_attribute_ns (undef, 'interface')) {
282          $param = $IFMethod->{$node->getAttributeNS (undef, 'interface')}          my $if = $node->get_attribute_ns (undef, 'interface');
283                            ->{$ln};          $param = $IFMethod->{$if}->{$ln};
284            unless ($param) {
285              last M if $Attr->{$ln};
286              valid_err "Method $if.$ln not supported", node => $node;
287            }
288            if ($if eq 'Element' and $ln eq 'getElementsByTagName' and
289                not $node->has_attribute_ns (undef, 'name') and
290                $node->has_attribute_ns (undef, 'tagname')) {
291              $node->set_attribute_ns (undef, 'name'
292                                     => $node->get_attribute_ns (undef, 'tagname'));
293            }
294        } else {        } else {
295          $param = $Method->{$ln};          $param = $Method->{$ln};
296        }        }
297        $result .= perl_var (type => '$',        $result .= perl_var (type => '$',
298                             local_name => $node->getAttributeNS (undef, 'obj')).                             local_name => $node->get_attribute_ns (undef, 'obj')).
299                '->'.$ln.' ('.                '->'.$param->[0].' ('.
300                  join (', ',                  join (', ',
301                       map {                       map {
302                         to_perl_value ($node->getAttributeNS (undef, $_),                         to_perl_value ($node->get_attribute_ns (undef, $_),
303                                        default => 'undef')                                        default => 'undef')
304                       } @$param).                       } @$param[1..$#$param]).
305                ");\n";                ");\n";
306      } elsif ($Attr->{$ln}) {        last MA;
307        if ($node->hasAttributeNS (undef, 'var')) {      } # M
308        A: {
309          if ($node->has_attribute_ns (undef, 'var')) {
310          $result .= perl_var (type => '$',          $result .= perl_var (type => '$',
311                               local_name => $node->getAttributeNS (undef, 'var')).                               local_name => $node->get_attribute_ns (undef, 'var')).
312                     ' = ';                     ' = ';
313        } elsif ($node->hasAttributeNS (undef, 'value')) {        } elsif ($node->has_attribute_ns (undef, 'value')) {
314          #          #
315        } else {        } else {
316          valid_err q<Unknown operation to an attribute>, node => $node;          valid_err q<Unknown operation to an attribute>, node => $node;
317        }        }
318        $result .= perl_var (type => '$',        my $obj = perl_var (type => '$',
319                             local_name => $node->getAttributeNS (undef, 'obj')).                            local_name => $node->get_attribute_ns (undef, 'obj'));
320                '->'.$ln;        my $if = $node->get_attribute_ns (undef, 'interface');
321        if ($node->hasAttributeNS (undef, 'var')) {        if (defined $if and $if eq 'DOMString') {
322            if ($ln eq 'length') {
323              $result .= 'length '.$obj;
324            } else {
325              valid_err q<$if.$ln not supported>, node => $node;
326            }
327          } else {
328            $result .= $obj.'->'.$Attr->{$ln};
329          }
330          if ($node->has_attribute_ns (undef, 'var')) {
331          $result .= ";\n";          $result .= ";\n";
332        } elsif ($node->hasAttributeNS (undef, 'value')) {        } elsif ($node->has_attribute_ns (undef, 'value')) {
333          $result .= " (".to_perl_value ($node->getAttributeNS (undef, 'value')).          $result .= " (".to_perl_value ($node->get_attribute_ns (undef, 'value')).
334                     ");\n";                     ");\n";
335        }        }
336          } # A
337        } # MA
338      } elsif ($ln eq 'assertEquals') {      } elsif ($ln eq 'assertEquals') {
339        my $expected = $node->getAttributeNS (undef, 'expected');        my $expected = $node->get_attribute_ns (undef, 'expected');
340        my $expectedType = $Status->{var}->{$expected}->{type} || '';        my $expectedType = $Status->{var}->{$expected}->{type} || '';
341        $result .= 'assertEquals'.        $result .= 'assertEquals'.
342                   ({Collection => 'Collection',                   ({Collection => 'Collection',
343                     List => 'List'}->{$expectedType}||'');                     List => 'List'}->{$expectedType}||'');
344        my $ignoreCase = $node->getAttributeNS (undef, 'ignoreCase') || 'false';        my $ignoreCase = $node->get_attribute_ns (undef, 'ignoreCase') || 'false';
345        if ($ignoreCase eq 'auto') {        if ($ignoreCase eq 'auto') {
346          $result .= 'AutoCase ('.          $result .= 'AutoCase ('.
347                     perl_literal ($node->getAttributeNS (undef, 'context') ||                     perl_literal ($node->get_attribute_ns (undef, 'context') ||
348                                   'element').                                   'element').
349                     ', ';                     ', ';
350        } else {        } else {
351          $result .= ' (';          $result .= ' (';
352        }        }
353        $result .= perl_literal ($node->getAttributeNS (undef, 'id')).', ';        $result .= perl_literal ($node->get_attribute_ns (undef, 'id')).', ';
354        $result .= join ", ", map {        $result .= join ", ", map {
355                     $ignoreCase eq 'true'                     $ignoreCase eq 'true'
356                       ? ($expectedType eq 'Collection' or                       ? ($expectedType eq 'Collection' or
# Line 244  sub node2code ($) { Line 361  sub node2code ($) {
361                     to_perl_value ($_)                     to_perl_value ($_)
362                   } (                   } (
363                     $expected,                     $expected,
364                     $node->getAttributeNS (undef, 'actual'),                     $node->get_attribute_ns (undef, 'actual'),
365                   );                   );
366        $result .= ");\n";        $result .= ");\n";
367      $Status->{Number}++;      $Status->{Number}++;
368      } elsif ($ln eq 'assertInstanceOf') {
369        my $obj = perl_code_literal
370                    (to_perl_value ($node->get_attribute_ns (undef, 'obj')));
371        $result .= perl_statement 'assertInstanceOf ('.
372                     perl_list
373                       ($node->get_attribute_ns (undef, 'id'),
374                        $node->get_attribute_ns (undef, 'type'),
375                        $obj).
376                   ')';
377        if ($node->has_child_nodes) {
378          $result .= perl_if
379                       'isInstanceOf ('.
380                       perl_list
381                         ($node->get_attribute_ns (undef, 'type'),
382                          $obj) . ')',
383                       body2code ($node);
384        }
385        $Status->{Number}++;
386      } elsif ($ln eq 'assertSame') {
387        my $expected = to_perl_value ($node->get_attribute_ns (undef, 'expected'));
388        my $actual = to_perl_value ($node->get_attribute_ns (undef, 'actual'));
389        $result .= perl_statement 'assertSame ('.
390                     perl_list
391                       ($node->get_attribute_ns (undef, 'id'),
392                        $expected, $actual).
393                   ')';
394        if ($node->has_child_nodes) {
395          $result .= perl_if
396                       'same ('.(perl_list $expected, $actual).')',
397                       body2code ($node);
398        }
399        $Status->{Number}++;
400    } elsif ($ln eq 'assertSize') {    } elsif ($ln eq 'assertSize') {
401      my $size = to_perl_value ($node->getAttributeNS (undef, 'size'));      my $size = to_perl_value ($node->get_attribute_ns (undef, 'size'));
402      my $coll = to_perl_value ($node->getAttributeNS (undef, 'collection'));      my $coll = to_perl_value ($node->get_attribute_ns (undef, 'collection'));
403      $result .= perl_statement 'assertSize ('.      $result .= perl_statement 'assertSize ('.
404                   perl_list                   perl_list
405                     ($node->getAttributeNS (undef, 'id'),                     ($node->get_attribute_ns (undef, 'id'),
406                      perl_code_literal $size, perl_code_literal $coll).                      perl_code_literal $size, perl_code_literal $coll).
407                 ')';                 ')';
408      if ($node->hasChildNodes) {      if ($node->has_child_nodes) {
409        $result .= perl_if        $result .= perl_if
410                     qq<$size == size ($coll)>,                     qq<$size == size ($coll)>,
411                     block2code ($node);                     body2code ($node);
412      }      }
413        $Status->{Number}++;
414    } elsif ($ln eq 'assertTrue' or $ln eq 'assertFalse') {    } elsif ($ln eq 'assertTrue' or $ln eq 'assertFalse') {
415        my $condition;        my $condition;
416        if ($node->hasAttributeNS (undef, 'actual')) {        if ($node->has_attribute_ns (undef, 'actual')) {
417          $condition = perl_var (type => '$',          $condition = perl_var (type => '$',
418                                 local_name => $node->getAttributeNS                                 local_name => $node->get_attribute_ns
419                                                         (undef, 'actual'));                                                         (undef, 'actual'));
420          if ($node->hasChildNodes) {          if ($node->has_child_nodes) {
421            valid_err q<Child of $ln found but not supported>,            valid_err q<Child of $ln found but not supported>,
422              node => $node;              node => $node;
423          }          }
424        } elsif ($node->hasChildNodes) {        } elsif ($node->has_child_nodes) {
425          $condition = condition2code ($node);          $condition = condition2code ($node);
426        } else {        } else {
427        valid_err $ln.q< w/o @actual not supported>, node => $node;        valid_err $ln.q< w/o @actual not supported>, node => $node;
428        }        }
429        $result .= perl_statement $ln . ' ('.        $result .= perl_statement $ln . ' ('.
430                       perl_literal ($node->getAttributeNS (undef, 'id')).', '.                       perl_literal ($node->get_attribute_ns (undef, 'id')).', '.
431                       $condition. ')';                       $condition. ')';
432      $Status->{Number}++;      $Status->{Number}++;
433      } elsif ($ln eq 'assertNotNull' or $ln eq 'assertNull') {    } elsif ($ln eq 'assertNotNull' or $ln eq 'assertNull') {
434        $result .= perl_statement $ln . ' (' .      $result .= perl_statement $ln . ' (' .
435                   perl_literal ($node->getAttributeNS (undef, 'id')).', '.                   perl_literal ($node->get_attribute_ns (undef, 'id')).', '.
436                   perl_var (type => '$',                   perl_var (type => '$',
437                             local_name => $node->getAttributeNS (undef, 'actual')).                             local_name => $node->get_attribute_ns (undef, 'actual')).
438                   ')';                   ')';
439        if ($node->hasChildNodes) {      if ($node->has_child_nodes) {
440          valid_err q<Child of $ln found but not supported>,        valid_err q<Child of $ln found but not supported>,
441            node => $node;            node => $node;
442        }      }
443        $Status->{Number}++;
444      } elsif ($ln eq 'assertURIEquals') {
445        $result .= perl_statement 'assertURIEquals ('.
446                     perl_list
447                       ($node->get_attribute_ns (undef, 'id'),
448                        perl_code_literal
449                          (to_perl_value ($node->get_attribute_ns (undef, 'scheme'),
450                                          default => 'undef')),
451                        perl_code_literal
452                          (to_perl_value ($node->get_attribute_ns (undef, 'path'),
453                                          default => 'undef')),
454                        perl_code_literal
455                          (to_perl_value ($node->get_attribute_ns (undef, 'host'),
456                                          default => 'undef')),
457                        perl_code_literal
458                          (to_perl_value ($node->get_attribute_ns (undef, 'file'),
459                                          default => 'undef')),
460                        perl_code_literal
461                          (to_perl_value ($node->get_attribute_ns (undef, 'name'),
462                                          default => 'undef')),
463                        perl_code_literal
464                          (to_perl_value ($node->get_attribute_ns (undef, 'query'),
465                                          default => 'undef')),
466                        perl_code_literal
467                          (to_perl_value ($node->get_attribute_ns (undef, 'fragment'),
468                                          default => 'undef')),
469                        perl_code_literal
470                          (to_perl_value ($node->get_attribute_ns (undef, 'isAbsolute'),
471                                          default => 'undef')),
472                        perl_code_literal
473                          (to_perl_value ($node->get_attribute_ns (undef, 'actual')))).
474                   ')';
475      $Status->{Number}++;      $Status->{Number}++;
476    } elsif ($ln eq 'assertDOMException') {    } elsif ($ln eq 'assertDOMException') {
477      $Status->{use}->{'Message::Util::Error'} = 1;      $Status->{use}->{'Message::Util::Error'} = 1;
# Line 298  sub node2code ($) { Line 480  sub node2code ($) {
480          my $success = 0;          my $success = 0;
481          try {          try {
482      ];      ];
483      my $children = $node->childNodes;      my $children = $node->child_nodes;
484      my $errname;      my $errname;
485      for (my $i = 0; $i < $children->length; $i++) {      for (my $i = 0; $i < $children->length; $i++) {
486        my $child = $children->item ($i);        my $child = $children->item ($i);
487        $errname = $child->localName if $child->nodeType == $child->ELEMENT_NODE;        $errname = $child->local_name if $child->node_type == $child->ELEMENT_NODE;
488        $result .= body2code ($child);        $result .= body2code ($child);
489      }      }
490      $result .= q[      $result .= q[
491          } catch Message::DOM::DOMException with {          } catch Message::DOM::IF::DOMException with {
492            my $err = shift;            my $err = shift;
493            $success = 1 if $err->{-type} eq ].perl_literal ($errname).q[;            $success = 1 if $err->{-type} eq ].perl_literal ($errname).q[;
494          }          };
495          assertTrue (].perl_literal ($node->getAttributeNS (undef, 'id')).          assertTrue (].perl_literal ($node->get_attribute_ns (undef, 'id')).
496          q[, $success);          q[, $success);
497        }        }
498      ];      ];
499      $Status->{Number}++;      $Status->{Number}++;
500    } elsif ($ln eq 'contentType') {    } elsif ($ln eq 'contentType') {
501      $result .= '$builder->{contentType} eq '.      $result .= '$builder->{contentType} eq '.
502                 perl_literal ($node->getAttributeNS (undef, 'type'));                 perl_literal ($node->get_attribute_ns (undef, 'type'));
503      $Status->{our}->{builder} = 1;      $Status->{our}->{builder} = 1;
504      } elsif ($ln eq 'for-each') {
505        my $collection = $node->get_attribute_ns (undef, 'collection');
506        my $collType = $Status->{var}->{$collection}->{type};
507        my $coll = to_perl_value ($collection);
508        my $assert;
509        my $code;
510        {
511          local $Status->{Number} = 0;
512          $code = body2code ($node);
513          $assert = $Status->{Number};
514        }
515        $Status->{Number_local} = 1;
516        $result .= 'for (my $i = 0; $i < '.
517                   ({'Collection'=>1,'List'=>1}->{$collType}
518                      ? '@{'.$coll.'}' : $coll.'->length').
519                   '; $i++) {'.
520                     perl_statement (qq<plan_local ($assert)>).
521                     perl_statement
522                       (perl_assign
523                           to_perl_value ($node->get_attribute_ns (undef, 'member'))
524                        => $coll . ({'Collection'=>1,'List'=>1}->{$collType}
525                                      ? '->[$i]' : '->item ($i)')).
526                     $code.
527                   '}';
528      } elsif ($ln eq 'try') {
529        my $children = $node->child_nodes;
530        my $true = '';
531        my $false = '';
532        for (my $i = 0; $i < $children->length; $i++) {
533          my $child = $children->item ($i);
534          if ($child->node_type == $child->ELEMENT_NODE) {
535            if ($child->local_name eq 'catch') {
536              valid_err q<Multiple 'catch'es found>, node => $child
537                if $false;
538              my @case;
539              my $children2 = $child->child_nodes;
540              for (my $j = 0; $j < $children2->length; $j++) {
541                my $child2 = $children2->item ($j);
542                if ($child2->node_type == $child2->ELEMENT_NODE) {
543                  if ($child2->local_name eq 'ImplementationException') {
544                    valid_err q<Element type not supported>, node => $child2;
545                  } else {
546                    push @case, '$err->{-type} eq '.
547                              perl_literal ($child2->get_attribute_ns (undef, 'code'))
548                                => body2code ($child2);
549                  }
550                } else {
551                  $false .= node2code ($child2);
552                }
553              }
554              $false .= perl_cases @case, else => perl_statement '$err->throw';
555            } else {
556              $true .= node2code ($child);
557            }
558          } else {
559            $true .= node2code ($child);
560          }
561        }
562        $result = "try {
563                     $true
564                   } catch Message::DOM::DOMMain::ManakaiDOMException with {
565                     my \$err = shift;
566                     $false
567                   };";
568        $Status->{use}->{'Message::Util::Error'} = 1;
569    } elsif ($ln eq 'if') {    } elsif ($ln eq 'if') {
570      my $children = $node->childNodes;      my $children = $node->child_nodes;
571      my $condition;      my $condition;
572      my $true = '';      my $true = '';
573        my $false = '';
574        my $assert_true = 0;
575        my $assert_false = 0;
576      for (my $i = 0; $i < $children->length; $i++) {      for (my $i = 0; $i < $children->length; $i++) {
577        my $child = $children->item ($i);        my $child = $children->item ($i);
578        if ($child->nodeType == $child->ELEMENT_NODE) {        if ($child->node_type == $child->ELEMENT_NODE) {
579          if (not $condition) {          if (not $condition) {
580            $condition = node2code ($child);            $condition = node2code ($child);
581          } elsif ($child->localName eq 'else') {          } elsif ($child->local_name eq 'else') {
582            valid_err q<Multiple 'else's found>, node => $child            valid_err q<Multiple 'else's found>, node => $child
583              if $true;              if $false;
584            $true = $result;            local $Status->{Number} = 0;
585            $result = '';            $false = body2code ($child);
586              $assert_false = $Status->{Number};
587          } else {          } else {
588            $result .= node2code ($child);            local $Status->{Number} = 0;
589              $true .= node2code ($child);
590              $assert_true += $Status->{Number};
591          }          }
592        } else {        } else {
593          $result .= node2code ($child);          $true .= node2code ($child);
594        }        }
595      }      }
596        if ($assert_true == $assert_false) {
597          $Status->{Number} += $assert_true;
598        } elsif ($assert_true > $assert_false) {
599          $false .= perl_statement 'skip_n ('.
600                      perl_list ($assert_true - $assert_false,
601                                 msg => q<Conditional>).')';
602          $Status->{Number} += $assert_true;
603        } else {
604          $true .= perl_statement 'skip_n ('.
605                      perl_list ($assert_false - $assert_true,
606                                 msg => q<Conditional>).')';
607          $Status->{Number} += $assert_false;
608        }
609      $result = perl_if      $result = perl_if
610                  $condition,                  $condition,
611                  $true || $result,                  $true,
612                  $true ? $result : undef;                  $false ? $false : undef;
613      } elsif ($ln eq 'while') {
614        my $children = $node->child_nodes;
615        my $condition;
616        my $true = '';
617        my $assert = 0;
618        {
619          local $Status->{Number} = 0;
620          for (my $i = 0; $i < $children->length; $i++) {
621            my $child = $children->item ($i);
622            if ($child->node_type == $child->ELEMENT_NODE) {
623              if (not $condition) {
624                $condition = node2code ($child);
625              } else {
626                $true .= node2code ($child);
627              }
628            } else {
629              $true .= node2code ($child);
630            }
631          }
632          $assert = $Status->{Number};
633        }
634        $Status->{Number_local} = 1;
635        $result .= "while ($condition) {
636                      plan_local ($assert);
637                      $true
638                    }";
639    } elsif ($ln eq 'or') {    } elsif ($ln eq 'or') {
640      $result .= condition2code ($node, join => 'or');      $result .= condition2code ($node, join => 'or');
641    } elsif ($ln eq 'not') {    } elsif ($ln eq 'not') {
642      $result .= 'not '.condition2code ($node, join => 'nosupport');      $result .= 'not '.condition2code ($node, join => 'nosupport');
643    } elsif ($ln eq 'notNull') {    } elsif ($ln eq 'notNull' or $ln eq 'isNull') {
644      $result .= 'defined '.      $result .= 'defined '.
645                 perl_var (type => '$',                 perl_var (type => '$',
646                           local_name => $node->getAttributeNS (undef, 'obj'));                           local_name => $node->get_attribute_ns (undef, 'obj'));
647        $result = 'not ' . $result if $ln eq 'isNull';
648      } elsif ({less => 1, lessOrEquals => 1,
649                greater => 1, greaterOrEquals => 1}->{$ln}) {
650        $result .= to_perl_value ($node->get_attribute_ns (undef, 'actual')).
651                   {less => '<', lessOrEquals => '<=',
652                    greater => '>', greaterOrEquals => '>='}->{$ln}.
653                   to_perl_value ($node->get_attribute_ns (undef, 'expected'));
654      } elsif ($ln eq 'equals' or $ln eq 'notEquals') {
655        my $case = $node->get_attribute_ns (undef, 'ignoreCase');
656        if ($case and $case eq 'auto') {
657          $result .= 'equalsAutoCase (' .
658                       perl_list
659                         ($node->get_attribute_ns (undef, 'context') || 'element',
660                          to_perl_value
661                            ($node->get_attribute_ns (undef, 'expected')),
662                          to_perl_value
663                            ($node->get_attribute_ns (undef, 'actual'))) . ')';
664        } else {
665          my $expected = to_perl_value
666                            ($node->get_attribute_ns (undef, 'expected'));
667          my $actual = to_perl_value
668                            ($node->get_attribute_ns (undef, 'actual'));
669          if ($case eq 'true') {
670            $result = "(uc ($expected) eq uc ($actual))";
671          } elsif ($node->has_attribute_ns (undef, 'bitmask')) {
672            my $bm = ' & ' . to_perl_value
673                              ($node->get_attribute_ns (undef, 'bitmask'));
674            $result = "($expected$bm == $actual$bm)";
675          } else {
676            $result = "($expected eq $actual)";
677          }
678        }
679        $result = "(not $result)" if $ln eq 'notEquals';
680      } elsif ($ln eq 'increment' or $ln eq 'decrement') {
681        $result .= perl_statement
682                     to_perl_value ($node->get_attribute_ns (undef, 'var')).
683                     {increment => ' += ', decrement => ' -= '}->{$ln}.
684                     to_perl_value ($node->get_attribute_ns (undef, 'value'));
685      } elsif ({qw/plus 1 subtract 1 mult 1 divide 1/}->{$ln}) {
686        $result .= perl_statement
687                     (perl_assign
688                         to_perl_value ($node->get_attribute_ns (undef, 'var'))
689                      => to_perl_value ($node->get_attribute_ns (undef, 'op1')).
690                         {qw<plus + subtract - mult * divide />}->{$ln}.
691                         to_perl_value ($node->get_attribute_ns (undef, 'op2')));
692      } elsif ($ln eq 'append') {
693        $result .= perl_statement
694                     'push @{'.
695                        to_perl_value ($node->get_attribute_ns (undef, 'collection')).
696                        '}, '.
697                        to_perl_value ($node->get_attribute_ns (undef, 'item'));
698      } elsif ($ln eq 'instanceOf') {
699        $result .= 'isInstanceOf ('.
700                   perl_list ($node->get_attribute_ns (undef, 'type'),
701                              perl_code_literal to_perl_value
702                                ($node->get_attribute_ns (undef, 'obj'))).
703                   ')';
704      } elsif ($ln eq 'assign') {
705        $result .= perl_statement
706                     perl_assign
707                          to_perl_value ($node->get_attribute_ns (undef, 'var'))
708                       => to_perl_value ($node->get_attribute_ns (undef, 'value'));
709      } elsif ($ln eq 'fail') {
710        $result .= perl_statement 'fail ('.
711                     perl_literal ($node->get_attribute_ns (undef, 'id')). ')';
712    } else {    } else {
713      valid_err q<Unknown element type: >.$ln;      valid_err q<Unknown element type: >.$ln;
714    }    }
# Line 360  sub node2code ($) { Line 717  sub node2code ($) {
717    
718  our $result = '';  our $result = '';
719    
720  my $input;  my $input = '';
721  {  {
722    local $/ = undef;    open my $in, '<', $Opt{file_name} or die "$0: $Opt{file_name}: $!";
723    $input = <>;    while (<$in>) {
724        $input .= $_;
725      }
726  }  }
727    
728  {  {
729  my $dom = Message::DOM::DOMImplementationRegistry    my $dom = $Message::DOM::ImplementationRegistry
730              ->getDOMImplementation      ->get_implementation
731                   ({Core => undef,        ({Core => undef,
732                     XML => undef,          XML => undef,
733                     ExpandedURI q<ManakaiDOMLS2003:LS> => '1.0'});          ExpandedURI q<ManakaiDOMLS2003:LS> => ''});
734    
735  my $parser = $dom->createLSParser (MODE_SYNCHRONOUS);    my $parser = $dom->create_ls_parser (MODE_SYNCHRONOUS);
736  my $in = $dom->createLSInput;    my $in = $dom->create_ls_input;
737  $in->stringData ($input);    $in->string_data ($input);
738      
739  my $src = $parser->parse ($in)->documentElement;    status_msg_ q<Parsing XML entity...>;
740      my $src = $parser->parse ($in)->document_element;
741  {    status_msg q<done>;
742  my $children = $src->ownerDocument->childNodes;    
743  for (my $i = 0; $i < $children->length; $i++) {    status_msg_ q<Generating test script...>;
744    my $node = $children->item ($i);    {
745    if ($node->nodeType == $node->COMMENT_NODE) {      my $children = $src->owner_document->child_nodes;
746      if ($node->data =~ /Copyright/) {      for (my $i = 0; $i < $children->length; $i++) {
747        $result .= perl_comment        my $node = $children->item ($i);
748                     qq<This script was generated by "$0"\n>.        if ($node->node_type == $node->COMMENT_NODE) {
749                     qq<and is a derived work from the source document.\n>.          if ($node->data =~ /Copyright/) {
750                     qq<The source document contained the following notice:\n>.            $result .= perl_comment
751                     $node->data;                         qq<This script was generated by "$0"\n>.
752      } else {                         qq<and is a derived work from the source document\n>.
753        $result .= perl_comment $node->data;                         qq<"$Opt{file_name}".\n>.
754                           qq<The source document contained the following notice:\n>.
755                           $node->data;
756            } else {
757              $result .= perl_comment $node->data;
758            }
759          }
760      }      }
761    }    }
762  }    
763  }    my $child = $src->child_nodes;
   
 my $child = $src->childNodes;  
764    
765  for (my $i = 0; $i < $child->length; $i++) {  for (my $i = 0; $i < $child->length; $i++) {
766    my $node = $child->item ($i);    my $node = $child->item ($i);
767    if ($node->nodeType == $node->ELEMENT_NODE) {    if ($node->node_type == $node->ELEMENT_NODE) {
768      my $ln = $node->localName;      my $ln = $node->local_name;
769      if ($ln eq 'metadata') {      if ($ln eq 'metadata') {
770        my $md = $node->childNodes;        my $md = $node->child_nodes;
771        for (my $j = 0; $j < $md->length; $j++) {        for (my $j = 0; $j < $md->length; $j++) {
772          my $node = $md->item ($j);          my $node = $md->item ($j);
773          if ($node->nodeType == $node->ELEMENT_NODE) {          if ($node->node_type == $node->ELEMENT_NODE) {
774            my $ln = $node->localName;            my $ln = $node->local_name;
775            if ($ln eq 'title') {            if ($ln eq 'title') {
776              $result .= perl_statement              $result .= perl_statement
777                           perl_assign                           perl_assign
778                             '$Info->{Name}'                             '$Info->{Name}'
779                           => perl_literal $node->textContent;                           => perl_literal $node->text_content;
780            } elsif ($ln eq 'description') {            } elsif ($ln eq 'description') {
781              $result .= perl_statement              $result .= perl_statement
782                           perl_assign                           perl_assign
783                             '$Info->{Description}'                             '$Info->{Description}'
784                           => perl_literal $node->textContent;                           => perl_literal $node->text_content;
785            } else {            } else {
786            #  valid_err q<Unknown element type: >.$ln,            #  valid_err q<Unknown element type: >.$ln,
787            #    node => $node;            #    node => $node;
788            }            }
789          } elsif ($node->nodeType == $node->TEXT_NODE) {          } elsif ($node->node_type == $node->TEXT_NODE) {
790            if ($node->data =~ /\S/) {            if ($node->data =~ /\S/) {
791              valid_err q<Unknown character data: >.$node->data,              valid_err q<Unknown character data: >.$node->data,
792                node => $node;                node => $node;
793            }            }
794          } elsif ($node->nodeType == $node->COMMENT_NODE) {          } elsif ($node->node_type == $node->COMMENT_NODE) {
795            $result .= perl_comment $node->data;            $result .= perl_comment $node->data;
796          } else {          } else {
797            valid_err q<Unknown node type: >.$node->nodeType,            valid_err q<Unknown node type: >.$node->node_type,
798              node => $node;              node => $node;
799          }          }
800        }        }
801      } elsif ($ln eq 'implementationAttribute') {      } elsif ($ln eq 'implementationAttribute') {
802        $result .= perl_comment        $result .= perl_statement 'impl_attr ('.
803                       sprintf 'Implementation attribute: @name=%s, @value=%s',                           perl_list
804                               $node->getAttributeNS (undef, 'name'),                               ($node->get_attribute_ns (undef, 'name'),
805                               $node->getAttributeNS (undef, 'value');                                $node->get_attribute_ns (undef, 'value')).')';
806      } else {      } else {
807        $result .= node2code ($node);        $result .= node2code ($node);
808      }      }
809    } elsif ($node->nodeType == $node->COMMENT_NODE) {    } elsif ($node->node_type == $node->COMMENT_NODE) {
810      $result .= perl_comment $node->data;      $result .= perl_comment $node->data;
811    } elsif ($node->nodeType == $node->TEXT_NODE) {    } elsif ($node->node_type == $node->TEXT_NODE) {
812      if ($node->data =~ /\S/) {      if ($node->data =~ /\S/) {
813        valid_err q<Unknown character data: >.$node->data,        valid_err q<Unknown character data: >.$node->data,
814          node => $node;          node => $node;
815      }      }
816    } else {    } else {
817      valid_err q<Unknown type of node: >.$node->nodeType,      valid_err q<Unknown type of node: >.$node->node_type,
818        node => $node;        node => $node;
819    }    }
820  }  }
# Line 466  for (keys %{$Status->{our}}) { Line 829  for (keys %{$Status->{our}}) {
829    $pre .= perl_statement perl_var type => '$', local_name => $_,    $pre .= perl_statement perl_var type => '$', local_name => $_,
830                                    scope => 'our';                                    scope => 'our';
831  }  }
832  $pre .= perl_statement q<plan (>.(0+$Status->{Number}).q<)>;  my $plan = $Status->{Number_local} ? 'plan_local' : 'plan';
833    $pre .= perl_statement qq<$plan (>.(0+$Status->{Number}).q<)>;
834    
835    $result .= perl_statement q<end_of_test ()>;
836    status_msg q<done>;
837    
838    {
839      my $output;
840      my $out_file_path = $Opt{output_file_name};
841      defined $out_file_path
842        ? (open $output, '>', $out_file_path or die "$0: $out_file_path: $!")
843        : ($output = \*STDOUT);
844    
845      status_msg_ sprintf qq<Writing Perl script %s...>,
846                          defined $out_file_path
847                            ? q<">.$out_file_path.q<">
848                            : 'to stdout';
849      print $output $pre.$result;
850      close $output;
851      status_msg q<done>;
852    }
853    
854    1;
855    
856    __END__
857    
858    =head1 NAME
859    
860    domtest2perl - DOM Test Suite XML Test File to Perl Test Code Converter
861    
862    =head1 SYNOPSIS
863    
864      perl path/to/domtest2perl.pl input.xml > output.pl
865      perl path/to/domtest2perl.pl input.xml --output-file=output.pl
866    
867    =over 4
868    
869    =item I<input.xml>
870    
871    The name of file to input.  It should be an XML document
872    in the DOM Test Suite.
873    
874    =item I<output.pl>
875    
876    The name of file to output.  It is overwritten if already exists.
877    
878    =back
879    
880    =head1 SEE ALSO
881    
882    I<Document Object Model (DOM) Conformance Test Suites>,
883    <http://www.w3.org/DOM/Test/>.
884    
885    F<domts2perl.pl>
886    
887    F<mkdommemlist.pl>
888    
889    =head1 LICENSE
890    
891    Copyright 2004-2005 Wakaba <w@suika.fam.cx>.  All rights reserved.
892    
893    This program is free software; you can redistribute it and/or
894    modify it under the same terms as Perl itself.
895    
896  output_result $pre.$result;  =cut
897    
Legend:
Removed from v.1.4  
changed lines
  Added in v.1.9
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24