/[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.1 by wakaba, Sat Oct 9 07:54:16 2004 UTC revision 1.8 by wakaba, Thu Jan 6 10:41:31 2005 UTC
# Line 1  Line 1 
1  #!/usr/bin/perl -w  #!/usr/bin/perl -w
2  use lib q<../lib>;  use lib q<../lib>;
3  use strict;  use strict;
4  BEGIN { require '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  GetOptions (
17       getElementsByTagName 1    'output-file=s' => \$output_filename,
18       getNamedItem 1  );
19       removeChild 1  
20       replaceChild 1/  if (defined $output_filename) {
21  };    open my $f, '>', $output_filename or die "$0: $output_filename: $!";
22  my $Attr = {    our $ResultOutput = $f;
23    qw/attributes 1  } else {
24       firstChild 1    our $ResultOutput = \*STDOUT;
25       item 1  }
26       nodeName 1  
27       specified 1/  our $Method;
28  };  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    sub to_perl_value ($;%) {
77      my ($s, %opt) = @_;
78      if (defined $s) {
79        if ($s =~ /^(?!\d)\w+$/) {
80          if ({true => 1, false => 1}->{$s}) {
81            return {true => '1', false => '0'}->{$s};
82          } else {
83            return perl_var (type => '$', local_name => $s);
84          }
85        } else {
86          return $s;
87        }
88      } elsif (defined $opt{default}) {
89        return $opt{default};
90      } else {
91        return '';
92      }
93    }
94    
95  sub body2code ($) {  sub body2code ($) {
96    my $parent = shift;    my $parent = shift;
# Line 68  sub body2code ($) { Line 122  sub body2code ($) {
122    $result;    $result;
123  }  }
124    
125    sub condition2code ($;%) {
126      my ($parent, %opt) = @_;
127      my $result = '';
128      my @result;
129      my $children = $parent->childNodes;
130      for (my $i = 0; $i < $children->length; $i++) {
131        my $child = $children->item ($i);
132        if ($child->nodeType == $child->ELEMENT_NODE) {
133          my $ln = $child->localName;
134          if ($Condition->{$ln}) {
135            push @result, node2code ($child);
136          } else {
137            valid_err q<Unknown element type: >.$child->localName,
138              node => $child;
139          }
140        } elsif ($child->nodeType == $child->COMMENT_NODE) {
141          $result .= perl_comment $child->data;
142        } elsif ($child->nodeType == $child->TEXT_NODE) {
143          if ($child->data =~ /\S/) {
144            valid_err q<Unknown character data: >.$child->data,
145              node => $child;
146          }
147        } else {
148          valid_err q<Unknown type of node: >.$child->nodeType,
149            node => $child;
150        }
151      }
152      $result .= join (($opt{join}||='or' eq 'or' ? ' || ' :
153                        $opt{join} eq 'and' ? ' && ' :
154                        valid_err q<Multiple condition not supported>,
155                          node => $parent),
156                       map {"($_)"} @result);
157      $result;
158    } #condition2code
159    
160    sub node2code ($);
161  sub node2code ($) {  sub node2code ($) {
162    my $node = shift;    my $node = shift;
163    my $result = '';    my $result = '';
164      if ($node->nodeType != $node->ELEMENT_NODE) {
165        if ($node->nodeType == $node->COMMENT_NODE) {
166          $result .= perl_comment $node->data;
167        } elsif ($node->nodeType == $node->TEXT_NODE) {
168          if ($node->data =~ /\S/) {
169            valid_err q<Unknown character data: >.$node->data,
170              node => $node;
171          }
172        } else {
173          valid_err q<Unknown type of node: >.$node->nodeType,
174            node => $node;
175        }
176        return $result;
177      }
178    my $ln = $node->localName;    my $ln = $node->localName;
179    
180    if ($ln eq 'var') {    if ($ln eq 'var') {
181        $result .= perl_statement      my $name = $node->getAttributeNS (undef, 'name');
182                     perl_var      my $var = perl_var
183                       local_name => $node->getAttributeNS (undef, 'name'),                       local_name => $name,
184                       scope => 'my',                       scope => 'my',
185                       type => '$';                       type => '$';
186        if ($node->getAttributeNS (undef, 'value')) {      my $type = $node->getAttributeNS (undef, 'type');
187          valid_err q<Attribute "value" not supported>, node => $node;      $result .= perl_comment $type;
188        if ($node->hasAttributeNS (undef, 'isNull') and
189            $node->getAttributeNS (undef, 'isNull') eq 'true') {
190          $result .= perl_statement perl_assign $var => 'undef';
191        } elsif ($node->hasAttributeNS (undef, 'value')) {
192          $result .= perl_statement
193                       perl_assign
194                            $var
195                         => to_perl_value ($node->getAttributeNS (undef, 'value'));
196        } else {
197          if ($type eq 'List' or $type eq 'Collection') {
198            my @member;
199            my $children = $node->childNodes;
200            for (my $i = 0; $i < $children->length; $i++) {
201              my $child = $children->item ($i);
202              if ($child->nodeType == $child->ELEMENT_NODE) {
203                if ($child->localName eq 'member') {
204                  push @member, perl_code_literal
205                                  (to_perl_value ($child->textContent));
206                } else {
207                  valid_err q<Unsupported element type>, node => $child;
208                }
209              } elsif ($child->nodeType == $child->COMMENT_NODE) {
210                $result .= perl_comment $child->data;
211              }
212            }
213            $result .= perl_statement
214                         perl_assign
215                              $var
216                           => perl_list \@member;
217          } elsif ($type =~ /Monitor/) {
218            valid_err qq<Type $type not supported>, node => $node;
219          } elsif ($node->hasChildNodes) {
220            valid_err q<Children not supported>, node => $node;
221          } else {
222            $result .= perl_statement $var;
223        }        }
224      } elsif ($ln eq 'load') {      }
225        $Status->{var}->{$name}->{type} = $node->getAttributeNS (undef, 'type');
226      } elsif ($ln eq 'load') {
227        $result .= perl_statement        $result .= perl_statement
228                     perl_assign                     perl_assign
229                       perl_var                       perl_var
# Line 91  sub node2code ($) { Line 232  sub node2code ($) {
232                     => 'load (' .                     => 'load (' .
233                        perl_literal ($node->getAttributeNS (undef, 'href')).                        perl_literal ($node->getAttributeNS (undef, 'href')).
234                        ')';                        ')';
235      } elsif ($Method->{$ln}) {    } elsif ($ln eq 'hasFeature' and
236               not $node->hasAttributeNS (undef, 'var')) {
237        ## If there is a "hasFeature" element in "body" and
238        ## it does not have "var" attribute, then it is part of the
239        ## implementation condition.
240        $result .= perl_statement 'hasFeature ('.
241                           to_perl_value ($node->getAttributeNS (undef, 'feature'),
242                                          default => 'undef') . ', '.
243                           to_perl_value ($node->getAttributeNS (undef, 'version'),
244                                          default => 'undef') . ')';
245      } elsif ($Method->{$ln}) {
246        $result .= perl_var (type => '$',        $result .= perl_var (type => '$',
247                             local_name => $node->getAttributeNS (undef, 'var')).                             local_name => $node->getAttributeNS (undef, 'var')).
248                   ' = '                   ' = '
249          if $node->hasAttributeNS (undef, 'var');          if $node->hasAttributeNS (undef, 'var');
250          my $param;
251          if ($node->hasAttributeNS (undef, 'interface')) {
252            my $if = $node->getAttributeNS (undef, 'interface');
253            $param = $IFMethod->{$if}->{$ln};
254            unless ($param) {
255              valid_err "Method $if.$ln not supported", node => $node;
256            }
257            if ($if eq 'Element' and $ln eq 'getElementsByTagName' and
258                not $node->hasAttributeNS (undef, 'name') and
259                $node->hasAttributeNS (undef, 'tagname')) {
260              $node->setAttributeNS (undef, 'name'
261                                     => $node->getAttributeNS (undef, 'tagname'));
262            }
263          } else {
264            $param = $Method->{$ln};
265          }
266        $result .= perl_var (type => '$',        $result .= perl_var (type => '$',
267                             local_name => $node->getAttributeNS (undef, 'obj')).                             local_name => $node->getAttributeNS (undef, 'obj')).
268                '->'.$ln.' ('.                '->'.$ln.' ('.
269                  ## TODO: parameters                  join (', ',
270                         map {
271                           to_perl_value ($node->getAttributeNS (undef, $_),
272                                          default => 'undef')
273                         } @$param).
274                ");\n";                ");\n";
275      } elsif ($Attr->{$ln}) {      } elsif ($Attr->{$ln}) {
276        if ($node->hasAttributeNS (undef, 'var')) {        if ($node->hasAttributeNS (undef, 'var')) {
277          $result .= perl_var (type => '$',          $result .= perl_var (type => '$',
278                               local_name => $node->getAttributeNS (undef, 'var')).                               local_name => $node->getAttributeNS (undef, 'var')).
279                     ' = ';                     ' = ';
280          } elsif ($node->hasAttributeNS (undef, 'value')) {
281            #
282        } else {        } else {
283          impl_err q<Attr set>;          valid_err q<Unknown operation to an attribute>, node => $node;
284          }
285          my $obj = perl_var (type => '$',
286                              local_name => $node->getAttributeNS (undef, 'obj'));
287          my $if = $node->getAttributeNS (undef, 'interface');
288          if (defined $if and $if eq 'DOMString') {
289            if ($ln eq 'length') {
290              $result .= 'length '.$obj;
291            } else {
292              valid_err q<$if.$ln not supported>, node => $node;
293            }
294          } else {
295            $result .= $obj.'->'.$ln;
296        }        }
       $result .= perl_var (type => '$',  
                            local_name => $node->getAttributeNS (undef, 'obj')).  
               '->'.$ln;  
297        if ($node->hasAttributeNS (undef, 'var')) {        if ($node->hasAttributeNS (undef, 'var')) {
298          $result .= ";\n";          $result .= ";\n";
299          } elsif ($node->hasAttributeNS (undef, 'value')) {
300            $result .= " (".to_perl_value ($node->getAttributeNS (undef, 'value')).
301                       ");\n";
302          }
303        } elsif ($ln eq 'assertEquals') {
304          my $expected = $node->getAttributeNS (undef, 'expected');
305          my $expectedType = $Status->{var}->{$expected}->{type} || '';
306          $result .= 'assertEquals'.
307                     ({Collection => 'Collection',
308                       List => 'List'}->{$expectedType}||'');
309          my $ignoreCase = $node->getAttributeNS (undef, 'ignoreCase') || 'false';
310          if ($ignoreCase eq 'auto') {
311            $result .= 'AutoCase ('.
312                       perl_literal ($node->getAttributeNS (undef, 'context') ||
313                                     'element').
314                       ', ';
315          } else {
316            $result .= ' (';
317        }        }
318      } elsif ($ln eq 'assertTrue') {        $result .= perl_literal ($node->getAttributeNS (undef, 'id')).', ';
319          $result .= join ", ", map {
320                       $ignoreCase eq 'true'
321                         ? ($expectedType eq 'Collection' or
322                            $expectedType eq 'List')
323                             ? "toLowerArray ($_)" : "lc ($_)"
324                         : $_
325                     } map {
326                       to_perl_value ($_)
327                     } (
328                       $expected,
329                       $node->getAttributeNS (undef, 'actual'),
330                     );
331          $result .= ");\n";
332        $Status->{Number}++;
333      } elsif ($ln eq 'assertInstanceOf') {
334        my $obj = perl_code_literal
335                    (to_perl_value ($node->getAttributeNS (undef, 'obj')));
336        $result .= perl_statement 'assertInstanceOf ('.
337                     perl_list
338                       ($node->getAttributeNS (undef, 'id'),
339                        $node->getAttributeNS (undef, 'type'),
340                        $obj).
341                   ')';
342        if ($node->hasChildNodes) {
343          $result .= perl_if
344                       'isInstanceOf ('.
345                       perl_list
346                         ($node->getAttributeNS (undef, 'type'),
347                          $obj) . ')',
348                       body2code ($node);
349        }
350        $Status->{Number}++;
351      } elsif ($ln eq 'assertSame') {
352        my $expected = to_perl_value ($node->getAttributeNS (undef, 'expected'));
353        my $actual = to_perl_value ($node->getAttributeNS (undef, 'actual'));
354        $result .= perl_statement 'assertSame ('.
355                     perl_list
356                       ($node->getAttributeNS (undef, 'id'),
357                        $expected, $actual).
358                   ')';
359        if ($node->hasChildNodes) {
360          $result .= perl_if
361                       'same ('.(perl_list $expected, $actual).')',
362                       body2code ($node);
363        }
364        $Status->{Number}++;
365      } elsif ($ln eq 'assertSize') {
366        my $size = to_perl_value ($node->getAttributeNS (undef, 'size'));
367        my $coll = to_perl_value ($node->getAttributeNS (undef, 'collection'));
368        $result .= perl_statement 'assertSize ('.
369                     perl_list
370                       ($node->getAttributeNS (undef, 'id'),
371                        perl_code_literal $size, perl_code_literal $coll).
372                   ')';
373        if ($node->hasChildNodes) {
374          $result .= perl_if
375                       qq<$size == size ($coll)>,
376                       body2code ($node);
377        }
378        $Status->{Number}++;
379      } elsif ($ln eq 'assertTrue' or $ln eq 'assertFalse') {
380          my $condition;
381        if ($node->hasAttributeNS (undef, 'actual')) {        if ($node->hasAttributeNS (undef, 'actual')) {
382          $result .= perl_statement $ln . ' ('.          $condition = perl_var (type => '$',
                      perl_literal ($node->getAttributeNS (undef, 'id')).', '.  
                      perl_var (type => '$',  
383                                 local_name => $node->getAttributeNS                                 local_name => $node->getAttributeNS
384                                                         (undef, 'actual')).                                                         (undef, 'actual'));
                      ')';  
385          if ($node->hasChildNodes) {          if ($node->hasChildNodes) {
386            valid_err q<Child of $ln found but not supported>,            valid_err q<Child of $ln found but not supported>,
387              node => $node;              node => $node;
388          }          }
389          } elsif ($node->hasChildNodes) {
390            $condition = condition2code ($node);
391        } else {        } else {
392          valid_err q<assertTrue w/o @actual not supported>,        valid_err $ln.q< w/o @actual not supported>, node => $node;
           node => $node;  
393        }        }
394      } elsif ($ln eq 'assertNotNull') {        $result .= perl_statement $ln . ' ('.
395        $result .= perl_statement $ln . ' (' .                       perl_literal ($node->getAttributeNS (undef, 'id')).', '.
396                         $condition. ')';
397        $Status->{Number}++;
398      } elsif ($ln eq 'assertNotNull' or $ln eq 'assertNull') {
399        $result .= perl_statement $ln . ' (' .
400                   perl_literal ($node->getAttributeNS (undef, 'id')).', '.                   perl_literal ($node->getAttributeNS (undef, 'id')).', '.
401                   perl_var (type => '$',                   perl_var (type => '$',
402                             local_name => $node->getAttributeNS (undef, 'actual')).                             local_name => $node->getAttributeNS (undef, 'actual')).
403                   ')';                   ')';
404        if ($node->hasChildNodes) {      if ($node->hasChildNodes) {
405          valid_err q<Child of $ln found but not supported>,        valid_err q<Child of $ln found but not supported>,
406            node => $node;            node => $node;
407        }      }
408        $Status->{Number}++;
409      } elsif ($ln eq 'assertURIEquals') {
410        $result .= perl_statement 'assertURIEquals ('.
411                     perl_list
412                       ($node->getAttributeNS (undef, 'id'),
413                        perl_code_literal
414                          (to_perl_value ($node->getAttributeNS (undef, 'scheme'),
415                                          default => 'undef')),
416                        perl_code_literal
417                          (to_perl_value ($node->getAttributeNS (undef, 'path'),
418                                          default => 'undef')),
419                        perl_code_literal
420                          (to_perl_value ($node->getAttributeNS (undef, 'host'),
421                                          default => 'undef')),
422                        perl_code_literal
423                          (to_perl_value ($node->getAttributeNS (undef, 'file'),
424                                          default => 'undef')),
425                        perl_code_literal
426                          (to_perl_value ($node->getAttributeNS (undef, 'name'),
427                                          default => 'undef')),
428                        perl_code_literal
429                          (to_perl_value ($node->getAttributeNS (undef, 'query'),
430                                          default => 'undef')),
431                        perl_code_literal
432                          (to_perl_value ($node->getAttributeNS (undef, 'fragment'),
433                                          default => 'undef')),
434                        perl_code_literal
435                          (to_perl_value ($node->getAttributeNS (undef, 'isAbsolute'),
436                                          default => 'undef')),
437                        perl_code_literal
438                          (to_perl_value ($node->getAttributeNS (undef, 'actual')))).
439                   ')';
440        $Status->{Number}++;
441    } elsif ($ln eq 'assertDOMException') {    } elsif ($ln eq 'assertDOMException') {
442      $Status->{use}->{'Message::Util::Error'} = 1;      $Status->{use}->{'Message::Util::Error'} = 1;
443      $result .= q[      $result .= q[
# Line 156  sub node2code ($) { Line 453  sub node2code ($) {
453        $result .= body2code ($child);        $result .= body2code ($child);
454      }      }
455      $result .= q[      $result .= q[
456          } catch Message::DOM::DOMException with {          } catch Message::DOM::IF::DOMException with {
457            my $err = shift;            my $err = shift;
458            $success = 1 if $err->{-type} eq ].perl_literal ($errname).q[;            $success = 1 if $err->{-type} eq ].perl_literal ($errname).q[;
459          }          };
460          assertTrue (].perl_literal ($node->getAttributeNS (undef, 'id')).          assertTrue (].perl_literal ($node->getAttributeNS (undef, 'id')).
461          q[, $success);          q[, $success);
462        }        }
463      ];      ];
464        $Status->{Number}++;
465      } elsif ($ln eq 'contentType') {
466        $result .= '$builder->{contentType} eq '.
467                   perl_literal ($node->getAttributeNS (undef, 'type'));
468        $Status->{our}->{builder} = 1;
469      } elsif ($ln eq 'for-each') {
470        my $collection = $node->getAttributeNS (undef, 'collection');
471        my $collType = $Status->{var}->{$collection}->{type};
472        my $coll = to_perl_value ($collection);
473        my $assert;
474        my $code;
475        {
476          local $Status->{Number} = 0;
477          $code = body2code ($node);
478          $assert = $Status->{Number};
479        }
480        $Status->{Number_local} = 1;
481        $result .= 'for (my $i = 0; $i < '.
482                   ({'Collection'=>1,'List'=>1}->{$collType}
483                      ? '@{'.$coll.'}' : $coll.'->length').
484                   '; $i++) {'.
485                     perl_statement (qq<plan_local ($assert)>).
486                     perl_statement
487                       (perl_assign
488                           to_perl_value ($node->getAttributeNS (undef, 'member'))
489                        => $coll . ({'Collection'=>1,'List'=>1}->{$collType}
490                                      ? '->[$i]' : '->item ($i)')).
491                     $code.
492                   '}';
493      } elsif ($ln eq 'try') {
494        my $children = $node->childNodes;
495        my $true = '';
496        my $false = '';
497        for (my $i = 0; $i < $children->length; $i++) {
498          my $child = $children->item ($i);
499          if ($child->nodeType == $child->ELEMENT_NODE) {
500            if ($child->localName eq 'catch') {
501              valid_err q<Multiple 'catch'es found>, node => $child
502                if $false;
503              my @case;
504              my $children2 = $child->childNodes;
505              for (my $j = 0; $j < $children2->length; $j++) {
506                my $child2 = $children2->item ($j);
507                if ($child2->nodeType == $child2->ELEMENT_NODE) {
508                  if ($child2->localName eq 'ImplementationException') {
509                    valid_err q<Element type not supported>, node => $child2;
510                  } else {
511                    push @case, '$err->{-type} eq '.
512                              perl_literal ($child2->getAttributeNS (undef, 'code'))
513                                => body2code ($child2);
514                  }
515                } else {
516                  $false .= node2code ($child2);
517                }
518              }
519              $false .= perl_cases @case, else => perl_statement '$err->throw';
520            } else {
521              $true .= node2code ($child);
522            }
523          } else {
524            $true .= node2code ($child);
525          }
526        }
527        $result = "try {
528                     $true
529                   } catch Message::DOM::DOMMain::ManakaiDOMException with {
530                     my \$err = shift;
531                     $false
532                   };";
533        $Status->{use}->{'Message::Util::Error'} = 1;
534      } elsif ($ln eq 'if') {
535        my $children = $node->childNodes;
536        my $condition;
537        my $true = '';
538        my $false = '';
539        my $assert_true = 0;
540        my $assert_false = 0;
541        for (my $i = 0; $i < $children->length; $i++) {
542          my $child = $children->item ($i);
543          if ($child->nodeType == $child->ELEMENT_NODE) {
544            if (not $condition) {
545              $condition = node2code ($child);
546            } elsif ($child->localName eq 'else') {
547              valid_err q<Multiple 'else's found>, node => $child
548                if $false;
549              local $Status->{Number} = 0;
550              $false = body2code ($child);
551              $assert_false = $Status->{Number};
552            } else {
553              local $Status->{Number} = 0;
554              $true .= node2code ($child);
555              $assert_true += $Status->{Number};
556            }
557          } else {
558            $true .= node2code ($child);
559          }
560        }
561        if ($assert_true == $assert_false) {
562          $Status->{Number} += $assert_true;
563        } elsif ($assert_true > $assert_false) {
564          $false .= perl_statement 'skip_n ('.
565                      perl_list ($assert_true - $assert_false,
566                                 msg => q<Conditional>).')';
567          $Status->{Number} += $assert_true;
568        } else {
569          $true .= perl_statement 'skip_n ('.
570                      perl_list ($assert_false - $assert_true,
571                                 msg => q<Conditional>).')';
572          $Status->{Number} += $assert_false;
573        }
574        $result = perl_if
575                    $condition,
576                    $true,
577                    $false ? $false : undef;
578      } elsif ($ln eq 'while') {
579        my $children = $node->childNodes;
580        my $condition;
581        my $true = '';
582        my $assert = 0;
583        {
584          local $Status->{Number} = 0;
585          for (my $i = 0; $i < $children->length; $i++) {
586            my $child = $children->item ($i);
587            if ($child->nodeType == $child->ELEMENT_NODE) {
588              if (not $condition) {
589                $condition = node2code ($child);
590              } else {
591                $true .= node2code ($child);
592              }
593            } else {
594              $true .= node2code ($child);
595            }
596          }
597          $assert = $Status->{Number};
598        }
599        $Status->{Number_local} = 1;
600        $result .= "while ($condition) {
601                      plan_local ($assert);
602                      $true
603                    }";
604      } elsif ($ln eq 'or') {
605        $result .= condition2code ($node, join => 'or');
606      } elsif ($ln eq 'not') {
607        $result .= 'not '.condition2code ($node, join => 'nosupport');
608      } elsif ($ln eq 'notNull' or $ln eq 'isNull') {
609        $result .= 'defined '.
610                   perl_var (type => '$',
611                             local_name => $node->getAttributeNS (undef, 'obj'));
612        $result = 'not ' . $result if $ln eq 'isNull';
613      } elsif ({less => 1, lessOrEquals => 1,
614                greater => 1, greaterOrEquals => 1}->{$ln}) {
615        $result .= to_perl_value ($node->getAttributeNS (undef, 'actual')).
616                   {less => '<', lessOrEquals => '<=',
617                    greater => '>', greaterOrEquals => '>='}->{$ln}.
618                   to_perl_value ($node->getAttributeNS (undef, 'expected'));
619      } elsif ($ln eq 'equals' or $ln eq 'notEquals') {
620        my $case = $node->getAttributeNS (undef, 'ignoreCase');
621        if ($case and $case eq 'auto') {
622          $result .= 'equalsAutoCase (' .
623                       perl_list
624                         ($node->getAttributeNS (undef, 'context') || 'element',
625                          to_perl_value
626                            ($node->getAttributeNS (undef, 'expected')),
627                          to_perl_value
628                            ($node->getAttributeNS (undef, 'actual'))) . ')';
629        } else {
630          my $expected = to_perl_value
631                            ($node->getAttributeNS (undef, 'expected'));
632          my $actual = to_perl_value
633                            ($node->getAttributeNS (undef, 'actual'));
634          if ($case eq 'true') {
635            $result = "(uc ($expected) eq uc ($actual))";
636          } elsif ($node->hasAttributeNS (undef, 'bitmask')) {
637            my $bm = ' & ' . to_perl_value
638                              ($node->getAttributeNS (undef, 'bitmask'));
639            $result = "($expected$bm == $actual$bm)";
640          } else {
641            $result = "($expected eq $actual)";
642          }
643        }
644        $result = "(not $result)" if $ln eq 'notEquals';
645      } elsif ($ln eq 'increment' or $ln eq 'decrement') {
646        $result .= perl_statement
647                     to_perl_value ($node->getAttributeNS (undef, 'var')).
648                     {increment => ' += ', decrement => ' -= '}->{$ln}.
649                     to_perl_value ($node->getAttributeNS (undef, 'value'));
650      } elsif ({qw/plus 1 subtract 1 mult 1 divide 1/}->{$ln}) {
651        $result .= perl_statement
652                     (perl_assign
653                         to_perl_value ($node->getAttributeNS (undef, 'var'))
654                      => to_perl_value ($node->getAttributeNS (undef, 'op1')).
655                         {qw<plus + subtract - mult * divide />}->{$ln}.
656                         to_perl_value ($node->getAttributeNS (undef, 'op2')));
657      } elsif ($ln eq 'append') {
658        $result .= perl_statement
659                     'push @{'.
660                        to_perl_value ($node->getAttributeNS (undef, 'collection')).
661                        '}, '.
662                        to_perl_value ($node->getAttributeNS (undef, 'item'));
663      } elsif ($ln eq 'instanceOf') {
664        $result .= 'isInstanceOf ('.
665                   perl_list ($node->getAttributeNS (undef, 'type'),
666                              perl_code_literal to_perl_value
667                                ($node->getAttributeNS (undef, 'obj'))).
668                   ')';
669      } elsif ($ln eq 'assign') {
670        $result .= perl_statement
671                     perl_assign
672                          to_perl_value ($node->getAttributeNS (undef, 'var'))
673                       => to_perl_value ($node->getAttributeNS (undef, 'value'));
674      } elsif ($ln eq 'fail') {
675        $result .= perl_statement 'fail ('.
676                     perl_literal ($node->getAttributeNS (undef, 'id')). ')';
677    } else {    } else {
678      valid_err q<Unknown element type: >.$ln;      valid_err q<Unknown element type: >.$ln;
679    }    }
680    $result;    $result;
681  }  }
682    
683    our $result = '';
684    
685    my $input_filename;
686  my $input;  my $input;
687  {  {
688    local $/ = undef;    local $/ = undef;
689    $input = <>;    $input = <>;
690      $input_filename = $ARGV;
691  }  }
692    
693  my $dom = Message::DOM::DOMImplementationRegistry  {
694    my $dom = $Message::DOM::DOMImplementationRegistry
695              ->getDOMImplementation              ->getDOMImplementation
696                   ({Core => undef,                   ({Core => undef,
697                     XML => undef,                     XML => undef,
698                     ExpandedURI q<ManakaiDOMLS2003:LS> => '1.0'});                     ExpandedURI q<ManakaiDOMLS2003:LS> => ''});
699    
700  my $parser = $dom->createLSParser (MODE_SYNCHRONOUS);  my $parser = $dom->createLSParser (MODE_SYNCHRONOUS);
701  my $in = $dom->createLSInput;  my $in = $dom->createLSInput;
# Line 196  for (my $i = 0; $i < $children->length; Line 711  for (my $i = 0; $i < $children->length;
711      if ($node->data =~ /Copyright/) {      if ($node->data =~ /Copyright/) {
712        $result .= perl_comment        $result .= perl_comment
713                     qq<This script was generated by "$0"\n>.                     qq<This script was generated by "$0"\n>.
714                     qq<and is a derived work from the source document.\n>.                     qq<and is a derived work from the source document\n>.
715                       qq<"$input_filename".\n>.
716                     qq<The source document contained the following notice:\n>.                     qq<The source document contained the following notice:\n>.
717                     $node->data;                     $node->data;
718      } else {      } else {
# Line 218  for (my $i = 0; $i < $child->length; $i+ Line 734  for (my $i = 0; $i < $child->length; $i+
734          my $node = $md->item ($j);          my $node = $md->item ($j);
735          if ($node->nodeType == $node->ELEMENT_NODE) {          if ($node->nodeType == $node->ELEMENT_NODE) {
736            my $ln = $node->localName;            my $ln = $node->localName;
737            if ($ln eq '...') {            if ($ln eq 'title') {
738                            $result .= perl_statement
739                             perl_assign
740                               '$Info->{Name}'
741                             => perl_literal $node->textContent;
742              } elsif ($ln eq 'description') {
743                $result .= perl_statement
744                             perl_assign
745                               '$Info->{Description}'
746                             => perl_literal $node->textContent;
747            } else {            } else {
748            #  valid_err q<Unknown element type: >.$ln,            #  valid_err q<Unknown element type: >.$ln,
749            #    node => $node;            #    node => $node;
# Line 236  for (my $i = 0; $i < $child->length; $i+ Line 760  for (my $i = 0; $i < $child->length; $i+
760              node => $node;              node => $node;
761          }          }
762        }        }
763        } elsif ($ln eq 'implementationAttribute') {
764          $result .= perl_statement 'impl_attr ('.
765                             perl_list
766                                 ($node->getAttributeNS (undef, 'name'),
767                                  $node->getAttributeNS (undef, 'value')).')';
768      } else {      } else {
769        $result .= node2code ($node);        $result .= node2code ($node);
770      }      }
# Line 251  for (my $i = 0; $i < $child->length; $i+ Line 780  for (my $i = 0; $i < $child->length; $i+
780        node => $node;        node => $node;
781    }    }
782  }  }
783    }
784    
785    my $pre = "#!/usr/bin/perl -w\nuse strict;\n";
786    $pre .= perl_statement ('require '.perl_literal 'manakai/domtest.pl');
787    $pre .= perl_statement
788                ('use Message::Util::Error')
789      if $Status->{use}->{'Message::Util::Error'};
790    for (keys %{$Status->{our}}) {
791      $pre .= perl_statement perl_var type => '$', local_name => $_,
792                                      scope => 'our';
793    }
794    my $plan = $Status->{Number_local} ? 'plan_local' : 'plan';
795    $pre .= perl_statement qq<$plan (>.(0+$Status->{Number}).q<)>;
796    
797    $result .= perl_statement q<end_of_test ()>;
798    
799    output_result $pre.$result;
800    
801    1;
802    
803    __END__
804    
805    =head1 NAME
806    
807    domtest2perl - DOM Test Suite XML Test File to Perl Test Code Converter
808    
809    =head1 SYNOPSIS
810    
811      perl path/to/domtest2perl.pl input.xml > output.pl
812      perl path/to/domtest2perl.pl input.xml --output-file=output.pl
813    
814    =over 4
815    
816    =item I<input.xml>
817    
818    The name of file to input.  It should be an XML document
819    in the DOM Test Suite.
820    
821    =item I<output.pl>
822    
823    The name of file to output.  It is overwritten if already exists.
824    
825    =back
826    
827    =head1 SEE ALSO
828    
829    I<Document Object Model (DOM) Conformance Test Suites>,
830    <http://www.w3.org/DOM/Test/>.
831    
832    F<domts2perl.pl>
833    
834    F<mkdommemlist.pl>
835    
836    =head1 LICENSE
837    
838    Copyright 2004-2005 Wakaba <w@suika.fam.cx>.  All rights reserved.
839    
840    This program is free software; you can redistribute it and/or
841    modify it under the same terms as Perl itself.
842    
843    =cut
844    
 output_result $result;  
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.8
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24