manakai/bin/domtest2perl.pl

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

use Message::Util::QName::Filter {
  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/;

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

use Getopt::Long;
use Pod::Usage;
my %Opt = ();
GetOptions (
  'debug' => \$Opt{debug},
  'help' => \$Opt{help},
  'output-file-name=s' => \$Opt{output_file_name},
  'verbose!' => \$Opt{verbose},
) or pod2usage (2);
pod2usage ({-exitval => 0, -verbose => 1}) if $Opt{help};
$Opt{file_name} = shift;
pod2usage ({-exitval => 2, -verbose => 0}) unless $Opt{file_name};
$Message::DOM::DOMFeature::DEBUG = 1 if $Opt{debug};

sub status_msg ($) {
  my $s = shift;
  $s .= "\n" unless $s =~ /\n$/;
  print STDERR $s;
}

sub status_msg_ ($) {
  my $s = shift;
  print STDERR $s;
}

sub verbose_msg ($) {
  my $s = shift;
  $s .= "\n" unless $s =~ /\n$/;
  print STDERR $s if $Opt{verbose};
}

sub verbose_msg_ ($) {
  my $s = shift;
  print STDERR $s if $Opt{verbose};
}

my $start_time;
BEGIN { $start_time = time }


our $Method;
our $IFMethod;
our $Attr;
my $Assert = {
  qw/assertDOMException 1
     assertEquals 1
     assertFalse 1
     assertInstanceOf 1
     assertNotNull 1
     assertNull 1
     assertSame 1
     assertSize 1
     assertTrue 1
     assertURIEquals 1/
};
my $Misc = {
  qw/append 1
     assign 1
     decrement 1
     fail 1
     if 1
     implementationAttribute 1
     increment 1
     for 1
     plus 1
     var 1
     while 1/
};
my $Condition = {
  qw/condition 1
     contains 1
     contentType 1
     equals 1
     greater 1
     greaterOrEquals 1
     hasSize 1
     implementationAttribute 1
     instanceOf 1
     isNull 1
     less 1
     lessOrEquals 1
     not 1
     notEquals 1
     notNull 1
     or 1/
};

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

sub to_perl_value ($;%) {
  my ($s, %opt) = @_;
  if (defined $s) {
    if ($s =~ /^(?!\d)\w+$/) {
      if ({true => 1, false => 1}->{$s}) {
        return {true => '1', false => '0'}->{$s};
      } else {
        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->child_nodes;
  for (my $i = 0; $i < $children->length; $i++) {
    my $child = $children->item ($i);
    if ($child->node_type == $child->ELEMENT_NODE) {
      my $ln = $child->local_name;
      if ($Method->{$ln} or $Attr->{$ln} or
          $Assert->{$ln} or $Misc->{$ln}) {
        $result .= node2code ($child);
      } else {
        valid_err q<Unknown element type: >.$child->local_name,
          node => $child;
      }
    } elsif ($child->node_type == $child->COMMENT_NODE) {
      $result .= perl_comment $child->data;
    } elsif ($child->node_type == $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->node_type,
        node => $child;
    }
  }
  $result;
}

sub condition2code ($;%) {
  my ($parent, %opt) = @_;
  my $result = '';
  my @result;
  my $children = $parent->child_nodes;
  for (my $i = 0; $i < $children->length; $i++) {
    my $child = $children->item ($i);
    if ($child->node_type == $child->ELEMENT_NODE) {
      my $ln = $child->local_name;
      if ($Condition->{$ln}) {
        push @result, node2code ($child);
      } else {
        valid_err q<Unknown element type: >.$child->local_name,
          node => $child;
      }
    } elsif ($child->node_type == $child->COMMENT_NODE) {
      $result .= perl_comment $child->data;
    } elsif ($child->node_type == $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->node_type,
        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->node_type != $node->ELEMENT_NODE) {
    if ($node->node_type == $node->COMMENT_NODE) {
      $result .= perl_comment $node->data;
    } elsif ($node->node_type == $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->node_type,
        node => $node;
    } 
    return $result;
  }
  my $ln = $node->local_name;

  if ($ln eq 'var') {
    my $name = $node->get_attribute_ns (undef, 'name');
    my $var = perl_var
                     local_name => $name,
                     scope => 'my',
                     type => '$';
    my $type = $node->get_attribute_ns (undef, 'type');
    $result .= perl_comment $type;
    if ($node->has_attribute_ns (undef, 'isNull') and
        $node->get_attribute_ns (undef, 'isNull') eq 'true') {
      $result .= perl_statement perl_assign $var => 'undef';
    } elsif ($node->has_attribute_ns (undef, 'value')) {
      $result .= perl_statement
                   perl_assign
                        $var
                     => to_perl_value ($node->get_attribute_ns (undef, 'value'));
    } else {
      if ($type eq 'List' or $type eq 'Collection') {
        my @member;
        my $children = $node->child_nodes;
        for (my $i = 0; $i < $children->length; $i++) {
          my $child = $children->item ($i);
          if ($child->node_type == $child->ELEMENT_NODE) {
            if ($child->local_name eq 'member') {
              push @member, perl_code_literal 
                              (to_perl_value ($child->text_content));
            } else {
              valid_err q<Unsupported element type>, node => $child;
            }
          } elsif ($child->node_type == $child->COMMENT_NODE) {
            $result .= perl_comment $child->data;
          }
        }
        $result .= perl_statement
                     perl_assign
                          $var
                       => perl_list \@member;
      } elsif ($type =~ /Monitor/) {
        valid_err qq<Type $type not supported>, node => $node;
      } elsif ($node->has_child_nodes) {
        valid_err q<Children not supported>, node => $node;
      } else {
        $result .= perl_statement $var;
      }
    }
    $Status->{var}->{$name}->{type} = $node->get_attribute_ns (undef, 'type');
  } elsif ($ln eq 'load') {
      $result .= perl_statement
                   perl_assign
                     perl_var 
                       (type => '$',
                        local_name => $node->get_attribute_ns (undef, 'var'))
                   => 'load (' . 
                      perl_literal ($node->get_attribute_ns (undef, 'href')).
                      ')';
  } elsif ($ln eq 'hasFeature' and
           not $node->has_attribute_ns (undef, 'var')) {
    ## If there is a "hasFeature" element in "body" and 
    ## it does not have "var" attribute, then it is part of the
    ## implementation condition. 
    $result .= perl_statement 'hasFeature ('.
                       to_perl_value ($node->get_attribute_ns (undef, 'feature'),
                                      default => 'undef') . ', '.
                       to_perl_value ($node->get_attribute_ns (undef, 'version'),
                                      default => 'undef') . ')';
  } elsif ($Method->{$ln} or $Attr->{$ln}) {
  MA: {
    M: {
      last M unless $Method->{$ln};
      $result .= perl_var (type => '$',
                           local_name => $node->get_attribute_ns (undef, 'var')).
                 ' = '
        if $node->has_attribute_ns (undef, 'var');
      my $param;
      if ($node->has_attribute_ns (undef, 'interface')) {
        my $if = $node->get_attribute_ns (undef, 'interface');
        $param = $IFMethod->{$if}->{$ln};
        unless ($param) {
          last M if $Attr->{$ln};
          valid_err "Method $if.$ln not supported", node => $node;
        }
        if ($if eq 'Element' and $ln eq 'getElementsByTagName' and
            not $node->has_attribute_ns (undef, 'name') and
            $node->has_attribute_ns (undef, 'tagname')) {
          $node->set_attribute_ns (undef, 'name'
                                 => $node->get_attribute_ns (undef, 'tagname'));
        }
      } else {
        $param = $Method->{$ln};
      }
      $result .= perl_var (type => '$',
                           local_name => $node->get_attribute_ns (undef, 'obj')).
              '->'.$param->[0].' ('.
                join (', ',
                     map {
                       to_perl_value ($node->get_attribute_ns (undef, $_),
                                      default => 'undef')
                     } @$param[1..$#$param]).
              ");\n";
      last MA;
    } # M
    A: {
      if ($node->has_attribute_ns (undef, 'var')) {
        $result .= perl_var (type => '$',
                             local_name => $node->get_attribute_ns (undef, 'var')).
                   ' = ';
      } elsif ($node->has_attribute_ns (undef, 'value')) {
        #
      } else {
        valid_err q<Unknown operation to an attribute>, node => $node;
      }
      my $obj = perl_var (type => '$',
                          local_name => $node->get_attribute_ns (undef, 'obj'));
      my $if = $node->get_attribute_ns (undef, 'interface');
      if (defined $if and $if eq 'DOMString') {
        if ($ln eq 'length') {
          $result .= 'length '.$obj;
        } else {
          valid_err q<$if.$ln not supported>, node => $node;
        }
      } else {
        $result .= $obj.'->'.$Attr->{$ln};
      }
      if ($node->has_attribute_ns (undef, 'var')) {
        $result .= ";\n";
      } elsif ($node->has_attribute_ns (undef, 'value')) {
        $result .= " (".to_perl_value ($node->get_attribute_ns (undef, 'value')).
                   ");\n";
      }
      } # A
    } # MA
    } elsif ($ln eq 'assertEquals') {
      my $expected = $node->get_attribute_ns (undef, 'expected');
      my $expectedType = $Status->{var}->{$expected}->{type} || '';
      $result .= 'assertEquals'.
                 ({Collection => 'Collection',
                   List => 'List'}->{$expectedType}||'');
      my $ignoreCase = $node->get_attribute_ns (undef, 'ignoreCase') || 'false';
      if ($ignoreCase eq 'auto') {
        $result .= 'AutoCase ('.
                   perl_literal ($node->get_attribute_ns (undef, 'context') ||
                                 'element').
                   ', ';
      } else {
        $result .= ' (';
      }
      $result .= perl_literal ($node->get_attribute_ns (undef, 'id')).', ';
      $result .= join ", ", map {
                   $ignoreCase eq 'true'
                     ? ($expectedType eq 'Collection' or
                        $expectedType eq 'List')
                         ? "toLowerArray ($_)" : "lc ($_)"
                     : $_
                 } map {
                   to_perl_value ($_)
                 } (
                   $expected,
                   $node->get_attribute_ns (undef, 'actual'),
                 );
      $result .= ");\n";
    $Status->{Number}++;
  } elsif ($ln eq 'assertInstanceOf') {
    my $obj = perl_code_literal
                (to_perl_value ($node->get_attribute_ns (undef, 'obj')));
    $result .= perl_statement 'assertInstanceOf ('.
                 perl_list 
                   ($node->get_attribute_ns (undef, 'id'),
                    $node->get_attribute_ns (undef, 'type'),
                    $obj).
               ')';
    if ($node->has_child_nodes) {
      $result .= perl_if
                   'isInstanceOf ('.
                   perl_list
                     ($node->get_attribute_ns (undef, 'type'),
                      $obj) . ')',
                   body2code ($node);
    }
    $Status->{Number}++;
  } elsif ($ln eq 'assertSame') {
    my $expected = to_perl_value ($node->get_attribute_ns (undef, 'expected'));
    my $actual = to_perl_value ($node->get_attribute_ns (undef, 'actual'));
    $result .= perl_statement 'assertSame ('.
                 perl_list 
                   ($node->get_attribute_ns (undef, 'id'),
                    $expected, $actual).
               ')';
    if ($node->has_child_nodes) {
      $result .= perl_if
                   'same ('.(perl_list $expected, $actual).')',
                   body2code ($node);
    }
    $Status->{Number}++;
  } elsif ($ln eq 'assertSize') {
    my $size = to_perl_value ($node->get_attribute_ns (undef, 'size'));
    my $coll = to_perl_value ($node->get_attribute_ns (undef, 'collection'));
    $result .= perl_statement 'assertSize ('.
                 perl_list 
                   ($node->get_attribute_ns (undef, 'id'),
                    perl_code_literal $size, perl_code_literal $coll).
               ')';
    if ($node->has_child_nodes) {
      $result .= perl_if
                   qq<$size == size ($coll)>,
                   body2code ($node);
    }
    $Status->{Number}++;
  } elsif ($ln eq 'assertTrue' or $ln eq 'assertFalse') {
      my $condition;
      if ($node->has_attribute_ns (undef, 'actual')) {
        $condition = perl_var (type => '$',
                               local_name => $node->get_attribute_ns
                                                       (undef, 'actual'));
        if ($node->has_child_nodes) {
          valid_err q<Child of $ln found but not supported>,
            node => $node;
        }
      } elsif ($node->has_child_nodes) {
        $condition = condition2code ($node);
      } else {
      valid_err $ln.q< w/o @actual not supported>, node => $node;
      }
      $result .= perl_statement $ln . ' ('.
                     perl_literal ($node->get_attribute_ns (undef, 'id')).', '.
                     $condition. ')';
    $Status->{Number}++;
  } elsif ($ln eq 'assertNotNull' or $ln eq 'assertNull') {
    $result .= perl_statement $ln . ' (' .
                 perl_literal ($node->get_attribute_ns (undef, 'id')).', '.
                 perl_var (type => '$',
                           local_name => $node->get_attribute_ns (undef, 'actual')).
                 ')';
    if ($node->has_child_nodes) {
      valid_err q<Child of $ln found but not supported>,
          node => $node;
    }
    $Status->{Number}++;
  } elsif ($ln eq 'assertURIEquals') {
    $result .= perl_statement 'assertURIEquals ('.
                 perl_list
                   ($node->get_attribute_ns (undef, 'id'),
                    perl_code_literal
                      (to_perl_value ($node->get_attribute_ns (undef, 'scheme'),
                                      default => 'undef')),
                    perl_code_literal
                      (to_perl_value ($node->get_attribute_ns (undef, 'path'),
                                      default => 'undef')),
                    perl_code_literal
                      (to_perl_value ($node->get_attribute_ns (undef, 'host'),
                                      default => 'undef')),
                    perl_code_literal
                      (to_perl_value ($node->get_attribute_ns (undef, 'file'),
                                      default => 'undef')),
                    perl_code_literal
                      (to_perl_value ($node->get_attribute_ns (undef, 'name'),
                                      default => 'undef')),
                    perl_code_literal
                      (to_perl_value ($node->get_attribute_ns (undef, 'query'),
                                      default => 'undef')),
                    perl_code_literal
                      (to_perl_value ($node->get_attribute_ns (undef, 'fragment'),
                                      default => 'undef')),
                    perl_code_literal
                      (to_perl_value ($node->get_attribute_ns (undef, 'isAbsolute'),
                                      default => 'undef')),
                    perl_code_literal
                      (to_perl_value ($node->get_attribute_ns (undef, 'actual')))).
               ')';
    $Status->{Number}++;
  } elsif ($ln eq 'assertDOMException') {
    $Status->{use}->{'Message::Util::Error'} = 1;
    $result .= q[
      {
        my $success = 0;
        try {
    ];
    my $children = $node->child_nodes;
    my $errname;
    for (my $i = 0; $i < $children->length; $i++) {
      my $child = $children->item ($i);
      $errname = $child->local_name if $child->node_type == $child->ELEMENT_NODE;
      $result .= body2code ($child);
    }
    $result .= q[
        } catch Message::DOM::IF::DOMException with {
          my $err = shift;
          $success = 1 if $err->{-type} eq ].perl_literal ($errname).q[;
        };
        assertTrue (].perl_literal ($node->get_attribute_ns (undef, 'id')).
        q[, $success);
      }
    ];
    $Status->{Number}++;
  } elsif ($ln eq 'contentType') {
    $result .= '$builder->{contentType} eq '.
               perl_literal ($node->get_attribute_ns (undef, 'type'));
    $Status->{our}->{builder} = 1;
  } elsif ($ln eq 'for-each') {
    my $collection = $node->get_attribute_ns (undef, 'collection');
    my $collType = $Status->{var}->{$collection}->{type};
    my $coll = to_perl_value ($collection);
    my $assert;
    my $code;
    {
      local $Status->{Number} = 0;
      $code = body2code ($node);
      $assert = $Status->{Number};
    }
    $Status->{Number_local} = 1;
    $result .= 'for (my $i = 0; $i < '.
               ({'Collection'=>1,'List'=>1}->{$collType}
                  ? '@{'.$coll.'}' : $coll.'->length').
               '; $i++) {'.
                 perl_statement (qq<plan_local ($assert)>).
                 perl_statement
                   (perl_assign
                       to_perl_value ($node->get_attribute_ns (undef, 'member'))
                    => $coll . ({'Collection'=>1,'List'=>1}->{$collType}
                                  ? '->[$i]' : '->item ($i)')).
                 $code.
               '}';
  } elsif ($ln eq 'try') {
    my $children = $node->child_nodes;
    my $true = '';
    my $false = '';
    for (my $i = 0; $i < $children->length; $i++) {
      my $child = $children->item ($i);
      if ($child->node_type == $child->ELEMENT_NODE) {
        if ($child->local_name eq 'catch') {
          valid_err q<Multiple 'catch'es found>, node => $child
            if $false;
          my @case;
          my $children2 = $child->child_nodes;
          for (my $j = 0; $j < $children2->length; $j++) {
            my $child2 = $children2->item ($j);
            if ($child2->node_type == $child2->ELEMENT_NODE) {
              if ($child2->local_name eq 'ImplementationException') {
                valid_err q<Element type not supported>, node => $child2;
              } else {
                push @case, '$err->{-type} eq '.
                          perl_literal ($child2->get_attribute_ns (undef, 'code'))
                            => body2code ($child2);
              }
            } else {
              $false .= node2code ($child2);
            }
          }
          $false .= perl_cases @case, else => perl_statement '$err->throw';
        } else {
          $true .= node2code ($child);
        }
      } else {
        $true .= node2code ($child);
      }
    }
    $result = "try {
                 $true
               } catch Message::DOM::DOMMain::ManakaiDOMException with {
                 my \$err = shift;
                 $false
               };";
    $Status->{use}->{'Message::Util::Error'} = 1;
  } elsif ($ln eq 'if') {
    my $children = $node->child_nodes;
    my $condition;
    my $true = '';
    my $false = '';
    my $assert_true = 0;
    my $assert_false = 0;
    for (my $i = 0; $i < $children->length; $i++) {
      my $child = $children->item ($i);
      if ($child->node_type == $child->ELEMENT_NODE) {
        if (not $condition) {
          $condition = node2code ($child);
        } elsif ($child->local_name eq 'else') {
          valid_err q<Multiple 'else's found>, node => $child
            if $false;
          local $Status->{Number} = 0;
          $false = body2code ($child);
          $assert_false = $Status->{Number};
        } else {
          local $Status->{Number} = 0;
          $true .= node2code ($child);
          $assert_true += $Status->{Number};
        }
      } else {
        $true .= node2code ($child);
      }
    }
    if ($assert_true == $assert_false) {
      $Status->{Number} += $assert_true;
    } elsif ($assert_true > $assert_false) {
      $false .= perl_statement 'skip_n ('.
                  perl_list ($assert_true - $assert_false,
                             msg => q<Conditional>).')';
      $Status->{Number} += $assert_true;
    } else {
      $true .= perl_statement 'skip_n ('.
                  perl_list ($assert_false - $assert_true,
                             msg => q<Conditional>).')';
      $Status->{Number} += $assert_false;
    }
    $result = perl_if
                $condition,
                $true,
                $false ? $false : undef;
  } elsif ($ln eq 'while') {
    my $children = $node->child_nodes;
    my $condition;
    my $true = '';
    my $assert = 0;
    {
      local $Status->{Number} = 0;
      for (my $i = 0; $i < $children->length; $i++) {
        my $child = $children->item ($i);
        if ($child->node_type == $child->ELEMENT_NODE) {
          if (not $condition) {
            $condition = node2code ($child);
          } else {
            $true .= node2code ($child);
          }
        } else {
          $true .= node2code ($child);
        }
      }
      $assert = $Status->{Number};
    }
    $Status->{Number_local} = 1;
    $result .= "while ($condition) {
                  plan_local ($assert);
                  $true
                }";
  } elsif ($ln eq 'or') {
    $result .= condition2code ($node, join => 'or');
  } elsif ($ln eq 'not') {
    $result .= 'not '.condition2code ($node, join => 'nosupport');
  } elsif ($ln eq 'notNull' or $ln eq 'isNull') {
    $result .= 'defined '.
               perl_var (type => '$',
                         local_name => $node->get_attribute_ns (undef, 'obj'));
    $result = 'not ' . $result if $ln eq 'isNull';
  } elsif ({less => 1, lessOrEquals => 1,
            greater => 1, greaterOrEquals => 1}->{$ln}) {
    $result .= to_perl_value ($node->get_attribute_ns (undef, 'actual')).
               {less => '<', lessOrEquals => '<=',
                greater => '>', greaterOrEquals => '>='}->{$ln}.
               to_perl_value ($node->get_attribute_ns (undef, 'expected'));
  } elsif ($ln eq 'equals' or $ln eq 'notEquals') {
    my $case = $node->get_attribute_ns (undef, 'ignoreCase');
    if ($case and $case eq 'auto') {
      $result .= 'equalsAutoCase (' .
                   perl_list
                     ($node->get_attribute_ns (undef, 'context') || 'element',
                      to_perl_value
                        ($node->get_attribute_ns (undef, 'expected')),
                      to_perl_value
                        ($node->get_attribute_ns (undef, 'actual'))) . ')';
    } else {
      my $expected = to_perl_value
                        ($node->get_attribute_ns (undef, 'expected'));
      my $actual = to_perl_value
                        ($node->get_attribute_ns (undef, 'actual'));
      if ($case eq 'true') {
        $result = "(uc ($expected) eq uc ($actual))";
      } elsif ($node->has_attribute_ns (undef, 'bitmask')) {
        my $bm = ' & ' . to_perl_value
                          ($node->get_attribute_ns (undef, 'bitmask'));
        $result = "($expected$bm == $actual$bm)";
      } else {
        $result = "($expected eq $actual)";
      }
    }
    $result = "(not $result)" if $ln eq 'notEquals';
  } elsif ($ln eq 'increment' or $ln eq 'decrement') {
    $result .= perl_statement
                 to_perl_value ($node->get_attribute_ns (undef, 'var')).
                 {increment => ' += ', decrement => ' -= '}->{$ln}.
                 to_perl_value ($node->get_attribute_ns (undef, 'value'));
  } elsif ({qw/plus 1 subtract 1 mult 1 divide 1/}->{$ln}) {
    $result .= perl_statement
                 (perl_assign
                     to_perl_value ($node->get_attribute_ns (undef, 'var'))
                  => to_perl_value ($node->get_attribute_ns (undef, 'op1')).
                     {qw<plus + subtract - mult * divide />}->{$ln}.
                     to_perl_value ($node->get_attribute_ns (undef, 'op2')));
  } elsif ($ln eq 'append') {
    $result .= perl_statement
                 'push @{'.
                    to_perl_value ($node->get_attribute_ns (undef, 'collection')).
                    '}, '.
                    to_perl_value ($node->get_attribute_ns (undef, 'item'));
  } elsif ($ln eq 'instanceOf') {
    $result .= 'isInstanceOf ('.
               perl_list ($node->get_attribute_ns (undef, 'type'),
                          perl_code_literal to_perl_value
                            ($node->get_attribute_ns (undef, 'obj'))).
               ')';
  } elsif ($ln eq 'assign') {
    $result .= perl_statement
                 perl_assign
                      to_perl_value ($node->get_attribute_ns (undef, 'var'))
                   => to_perl_value ($node->get_attribute_ns (undef, 'value'));
  } elsif ($ln eq 'fail') {
    $result .= perl_statement 'fail ('.
                 perl_literal ($node->get_attribute_ns (undef, 'id')). ')';
  } else {
    valid_err q<Unknown element type: >.$ln;
  }
  $result;
}

our $result = '';

my $input = '';
{
  open my $in, '<', $Opt{file_name} or die "$0: $Opt{file_name}: $!";
  while (<$in>) {
    $input .= $_;
  }
}

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

  my $parser = $dom->create_ls_parser (MODE_SYNCHRONOUS);
  my $in = $dom->create_ls_input;
  $in->string_data ($input);
  
  status_msg_ q<Parsing XML entity...>;
  my $src = $parser->parse ($in)->document_element;
  status_msg q<done>;
  
  status_msg_ q<Generating test script...>;
  {
    my $children = $src->owner_document->child_nodes;
    for (my $i = 0; $i < $children->length; $i++) {
      my $node = $children->item ($i);
      if ($node->node_type == $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<"$Opt{file_name}".\n>.
                       qq<The source document contained the following notice:\n>.
                       $node->data;
        } else {
          $result .= perl_comment $node->data;
        }
      }
    }
  }
  
  my $child = $src->child_nodes;

for (my $i = 0; $i < $child->length; $i++) {
  my $node = $child->item ($i);
  if ($node->node_type == $node->ELEMENT_NODE) {
    my $ln = $node->local_name;
    if ($ln eq 'metadata') {
      my $md = $node->child_nodes;
      for (my $j = 0; $j < $md->length; $j++) {
        my $node = $md->item ($j);
        if ($node->node_type == $node->ELEMENT_NODE) {
          my $ln = $node->local_name;
          if ($ln eq 'title') {
            $result .= perl_statement
                         perl_assign
                           '$Info->{Name}'
                         => perl_literal $node->text_content;
          } elsif ($ln eq 'description') {
            $result .= perl_statement
                         perl_assign
                           '$Info->{Description}'
                         => perl_literal $node->text_content;
          } else {
          #  valid_err q<Unknown element type: >.$ln,
          #    node => $node;
          }
        } elsif ($node->node_type == $node->TEXT_NODE) {
          if ($node->data =~ /\S/) {
            valid_err q<Unknown character data: >.$node->data,
              node => $node;
          }
        } elsif ($node->node_type == $node->COMMENT_NODE) {
          $result .= perl_comment $node->data;
        } else {
          valid_err q<Unknown node type: >.$node->node_type,
            node => $node;
        }
      }
    } elsif ($ln eq 'implementationAttribute') {
      $result .= perl_statement 'impl_attr ('.
                         perl_list
                             ($node->get_attribute_ns (undef, 'name'),
                              $node->get_attribute_ns (undef, 'value')).')';
    } else {
      $result .= node2code ($node);
    } 
  } elsif ($node->node_type == $node->COMMENT_NODE) {
    $result .= perl_comment $node->data;
  } elsif ($node->node_type == $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->node_type,
      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';
}
my $plan = $Status->{Number_local} ? 'plan_local' : 'plan';
$pre .= perl_statement qq<$plan (>.(0+$Status->{Number}).q<)>;

$result .= perl_statement q<end_of_test ()>;
status_msg q<done>;

{
  my $output;
  my $out_file_path = $Opt{output_file_name};
  defined $out_file_path
    ? (open $output, '>', $out_file_path or die "$0: $out_file_path: $!")
    : ($output = \*STDOUT);

  status_msg_ sprintf qq<Writing Perl script %s...>,
                      defined $out_file_path
                        ? q<">.$out_file_path.q<">
                        : 'to stdout';
  print $output $pre.$result;
  close $output;
  status_msg q<done>;
}

1;

__END__

=head1 NAME

domtest2perl - DOM Test Suite XML Test File to Perl Test Code Converter

=head1 SYNOPSIS

  perl path/to/domtest2perl.pl input.xml > output.pl
  perl path/to/domtest2perl.pl input.xml --output-file=output.pl

=over 4

=item I<input.xml>

The name of file to input.  It should be an XML document 
in the DOM Test Suite. 

=item I<output.pl>

The name of file to output.  It is overwritten if already exists. 

=back

=head1 SEE ALSO

I<Document Object Model (DOM) Conformance Test Suites>,
<http://www.w3.org/DOM/Test/>.

F<domts2perl.pl>

F<mkdommemlist.pl>

=head1 LICENSE

Copyright 2004-2005 Wakaba <w@suika.fam.cx>.  All rights reserved.

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut
