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/;
use Getopt::Long;

require 'dommemlist.pl.tmp'; ## Generated by mkdommemlist.pl

my $output_filename;
my $output_file;
GetOptions (
  'output-file=s' => \$output_filename,
);
if (defined $output_filename) {
  open $output_file, '>', $output_filename or die "$0: $output_filename: $!";
} else {
  $output_file = \*STDOUT;
}

our $Method;
our $IFMethod;
our $Attr;
my $Assert = {
  qw/assertDOMException 1
     assertFalse 1
     assertNotNull 1
     assertNull 1
     assertSize 1
     assertTrue 1/
};
my $Misc = {
  qw/if 1
     implementationAttribute 1
     var 1/
};
my $Condition = {
  qw/condition 1
     contains 1
     contentType 1
     hasSize 1
     implementationAttribute 1
     not 1
     notNull 1
     or 1/
};

my $Status = {Number => 0, our => {Info => 1}};

## Defined in genlib.pl but redefined.
sub output_result ($) {
  print $output_file shift;
}

sub to_perl_value ($;%) {
  my ($s, %opt) = @_;
  if (defined $s) {
    if ($s =~ /^(?!\d)\w+$/) {
      return perl_var (type => '$', local_name => $s);
    } else {
      return $s;
    }
  } elsif (defined $opt{default}) {
    return $opt{default};
  } else {
    return '';
  }
}

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 condition2code ($;%) {
  my ($parent, %opt) = @_;
  my $result = '';
  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 ($Condition->{$ln}) {
        push @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 .= join (($opt{join}||='or' eq 'or' ? ' || ' : 
                    $opt{join} eq 'and' ? ' && ' : 
                    valid_err q<Multiple condition not supported>,
                      node => $parent),
                   map {"($_)"} @result);
  $result;
} #condition2code

sub node2code ($);
sub node2code ($) {
  my $node = shift;
  my $result = '';
  if ($node->nodeType != $node->ELEMENT_NODE) {
    if ($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;
    } 
    return $result;
  }
  my $ln = $node->localName;

  if ($ln eq 'var') {
    my $name = $node->getAttributeNS (undef, 'name');
    $result .= perl_statement
                   perl_var
                     local_name => $name,
                     scope => 'my',
                     type => '$';
    if ($node->getAttributeNS (undef, 'value')) {
      valid_err q<Attribute "value" not supported>, node => $node;
    }
    $Status->{var}->{$name}->{type} = $node->getAttributeNS (undef, 'type');
  } 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');
      my $param;
      if ($node->hasAttributeNS (undef, 'interface')) {
        $param = $IFMethod->{$node->getAttributeNS (undef, 'interface')}
                          ->{$ln};
      } else {
        $param = $Method->{$ln};
      }
      $result .= perl_var (type => '$',
                           local_name => $node->getAttributeNS (undef, 'obj')).
              '->'.$ln.' ('.
                join (', ',
                     map {
                       to_perl_value ($node->getAttributeNS (undef, $_),
                                      default => 'undef')
                     } @$param).
              ");\n";
    } elsif ($Attr->{$ln}) {
      if ($node->hasAttributeNS (undef, 'var')) {
        $result .= perl_var (type => '$',
                             local_name => $node->getAttributeNS (undef, 'var')).
                   ' = ';
      } elsif ($node->hasAttributeNS (undef, 'value')) {
        #
      } else {
        valid_err q<Unknown operation to an attribute>, node => $node;
      }
      $result .= perl_var (type => '$',
                           local_name => $node->getAttributeNS (undef, 'obj')).
              '->'.$ln;
      if ($node->hasAttributeNS (undef, 'var')) {
        $result .= ";\n";
      } elsif ($node->hasAttributeNS (undef, 'value')) {
        $result .= " (".to_perl_value ($node->getAttributeNS (undef, 'value')).
                   ");\n";
      }
    } elsif ($ln eq 'assertEquals') {
      my $expected = $node->getAttributeNS (undef, 'expected');
      my $expectedType = $Status->{var}->{$expected}->{type} || '';
      $result .= 'assertEquals'.
                 ({Collection => 'Collection',
                   List => 'List'}->{$expectedType}||'');
      my $ignoreCase = $node->getAttributeNS (undef, 'ignoreCase') || 'false';
      if ($ignoreCase eq 'auto') {
        $result .= 'AutoCase ('.
                   perl_literal ($node->getAttributeNS (undef, 'context') ||
                                 'element').
                   ', ';
      } else {
        $result .= ' (';
      }
      $result .= perl_literal ($node->getAttributeNS (undef, 'id')).', ';
      $result .= join ", ", map {
                   $ignoreCase eq 'true'
                     ? ($expectedType eq 'Collection' or
                        $expectedType eq 'List')
                         ? "toLowerArray ($_)" : "lc ($_)"
                     : $_
                 } map {
                   to_perl_value ($_)
                 } (
                   $expected,
                   $node->getAttributeNS (undef, 'actual'),
                 );
      $result .= ");\n";
    $Status->{Number}++;
  } elsif ($ln eq 'assertSize') {
    my $size = to_perl_value ($node->getAttributeNS (undef, 'size'));
    my $coll = to_perl_value ($node->getAttributeNS (undef, 'collection'));
    $result .= perl_statement 'assertSize ('.
                 perl_list 
                   ($node->getAttributeNS (undef, 'id'),
                    perl_code_literal $size, perl_code_literal $coll).
               ')';
    if ($node->hasChildNodes) {
      $result .= perl_if
                   qq<$size == size ($coll)>,
                   block2code ($node);
    }
  } elsif ($ln eq 'assertTrue' or $ln eq 'assertFalse') {
      my $condition;
      if ($node->hasAttributeNS (undef, 'actual')) {
        $condition = 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 ($node->hasChildNodes) {
        $condition = condition2code ($node);
      } else {
      valid_err $ln.q< w/o @actual not supported>, node => $node;
      }
      $result .= perl_statement $ln . ' ('.
                     perl_literal ($node->getAttributeNS (undef, 'id')).', '.
                     $condition. ')';
    $Status->{Number}++;
    } elsif ($ln eq 'assertNotNull' or $ln eq 'assertNull') {
      $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;
      }
    $Status->{Number}++;
  } 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);
      }
    ];
    $Status->{Number}++;
  } elsif ($ln eq 'contentType') {
    $result .= '$builder->{contentType} eq '.
               perl_literal ($node->getAttributeNS (undef, 'type'));
    $Status->{our}->{builder} = 1;
  } elsif ($ln eq 'if') {
    my $children = $node->childNodes;
    my $condition;
    my $true = '';
    for (my $i = 0; $i < $children->length; $i++) {
      my $child = $children->item ($i);
      if ($child->nodeType == $child->ELEMENT_NODE) {
        if (not $condition) {
          $condition = node2code ($child);
        } elsif ($child->localName eq 'else') {
          valid_err q<Multiple 'else's found>, node => $child
            if $true;
          $true = $result;
          $result = '';
        } else {
          $result .= node2code ($child);
        }
      } else {
        $result .= node2code ($child);
      }
    }
    $result = perl_if
                $condition,
                $true || $result,
                $true ? $result : undef;
  } elsif ($ln eq 'or') {
    $result .= condition2code ($node, join => 'or');
  } elsif ($ln eq 'not') {
    $result .= 'not '.condition2code ($node, join => 'nosupport');
  } elsif ($ln eq 'notNull') {
    $result .= 'defined '.
               perl_var (type => '$',
                         local_name => $node->getAttributeNS (undef, 'obj'));
  } else {
    valid_err q<Unknown element type: >.$ln;
  }
  $result;
}

our $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 'title') {
            $result .= perl_statement
                         perl_assign
                           '$Info->{Name}'
                         => perl_literal $node->textContent;
          } elsif ($ln eq 'description') {
            $result .= perl_statement
                         perl_assign
                           '$Info->{Description}'
                         => perl_literal $node->textContent;
          } 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;
        }
      }
    } elsif ($ln eq 'implementationAttribute') {
      $result .= perl_comment
                     sprintf 'Implementation attribute: @name=%s, @value=%s',
                             $node->getAttributeNS (undef, 'name'),
                             $node->getAttributeNS (undef, 'value');
    } 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;
  }
}
}

my $pre = "#!/usr/bin/perl -w\nuse strict;\n";
$pre .= perl_statement ('require '.perl_literal 'manakai/domtest.pl');
$pre .= perl_statement
            ('use Message::Util::Error')
  if $Status->{use}->{'Message::Util::Error'};
for (keys %{$Status->{our}}) {
  $pre .= perl_statement perl_var type => '$', local_name => $_,
                                  scope => 'our';
}
$pre .= perl_statement q<plan (>.(0+$Status->{Number}).q<)>;

output_result $pre.$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	wakaba	1.3	use Getopt::Long;
13	wakaba	1.1
14	wakaba	1.3	require 'dommemlist.pl.tmp'; ## Generated by mkdommemlist.pl
15
16			my $output_filename;
17			my $output_file;
18			GetOptions (
19			'output-file=s' => \$output_filename,
20			);
21			if (defined $output_filename) {
22			open $output_file, '>', $output_filename or die "$0: $output_filename: $!";
23			} else {
24			$output_file = \*STDOUT;
25			}
26
27	wakaba	1.4	our $Method;
28			our $IFMethod;
29	wakaba	1.3	our $Attr;
30	wakaba	1.1	my $Assert = {
31			qw/assertDOMException 1
32	wakaba	1.3	assertFalse 1
33	wakaba	1.1	assertNotNull 1
34	wakaba	1.3	assertNull 1
35	wakaba	1.4	assertSize 1
36	wakaba	1.1	assertTrue 1/
37			};
38			my $Misc = {
39	wakaba	1.3	qw/if 1
40			implementationAttribute 1
41			var 1/
42	wakaba	1.1	};
43	wakaba	1.3	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 = {Number => 0, our => {Info => 1}};
55
56			## Defined in genlib.pl but redefined.
57			sub output_result ($) {
58			print $output_file shift;
59			}
60	wakaba	1.1
61	wakaba	1.3	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	wakaba	1.1
76			sub body2code ($) {
77			my $parent = shift;
78			my $result = '';
79			my $children = $parent->childNodes;
80			for (my $i = 0; $i < $children->length; $i++) {
81			my $child = $children->item ($i);
82			if ($child->nodeType == $child->ELEMENT_NODE) {
83			my $ln = $child->localName;
84			if ($Method->{$ln} or $Attr->{$ln} or
85			$Assert->{$ln} or $Misc->{$ln}) {
86			$result .= node2code ($child);
87			} else {
88			valid_err q<Unknown element type: >.$child->localName,
89			node => $child;
90			}
91			} elsif ($child->nodeType == $child->COMMENT_NODE) {
92			$result .= perl_comment $child->data;
93			} elsif ($child->nodeType == $child->TEXT_NODE) {
94			if ($child->data =~ /\S/) {
95			valid_err q<Unknown character data: >.$child->data,
96			node => $child;
97			}
98			} else {
99			valid_err q<Unknown type of node: >.$child->nodeType,
100			node => $child;
101			}
102			}
103			$result;
104			}
105
106	wakaba	1.3	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	wakaba	1.1	sub node2code ($) {
143			my $node = shift;
144			my $result = '';
145	wakaba	1.3	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	wakaba	1.1	my $ln = $node->localName;
160
161			if ($ln eq 'var') {
162	wakaba	1.3	my $name = $node->getAttributeNS (undef, 'name');
163			$result .= perl_statement
164	wakaba	1.1	perl_var
165	wakaba	1.3	local_name => $name,
166	wakaba	1.1	scope => 'my',
167			type => '$';
168	wakaba	1.3	if ($node->getAttributeNS (undef, 'value')) {
169			valid_err q<Attribute "value" not supported>, node => $node;
170			}
171			$Status->{var}->{$name}->{type} = $node->getAttributeNS (undef, 'type');
172			} elsif ($ln eq 'load') {
173	wakaba	1.1	$result .= perl_statement
174			perl_assign
175			perl_var
176			(type => '$',
177			local_name => $node->getAttributeNS (undef, 'var'))
178			=> 'load (' .
179			perl_literal ($node->getAttributeNS (undef, 'href')).
180			')';
181			} elsif ($Method->{$ln}) {
182			$result .= perl_var (type => '$',
183			local_name => $node->getAttributeNS (undef, 'var')).
184			' = '
185			if $node->hasAttributeNS (undef, 'var');
186	wakaba	1.4	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	wakaba	1.1	$result .= perl_var (type => '$',
194			local_name => $node->getAttributeNS (undef, 'obj')).
195			'->'.$ln.' ('.
196	wakaba	1.3	join (', ',
197			map {
198			to_perl_value ($node->getAttributeNS (undef, $_),
199			default => 'undef')
200	wakaba	1.4	} @$param).
201	wakaba	1.1	");\n";
202			} elsif ($Attr->{$ln}) {
203			if ($node->hasAttributeNS (undef, 'var')) {
204			$result .= perl_var (type => '$',
205			local_name => $node->getAttributeNS (undef, 'var')).
206			' = ';
207	wakaba	1.3	} elsif ($node->hasAttributeNS (undef, 'value')) {
208			#
209	wakaba	1.1	} else {
210	wakaba	1.3	valid_err q<Unknown operation to an attribute>, node => $node;
211	wakaba	1.1	}
212			$result .= perl_var (type => '$',
213			local_name => $node->getAttributeNS (undef, 'obj')).
214			'->'.$ln;
215			if ($node->hasAttributeNS (undef, 'var')) {
216			$result .= ";\n";
217	wakaba	1.3	} 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	wakaba	1.1	}
236	wakaba	1.3	$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	wakaba	1.4	} 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	wakaba	1.3	} elsif ($ln eq 'assertTrue' or $ln eq 'assertFalse') {
265			my $condition;
266	wakaba	1.1	if ($node->hasAttributeNS (undef, 'actual')) {
267	wakaba	1.3	$condition = perl_var (type => '$',
268	wakaba	1.1	local_name => $node->getAttributeNS
269	wakaba	1.3	(undef, 'actual'));
270	wakaba	1.1	if ($node->hasChildNodes) {
271			valid_err q<Child of $ln found but not supported>,
272			node => $node;
273			}
274	wakaba	1.3	} elsif ($node->hasChildNodes) {
275			$condition = condition2code ($node);
276	wakaba	1.1	} else {
277	wakaba	1.3	valid_err $ln.q< w/o @actual not supported>, node => $node;
278	wakaba	1.1	}
279	wakaba	1.3	$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	wakaba	1.1	$result .= perl_statement $ln . ' (' .
285			perl_literal ($node->getAttributeNS (undef, 'id')).', '.
286			perl_var (type => '$',
287			local_name => $node->getAttributeNS (undef, 'actual')).
288			')';
289			if ($node->hasChildNodes) {
290			valid_err q<Child of $ln found but not supported>,
291			node => $node;
292			}
293	wakaba	1.3	$Status->{Number}++;
294	wakaba	1.1	} elsif ($ln eq 'assertDOMException') {
295			$Status->{use}->{'Message::Util::Error'} = 1;
296			$result .= q[
297			{
298			my $success = 0;
299			try {
300			];
301			my $children = $node->childNodes;
302			my $errname;
303			for (my $i = 0; $i < $children->length; $i++) {
304			my $child = $children->item ($i);
305			$errname = $child->localName if $child->nodeType == $child->ELEMENT_NODE;
306			$result .= body2code ($child);
307			}
308			$result .= q[
309			} catch Message::DOM::DOMException with {
310			my $err = shift;
311			$success = 1 if $err->{-type} eq ].perl_literal ($errname).q[;
312			}
313			assertTrue (].perl_literal ($node->getAttributeNS (undef, 'id')).
314			q[, $success);
315			}
316			];
317	wakaba	1.3	$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	wakaba	1.1	} else {
356			valid_err q<Unknown element type: >.$ln;
357			}
358			$result;
359			}
360
361	wakaba	1.3	our $result = '';
362
363	wakaba	1.1	my $input;
364			{
365			local $/ = undef;
366			$input = <>;
367			}
368
369	wakaba	1.3	{
370	wakaba	1.1	my $dom = Message::DOM::DOMImplementationRegistry
371			->getDOMImplementation
372			({Core => undef,
373			XML => undef,
374			ExpandedURI q<ManakaiDOMLS2003:LS> => '1.0'});
375
376			my $parser = $dom->createLSParser (MODE_SYNCHRONOUS);
377			my $in = $dom->createLSInput;
378			$in->stringData ($input);
379
380			my $src = $parser->parse ($in)->documentElement;
381
382			{
383			my $children = $src->ownerDocument->childNodes;
384			for (my $i = 0; $i < $children->length; $i++) {
385			my $node = $children->item ($i);
386			if ($node->nodeType == $node->COMMENT_NODE) {
387			if ($node->data =~ /Copyright/) {
388			$result .= perl_comment
389			qq<This script was generated by "$0"\n>.
390			qq<and is a derived work from the source document.\n>.
391			qq<The source document contained the following notice:\n>.
392			$node->data;
393			} else {
394			$result .= perl_comment $node->data;
395			}
396			}
397			}
398			}
399
400			my $child = $src->childNodes;
401
402			for (my $i = 0; $i < $child->length; $i++) {
403			my $node = $child->item ($i);
404			if ($node->nodeType == $node->ELEMENT_NODE) {
405			my $ln = $node->localName;
406			if ($ln eq 'metadata') {
407			my $md = $node->childNodes;
408			for (my $j = 0; $j < $md->length; $j++) {
409			my $node = $md->item ($j);
410			if ($node->nodeType == $node->ELEMENT_NODE) {
411			my $ln = $node->localName;
412	wakaba	1.3	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	wakaba	1.1	} else {
423			# valid_err q<Unknown element type: >.$ln,
424			# node => $node;
425			}
426			} elsif ($node->nodeType == $node->TEXT_NODE) {
427			if ($node->data =~ /\S/) {
428			valid_err q<Unknown character data: >.$node->data,
429			node => $node;
430			}
431			} elsif ($node->nodeType == $node->COMMENT_NODE) {
432			$result .= perl_comment $node->data;
433			} else {
434			valid_err q<Unknown node type: >.$node->nodeType,
435			node => $node;
436			}
437			}
438	wakaba	1.3	} 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	wakaba	1.1	} else {
444			$result .= node2code ($node);
445			}
446			} elsif ($node->nodeType == $node->COMMENT_NODE) {
447			$result .= perl_comment $node->data;
448			} elsif ($node->nodeType == $node->TEXT_NODE) {
449			if ($node->data =~ /\S/) {
450			valid_err q<Unknown character data: >.$node->data,
451			node => $node;
452			}
453			} else {
454			valid_err q<Unknown type of node: >.$node->nodeType,
455			node => $node;
456			}
457			}
458	wakaba	1.3	}
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	wakaba	1.1
471	wakaba	1.3	output_result $pre.$result;
472	wakaba	1.1