/[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.2 by wakaba, Sun Oct 10 00:01:08 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/;
10    
11  my $Method = {  require 'dommemlist.pl.tmp'; ## Generated by mkdommemlist.pl
12    qw/createEntityReference 1  
13       createTextNode 1  use Getopt::Long;
14       getAttributeNode 1  use Pod::Usage;
15       getElementsByTagName 1  my %Opt = ();
16       getNamedItem 1  GetOptions (
17       removeChild 1    'debug' => \$Opt{debug},
18       replaceChild 1/    'help' => \$Opt{help},
19  };    'output-file-name=s' => \$Opt{output_file_name},
20  my $Attr = {    'verbose!' => \$Opt{verbose},
21    qw/attributes 1  ) or pod2usage (2);
22       firstChild 1  pod2usage ({-exitval => 0, -verbose => 1}) if $Opt{help};
23       item 1  $Opt{file_name} = shift;
24       nodeName 1  pod2usage ({-exitval => 2, -verbose => 0}) unless $Opt{file_name};
25       specified 1/  $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;
55    our $IFMethod;
56    our $Attr;
57  my $Assert = {  my $Assert = {
58    qw/assertDOMException 1    qw/assertDOMException 1
59         assertEquals 1
60         assertFalse 1
61         assertInstanceOf 1
62       assertNotNull 1       assertNotNull 1
63       assertTrue 1/       assertNull 1
64         assertSame 1
65         assertSize 1
66         assertTrue 1
67         assertURIEquals 1/
68  };  };
69  my $Misc = {  my $Misc = {
70    qw/var 1/    qw/append 1
71         assign 1
72         decrement 1
73         fail 1
74         if 1
75         implementationAttribute 1
76         increment 1
77         for 1
78         plus 1
79         var 1
80         while 1/
81    };
82    my $Condition = {
83      qw/condition 1
84         contains 1
85         contentType 1
86         equals 1
87         greater 1
88         greaterOrEquals 1
89         hasSize 1
90         implementationAttribute 1
91         instanceOf 1
92         isNull 1
93         less 1
94         lessOrEquals 1
95         not 1
96         notEquals 1
97         notNull 1
98         or 1/
99  };  };
100    
101  my $Status;  my $Status = {Number => 0, our => {Info => 1}};
102  our $result = '';  
103    sub to_perl_value ($;%) {
104      my ($s, %opt) = @_;
105      if (defined $s) {
106        if ($s =~ /^(?!\d)\w+$/) {
107          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 {
113          return $s;
114        }
115      } elsif (defined $opt{default}) {
116        return $opt{default};
117      } else {
118        return '';
119      }
120    }
121    
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    }    }
149    $result;    $result;
150  }  }
151    
152    sub condition2code ($;%) {
153      my ($parent, %opt) = @_;
154      my $result = '';
155      my @result;
156      my $children = $parent->child_nodes;
157      for (my $i = 0; $i < $children->length; $i++) {
158        my $child = $children->item ($i);
159        if ($child->node_type == $child->ELEMENT_NODE) {
160          my $ln = $child->local_name;
161          if ($Condition->{$ln}) {
162            push @result, node2code ($child);
163          } else {
164            valid_err q<Unknown element type: >.$child->local_name,
165              node => $child;
166          }
167        } elsif ($child->node_type == $child->COMMENT_NODE) {
168          $result .= perl_comment $child->data;
169        } elsif ($child->node_type == $child->TEXT_NODE) {
170          if ($child->data =~ /\S/) {
171            valid_err q<Unknown character data: >.$child->data,
172              node => $child;
173          }
174        } else {
175          valid_err q<Unknown type of node: >.$child->node_type,
176            node => $child;
177        }
178      }
179      $result .= join (($opt{join}||='or' eq 'or' ? ' || ' :
180                        $opt{join} eq 'and' ? ' && ' :
181                        valid_err q<Multiple condition not supported>,
182                          node => $parent),
183                       map {"($_)"} @result);
184      $result;
185    } #condition2code
186    
187    sub node2code ($);
188  sub node2code ($) {  sub node2code ($) {
189    my $node = shift;    my $node = shift;
190    my $result = '';    my $result = '';
191    my $ln = $node->localName;    if ($node->node_type != $node->ELEMENT_NODE) {
192        if ($node->node_type == $node->COMMENT_NODE) {
193          $result .= perl_comment $node->data;
194        } elsif ($node->node_type == $node->TEXT_NODE) {
195          if ($node->data =~ /\S/) {
196            valid_err q<Unknown character data: >.$node->data,
197              node => $node;
198          }
199        } else {
200          valid_err q<Unknown type of node: >.$node->node_type,
201            node => $node;
202        }
203        return $result;
204      }
205      my $ln = $node->local_name;
206    
207    if ($ln eq 'var') {    if ($ln eq 'var') {
208        $result .= perl_statement      my $name = $node->get_attribute_ns (undef, 'name');
209                     perl_var      my $var = perl_var
210                       local_name => $node->getAttributeNS (undef, '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      } elsif ($ln eq 'load') {      }
252        $Status->{var}->{$name}->{type} = $node->get_attribute_ns (undef, 'type');
253      } 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;
281          if ($node->has_attribute_ns (undef, 'interface')) {
282            my $if = $node->get_attribute_ns (undef, 'interface');
283            $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 {
295            $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                  ## TODO: parameters                  join (', ',
301                         map {
302                           to_perl_value ($node->get_attribute_ns (undef, $_),
303                                          default => 'undef')
304                         } @$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->has_attribute_ns (undef, 'value')) {
314            #
315        } else {        } else {
316          impl_err q<Attr set>;          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->has_attribute_ns (undef, 'value')) {
333            $result .= " (".to_perl_value ($node->get_attribute_ns (undef, 'value')).
334                       ");\n";
335          }
336          } # A
337        } # MA
338        } elsif ($ln eq 'assertEquals') {
339          my $expected = $node->get_attribute_ns (undef, 'expected');
340          my $expectedType = $Status->{var}->{$expected}->{type} || '';
341          $result .= 'assertEquals'.
342                     ({Collection => 'Collection',
343                       List => 'List'}->{$expectedType}||'');
344          my $ignoreCase = $node->get_attribute_ns (undef, 'ignoreCase') || 'false';
345          if ($ignoreCase eq 'auto') {
346            $result .= 'AutoCase ('.
347                       perl_literal ($node->get_attribute_ns (undef, 'context') ||
348                                     'element').
349                       ', ';
350          } else {
351            $result .= ' (';
352        }        }
353      } elsif ($ln eq 'assertTrue') {        $result .= perl_literal ($node->get_attribute_ns (undef, 'id')).', ';
354        if ($node->hasAttributeNS (undef, 'actual')) {        $result .= join ", ", map {
355          $result .= perl_statement $ln . ' ('.                     $ignoreCase eq 'true'
356                       perl_literal ($node->getAttributeNS (undef, 'id')).', '.                       ? ($expectedType eq 'Collection' or
357                       perl_var (type => '$',                          $expectedType eq 'List')
358                                 local_name => $node->getAttributeNS                           ? "toLowerArray ($_)" : "lc ($_)"
359                                                         (undef, 'actual')).                       : $_
360                       ')';                   } map {
361          if ($node->hasChildNodes) {                     to_perl_value ($_)
362                     } (
363                       $expected,
364                       $node->get_attribute_ns (undef, 'actual'),
365                     );
366          $result .= ");\n";
367        $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') {
401        my $size = to_perl_value ($node->get_attribute_ns (undef, 'size'));
402        my $coll = to_perl_value ($node->get_attribute_ns (undef, 'collection'));
403        $result .= perl_statement 'assertSize ('.
404                     perl_list
405                       ($node->get_attribute_ns (undef, 'id'),
406                        perl_code_literal $size, perl_code_literal $coll).
407                   ')';
408        if ($node->has_child_nodes) {
409          $result .= perl_if
410                       qq<$size == size ($coll)>,
411                       body2code ($node);
412        }
413        $Status->{Number}++;
414      } elsif ($ln eq 'assertTrue' or $ln eq 'assertFalse') {
415          my $condition;
416          if ($node->has_attribute_ns (undef, 'actual')) {
417            $condition = perl_var (type => '$',
418                                   local_name => $node->get_attribute_ns
419                                                           (undef, 'actual'));
420            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->has_child_nodes) {
425            $condition = condition2code ($node);
426        } else {        } else {
427          valid_err q<assertTrue w/o @actual not supported>,        valid_err $ln.q< w/o @actual not supported>, node => $node;
           node => $node;  
428        }        }
429      } elsif ($ln eq 'assertNotNull') {        $result .= perl_statement $ln . ' ('.
430        $result .= perl_statement $ln . ' (' .                       perl_literal ($node->get_attribute_ns (undef, 'id')).', '.
431                   perl_literal ($node->getAttributeNS (undef, 'id')).', '.                       $condition. ')';
432        $Status->{Number}++;
433      } elsif ($ln eq 'assertNotNull' or $ln eq 'assertNull') {
434        $result .= perl_statement $ln . ' (' .
435                     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}++;
476    } elsif ($ln eq 'assertDOMException') {    } elsif ($ln eq 'assertDOMException') {
477      $Status->{use}->{'Message::Util::Error'} = 1;      $Status->{use}->{'Message::Util::Error'} = 1;
478      $result .= q[      $result .= q[
# Line 148  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}++;
500      } elsif ($ln eq 'contentType') {
501        $result .= '$builder->{contentType} eq '.
502                   perl_literal ($node->get_attribute_ns (undef, 'type'));
503        $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') {
570        my $children = $node->child_nodes;
571        my $condition;
572        my $true = '';
573        my $false = '';
574        my $assert_true = 0;
575        my $assert_false = 0;
576        for (my $i = 0; $i < $children->length; $i++) {
577          my $child = $children->item ($i);
578          if ($child->node_type == $child->ELEMENT_NODE) {
579            if (not $condition) {
580              $condition = node2code ($child);
581            } elsif ($child->local_name eq 'else') {
582              valid_err q<Multiple 'else's found>, node => $child
583                if $false;
584              local $Status->{Number} = 0;
585              $false = body2code ($child);
586              $assert_false = $Status->{Number};
587            } else {
588              local $Status->{Number} = 0;
589              $true .= node2code ($child);
590              $assert_true += $Status->{Number};
591            }
592          } else {
593            $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
610                    $condition,
611                    $true,
612                    $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') {
640        $result .= condition2code ($node, join => 'or');
641      } elsif ($ln eq 'not') {
642        $result .= 'not '.condition2code ($node, join => 'nosupport');
643      } elsif ($ln eq 'notNull' or $ln eq 'isNull') {
644        $result .= 'defined '.
645                   perl_var (type => '$',
646                             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    }    }
715    $result;    $result;
716  }  }
717    
718  my $input;  our $result = '';
719    
720    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    
 my $dom = Message::DOM::DOMImplementationRegistry  
             ->getDOMImplementation  
                  ({Core => undef,  
                    XML => undef,  
                    ExpandedURI q<ManakaiDOMLS2003:LS> => '1.0'});  
   
 my $parser = $dom->createLSParser (MODE_SYNCHRONOUS);  
 my $in = $dom->createLSInput;  
 $in->stringData ($input);  
   
 my $src = $parser->parse ($in)->documentElement;  
   
728  {  {
729  my $children = $src->ownerDocument->childNodes;    my $dom = $Message::DOM::ImplementationRegistry
730  for (my $i = 0; $i < $children->length; $i++) {      ->get_implementation
731    my $node = $children->item ($i);        ({Core => undef,
732    if ($node->nodeType == $node->COMMENT_NODE) {          XML => undef,
733      if ($node->data =~ /Copyright/) {          ExpandedURI q<ManakaiDOMLS2003:LS> => ''});
734        $result .= perl_comment  
735                     qq<This script was generated by "$0"\n>.    my $parser = $dom->create_ls_parser (MODE_SYNCHRONOUS);
736                     qq<and is a derived work from the source document.\n>.    my $in = $dom->create_ls_input;
737                     qq<The source document contained the following notice:\n>.    $in->string_data ($input);
738                     $node->data;    
739      } else {    status_msg_ q<Parsing XML entity...>;
740        $result .= perl_comment $node->data;    my $src = $parser->parse ($in)->document_element;
741      status_msg q<done>;
742      
743      status_msg_ q<Generating test script...>;
744      {
745        my $children = $src->owner_document->child_nodes;
746        for (my $i = 0; $i < $children->length; $i++) {
747          my $node = $children->item ($i);
748          if ($node->node_type == $node->COMMENT_NODE) {
749            if ($node->data =~ /Copyright/) {
750              $result .= perl_comment
751                           qq<This script was generated by "$0"\n>.
752                           qq<and is a derived work from the source document\n>.
753                           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 '...') {            if ($ln eq 'title') {
776                            $result .= perl_statement
777                             perl_assign
778                               '$Info->{Name}'
779                             => perl_literal $node->text_content;
780              } elsif ($ln eq 'description') {
781                $result .= perl_statement
782                             perl_assign
783                               '$Info->{Description}'
784                             => 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') {
802          $result .= perl_statement 'impl_attr ('.
803                             perl_list
804                                 ($node->get_attribute_ns (undef, 'name'),
805                                  $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  }  }
821    }
822    
823    my $pre = "#!/usr/bin/perl -w\nuse strict;\n";
824    $pre .= perl_statement ('require '.perl_literal 'manakai/domtest.pl');
825    $pre .= perl_statement
826                ('use Message::Util::Error')
827      if $Status->{use}->{'Message::Util::Error'};
828    for (keys %{$Status->{our}}) {
829      $pre .= perl_statement perl_var type => '$', local_name => $_,
830                                      scope => 'our';
831    }
832    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    =cut
897    
 output_result $result;  
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.9
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24