/[suikacvs]/messaging/manakai/bin/domtest2perl.pl
Suika

Diff of /messaging/manakai/bin/domtest2perl.pl

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.7 by wakaba, Wed Jan 5 12:19:38 2005 UTC revision 1.8 by wakaba, Thu Jan 6 10:41:31 2005 UTC
# Line 13  use Getopt::Long; Line 13  use Getopt::Long;
13  require 'dommemlist.pl.tmp'; ## Generated by mkdommemlist.pl  require 'dommemlist.pl.tmp'; ## Generated by mkdommemlist.pl
14    
15  my $output_filename;  my $output_filename;
 my $output_file;  
16  GetOptions (  GetOptions (
17    'output-file=s' => \$output_filename,    'output-file=s' => \$output_filename,
18  );  );
19    
20  if (defined $output_filename) {  if (defined $output_filename) {
21    open $output_file, '>', $output_filename or die "$0: $output_filename: $!";    open my $f, '>', $output_filename or die "$0: $output_filename: $!";
22      our $ResultOutput = $f;
23  } else {  } else {
24    $output_file = \*STDOUT;    our $ResultOutput = \*STDOUT;
25  }  }
26    
27  our $Method;  our $Method;
# Line 72  my $Condition = { Line 73  my $Condition = {
73    
74  my $Status = {Number => 0, our => {Info => 1}};  my $Status = {Number => 0, our => {Info => 1}};
75    
 ## Defined in genlib.pl but redefined.  
 sub output_result ($) {  
   print $output_file shift;  
 }  
   
76  sub to_perl_value ($;%) {  sub to_perl_value ($;%) {
77    my ($s, %opt) = @_;    my ($s, %opt) = @_;
78    if (defined $s) {    if (defined $s) {
# Line 474  sub node2code ($) { Line 470  sub node2code ($) {
470      my $collection = $node->getAttributeNS (undef, 'collection');      my $collection = $node->getAttributeNS (undef, 'collection');
471      my $collType = $Status->{var}->{$collection}->{type};      my $collType = $Status->{var}->{$collection}->{type};
472      my $coll = to_perl_value ($collection);      my $coll = to_perl_value ($collection);
473        my $assert;
474        my $code;
475        {
476          local $Status->{Number} = 0;
477          $code = body2code ($node);
478          $assert = $Status->{Number};
479        }
480        $Status->{Number_local} = 1;
481      $result .= 'for (my $i = 0; $i < '.      $result .= 'for (my $i = 0; $i < '.
482                 ({'Collection'=>1,'List'=>1}->{$collType}                 ({'Collection'=>1,'List'=>1}->{$collType}
483                    ? '@{'.$coll.'}' : $coll.'->length').                    ? '@{'.$coll.'}' : $coll.'->length').
484                 '; $i++) {'.                 '; $i++) {'.
485                     perl_statement (qq<plan_local ($assert)>).
486                   perl_statement                   perl_statement
487                     (perl_assign                     (perl_assign
488                         to_perl_value ($node->getAttributeNS (undef, 'member'))                         to_perl_value ($node->getAttributeNS (undef, 'member'))
489                      => $coll . ({'Collection'=>1,'List'=>1}->{$collType}                      => $coll . ({'Collection'=>1,'List'=>1}->{$collType}
490                                    ? '->[$i]' : '->item ($i)')).                                    ? '->[$i]' : '->item ($i)')).
491                   body2code ($node).                   $code.
492                 '}';                 '}';
493    } elsif ($ln eq 'try') {    } elsif ($ln eq 'try') {
494      my $children = $node->childNodes;      my $children = $node->childNodes;
# Line 556  sub node2code ($) { Line 561  sub node2code ($) {
561      if ($assert_true == $assert_false) {      if ($assert_true == $assert_false) {
562        $Status->{Number} += $assert_true;        $Status->{Number} += $assert_true;
563      } elsif ($assert_true > $assert_false) {      } elsif ($assert_true > $assert_false) {
564        $false .= perl_statement ('is_ok ()') x ($assert_true - $assert_false);        $false .= perl_statement 'skip_n ('.
565                      perl_list ($assert_true - $assert_false,
566                                 msg => q<Conditional>).')';
567        $Status->{Number} += $assert_true;        $Status->{Number} += $assert_true;
568      } else {      } else {
569        $true .= perl_statement ('is_ok ()') x ($assert_false - $assert_true);        $true .= perl_statement 'skip_n ('.
570                      perl_list ($assert_false - $assert_true,
571                                 msg => q<Conditional>).')';
572        $Status->{Number} += $assert_false;        $Status->{Number} += $assert_false;
573      }      }
574      $result = perl_if      $result = perl_if
# Line 587  sub node2code ($) { Line 596  sub node2code ($) {
596        }        }
597        $assert = $Status->{Number};        $assert = $Status->{Number};
598      }      }
599      $Status->{Number} += $assert;      $Status->{Number_local} = 1;
600      $result .= "while ($condition) {      $result .= "while ($condition) {
601                      plan_local ($assert);
602                    $true                    $true
603                  }";                  }";
604    } elsif ($ln eq 'or') {    } elsif ($ln eq 'or') {
# Line 672  sub node2code ($) { Line 682  sub node2code ($) {
682    
683  our $result = '';  our $result = '';
684    
685    my $input_filename;
686  my $input;  my $input;
687  {  {
688    local $/ = undef;    local $/ = undef;
689    $input = <>;    $input = <>;
690      $input_filename = $ARGV;
691  }  }
692    
693  {  {
# Line 699  for (my $i = 0; $i < $children->length; Line 711  for (my $i = 0; $i < $children->length;
711      if ($node->data =~ /Copyright/) {      if ($node->data =~ /Copyright/) {
712        $result .= perl_comment        $result .= perl_comment
713                     qq<This script was generated by "$0"\n>.                     qq<This script was generated by "$0"\n>.
714                     qq<and is a derived work from the source document.\n>.                     qq<and is a derived work from the source document\n>.
715                       qq<"$input_filename".\n>.
716                     qq<The source document contained the following notice:\n>.                     qq<The source document contained the following notice:\n>.
717                     $node->data;                     $node->data;
718      } else {      } else {
# Line 778  for (keys %{$Status->{our}}) { Line 791  for (keys %{$Status->{our}}) {
791    $pre .= perl_statement perl_var type => '$', local_name => $_,    $pre .= perl_statement perl_var type => '$', local_name => $_,
792                                    scope => 'our';                                    scope => 'our';
793  }  }
794  $pre .= perl_statement q<plan (>.(0+$Status->{Number}).q<)>;  my $plan = $Status->{Number_local} ? 'plan_local' : 'plan';
795    $pre .= perl_statement qq<$plan (>.(0+$Status->{Number}).q<)>;
796    
797    $result .= perl_statement q<end_of_test ()>;
798    
799  output_result $pre.$result;  output_result $pre.$result;
800    
Legend:
Removed from v.1.7  
changed lines
  Added in v.1.8
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24