/[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.3 by wakaba, Sun Feb 26 14:32:38 2006 UTC revision 1.10 by wakaba, Mon Apr 3 12:53:22 2006 UTC
# Line 116  BEGIN { $start_time = time } Line 116  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  use Message::Util::DIS::Test;  
120  use Message::DOM::GenericLS;  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',
                              ExpandedURI q<fe:GenericLS> => '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                               '+' . ExpandedURI q<DIS:TDT> => '1.0',                               %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');
 my $pc = $impl->get_feature (ExpandedURI q<Util:PerlCode> => '1.0');  
 my $di = $impl->get_feature (ExpandedURI q<DIS:Core> => '1.0');  
136  my $tdt_parser;  my $tdt_parser;
137    
138  ## --- Loading and Updating the Database  ## --- Loading and Updating the Database
# Line 210  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 291  for (@{$Opt{create_module}}) { Line 293  for (@{$Opt{create_module}}) {
293    
294    if ($out_type eq 'perl-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;      local $Message::Util::DIS::Perl::Implementation
297            = $impl->get_feature (ExpandedURI q<Util:PerlCode> => '1.0');
298        my $pl = $mod->pl_generate_perl_module_file
299                        ($impl->get_feature (ExpandedURI q<Util:PerlCode> => '1.0'));
300      status_msg qq<done>;      status_msg qq<done>;
301    
302      my $output;      my $output;
# Line 338  $db->free; Line 343  $db->free;
343  undef $db;  undef $db;
344  status_msg "done";  status_msg "done";
345    
346    undef $limpl;
347    undef $impl;
348    
349  {  {
350    use integer;    use integer;
351    my $time = time - $start_time;    my $time = time - $start_time;
# Line 476  sub daf_get_referring_module_uri_list ($ Line 484  sub daf_get_referring_module_uri_list ($
484  sub dac_search_file_path_stem ($$$) {  sub dac_search_file_path_stem ($$$) {
485    my ($ns, $ln, $suffix) = @_;    my ($ns, $ln, $suffix) = @_;
486    require File::Spec;    require File::Spec;
487    for my $dir ('.', @{$Opt{input_search_path}->{$ns}||[]}) {    for my $dir (@{$Opt{input_search_path}->{$ns}||[]}) {
488      my $name = Cwd::abs_path      my $name = Cwd::abs_path
489          (File::Spec->canonpath          (File::Spec->canonpath
490           (File::Spec->catfile ($dir, $ln)));           (File::Spec->catfile ($dir, $ln)));
# Line 581  sub daf_check_undefined () { Line 589  sub daf_check_undefined () {
589    
590  sub daf_generate_perl_test_file ($) {  sub daf_generate_perl_test_file ($) {
591    my $mod = shift;    my $mod = shift;
592    my $pl = $pc->create_perl_file;    my $pc = $impl->get_feature (ExpandedURI q<Util:PerlCode> => '1.0');
593      local $Message::Util::DIS::Perl::Implementation = $pc;
594      my $pl = $pc->create_pc_file;
595      my $factory = $pl->owner_document;
596    my $pack = $pl->get_last_package ("Manakai::Test", make_new_package => 1);    my $pack = $pl->get_last_package ("Manakai::Test", make_new_package => 1);
597    $pack->add_use_perl_module_name ("Message::Util::DIS::Test");    $pack->add_use_perl_module_name ("Message::Util::DIS::Test");
598    $pack->add_use_perl_module_name ("Message::Util::Error");    $pack->add_use_perl_module_name ("Message::Util::Error");
# Line 593  sub daf_generate_perl_test_file ($) { Line 604  sub daf_generate_perl_test_file ($) {
604    $pl->license_uri ($mod->get_property_resource (ExpandedURI q<dis:License>)    $pl->license_uri ($mod->get_property_resource (ExpandedURI q<dis:License>)
605                          ->uri);                          ->uri);
606    
607      $pack->append_code ('
608        use Getopt::Long;
609        my %Skip;
610        GetOptions (
611          "Skip=s" => sub {
612            shift;
613            for (split /\s+/, shift) {
614              if (/^(\d+)-(\d+)$/) {
615                $Skip{$_} = 1 for $1..$2;
616              } else {
617                $Skip{$_} = 1;
618              }
619            }
620          },
621        );
622      ');
623    
624    $pack->append_code    $pack->append_code
625      ($pc->create_perl_statement      ($pc->create_perl_statement
626         ('my $impl = $Message::DOM::ImplementationRegistry->get_implementation ({         ('my $impl = $Message::DOM::ImplementationRegistry->get_implementation ({
# Line 612  sub daf_generate_perl_test_file ($) { Line 640  sub daf_generate_perl_test_file ($) {
640    
641      if ($res->is_type_uri (ExpandedURI q<test:Test>)) {      if ($res->is_type_uri (ExpandedURI q<test:Test>)) {
642        if ($res->is_type_uri (ExpandedURI q<test:StandaloneTest>)) {        if ($res->is_type_uri (ExpandedURI q<test:StandaloneTest>)) {
643          $total_tests++;          my $test_num = ++$total_tests;
644            my $test_uri = $res->name_uri || $res->uri;
645    
646          $pack->append_code ('$test->start_new_test (');          $pack->append_code ('$test->start_new_test (');
647          $pack->append_new_pc_literal ($res->name_uri || $res->uri);          $pack->append_new_pc_literal ($test_uri);
648          $pack->append_code (');');          $pack->append_code (');');
649    
650            $pack->append_code ('if (not $Skip{'.$test_num.'} and not $Skip{');
651            $pack->append_new_pc_literal ($test_uri);
652            $pack->append_code ('}) {');
653                    
654          $pack->append_code ('try {');          $pack->append_code ('try {');
655                    
656          my $test_pc = $res->pl_code_fragment;          my $test_pc = $res->pl_code_fragment ($factory);
657          if (not defined $test_pc) {          if (not defined $test_pc) {
658            die "Perl test code not defined for <".$res->uri.">";            die "Perl test code not defined for <".$res->uri.">";
659          }          }
# Line 636  sub daf_generate_perl_test_file ($) { Line 670  sub daf_generate_perl_test_file ($) {
670            $test->not_ok;            $test->not_ok;
671          };');          };');
672    
673            $pack->append_code ('} else { warn "'.$test_num.' skipped\n" }');
674    
675        } elsif ($res->is_type_uri (ExpandedURI q<test:ParserTestSet>)) {        } elsif ($res->is_type_uri (ExpandedURI q<test:ParserTestSet>)) {
676          my $block = $pack->append_new_pc_block;          my $block = $pack->append_new_pc_block;
677          my @test;          my @test;
# Line 662  sub daf_generate_perl_test_file ($) { Line 698  sub daf_generate_perl_test_file ($) {
698                   not defined $ttest->{root_uri};                   not defined $ttest->{root_uri};
699            }            }
700    
701              ## DOM configuration parameters
702              for my $v (@{$tres->get_property_value_list
703                                  (ExpandedURI q<c:anyDOMConfigurationParameter>)}) {
704                my $cpuri = $v->name;
705                my $cp = $db->get_resource ($cpuri, for_arg => $tres->for_uri);
706                $ttest->{dom_config}->{$cp->get_dom_configuration_parameter_name}
707                  = $v->get_perl_code ($block->owner_document, $tres);
708              }
709    
710            ## Result DOM tree            ## Result DOM tree
711            my $tree_t = $tres->get_property_text (ExpandedURI q<test:domTree>);            my $tree_t = $tres->get_property_text (ExpandedURI q<test:domTree>);
712            if (defined $tree_t) {            if (defined $tree_t) {
# Line 684  sub daf_generate_perl_test_file ($) { Line 729  sub daf_generate_perl_test_file ($) {
729            $_->append_new_pc_literal (\@test);            $_->append_new_pc_literal (\@test);
730          }          }
731                    
732          my $plc = $res->pl_code_fragment;          my $plc = $res->pl_code_fragment ($factory);
733          unless ($plc) {          unless ($plc) {
734            die "Resource <".$res->uri."> does not have Perl test code";            die "Resource <".$res->uri."> does not have Perl test code";
735          }          }
Legend:
Removed from v.1.3  
changed lines
  Added in v.1.10
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24