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

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

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

revision 1.4 by wakaba, Sat Oct 16 13:34:56 2004 UTC revision 1.8 by wakaba, Thu Jan 6 10:41:31 2005 UTC
# Line 3  use lib q<../lib>; Line 3  use lib q<../lib>;
3  use strict;  use strict;
4  BEGIN { require 'manakai/genlib.pl' }  BEGIN { require 'manakai/genlib.pl' }
5    
6  use Message::Util::QName::General [qw/ExpandedURI/], {  use Message::Util::QName::Filter {
7    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#>,  
8  };  };
9  use Message::DOM::ManakaiDOMLS2003;  use Message::DOM::ManakaiDOMLS2003;
10  use Message::DOM::DOMLS qw/MODE_SYNCHRONOUS/;  use Message::DOM::DOMLS qw/MODE_SYNCHRONOUS/;
# Line 14  use Getopt::Long; Line 13  use Getopt::Long;
13  require 'dommemlist.pl.tmp'; ## Generated by mkdommemlist.pl  require 'dommemlist.pl.tmp'; ## Generated by mkdommemlist.pl
14    
15  my $output_filename;  my $output_filename;
 my $output_file;  
16  GetOptions (  GetOptions (
17    'output-file=s' => \$output_filename,    'output-file=s' => \$output_filename,
18  );  );
19    
20  if (defined $output_filename) {  if (defined $output_filename) {
21    open $output_file, '>', $output_filename or die "$0: $output_filename: $!";    open my $f, '>', $output_filename or die "$0: $output_filename: $!";
22      our $ResultOutput = $f;
23  } else {  } else {
24    $output_file = \*STDOUT;    our $ResultOutput = \*STDOUT;
25  }  }
26    
27  our $Method;  our $Method;
# Line 29  our $IFMethod; Line 29  our $IFMethod;
29  our $Attr;  our $Attr;
30  my $Assert = {  my $Assert = {
31    qw/assertDOMException 1    qw/assertDOMException 1
32         assertEquals 1
33       assertFalse 1       assertFalse 1
34         assertInstanceOf 1
35       assertNotNull 1       assertNotNull 1
36       assertNull 1       assertNull 1
37         assertSame 1
38       assertSize 1       assertSize 1
39       assertTrue 1/       assertTrue 1
40         assertURIEquals 1/
41  };  };
42  my $Misc = {  my $Misc = {
43    qw/if 1    qw/append 1
44         assign 1
45         decrement 1
46         fail 1
47         if 1
48       implementationAttribute 1       implementationAttribute 1
49       var 1/       increment 1
50         for 1
51         plus 1
52         var 1
53         while 1/
54  };  };
55  my $Condition = {  my $Condition = {
56    qw/condition 1    qw/condition 1
57       contains 1       contains 1
58       contentType 1       contentType 1
59         equals 1
60         greater 1
61         greaterOrEquals 1
62       hasSize 1       hasSize 1
63       implementationAttribute 1       implementationAttribute 1
64         instanceOf 1
65         isNull 1
66         less 1
67         lessOrEquals 1
68       not 1       not 1
69         notEquals 1
70       notNull 1       notNull 1
71       or 1/       or 1/
72  };  };
73    
74  my $Status = {Number => 0, our => {Info => 1}};  my $Status = {Number => 0, our => {Info => 1}};
75    
 ## Defined in genlib.pl but redefined.  
 sub output_result ($) {  
   print $output_file shift;  
 }  
   
76  sub to_perl_value ($;%) {  sub to_perl_value ($;%) {
77    my ($s, %opt) = @_;    my ($s, %opt) = @_;
78    if (defined $s) {    if (defined $s) {
79      if ($s =~ /^(?!\d)\w+$/) {      if ($s =~ /^(?!\d)\w+$/) {
80        return perl_var (type => '$', local_name => $s);        if ({true => 1, false => 1}->{$s}) {
81            return {true => '1', false => '0'}->{$s};
82          } else {
83            return perl_var (type => '$', local_name => $s);
84          }
85      } else {      } else {
86        return $s;        return $s;
87      }      }
# Line 160  sub node2code ($) { Line 179  sub node2code ($) {
179    
180    if ($ln eq 'var') {    if ($ln eq 'var') {
181      my $name = $node->getAttributeNS (undef, 'name');      my $name = $node->getAttributeNS (undef, 'name');
182      $result .= perl_statement      my $var = perl_var
                    perl_var  
183                       local_name => $name,                       local_name => $name,
184                       scope => 'my',                       scope => 'my',
185                       type => '$';                       type => '$';
186      if ($node->getAttributeNS (undef, 'value')) {      my $type = $node->getAttributeNS (undef, 'type');
187        valid_err q<Attribute "value" not supported>, node => $node;      $result .= perl_comment $type;
188        if ($node->hasAttributeNS (undef, 'isNull') and
189            $node->getAttributeNS (undef, 'isNull') eq 'true') {
190          $result .= perl_statement perl_assign $var => 'undef';
191        } elsif ($node->hasAttributeNS (undef, 'value')) {
192          $result .= perl_statement
193                       perl_assign
194                            $var
195                         => to_perl_value ($node->getAttributeNS (undef, 'value'));
196        } else {
197          if ($type eq 'List' or $type eq 'Collection') {
198            my @member;
199            my $children = $node->childNodes;
200            for (my $i = 0; $i < $children->length; $i++) {
201              my $child = $children->item ($i);
202              if ($child->nodeType == $child->ELEMENT_NODE) {
203                if ($child->localName eq 'member') {
204                  push @member, perl_code_literal
205                                  (to_perl_value ($child->textContent));
206                } else {
207                  valid_err q<Unsupported element type>, node => $child;
208                }
209              } elsif ($child->nodeType == $child->COMMENT_NODE) {
210                $result .= perl_comment $child->data;
211              }
212            }
213            $result .= perl_statement
214                         perl_assign
215                              $var
216                           => perl_list \@member;
217          } elsif ($type =~ /Monitor/) {
218            valid_err qq<Type $type not supported>, node => $node;
219          } elsif ($node->hasChildNodes) {
220            valid_err q<Children not supported>, node => $node;
221          } else {
222            $result .= perl_statement $var;
223          }
224      }      }
225      $Status->{var}->{$name}->{type} = $node->getAttributeNS (undef, 'type');      $Status->{var}->{$name}->{type} = $node->getAttributeNS (undef, 'type');
226    } elsif ($ln eq 'load') {    } elsif ($ln eq 'load') {
# Line 178  sub node2code ($) { Line 232  sub node2code ($) {
232                     => 'load (' .                     => 'load (' .
233                        perl_literal ($node->getAttributeNS (undef, 'href')).                        perl_literal ($node->getAttributeNS (undef, 'href')).
234                        ')';                        ')';
235      } elsif ($Method->{$ln}) {    } elsif ($ln eq 'hasFeature' and
236               not $node->hasAttributeNS (undef, 'var')) {
237        ## If there is a "hasFeature" element in "body" and
238        ## it does not have "var" attribute, then it is part of the
239        ## implementation condition.
240        $result .= perl_statement 'hasFeature ('.
241                           to_perl_value ($node->getAttributeNS (undef, 'feature'),
242                                          default => 'undef') . ', '.
243                           to_perl_value ($node->getAttributeNS (undef, 'version'),
244                                          default => 'undef') . ')';
245      } elsif ($Method->{$ln}) {
246        $result .= perl_var (type => '$',        $result .= perl_var (type => '$',
247                             local_name => $node->getAttributeNS (undef, 'var')).                             local_name => $node->getAttributeNS (undef, 'var')).
248                   ' = '                   ' = '
249          if $node->hasAttributeNS (undef, 'var');          if $node->hasAttributeNS (undef, 'var');
250        my $param;        my $param;
251        if ($node->hasAttributeNS (undef, 'interface')) {        if ($node->hasAttributeNS (undef, 'interface')) {
252          $param = $IFMethod->{$node->getAttributeNS (undef, 'interface')}          my $if = $node->getAttributeNS (undef, 'interface');
253                            ->{$ln};          $param = $IFMethod->{$if}->{$ln};
254            unless ($param) {
255              valid_err "Method $if.$ln not supported", node => $node;
256            }
257            if ($if eq 'Element' and $ln eq 'getElementsByTagName' and
258                not $node->hasAttributeNS (undef, 'name') and
259                $node->hasAttributeNS (undef, 'tagname')) {
260              $node->setAttributeNS (undef, 'name'
261                                     => $node->getAttributeNS (undef, 'tagname'));
262            }
263        } else {        } else {
264          $param = $Method->{$ln};          $param = $Method->{$ln};
265        }        }
# Line 209  sub node2code ($) { Line 282  sub node2code ($) {
282        } else {        } else {
283          valid_err q<Unknown operation to an attribute>, node => $node;          valid_err q<Unknown operation to an attribute>, node => $node;
284        }        }
285        $result .= perl_var (type => '$',        my $obj = perl_var (type => '$',
286                             local_name => $node->getAttributeNS (undef, 'obj')).                            local_name => $node->getAttributeNS (undef, 'obj'));
287                '->'.$ln;        my $if = $node->getAttributeNS (undef, 'interface');
288          if (defined $if and $if eq 'DOMString') {
289            if ($ln eq 'length') {
290              $result .= 'length '.$obj;
291            } else {
292              valid_err q<$if.$ln not supported>, node => $node;
293            }
294          } else {
295            $result .= $obj.'->'.$ln;
296          }
297        if ($node->hasAttributeNS (undef, 'var')) {        if ($node->hasAttributeNS (undef, 'var')) {
298          $result .= ";\n";          $result .= ";\n";
299        } elsif ($node->hasAttributeNS (undef, 'value')) {        } elsif ($node->hasAttributeNS (undef, 'value')) {
# Line 248  sub node2code ($) { Line 330  sub node2code ($) {
330                   );                   );
331        $result .= ");\n";        $result .= ");\n";
332      $Status->{Number}++;      $Status->{Number}++;
333      } elsif ($ln eq 'assertInstanceOf') {
334        my $obj = perl_code_literal
335                    (to_perl_value ($node->getAttributeNS (undef, 'obj')));
336        $result .= perl_statement 'assertInstanceOf ('.
337                     perl_list
338                       ($node->getAttributeNS (undef, 'id'),
339                        $node->getAttributeNS (undef, 'type'),
340                        $obj).
341                   ')';
342        if ($node->hasChildNodes) {
343          $result .= perl_if
344                       'isInstanceOf ('.
345                       perl_list
346                         ($node->getAttributeNS (undef, 'type'),
347                          $obj) . ')',
348                       body2code ($node);
349        }
350        $Status->{Number}++;
351      } elsif ($ln eq 'assertSame') {
352        my $expected = to_perl_value ($node->getAttributeNS (undef, 'expected'));
353        my $actual = to_perl_value ($node->getAttributeNS (undef, 'actual'));
354        $result .= perl_statement 'assertSame ('.
355                     perl_list
356                       ($node->getAttributeNS (undef, 'id'),
357                        $expected, $actual).
358                   ')';
359        if ($node->hasChildNodes) {
360          $result .= perl_if
361                       'same ('.(perl_list $expected, $actual).')',
362                       body2code ($node);
363        }
364        $Status->{Number}++;
365    } elsif ($ln eq 'assertSize') {    } elsif ($ln eq 'assertSize') {
366      my $size = to_perl_value ($node->getAttributeNS (undef, 'size'));      my $size = to_perl_value ($node->getAttributeNS (undef, 'size'));
367      my $coll = to_perl_value ($node->getAttributeNS (undef, 'collection'));      my $coll = to_perl_value ($node->getAttributeNS (undef, 'collection'));
# Line 259  sub node2code ($) { Line 373  sub node2code ($) {
373      if ($node->hasChildNodes) {      if ($node->hasChildNodes) {
374        $result .= perl_if        $result .= perl_if
375                     qq<$size == size ($coll)>,                     qq<$size == size ($coll)>,
376                     block2code ($node);                     body2code ($node);
377      }      }
378        $Status->{Number}++;
379    } elsif ($ln eq 'assertTrue' or $ln eq 'assertFalse') {    } elsif ($ln eq 'assertTrue' or $ln eq 'assertFalse') {
380        my $condition;        my $condition;
381        if ($node->hasAttributeNS (undef, 'actual')) {        if ($node->hasAttributeNS (undef, 'actual')) {
# Line 280  sub node2code ($) { Line 395  sub node2code ($) {
395                       perl_literal ($node->getAttributeNS (undef, 'id')).', '.                       perl_literal ($node->getAttributeNS (undef, 'id')).', '.
396                       $condition. ')';                       $condition. ')';
397      $Status->{Number}++;      $Status->{Number}++;
398      } elsif ($ln eq 'assertNotNull' or $ln eq 'assertNull') {    } elsif ($ln eq 'assertNotNull' or $ln eq 'assertNull') {
399        $result .= perl_statement $ln . ' (' .      $result .= perl_statement $ln . ' (' .
400                   perl_literal ($node->getAttributeNS (undef, 'id')).', '.                   perl_literal ($node->getAttributeNS (undef, 'id')).', '.
401                   perl_var (type => '$',                   perl_var (type => '$',
402                             local_name => $node->getAttributeNS (undef, 'actual')).                             local_name => $node->getAttributeNS (undef, 'actual')).
403                   ')';                   ')';
404        if ($node->hasChildNodes) {      if ($node->hasChildNodes) {
405          valid_err q<Child of $ln found but not supported>,        valid_err q<Child of $ln found but not supported>,
406            node => $node;            node => $node;
407        }      }
408        $Status->{Number}++;
409      } elsif ($ln eq 'assertURIEquals') {
410        $result .= perl_statement 'assertURIEquals ('.
411                     perl_list
412                       ($node->getAttributeNS (undef, 'id'),
413                        perl_code_literal
414                          (to_perl_value ($node->getAttributeNS (undef, 'scheme'),
415                                          default => 'undef')),
416                        perl_code_literal
417                          (to_perl_value ($node->getAttributeNS (undef, 'path'),
418                                          default => 'undef')),
419                        perl_code_literal
420                          (to_perl_value ($node->getAttributeNS (undef, 'host'),
421                                          default => 'undef')),
422                        perl_code_literal
423                          (to_perl_value ($node->getAttributeNS (undef, 'file'),
424                                          default => 'undef')),
425                        perl_code_literal
426                          (to_perl_value ($node->getAttributeNS (undef, 'name'),
427                                          default => 'undef')),
428                        perl_code_literal
429                          (to_perl_value ($node->getAttributeNS (undef, 'query'),
430                                          default => 'undef')),
431                        perl_code_literal
432                          (to_perl_value ($node->getAttributeNS (undef, 'fragment'),
433                                          default => 'undef')),
434                        perl_code_literal
435                          (to_perl_value ($node->getAttributeNS (undef, 'isAbsolute'),
436                                          default => 'undef')),
437                        perl_code_literal
438                          (to_perl_value ($node->getAttributeNS (undef, 'actual')))).
439                   ')';
440      $Status->{Number}++;      $Status->{Number}++;
441    } elsif ($ln eq 'assertDOMException') {    } elsif ($ln eq 'assertDOMException') {
442      $Status->{use}->{'Message::Util::Error'} = 1;      $Status->{use}->{'Message::Util::Error'} = 1;
# Line 306  sub node2code ($) { Line 453  sub node2code ($) {
453        $result .= body2code ($child);        $result .= body2code ($child);
454      }      }
455      $result .= q[      $result .= q[
456          } catch Message::DOM::DOMException with {          } catch Message::DOM::IF::DOMException with {
457            my $err = shift;            my $err = shift;
458            $success = 1 if $err->{-type} eq ].perl_literal ($errname).q[;            $success = 1 if $err->{-type} eq ].perl_literal ($errname).q[;
459          }          };
460          assertTrue (].perl_literal ($node->getAttributeNS (undef, 'id')).          assertTrue (].perl_literal ($node->getAttributeNS (undef, 'id')).
461          q[, $success);          q[, $success);
462        }        }
# Line 319  sub node2code ($) { Line 466  sub node2code ($) {
466      $result .= '$builder->{contentType} eq '.      $result .= '$builder->{contentType} eq '.
467                 perl_literal ($node->getAttributeNS (undef, 'type'));                 perl_literal ($node->getAttributeNS (undef, 'type'));
468      $Status->{our}->{builder} = 1;      $Status->{our}->{builder} = 1;
469      } elsif ($ln eq 'for-each') {
470        my $collection = $node->getAttributeNS (undef, 'collection');
471        my $collType = $Status->{var}->{$collection}->{type};
472        my $coll = to_perl_value ($collection);
473        my $assert;
474        my $code;
475        {
476          local $Status->{Number} = 0;
477          $code = body2code ($node);
478          $assert = $Status->{Number};
479        }
480        $Status->{Number_local} = 1;
481        $result .= 'for (my $i = 0; $i < '.
482                   ({'Collection'=>1,'List'=>1}->{$collType}
483                      ? '@{'.$coll.'}' : $coll.'->length').
484                   '; $i++) {'.
485                     perl_statement (qq<plan_local ($assert)>).
486                     perl_statement
487                       (perl_assign
488                           to_perl_value ($node->getAttributeNS (undef, 'member'))
489                        => $coll . ({'Collection'=>1,'List'=>1}->{$collType}
490                                      ? '->[$i]' : '->item ($i)')).
491                     $code.
492                   '}';
493      } elsif ($ln eq 'try') {
494        my $children = $node->childNodes;
495        my $true = '';
496        my $false = '';
497        for (my $i = 0; $i < $children->length; $i++) {
498          my $child = $children->item ($i);
499          if ($child->nodeType == $child->ELEMENT_NODE) {
500            if ($child->localName eq 'catch') {
501              valid_err q<Multiple 'catch'es found>, node => $child
502                if $false;
503              my @case;
504              my $children2 = $child->childNodes;
505              for (my $j = 0; $j < $children2->length; $j++) {
506                my $child2 = $children2->item ($j);
507                if ($child2->nodeType == $child2->ELEMENT_NODE) {
508                  if ($child2->localName eq 'ImplementationException') {
509                    valid_err q<Element type not supported>, node => $child2;
510                  } else {
511                    push @case, '$err->{-type} eq '.
512                              perl_literal ($child2->getAttributeNS (undef, 'code'))
513                                => body2code ($child2);
514                  }
515                } else {
516                  $false .= node2code ($child2);
517                }
518              }
519              $false .= perl_cases @case, else => perl_statement '$err->throw';
520            } else {
521              $true .= node2code ($child);
522            }
523          } else {
524            $true .= node2code ($child);
525          }
526        }
527        $result = "try {
528                     $true
529                   } catch Message::DOM::DOMMain::ManakaiDOMException with {
530                     my \$err = shift;
531                     $false
532                   };";
533        $Status->{use}->{'Message::Util::Error'} = 1;
534    } elsif ($ln eq 'if') {    } elsif ($ln eq 'if') {
535      my $children = $node->childNodes;      my $children = $node->childNodes;
536      my $condition;      my $condition;
537      my $true = '';      my $true = '';
538        my $false = '';
539        my $assert_true = 0;
540        my $assert_false = 0;
541      for (my $i = 0; $i < $children->length; $i++) {      for (my $i = 0; $i < $children->length; $i++) {
542        my $child = $children->item ($i);        my $child = $children->item ($i);
543        if ($child->nodeType == $child->ELEMENT_NODE) {        if ($child->nodeType == $child->ELEMENT_NODE) {
# Line 330  sub node2code ($) { Line 545  sub node2code ($) {
545            $condition = node2code ($child);            $condition = node2code ($child);
546          } elsif ($child->localName eq 'else') {          } elsif ($child->localName eq 'else') {
547            valid_err q<Multiple 'else's found>, node => $child            valid_err q<Multiple 'else's found>, node => $child
548              if $true;              if $false;
549            $true = $result;            local $Status->{Number} = 0;
550            $result = '';            $false = body2code ($child);
551              $assert_false = $Status->{Number};
552          } else {          } else {
553            $result .= node2code ($child);            local $Status->{Number} = 0;
554              $true .= node2code ($child);
555              $assert_true += $Status->{Number};
556          }          }
557        } else {        } else {
558          $result .= node2code ($child);          $true .= node2code ($child);
559        }        }
560      }      }
561        if ($assert_true == $assert_false) {
562          $Status->{Number} += $assert_true;
563        } elsif ($assert_true > $assert_false) {
564          $false .= perl_statement 'skip_n ('.
565                      perl_list ($assert_true - $assert_false,
566                                 msg => q<Conditional>).')';
567          $Status->{Number} += $assert_true;
568        } else {
569          $true .= perl_statement 'skip_n ('.
570                      perl_list ($assert_false - $assert_true,
571                                 msg => q<Conditional>).')';
572          $Status->{Number} += $assert_false;
573        }
574      $result = perl_if      $result = perl_if
575                  $condition,                  $condition,
576                  $true || $result,                  $true,
577                  $true ? $result : undef;                  $false ? $false : undef;
578      } elsif ($ln eq 'while') {
579        my $children = $node->childNodes;
580        my $condition;
581        my $true = '';
582        my $assert = 0;
583        {
584          local $Status->{Number} = 0;
585          for (my $i = 0; $i < $children->length; $i++) {
586            my $child = $children->item ($i);
587            if ($child->nodeType == $child->ELEMENT_NODE) {
588              if (not $condition) {
589                $condition = node2code ($child);
590              } else {
591                $true .= node2code ($child);
592              }
593            } else {
594              $true .= node2code ($child);
595            }
596          }
597          $assert = $Status->{Number};
598        }
599        $Status->{Number_local} = 1;
600        $result .= "while ($condition) {
601                      plan_local ($assert);
602                      $true
603                    }";
604    } elsif ($ln eq 'or') {    } elsif ($ln eq 'or') {
605      $result .= condition2code ($node, join => 'or');      $result .= condition2code ($node, join => 'or');
606    } elsif ($ln eq 'not') {    } elsif ($ln eq 'not') {
607      $result .= 'not '.condition2code ($node, join => 'nosupport');      $result .= 'not '.condition2code ($node, join => 'nosupport');
608    } elsif ($ln eq 'notNull') {    } elsif ($ln eq 'notNull' or $ln eq 'isNull') {
609      $result .= 'defined '.      $result .= 'defined '.
610                 perl_var (type => '$',                 perl_var (type => '$',
611                           local_name => $node->getAttributeNS (undef, 'obj'));                           local_name => $node->getAttributeNS (undef, 'obj'));
612        $result = 'not ' . $result if $ln eq 'isNull';
613      } elsif ({less => 1, lessOrEquals => 1,
614                greater => 1, greaterOrEquals => 1}->{$ln}) {
615        $result .= to_perl_value ($node->getAttributeNS (undef, 'actual')).
616                   {less => '<', lessOrEquals => '<=',
617                    greater => '>', greaterOrEquals => '>='}->{$ln}.
618                   to_perl_value ($node->getAttributeNS (undef, 'expected'));
619      } elsif ($ln eq 'equals' or $ln eq 'notEquals') {
620        my $case = $node->getAttributeNS (undef, 'ignoreCase');
621        if ($case and $case eq 'auto') {
622          $result .= 'equalsAutoCase (' .
623                       perl_list
624                         ($node->getAttributeNS (undef, 'context') || 'element',
625                          to_perl_value
626                            ($node->getAttributeNS (undef, 'expected')),
627                          to_perl_value
628                            ($node->getAttributeNS (undef, 'actual'))) . ')';
629        } else {
630          my $expected = to_perl_value
631                            ($node->getAttributeNS (undef, 'expected'));
632          my $actual = to_perl_value
633                            ($node->getAttributeNS (undef, 'actual'));
634          if ($case eq 'true') {
635            $result = "(uc ($expected) eq uc ($actual))";
636          } elsif ($node->hasAttributeNS (undef, 'bitmask')) {
637            my $bm = ' & ' . to_perl_value
638                              ($node->getAttributeNS (undef, 'bitmask'));
639            $result = "($expected$bm == $actual$bm)";
640          } else {
641            $result = "($expected eq $actual)";
642          }
643        }
644        $result = "(not $result)" if $ln eq 'notEquals';
645      } elsif ($ln eq 'increment' or $ln eq 'decrement') {
646        $result .= perl_statement
647                     to_perl_value ($node->getAttributeNS (undef, 'var')).
648                     {increment => ' += ', decrement => ' -= '}->{$ln}.
649                     to_perl_value ($node->getAttributeNS (undef, 'value'));
650      } elsif ({qw/plus 1 subtract 1 mult 1 divide 1/}->{$ln}) {
651        $result .= perl_statement
652                     (perl_assign
653                         to_perl_value ($node->getAttributeNS (undef, 'var'))
654                      => to_perl_value ($node->getAttributeNS (undef, 'op1')).
655                         {qw<plus + subtract - mult * divide />}->{$ln}.
656                         to_perl_value ($node->getAttributeNS (undef, 'op2')));
657      } elsif ($ln eq 'append') {
658        $result .= perl_statement
659                     'push @{'.
660                        to_perl_value ($node->getAttributeNS (undef, 'collection')).
661                        '}, '.
662                        to_perl_value ($node->getAttributeNS (undef, 'item'));
663      } elsif ($ln eq 'instanceOf') {
664        $result .= 'isInstanceOf ('.
665                   perl_list ($node->getAttributeNS (undef, 'type'),
666                              perl_code_literal to_perl_value
667                                ($node->getAttributeNS (undef, 'obj'))).
668                   ')';
669      } elsif ($ln eq 'assign') {
670        $result .= perl_statement
671                     perl_assign
672                          to_perl_value ($node->getAttributeNS (undef, 'var'))
673                       => to_perl_value ($node->getAttributeNS (undef, 'value'));
674      } elsif ($ln eq 'fail') {
675        $result .= perl_statement 'fail ('.
676                     perl_literal ($node->getAttributeNS (undef, 'id')). ')';
677    } else {    } else {
678      valid_err q<Unknown element type: >.$ln;      valid_err q<Unknown element type: >.$ln;
679    }    }
# Line 360  sub node2code ($) { Line 682  sub node2code ($) {
682    
683  our $result = '';  our $result = '';
684    
685    my $input_filename;
686  my $input;  my $input;
687  {  {
688    local $/ = undef;    local $/ = undef;
689    $input = <>;    $input = <>;
690      $input_filename = $ARGV;
691  }  }
692    
693  {  {
694  my $dom = Message::DOM::DOMImplementationRegistry  my $dom = $Message::DOM::DOMImplementationRegistry
695              ->getDOMImplementation              ->getDOMImplementation
696                   ({Core => undef,                   ({Core => undef,
697                     XML => undef,                     XML => undef,
698                     ExpandedURI q<ManakaiDOMLS2003:LS> => '1.0'});                     ExpandedURI q<ManakaiDOMLS2003:LS> => ''});
699    
700  my $parser = $dom->createLSParser (MODE_SYNCHRONOUS);  my $parser = $dom->createLSParser (MODE_SYNCHRONOUS);
701  my $in = $dom->createLSInput;  my $in = $dom->createLSInput;
# Line 387  for (my $i = 0; $i < $children->length; Line 711  for (my $i = 0; $i < $children->length;
711      if ($node->data =~ /Copyright/) {      if ($node->data =~ /Copyright/) {
712        $result .= perl_comment        $result .= perl_comment
713                     qq<This script was generated by "$0"\n>.                     qq<This script was generated by "$0"\n>.
714                     qq<and is a derived work from the source document.\n>.                     qq<and is a derived work from the source document\n>.
715                       qq<"$input_filename".\n>.
716                     qq<The source document contained the following notice:\n>.                     qq<The source document contained the following notice:\n>.
717                     $node->data;                     $node->data;
718      } else {      } else {
# Line 436  for (my $i = 0; $i < $child->length; $i+ Line 761  for (my $i = 0; $i < $child->length; $i+
761          }          }
762        }        }
763      } elsif ($ln eq 'implementationAttribute') {      } elsif ($ln eq 'implementationAttribute') {
764        $result .= perl_comment        $result .= perl_statement 'impl_attr ('.
765                       sprintf 'Implementation attribute: @name=%s, @value=%s',                           perl_list
766                               $node->getAttributeNS (undef, 'name'),                               ($node->getAttributeNS (undef, 'name'),
767                               $node->getAttributeNS (undef, 'value');                                $node->getAttributeNS (undef, 'value')).')';
768      } else {      } else {
769        $result .= node2code ($node);        $result .= node2code ($node);
770      }      }
# Line 466  for (keys %{$Status->{our}}) { Line 791  for (keys %{$Status->{our}}) {
791    $pre .= perl_statement perl_var type => '$', local_name => $_,    $pre .= perl_statement perl_var type => '$', local_name => $_,
792                                    scope => 'our';                                    scope => 'our';
793  }  }
794  $pre .= perl_statement q<plan (>.(0+$Status->{Number}).q<)>;  my $plan = $Status->{Number_local} ? 'plan_local' : 'plan';
795    $pre .= perl_statement qq<$plan (>.(0+$Status->{Number}).q<)>;
796    
797    $result .= perl_statement q<end_of_test ()>;
798    
799  output_result $pre.$result;  output_result $pre.$result;
800    
801    1;
802    
803    __END__
804    
805    =head1 NAME
806    
807    domtest2perl - DOM Test Suite XML Test File to Perl Test Code Converter
808    
809    =head1 SYNOPSIS
810    
811      perl path/to/domtest2perl.pl input.xml > output.pl
812      perl path/to/domtest2perl.pl input.xml --output-file=output.pl
813    
814    =over 4
815    
816    =item I<input.xml>
817    
818    The name of file to input.  It should be an XML document
819    in the DOM Test Suite.
820    
821    =item I<output.pl>
822    
823    The name of file to output.  It is overwritten if already exists.
824    
825    =back
826    
827    =head1 SEE ALSO
828    
829    I<Document Object Model (DOM) Conformance Test Suites>,
830    <http://www.w3.org/DOM/Test/>.
831    
832    F<domts2perl.pl>
833    
834    F<mkdommemlist.pl>
835    
836    =head1 LICENSE
837    
838    Copyright 2004-2005 Wakaba <w@suika.fam.cx>.  All rights reserved.
839    
840    This program is free software; you can redistribute it and/or
841    modify it under the same terms as Perl itself.
842    
843    =cut
844    
Legend:
Removed from v.1.4  
changed lines
  Added in v.1.8
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24