/[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.5 by wakaba, Sun Oct 31 12:29:00 2004 UTC
# 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  };  };
# Line 62  sub to_perl_value ($;%) { Line 82  sub to_perl_value ($;%) {
82    my ($s, %opt) = @_;    my ($s, %opt) = @_;
83    if (defined $s) {    if (defined $s) {
84      if ($s =~ /^(?!\d)\w+$/) {      if ($s =~ /^(?!\d)\w+$/) {
85        return perl_var (type => '$', local_name => $s);        if ({true => 1, false => 1}->{$s}) {
86            return {true => '1', false => '0'}->{$s};
87          } else {
88            return perl_var (type => '$', local_name => $s);
89          }
90      } else {      } else {
91        return $s;        return $s;
92      }      }
# Line 160  sub node2code ($) { Line 184  sub node2code ($) {
184    
185    if ($ln eq 'var') {    if ($ln eq 'var') {
186      my $name = $node->getAttributeNS (undef, 'name');      my $name = $node->getAttributeNS (undef, 'name');
187      $result .= perl_statement      my $var = perl_var
                    perl_var  
188                       local_name => $name,                       local_name => $name,
189                       scope => 'my',                       scope => 'my',
190                       type => '$';                       type => '$';
191      if ($node->getAttributeNS (undef, 'value')) {      my $type = $node->getAttributeNS (undef, 'type');
192        valid_err q<Attribute "value" not supported>, node => $node;      $result .= perl_comment $type;
193        if ($node->hasAttributeNS (undef, 'isNull') and
194            $node->getAttributeNS (undef, 'isNull') eq 'true') {
195          $result .= perl_statement perl_assign $var => 'undef';
196        } elsif ($node->hasAttributeNS (undef, 'value')) {
197          $result .= perl_statement
198                       perl_assign
199                            $var
200                         => to_perl_value ($node->getAttributeNS (undef, 'value'));
201        } else {
202          if ($type eq 'List' or $type eq 'Collection') {
203            my @member;
204            my $children = $node->childNodes;
205            for (my $i = 0; $i < $children->length; $i++) {
206              my $child = $children->item ($i);
207              if ($child->nodeType == $child->ELEMENT_NODE) {
208                if ($child->localName eq 'member') {
209                  push @member, perl_code_literal
210                                  (to_perl_value ($child->textContent));
211                } else {
212                  valid_err q<Unsupported element type>, node => $child;
213                }
214              } elsif ($child->nodeType == $child->COMMENT_NODE) {
215                $result .= perl_comment $child->data;
216              }
217            }
218            $result .= perl_statement
219                         perl_assign
220                              $var
221                           => perl_list \@member;
222          } elsif ($type =~ /Monitor/) {
223            valid_err qq<Type $type not supported>, node => $node;
224          } elsif ($node->hasChildNodes) {
225            valid_err q<Children not supported>, node => $node;
226          } else {
227            $result .= perl_statement $var;
228          }
229      }      }
230      $Status->{var}->{$name}->{type} = $node->getAttributeNS (undef, 'type');      $Status->{var}->{$name}->{type} = $node->getAttributeNS (undef, 'type');
231    } elsif ($ln eq 'load') {    } elsif ($ln eq 'load') {
# Line 185  sub node2code ($) { Line 244  sub node2code ($) {
244          if $node->hasAttributeNS (undef, 'var');          if $node->hasAttributeNS (undef, 'var');
245        my $param;        my $param;
246        if ($node->hasAttributeNS (undef, 'interface')) {        if ($node->hasAttributeNS (undef, 'interface')) {
247          $param = $IFMethod->{$node->getAttributeNS (undef, 'interface')}          my $if = $node->getAttributeNS (undef, 'interface');
248                            ->{$ln};          $param = $IFMethod->{$if}->{$ln};
249            unless ($param) {
250              valid_err "Method $if.$ln not supported", node => $node;
251            }
252            if ($if eq 'Element' and $ln eq 'getElementsByTagName' and
253                not $node->hasAttributeNS (undef, 'name') and
254                $node->hasAttributeNS (undef, 'tagname')) {
255              $node->setAttributeNS (undef, 'name'
256                                     => $node->getAttributeNS (undef, 'tagname'));
257            }
258        } else {        } else {
259          $param = $Method->{$ln};          $param = $Method->{$ln};
260        }        }
# Line 209  sub node2code ($) { Line 277  sub node2code ($) {
277        } else {        } else {
278          valid_err q<Unknown operation to an attribute>, node => $node;          valid_err q<Unknown operation to an attribute>, node => $node;
279        }        }
280        $result .= perl_var (type => '$',        my $obj = perl_var (type => '$',
281                             local_name => $node->getAttributeNS (undef, 'obj')).                            local_name => $node->getAttributeNS (undef, 'obj'));
282                '->'.$ln;        my $if = $node->getAttributeNS (undef, 'interface');
283          if (defined $if and $if eq 'DOMString') {
284            if ($ln eq 'length') {
285              $result .= 'length '.$obj;
286            } else {
287              valid_err q<$if.$ln not supported>, node => $node;
288            }
289          } else {
290            $result .= $obj.'->'.$ln;
291          }
292        if ($node->hasAttributeNS (undef, 'var')) {        if ($node->hasAttributeNS (undef, 'var')) {
293          $result .= ";\n";          $result .= ";\n";
294        } elsif ($node->hasAttributeNS (undef, 'value')) {        } elsif ($node->hasAttributeNS (undef, 'value')) {
# Line 248  sub node2code ($) { Line 325  sub node2code ($) {
325                   );                   );
326        $result .= ");\n";        $result .= ");\n";
327      $Status->{Number}++;      $Status->{Number}++;
328      } elsif ($ln eq 'assertInstanceOf') {
329        my $obj = perl_code_literal
330                    (to_perl_value ($node->getAttributeNS (undef, 'obj')));
331        $result .= perl_statement 'assertInstanceOf ('.
332                     perl_list
333                       ($node->getAttributeNS (undef, 'id'),
334                        $node->getAttributeNS (undef, 'type'),
335                        $obj).
336                   ')';
337        if ($node->hasChildNodes) {
338          $result .= perl_if
339                       'isInstanceOf ('.
340                       perl_list
341                         ($node->getAttributeNS (undef, 'type'),
342                          $obj) . ')',
343                       body2code ($node);
344        }
345        $Status->{Number}++;
346      } elsif ($ln eq 'assertSame') {
347        my $expected = to_perl_value ($node->getAttributeNS (undef, 'expected'));
348        my $actual = to_perl_value ($node->getAttributeNS (undef, 'actual'));
349        $result .= perl_statement 'assertSame ('.
350                     perl_list
351                       ($node->getAttributeNS (undef, 'id'),
352                        $expected, $actual).
353                   ')';
354        if ($node->hasChildNodes) {
355          $result .= perl_if
356                       'same ('.(perl_list $expected, $actual).')',
357                       body2code ($node);
358        }
359        $Status->{Number}++;
360    } elsif ($ln eq 'assertSize') {    } elsif ($ln eq 'assertSize') {
361      my $size = to_perl_value ($node->getAttributeNS (undef, 'size'));      my $size = to_perl_value ($node->getAttributeNS (undef, 'size'));
362      my $coll = to_perl_value ($node->getAttributeNS (undef, 'collection'));      my $coll = to_perl_value ($node->getAttributeNS (undef, 'collection'));
# Line 259  sub node2code ($) { Line 368  sub node2code ($) {
368      if ($node->hasChildNodes) {      if ($node->hasChildNodes) {
369        $result .= perl_if        $result .= perl_if
370                     qq<$size == size ($coll)>,                     qq<$size == size ($coll)>,
371                     block2code ($node);                     body2code ($node);
372      }      }
373        $Status->{Number}++;
374    } elsif ($ln eq 'assertTrue' or $ln eq 'assertFalse') {    } elsif ($ln eq 'assertTrue' or $ln eq 'assertFalse') {
375        my $condition;        my $condition;
376        if ($node->hasAttributeNS (undef, 'actual')) {        if ($node->hasAttributeNS (undef, 'actual')) {
# Line 280  sub node2code ($) { Line 390  sub node2code ($) {
390                       perl_literal ($node->getAttributeNS (undef, 'id')).', '.                       perl_literal ($node->getAttributeNS (undef, 'id')).', '.
391                       $condition. ')';                       $condition. ')';
392      $Status->{Number}++;      $Status->{Number}++;
393      } elsif ($ln eq 'assertNotNull' or $ln eq 'assertNull') {    } elsif ($ln eq 'assertNotNull' or $ln eq 'assertNull') {
394        $result .= perl_statement $ln . ' (' .      $result .= perl_statement $ln . ' (' .
395                   perl_literal ($node->getAttributeNS (undef, 'id')).', '.                   perl_literal ($node->getAttributeNS (undef, 'id')).', '.
396                   perl_var (type => '$',                   perl_var (type => '$',
397                             local_name => $node->getAttributeNS (undef, 'actual')).                             local_name => $node->getAttributeNS (undef, 'actual')).
398                   ')';                   ')';
399        if ($node->hasChildNodes) {      if ($node->hasChildNodes) {
400          valid_err q<Child of $ln found but not supported>,        valid_err q<Child of $ln found but not supported>,
401            node => $node;            node => $node;
402        }      }
403        $Status->{Number}++;
404      } elsif ($ln eq 'assertURIEquals') {
405        $result .= perl_statement 'assertURIEquals ('.
406                     perl_list
407                       ($node->getAttributeNS (undef, 'id'),
408                        perl_code_literal
409                          (to_perl_value ($node->getAttributeNS (undef, 'scheme'),
410                                          default => 'undef')),
411                        perl_code_literal
412                          (to_perl_value ($node->getAttributeNS (undef, 'path'),
413                                          default => 'undef')),
414                        perl_code_literal
415                          (to_perl_value ($node->getAttributeNS (undef, 'host'),
416                                          default => 'undef')),
417                        perl_code_literal
418                          (to_perl_value ($node->getAttributeNS (undef, 'file'),
419                                          default => 'undef')),
420                        perl_code_literal
421                          (to_perl_value ($node->getAttributeNS (undef, 'name'),
422                                          default => 'undef')),
423                        perl_code_literal
424                          (to_perl_value ($node->getAttributeNS (undef, 'query'),
425                                          default => 'undef')),
426                        perl_code_literal
427                          (to_perl_value ($node->getAttributeNS (undef, 'fragment'),
428                                          default => 'undef')),
429                        perl_code_literal
430                          (to_perl_value ($node->getAttributeNS (undef, 'isAbsolute'),
431                                          default => 'undef')),
432                        perl_code_literal
433                          (to_perl_value ($node->getAttributeNS (undef, 'actual')))).
434                   ')';
435      $Status->{Number}++;      $Status->{Number}++;
436    } elsif ($ln eq 'assertDOMException') {    } elsif ($ln eq 'assertDOMException') {
437      $Status->{use}->{'Message::Util::Error'} = 1;      $Status->{use}->{'Message::Util::Error'} = 1;
# Line 309  sub node2code ($) { Line 451  sub node2code ($) {
451          } catch Message::DOM::DOMException with {          } catch Message::DOM::DOMException with {
452            my $err = shift;            my $err = shift;
453            $success = 1 if $err->{-type} eq ].perl_literal ($errname).q[;            $success = 1 if $err->{-type} eq ].perl_literal ($errname).q[;
454          }          };
455          assertTrue (].perl_literal ($node->getAttributeNS (undef, 'id')).          assertTrue (].perl_literal ($node->getAttributeNS (undef, 'id')).
456          q[, $success);          q[, $success);
457        }        }
# Line 319  sub node2code ($) { Line 461  sub node2code ($) {
461      $result .= '$builder->{contentType} eq '.      $result .= '$builder->{contentType} eq '.
462                 perl_literal ($node->getAttributeNS (undef, 'type'));                 perl_literal ($node->getAttributeNS (undef, 'type'));
463      $Status->{our}->{builder} = 1;      $Status->{our}->{builder} = 1;
464      } elsif ($ln eq 'for-each') {
465        my $collection = $node->getAttributeNS (undef, 'collection');
466        my $collType = $Status->{var}->{$collection}->{type};
467        my $coll = to_perl_value ($collection);
468        $result .= 'for (my $i = 0; $i < '.
469                   ({'Collection'=>1,'List'=>1}->{$collType}
470                      ? '@{'.$coll.'}' : $coll.'->length').
471                   '; $i++) {'.
472                     perl_statement
473                       (perl_assign
474                           to_perl_value ($node->getAttributeNS (undef, 'member'))
475                        => $coll . ({'Collection'=>1,'List'=>1}->{$collType}
476                                      ? '->[$i]' : '->item ($i)')).
477                     body2code ($node).
478                   '}';
479      } elsif ($ln eq 'try') {
480        my $children = $node->childNodes;
481        my $true = '';
482        my $false = '';
483        for (my $i = 0; $i < $children->length; $i++) {
484          my $child = $children->item ($i);
485          if ($child->nodeType == $child->ELEMENT_NODE) {
486            if ($child->localName eq 'catch') {
487              valid_err q<Multiple 'catch'es found>, node => $child
488                if $false;
489              my @case;
490              my $children2 = $child->childNodes;
491              for (my $j = 0; $j < $children2->length; $j++) {
492                my $child2 = $children2->item ($j);
493                if ($child2->nodeType == $child2->ELEMENT_NODE) {
494                  if ($child2->localName eq 'ImplementationException') {
495                    valid_err q<Element type not supported>, node => $child2;
496                  } else {
497                    push @case, '$err->{-type} eq '.
498                              perl_literal ($child2->getAttributeNS (undef, 'code'))
499                                => body2code ($child2);
500                  }
501                } else {
502                  $false .= node2code ($child2);
503                }
504              }
505              $false .= perl_cases @case, else => perl_statement '$err->throw';
506            } else {
507              $true .= node2code ($child);
508            }
509          } else {
510            $true .= node2code ($child);
511          }
512        }
513        $result = "try {
514                     $true
515                   } catch Message::DOM::ManakaiDOMException with {
516                     my \$err = shift;
517                     $false
518                   };";
519        $Status->{use}->{'Message::Util::Error'} = 1;
520    } elsif ($ln eq 'if') {    } elsif ($ln eq 'if') {
521      my $children = $node->childNodes;      my $children = $node->childNodes;
522      my $condition;      my $condition;
523      my $true = '';      my $true = '';
524        my $false = '';
525        my $assert_true = 0;
526        my $assert_false = 0;
527      for (my $i = 0; $i < $children->length; $i++) {      for (my $i = 0; $i < $children->length; $i++) {
528        my $child = $children->item ($i);        my $child = $children->item ($i);
529        if ($child->nodeType == $child->ELEMENT_NODE) {        if ($child->nodeType == $child->ELEMENT_NODE) {
# Line 330  sub node2code ($) { Line 531  sub node2code ($) {
531            $condition = node2code ($child);            $condition = node2code ($child);
532          } elsif ($child->localName eq 'else') {          } elsif ($child->localName eq 'else') {
533            valid_err q<Multiple 'else's found>, node => $child            valid_err q<Multiple 'else's found>, node => $child
534              if $true;              if $false;
535            $true = $result;            local $Status->{Number} = 0;
536            $result = '';            $false = body2code ($child);
537              $assert_false = $Status->{Number};
538          } else {          } else {
539            $result .= node2code ($child);            local $Status->{Number} = 0;
540              $true .= node2code ($child);
541              $assert_true += $Status->{Number};
542          }          }
543        } else {        } else {
544          $result .= node2code ($child);          $true .= node2code ($child);
545        }        }
546      }      }
547        if ($assert_true == $assert_false) {
548          $Status->{Number} += $assert_true;
549        } elsif ($assert_true > $assert_false) {
550          $false .= perl_statement ('is_ok ()') x ($assert_true - $assert_false);
551          $Status->{Number} += $assert_true;
552        } else {
553          $true .= perl_statement ('is_ok ()') x ($assert_false - $assert_true);
554          $Status->{Number} += $assert_false;
555        }
556      $result = perl_if      $result = perl_if
557                  $condition,                  $condition,
558                  $true || $result,                  $true,
559                  $true ? $result : undef;                  $false ? $false : undef;
560      } elsif ($ln eq 'while') {
561        my $children = $node->childNodes;
562        my $condition;
563        my $true = '';
564        my $assert = 0;
565        {
566          local $Status->{Number} = 0;
567          for (my $i = 0; $i < $children->length; $i++) {
568            my $child = $children->item ($i);
569            if ($child->nodeType == $child->ELEMENT_NODE) {
570              if (not $condition) {
571                $condition = node2code ($child);
572              } else {
573                $true .= node2code ($child);
574              }
575            } else {
576              $true .= node2code ($child);
577            }
578          }
579          $assert = $Status->{Number};
580        }
581        $Status->{Number} += $assert;
582        $result .= "while ($condition) {
583                      $true
584                    }";
585    } elsif ($ln eq 'or') {    } elsif ($ln eq 'or') {
586      $result .= condition2code ($node, join => 'or');      $result .= condition2code ($node, join => 'or');
587    } elsif ($ln eq 'not') {    } elsif ($ln eq 'not') {
588      $result .= 'not '.condition2code ($node, join => 'nosupport');      $result .= 'not '.condition2code ($node, join => 'nosupport');
589    } elsif ($ln eq 'notNull') {    } elsif ($ln eq 'notNull' or $ln eq 'isNull') {
590      $result .= 'defined '.      $result .= 'defined '.
591                 perl_var (type => '$',                 perl_var (type => '$',
592                           local_name => $node->getAttributeNS (undef, 'obj'));                           local_name => $node->getAttributeNS (undef, 'obj'));
593        $result = 'not ' . $result if $ln eq 'isNull';
594      } elsif ({less => 1, lessOrEquals => 1,
595                greater => 1, greaterOrEquals => 1}->{$ln}) {
596        $result .= to_perl_value ($node->getAttributeNS (undef, 'actual')).
597                   {less => '<', lessOrEquals => '<=',
598                    greater => '>', greaterOrEquals => '>='}->{$ln}.
599                   to_perl_value ($node->getAttributeNS (undef, 'expected'));
600      } elsif ($ln eq 'equals' or $ln eq 'notEquals') {
601        my $case = $node->getAttributeNS (undef, 'ignoreCase');
602        if ($case and $case eq 'auto') {
603          $result .= 'equalsAutoCase (' .
604                       perl_list
605                         ($node->getAttributeNS (undef, 'context') || 'element',
606                          to_perl_value
607                            ($node->getAttributeNS (undef, 'expected')),
608                          to_perl_value
609                            ($node->getAttributeNS (undef, 'actual'))) . ')';
610        } else {
611          my $expected = to_perl_value
612                            ($node->getAttributeNS (undef, 'expected'));
613          my $actual = to_perl_value
614                            ($node->getAttributeNS (undef, 'actual'));
615          if ($case eq 'true') {
616            $result = "(uc ($expected) eq uc ($actual))";
617          } elsif ($node->hasAttributeNS (undef, 'bitmask')) {
618            my $bm = ' & ' . to_perl_value
619                              ($node->getAttributeNS (undef, 'bitmask'));
620            $result = "($expected$bm == $actual$bm)";
621          } else {
622            $result = "($expected eq $actual)";
623          }
624        }
625        $result = "(not $result)" if $ln eq 'notEquals';
626      } elsif ($ln eq 'increment' or $ln eq 'decrement') {
627        $result .= perl_statement
628                     to_perl_value ($node->getAttributeNS (undef, 'var')).
629                     {increment => ' += ', decrement => ' -= '}->{$ln}.
630                     to_perl_value ($node->getAttributeNS (undef, 'value'));
631      } elsif ({qw/plus 1 subtract 1 mult 1 divide 1/}->{$ln}) {
632        $result .= perl_statement
633                     (perl_assign
634                         to_perl_value ($node->getAttributeNS (undef, 'var'))
635                      => to_perl_value ($node->getAttributeNS (undef, 'op1')).
636                         {qw<plus + subtract - mult * divide />}->{$ln}.
637                         to_perl_value ($node->getAttributeNS (undef, 'op2')));
638      } elsif ($ln eq 'append') {
639        $result .= perl_statement
640                     'push @{'.
641                        to_perl_value ($node->getAttributeNS (undef, 'collection')).
642                        '}, '.
643                        to_perl_value ($node->getAttributeNS (undef, 'item'));
644      } elsif ($ln eq 'instanceOf') {
645        $result .= 'isInstanceOf ('.
646                   perl_list ($node->getAttributeNS (undef, 'type'),
647                              perl_code_literal to_perl_value
648                                ($node->getAttributeNS (undef, 'obj'))).
649                   ')';
650      } elsif ($ln eq 'assign') {
651        $result .= perl_statement
652                     perl_assign
653                          to_perl_value ($node->getAttributeNS (undef, 'var'))
654                       => to_perl_value ($node->getAttributeNS (undef, 'value'));
655      } elsif ($ln eq 'fail') {
656        $result .= perl_statement 'fail ('.
657                     perl_literal ($node->getAttributeNS (undef, 'id')). ')';
658    } else {    } else {
659      valid_err q<Unknown element type: >.$ln;      valid_err q<Unknown element type: >.$ln;
660    }    }
Legend:
Removed from v.1.4  
changed lines
  Added in v.1.5
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24