/[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.5 by wakaba, Sun Oct 31 12:29:00 2004 UTC revision 1.8 by wakaba, Thu Jan 6 10:41:31 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/;
# Line 14  use Getopt::Long; Line 13  use Getopt::Long;
13  require 'dommemlist.pl.tmp'; ## Generated by mkdommemlist.pl  require 'dommemlist.pl.tmp'; ## Generated by mkdommemlist.pl
14    
15  my $output_filename;  my $output_filename;
 my $output_file;  
16  GetOptions (  GetOptions (
17    'output-file=s' => \$output_filename,    'output-file=s' => \$output_filename,
18  );  );
19    
20  if (defined $output_filename) {  if (defined $output_filename) {
21    open $output_file, '>', $output_filename or die "$0: $output_filename: $!";    open my $f, '>', $output_filename or die "$0: $output_filename: $!";
22      our $ResultOutput = $f;
23  } else {  } else {
24    $output_file = \*STDOUT;    our $ResultOutput = \*STDOUT;
25  }  }
26    
27  our $Method;  our $Method;
# Line 73  my $Condition = { Line 73  my $Condition = {
73    
74  my $Status = {Number => 0, our => {Info => 1}};  my $Status = {Number => 0, our => {Info => 1}};
75    
 ## Defined in genlib.pl but redefined.  
 sub output_result ($) {  
   print $output_file shift;  
 }  
   
76  sub to_perl_value ($;%) {  sub to_perl_value ($;%) {
77    my ($s, %opt) = @_;    my ($s, %opt) = @_;
78    if (defined $s) {    if (defined $s) {
# Line 237  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                   ' = '                   ' = '
# Line 448  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          };          };
# Line 465  sub node2code ($) { Line 470  sub node2code ($) {
470      my $collection = $node->getAttributeNS (undef, 'collection');      my $collection = $node->getAttributeNS (undef, 'collection');
471      my $collType = $Status->{var}->{$collection}->{type};      my $collType = $Status->{var}->{$collection}->{type};
472      my $coll = to_perl_value ($collection);      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 < '.      $result .= 'for (my $i = 0; $i < '.
482                 ({'Collection'=>1,'List'=>1}->{$collType}                 ({'Collection'=>1,'List'=>1}->{$collType}
483                    ? '@{'.$coll.'}' : $coll.'->length').                    ? '@{'.$coll.'}' : $coll.'->length').
484                 '; $i++) {'.                 '; $i++) {'.
485                     perl_statement (qq<plan_local ($assert)>).
486                   perl_statement                   perl_statement
487                     (perl_assign                     (perl_assign
488                         to_perl_value ($node->getAttributeNS (undef, 'member'))                         to_perl_value ($node->getAttributeNS (undef, 'member'))
489                      => $coll . ({'Collection'=>1,'List'=>1}->{$collType}                      => $coll . ({'Collection'=>1,'List'=>1}->{$collType}
490                                    ? '->[$i]' : '->item ($i)')).                                    ? '->[$i]' : '->item ($i)')).
491                   body2code ($node).                   $code.
492                 '}';                 '}';
493    } elsif ($ln eq 'try') {    } elsif ($ln eq 'try') {
494      my $children = $node->childNodes;      my $children = $node->childNodes;
# Line 512  sub node2code ($) { Line 526  sub node2code ($) {
526      }      }
527      $result = "try {      $result = "try {
528                   $true                   $true
529                 } catch Message::DOM::ManakaiDOMException with {                 } catch Message::DOM::DOMMain::ManakaiDOMException with {
530                   my \$err = shift;                   my \$err = shift;
531                   $false                   $false
532                 };";                 };";
# Line 547  sub node2code ($) { Line 561  sub node2code ($) {
561      if ($assert_true == $assert_false) {      if ($assert_true == $assert_false) {
562        $Status->{Number} += $assert_true;        $Status->{Number} += $assert_true;
563      } elsif ($assert_true > $assert_false) {      } elsif ($assert_true > $assert_false) {
564        $false .= perl_statement ('is_ok ()') x ($assert_true - $assert_false);        $false .= perl_statement 'skip_n ('.
565                      perl_list ($assert_true - $assert_false,
566                                 msg => q<Conditional>).')';
567        $Status->{Number} += $assert_true;        $Status->{Number} += $assert_true;
568      } else {      } else {
569        $true .= perl_statement ('is_ok ()') x ($assert_false - $assert_true);        $true .= perl_statement 'skip_n ('.
570                      perl_list ($assert_false - $assert_true,
571                                 msg => q<Conditional>).')';
572        $Status->{Number} += $assert_false;        $Status->{Number} += $assert_false;
573      }      }
574      $result = perl_if      $result = perl_if
# Line 578  sub node2code ($) { Line 596  sub node2code ($) {
596        }        }
597        $assert = $Status->{Number};        $assert = $Status->{Number};
598      }      }
599      $Status->{Number} += $assert;      $Status->{Number_local} = 1;
600      $result .= "while ($condition) {      $result .= "while ($condition) {
601                      plan_local ($assert);
602                    $true                    $true
603                  }";                  }";
604    } elsif ($ln eq 'or') {    } elsif ($ln eq 'or') {
# Line 663  sub node2code ($) { Line 682  sub node2code ($) {
682    
683  our $result = '';  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  {  {
694  my $dom = Message::DOM::DOMImplementationRegistry  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 690  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 739  for (my $i = 0; $i < $child->length; $i+ Line 761  for (my $i = 0; $i < $child->length; $i+
761          }          }
762        }        }
763      } elsif ($ln eq 'implementationAttribute') {      } elsif ($ln eq 'implementationAttribute') {
764        $result .= perl_comment        $result .= perl_statement 'impl_attr ('.
765                       sprintf 'Implementation attribute: @name=%s, @value=%s',                           perl_list
766                               $node->getAttributeNS (undef, 'name'),                               ($node->getAttributeNS (undef, 'name'),
767                               $node->getAttributeNS (undef, 'value');                                $node->getAttributeNS (undef, 'value')).')';
768      } else {      } else {
769        $result .= node2code ($node);        $result .= node2code ($node);
770      }      }
# Line 769  for (keys %{$Status->{our}}) { Line 791  for (keys %{$Status->{our}}) {
791    $pre .= perl_statement perl_var type => '$', local_name => $_,    $pre .= perl_statement perl_var type => '$', local_name => $_,
792                                    scope => 'our';                                    scope => 'our';
793  }  }
794  $pre .= perl_statement q<plan (>.(0+$Status->{Number}).q<)>;  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;  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    
Legend:
Removed from v.1.5  
changed lines
  Added in v.1.8
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24