/[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.3 by wakaba, Sun Oct 10 06:09:47 2004 UTC
# Line 9  use Message::Util::QName::General [qw/Ex Line 9  use Message::Util::QName::General [qw/Ex
9  };  };
10  use Message::DOM::ManakaiDOMLS2003;  use Message::DOM::ManakaiDOMLS2003;
11  use Message::DOM::DOMLS qw/MODE_SYNCHRONOUS/;  use Message::DOM::DOMLS qw/MODE_SYNCHRONOUS/;
12    use Getopt::Long;
13    
14  my $Method = {  require 'dommemlist.pl.tmp'; ## Generated by mkdommemlist.pl
15    qw/createEntityReference 1  
16       createTextNode 1  my $output_filename;
17       getAttributeNode 1  my $output_file;
18       getElementsByTagName 1  GetOptions (
19       getNamedItem 1    'output-file=s' => \$output_filename,
20       removeChild 1  );
21       replaceChild 1/  if (defined $output_filename) {
22  };    open $output_file, '>', $output_filename or die "$0: $output_filename: $!";
23  my $Attr = {  } else {
24    qw/attributes 1    $output_file = \*STDOUT;
25       firstChild 1  }
26       item 1  
27       nodeName 1  our $Method;
28       specified 1/  our $Attr;
29  };  our $MethodParam;
30  my $Assert = {  my $Assert = {
31    qw/assertDOMException 1    qw/assertDOMException 1
32         assertFalse 1
33       assertNotNull 1       assertNotNull 1
34         assertNull 1
35       assertTrue 1/       assertTrue 1/
36  };  };
37  my $Misc = {  my $Misc = {
38    qw/var 1/    qw/if 1
39         implementationAttribute 1
40         var 1/
41    };
42    my $Condition = {
43      qw/condition 1
44         contains 1
45         contentType 1
46         hasSize 1
47         implementationAttribute 1
48         not 1
49         notNull 1
50         or 1/
51  };  };
52    
53  my $Status;  my $Status = {Number => 0, our => {Info => 1}};
54  our $result = '';  
55    ## Defined in genlib.pl but redefined.
56    sub output_result ($) {
57      print $output_file shift;
58    }
59    
60    sub to_perl_value ($;%) {
61      my ($s, %opt) = @_;
62      if (defined $s) {
63        if ($s =~ /^(?!\d)\w+$/) {
64          return perl_var (type => '$', local_name => $s);
65        } else {
66          return $s;
67        }
68      } elsif (defined $opt{default}) {
69        return $opt{default};
70      } else {
71        return '';
72      }
73    }
74    
75  sub body2code ($) {  sub body2code ($) {
76    my $parent = shift;    my $parent = shift;
# Line 68  sub body2code ($) { Line 102  sub body2code ($) {
102    $result;    $result;
103  }  }
104    
105    sub condition2code ($;%) {
106      my ($parent, %opt) = @_;
107      my $result = '';
108      my @result;
109      my $children = $parent->childNodes;
110      for (my $i = 0; $i < $children->length; $i++) {
111        my $child = $children->item ($i);
112        if ($child->nodeType == $child->ELEMENT_NODE) {
113          my $ln = $child->localName;
114          if ($Condition->{$ln}) {
115            push @result, node2code ($child);
116          } else {
117            valid_err q<Unknown element type: >.$child->localName,
118              node => $child;
119          }
120        } elsif ($child->nodeType == $child->COMMENT_NODE) {
121          $result .= perl_comment $child->data;
122        } elsif ($child->nodeType == $child->TEXT_NODE) {
123          if ($child->data =~ /\S/) {
124            valid_err q<Unknown character data: >.$child->data,
125              node => $child;
126          }
127        } else {
128          valid_err q<Unknown type of node: >.$child->nodeType,
129            node => $child;
130        }
131      }
132      $result .= join (($opt{join}||='or' eq 'or' ? ' || ' :
133                        $opt{join} eq 'and' ? ' && ' :
134                        valid_err q<Multiple condition not supported>,
135                          node => $parent),
136                       map {"($_)"} @result);
137      $result;
138    } #condition2code
139    
140    sub node2code ($);
141  sub node2code ($) {  sub node2code ($) {
142    my $node = shift;    my $node = shift;
143    my $result = '';    my $result = '';
144      if ($node->nodeType != $node->ELEMENT_NODE) {
145        if ($node->nodeType == $node->COMMENT_NODE) {
146          $result .= perl_comment $node->data;
147        } elsif ($node->nodeType == $node->TEXT_NODE) {
148          if ($node->data =~ /\S/) {
149            valid_err q<Unknown character data: >.$node->data,
150              node => $node;
151          }
152        } else {
153          valid_err q<Unknown type of node: >.$node->nodeType,
154            node => $node;
155        }
156        return $result;
157      }
158    my $ln = $node->localName;    my $ln = $node->localName;
159    
160    if ($ln eq 'var') {    if ($ln eq 'var') {
161        $result .= perl_statement      my $name = $node->getAttributeNS (undef, 'name');
162        $result .= perl_statement
163                     perl_var                     perl_var
164                       local_name => $node->getAttributeNS (undef, 'name'),                       local_name => $name,
165                       scope => 'my',                       scope => 'my',
166                       type => '$';                       type => '$';
167        if ($node->getAttributeNS (undef, 'value')) {      if ($node->getAttributeNS (undef, 'value')) {
168          valid_err q<Attribute "value" not supported>, node => $node;        valid_err q<Attribute "value" not supported>, node => $node;
169        }      }
170      } elsif ($ln eq 'load') {      $Status->{var}->{$name}->{type} = $node->getAttributeNS (undef, 'type');
171      } elsif ($ln eq 'load') {
172        $result .= perl_statement        $result .= perl_statement
173                     perl_assign                     perl_assign
174                       perl_var                       perl_var
# Line 99  sub node2code ($) { Line 185  sub node2code ($) {
185        $result .= perl_var (type => '$',        $result .= perl_var (type => '$',
186                             local_name => $node->getAttributeNS (undef, 'obj')).                             local_name => $node->getAttributeNS (undef, 'obj')).
187                '->'.$ln.' ('.                '->'.$ln.' ('.
188                  ## TODO: parameters                  join (', ',
189                         map {
190                           to_perl_value ($node->getAttributeNS (undef, $_),
191                                          default => 'undef')
192                         } @{$Method->{$ln}}).
193                ");\n";                ");\n";
194      } elsif ($Attr->{$ln}) {      } elsif ($Attr->{$ln}) {
195        if ($node->hasAttributeNS (undef, 'var')) {        if ($node->hasAttributeNS (undef, 'var')) {
196          $result .= perl_var (type => '$',          $result .= perl_var (type => '$',
197                               local_name => $node->getAttributeNS (undef, 'var')).                               local_name => $node->getAttributeNS (undef, 'var')).
198                     ' = ';                     ' = ';
199          } elsif ($node->hasAttributeNS (undef, 'value')) {
200            #
201        } else {        } else {
202          impl_err q<Attr set>;          valid_err q<Unknown operation to an attribute>, node => $node;
203        }        }
204        $result .= perl_var (type => '$',        $result .= perl_var (type => '$',
205                             local_name => $node->getAttributeNS (undef, 'obj')).                             local_name => $node->getAttributeNS (undef, 'obj')).
206                '->'.$ln;                '->'.$ln;
207        if ($node->hasAttributeNS (undef, 'var')) {        if ($node->hasAttributeNS (undef, 'var')) {
208          $result .= ";\n";          $result .= ";\n";
209          } elsif ($node->hasAttributeNS (undef, 'value')) {
210            $result .= " (".to_perl_value ($node->getAttributeNS (undef, 'value')).
211                       ");\n";
212          }
213        } elsif ($ln eq 'assertEquals') {
214          my $expected = $node->getAttributeNS (undef, 'expected');
215          my $expectedType = $Status->{var}->{$expected}->{type} || '';
216          $result .= 'assertEquals'.
217                     ({Collection => 'Collection',
218                       List => 'List'}->{$expectedType}||'');
219          my $ignoreCase = $node->getAttributeNS (undef, 'ignoreCase') || 'false';
220          if ($ignoreCase eq 'auto') {
221            $result .= 'AutoCase ('.
222                       perl_literal ($node->getAttributeNS (undef, 'context') ||
223                                     'element').
224                       ', ';
225          } else {
226            $result .= ' (';
227        }        }
228      } elsif ($ln eq 'assertTrue') {        $result .= perl_literal ($node->getAttributeNS (undef, 'id')).', ';
229          $result .= join ", ", map {
230                       $ignoreCase eq 'true'
231                         ? ($expectedType eq 'Collection' or
232                            $expectedType eq 'List')
233                             ? "toLowerArray ($_)" : "lc ($_)"
234                         : $_
235                     } map {
236                       to_perl_value ($_)
237                     } (
238                       $expected,
239                       $node->getAttributeNS (undef, 'actual'),
240                     );
241          $result .= ");\n";
242        $Status->{Number}++;
243      } elsif ($ln eq 'assertTrue' or $ln eq 'assertFalse') {
244          my $condition;
245        if ($node->hasAttributeNS (undef, 'actual')) {        if ($node->hasAttributeNS (undef, 'actual')) {
246          $result .= perl_statement $ln . ' ('.          $condition = perl_var (type => '$',
                      perl_literal ($node->getAttributeNS (undef, 'id')).', '.  
                      perl_var (type => '$',  
247                                 local_name => $node->getAttributeNS                                 local_name => $node->getAttributeNS
248                                                         (undef, 'actual')).                                                         (undef, 'actual'));
                      ')';  
249          if ($node->hasChildNodes) {          if ($node->hasChildNodes) {
250            valid_err q<Child of $ln found but not supported>,            valid_err q<Child of $ln found but not supported>,
251              node => $node;              node => $node;
252          }          }
253          } elsif ($node->hasChildNodes) {
254            $condition = condition2code ($node);
255        } else {        } else {
256          valid_err q<assertTrue w/o @actual not supported>,        valid_err $ln.q< w/o @actual not supported>, node => $node;
           node => $node;  
257        }        }
258      } elsif ($ln eq 'assertNotNull') {        $result .= perl_statement $ln . ' ('.
259                         perl_literal ($node->getAttributeNS (undef, 'id')).', '.
260                         $condition. ')';
261        $Status->{Number}++;
262        } elsif ($ln eq 'assertNotNull' or $ln eq 'assertNull') {
263        $result .= perl_statement $ln . ' (' .        $result .= perl_statement $ln . ' (' .
264                   perl_literal ($node->getAttributeNS (undef, 'id')).', '.                   perl_literal ($node->getAttributeNS (undef, 'id')).', '.
265                   perl_var (type => '$',                   perl_var (type => '$',
# Line 141  sub node2code ($) { Line 269  sub node2code ($) {
269          valid_err q<Child of $ln found but not supported>,          valid_err q<Child of $ln found but not supported>,
270            node => $node;            node => $node;
271        }        }
272        $Status->{Number}++;
273    } elsif ($ln eq 'assertDOMException') {    } elsif ($ln eq 'assertDOMException') {
274      $Status->{use}->{'Message::Util::Error'} = 1;      $Status->{use}->{'Message::Util::Error'} = 1;
275      $result .= q[      $result .= q[
# Line 164  sub node2code ($) { Line 293  sub node2code ($) {
293          q[, $success);          q[, $success);
294        }        }
295      ];      ];
296        $Status->{Number}++;
297      } elsif ($ln eq 'contentType') {
298        $result .= '$builder->{contentType} eq '.
299                   perl_literal ($node->getAttributeNS (undef, 'type'));
300        $Status->{our}->{builder} = 1;
301      } elsif ($ln eq 'if') {
302        my $children = $node->childNodes;
303        my $condition;
304        my $true = '';
305        for (my $i = 0; $i < $children->length; $i++) {
306          my $child = $children->item ($i);
307          if ($child->nodeType == $child->ELEMENT_NODE) {
308            if (not $condition) {
309              $condition = node2code ($child);
310            } elsif ($child->localName eq 'else') {
311              valid_err q<Multiple 'else's found>, node => $child
312                if $true;
313              $true = $result;
314              $result = '';
315            } else {
316              $result .= node2code ($child);
317            }
318          } else {
319            $result .= node2code ($child);
320          }
321        }
322        $result = perl_if
323                    $condition,
324                    $true || $result,
325                    $true ? $result : undef;
326      } elsif ($ln eq 'or') {
327        $result .= condition2code ($node, join => 'or');
328      } elsif ($ln eq 'not') {
329        $result .= 'not '.condition2code ($node, join => 'nosupport');
330      } elsif ($ln eq 'notNull') {
331        $result .= 'defined '.
332                   perl_var (type => '$',
333                             local_name => $node->getAttributeNS (undef, 'obj'));
334    } else {    } else {
335      valid_err q<Unknown element type: >.$ln;      valid_err q<Unknown element type: >.$ln;
336    }    }
337    $result;    $result;
338  }  }
339    
340    our $result = '';
341    
342  my $input;  my $input;
343  {  {
344    local $/ = undef;    local $/ = undef;
345    $input = <>;    $input = <>;
346  }  }
347    
348    {
349  my $dom = Message::DOM::DOMImplementationRegistry  my $dom = Message::DOM::DOMImplementationRegistry
350              ->getDOMImplementation              ->getDOMImplementation
351                   ({Core => undef,                   ({Core => undef,
# Line 218  for (my $i = 0; $i < $child->length; $i+ Line 388  for (my $i = 0; $i < $child->length; $i+
388          my $node = $md->item ($j);          my $node = $md->item ($j);
389          if ($node->nodeType == $node->ELEMENT_NODE) {          if ($node->nodeType == $node->ELEMENT_NODE) {
390            my $ln = $node->localName;            my $ln = $node->localName;
391            if ($ln eq '...') {            if ($ln eq 'title') {
392                            $result .= perl_statement
393                             perl_assign
394                               '$Info->{Name}'
395                             => perl_literal $node->textContent;
396              } elsif ($ln eq 'description') {
397                $result .= perl_statement
398                             perl_assign
399                               '$Info->{Description}'
400                             => perl_literal $node->textContent;
401            } else {            } else {
402            #  valid_err q<Unknown element type: >.$ln,            #  valid_err q<Unknown element type: >.$ln,
403            #    node => $node;            #    node => $node;
# Line 236  for (my $i = 0; $i < $child->length; $i+ Line 414  for (my $i = 0; $i < $child->length; $i+
414              node => $node;              node => $node;
415          }          }
416        }        }
417        } elsif ($ln eq 'implementationAttribute') {
418          $result .= perl_comment
419                         sprintf 'Implementation attribute: @name=%s, @value=%s',
420                                 $node->getAttributeNS (undef, 'name'),
421                                 $node->getAttributeNS (undef, 'value');
422      } else {      } else {
423        $result .= node2code ($node);        $result .= node2code ($node);
424      }      }
# Line 251  for (my $i = 0; $i < $child->length; $i+ Line 434  for (my $i = 0; $i < $child->length; $i+
434        node => $node;        node => $node;
435    }    }
436  }  }
437    }
438    
439    my $pre = "#!/usr/bin/perl -w\nuse strict;\n";
440    $pre .= perl_statement ('require '.perl_literal 'manakai/domtest.pl');
441    $pre .= perl_statement
442                ('use Message::Util::Error')
443      if $Status->{use}->{'Message::Util::Error'};
444    for (keys %{$Status->{our}}) {
445      $pre .= perl_statement perl_var type => '$', local_name => $_,
446                                      scope => 'our';
447    }
448    $pre .= perl_statement q<plan (>.(0+$Status->{Number}).q<)>;
449    
450    output_result $pre.$result;
451    
 output_result $result;  
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24