/[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.5 by wakaba, Sun Oct 31 12:29:00 2004 UTC
# Line 9  use Message::Util::QName::General [qw/Ex Line 9  use Message::Util::QName::General [qw/Ex
9  };  };
10  use Message::DOM::ManakaiDOMLS2003;  use Message::DOM::ManakaiDOMLS2003;
11  use Message::DOM::DOMLS qw/MODE_SYNCHRONOUS/;  use Message::DOM::DOMLS qw/MODE_SYNCHRONOUS/;
12    use Getopt::Long;
13    
14  my $Method = {  require 'dommemlist.pl.tmp'; ## Generated by mkdommemlist.pl
15    qw/createEntityReference 1  
16       createTextNode 1  my $output_filename;
17       getAttributeNode 1  my $output_file;
18       getElementsByTagName 1  GetOptions (
19       getNamedItem 1    'output-file=s' => \$output_filename,
20       removeChild 1  );
21       replaceChild 1/  if (defined $output_filename) {
22  };    open $output_file, '>', $output_filename or die "$0: $output_filename: $!";
23  my $Attr = {  } else {
24    qw/attributes 1    $output_file = \*STDOUT;
25       firstChild 1  }
26       item 1  
27       nodeName 1  our $Method;
28       specified 1/  our $IFMethod;
29  };  our $Attr;
30  my $Assert = {  my $Assert = {
31    qw/assertDOMException 1    qw/assertDOMException 1
32         assertEquals 1
33         assertFalse 1
34         assertInstanceOf 1
35       assertNotNull 1       assertNotNull 1
36       assertTrue 1/       assertNull 1
37         assertSame 1
38         assertSize 1
39         assertTrue 1
40         assertURIEquals 1/
41  };  };
42  my $Misc = {  my $Misc = {
43    qw/var 1/    qw/append 1
44         assign 1
45         decrement 1
46         fail 1
47         if 1
48         implementationAttribute 1
49         increment 1
50         for 1
51         plus 1
52         var 1
53         while 1/
54    };
55    my $Condition = {
56      qw/condition 1
57         contains 1
58         contentType 1
59         equals 1
60         greater 1
61         greaterOrEquals 1
62         hasSize 1
63         implementationAttribute 1
64         instanceOf 1
65         isNull 1
66         less 1
67         lessOrEquals 1
68         not 1
69         notEquals 1
70         notNull 1
71         or 1/
72  };  };
73    
74  my $Status;  my $Status = {Number => 0, our => {Info => 1}};
75  our $result = '';  
76    ## Defined in genlib.pl but redefined.
77    sub output_result ($) {
78      print $output_file shift;
79    }
80    
81    sub to_perl_value ($;%) {
82      my ($s, %opt) = @_;
83      if (defined $s) {
84        if ($s =~ /^(?!\d)\w+$/) {
85          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 {
91          return $s;
92        }
93      } elsif (defined $opt{default}) {
94        return $opt{default};
95      } else {
96        return '';
97      }
98    }
99    
100  sub body2code ($) {  sub body2code ($) {
101    my $parent = shift;    my $parent = shift;
# Line 68  sub body2code ($) { Line 127  sub body2code ($) {
127    $result;    $result;
128  }  }
129    
130    sub condition2code ($;%) {
131      my ($parent, %opt) = @_;
132      my $result = '';
133      my @result;
134      my $children = $parent->childNodes;
135      for (my $i = 0; $i < $children->length; $i++) {
136        my $child = $children->item ($i);
137        if ($child->nodeType == $child->ELEMENT_NODE) {
138          my $ln = $child->localName;
139          if ($Condition->{$ln}) {
140            push @result, node2code ($child);
141          } else {
142            valid_err q<Unknown element type: >.$child->localName,
143              node => $child;
144          }
145        } elsif ($child->nodeType == $child->COMMENT_NODE) {
146          $result .= perl_comment $child->data;
147        } elsif ($child->nodeType == $child->TEXT_NODE) {
148          if ($child->data =~ /\S/) {
149            valid_err q<Unknown character data: >.$child->data,
150              node => $child;
151          }
152        } else {
153          valid_err q<Unknown type of node: >.$child->nodeType,
154            node => $child;
155        }
156      }
157      $result .= join (($opt{join}||='or' eq 'or' ? ' || ' :
158                        $opt{join} eq 'and' ? ' && ' :
159                        valid_err q<Multiple condition not supported>,
160                          node => $parent),
161                       map {"($_)"} @result);
162      $result;
163    } #condition2code
164    
165    sub node2code ($);
166  sub node2code ($) {  sub node2code ($) {
167    my $node = shift;    my $node = shift;
168    my $result = '';    my $result = '';
169      if ($node->nodeType != $node->ELEMENT_NODE) {
170        if ($node->nodeType == $node->COMMENT_NODE) {
171          $result .= perl_comment $node->data;
172        } elsif ($node->nodeType == $node->TEXT_NODE) {
173          if ($node->data =~ /\S/) {
174            valid_err q<Unknown character data: >.$node->data,
175              node => $node;
176          }
177        } else {
178          valid_err q<Unknown type of node: >.$node->nodeType,
179            node => $node;
180        }
181        return $result;
182      }
183    my $ln = $node->localName;    my $ln = $node->localName;
184    
185    if ($ln eq 'var') {    if ($ln eq 'var') {
186        $result .= perl_statement      my $name = $node->getAttributeNS (undef, 'name');
187                     perl_var      my $var = perl_var
188                       local_name => $node->getAttributeNS (undef, '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      } elsif ($ln eq 'load') {      }
230        $Status->{var}->{$name}->{type} = $node->getAttributeNS (undef, 'type');
231      } elsif ($ln eq 'load') {
232        $result .= perl_statement        $result .= perl_statement
233                     perl_assign                     perl_assign
234                       perl_var                       perl_var
# Line 96  sub node2code ($) { Line 242  sub node2code ($) {
242                             local_name => $node->getAttributeNS (undef, 'var')).                             local_name => $node->getAttributeNS (undef, 'var')).
243                   ' = '                   ' = '
244          if $node->hasAttributeNS (undef, 'var');          if $node->hasAttributeNS (undef, 'var');
245          my $param;
246          if ($node->hasAttributeNS (undef, 'interface')) {
247            my $if = $node->getAttributeNS (undef, 'interface');
248            $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 {
259            $param = $Method->{$ln};
260          }
261        $result .= perl_var (type => '$',        $result .= perl_var (type => '$',
262                             local_name => $node->getAttributeNS (undef, 'obj')).                             local_name => $node->getAttributeNS (undef, 'obj')).
263                '->'.$ln.' ('.                '->'.$ln.' ('.
264                  ## TODO: parameters                  join (', ',
265                         map {
266                           to_perl_value ($node->getAttributeNS (undef, $_),
267                                          default => 'undef')
268                         } @$param).
269                ");\n";                ");\n";
270      } elsif ($Attr->{$ln}) {      } elsif ($Attr->{$ln}) {
271        if ($node->hasAttributeNS (undef, 'var')) {        if ($node->hasAttributeNS (undef, 'var')) {
272          $result .= perl_var (type => '$',          $result .= perl_var (type => '$',
273                               local_name => $node->getAttributeNS (undef, 'var')).                               local_name => $node->getAttributeNS (undef, 'var')).
274                     ' = ';                     ' = ';
275          } elsif ($node->hasAttributeNS (undef, 'value')) {
276            #
277        } else {        } else {
278          impl_err q<Attr set>;          valid_err q<Unknown operation to an attribute>, node => $node;
279          }
280          my $obj = perl_var (type => '$',
281                              local_name => $node->getAttributeNS (undef, 'obj'));
282          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        }        }
       $result .= perl_var (type => '$',  
                            local_name => $node->getAttributeNS (undef, 'obj')).  
               '->'.$ln;  
292        if ($node->hasAttributeNS (undef, 'var')) {        if ($node->hasAttributeNS (undef, 'var')) {
293          $result .= ";\n";          $result .= ";\n";
294          } elsif ($node->hasAttributeNS (undef, 'value')) {
295            $result .= " (".to_perl_value ($node->getAttributeNS (undef, 'value')).
296                       ");\n";
297          }
298        } elsif ($ln eq 'assertEquals') {
299          my $expected = $node->getAttributeNS (undef, 'expected');
300          my $expectedType = $Status->{var}->{$expected}->{type} || '';
301          $result .= 'assertEquals'.
302                     ({Collection => 'Collection',
303                       List => 'List'}->{$expectedType}||'');
304          my $ignoreCase = $node->getAttributeNS (undef, 'ignoreCase') || 'false';
305          if ($ignoreCase eq 'auto') {
306            $result .= 'AutoCase ('.
307                       perl_literal ($node->getAttributeNS (undef, 'context') ||
308                                     'element').
309                       ', ';
310          } else {
311            $result .= ' (';
312        }        }
313      } elsif ($ln eq 'assertTrue') {        $result .= perl_literal ($node->getAttributeNS (undef, 'id')).', ';
314          $result .= join ", ", map {
315                       $ignoreCase eq 'true'
316                         ? ($expectedType eq 'Collection' or
317                            $expectedType eq 'List')
318                             ? "toLowerArray ($_)" : "lc ($_)"
319                         : $_
320                     } map {
321                       to_perl_value ($_)
322                     } (
323                       $expected,
324                       $node->getAttributeNS (undef, 'actual'),
325                     );
326          $result .= ");\n";
327        $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') {
361        my $size = to_perl_value ($node->getAttributeNS (undef, 'size'));
362        my $coll = to_perl_value ($node->getAttributeNS (undef, 'collection'));
363        $result .= perl_statement 'assertSize ('.
364                     perl_list
365                       ($node->getAttributeNS (undef, 'id'),
366                        perl_code_literal $size, perl_code_literal $coll).
367                   ')';
368        if ($node->hasChildNodes) {
369          $result .= perl_if
370                       qq<$size == size ($coll)>,
371                       body2code ($node);
372        }
373        $Status->{Number}++;
374      } elsif ($ln eq 'assertTrue' or $ln eq 'assertFalse') {
375          my $condition;
376        if ($node->hasAttributeNS (undef, 'actual')) {        if ($node->hasAttributeNS (undef, 'actual')) {
377          $result .= perl_statement $ln . ' ('.          $condition = perl_var (type => '$',
                      perl_literal ($node->getAttributeNS (undef, 'id')).', '.  
                      perl_var (type => '$',  
378                                 local_name => $node->getAttributeNS                                 local_name => $node->getAttributeNS
379                                                         (undef, 'actual')).                                                         (undef, 'actual'));
                      ')';  
380          if ($node->hasChildNodes) {          if ($node->hasChildNodes) {
381            valid_err q<Child of $ln found but not supported>,            valid_err q<Child of $ln found but not supported>,
382              node => $node;              node => $node;
383          }          }
384          } elsif ($node->hasChildNodes) {
385            $condition = condition2code ($node);
386        } else {        } else {
387          valid_err q<assertTrue w/o @actual not supported>,        valid_err $ln.q< w/o @actual not supported>, node => $node;
           node => $node;  
388        }        }
389      } elsif ($ln eq 'assertNotNull') {        $result .= perl_statement $ln . ' ('.
390        $result .= perl_statement $ln . ' (' .                       perl_literal ($node->getAttributeNS (undef, 'id')).', '.
391                         $condition. ')';
392        $Status->{Number}++;
393      } elsif ($ln eq 'assertNotNull' or $ln eq 'assertNull') {
394        $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}++;
436    } elsif ($ln eq 'assertDOMException') {    } elsif ($ln eq 'assertDOMException') {
437      $Status->{use}->{'Message::Util::Error'} = 1;      $Status->{use}->{'Message::Util::Error'} = 1;
438      $result .= q[      $result .= q[
# Line 159  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        }        }
458      ];      ];
459        $Status->{Number}++;
460      } elsif ($ln eq 'contentType') {
461        $result .= '$builder->{contentType} eq '.
462                   perl_literal ($node->getAttributeNS (undef, 'type'));
463        $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') {
521        my $children = $node->childNodes;
522        my $condition;
523        my $true = '';
524        my $false = '';
525        my $assert_true = 0;
526        my $assert_false = 0;
527        for (my $i = 0; $i < $children->length; $i++) {
528          my $child = $children->item ($i);
529          if ($child->nodeType == $child->ELEMENT_NODE) {
530            if (not $condition) {
531              $condition = node2code ($child);
532            } elsif ($child->localName eq 'else') {
533              valid_err q<Multiple 'else's found>, node => $child
534                if $false;
535              local $Status->{Number} = 0;
536              $false = body2code ($child);
537              $assert_false = $Status->{Number};
538            } else {
539              local $Status->{Number} = 0;
540              $true .= node2code ($child);
541              $assert_true += $Status->{Number};
542            }
543          } else {
544            $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
557                    $condition,
558                    $true,
559                    $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') {
586        $result .= condition2code ($node, join => 'or');
587      } elsif ($ln eq 'not') {
588        $result .= 'not '.condition2code ($node, join => 'nosupport');
589      } elsif ($ln eq 'notNull' or $ln eq 'isNull') {
590        $result .= 'defined '.
591                   perl_var (type => '$',
592                             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    }    }
661    $result;    $result;
662  }  }
663    
664    our $result = '';
665    
666  my $input;  my $input;
667  {  {
668    local $/ = undef;    local $/ = undef;
669    $input = <>;    $input = <>;
670  }  }
671    
672    {
673  my $dom = Message::DOM::DOMImplementationRegistry  my $dom = Message::DOM::DOMImplementationRegistry
674              ->getDOMImplementation              ->getDOMImplementation
675                   ({Core => undef,                   ({Core => undef,
# Line 218  for (my $i = 0; $i < $child->length; $i+ Line 712  for (my $i = 0; $i < $child->length; $i+
712          my $node = $md->item ($j);          my $node = $md->item ($j);
713          if ($node->nodeType == $node->ELEMENT_NODE) {          if ($node->nodeType == $node->ELEMENT_NODE) {
714            my $ln = $node->localName;            my $ln = $node->localName;
715            if ($ln eq '...') {            if ($ln eq 'title') {
716                            $result .= perl_statement
717                             perl_assign
718                               '$Info->{Name}'
719                             => perl_literal $node->textContent;
720              } elsif ($ln eq 'description') {
721                $result .= perl_statement
722                             perl_assign
723                               '$Info->{Description}'
724                             => perl_literal $node->textContent;
725            } else {            } else {
726            #  valid_err q<Unknown element type: >.$ln,            #  valid_err q<Unknown element type: >.$ln,
727            #    node => $node;            #    node => $node;
# Line 236  for (my $i = 0; $i < $child->length; $i+ Line 738  for (my $i = 0; $i < $child->length; $i+
738              node => $node;              node => $node;
739          }          }
740        }        }
741        } elsif ($ln eq 'implementationAttribute') {
742          $result .= perl_comment
743                         sprintf 'Implementation attribute: @name=%s, @value=%s',
744                                 $node->getAttributeNS (undef, 'name'),
745                                 $node->getAttributeNS (undef, 'value');
746      } else {      } else {
747        $result .= node2code ($node);        $result .= node2code ($node);
748      }      }
# Line 251  for (my $i = 0; $i < $child->length; $i+ Line 758  for (my $i = 0; $i < $child->length; $i+
758        node => $node;        node => $node;
759    }    }
760  }  }
761    }
762    
763    my $pre = "#!/usr/bin/perl -w\nuse strict;\n";
764    $pre .= perl_statement ('require '.perl_literal 'manakai/domtest.pl');
765    $pre .= perl_statement
766                ('use Message::Util::Error')
767      if $Status->{use}->{'Message::Util::Error'};
768    for (keys %{$Status->{our}}) {
769      $pre .= perl_statement perl_var type => '$', local_name => $_,
770                                      scope => 'our';
771    }
772    $pre .= perl_statement q<plan (>.(0+$Status->{Number}).q<)>;
773    
774    output_result $pre.$result;
775    
 output_result $result;  
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.5
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24