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 $Attr;
our $MethodParam;
my $Assert = {
  qw/assertDOMException 1
     assertFalse 1
     assertNotNull 1
     assertNull 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');
      $result .= perl_var (type => '$',
                           local_name => $node->getAttributeNS (undef, 'obj')).
              '->'.$ln.' ('.
                join (', ',
                     map {
                       to_perl_value ($node->getAttributeNS (undef, $_),
                                      default => 'undef')
                     } @{$Method->{$ln}}).
              ");\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 '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	#!/usr/bin/perl -w
2	use lib q<../lib>;
3	use strict;
4	BEGIN { require 'manakai/genlib.pl' }
5
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	use Getopt::Long;
13
14	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	our $Method;
28	our $Attr;
29	our $MethodParam;
30	my $Assert = {
31	qw/assertDOMException 1
32	assertFalse 1
33	assertNotNull 1
34	assertNull 1
35	assertTrue 1/
36	};
37	my $Misc = {
38	qw/if 1
39	implementationAttribute 1
40	var 1/
41	};
42	my $Condition = {
43	qw/condition 1
44	contains 1
45	contentType 1
46	hasSize 1
47	implementationAttribute 1
48	not 1
49	notNull 1
50	or 1/
51	};
52
53	my $Status = {Number => 0, our => {Info => 1}};
54
55	## Defined in genlib.pl but redefined.
56	sub output_result ($) {
57	print $output_file shift;
58	}
59
60	sub to_perl_value ($;%) {
61	my ($s, %opt) = @_;
62	if (defined $s) {
63	if ($s =~ /^(?!\d)\w+$/) {
64	return perl_var (type => '$', local_name => $s);
65	} else {
66	return $s;
67	}
68	} elsif (defined $opt{default}) {
69	return $opt{default};
70	} else {
71	return '';
72	}
73	}
74
75	sub body2code ($) {
76	my $parent = shift;
77	my $result = '';
78	my $children = $parent->childNodes;
79	for (my $i = 0; $i < $children->length; $i++) {
80	my $child = $children->item ($i);
81	if ($child->nodeType == $child->ELEMENT_NODE) {
82	my $ln = $child->localName;
83	if ($Method->{$ln} or $Attr->{$ln} or
84	$Assert->{$ln} or $Misc->{$ln}) {
85	$result .= node2code ($child);
86	} else {
87	valid_err q<Unknown element type: >.$child->localName,
88	node => $child;
89	}
90	} elsif ($child->nodeType == $child->COMMENT_NODE) {
91	$result .= perl_comment $child->data;
92	} elsif ($child->nodeType == $child->TEXT_NODE) {
93	if ($child->data =~ /\S/) {
94	valid_err q<Unknown character data: >.$child->data,
95	node => $child;
96	}
97	} else {
98	valid_err q<Unknown type of node: >.$child->nodeType,
99	node => $child;
100	}
101	}
102	$result;
103	}
104
105	sub condition2code ($;%) {
106	my ($parent, %opt) = @_;
107	my $result = '';
108	my @result;
109	my $children = $parent->childNodes;
110	for (my $i = 0; $i < $children->length; $i++) {
111	my $child = $children->item ($i);
112	if ($child->nodeType == $child->ELEMENT_NODE) {
113	my $ln = $child->localName;
114	if ($Condition->{$ln}) {
115	push @result, node2code ($child);
116	} else {
117	valid_err q<Unknown element type: >.$child->localName,
118	node => $child;
119	}
120	} elsif ($child->nodeType == $child->COMMENT_NODE) {
121	$result .= perl_comment $child->data;
122	} elsif ($child->nodeType == $child->TEXT_NODE) {
123	if ($child->data =~ /\S/) {
124	valid_err q<Unknown character data: >.$child->data,
125	node => $child;
126	}
127	} else {
128	valid_err q<Unknown type of node: >.$child->nodeType,
129	node => $child;
130	}
131	}
132	$result .= join (($opt{join}\|\|='or' eq 'or' ? ' \|\| ' :
133	$opt{join} eq 'and' ? ' && ' :
134	valid_err q<Multiple condition not supported>,
135	node => $parent),
136	map {"($_)"} @result);
137	$result;
138	} #condition2code
139
140	sub node2code ($);
141	sub node2code ($) {
142	my $node = shift;
143	my $result = '';
144	if ($node->nodeType != $node->ELEMENT_NODE) {
145	if ($node->nodeType == $node->COMMENT_NODE) {
146	$result .= perl_comment $node->data;
147	} elsif ($node->nodeType == $node->TEXT_NODE) {
148	if ($node->data =~ /\S/) {
149	valid_err q<Unknown character data: >.$node->data,
150	node => $node;
151	}
152	} else {
153	valid_err q<Unknown type of node: >.$node->nodeType,
154	node => $node;
155	}
156	return $result;
157	}
158	my $ln = $node->localName;
159
160	if ($ln eq 'var') {
161	my $name = $node->getAttributeNS (undef, 'name');
162	$result .= perl_statement
163	perl_var
164	local_name => $name,
165	scope => 'my',
166	type => '$';
167	if ($node->getAttributeNS (undef, 'value')) {
168	valid_err q<Attribute "value" not supported>, node => $node;
169	}
170	$Status->{var}->{$name}->{type} = $node->getAttributeNS (undef, 'type');
171	} elsif ($ln eq 'load') {
172	$result .= perl_statement
173	perl_assign
174	perl_var
175	(type => '$',
176	local_name => $node->getAttributeNS (undef, 'var'))
177	=> 'load (' .
178	perl_literal ($node->getAttributeNS (undef, 'href')).
179	')';
180	} elsif ($Method->{$ln}) {
181	$result .= perl_var (type => '$',
182	local_name => $node->getAttributeNS (undef, 'var')).
183	' = '
184	if $node->hasAttributeNS (undef, 'var');
185	$result .= perl_var (type => '$',
186	local_name => $node->getAttributeNS (undef, 'obj')).
187	'->'.$ln.' ('.
188	join (', ',
189	map {
190	to_perl_value ($node->getAttributeNS (undef, $_),
191	default => 'undef')
192	} @{$Method->{$ln}}).
193	");\n";
194	} elsif ($Attr->{$ln}) {
195	if ($node->hasAttributeNS (undef, 'var')) {
196	$result .= perl_var (type => '$',
197	local_name => $node->getAttributeNS (undef, 'var')).
198	' = ';
199	} elsif ($node->hasAttributeNS (undef, 'value')) {
200	#
201	} else {
202	valid_err q<Unknown operation to an attribute>, node => $node;
203	}
204	$result .= perl_var (type => '$',
205	local_name => $node->getAttributeNS (undef, 'obj')).
206	'->'.$ln;
207	if ($node->hasAttributeNS (undef, 'var')) {
208	$result .= ";\n";
209	} elsif ($node->hasAttributeNS (undef, 'value')) {
210	$result .= " (".to_perl_value ($node->getAttributeNS (undef, 'value')).
211	");\n";
212	}
213	} elsif ($ln eq 'assertEquals') {
214	my $expected = $node->getAttributeNS (undef, 'expected');
215	my $expectedType = $Status->{var}->{$expected}->{type} \|\| '';
216	$result .= 'assertEquals'.
217	({Collection => 'Collection',
218	List => 'List'}->{$expectedType}\|\|'');
219	my $ignoreCase = $node->getAttributeNS (undef, 'ignoreCase') \|\| 'false';
220	if ($ignoreCase eq 'auto') {
221	$result .= 'AutoCase ('.
222	perl_literal ($node->getAttributeNS (undef, 'context') \|\|
223	'element').
224	', ';
225	} else {
226	$result .= ' (';
227	}
228	$result .= perl_literal ($node->getAttributeNS (undef, 'id')).', ';
229	$result .= join ", ", map {
230	$ignoreCase eq 'true'
231	? ($expectedType eq 'Collection' or
232	$expectedType eq 'List')
233	? "toLowerArray ($_)" : "lc ($_)"
234	: $_
235	} map {
236	to_perl_value ($_)
237	} (
238	$expected,
239	$node->getAttributeNS (undef, 'actual'),
240	);
241	$result .= ");\n";
242	$Status->{Number}++;
243	} elsif ($ln eq 'assertTrue' or $ln eq 'assertFalse') {
244	my $condition;
245	if ($node->hasAttributeNS (undef, 'actual')) {
246	$condition = perl_var (type => '$',
247	local_name => $node->getAttributeNS
248	(undef, 'actual'));
249	if ($node->hasChildNodes) {
250	valid_err q<Child of $ln found but not supported>,
251	node => $node;
252	}
253	} elsif ($node->hasChildNodes) {
254	$condition = condition2code ($node);
255	} else {
256	valid_err $ln.q< w/o @actual not supported>, node => $node;
257	}
258	$result .= perl_statement $ln . ' ('.
259	perl_literal ($node->getAttributeNS (undef, 'id')).', '.
260	$condition. ')';
261	$Status->{Number}++;
262	} elsif ($ln eq 'assertNotNull' or $ln eq 'assertNull') {
263	$result .= perl_statement $ln . ' (' .
264	perl_literal ($node->getAttributeNS (undef, 'id')).', '.
265	perl_var (type => '$',
266	local_name => $node->getAttributeNS (undef, 'actual')).
267	')';
268	if ($node->hasChildNodes) {
269	valid_err q<Child of $ln found but not supported>,
270	node => $node;
271	}
272	$Status->{Number}++;
273	} elsif ($ln eq 'assertDOMException') {
274	$Status->{use}->{'Message::Util::Error'} = 1;
275	$result .= q[
276	{
277	my $success = 0;
278	try {
279	];
280	my $children = $node->childNodes;
281	my $errname;
282	for (my $i = 0; $i < $children->length; $i++) {
283	my $child = $children->item ($i);
284	$errname = $child->localName if $child->nodeType == $child->ELEMENT_NODE;
285	$result .= body2code ($child);
286	}
287	$result .= q[
288	} catch Message::DOM::DOMException with {
289	my $err = shift;
290	$success = 1 if $err->{-type} eq ].perl_literal ($errname).q[;
291	}
292	assertTrue (].perl_literal ($node->getAttributeNS (undef, 'id')).
293	q[, $success);
294	}
295	];
296	$Status->{Number}++;
297	} elsif ($ln eq 'contentType') {
298	$result .= '$builder->{contentType} eq '.
299	perl_literal ($node->getAttributeNS (undef, 'type'));
300	$Status->{our}->{builder} = 1;
301	} elsif ($ln eq 'if') {
302	my $children = $node->childNodes;
303	my $condition;
304	my $true = '';
305	for (my $i = 0; $i < $children->length; $i++) {
306	my $child = $children->item ($i);
307	if ($child->nodeType == $child->ELEMENT_NODE) {
308	if (not $condition) {
309	$condition = node2code ($child);
310	} elsif ($child->localName eq 'else') {
311	valid_err q<Multiple 'else's found>, node => $child
312	if $true;
313	$true = $result;
314	$result = '';
315	} else {
316	$result .= node2code ($child);
317	}
318	} else {
319	$result .= node2code ($child);
320	}
321	}
322	$result = perl_if
323	$condition,
324	$true \|\| $result,
325	$true ? $result : undef;
326	} elsif ($ln eq 'or') {
327	$result .= condition2code ($node, join => 'or');
328	} elsif ($ln eq 'not') {
329	$result .= 'not '.condition2code ($node, join => 'nosupport');
330	} elsif ($ln eq 'notNull') {
331	$result .= 'defined '.
332	perl_var (type => '$',
333	local_name => $node->getAttributeNS (undef, 'obj'));
334	} else {
335	valid_err q<Unknown element type: >.$ln;
336	}
337	$result;
338	}
339
340	our $result = '';
341
342	my $input;
343	{
344	local $/ = undef;
345	$input = <>;
346	}
347
348	{
349	my $dom = Message::DOM::DOMImplementationRegistry
350	->getDOMImplementation
351	({Core => undef,
352	XML => undef,
353	ExpandedURI q<ManakaiDOMLS2003:LS> => '1.0'});
354
355	my $parser = $dom->createLSParser (MODE_SYNCHRONOUS);
356	my $in = $dom->createLSInput;
357	$in->stringData ($input);
358
359	my $src = $parser->parse ($in)->documentElement;
360
361	{
362	my $children = $src->ownerDocument->childNodes;
363	for (my $i = 0; $i < $children->length; $i++) {
364	my $node = $children->item ($i);
365	if ($node->nodeType == $node->COMMENT_NODE) {
366	if ($node->data =~ /Copyright/) {
367	$result .= perl_comment
368	qq<This script was generated by "$0"\n>.
369	qq<and is a derived work from the source document.\n>.
370	qq<The source document contained the following notice:\n>.
371	$node->data;
372	} else {
373	$result .= perl_comment $node->data;
374	}
375	}
376	}
377	}
378
379	my $child = $src->childNodes;
380
381	for (my $i = 0; $i < $child->length; $i++) {
382	my $node = $child->item ($i);
383	if ($node->nodeType == $node->ELEMENT_NODE) {
384	my $ln = $node->localName;
385	if ($ln eq 'metadata') {
386	my $md = $node->childNodes;
387	for (my $j = 0; $j < $md->length; $j++) {
388	my $node = $md->item ($j);
389	if ($node->nodeType == $node->ELEMENT_NODE) {
390	my $ln = $node->localName;
391	if ($ln eq 'title') {
392	$result .= perl_statement
393	perl_assign
394	'$Info->{Name}'
395	=> perl_literal $node->textContent;
396	} elsif ($ln eq 'description') {
397	$result .= perl_statement
398	perl_assign
399	'$Info->{Description}'
400	=> perl_literal $node->textContent;
401	} else {
402	# valid_err q<Unknown element type: >.$ln,
403	# node => $node;
404	}
405	} elsif ($node->nodeType == $node->TEXT_NODE) {
406	if ($node->data =~ /\S/) {
407	valid_err q<Unknown character data: >.$node->data,
408	node => $node;
409	}
410	} elsif ($node->nodeType == $node->COMMENT_NODE) {
411	$result .= perl_comment $node->data;
412	} else {
413	valid_err q<Unknown node type: >.$node->nodeType,
414	node => $node;
415	}
416	}
417	} elsif ($ln eq 'implementationAttribute') {
418	$result .= perl_comment
419	sprintf 'Implementation attribute: @name=%s, @value=%s',
420	$node->getAttributeNS (undef, 'name'),
421	$node->getAttributeNS (undef, 'value');
422	} else {
423	$result .= node2code ($node);
424	}
425	} elsif ($node->nodeType == $node->COMMENT_NODE) {
426	$result .= perl_comment $node->data;
427	} elsif ($node->nodeType == $node->TEXT_NODE) {
428	if ($node->data =~ /\S/) {
429	valid_err q<Unknown character data: >.$node->data,
430	node => $node;
431	}
432	} else {
433	valid_err q<Unknown type of node: >.$node->nodeType,
434	node => $node;
435	}
436	}
437	}
438
439	my $pre = "#!/usr/bin/perl -w\nuse strict;\n";
440	$pre .= perl_statement ('require '.perl_literal 'manakai/domtest.pl');
441	$pre .= perl_statement
442	('use Message::Util::Error')
443	if $Status->{use}->{'Message::Util::Error'};
444	for (keys %{$Status->{our}}) {
445	$pre .= perl_statement perl_var type => '$', local_name => $_,
446	scope => 'our';
447	}
448	$pre .= perl_statement q<plan (>.(0+$Status->{Number}).q<)>;
449
450	output_result $pre.$result;
451