/[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.3 by wakaba, Sun Oct 10 06:09:47 2004 UTC revision 1.7 by wakaba, Wed Jan 5 12:19:38 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 24  if (defined $output_filename) { Line 23  if (defined $output_filename) {
23    $output_file = \*STDOUT;    $output_file = \*STDOUT;
24  }  }
25    
26  our $Method;  our $Method;
27    our $IFMethod;
28  our $Attr;  our $Attr;
 our $MethodParam;  
29  my $Assert = {  my $Assert = {
30    qw/assertDOMException 1    qw/assertDOMException 1
31         assertEquals 1
32       assertFalse 1       assertFalse 1
33         assertInstanceOf 1
34       assertNotNull 1       assertNotNull 1
35       assertNull 1       assertNull 1
36       assertTrue 1/       assertSame 1
37         assertSize 1
38         assertTrue 1
39         assertURIEquals 1/
40  };  };
41  my $Misc = {  my $Misc = {
42    qw/if 1    qw/append 1
43         assign 1
44         decrement 1
45         fail 1
46         if 1
47       implementationAttribute 1       implementationAttribute 1
48       var 1/       increment 1
49         for 1
50         plus 1
51         var 1
52         while 1/
53  };  };
54  my $Condition = {  my $Condition = {
55    qw/condition 1    qw/condition 1
56       contains 1       contains 1
57       contentType 1       contentType 1
58         equals 1
59         greater 1
60         greaterOrEquals 1
61       hasSize 1       hasSize 1
62       implementationAttribute 1       implementationAttribute 1
63         instanceOf 1
64         isNull 1
65         less 1
66         lessOrEquals 1
67       not 1       not 1
68         notEquals 1
69       notNull 1       notNull 1
70       or 1/       or 1/
71  };  };
# Line 61  sub to_perl_value ($;%) { Line 81  sub to_perl_value ($;%) {
81    my ($s, %opt) = @_;    my ($s, %opt) = @_;
82    if (defined $s) {    if (defined $s) {
83      if ($s =~ /^(?!\d)\w+$/) {      if ($s =~ /^(?!\d)\w+$/) {
84        return perl_var (type => '$', local_name => $s);        if ({true => 1, false => 1}->{$s}) {
85            return {true => '1', false => '0'}->{$s};
86          } else {
87            return perl_var (type => '$', local_name => $s);
88          }
89      } else {      } else {
90        return $s;        return $s;
91      }      }
# Line 159  sub node2code ($) { Line 183  sub node2code ($) {
183    
184    if ($ln eq 'var') {    if ($ln eq 'var') {
185      my $name = $node->getAttributeNS (undef, 'name');      my $name = $node->getAttributeNS (undef, 'name');
186      $result .= perl_statement      my $var = perl_var
                    perl_var  
187                       local_name => $name,                       local_name => $name,
188                       scope => 'my',                       scope => 'my',
189                       type => '$';                       type => '$';
190      if ($node->getAttributeNS (undef, 'value')) {      my $type = $node->getAttributeNS (undef, 'type');
191        valid_err q<Attribute "value" not supported>, node => $node;      $result .= perl_comment $type;
192        if ($node->hasAttributeNS (undef, 'isNull') and
193            $node->getAttributeNS (undef, 'isNull') eq 'true') {
194          $result .= perl_statement perl_assign $var => 'undef';
195        } elsif ($node->hasAttributeNS (undef, 'value')) {
196          $result .= perl_statement
197                       perl_assign
198                            $var
199                         => to_perl_value ($node->getAttributeNS (undef, 'value'));
200        } else {
201          if ($type eq 'List' or $type eq 'Collection') {
202            my @member;
203            my $children = $node->childNodes;
204            for (my $i = 0; $i < $children->length; $i++) {
205              my $child = $children->item ($i);
206              if ($child->nodeType == $child->ELEMENT_NODE) {
207                if ($child->localName eq 'member') {
208                  push @member, perl_code_literal
209                                  (to_perl_value ($child->textContent));
210                } else {
211                  valid_err q<Unsupported element type>, node => $child;
212                }
213              } elsif ($child->nodeType == $child->COMMENT_NODE) {
214                $result .= perl_comment $child->data;
215              }
216            }
217            $result .= perl_statement
218                         perl_assign
219                              $var
220                           => perl_list \@member;
221          } elsif ($type =~ /Monitor/) {
222            valid_err qq<Type $type not supported>, node => $node;
223          } elsif ($node->hasChildNodes) {
224            valid_err q<Children not supported>, node => $node;
225          } else {
226            $result .= perl_statement $var;
227          }
228      }      }
229      $Status->{var}->{$name}->{type} = $node->getAttributeNS (undef, 'type');      $Status->{var}->{$name}->{type} = $node->getAttributeNS (undef, 'type');
230    } elsif ($ln eq 'load') {    } elsif ($ln eq 'load') {
# Line 177  sub node2code ($) { Line 236  sub node2code ($) {
236                     => 'load (' .                     => 'load (' .
237                        perl_literal ($node->getAttributeNS (undef, 'href')).                        perl_literal ($node->getAttributeNS (undef, 'href')).
238                        ')';                        ')';
239      } elsif ($Method->{$ln}) {    } elsif ($ln eq 'hasFeature' and
240               not $node->hasAttributeNS (undef, 'var')) {
241        ## If there is a "hasFeature" element in "body" and
242        ## it does not have "var" attribute, then it is part of the
243        ## implementation condition.
244        $result .= perl_statement 'hasFeature ('.
245                           to_perl_value ($node->getAttributeNS (undef, 'feature'),
246                                          default => 'undef') . ', '.
247                           to_perl_value ($node->getAttributeNS (undef, 'version'),
248                                          default => 'undef') . ')';
249      } elsif ($Method->{$ln}) {
250        $result .= perl_var (type => '$',        $result .= perl_var (type => '$',
251                             local_name => $node->getAttributeNS (undef, 'var')).                             local_name => $node->getAttributeNS (undef, 'var')).
252                   ' = '                   ' = '
253          if $node->hasAttributeNS (undef, 'var');          if $node->hasAttributeNS (undef, 'var');
254          my $param;
255          if ($node->hasAttributeNS (undef, 'interface')) {
256            my $if = $node->getAttributeNS (undef, 'interface');
257            $param = $IFMethod->{$if}->{$ln};
258            unless ($param) {
259              valid_err "Method $if.$ln not supported", node => $node;
260            }
261            if ($if eq 'Element' and $ln eq 'getElementsByTagName' and
262                not $node->hasAttributeNS (undef, 'name') and
263                $node->hasAttributeNS (undef, 'tagname')) {
264              $node->setAttributeNS (undef, 'name'
265                                     => $node->getAttributeNS (undef, 'tagname'));
266            }
267          } else {
268            $param = $Method->{$ln};
269          }
270        $result .= perl_var (type => '$',        $result .= perl_var (type => '$',
271                             local_name => $node->getAttributeNS (undef, 'obj')).                             local_name => $node->getAttributeNS (undef, 'obj')).
272                '->'.$ln.' ('.                '->'.$ln.' ('.
# Line 189  sub node2code ($) { Line 274  sub node2code ($) {
274                       map {                       map {
275                         to_perl_value ($node->getAttributeNS (undef, $_),                         to_perl_value ($node->getAttributeNS (undef, $_),
276                                        default => 'undef')                                        default => 'undef')
277                       } @{$Method->{$ln}}).                       } @$param).
278                ");\n";                ");\n";
279      } elsif ($Attr->{$ln}) {      } elsif ($Attr->{$ln}) {
280        if ($node->hasAttributeNS (undef, 'var')) {        if ($node->hasAttributeNS (undef, 'var')) {
# Line 201  sub node2code ($) { Line 286  sub node2code ($) {
286        } else {        } else {
287          valid_err q<Unknown operation to an attribute>, node => $node;          valid_err q<Unknown operation to an attribute>, node => $node;
288        }        }
289        $result .= perl_var (type => '$',        my $obj = perl_var (type => '$',
290                             local_name => $node->getAttributeNS (undef, 'obj')).                            local_name => $node->getAttributeNS (undef, 'obj'));
291                '->'.$ln;        my $if = $node->getAttributeNS (undef, 'interface');
292          if (defined $if and $if eq 'DOMString') {
293            if ($ln eq 'length') {
294              $result .= 'length '.$obj;
295            } else {
296              valid_err q<$if.$ln not supported>, node => $node;
297            }
298          } else {
299            $result .= $obj.'->'.$ln;
300          }
301        if ($node->hasAttributeNS (undef, 'var')) {        if ($node->hasAttributeNS (undef, 'var')) {
302          $result .= ";\n";          $result .= ";\n";
303        } elsif ($node->hasAttributeNS (undef, 'value')) {        } elsif ($node->hasAttributeNS (undef, 'value')) {
# Line 240  sub node2code ($) { Line 334  sub node2code ($) {
334                   );                   );
335        $result .= ");\n";        $result .= ");\n";
336      $Status->{Number}++;      $Status->{Number}++;
337      } elsif ($ln eq 'assertInstanceOf') {
338        my $obj = perl_code_literal
339                    (to_perl_value ($node->getAttributeNS (undef, 'obj')));
340        $result .= perl_statement 'assertInstanceOf ('.
341                     perl_list
342                       ($node->getAttributeNS (undef, 'id'),
343                        $node->getAttributeNS (undef, 'type'),
344                        $obj).
345                   ')';
346        if ($node->hasChildNodes) {
347          $result .= perl_if
348                       'isInstanceOf ('.
349                       perl_list
350                         ($node->getAttributeNS (undef, 'type'),
351                          $obj) . ')',
352                       body2code ($node);
353        }
354        $Status->{Number}++;
355      } elsif ($ln eq 'assertSame') {
356        my $expected = to_perl_value ($node->getAttributeNS (undef, 'expected'));
357        my $actual = to_perl_value ($node->getAttributeNS (undef, 'actual'));
358        $result .= perl_statement 'assertSame ('.
359                     perl_list
360                       ($node->getAttributeNS (undef, 'id'),
361                        $expected, $actual).
362                   ')';
363        if ($node->hasChildNodes) {
364          $result .= perl_if
365                       'same ('.(perl_list $expected, $actual).')',
366                       body2code ($node);
367        }
368        $Status->{Number}++;
369      } elsif ($ln eq 'assertSize') {
370        my $size = to_perl_value ($node->getAttributeNS (undef, 'size'));
371        my $coll = to_perl_value ($node->getAttributeNS (undef, 'collection'));
372        $result .= perl_statement 'assertSize ('.
373                     perl_list
374                       ($node->getAttributeNS (undef, 'id'),
375                        perl_code_literal $size, perl_code_literal $coll).
376                   ')';
377        if ($node->hasChildNodes) {
378          $result .= perl_if
379                       qq<$size == size ($coll)>,
380                       body2code ($node);
381        }
382        $Status->{Number}++;
383    } elsif ($ln eq 'assertTrue' or $ln eq 'assertFalse') {    } elsif ($ln eq 'assertTrue' or $ln eq 'assertFalse') {
384        my $condition;        my $condition;
385        if ($node->hasAttributeNS (undef, 'actual')) {        if ($node->hasAttributeNS (undef, 'actual')) {
# Line 259  sub node2code ($) { Line 399  sub node2code ($) {
399                       perl_literal ($node->getAttributeNS (undef, 'id')).', '.                       perl_literal ($node->getAttributeNS (undef, 'id')).', '.
400                       $condition. ')';                       $condition. ')';
401      $Status->{Number}++;      $Status->{Number}++;
402      } elsif ($ln eq 'assertNotNull' or $ln eq 'assertNull') {    } elsif ($ln eq 'assertNotNull' or $ln eq 'assertNull') {
403        $result .= perl_statement $ln . ' (' .      $result .= perl_statement $ln . ' (' .
404                   perl_literal ($node->getAttributeNS (undef, 'id')).', '.                   perl_literal ($node->getAttributeNS (undef, 'id')).', '.
405                   perl_var (type => '$',                   perl_var (type => '$',
406                             local_name => $node->getAttributeNS (undef, 'actual')).                             local_name => $node->getAttributeNS (undef, 'actual')).
407                   ')';                   ')';
408        if ($node->hasChildNodes) {      if ($node->hasChildNodes) {
409          valid_err q<Child of $ln found but not supported>,        valid_err q<Child of $ln found but not supported>,
410            node => $node;            node => $node;
411        }      }
412        $Status->{Number}++;
413      } elsif ($ln eq 'assertURIEquals') {
414        $result .= perl_statement 'assertURIEquals ('.
415                     perl_list
416                       ($node->getAttributeNS (undef, 'id'),
417                        perl_code_literal
418                          (to_perl_value ($node->getAttributeNS (undef, 'scheme'),
419                                          default => 'undef')),
420                        perl_code_literal
421                          (to_perl_value ($node->getAttributeNS (undef, 'path'),
422                                          default => 'undef')),
423                        perl_code_literal
424                          (to_perl_value ($node->getAttributeNS (undef, 'host'),
425                                          default => 'undef')),
426                        perl_code_literal
427                          (to_perl_value ($node->getAttributeNS (undef, 'file'),
428                                          default => 'undef')),
429                        perl_code_literal
430                          (to_perl_value ($node->getAttributeNS (undef, 'name'),
431                                          default => 'undef')),
432                        perl_code_literal
433                          (to_perl_value ($node->getAttributeNS (undef, 'query'),
434                                          default => 'undef')),
435                        perl_code_literal
436                          (to_perl_value ($node->getAttributeNS (undef, 'fragment'),
437                                          default => 'undef')),
438                        perl_code_literal
439                          (to_perl_value ($node->getAttributeNS (undef, 'isAbsolute'),
440                                          default => 'undef')),
441                        perl_code_literal
442                          (to_perl_value ($node->getAttributeNS (undef, 'actual')))).
443                   ')';
444      $Status->{Number}++;      $Status->{Number}++;
445    } elsif ($ln eq 'assertDOMException') {    } elsif ($ln eq 'assertDOMException') {
446      $Status->{use}->{'Message::Util::Error'} = 1;      $Status->{use}->{'Message::Util::Error'} = 1;
# Line 285  sub node2code ($) { Line 457  sub node2code ($) {
457        $result .= body2code ($child);        $result .= body2code ($child);
458      }      }
459      $result .= q[      $result .= q[
460          } catch Message::DOM::DOMException with {          } catch Message::DOM::IF::DOMException with {
461            my $err = shift;            my $err = shift;
462            $success = 1 if $err->{-type} eq ].perl_literal ($errname).q[;            $success = 1 if $err->{-type} eq ].perl_literal ($errname).q[;
463          }          };
464          assertTrue (].perl_literal ($node->getAttributeNS (undef, 'id')).          assertTrue (].perl_literal ($node->getAttributeNS (undef, 'id')).
465          q[, $success);          q[, $success);
466        }        }
# Line 298  sub node2code ($) { Line 470  sub node2code ($) {
470      $result .= '$builder->{contentType} eq '.      $result .= '$builder->{contentType} eq '.
471                 perl_literal ($node->getAttributeNS (undef, 'type'));                 perl_literal ($node->getAttributeNS (undef, 'type'));
472      $Status->{our}->{builder} = 1;      $Status->{our}->{builder} = 1;
473      } elsif ($ln eq 'for-each') {
474        my $collection = $node->getAttributeNS (undef, 'collection');
475        my $collType = $Status->{var}->{$collection}->{type};
476        my $coll = to_perl_value ($collection);
477        $result .= 'for (my $i = 0; $i < '.
478                   ({'Collection'=>1,'List'=>1}->{$collType}
479                      ? '@{'.$coll.'}' : $coll.'->length').
480                   '; $i++) {'.
481                     perl_statement
482                       (perl_assign
483                           to_perl_value ($node->getAttributeNS (undef, 'member'))
484                        => $coll . ({'Collection'=>1,'List'=>1}->{$collType}
485                                      ? '->[$i]' : '->item ($i)')).
486                     body2code ($node).
487                   '}';
488      } elsif ($ln eq 'try') {
489        my $children = $node->childNodes;
490        my $true = '';
491        my $false = '';
492        for (my $i = 0; $i < $children->length; $i++) {
493          my $child = $children->item ($i);
494          if ($child->nodeType == $child->ELEMENT_NODE) {
495            if ($child->localName eq 'catch') {
496              valid_err q<Multiple 'catch'es found>, node => $child
497                if $false;
498              my @case;
499              my $children2 = $child->childNodes;
500              for (my $j = 0; $j < $children2->length; $j++) {
501                my $child2 = $children2->item ($j);
502                if ($child2->nodeType == $child2->ELEMENT_NODE) {
503                  if ($child2->localName eq 'ImplementationException') {
504                    valid_err q<Element type not supported>, node => $child2;
505                  } else {
506                    push @case, '$err->{-type} eq '.
507                              perl_literal ($child2->getAttributeNS (undef, 'code'))
508                                => body2code ($child2);
509                  }
510                } else {
511                  $false .= node2code ($child2);
512                }
513              }
514              $false .= perl_cases @case, else => perl_statement '$err->throw';
515            } else {
516              $true .= node2code ($child);
517            }
518          } else {
519            $true .= node2code ($child);
520          }
521        }
522        $result = "try {
523                     $true
524                   } catch Message::DOM::DOMMain::ManakaiDOMException with {
525                     my \$err = shift;
526                     $false
527                   };";
528        $Status->{use}->{'Message::Util::Error'} = 1;
529    } elsif ($ln eq 'if') {    } elsif ($ln eq 'if') {
530      my $children = $node->childNodes;      my $children = $node->childNodes;
531      my $condition;      my $condition;
532      my $true = '';      my $true = '';
533        my $false = '';
534        my $assert_true = 0;
535        my $assert_false = 0;
536      for (my $i = 0; $i < $children->length; $i++) {      for (my $i = 0; $i < $children->length; $i++) {
537        my $child = $children->item ($i);        my $child = $children->item ($i);
538        if ($child->nodeType == $child->ELEMENT_NODE) {        if ($child->nodeType == $child->ELEMENT_NODE) {
# Line 309  sub node2code ($) { Line 540  sub node2code ($) {
540            $condition = node2code ($child);            $condition = node2code ($child);
541          } elsif ($child->localName eq 'else') {          } elsif ($child->localName eq 'else') {
542            valid_err q<Multiple 'else's found>, node => $child            valid_err q<Multiple 'else's found>, node => $child
543              if $true;              if $false;
544            $true = $result;            local $Status->{Number} = 0;
545            $result = '';            $false = body2code ($child);
546              $assert_false = $Status->{Number};
547          } else {          } else {
548            $result .= node2code ($child);            local $Status->{Number} = 0;
549              $true .= node2code ($child);
550              $assert_true += $Status->{Number};
551          }          }
552        } else {        } else {
553          $result .= node2code ($child);          $true .= node2code ($child);
554        }        }
555      }      }
556        if ($assert_true == $assert_false) {
557          $Status->{Number} += $assert_true;
558        } elsif ($assert_true > $assert_false) {
559          $false .= perl_statement ('is_ok ()') x ($assert_true - $assert_false);
560          $Status->{Number} += $assert_true;
561        } else {
562          $true .= perl_statement ('is_ok ()') x ($assert_false - $assert_true);
563          $Status->{Number} += $assert_false;
564        }
565      $result = perl_if      $result = perl_if
566                  $condition,                  $condition,
567                  $true || $result,                  $true,
568                  $true ? $result : undef;                  $false ? $false : undef;
569      } elsif ($ln eq 'while') {
570        my $children = $node->childNodes;
571        my $condition;
572        my $true = '';
573        my $assert = 0;
574        {
575          local $Status->{Number} = 0;
576          for (my $i = 0; $i < $children->length; $i++) {
577            my $child = $children->item ($i);
578            if ($child->nodeType == $child->ELEMENT_NODE) {
579              if (not $condition) {
580                $condition = node2code ($child);
581              } else {
582                $true .= node2code ($child);
583              }
584            } else {
585              $true .= node2code ($child);
586            }
587          }
588          $assert = $Status->{Number};
589        }
590        $Status->{Number} += $assert;
591        $result .= "while ($condition) {
592                      $true
593                    }";
594    } elsif ($ln eq 'or') {    } elsif ($ln eq 'or') {
595      $result .= condition2code ($node, join => 'or');      $result .= condition2code ($node, join => 'or');
596    } elsif ($ln eq 'not') {    } elsif ($ln eq 'not') {
597      $result .= 'not '.condition2code ($node, join => 'nosupport');      $result .= 'not '.condition2code ($node, join => 'nosupport');
598    } elsif ($ln eq 'notNull') {    } elsif ($ln eq 'notNull' or $ln eq 'isNull') {
599      $result .= 'defined '.      $result .= 'defined '.
600                 perl_var (type => '$',                 perl_var (type => '$',
601                           local_name => $node->getAttributeNS (undef, 'obj'));                           local_name => $node->getAttributeNS (undef, 'obj'));
602        $result = 'not ' . $result if $ln eq 'isNull';
603      } elsif ({less => 1, lessOrEquals => 1,
604                greater => 1, greaterOrEquals => 1}->{$ln}) {
605        $result .= to_perl_value ($node->getAttributeNS (undef, 'actual')).
606                   {less => '<', lessOrEquals => '<=',
607                    greater => '>', greaterOrEquals => '>='}->{$ln}.
608                   to_perl_value ($node->getAttributeNS (undef, 'expected'));
609      } elsif ($ln eq 'equals' or $ln eq 'notEquals') {
610        my $case = $node->getAttributeNS (undef, 'ignoreCase');
611        if ($case and $case eq 'auto') {
612          $result .= 'equalsAutoCase (' .
613                       perl_list
614                         ($node->getAttributeNS (undef, 'context') || 'element',
615                          to_perl_value
616                            ($node->getAttributeNS (undef, 'expected')),
617                          to_perl_value
618                            ($node->getAttributeNS (undef, 'actual'))) . ')';
619        } else {
620          my $expected = to_perl_value
621                            ($node->getAttributeNS (undef, 'expected'));
622          my $actual = to_perl_value
623                            ($node->getAttributeNS (undef, 'actual'));
624          if ($case eq 'true') {
625            $result = "(uc ($expected) eq uc ($actual))";
626          } elsif ($node->hasAttributeNS (undef, 'bitmask')) {
627            my $bm = ' & ' . to_perl_value
628                              ($node->getAttributeNS (undef, 'bitmask'));
629            $result = "($expected$bm == $actual$bm)";
630          } else {
631            $result = "($expected eq $actual)";
632          }
633        }
634        $result = "(not $result)" if $ln eq 'notEquals';
635      } elsif ($ln eq 'increment' or $ln eq 'decrement') {
636        $result .= perl_statement
637                     to_perl_value ($node->getAttributeNS (undef, 'var')).
638                     {increment => ' += ', decrement => ' -= '}->{$ln}.
639                     to_perl_value ($node->getAttributeNS (undef, 'value'));
640      } elsif ({qw/plus 1 subtract 1 mult 1 divide 1/}->{$ln}) {
641        $result .= perl_statement
642                     (perl_assign
643                         to_perl_value ($node->getAttributeNS (undef, 'var'))
644                      => to_perl_value ($node->getAttributeNS (undef, 'op1')).
645                         {qw<plus + subtract - mult * divide />}->{$ln}.
646                         to_perl_value ($node->getAttributeNS (undef, 'op2')));
647      } elsif ($ln eq 'append') {
648        $result .= perl_statement
649                     'push @{'.
650                        to_perl_value ($node->getAttributeNS (undef, 'collection')).
651                        '}, '.
652                        to_perl_value ($node->getAttributeNS (undef, 'item'));
653      } elsif ($ln eq 'instanceOf') {
654        $result .= 'isInstanceOf ('.
655                   perl_list ($node->getAttributeNS (undef, 'type'),
656                              perl_code_literal to_perl_value
657                                ($node->getAttributeNS (undef, 'obj'))).
658                   ')';
659      } elsif ($ln eq 'assign') {
660        $result .= perl_statement
661                     perl_assign
662                          to_perl_value ($node->getAttributeNS (undef, 'var'))
663                       => to_perl_value ($node->getAttributeNS (undef, 'value'));
664      } elsif ($ln eq 'fail') {
665        $result .= perl_statement 'fail ('.
666                     perl_literal ($node->getAttributeNS (undef, 'id')). ')';
667    } else {    } else {
668      valid_err q<Unknown element type: >.$ln;      valid_err q<Unknown element type: >.$ln;
669    }    }
# Line 346  my $input; Line 679  my $input;
679  }  }
680    
681  {  {
682  my $dom = Message::DOM::DOMImplementationRegistry  my $dom = $Message::DOM::DOMImplementationRegistry
683              ->getDOMImplementation              ->getDOMImplementation
684                   ({Core => undef,                   ({Core => undef,
685                     XML => undef,                     XML => undef,
686                     ExpandedURI q<ManakaiDOMLS2003:LS> => '1.0'});                     ExpandedURI q<ManakaiDOMLS2003:LS> => ''});
687    
688  my $parser = $dom->createLSParser (MODE_SYNCHRONOUS);  my $parser = $dom->createLSParser (MODE_SYNCHRONOUS);
689  my $in = $dom->createLSInput;  my $in = $dom->createLSInput;
# Line 415  for (my $i = 0; $i < $child->length; $i+ Line 748  for (my $i = 0; $i < $child->length; $i+
748          }          }
749        }        }
750      } elsif ($ln eq 'implementationAttribute') {      } elsif ($ln eq 'implementationAttribute') {
751        $result .= perl_comment        $result .= perl_statement 'impl_attr ('.
752                       sprintf 'Implementation attribute: @name=%s, @value=%s',                           perl_list
753                               $node->getAttributeNS (undef, 'name'),                               ($node->getAttributeNS (undef, 'name'),
754                               $node->getAttributeNS (undef, 'value');                                $node->getAttributeNS (undef, 'value')).')';
755      } else {      } else {
756        $result .= node2code ($node);        $result .= node2code ($node);
757      }      }
# Line 449  $pre .= perl_statement q<plan (>.(0+$Sta Line 782  $pre .= perl_statement q<plan (>.(0+$Sta
782    
783  output_result $pre.$result;  output_result $pre.$result;
784    
785    1;
786    
787    __END__
788    
789    =head1 NAME
790    
791    domtest2perl - DOM Test Suite XML Test File to Perl Test Code Converter
792    
793    =head1 SYNOPSIS
794    
795      perl path/to/domtest2perl.pl input.xml > output.pl
796      perl path/to/domtest2perl.pl input.xml --output-file=output.pl
797    
798    =over 4
799    
800    =item I<input.xml>
801    
802    The name of file to input.  It should be an XML document
803    in the DOM Test Suite.
804    
805    =item I<output.pl>
806    
807    The name of file to output.  It is overwritten if already exists.
808    
809    =back
810    
811    =head1 SEE ALSO
812    
813    I<Document Object Model (DOM) Conformance Test Suites>,
814    <http://www.w3.org/DOM/Test/>.
815    
816    F<domts2perl.pl>
817    
818    F<mkdommemlist.pl>
819    
820    =head1 LICENSE
821    
822    Copyright 2004-2005 Wakaba <w@suika.fam.cx>.  All rights reserved.
823    
824    This program is free software; you can redistribute it and/or
825    modify it under the same terms as Perl itself.
826    
827    =cut
828    
Legend:
Removed from v.1.3  
changed lines
  Added in v.1.7
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24