manakai/bin/domtest2perl.pl

#!/usr/bin/perl -w 
use lib q<../lib>;
use strict;
BEGIN { require 'manakai/genlib.pl' }

use Message::Util::QName::General [qw/ExpandedURI/], {
  ManakaiDOMLS2003
    => q<http://suika.fam.cx/~wakaba/archive/2004/9/27/mdom-old-ls#>,
};
use Message::DOM::ManakaiDOMLS2003;
use Message::DOM::DOMLS qw/MODE_SYNCHRONOUS/;

my $Method = {
  qw/createEntityReference 1
     createTextNode 1
     getAttributeNode 1
     getElementsByTagName 1
     getNamedItem 1
     removeChild 1
     replaceChild 1/
};
my $Attr = {
  qw/attributes 1
     firstChild 1
     item 1
     nodeName 1
     specified 1/
};
my $Assert = {
  qw/assertDOMException 1
     assertNotNull 1
     assertTrue 1/
};
my $Misc = {
  qw/var 1/
};

my $Status;
our $result = '';

sub body2code ($) {
  my $parent = shift;
  my $result = '';
  my $children = $parent->childNodes;
  for (my $i = 0; $i < $children->length; $i++) {
    my $child = $children->item ($i);
    if ($child->nodeType == $child->ELEMENT_NODE) {
      my $ln = $child->localName;
      if ($Method->{$ln} or $Attr->{$ln} or
          $Assert->{$ln} or $Misc->{$ln}) {
        $result .= node2code ($child);
      } else {
        valid_err q<Unknown element type: >.$child->localName,
          node => $child;
      }
    } elsif ($child->nodeType == $child->COMMENT_NODE) {
      $result .= perl_comment $child->data;
    } elsif ($child->nodeType == $child->TEXT_NODE) {
      if ($child->data =~ /\S/) {
        valid_err q<Unknown character data: >.$child->data,
          node => $child;
      }
    } else {
      valid_err q<Unknown type of node: >.$child->nodeType,
        node => $child;
    }
  }
  $result;
}

sub node2code ($) {
  my $node = shift;
  my $result = '';
  my $ln = $node->localName;

  if ($ln eq 'var') {
      $result .= perl_statement
                   perl_var
                     local_name => $node->getAttributeNS (undef, 'name'),
                     scope => 'my',
                     type => '$';
      if ($node->getAttributeNS (undef, 'value')) {
        valid_err q<Attribute "value" not supported>, node => $node;
      }
    } elsif ($ln eq 'load') {
      $result .= perl_statement
                   perl_assign
                     perl_var 
                       (type => '$',
                        local_name => $node->getAttributeNS (undef, 'var'))
                   => 'load (' . 
                      perl_literal ($node->getAttributeNS (undef, 'href')).
                      ')';
    } elsif ($Method->{$ln}) {
      $result .= perl_var (type => '$',
                           local_name => $node->getAttributeNS (undef, 'var')).
                 ' = '
        if $node->hasAttributeNS (undef, 'var');
      $result .= perl_var (type => '$',
                           local_name => $node->getAttributeNS (undef, 'obj')).
              '->'.$ln.' ('.
                ## TODO: parameters
              ");\n";
    } elsif ($Attr->{$ln}) {
      if ($node->hasAttributeNS (undef, 'var')) {
        $result .= perl_var (type => '$',
                             local_name => $node->getAttributeNS (undef, 'var')).
                   ' = ';
      } else {
        impl_err q<Attr set>;
      }
      $result .= perl_var (type => '$',
                           local_name => $node->getAttributeNS (undef, 'obj')).
              '->'.$ln;
      if ($node->hasAttributeNS (undef, 'var')) {
        $result .= ";\n";
      }
    } elsif ($ln eq 'assertTrue') {
      if ($node->hasAttributeNS (undef, 'actual')) {
        $result .= perl_statement $ln . ' ('.
                     perl_literal ($node->getAttributeNS (undef, 'id')).', '.
                     perl_var (type => '$',
                               local_name => $node->getAttributeNS
                                                       (undef, 'actual')).
                     ')';
        if ($node->hasChildNodes) {
          valid_err q<Child of $ln found but not supported>,
            node => $node;
        }
      } else {
        valid_err q<assertTrue w/o @actual not supported>,
          node => $node;
      }
    } elsif ($ln eq 'assertNotNull') {
      $result .= perl_statement $ln . ' (' .
                 perl_literal ($node->getAttributeNS (undef, 'id')).', '.
                 perl_var (type => '$',
                           local_name => $node->getAttributeNS (undef, 'actual')).
                 ')';
      if ($node->hasChildNodes) {
        valid_err q<Child of $ln found but not supported>,
          node => $node;
      }
  } elsif ($ln eq 'assertDOMException') {
    $Status->{use}->{'Message::Util::Error'} = 1;
    $result .= q[
      {
        my $success = 0;
        try {
    ];
    my $children = $node->childNodes;
    my $errname;
    for (my $i = 0; $i < $children->length; $i++) {
      my $child = $children->item ($i);
      $errname = $child->localName if $child->nodeType == $child->ELEMENT_NODE;
      $result .= body2code ($child);
    }
    $result .= q[
        } catch Message::DOM::DOMException with {
          my $err = shift;
          $success = 1 if $err->{-type} eq ].perl_literal ($errname).q[;
        }
        assertTrue (].perl_literal ($node->getAttributeNS (undef, 'id')).
        q[, $success);
      }
    ];
  } else {
    valid_err q<Unknown element type: >.$ln;
  }
  $result;
}

my $input;
{
  local $/ = undef;
  $input = <>;
}

my $dom = Message::DOM::DOMImplementationRegistry
            ->getDOMImplementation
                 ({Core => undef,
                   XML => undef,
                   ExpandedURI q<ManakaiDOMLS2003:LS> => '1.0'});

my $parser = $dom->createLSParser (MODE_SYNCHRONOUS);
my $in = $dom->createLSInput;
$in->stringData ($input);

my $src = $parser->parse ($in)->documentElement;

{
my $children = $src->ownerDocument->childNodes;
for (my $i = 0; $i < $children->length; $i++) {
  my $node = $children->item ($i);
  if ($node->nodeType == $node->COMMENT_NODE) {
    if ($node->data =~ /Copyright/) {
      $result .= perl_comment 
                   qq<This script was generated by "$0"\n>.
                   qq<and is a derived work from the source document.\n>.
                   qq<The source document contained the following notice:\n>.
                   $node->data;
    } else {
      $result .= perl_comment $node->data;
    }
  }
}
}

my $child = $src->childNodes;

for (my $i = 0; $i < $child->length; $i++) {
  my $node = $child->item ($i);
  if ($node->nodeType == $node->ELEMENT_NODE) {
    my $ln = $node->localName;
    if ($ln eq 'metadata') {
      my $md = $node->childNodes;
      for (my $j = 0; $j < $md->length; $j++) {
        my $node = $md->item ($j);
        if ($node->nodeType == $node->ELEMENT_NODE) {
          my $ln = $node->localName;
          if ($ln eq '...') {
            
          } else {
          #  valid_err q<Unknown element type: >.$ln,
          #    node => $node;
          }
        } elsif ($node->nodeType == $node->TEXT_NODE) {
          if ($node->data =~ /\S/) {
            valid_err q<Unknown character data: >.$node->data,
              node => $node;
          }
        } elsif ($node->nodeType == $node->COMMENT_NODE) {
          $result .= perl_comment $node->data;
        } else {
          valid_err q<Unknown node type: >.$node->nodeType,
            node => $node;
        }
      }
    } else {
      $result .= node2code ($node);
    } 
  } elsif ($node->nodeType == $node->COMMENT_NODE) {
    $result .= perl_comment $node->data;
  } elsif ($node->nodeType == $node->TEXT_NODE) {
    if ($node->data =~ /\S/) {
      valid_err q<Unknown character data: >.$node->data,
        node => $node;
    }
  } else {
    valid_err q<Unknown type of node: >.$node->nodeType,
      node => $node;
  }
}


output_result $result;
1	wakaba	1.1	#!/usr/bin/perl -w
2			use lib q<../lib>;
3			use strict;
4	wakaba	1.2	BEGIN { require 'manakai/genlib.pl' }
5	wakaba	1.1
6			use Message::Util::QName::General [qw/ExpandedURI/], {
7			ManakaiDOMLS2003
8			=> q<http://suika.fam.cx/~wakaba/archive/2004/9/27/mdom-old-ls#>,
9			};
10			use Message::DOM::ManakaiDOMLS2003;
11			use Message::DOM::DOMLS qw/MODE_SYNCHRONOUS/;
12
13			my $Method = {
14			qw/createEntityReference 1
15			createTextNode 1
16			getAttributeNode 1
17			getElementsByTagName 1
18			getNamedItem 1
19			removeChild 1
20			replaceChild 1/
21			};
22			my $Attr = {
23			qw/attributes 1
24			firstChild 1
25			item 1
26			nodeName 1
27			specified 1/
28			};
29			my $Assert = {
30			qw/assertDOMException 1
31			assertNotNull 1
32			assertTrue 1/
33			};
34			my $Misc = {
35			qw/var 1/
36			};
37
38			my $Status;
39			our $result = '';
40
41			sub body2code ($) {
42			my $parent = shift;
43			my $result = '';
44			my $children = $parent->childNodes;
45			for (my $i = 0; $i < $children->length; $i++) {
46			my $child = $children->item ($i);
47			if ($child->nodeType == $child->ELEMENT_NODE) {
48			my $ln = $child->localName;
49			if ($Method->{$ln} or $Attr->{$ln} or
50			$Assert->{$ln} or $Misc->{$ln}) {
51			$result .= node2code ($child);
52			} else {
53			valid_err q<Unknown element type: >.$child->localName,
54			node => $child;
55			}
56			} elsif ($child->nodeType == $child->COMMENT_NODE) {
57			$result .= perl_comment $child->data;
58			} elsif ($child->nodeType == $child->TEXT_NODE) {
59			if ($child->data =~ /\S/) {
60			valid_err q<Unknown character data: >.$child->data,
61			node => $child;
62			}
63			} else {
64			valid_err q<Unknown type of node: >.$child->nodeType,
65			node => $child;
66			}
67			}
68			$result;
69			}
70
71			sub node2code ($) {
72			my $node = shift;
73			my $result = '';
74			my $ln = $node->localName;
75
76			if ($ln eq 'var') {
77			$result .= perl_statement
78			perl_var
79			local_name => $node->getAttributeNS (undef, 'name'),
80			scope => 'my',
81			type => '$';
82			if ($node->getAttributeNS (undef, 'value')) {
83			valid_err q<Attribute "value" not supported>, node => $node;
84			}
85			} elsif ($ln eq 'load') {
86			$result .= perl_statement
87			perl_assign
88			perl_var
89			(type => '$',
90			local_name => $node->getAttributeNS (undef, 'var'))
91			=> 'load (' .
92			perl_literal ($node->getAttributeNS (undef, 'href')).
93			')';
94			} elsif ($Method->{$ln}) {
95			$result .= perl_var (type => '$',
96			local_name => $node->getAttributeNS (undef, 'var')).
97			' = '
98			if $node->hasAttributeNS (undef, 'var');
99			$result .= perl_var (type => '$',
100			local_name => $node->getAttributeNS (undef, 'obj')).
101			'->'.$ln.' ('.
102			## TODO: parameters
103			");\n";
104			} elsif ($Attr->{$ln}) {
105			if ($node->hasAttributeNS (undef, 'var')) {
106			$result .= perl_var (type => '$',
107			local_name => $node->getAttributeNS (undef, 'var')).
108			' = ';
109			} else {
110			impl_err q<Attr set>;
111			}
112			$result .= perl_var (type => '$',
113			local_name => $node->getAttributeNS (undef, 'obj')).
114			'->'.$ln;
115			if ($node->hasAttributeNS (undef, 'var')) {
116			$result .= ";\n";
117			}
118			} elsif ($ln eq 'assertTrue') {
119			if ($node->hasAttributeNS (undef, 'actual')) {
120			$result .= perl_statement $ln . ' ('.
121			perl_literal ($node->getAttributeNS (undef, 'id')).', '.
122			perl_var (type => '$',
123			local_name => $node->getAttributeNS
124			(undef, 'actual')).
125			')';
126			if ($node->hasChildNodes) {
127			valid_err q<Child of $ln found but not supported>,
128			node => $node;
129			}
130			} else {
131			valid_err q<assertTrue w/o @actual not supported>,
132			node => $node;
133			}
134			} elsif ($ln eq 'assertNotNull') {
135			$result .= perl_statement $ln . ' (' .
136			perl_literal ($node->getAttributeNS (undef, 'id')).', '.
137			perl_var (type => '$',
138			local_name => $node->getAttributeNS (undef, 'actual')).
139			')';
140			if ($node->hasChildNodes) {
141			valid_err q<Child of $ln found but not supported>,
142			node => $node;
143			}
144			} elsif ($ln eq 'assertDOMException') {
145			$Status->{use}->{'Message::Util::Error'} = 1;
146			$result .= q[
147			{
148			my $success = 0;
149			try {
150			];
151			my $children = $node->childNodes;
152			my $errname;
153			for (my $i = 0; $i < $children->length; $i++) {
154			my $child = $children->item ($i);
155			$errname = $child->localName if $child->nodeType == $child->ELEMENT_NODE;
156			$result .= body2code ($child);
157			}
158			$result .= q[
159			} catch Message::DOM::DOMException with {
160			my $err = shift;
161			$success = 1 if $err->{-type} eq ].perl_literal ($errname).q[;
162			}
163			assertTrue (].perl_literal ($node->getAttributeNS (undef, 'id')).
164			q[, $success);
165			}
166			];
167			} else {
168			valid_err q<Unknown element type: >.$ln;
169			}
170			$result;
171			}
172
173			my $input;
174			{
175			local $/ = undef;
176			$input = <>;
177			}
178
179			my $dom = Message::DOM::DOMImplementationRegistry
180			->getDOMImplementation
181			({Core => undef,
182			XML => undef,
183			ExpandedURI q<ManakaiDOMLS2003:LS> => '1.0'});
184
185			my $parser = $dom->createLSParser (MODE_SYNCHRONOUS);
186			my $in = $dom->createLSInput;
187			$in->stringData ($input);
188
189			my $src = $parser->parse ($in)->documentElement;
190
191			{
192			my $children = $src->ownerDocument->childNodes;
193			for (my $i = 0; $i < $children->length; $i++) {
194			my $node = $children->item ($i);
195			if ($node->nodeType == $node->COMMENT_NODE) {
196			if ($node->data =~ /Copyright/) {
197			$result .= perl_comment
198			qq<This script was generated by "$0"\n>.
199			qq<and is a derived work from the source document.\n>.
200			qq<The source document contained the following notice:\n>.
201			$node->data;
202			} else {
203			$result .= perl_comment $node->data;
204			}
205			}
206			}
207			}
208
209			my $child = $src->childNodes;
210
211			for (my $i = 0; $i < $child->length; $i++) {
212			my $node = $child->item ($i);
213			if ($node->nodeType == $node->ELEMENT_NODE) {
214			my $ln = $node->localName;
215			if ($ln eq 'metadata') {
216			my $md = $node->childNodes;
217			for (my $j = 0; $j < $md->length; $j++) {
218			my $node = $md->item ($j);
219			if ($node->nodeType == $node->ELEMENT_NODE) {
220			my $ln = $node->localName;
221			if ($ln eq '...') {
222
223			} else {
224			# valid_err q<Unknown element type: >.$ln,
225			# node => $node;
226			}
227			} elsif ($node->nodeType == $node->TEXT_NODE) {
228			if ($node->data =~ /\S/) {
229			valid_err q<Unknown character data: >.$node->data,
230			node => $node;
231			}
232			} elsif ($node->nodeType == $node->COMMENT_NODE) {
233			$result .= perl_comment $node->data;
234			} else {
235			valid_err q<Unknown node type: >.$node->nodeType,
236			node => $node;
237			}
238			}
239			} else {
240			$result .= node2code ($node);
241			}
242			} elsif ($node->nodeType == $node->COMMENT_NODE) {
243			$result .= perl_comment $node->data;
244			} elsif ($node->nodeType == $node->TEXT_NODE) {
245			if ($node->data =~ /\S/) {
246			valid_err q<Unknown character data: >.$node->data,
247			node => $node;
248			}
249			} else {
250			valid_err q<Unknown type of node: >.$node->nodeType,
251			node => $node;
252			}
253			}
254
255
256			output_result $result;