/[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.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/;
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 91  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.' ('.
273                  ## TODO: parameters                  join (', ',
274                         map {
275                           to_perl_value ($node->getAttributeNS (undef, $_),
276                                          default => 'undef')
277                         } @$param).
278                ");\n";                ");\n";
279      } elsif ($Attr->{$ln}) {      } elsif ($Attr->{$ln}) {
280        if ($node->hasAttributeNS (undef, 'var')) {        if ($node->hasAttributeNS (undef, 'var')) {
281          $result .= perl_var (type => '$',          $result .= perl_var (type => '$',
282                               local_name => $node->getAttributeNS (undef, 'var')).                               local_name => $node->getAttributeNS (undef, 'var')).
283                     ' = ';                     ' = ';
284          } elsif ($node->hasAttributeNS (undef, 'value')) {
285            #
286        } else {        } else {
287          impl_err q<Attr set>;          valid_err q<Unknown operation to an attribute>, node => $node;
288          }
289          my $obj = perl_var (type => '$',
290                              local_name => $node->getAttributeNS (undef, 'obj'));
291          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        }        }
       $result .= perl_var (type => '$',  
                            local_name => $node->getAttributeNS (undef, 'obj')).  
               '->'.$ln;  
301        if ($node->hasAttributeNS (undef, 'var')) {        if ($node->hasAttributeNS (undef, 'var')) {
302          $result .= ";\n";          $result .= ";\n";
303          } elsif ($node->hasAttributeNS (undef, 'value')) {
304            $result .= " (".to_perl_value ($node->getAttributeNS (undef, 'value')).
305                       ");\n";
306          }
307        } elsif ($ln eq 'assertEquals') {
308          my $expected = $node->getAttributeNS (undef, 'expected');
309          my $expectedType = $Status->{var}->{$expected}->{type} || '';
310          $result .= 'assertEquals'.
311                     ({Collection => 'Collection',
312                       List => 'List'}->{$expectedType}||'');
313          my $ignoreCase = $node->getAttributeNS (undef, 'ignoreCase') || 'false';
314          if ($ignoreCase eq 'auto') {
315            $result .= 'AutoCase ('.
316                       perl_literal ($node->getAttributeNS (undef, 'context') ||
317                                     'element').
318                       ', ';
319          } else {
320            $result .= ' (';
321        }        }
322      } elsif ($ln eq 'assertTrue') {        $result .= perl_literal ($node->getAttributeNS (undef, 'id')).', ';
323          $result .= join ", ", map {
324                       $ignoreCase eq 'true'
325                         ? ($expectedType eq 'Collection' or
326                            $expectedType eq 'List')
327                             ? "toLowerArray ($_)" : "lc ($_)"
328                         : $_
329                     } map {
330                       to_perl_value ($_)
331                     } (
332                       $expected,
333                       $node->getAttributeNS (undef, 'actual'),
334                     );
335          $result .= ");\n";
336        $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') {
384          my $condition;
385        if ($node->hasAttributeNS (undef, 'actual')) {        if ($node->hasAttributeNS (undef, 'actual')) {
386          $result .= perl_statement $ln . ' ('.          $condition = perl_var (type => '$',
                      perl_literal ($node->getAttributeNS (undef, 'id')).', '.  
                      perl_var (type => '$',  
387                                 local_name => $node->getAttributeNS                                 local_name => $node->getAttributeNS
388                                                         (undef, 'actual')).                                                         (undef, 'actual'));
                      ')';  
389          if ($node->hasChildNodes) {          if ($node->hasChildNodes) {
390            valid_err q<Child of $ln found but not supported>,            valid_err q<Child of $ln found but not supported>,
391              node => $node;              node => $node;
392          }          }
393          } elsif ($node->hasChildNodes) {
394            $condition = condition2code ($node);
395        } else {        } else {
396          valid_err q<assertTrue w/o @actual not supported>,        valid_err $ln.q< w/o @actual not supported>, node => $node;
           node => $node;  
397        }        }
398      } elsif ($ln eq 'assertNotNull') {        $result .= perl_statement $ln . ' ('.
399        $result .= perl_statement $ln . ' (' .                       perl_literal ($node->getAttributeNS (undef, 'id')).', '.
400                         $condition. ')';
401        $Status->{Number}++;
402      } elsif ($ln eq 'assertNotNull' or $ln eq 'assertNull') {
403        $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}++;
445    } elsif ($ln eq 'assertDOMException') {    } elsif ($ln eq 'assertDOMException') {
446      $Status->{use}->{'Message::Util::Error'} = 1;      $Status->{use}->{'Message::Util::Error'} = 1;
447      $result .= q[      $result .= q[
# Line 156  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        }        }
467      ];      ];
468        $Status->{Number}++;
469      } elsif ($ln eq 'contentType') {
470        $result .= '$builder->{contentType} eq '.
471                   perl_literal ($node->getAttributeNS (undef, 'type'));
472        $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') {
530        my $children = $node->childNodes;
531        my $condition;
532        my $true = '';
533        my $false = '';
534        my $assert_true = 0;
535        my $assert_false = 0;
536        for (my $i = 0; $i < $children->length; $i++) {
537          my $child = $children->item ($i);
538          if ($child->nodeType == $child->ELEMENT_NODE) {
539            if (not $condition) {
540              $condition = node2code ($child);
541            } elsif ($child->localName eq 'else') {
542              valid_err q<Multiple 'else's found>, node => $child
543                if $false;
544              local $Status->{Number} = 0;
545              $false = body2code ($child);
546              $assert_false = $Status->{Number};
547            } else {
548              local $Status->{Number} = 0;
549              $true .= node2code ($child);
550              $assert_true += $Status->{Number};
551            }
552          } else {
553            $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
566                    $condition,
567                    $true,
568                    $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') {
595        $result .= condition2code ($node, join => 'or');
596      } elsif ($ln eq 'not') {
597        $result .= 'not '.condition2code ($node, join => 'nosupport');
598      } elsif ($ln eq 'notNull' or $ln eq 'isNull') {
599        $result .= 'defined '.
600                   perl_var (type => '$',
601                             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    }    }
670    $result;    $result;
671  }  }
672    
673    our $result = '';
674    
675  my $input;  my $input;
676  {  {
677    local $/ = undef;    local $/ = undef;
678    $input = <>;    $input = <>;
679  }  }
680    
681  my $dom = Message::DOM::DOMImplementationRegistry  {
682    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 218  for (my $i = 0; $i < $child->length; $i+ Line 721  for (my $i = 0; $i < $child->length; $i+
721          my $node = $md->item ($j);          my $node = $md->item ($j);
722          if ($node->nodeType == $node->ELEMENT_NODE) {          if ($node->nodeType == $node->ELEMENT_NODE) {
723            my $ln = $node->localName;            my $ln = $node->localName;
724            if ($ln eq '...') {            if ($ln eq 'title') {
725                            $result .= perl_statement
726                             perl_assign
727                               '$Info->{Name}'
728                             => perl_literal $node->textContent;
729              } elsif ($ln eq 'description') {
730                $result .= perl_statement
731                             perl_assign
732                               '$Info->{Description}'
733                             => perl_literal $node->textContent;
734            } else {            } else {
735            #  valid_err q<Unknown element type: >.$ln,            #  valid_err q<Unknown element type: >.$ln,
736            #    node => $node;            #    node => $node;
# Line 236  for (my $i = 0; $i < $child->length; $i+ Line 747  for (my $i = 0; $i < $child->length; $i+
747              node => $node;              node => $node;
748          }          }
749        }        }
750        } elsif ($ln eq 'implementationAttribute') {
751          $result .= perl_statement 'impl_attr ('.
752                             perl_list
753                                 ($node->getAttributeNS (undef, 'name'),
754                                  $node->getAttributeNS (undef, 'value')).')';
755      } else {      } else {
756        $result .= node2code ($node);        $result .= node2code ($node);
757      }      }
# Line 251  for (my $i = 0; $i < $child->length; $i+ Line 767  for (my $i = 0; $i < $child->length; $i+
767        node => $node;        node => $node;
768    }    }
769  }  }
770    }
771    
772    my $pre = "#!/usr/bin/perl -w\nuse strict;\n";
773    $pre .= perl_statement ('require '.perl_literal 'manakai/domtest.pl');
774    $pre .= perl_statement
775                ('use Message::Util::Error')
776      if $Status->{use}->{'Message::Util::Error'};
777    for (keys %{$Status->{our}}) {
778      $pre .= perl_statement perl_var type => '$', local_name => $_,
779                                      scope => 'our';
780    }
781    $pre .= perl_statement q<plan (>.(0+$Status->{Number}).q<)>;
782    
783    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    
 output_result $result;  
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.7
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24