/[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.5 by wakaba, Sun Mar 12 10:13:31 2006 UTC revision 1.11 by wakaba, Tue Apr 4 14:30:29 2006 UTC
# Line 34  GetOptions ( Line 34  GetOptions (
34    'debug' => \$Opt{debug},    'debug' => \$Opt{debug},
35    'dis-file-suffix=s' => \$Opt{dis_suffix},    'dis-file-suffix=s' => \$Opt{dis_suffix},
36    'daem-file-suffix=s' => \$Opt{daem_suffix},    'daem-file-suffix=s' => \$Opt{daem_suffix},
37      'dafs-file-suffix=s' => \$Opt{dafs_suffix},
38    'dafx-file-suffix=s' => \$Opt{dafx_suffix},    'dafx-file-suffix=s' => \$Opt{dafx_suffix},
39    'help' => \$Opt{help},    'help' => \$Opt{help},
40    'search-path|I=s' => sub {    'search-path|I=s' => sub {
# Line 82  $Opt{no_undef_check} = defined $Opt{no_u Line 83  $Opt{no_undef_check} = defined $Opt{no_u
83  $Opt{dis_suffix} = '.dis' unless defined $Opt{dis_suffix};  $Opt{dis_suffix} = '.dis' unless defined $Opt{dis_suffix};
84  $Opt{daem_suffix} = '.dafm' unless defined $Opt{daem_suffix};  $Opt{daem_suffix} = '.dafm' unless defined $Opt{daem_suffix};
85  $Opt{dafx_suffix} = '.dafx' unless defined $Opt{dafx_suffix};  $Opt{dafx_suffix} = '.dafx' unless defined $Opt{dafx_suffix};
86    $Opt{dafs_suffix} = '.dafs' unless defined $Opt{dafs_suffix};
87  $Message::DOM::DOMFeature::DEBUG = 1 if $Opt{debug};  $Message::DOM::DOMFeature::DEBUG = 1 if $Opt{debug};
88  require Error;  require Error;
89  $Error::Debug = 1 if $Opt{debug};  $Error::Debug = 1 if $Opt{debug};
# Line 133  my $limpl = $Message::DOM::Implementatio Line 135  my $limpl = $Message::DOM::Implementatio
135                               %feature,                               %feature,
136                             });                             });
137  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');  
138  my $tdt_parser;  my $tdt_parser;
139    
140  ## --- Loading and Updating the Database  ## --- Loading and Updating the Database
# Line 295  for (@{$Opt{create_module}}) { Line 295  for (@{$Opt{create_module}}) {
295    
296    if ($out_type eq 'perl-pm') {    if ($out_type eq 'perl-pm') {
297      status_msg_ qq<Generating Perl module from <$mod_uri> for <$mod_for>...>;      status_msg_ qq<Generating Perl module from <$mod_uri> for <$mod_for>...>;
298      my $pl = $mod->pl_generate_perl_module_file;      local $Message::Util::DIS::Perl::Implementation
299            = $impl->get_feature (ExpandedURI q<Util:PerlCode> => '1.0');
300        my $pl = $mod->pl_generate_perl_module_file
301                        ($impl->get_feature (ExpandedURI q<Util:PerlCode> => '1.0'));
302      status_msg qq<done>;      status_msg qq<done>;
303    
304      my $output;      my $output;
# Line 342  $db->free; Line 345  $db->free;
345  undef $db;  undef $db;
346  status_msg "done";  status_msg "done";
347    
348    undef $limpl;
349    undef $impl;
350    
351  {  {
352    use integer;    use integer;
353    my $time = time - $start_time;    my $time = time - $start_time;
# Line 480  sub daf_get_referring_module_uri_list ($ Line 486  sub daf_get_referring_module_uri_list ($
486  sub dac_search_file_path_stem ($$$) {  sub dac_search_file_path_stem ($$$) {
487    my ($ns, $ln, $suffix) = @_;    my ($ns, $ln, $suffix) = @_;
488    require File::Spec;    require File::Spec;
489    for my $dir ('.', @{$Opt{input_search_path}->{$ns}||[]}) {    for my $dir (@{$Opt{input_search_path}->{$ns}||[]}) {
490      my $name = Cwd::abs_path      my $name = Cwd::abs_path
491          (File::Spec->canonpath          (File::Spec->canonpath
492           (File::Spec->catfile ($dir, $ln)));           (File::Spec->catfile ($dir, $ln)));
# Line 539  sub daf_db_module_resolver ($$$) { Line 545  sub daf_db_module_resolver ($$$) {
545    my ($db, $mod, $type) = @_;    my ($db, $mod, $type) = @_;
546    my $ns = $mod->namespace_uri;    my $ns = $mod->namespace_uri;
547    my $ln = $mod->local_name;    my $ln = $mod->local_name;
548    my $suffix = $type eq ExpandedURI q<dp:ModuleIndexFile>    my $suffix = {
549                   ? $Opt{dafx_suffix} : $Opt{daem_suffix};      ExpandedURI q<dp:ModuleIndexFile> => $Opt{dafx_suffix},
550        ExpandedURI q<dp:ModuleResourceFile> => $Opt{daem_suffix},
551        ExpandedURI q<dp:ModuleNodeStorageFile> => $Opt{dafs_suffix},
552      }->{$type} or die "Unsupported type: <$type>";
553    verbose_msg qq<Database module <$ns$ln> is requested>;    verbose_msg qq<Database module <$ns$ln> is requested>;
554    my $name = dac_search_file_path_stem ($ns, $ln, $suffix);    my $name = dac_search_file_path_stem ($ns, $ln, $suffix);
555    if (defined $name) {    if (defined $name) {
# Line 585  sub daf_check_undefined () { Line 594  sub daf_check_undefined () {
594    
595  sub daf_generate_perl_test_file ($) {  sub daf_generate_perl_test_file ($) {
596    my $mod = shift;    my $mod = shift;
597    my $pl = $pc->create_perl_file;    my $pc = $impl->get_feature (ExpandedURI q<Util:PerlCode> => '1.0');
598      local $Message::Util::DIS::Perl::Implementation = $pc;
599      my $pl = $pc->create_pc_file;
600      my $factory = $pl->owner_document;
601    my $pack = $pl->get_last_package ("Manakai::Test", make_new_package => 1);    my $pack = $pl->get_last_package ("Manakai::Test", make_new_package => 1);
602    $pack->add_use_perl_module_name ("Message::Util::DIS::Test");    $pack->add_use_perl_module_name ("Message::Util::DIS::Test");
603    $pack->add_use_perl_module_name ("Message::Util::Error");    $pack->add_use_perl_module_name ("Message::Util::Error");
# Line 597  sub daf_generate_perl_test_file ($) { Line 609  sub daf_generate_perl_test_file ($) {
609    $pl->license_uri ($mod->get_property_resource (ExpandedURI q<dis:License>)    $pl->license_uri ($mod->get_property_resource (ExpandedURI q<dis:License>)
610                          ->uri);                          ->uri);
611    
612      $pack->append_code ('
613        use Getopt::Long;
614        my %Skip;
615        GetOptions (
616          "Skip=s" => sub {
617            shift;
618            for (split /\s+/, shift) {
619              if (/^(\d+)-(\d+)$/) {
620                $Skip{$_} = 1 for $1..$2;
621              } else {
622                $Skip{$_} = 1;
623              }
624            }
625          },
626        );
627      ');
628    
629    $pack->append_code    $pack->append_code
630      ($pc->create_perl_statement      ($pc->create_perl_statement
631         ('my $impl = $Message::DOM::ImplementationRegistry->get_implementation ({         ('my $impl = $Message::DOM::ImplementationRegistry->get_implementation ({
# Line 616  sub daf_generate_perl_test_file ($) { Line 645  sub daf_generate_perl_test_file ($) {
645    
646      if ($res->is_type_uri (ExpandedURI q<test:Test>)) {      if ($res->is_type_uri (ExpandedURI q<test:Test>)) {
647        if ($res->is_type_uri (ExpandedURI q<test:StandaloneTest>)) {        if ($res->is_type_uri (ExpandedURI q<test:StandaloneTest>)) {
648          $total_tests++;          my $test_num = ++$total_tests;
649            my $test_uri = $res->name_uri || $res->uri;
650    
651          $pack->append_code ('$test->start_new_test (');          $pack->append_code ('$test->start_new_test (');
652          $pack->append_new_pc_literal ($res->name_uri || $res->uri);          $pack->append_new_pc_literal ($test_uri);
653          $pack->append_code (');');          $pack->append_code (');');
654    
655            $pack->append_code ('if (not $Skip{'.$test_num.'} and not $Skip{');
656            $pack->append_new_pc_literal ($test_uri);
657            $pack->append_code ('}) {');
658                    
659          $pack->append_code ('try {');          $pack->append_code ('try {');
660                    
661          my $test_pc = $res->pl_code_fragment;          my $test_pc = $res->pl_code_fragment ($factory);
662          if (not defined $test_pc) {          if (not defined $test_pc) {
663            die "Perl test code not defined for <".$res->uri.">";            die "Perl test code not defined for <".$res->uri.">";
664          }          }
# Line 640  sub daf_generate_perl_test_file ($) { Line 675  sub daf_generate_perl_test_file ($) {
675            $test->not_ok;            $test->not_ok;
676          };');          };');
677    
678            $pack->append_code ('} else { warn "'.$test_num.' skipped\n" }');
679    
680        } elsif ($res->is_type_uri (ExpandedURI q<test:ParserTestSet>)) {        } elsif ($res->is_type_uri (ExpandedURI q<test:ParserTestSet>)) {
681          my $block = $pack->append_new_pc_block;          my $block = $pack->append_new_pc_block;
682          my @test;          my @test;
# Line 666  sub daf_generate_perl_test_file ($) { Line 703  sub daf_generate_perl_test_file ($) {
703                   not defined $ttest->{root_uri};                   not defined $ttest->{root_uri};
704            }            }
705    
706              ## DOM configuration parameters
707              for my $v (@{$tres->get_property_value_list
708                                  (ExpandedURI q<c:anyDOMConfigurationParameter>)}) {
709                my $cpuri = $v->name;
710                my $cp = $db->get_resource ($cpuri, for_arg => $tres->for_uri);
711                $ttest->{dom_config}->{$cp->get_dom_configuration_parameter_name}
712                  = $v->get_perl_code ($block->owner_document, $tres);
713              }
714    
715            ## Result DOM tree            ## Result DOM tree
716            my $tree_t = $tres->get_property_text (ExpandedURI q<test:domTree>);            my $tree_t = $tres->get_property_text (ExpandedURI q<test:domTree>);
717            if (defined $tree_t) {            if (defined $tree_t) {
# Line 688  sub daf_generate_perl_test_file ($) { Line 734  sub daf_generate_perl_test_file ($) {
734            $_->append_new_pc_literal (\@test);            $_->append_new_pc_literal (\@test);
735          }          }
736                    
737          my $plc = $res->pl_code_fragment;          my $plc = $res->pl_code_fragment ($factory);
738          unless ($plc) {          unless ($plc) {
739            die "Resource <".$res->uri."> does not have Perl test code";            die "Resource <".$res->uri."> does not have Perl test code";
740          }          }
Legend:
Removed from v.1.5  
changed lines
  Added in v.1.11
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24  
Google Analytics is used in this page; Cookies are used. 忍者AdMax is used in this page; Cookies are used. Privacy policy.