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