/[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.6 by wakaba, Fri Dec 31 12:03:39 2004 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/;
11    use Getopt::Long;
12    
13  my $Method = {  require 'dommemlist.pl.tmp'; ## Generated by mkdommemlist.pl
14    qw/createEntityReference 1  
15       createTextNode 1  my $output_filename;
16       getAttributeNode 1  my $output_file;
17       getElementsByTagName 1  GetOptions (
18       getNamedItem 1    'output-file=s' => \$output_filename,
19       removeChild 1  );
20       replaceChild 1/  if (defined $output_filename) {
21  };    open $output_file, '>', $output_filename or die "$0: $output_filename: $!";
22  my $Attr = {  } else {
23    qw/attributes 1    $output_file = \*STDOUT;
24       firstChild 1  }
25       item 1  
26       nodeName 1  our $Method;
27       specified 1/  our $IFMethod;
28  };  our $Attr;
29  my $Assert = {  my $Assert = {
30    qw/assertDOMException 1    qw/assertDOMException 1
31         assertEquals 1
32         assertFalse 1
33         assertInstanceOf 1
34       assertNotNull 1       assertNotNull 1
35       assertTrue 1/       assertNull 1
36         assertSame 1
37         assertSize 1
38         assertTrue 1
39         assertURIEquals 1/
40  };  };
41  my $Misc = {  my $Misc = {
42    qw/var 1/    qw/append 1
43         assign 1
44         decrement 1
45         fail 1
46         if 1
47         implementationAttribute 1
48         increment 1
49         for 1
50         plus 1
51         var 1
52         while 1/
53    };
54    my $Condition = {
55      qw/condition 1
56         contains 1
57         contentType 1
58         equals 1
59         greater 1
60         greaterOrEquals 1
61         hasSize 1
62         implementationAttribute 1
63         instanceOf 1
64         isNull 1
65         less 1
66         lessOrEquals 1
67         not 1
68         notEquals 1
69         notNull 1
70         or 1/
71  };  };
72    
73  my $Status;  my $Status = {Number => 0, our => {Info => 1}};
74  our $result = '';  
75    ## Defined in genlib.pl but redefined.
76    sub output_result ($) {
77      print $output_file shift;
78    }
79    
80    sub to_perl_value ($;%) {
81      my ($s, %opt) = @_;
82      if (defined $s) {
83        if ($s =~ /^(?!\d)\w+$/) {
84          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 {
90          return $s;
91        }
92      } elsif (defined $opt{default}) {
93        return $opt{default};
94      } else {
95        return '';
96      }
97    }
98    
99  sub body2code ($) {  sub body2code ($) {
100    my $parent = shift;    my $parent = shift;
# Line 68  sub body2code ($) { Line 126  sub body2code ($) {
126    $result;    $result;
127  }  }
128    
129    sub condition2code ($;%) {
130      my ($parent, %opt) = @_;
131      my $result = '';
132      my @result;
133      my $children = $parent->childNodes;
134      for (my $i = 0; $i < $children->length; $i++) {
135        my $child = $children->item ($i);
136        if ($child->nodeType == $child->ELEMENT_NODE) {
137          my $ln = $child->localName;
138          if ($Condition->{$ln}) {
139            push @result, node2code ($child);
140          } else {
141            valid_err q<Unknown element type: >.$child->localName,
142              node => $child;
143          }
144        } elsif ($child->nodeType == $child->COMMENT_NODE) {
145          $result .= perl_comment $child->data;
146        } elsif ($child->nodeType == $child->TEXT_NODE) {
147          if ($child->data =~ /\S/) {
148            valid_err q<Unknown character data: >.$child->data,
149              node => $child;
150          }
151        } else {
152          valid_err q<Unknown type of node: >.$child->nodeType,
153            node => $child;
154        }
155      }
156      $result .= join (($opt{join}||='or' eq 'or' ? ' || ' :
157                        $opt{join} eq 'and' ? ' && ' :
158                        valid_err q<Multiple condition not supported>,
159                          node => $parent),
160                       map {"($_)"} @result);
161      $result;
162    } #condition2code
163    
164    sub node2code ($);
165  sub node2code ($) {  sub node2code ($) {
166    my $node = shift;    my $node = shift;
167    my $result = '';    my $result = '';
168      if ($node->nodeType != $node->ELEMENT_NODE) {
169        if ($node->nodeType == $node->COMMENT_NODE) {
170          $result .= perl_comment $node->data;
171        } elsif ($node->nodeType == $node->TEXT_NODE) {
172          if ($node->data =~ /\S/) {
173            valid_err q<Unknown character data: >.$node->data,
174              node => $node;
175          }
176        } else {
177          valid_err q<Unknown type of node: >.$node->nodeType,
178            node => $node;
179        }
180        return $result;
181      }
182    my $ln = $node->localName;    my $ln = $node->localName;
183    
184    if ($ln eq 'var') {    if ($ln eq 'var') {
185        $result .= perl_statement      my $name = $node->getAttributeNS (undef, 'name');
186                     perl_var      my $var = perl_var
187                       local_name => $node->getAttributeNS (undef, '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      } elsif ($ln eq 'load') {      }
229        $Status->{var}->{$name}->{type} = $node->getAttributeNS (undef, 'type');
230      } elsif ($ln eq 'load') {
231        $result .= perl_statement        $result .= perl_statement
232                     perl_assign                     perl_assign
233                       perl_var                       perl_var
# Line 96  sub node2code ($) { Line 241  sub node2code ($) {
241                             local_name => $node->getAttributeNS (undef, 'var')).                             local_name => $node->getAttributeNS (undef, 'var')).
242                   ' = '                   ' = '
243          if $node->hasAttributeNS (undef, 'var');          if $node->hasAttributeNS (undef, 'var');
244          my $param;
245          if ($node->hasAttributeNS (undef, 'interface')) {
246            my $if = $node->getAttributeNS (undef, 'interface');
247            $param = $IFMethod->{$if}->{$ln};
248            unless ($param) {
249              valid_err "Method $if.$ln not supported", node => $node;
250            }
251            if ($if eq 'Element' and $ln eq 'getElementsByTagName' and
252                not $node->hasAttributeNS (undef, 'name') and
253                $node->hasAttributeNS (undef, 'tagname')) {
254              $node->setAttributeNS (undef, 'name'
255                                     => $node->getAttributeNS (undef, 'tagname'));
256            }
257          } else {
258            $param = $Method->{$ln};
259          }
260        $result .= perl_var (type => '$',        $result .= perl_var (type => '$',
261                             local_name => $node->getAttributeNS (undef, 'obj')).                             local_name => $node->getAttributeNS (undef, 'obj')).
262                '->'.$ln.' ('.                '->'.$ln.' ('.
263                  ## TODO: parameters                  join (', ',
264                         map {
265                           to_perl_value ($node->getAttributeNS (undef, $_),
266                                          default => 'undef')
267                         } @$param).
268                ");\n";                ");\n";
269      } elsif ($Attr->{$ln}) {      } elsif ($Attr->{$ln}) {
270        if ($node->hasAttributeNS (undef, 'var')) {        if ($node->hasAttributeNS (undef, 'var')) {
271          $result .= perl_var (type => '$',          $result .= perl_var (type => '$',
272                               local_name => $node->getAttributeNS (undef, 'var')).                               local_name => $node->getAttributeNS (undef, 'var')).
273                     ' = ';                     ' = ';
274          } elsif ($node->hasAttributeNS (undef, 'value')) {
275            #
276        } else {        } else {
277          impl_err q<Attr set>;          valid_err q<Unknown operation to an attribute>, node => $node;
278          }
279          my $obj = perl_var (type => '$',
280                              local_name => $node->getAttributeNS (undef, 'obj'));
281          my $if = $node->getAttributeNS (undef, 'interface');
282          if (defined $if and $if eq 'DOMString') {
283            if ($ln eq 'length') {
284              $result .= 'length '.$obj;
285            } else {
286              valid_err q<$if.$ln not supported>, node => $node;
287            }
288          } else {
289            $result .= $obj.'->'.$ln;
290        }        }
       $result .= perl_var (type => '$',  
                            local_name => $node->getAttributeNS (undef, 'obj')).  
               '->'.$ln;  
291        if ($node->hasAttributeNS (undef, 'var')) {        if ($node->hasAttributeNS (undef, 'var')) {
292          $result .= ";\n";          $result .= ";\n";
293          } elsif ($node->hasAttributeNS (undef, 'value')) {
294            $result .= " (".to_perl_value ($node->getAttributeNS (undef, 'value')).
295                       ");\n";
296          }
297        } elsif ($ln eq 'assertEquals') {
298          my $expected = $node->getAttributeNS (undef, 'expected');
299          my $expectedType = $Status->{var}->{$expected}->{type} || '';
300          $result .= 'assertEquals'.
301                     ({Collection => 'Collection',
302                       List => 'List'}->{$expectedType}||'');
303          my $ignoreCase = $node->getAttributeNS (undef, 'ignoreCase') || 'false';
304          if ($ignoreCase eq 'auto') {
305            $result .= 'AutoCase ('.
306                       perl_literal ($node->getAttributeNS (undef, 'context') ||
307                                     'element').
308                       ', ';
309          } else {
310            $result .= ' (';
311        }        }
312      } elsif ($ln eq 'assertTrue') {        $result .= perl_literal ($node->getAttributeNS (undef, 'id')).', ';
313          $result .= join ", ", map {
314                       $ignoreCase eq 'true'
315                         ? ($expectedType eq 'Collection' or
316                            $expectedType eq 'List')
317                             ? "toLowerArray ($_)" : "lc ($_)"
318                         : $_
319                     } map {
320                       to_perl_value ($_)
321                     } (
322                       $expected,
323                       $node->getAttributeNS (undef, 'actual'),
324                     );
325          $result .= ");\n";
326        $Status->{Number}++;
327      } elsif ($ln eq 'assertInstanceOf') {
328        my $obj = perl_code_literal
329                    (to_perl_value ($node->getAttributeNS (undef, 'obj')));
330        $result .= perl_statement 'assertInstanceOf ('.
331                     perl_list
332                       ($node->getAttributeNS (undef, 'id'),
333                        $node->getAttributeNS (undef, 'type'),
334                        $obj).
335                   ')';
336        if ($node->hasChildNodes) {
337          $result .= perl_if
338                       'isInstanceOf ('.
339                       perl_list
340                         ($node->getAttributeNS (undef, 'type'),
341                          $obj) . ')',
342                       body2code ($node);
343        }
344        $Status->{Number}++;
345      } elsif ($ln eq 'assertSame') {
346        my $expected = to_perl_value ($node->getAttributeNS (undef, 'expected'));
347        my $actual = to_perl_value ($node->getAttributeNS (undef, 'actual'));
348        $result .= perl_statement 'assertSame ('.
349                     perl_list
350                       ($node->getAttributeNS (undef, 'id'),
351                        $expected, $actual).
352                   ')';
353        if ($node->hasChildNodes) {
354          $result .= perl_if
355                       'same ('.(perl_list $expected, $actual).')',
356                       body2code ($node);
357        }
358        $Status->{Number}++;
359      } elsif ($ln eq 'assertSize') {
360        my $size = to_perl_value ($node->getAttributeNS (undef, 'size'));
361        my $coll = to_perl_value ($node->getAttributeNS (undef, 'collection'));
362        $result .= perl_statement 'assertSize ('.
363                     perl_list
364                       ($node->getAttributeNS (undef, 'id'),
365                        perl_code_literal $size, perl_code_literal $coll).
366                   ')';
367        if ($node->hasChildNodes) {
368          $result .= perl_if
369                       qq<$size == size ($coll)>,
370                       body2code ($node);
371        }
372        $Status->{Number}++;
373      } elsif ($ln eq 'assertTrue' or $ln eq 'assertFalse') {
374          my $condition;
375        if ($node->hasAttributeNS (undef, 'actual')) {        if ($node->hasAttributeNS (undef, 'actual')) {
376          $result .= perl_statement $ln . ' ('.          $condition = perl_var (type => '$',
                      perl_literal ($node->getAttributeNS (undef, 'id')).', '.  
                      perl_var (type => '$',  
377                                 local_name => $node->getAttributeNS                                 local_name => $node->getAttributeNS
378                                                         (undef, 'actual')).                                                         (undef, 'actual'));
                      ')';  
379          if ($node->hasChildNodes) {          if ($node->hasChildNodes) {
380            valid_err q<Child of $ln found but not supported>,            valid_err q<Child of $ln found but not supported>,
381              node => $node;              node => $node;
382          }          }
383          } elsif ($node->hasChildNodes) {
384            $condition = condition2code ($node);
385        } else {        } else {
386          valid_err q<assertTrue w/o @actual not supported>,        valid_err $ln.q< w/o @actual not supported>, node => $node;
           node => $node;  
387        }        }
388      } elsif ($ln eq 'assertNotNull') {        $result .= perl_statement $ln . ' ('.
389        $result .= perl_statement $ln . ' (' .                       perl_literal ($node->getAttributeNS (undef, 'id')).', '.
390                         $condition. ')';
391        $Status->{Number}++;
392      } elsif ($ln eq 'assertNotNull' or $ln eq 'assertNull') {
393        $result .= perl_statement $ln . ' (' .
394                   perl_literal ($node->getAttributeNS (undef, 'id')).', '.                   perl_literal ($node->getAttributeNS (undef, 'id')).', '.
395                   perl_var (type => '$',                   perl_var (type => '$',
396                             local_name => $node->getAttributeNS (undef, 'actual')).                             local_name => $node->getAttributeNS (undef, 'actual')).
397                   ')';                   ')';
398        if ($node->hasChildNodes) {      if ($node->hasChildNodes) {
399          valid_err q<Child of $ln found but not supported>,        valid_err q<Child of $ln found but not supported>,
400            node => $node;            node => $node;
401        }      }
402        $Status->{Number}++;
403      } elsif ($ln eq 'assertURIEquals') {
404        $result .= perl_statement 'assertURIEquals ('.
405                     perl_list
406                       ($node->getAttributeNS (undef, 'id'),
407                        perl_code_literal
408                          (to_perl_value ($node->getAttributeNS (undef, 'scheme'),
409                                          default => 'undef')),
410                        perl_code_literal
411                          (to_perl_value ($node->getAttributeNS (undef, 'path'),
412                                          default => 'undef')),
413                        perl_code_literal
414                          (to_perl_value ($node->getAttributeNS (undef, 'host'),
415                                          default => 'undef')),
416                        perl_code_literal
417                          (to_perl_value ($node->getAttributeNS (undef, 'file'),
418                                          default => 'undef')),
419                        perl_code_literal
420                          (to_perl_value ($node->getAttributeNS (undef, 'name'),
421                                          default => 'undef')),
422                        perl_code_literal
423                          (to_perl_value ($node->getAttributeNS (undef, 'query'),
424                                          default => 'undef')),
425                        perl_code_literal
426                          (to_perl_value ($node->getAttributeNS (undef, 'fragment'),
427                                          default => 'undef')),
428                        perl_code_literal
429                          (to_perl_value ($node->getAttributeNS (undef, 'isAbsolute'),
430                                          default => 'undef')),
431                        perl_code_literal
432                          (to_perl_value ($node->getAttributeNS (undef, 'actual')))).
433                   ')';
434        $Status->{Number}++;
435    } elsif ($ln eq 'assertDOMException') {    } elsif ($ln eq 'assertDOMException') {
436      $Status->{use}->{'Message::Util::Error'} = 1;      $Status->{use}->{'Message::Util::Error'} = 1;
437      $result .= q[      $result .= q[
# Line 159  sub node2code ($) { Line 450  sub node2code ($) {
450          } catch Message::DOM::DOMException with {          } catch Message::DOM::DOMException with {
451            my $err = shift;            my $err = shift;
452            $success = 1 if $err->{-type} eq ].perl_literal ($errname).q[;            $success = 1 if $err->{-type} eq ].perl_literal ($errname).q[;
453          }          };
454          assertTrue (].perl_literal ($node->getAttributeNS (undef, 'id')).          assertTrue (].perl_literal ($node->getAttributeNS (undef, 'id')).
455          q[, $success);          q[, $success);
456        }        }
457      ];      ];
458        $Status->{Number}++;
459      } elsif ($ln eq 'contentType') {
460        $result .= '$builder->{contentType} eq '.
461                   perl_literal ($node->getAttributeNS (undef, 'type'));
462        $Status->{our}->{builder} = 1;
463      } elsif ($ln eq 'for-each') {
464        my $collection = $node->getAttributeNS (undef, 'collection');
465        my $collType = $Status->{var}->{$collection}->{type};
466        my $coll = to_perl_value ($collection);
467        $result .= 'for (my $i = 0; $i < '.
468                   ({'Collection'=>1,'List'=>1}->{$collType}
469                      ? '@{'.$coll.'}' : $coll.'->length').
470                   '; $i++) {'.
471                     perl_statement
472                       (perl_assign
473                           to_perl_value ($node->getAttributeNS (undef, 'member'))
474                        => $coll . ({'Collection'=>1,'List'=>1}->{$collType}
475                                      ? '->[$i]' : '->item ($i)')).
476                     body2code ($node).
477                   '}';
478      } elsif ($ln eq 'try') {
479        my $children = $node->childNodes;
480        my $true = '';
481        my $false = '';
482        for (my $i = 0; $i < $children->length; $i++) {
483          my $child = $children->item ($i);
484          if ($child->nodeType == $child->ELEMENT_NODE) {
485            if ($child->localName eq 'catch') {
486              valid_err q<Multiple 'catch'es found>, node => $child
487                if $false;
488              my @case;
489              my $children2 = $child->childNodes;
490              for (my $j = 0; $j < $children2->length; $j++) {
491                my $child2 = $children2->item ($j);
492                if ($child2->nodeType == $child2->ELEMENT_NODE) {
493                  if ($child2->localName eq 'ImplementationException') {
494                    valid_err q<Element type not supported>, node => $child2;
495                  } else {
496                    push @case, '$err->{-type} eq '.
497                              perl_literal ($child2->getAttributeNS (undef, 'code'))
498                                => body2code ($child2);
499                  }
500                } else {
501                  $false .= node2code ($child2);
502                }
503              }
504              $false .= perl_cases @case, else => perl_statement '$err->throw';
505            } else {
506              $true .= node2code ($child);
507            }
508          } else {
509            $true .= node2code ($child);
510          }
511        }
512        $result = "try {
513                     $true
514                   } catch Message::DOM::ManakaiDOMException with {
515                     my \$err = shift;
516                     $false
517                   };";
518        $Status->{use}->{'Message::Util::Error'} = 1;
519      } elsif ($ln eq 'if') {
520        my $children = $node->childNodes;
521        my $condition;
522        my $true = '';
523        my $false = '';
524        my $assert_true = 0;
525        my $assert_false = 0;
526        for (my $i = 0; $i < $children->length; $i++) {
527          my $child = $children->item ($i);
528          if ($child->nodeType == $child->ELEMENT_NODE) {
529            if (not $condition) {
530              $condition = node2code ($child);
531            } elsif ($child->localName eq 'else') {
532              valid_err q<Multiple 'else's found>, node => $child
533                if $false;
534              local $Status->{Number} = 0;
535              $false = body2code ($child);
536              $assert_false = $Status->{Number};
537            } else {
538              local $Status->{Number} = 0;
539              $true .= node2code ($child);
540              $assert_true += $Status->{Number};
541            }
542          } else {
543            $true .= node2code ($child);
544          }
545        }
546        if ($assert_true == $assert_false) {
547          $Status->{Number} += $assert_true;
548        } elsif ($assert_true > $assert_false) {
549          $false .= perl_statement ('is_ok ()') x ($assert_true - $assert_false);
550          $Status->{Number} += $assert_true;
551        } else {
552          $true .= perl_statement ('is_ok ()') x ($assert_false - $assert_true);
553          $Status->{Number} += $assert_false;
554        }
555        $result = perl_if
556                    $condition,
557                    $true,
558                    $false ? $false : undef;
559      } elsif ($ln eq 'while') {
560        my $children = $node->childNodes;
561        my $condition;
562        my $true = '';
563        my $assert = 0;
564        {
565          local $Status->{Number} = 0;
566          for (my $i = 0; $i < $children->length; $i++) {
567            my $child = $children->item ($i);
568            if ($child->nodeType == $child->ELEMENT_NODE) {
569              if (not $condition) {
570                $condition = node2code ($child);
571              } else {
572                $true .= node2code ($child);
573              }
574            } else {
575              $true .= node2code ($child);
576            }
577          }
578          $assert = $Status->{Number};
579        }
580        $Status->{Number} += $assert;
581        $result .= "while ($condition) {
582                      $true
583                    }";
584      } elsif ($ln eq 'or') {
585        $result .= condition2code ($node, join => 'or');
586      } elsif ($ln eq 'not') {
587        $result .= 'not '.condition2code ($node, join => 'nosupport');
588      } elsif ($ln eq 'notNull' or $ln eq 'isNull') {
589        $result .= 'defined '.
590                   perl_var (type => '$',
591                             local_name => $node->getAttributeNS (undef, 'obj'));
592        $result = 'not ' . $result if $ln eq 'isNull';
593      } elsif ({less => 1, lessOrEquals => 1,
594                greater => 1, greaterOrEquals => 1}->{$ln}) {
595        $result .= to_perl_value ($node->getAttributeNS (undef, 'actual')).
596                   {less => '<', lessOrEquals => '<=',
597                    greater => '>', greaterOrEquals => '>='}->{$ln}.
598                   to_perl_value ($node->getAttributeNS (undef, 'expected'));
599      } elsif ($ln eq 'equals' or $ln eq 'notEquals') {
600        my $case = $node->getAttributeNS (undef, 'ignoreCase');
601        if ($case and $case eq 'auto') {
602          $result .= 'equalsAutoCase (' .
603                       perl_list
604                         ($node->getAttributeNS (undef, 'context') || 'element',
605                          to_perl_value
606                            ($node->getAttributeNS (undef, 'expected')),
607                          to_perl_value
608                            ($node->getAttributeNS (undef, 'actual'))) . ')';
609        } else {
610          my $expected = to_perl_value
611                            ($node->getAttributeNS (undef, 'expected'));
612          my $actual = to_perl_value
613                            ($node->getAttributeNS (undef, 'actual'));
614          if ($case eq 'true') {
615            $result = "(uc ($expected) eq uc ($actual))";
616          } elsif ($node->hasAttributeNS (undef, 'bitmask')) {
617            my $bm = ' & ' . to_perl_value
618                              ($node->getAttributeNS (undef, 'bitmask'));
619            $result = "($expected$bm == $actual$bm)";
620          } else {
621            $result = "($expected eq $actual)";
622          }
623        }
624        $result = "(not $result)" if $ln eq 'notEquals';
625      } elsif ($ln eq 'increment' or $ln eq 'decrement') {
626        $result .= perl_statement
627                     to_perl_value ($node->getAttributeNS (undef, 'var')).
628                     {increment => ' += ', decrement => ' -= '}->{$ln}.
629                     to_perl_value ($node->getAttributeNS (undef, 'value'));
630      } elsif ({qw/plus 1 subtract 1 mult 1 divide 1/}->{$ln}) {
631        $result .= perl_statement
632                     (perl_assign
633                         to_perl_value ($node->getAttributeNS (undef, 'var'))
634                      => to_perl_value ($node->getAttributeNS (undef, 'op1')).
635                         {qw<plus + subtract - mult * divide />}->{$ln}.
636                         to_perl_value ($node->getAttributeNS (undef, 'op2')));
637      } elsif ($ln eq 'append') {
638        $result .= perl_statement
639                     'push @{'.
640                        to_perl_value ($node->getAttributeNS (undef, 'collection')).
641                        '}, '.
642                        to_perl_value ($node->getAttributeNS (undef, 'item'));
643      } elsif ($ln eq 'instanceOf') {
644        $result .= 'isInstanceOf ('.
645                   perl_list ($node->getAttributeNS (undef, 'type'),
646                              perl_code_literal to_perl_value
647                                ($node->getAttributeNS (undef, 'obj'))).
648                   ')';
649      } elsif ($ln eq 'assign') {
650        $result .= perl_statement
651                     perl_assign
652                          to_perl_value ($node->getAttributeNS (undef, 'var'))
653                       => to_perl_value ($node->getAttributeNS (undef, 'value'));
654      } elsif ($ln eq 'fail') {
655        $result .= perl_statement 'fail ('.
656                     perl_literal ($node->getAttributeNS (undef, 'id')). ')';
657    } else {    } else {
658      valid_err q<Unknown element type: >.$ln;      valid_err q<Unknown element type: >.$ln;
659    }    }
660    $result;    $result;
661  }  }
662    
663    our $result = '';
664    
665  my $input;  my $input;
666  {  {
667    local $/ = undef;    local $/ = undef;
668    $input = <>;    $input = <>;
669  }  }
670    
671  my $dom = Message::DOM::DOMImplementationRegistry  {
672    my $dom = $Message::DOM::DOMImplementationRegistry
673              ->getDOMImplementation              ->getDOMImplementation
674                   ({Core => undef,                   ({Core => undef,
675                     XML => undef,                     XML => undef,
676                     ExpandedURI q<ManakaiDOMLS2003:LS> => '1.0'});                     ExpandedURI q<ManakaiDOMLS2003:LS> => ''});
677    
678  my $parser = $dom->createLSParser (MODE_SYNCHRONOUS);  my $parser = $dom->createLSParser (MODE_SYNCHRONOUS);
679  my $in = $dom->createLSInput;  my $in = $dom->createLSInput;
# Line 218  for (my $i = 0; $i < $child->length; $i+ Line 711  for (my $i = 0; $i < $child->length; $i+
711          my $node = $md->item ($j);          my $node = $md->item ($j);
712          if ($node->nodeType == $node->ELEMENT_NODE) {          if ($node->nodeType == $node->ELEMENT_NODE) {
713            my $ln = $node->localName;            my $ln = $node->localName;
714            if ($ln eq '...') {            if ($ln eq 'title') {
715                            $result .= perl_statement
716                             perl_assign
717                               '$Info->{Name}'
718                             => perl_literal $node->textContent;
719              } elsif ($ln eq 'description') {
720                $result .= perl_statement
721                             perl_assign
722                               '$Info->{Description}'
723                             => perl_literal $node->textContent;
724            } else {            } else {
725            #  valid_err q<Unknown element type: >.$ln,            #  valid_err q<Unknown element type: >.$ln,
726            #    node => $node;            #    node => $node;
# Line 236  for (my $i = 0; $i < $child->length; $i+ Line 737  for (my $i = 0; $i < $child->length; $i+
737              node => $node;              node => $node;
738          }          }
739        }        }
740        } elsif ($ln eq 'implementationAttribute') {
741          $result .= perl_comment
742                         sprintf 'Implementation attribute: @name=%s, @value=%s',
743                                 $node->getAttributeNS (undef, 'name'),
744                                 $node->getAttributeNS (undef, 'value');
745      } else {      } else {
746        $result .= node2code ($node);        $result .= node2code ($node);
747      }      }
# Line 251  for (my $i = 0; $i < $child->length; $i+ Line 757  for (my $i = 0; $i < $child->length; $i+
757        node => $node;        node => $node;
758    }    }
759  }  }
760    }
761    
762    my $pre = "#!/usr/bin/perl -w\nuse strict;\n";
763    $pre .= perl_statement ('require '.perl_literal 'manakai/domtest.pl');
764    $pre .= perl_statement
765                ('use Message::Util::Error')
766      if $Status->{use}->{'Message::Util::Error'};
767    for (keys %{$Status->{our}}) {
768      $pre .= perl_statement perl_var type => '$', local_name => $_,
769                                      scope => 'our';
770    }
771    $pre .= perl_statement q<plan (>.(0+$Status->{Number}).q<)>;
772    
773    output_result $pre.$result;
774    
 output_result $result;  
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.6
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24