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

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

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

revision 1.1 by wakaba, Sat Feb 25 16:49:55 2006 UTC revision 1.7 by wakaba, Fri Mar 17 08:06:20 2006 UTC
# Line 1  Line 1 
1  #!/usr/bin/perl -w  #!/usr/bin/perl -w
2  use strict;  use strict;
3  use Message::Util::QName::Filter {  use Message::Util::QName::Filter {
4      c => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/dom-core#>,
5    DIS => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#>,    DIS => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#>,
6    dis => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/lang#dis-->,    dis => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/lang#dis-->,
7      DOMLS => q<http://suika.fam.cx/~wakaba/archive/2004/dom/ls#>,
8    dp => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#Perl/>,    dp => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#Perl/>,
9    fe => q<http://suika.fam.cx/www/2006/feature/>,    fe => q<http://suika.fam.cx/www/2006/feature/>,
10    ManakaiDOM => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/manakai-dom#>,    ManakaiDOM => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/manakai-dom#>,
11      pc => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/PerlCode#>,
12    swcfg21 => q<http://suika.fam.cx/~wakaba/archive/2005/swcfg21#>,    swcfg21 => q<http://suika.fam.cx/~wakaba/archive/2005/swcfg21#>,
13      test => q<http://suika.fam.cx/~wakaba/archive/2004/dis/Test#>,
14    Util => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/>,    Util => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/>,
15  };  };
16    
# Line 18  GetOptions ( Line 22  GetOptions (
22    'create-perl-module=s' => sub {    'create-perl-module=s' => sub {
23      shift;      shift;
24      my $i = [split /\s+/, shift, 3];      my $i = [split /\s+/, shift, 3];
25      $i->[3] = 'pm';      $i->[3] = 'perl-pm';
26        push @{$Opt{create_module}}, $i;
27      },
28      'create-perl-test=s' => sub {
29        shift;
30        my $i = [split /\s+/, shift, 3];
31        $i->[3] = 'perl-t';
32      push @{$Opt{create_module}}, $i;      push @{$Opt{create_module}}, $i;
33    },    },
34    'debug' => \$Opt{debug},    'debug' => \$Opt{debug},
# Line 99  sub verbose_msg_ ($) { Line 109  sub verbose_msg_ ($) {
109    print STDERR $s if $Opt{verbose};    print STDERR $s if $Opt{verbose};
110  }  }
111    
112    ## ---- The MAIN Program
113    
114  my $start_time;  my $start_time;
115  BEGIN { $start_time = time }  BEGIN { $start_time = time }
116    
117  use Message::Util::DIS::DNLite;  use Message::Util::DIS::DNLite;
118  use Message::Util::PerlCode;  use Message::Util::PerlCode;
119    
120    my %feature;
121    eval q{
122      use Message::Util::DIS::Test;
123      use Message::DOM::GenericLS;
124      $feature{ExpandedURI q<fe:GenericLS>} = '3.0';
125      $feature{'+' . ExpandedURI q<DIS:TDT>} = '1.0';
126    };
127    
128  my $limpl = $Message::DOM::ImplementationRegistry->get_implementation  my $limpl = $Message::DOM::ImplementationRegistry->get_implementation
129                             ({ExpandedURI q<fe:Min> => '3.0',                             ({ExpandedURI q<fe:Min> => '3.0',
130                               '+' . ExpandedURI q<DIS:DNLite> => '1.0',                               '+' . ExpandedURI q<DIS:DNLite> => '1.0',
131                               '+' . ExpandedURI q<DIS:Core> => '1.0',                               '+' . ExpandedURI q<DIS:Core> => '1.0',
132                               '+' . ExpandedURI q<Util:PerlCode> => '1.0',                               '+' . ExpandedURI q<Util:PerlCode> => '1.0',
133                                 %feature,
134                             });                             });
135  my $impl = $limpl->get_feature (ExpandedURI q<DIS:Core> => '1.0');  my $impl = $limpl->get_feature (ExpandedURI q<DIS:Core> => '1.0');
136  my $parser = $impl->create_dis_parser;  my $tdt_parser;
137  our $DNi = $impl->get_feature (ExpandedURI q<DIS:DNLite> => '1.0');  
138    ## --- Loading and Updating the Database
139    
140  my $HasError;  my $HasError;
141  my $db = $impl->create_dis_database;  my $db = $impl->create_dis_database;
142  $db->pl_database_module_resolver (\&daf_db_module_resolver);  $db->pl_database_module_resolver (\&daf_db_module_resolver);
143  $db->dom_config->set_parameter ('error-handler' => \&daf_on_error);  $db->dom_config->set_parameter ('error-handler' => \&daf_on_error);
144    
145    my $parser = $impl->create_dis_parser;
146    my $DNi = $impl->get_feature (ExpandedURI q<DIS:DNLite> => '1.0');
147  my %ModuleSourceDISDocument;  my %ModuleSourceDISDocument;
148  my %ModuleSourceDNLDocument;  my %ModuleSourceDNLDocument;
149  my %ModuleNameNamespaceBinding = (  my %ModuleNameNamespaceBinding = (
# Line 189  get_referring_module_uri_list => sub { Line 213  get_referring_module_uri_list => sub {
213      unless (defined $ModuleSourceDISDocument{$module_uri}) {      unless (defined $ModuleSourceDISDocument{$module_uri}) {
214        daf_open_source_dis_document ($module_uri);        daf_open_source_dis_document ($module_uri);
215      }      }
     daf_convert_dis_document_to_dnl_document ();  
216    }    }
217    return daf_get_referring_module_uri_list ($module_uri);    return daf_get_referring_module_uri_list ($module_uri);
218  },  },
# Line 253  status_msg "done"; Line 276  status_msg "done";
276    
277  daf_check_undefined ();  daf_check_undefined ();
278    
279    undef $DNi;
280    undef %ModuleSourceDNLDocument;
281    exit $HasError if $HasError;
282    
283    ## --- Creating Files
284    
285  for (@{$Opt{create_module}}) {  for (@{$Opt{create_module}}) {
286    my ($mod_uri, $out_file_path, $mod_for, $out_type) = @$_;    my ($mod_uri, $out_file_path, $mod_for, $out_type) = @$_;
287    unless (defined $mod_for) {    unless (defined $mod_for) {
# Line 262  for (@{$Opt{create_module}}) { Line 291  for (@{$Opt{create_module}}) {
291    }    }
292    my $mod = $db->get_module ($mod_uri, for_arg => $mod_for);    my $mod = $db->get_module ($mod_uri, for_arg => $mod_for);
293    
294    if ($out_type eq 'pm') {    if ($out_type eq 'perl-pm') {
295      status_msg_ qq<Generating Perl module from <$mod_uri> for <$mod_for>...>;      status_msg_ qq<Generating Perl module from <$mod_uri> for <$mod_for>...>;
296      my $pl = $mod->pl_generate_perl_module_file;      my $pl = $mod->pl_generate_perl_module_file;
297      status_msg qq<done>;      status_msg qq<done>;
# Line 279  for (@{$Opt{create_module}}) { Line 308  for (@{$Opt{create_module}}) {
308      print $output $pl->stringify;      print $output $pl->stringify;
309      close $output;      close $output;
310      status_msg q<done>;      status_msg q<done>;
311      } elsif ($out_type eq 'perl-t') {
312        status_msg_ qq<Generating Perl test from <$mod_uri> for <$mod_for>...>;
313        my $pl = daf_generate_perl_test_file ($mod);
314        status_msg qq<done>;
315    
316        my $cfg = $pl->owner_document->dom_config;
317        $cfg->set_parameter (ExpandedURI q<pc:preserve-line-break> => 1);
318    
319        my $output;
320        defined $out_file_path
321            ? (open $output, '>', $out_file_path or die "$0: $out_file_path: $!")
322              : ($output = \*STDOUT);
323    
324        status_msg_ sprintf qq<Writing Perl test %s...>,
325                              defined $out_file_path
326                                ? q<">.$out_file_path.q<">
327                                : 'to stdout';
328        print $output $pl->stringify;
329        close $output;
330        status_msg q<done>;
331    }    }
332  }  }
333    
334  daf_check_undefined ();  daf_check_undefined ();
335    
336    ## --- The END
337    
338  status_msg_ "Closing the database...";  status_msg_ "Closing the database...";
339  $db->free;  $db->free;
340  undef $db;  undef $db;
 undef %ModuleSourceDNLDocument;  
341  status_msg "done";  status_msg "done";
342    
343  undef $DNi;  undef $limpl;
344    undef $impl;
345    
346  {  {
347    use integer;    use integer;
# Line 303  END { Line 354  END {
354    $db->free if $db;    $db->free if $db;
355  }  }
356    
357    ## ---- Subroutines
358    
359  sub daf_open_source_dis_document ($) {  sub daf_open_source_dis_document ($) {
360    my ($module_uri) = @_;    my ($module_uri) = @_;
361    
# Line 531  sub daf_check_undefined () { Line 584  sub daf_check_undefined () {
584    }    }
585  } # daf_check_undefined  } # daf_check_undefined
586    
587    sub daf_generate_perl_test_file ($) {
588      my $mod = shift;
589      my $pc = $impl->get_feature (ExpandedURI q<Util:PerlCode> => '1.0');
590      my $pl = $pc->create_perl_file;
591      my $pack = $pl->get_last_package ("Manakai::Test", make_new_package => 1);
592      $pack->add_use_perl_module_name ("Message::Util::DIS::Test");
593      $pack->add_use_perl_module_name ("Message::Util::Error");
594      $pack->add_require_perl_module_name ($mod->pl_fully_qualified_name);
595    
596      $pl->source_file ($mod->get_property_text (ExpandedURI q<DIS:sourceFile>, ""));
597      $pl->source_module ($mod->name_uri);
598      $pl->source_for ($mod->for_uri);
599      $pl->license_uri ($mod->get_property_resource (ExpandedURI q<dis:License>)
600                            ->uri);
601    
602      $pack->append_code ('
603        use Getopt::Long;
604        my %Skip;
605        GetOptions (
606          "Skip=s" => sub {
607            shift;
608            for (split /\s+/, shift) {
609              if (/^(\d+)-(\d+)$/) {
610                $Skip{$_} = 1 for $1..$2;
611              } else {
612                $Skip{$_} = 1;
613              }
614            }
615          },
616        );
617      ');
618    
619      $pack->append_code
620        ($pc->create_perl_statement
621           ('my $impl = $Message::DOM::ImplementationRegistry->get_implementation ({
622               "http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#Test"
623                 => "1.0",
624             })'));
625    
626      $pack->append_code
627          (my $num_statement = $pc->create_perl_statement
628                                      ('my $test = $impl->create_test_manager'));
629    
630      my $total_tests = 0;
631      my %processed;
632      for my $res (@{$mod->get_resource_list}) {
633        next if $res->owner_module ne $mod or $processed{$res->uri};
634        $processed{$res->uri} = 1;
635    
636        if ($res->is_type_uri (ExpandedURI q<test:Test>)) {
637          if ($res->is_type_uri (ExpandedURI q<test:StandaloneTest>)) {
638            my $test_num = ++$total_tests;
639            my $test_uri = $res->name_uri || $res->uri;
640    
641            $pack->append_code ('$test->start_new_test (');
642            $pack->append_new_pc_literal ($test_uri);
643            $pack->append_code (');');
644    
645            $pack->append_code ('if (not $Skip{'.$test_num.'} and not $Skip{');
646            $pack->append_new_pc_literal ($test_uri);
647            $pack->append_code ('}) {');
648            
649            $pack->append_code ('try {');
650            
651            my $test_pc = $res->pl_code_fragment;
652            if (not defined $test_pc) {
653              die "Perl test code not defined for <".$res->uri.">";
654            }
655            
656            $pack->append_code_fragment ($test_pc);
657            
658            $pack->append_code ('$test->ok;');
659            
660            $pack->append_code ('} catch Message::Util::IF::DTException with {
661              ##
662            } otherwise {
663              my $err = shift;
664              warn $err;
665              $test->not_ok;
666            };');
667    
668            $pack->append_code ('} else { warn "'.$test_num.' skipped\n" }');
669    
670          } elsif ($res->is_type_uri (ExpandedURI q<test:ParserTestSet>)) {
671            my $block = $pack->append_new_pc_block;
672            my @test;
673            
674            $tdt_parser ||= $limpl->create_gls_parser
675                                     ({
676                                       ExpandedURI q<DIS:TDT> => '1.0',
677                                      });
678            for my $tres (@{$res->get_child_resource_list_by_type
679                                    (ExpandedURI q<test:ParserTest>)}) {
680              $total_tests++;
681              push @test, my $ttest = {entity => {}};
682              $ttest->{uri} = $tres->uri;
683              for my $eres (@{$tres->get_child_resource_list_by_type
684                                       (ExpandedURI q<test:Entity>)}) {
685                my $tent = $ttest->{entity}->{$eres->uri} = {};
686                for (ExpandedURI q<test:uri>, ExpandedURI q<test:baseURI>,
687                     ExpandedURI q<test:value>) {
688                  my $v = $eres->get_property_text ($_);
689                  $tent->{$_} = $v if defined $v;
690                }
691                $ttest->{root_uri} = $eres->uri
692                  if $eres->is_type_uri (ExpandedURI q<test:RootEntity>) or
693                     not defined $ttest->{root_uri};
694              }
695    
696              ## DOM configuration parameters
697              for my $v (@{$tres->get_property_value_list
698                                  (ExpandedURI q<c:anyDOMConfigurationParameter>)}) {
699                my $cpuri = $v->name;
700                my $cp = $db->get_resource ($cpuri, for_arg => $tres->for_uri);
701                $ttest->{dom_config}->{$cp->get_dom_configuration_parameter_name}
702                  = $v->get_perl_code ($block->owner_document, $tres);
703              }
704    
705              ## Result DOM tree
706              my $tree_t = $tres->get_property_text (ExpandedURI q<test:domTree>);
707              if (defined $tree_t) {
708                $ttest->{dom_tree} = $tdt_parser->parse_string ($tree_t);
709              }
710    
711              ## Expected |DOMError|s
712              for (@{$tres->get_property_value_list (ExpandedURI q<c:erred>)}) {
713                my $err = $tdt_parser->parse_tdt_error_string
714                                         ($_->string_value, $db, $_,
715                                          undef, $tres->for_uri);
716                push @{$ttest->{dom_error}->{$err->{type}->{value}} ||= []}, $err;
717              }
718            }
719    
720            for ($block->append_statement
721                       ->append_new_pc_expression ('=')) {
722              $_->append_new_pc_variable ('$', undef, 'TestData')
723                ->variable_scope ('my');
724              $_->append_new_pc_literal (\@test);
725            }
726            
727            my $plc = $res->pl_code_fragment;
728            unless ($plc) {
729              die "Resource <".$res->uri."> does not have Perl test code";
730            }
731    
732            $block->append_code_fragment ($plc);
733            
734          } # test resource type
735        } # test:Test
736      }
737      
738      $num_statement->append_code (' (' . $total_tests . ')');
739    
740      return $pl;
741    } # daf_generate_perl_test_file
742    
743  __END__  __END__
744    
745  =head1 NAME  =head1 NAME
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.7
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24