/[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.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/;
# Line 237  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                   ' = '                   ' = '
# Line 448  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          };          };
# Line 512  sub node2code ($) { Line 521  sub node2code ($) {
521      }      }
522      $result = "try {      $result = "try {
523                   $true                   $true
524                 } catch Message::DOM::ManakaiDOMException with {                 } catch Message::DOM::DOMMain::ManakaiDOMException with {
525                   my \$err = shift;                   my \$err = shift;
526                   $false                   $false
527                 };";                 };";
# Line 670  my $input; Line 679  my $input;
679  }  }
680    
681  {  {
682  my $dom = Message::DOM::DOMImplementationRegistry  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 739  for (my $i = 0; $i < $child->length; $i+ Line 748  for (my $i = 0; $i < $child->length; $i+
748          }          }
749        }        }
750      } elsif ($ln eq 'implementationAttribute') {      } elsif ($ln eq 'implementationAttribute') {
751        $result .= perl_comment        $result .= perl_statement 'impl_attr ('.
752                       sprintf 'Implementation attribute: @name=%s, @value=%s',                           perl_list
753                               $node->getAttributeNS (undef, 'name'),                               ($node->getAttributeNS (undef, 'name'),
754                               $node->getAttributeNS (undef, 'value');                                $node->getAttributeNS (undef, 'value')).')';
755      } else {      } else {
756        $result .= node2code ($node);        $result .= node2code ($node);
757      }      }
# Line 773  $pre .= perl_statement q<plan (>.(0+$Sta Line 782  $pre .= perl_statement q<plan (>.(0+$Sta
782    
783  output_result $pre.$result;  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    
Legend:
Removed from v.1.5  
changed lines
  Added in v.1.7
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24