/[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.6 by wakaba, Fri Dec 31 12:03:39 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    
# Line 8  use Message::Util::QName::Filter { Line 7  use Message::Util::QName::Filter {
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;
# Line 72  my $Condition = { Line 100  my $Condition = {
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) {
# Line 99  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 130  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 165  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      my $var = perl_var      my $var = perl_var
210                       local_name => $name,                       local_name => $name,
211                       scope => 'my',                       scope => 'my',
212                       type => '$';                       type => '$';
213      my $type = $node->getAttributeNS (undef, 'type');      my $type = $node->get_attribute_ns (undef, 'type');
214      $result .= perl_comment $type;      $result .= perl_comment $type;
215      if ($node->hasAttributeNS (undef, 'isNull') and      if ($node->has_attribute_ns (undef, 'isNull') and
216          $node->getAttributeNS (undef, 'isNull') eq 'true') {          $node->get_attribute_ns (undef, 'isNull') eq 'true') {
217        $result .= perl_statement perl_assign $var => 'undef';        $result .= perl_statement perl_assign $var => 'undef';
218      } elsif ($node->hasAttributeNS (undef, 'value')) {      } elsif ($node->has_attribute_ns (undef, 'value')) {
219        $result .= perl_statement        $result .= perl_statement
220                     perl_assign                     perl_assign
221                          $var                          $var
222                       => to_perl_value ($node->getAttributeNS (undef, 'value'));                       => to_perl_value ($node->get_attribute_ns (undef, 'value'));
223      } else {      } else {
224        if ($type eq 'List' or $type eq 'Collection') {        if ($type eq 'List' or $type eq 'Collection') {
225          my @member;          my @member;
226          my $children = $node->childNodes;          my $children = $node->child_nodes;
227          for (my $i = 0; $i < $children->length; $i++) {          for (my $i = 0; $i < $children->length; $i++) {
228            my $child = $children->item ($i);            my $child = $children->item ($i);
229            if ($child->nodeType == $child->ELEMENT_NODE) {            if ($child->node_type == $child->ELEMENT_NODE) {
230              if ($child->localName eq 'member') {              if ($child->local_name eq 'member') {
231                push @member, perl_code_literal                push @member, perl_code_literal
232                                (to_perl_value ($child->textContent));                                (to_perl_value ($child->text_content));
233              } else {              } else {
234                valid_err q<Unsupported element type>, node => $child;                valid_err q<Unsupported element type>, node => $child;
235              }              }
236            } elsif ($child->nodeType == $child->COMMENT_NODE) {            } elsif ($child->node_type == $child->COMMENT_NODE) {
237              $result .= perl_comment $child->data;              $result .= perl_comment $child->data;
238            }            }
239          }          }
# Line 220  sub node2code ($) { Line 243  sub node2code ($) {
243                         => perl_list \@member;                         => perl_list \@member;
244        } elsif ($type =~ /Monitor/) {        } elsif ($type =~ /Monitor/) {
245          valid_err qq<Type $type not supported>, node => $node;          valid_err qq<Type $type not supported>, node => $node;
246        } elsif ($node->hasChildNodes) {        } elsif ($node->has_child_nodes) {
247          valid_err q<Children not supported>, node => $node;          valid_err q<Children not supported>, node => $node;
248        } else {        } else {
249          $result .= perl_statement $var;          $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          my $if = $node->getAttributeNS (undef, 'interface');          my $if = $node->get_attribute_ns (undef, 'interface');
283          $param = $IFMethod->{$if}->{$ln};          $param = $IFMethod->{$if}->{$ln};
284          unless ($param) {          unless ($param) {
285              last M if $Attr->{$ln};
286            valid_err "Method $if.$ln not supported", node => $node;            valid_err "Method $if.$ln not supported", node => $node;
287          }          }
288          if ($if eq 'Element' and $ln eq 'getElementsByTagName' and          if ($if eq 'Element' and $ln eq 'getElementsByTagName' and
289              not $node->hasAttributeNS (undef, 'name') and              not $node->has_attribute_ns (undef, 'name') and
290              $node->hasAttributeNS (undef, 'tagname')) {              $node->has_attribute_ns (undef, 'tagname')) {
291            $node->setAttributeNS (undef, 'name'            $node->set_attribute_ns (undef, 'name'
292                                   => $node->getAttributeNS (undef, 'tagname'));                                   => $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        my $obj = perl_var (type => '$',        my $obj = perl_var (type => '$',
319                            local_name => $node->getAttributeNS (undef, 'obj'));                            local_name => $node->get_attribute_ns (undef, 'obj'));
320        my $if = $node->getAttributeNS (undef, 'interface');        my $if = $node->get_attribute_ns (undef, 'interface');
321        if (defined $if and $if eq 'DOMString') {        if (defined $if and $if eq 'DOMString') {
322          if ($ln eq 'length') {          if ($ln eq 'length') {
323            $result .= 'length '.$obj;            $result .= 'length '.$obj;
# Line 286  sub node2code ($) { Line 325  sub node2code ($) {
325            valid_err q<$if.$ln not supported>, node => $node;            valid_err q<$if.$ln not supported>, node => $node;
326          }          }
327        } else {        } else {
328          $result .= $obj.'->'.$ln;          $result .= $obj.'->'.$Attr->{$ln};
329        }        }
330        if ($node->hasAttributeNS (undef, 'var')) {        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 320  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') {    } elsif ($ln eq 'assertInstanceOf') {
369      my $obj = perl_code_literal      my $obj = perl_code_literal
370                  (to_perl_value ($node->getAttributeNS (undef, 'obj')));                  (to_perl_value ($node->get_attribute_ns (undef, 'obj')));
371      $result .= perl_statement 'assertInstanceOf ('.      $result .= perl_statement 'assertInstanceOf ('.
372                   perl_list                   perl_list
373                     ($node->getAttributeNS (undef, 'id'),                     ($node->get_attribute_ns (undef, 'id'),
374                      $node->getAttributeNS (undef, 'type'),                      $node->get_attribute_ns (undef, 'type'),
375                      $obj).                      $obj).
376                 ')';                 ')';
377      if ($node->hasChildNodes) {      if ($node->has_child_nodes) {
378        $result .= perl_if        $result .= perl_if
379                     'isInstanceOf ('.                     'isInstanceOf ('.
380                     perl_list                     perl_list
381                       ($node->getAttributeNS (undef, 'type'),                       ($node->get_attribute_ns (undef, 'type'),
382                        $obj) . ')',                        $obj) . ')',
383                     body2code ($node);                     body2code ($node);
384      }      }
385      $Status->{Number}++;      $Status->{Number}++;
386    } elsif ($ln eq 'assertSame') {    } elsif ($ln eq 'assertSame') {
387      my $expected = to_perl_value ($node->getAttributeNS (undef, 'expected'));      my $expected = to_perl_value ($node->get_attribute_ns (undef, 'expected'));
388      my $actual = to_perl_value ($node->getAttributeNS (undef, 'actual'));      my $actual = to_perl_value ($node->get_attribute_ns (undef, 'actual'));
389      $result .= perl_statement 'assertSame ('.      $result .= perl_statement 'assertSame ('.
390                   perl_list                   perl_list
391                     ($node->getAttributeNS (undef, 'id'),                     ($node->get_attribute_ns (undef, 'id'),
392                      $expected, $actual).                      $expected, $actual).
393                 ')';                 ')';
394      if ($node->hasChildNodes) {      if ($node->has_child_nodes) {
395        $result .= perl_if        $result .= perl_if
396                     'same ('.(perl_list $expected, $actual).')',                     'same ('.(perl_list $expected, $actual).')',
397                     body2code ($node);                     body2code ($node);
398      }      }
399      $Status->{Number}++;      $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                     body2code ($node);                     body2code ($node);
# Line 372  sub node2code ($) { Line 413  sub node2code ($) {
413      $Status->{Number}++;      $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      }      }
# Line 403  sub node2code ($) { Line 444  sub node2code ($) {
444    } elsif ($ln eq 'assertURIEquals') {    } elsif ($ln eq 'assertURIEquals') {
445      $result .= perl_statement 'assertURIEquals ('.      $result .= perl_statement 'assertURIEquals ('.
446                   perl_list                   perl_list
447                     ($node->getAttributeNS (undef, 'id'),                     ($node->get_attribute_ns (undef, 'id'),
448                      perl_code_literal                      perl_code_literal
449                        (to_perl_value ($node->getAttributeNS (undef, 'scheme'),                        (to_perl_value ($node->get_attribute_ns (undef, 'scheme'),
450                                        default => 'undef')),                                        default => 'undef')),
451                      perl_code_literal                      perl_code_literal
452                        (to_perl_value ($node->getAttributeNS (undef, 'path'),                        (to_perl_value ($node->get_attribute_ns (undef, 'path'),
453                                        default => 'undef')),                                        default => 'undef')),
454                      perl_code_literal                      perl_code_literal
455                        (to_perl_value ($node->getAttributeNS (undef, 'host'),                        (to_perl_value ($node->get_attribute_ns (undef, 'host'),
456                                        default => 'undef')),                                        default => 'undef')),
457                      perl_code_literal                      perl_code_literal
458                        (to_perl_value ($node->getAttributeNS (undef, 'file'),                        (to_perl_value ($node->get_attribute_ns (undef, 'file'),
459                                        default => 'undef')),                                        default => 'undef')),
460                      perl_code_literal                      perl_code_literal
461                        (to_perl_value ($node->getAttributeNS (undef, 'name'),                        (to_perl_value ($node->get_attribute_ns (undef, 'name'),
462                                        default => 'undef')),                                        default => 'undef')),
463                      perl_code_literal                      perl_code_literal
464                        (to_perl_value ($node->getAttributeNS (undef, 'query'),                        (to_perl_value ($node->get_attribute_ns (undef, 'query'),
465                                        default => 'undef')),                                        default => 'undef')),
466                      perl_code_literal                      perl_code_literal
467                        (to_perl_value ($node->getAttributeNS (undef, 'fragment'),                        (to_perl_value ($node->get_attribute_ns (undef, 'fragment'),
468                                        default => 'undef')),                                        default => 'undef')),
469                      perl_code_literal                      perl_code_literal
470                        (to_perl_value ($node->getAttributeNS (undef, 'isAbsolute'),                        (to_perl_value ($node->get_attribute_ns (undef, 'isAbsolute'),
471                                        default => 'undef')),                                        default => 'undef')),
472                      perl_code_literal                      perl_code_literal
473                        (to_perl_value ($node->getAttributeNS (undef, 'actual')))).                        (to_perl_value ($node->get_attribute_ns (undef, 'actual')))).
474                 ')';                 ')';
475      $Status->{Number}++;      $Status->{Number}++;
476    } elsif ($ln eq 'assertDOMException') {    } elsif ($ln eq 'assertDOMException') {
# Line 439  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') {    } elsif ($ln eq 'for-each') {
505      my $collection = $node->getAttributeNS (undef, 'collection');      my $collection = $node->get_attribute_ns (undef, 'collection');
506      my $collType = $Status->{var}->{$collection}->{type};      my $collType = $Status->{var}->{$collection}->{type};
507      my $coll = to_perl_value ($collection);      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 < '.      $result .= 'for (my $i = 0; $i < '.
517                 ({'Collection'=>1,'List'=>1}->{$collType}                 ({'Collection'=>1,'List'=>1}->{$collType}
518                    ? '@{'.$coll.'}' : $coll.'->length').                    ? '@{'.$coll.'}' : $coll.'->length').
519                 '; $i++) {'.                 '; $i++) {'.
520                     perl_statement (qq<plan_local ($assert)>).
521                   perl_statement                   perl_statement
522                     (perl_assign                     (perl_assign
523                         to_perl_value ($node->getAttributeNS (undef, 'member'))                         to_perl_value ($node->get_attribute_ns (undef, 'member'))
524                      => $coll . ({'Collection'=>1,'List'=>1}->{$collType}                      => $coll . ({'Collection'=>1,'List'=>1}->{$collType}
525                                    ? '->[$i]' : '->item ($i)')).                                    ? '->[$i]' : '->item ($i)')).
526                   body2code ($node).                   $code.
527                 '}';                 '}';
528    } elsif ($ln eq 'try') {    } elsif ($ln eq 'try') {
529      my $children = $node->childNodes;      my $children = $node->child_nodes;
530      my $true = '';      my $true = '';
531      my $false = '';      my $false = '';
532      for (my $i = 0; $i < $children->length; $i++) {      for (my $i = 0; $i < $children->length; $i++) {
533        my $child = $children->item ($i);        my $child = $children->item ($i);
534        if ($child->nodeType == $child->ELEMENT_NODE) {        if ($child->node_type == $child->ELEMENT_NODE) {
535          if ($child->localName eq 'catch') {          if ($child->local_name eq 'catch') {
536            valid_err q<Multiple 'catch'es found>, node => $child            valid_err q<Multiple 'catch'es found>, node => $child
537              if $false;              if $false;
538            my @case;            my @case;
539            my $children2 = $child->childNodes;            my $children2 = $child->child_nodes;
540            for (my $j = 0; $j < $children2->length; $j++) {            for (my $j = 0; $j < $children2->length; $j++) {
541              my $child2 = $children2->item ($j);              my $child2 = $children2->item ($j);
542              if ($child2->nodeType == $child2->ELEMENT_NODE) {              if ($child2->node_type == $child2->ELEMENT_NODE) {
543                if ($child2->localName eq 'ImplementationException') {                if ($child2->local_name eq 'ImplementationException') {
544                  valid_err q<Element type not supported>, node => $child2;                  valid_err q<Element type not supported>, node => $child2;
545                } else {                } else {
546                  push @case, '$err->{-type} eq '.                  push @case, '$err->{-type} eq '.
547                            perl_literal ($child2->getAttributeNS (undef, 'code'))                            perl_literal ($child2->get_attribute_ns (undef, 'code'))
548                              => body2code ($child2);                              => body2code ($child2);
549                }                }
550              } else {              } else {
# Line 511  sub node2code ($) { Line 561  sub node2code ($) {
561      }      }
562      $result = "try {      $result = "try {
563                   $true                   $true
564                 } catch Message::DOM::ManakaiDOMException with {                 } catch Message::DOM::DOMMain::ManakaiDOMException with {
565                   my \$err = shift;                   my \$err = shift;
566                   $false                   $false
567                 };";                 };";
568      $Status->{use}->{'Message::Util::Error'} = 1;      $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 = '';      my $false = '';
# Line 525  sub node2code ($) { Line 575  sub node2code ($) {
575      my $assert_false = 0;      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 $false;              if $false;
584            local $Status->{Number} = 0;            local $Status->{Number} = 0;
# Line 546  sub node2code ($) { Line 596  sub node2code ($) {
596      if ($assert_true == $assert_false) {      if ($assert_true == $assert_false) {
597        $Status->{Number} += $assert_true;        $Status->{Number} += $assert_true;
598      } elsif ($assert_true > $assert_false) {      } elsif ($assert_true > $assert_false) {
599        $false .= perl_statement ('is_ok ()') x ($assert_true - $assert_false);        $false .= perl_statement 'skip_n ('.
600                      perl_list ($assert_true - $assert_false,
601                                 msg => q<Conditional>).')';
602        $Status->{Number} += $assert_true;        $Status->{Number} += $assert_true;
603      } else {      } else {
604        $true .= perl_statement ('is_ok ()') x ($assert_false - $assert_true);        $true .= perl_statement 'skip_n ('.
605                      perl_list ($assert_false - $assert_true,
606                                 msg => q<Conditional>).')';
607        $Status->{Number} += $assert_false;        $Status->{Number} += $assert_false;
608      }      }
609      $result = perl_if      $result = perl_if
# Line 557  sub node2code ($) { Line 611  sub node2code ($) {
611                  $true,                  $true,
612                  $false ? $false : undef;                  $false ? $false : undef;
613    } elsif ($ln eq 'while') {    } elsif ($ln eq 'while') {
614      my $children = $node->childNodes;      my $children = $node->child_nodes;
615      my $condition;      my $condition;
616      my $true = '';      my $true = '';
617      my $assert = 0;      my $assert = 0;
# Line 565  sub node2code ($) { Line 619  sub node2code ($) {
619        local $Status->{Number} = 0;        local $Status->{Number} = 0;
620        for (my $i = 0; $i < $children->length; $i++) {        for (my $i = 0; $i < $children->length; $i++) {
621          my $child = $children->item ($i);          my $child = $children->item ($i);
622          if ($child->nodeType == $child->ELEMENT_NODE) {          if ($child->node_type == $child->ELEMENT_NODE) {
623            if (not $condition) {            if (not $condition) {
624              $condition = node2code ($child);              $condition = node2code ($child);
625            } else {            } else {
# Line 577  sub node2code ($) { Line 631  sub node2code ($) {
631        }        }
632        $assert = $Status->{Number};        $assert = $Status->{Number};
633      }      }
634      $Status->{Number} += $assert;      $Status->{Number_local} = 1;
635      $result .= "while ($condition) {      $result .= "while ($condition) {
636                      plan_local ($assert);
637                    $true                    $true
638                  }";                  }";
639    } elsif ($ln eq 'or') {    } elsif ($ln eq 'or') {
# Line 588  sub node2code ($) { Line 643  sub node2code ($) {
643    } elsif ($ln eq 'notNull' or $ln eq 'isNull') {    } 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';      $result = 'not ' . $result if $ln eq 'isNull';
648    } elsif ({less => 1, lessOrEquals => 1,    } elsif ({less => 1, lessOrEquals => 1,
649              greater => 1, greaterOrEquals => 1}->{$ln}) {              greater => 1, greaterOrEquals => 1}->{$ln}) {
650      $result .= to_perl_value ($node->getAttributeNS (undef, 'actual')).      $result .= to_perl_value ($node->get_attribute_ns (undef, 'actual')).
651                 {less => '<', lessOrEquals => '<=',                 {less => '<', lessOrEquals => '<=',
652                  greater => '>', greaterOrEquals => '>='}->{$ln}.                  greater => '>', greaterOrEquals => '>='}->{$ln}.
653                 to_perl_value ($node->getAttributeNS (undef, 'expected'));                 to_perl_value ($node->get_attribute_ns (undef, 'expected'));
654    } elsif ($ln eq 'equals' or $ln eq 'notEquals') {    } elsif ($ln eq 'equals' or $ln eq 'notEquals') {
655      my $case = $node->getAttributeNS (undef, 'ignoreCase');      my $case = $node->get_attribute_ns (undef, 'ignoreCase');
656      if ($case and $case eq 'auto') {      if ($case and $case eq 'auto') {
657        $result .= 'equalsAutoCase (' .        $result .= 'equalsAutoCase (' .
658                     perl_list                     perl_list
659                       ($node->getAttributeNS (undef, 'context') || 'element',                       ($node->get_attribute_ns (undef, 'context') || 'element',
660                        to_perl_value                        to_perl_value
661                          ($node->getAttributeNS (undef, 'expected')),                          ($node->get_attribute_ns (undef, 'expected')),
662                        to_perl_value                        to_perl_value
663                          ($node->getAttributeNS (undef, 'actual'))) . ')';                          ($node->get_attribute_ns (undef, 'actual'))) . ')';
664      } else {      } else {
665        my $expected = to_perl_value        my $expected = to_perl_value
666                          ($node->getAttributeNS (undef, 'expected'));                          ($node->get_attribute_ns (undef, 'expected'));
667        my $actual = to_perl_value        my $actual = to_perl_value
668                          ($node->getAttributeNS (undef, 'actual'));                          ($node->get_attribute_ns (undef, 'actual'));
669        if ($case eq 'true') {        if ($case eq 'true') {
670          $result = "(uc ($expected) eq uc ($actual))";          $result = "(uc ($expected) eq uc ($actual))";
671        } elsif ($node->hasAttributeNS (undef, 'bitmask')) {        } elsif ($node->has_attribute_ns (undef, 'bitmask')) {
672          my $bm = ' & ' . to_perl_value          my $bm = ' & ' . to_perl_value
673                            ($node->getAttributeNS (undef, 'bitmask'));                            ($node->get_attribute_ns (undef, 'bitmask'));
674          $result = "($expected$bm == $actual$bm)";          $result = "($expected$bm == $actual$bm)";
675        } else {        } else {
676          $result = "($expected eq $actual)";          $result = "($expected eq $actual)";
# Line 624  sub node2code ($) { Line 679  sub node2code ($) {
679      $result = "(not $result)" if $ln eq 'notEquals';      $result = "(not $result)" if $ln eq 'notEquals';
680    } elsif ($ln eq 'increment' or $ln eq 'decrement') {    } elsif ($ln eq 'increment' or $ln eq 'decrement') {
681      $result .= perl_statement      $result .= perl_statement
682                   to_perl_value ($node->getAttributeNS (undef, 'var')).                   to_perl_value ($node->get_attribute_ns (undef, 'var')).
683                   {increment => ' += ', decrement => ' -= '}->{$ln}.                   {increment => ' += ', decrement => ' -= '}->{$ln}.
684                   to_perl_value ($node->getAttributeNS (undef, 'value'));                   to_perl_value ($node->get_attribute_ns (undef, 'value'));
685    } elsif ({qw/plus 1 subtract 1 mult 1 divide 1/}->{$ln}) {    } elsif ({qw/plus 1 subtract 1 mult 1 divide 1/}->{$ln}) {
686      $result .= perl_statement      $result .= perl_statement
687                   (perl_assign                   (perl_assign
688                       to_perl_value ($node->getAttributeNS (undef, 'var'))                       to_perl_value ($node->get_attribute_ns (undef, 'var'))
689                    => to_perl_value ($node->getAttributeNS (undef, 'op1')).                    => to_perl_value ($node->get_attribute_ns (undef, 'op1')).
690                       {qw<plus + subtract - mult * divide />}->{$ln}.                       {qw<plus + subtract - mult * divide />}->{$ln}.
691                       to_perl_value ($node->getAttributeNS (undef, 'op2')));                       to_perl_value ($node->get_attribute_ns (undef, 'op2')));
692    } elsif ($ln eq 'append') {    } elsif ($ln eq 'append') {
693      $result .= perl_statement      $result .= perl_statement
694                   'push @{'.                   'push @{'.
695                      to_perl_value ($node->getAttributeNS (undef, 'collection')).                      to_perl_value ($node->get_attribute_ns (undef, 'collection')).
696                      '}, '.                      '}, '.
697                      to_perl_value ($node->getAttributeNS (undef, 'item'));                      to_perl_value ($node->get_attribute_ns (undef, 'item'));
698    } elsif ($ln eq 'instanceOf') {    } elsif ($ln eq 'instanceOf') {
699      $result .= 'isInstanceOf ('.      $result .= 'isInstanceOf ('.
700                 perl_list ($node->getAttributeNS (undef, 'type'),                 perl_list ($node->get_attribute_ns (undef, 'type'),
701                            perl_code_literal to_perl_value                            perl_code_literal to_perl_value
702                              ($node->getAttributeNS (undef, 'obj'))).                              ($node->get_attribute_ns (undef, 'obj'))).
703                 ')';                 ')';
704    } elsif ($ln eq 'assign') {    } elsif ($ln eq 'assign') {
705      $result .= perl_statement      $result .= perl_statement
706                   perl_assign                   perl_assign
707                        to_perl_value ($node->getAttributeNS (undef, 'var'))                        to_perl_value ($node->get_attribute_ns (undef, 'var'))
708                     => to_perl_value ($node->getAttributeNS (undef, 'value'));                     => to_perl_value ($node->get_attribute_ns (undef, 'value'));
709    } elsif ($ln eq 'fail') {    } elsif ($ln eq 'fail') {
710      $result .= perl_statement 'fail ('.      $result .= perl_statement 'fail ('.
711                   perl_literal ($node->getAttributeNS (undef, 'id')). ')';                   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 662  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> => ''});          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 768  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.6  
changed lines
  Added in v.1.9
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24