/[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.9 by wakaba, Sat Apr 1 14:41:29 2006 UTC revision 1.12 by wakaba, Sun Apr 9 14:29:41 2006 UTC
# Line 12  use Message::Util::QName::Filter { Line 12  use Message::Util::QName::Filter {
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#>,    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      xp => q<http://suika.fam.cx/~wakaba/archive/2004/dom/xml-parser#>,
16  };  };
17    
18  use Cwd;  use Cwd;
# Line 34  GetOptions ( Line 35  GetOptions (
35    'debug' => \$Opt{debug},    'debug' => \$Opt{debug},
36    'dis-file-suffix=s' => \$Opt{dis_suffix},    'dis-file-suffix=s' => \$Opt{dis_suffix},
37    'daem-file-suffix=s' => \$Opt{daem_suffix},    'daem-file-suffix=s' => \$Opt{daem_suffix},
38      'dafs-file-suffix=s' => \$Opt{dafs_suffix},
39    'dafx-file-suffix=s' => \$Opt{dafx_suffix},    'dafx-file-suffix=s' => \$Opt{dafx_suffix},
40    'help' => \$Opt{help},    'help' => \$Opt{help},
41    'search-path|I=s' => sub {    'search-path|I=s' => sub {
# Line 82  $Opt{no_undef_check} = defined $Opt{no_u Line 84  $Opt{no_undef_check} = defined $Opt{no_u
84  $Opt{dis_suffix} = '.dis' unless defined $Opt{dis_suffix};  $Opt{dis_suffix} = '.dis' unless defined $Opt{dis_suffix};
85  $Opt{daem_suffix} = '.dafm' unless defined $Opt{daem_suffix};  $Opt{daem_suffix} = '.dafm' unless defined $Opt{daem_suffix};
86  $Opt{dafx_suffix} = '.dafx' unless defined $Opt{dafx_suffix};  $Opt{dafx_suffix} = '.dafx' unless defined $Opt{dafx_suffix};
87    $Opt{dafs_suffix} = '.dafs' unless defined $Opt{dafs_suffix};
88  $Message::DOM::DOMFeature::DEBUG = 1 if $Opt{debug};  $Message::DOM::DOMFeature::DEBUG = 1 if $Opt{debug};
89  require Error;  require Error;
90  $Error::Debug = 1 if $Opt{debug};  $Error::Debug = 1 if $Opt{debug};
# Line 295  for (@{$Opt{create_module}}) { Line 298  for (@{$Opt{create_module}}) {
298      status_msg_ qq<Generating Perl module from <$mod_uri> for <$mod_for>...>;      status_msg_ qq<Generating Perl module from <$mod_uri> for <$mod_for>...>;
299      local $Message::Util::DIS::Perl::Implementation      local $Message::Util::DIS::Perl::Implementation
300          = $impl->get_feature (ExpandedURI q<Util:PerlCode> => '1.0');          = $impl->get_feature (ExpandedURI q<Util:PerlCode> => '1.0');
301      my $pl = $mod->pl_generate_perl_module_file;      my $pl = $mod->pl_generate_perl_module_file
302                        ($impl->get_feature (ExpandedURI q<Util:PerlCode> => '1.0'));
303      status_msg qq<done>;      status_msg qq<done>;
304    
305      my $output;      my $output;
# Line 542  sub daf_db_module_resolver ($$$) { Line 546  sub daf_db_module_resolver ($$$) {
546    my ($db, $mod, $type) = @_;    my ($db, $mod, $type) = @_;
547    my $ns = $mod->namespace_uri;    my $ns = $mod->namespace_uri;
548    my $ln = $mod->local_name;    my $ln = $mod->local_name;
549    my $suffix = $type eq ExpandedURI q<dp:ModuleIndexFile>    my $suffix = {
550                   ? $Opt{dafx_suffix} : $Opt{daem_suffix};      ExpandedURI q<dp:ModuleIndexFile> => $Opt{dafx_suffix},
551        ExpandedURI q<dp:ModuleResourceFile> => $Opt{daem_suffix},
552        ExpandedURI q<dp:ModuleNodeStorageFile> => $Opt{dafs_suffix},
553      }->{$type} or die "Unsupported type: <$type>";
554    verbose_msg qq<Database module <$ns$ln> is requested>;    verbose_msg qq<Database module <$ns$ln> is requested>;
555    my $name = dac_search_file_path_stem ($ns, $ln, $suffix);    my $name = dac_search_file_path_stem ($ns, $ln, $suffix);
556    if (defined $name) {    if (defined $name) {
# Line 590  sub daf_generate_perl_test_file ($) { Line 597  sub daf_generate_perl_test_file ($) {
597    my $mod = shift;    my $mod = shift;
598    my $pc = $impl->get_feature (ExpandedURI q<Util:PerlCode> => '1.0');    my $pc = $impl->get_feature (ExpandedURI q<Util:PerlCode> => '1.0');
599    local $Message::Util::DIS::Perl::Implementation = $pc;    local $Message::Util::DIS::Perl::Implementation = $pc;
600    my $pl = $pc->create_perl_file;    my $pl = $pc->create_pc_file;
601      my $factory = $pl->owner_document;
602    my $pack = $pl->get_last_package ("Manakai::Test", make_new_package => 1);    my $pack = $pl->get_last_package ("Manakai::Test", make_new_package => 1);
603    $pack->add_use_perl_module_name ("Message::Util::DIS::Test");    $pack->add_use_perl_module_name ("Message::Util::DIS::Test");
604    $pack->add_use_perl_module_name ("Message::Util::Error");    $pack->add_use_perl_module_name ("Message::Util::Error");
# Line 619  sub daf_generate_perl_test_file ($) { Line 627  sub daf_generate_perl_test_file ($) {
627      );      );
628    ');    ');
629    
630    $pack->append_code    $pack->append_child ($factory->create_pc_statement)
631      ($pc->create_perl_statement         ->append_code
632         ('my $impl = $Message::DOM::ImplementationRegistry->get_implementation ({             ('my $impl = $Message::DOM::ImplementationRegistry
633             "http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#Test"                              ->get_implementation ({
634               => "1.0",                  "http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#Test"
635           })'));                      => "1.0",
636                })');
637    $pack->append_code  
638        (my $num_statement = $pc->create_perl_statement    my $num_statement = $pack->append_child ($factory->create_pc_statement);
639                                    ('my $test = $impl->create_test_manager'));    $num_statement->append_code ('my $test = $impl->create_test_manager');
640    
641    my $total_tests = 0;    my $total_tests = 0;
642    my %processed;    my %processed;
# Line 651  sub daf_generate_perl_test_file ($) { Line 659  sub daf_generate_perl_test_file ($) {
659                    
660          $pack->append_code ('try {');          $pack->append_code ('try {');
661                    
662          my $test_pc = $res->pl_code_fragment;          my $test_pc = $res->pl_code_fragment ($factory);
663          if (not defined $test_pc) {          if (not defined $test_pc) {
664            die "Perl test code not defined for <".$res->uri.">";            die "Perl test code not defined for <".$res->uri.">";
665          }          }
666                    
667          $pack->append_code_fragment ($test_pc);          $pack->append_child ($test_pc);
668                    
669          $pack->append_code ('$test->ok;');          $pack->append_code ('$test->ok;');
670                    
# Line 687  sub daf_generate_perl_test_file ($) { Line 695  sub daf_generate_perl_test_file ($) {
695                                     (ExpandedURI q<test:Entity>)}) {                                     (ExpandedURI q<test:Entity>)}) {
696              my $tent = $ttest->{entity}->{$eres->uri} = {};              my $tent = $ttest->{entity}->{$eres->uri} = {};
697              for (ExpandedURI q<test:uri>, ExpandedURI q<test:baseURI>,              for (ExpandedURI q<test:uri>, ExpandedURI q<test:baseURI>,
698                   ExpandedURI q<test:value>) {                   ExpandedURI q<test:value>, ExpandedURI q<xp:encoding>) {
699                my $v = $eres->get_property_text ($_);                my $v = $eres->get_property_text ($_);
700                $tent->{$_} = $v if defined $v;                $tent->{$_} = $v if defined $v;
701              }              }
# Line 727  sub daf_generate_perl_test_file ($) { Line 735  sub daf_generate_perl_test_file ($) {
735            $_->append_new_pc_literal (\@test);            $_->append_new_pc_literal (\@test);
736          }          }
737                    
738          my $plc = $res->pl_code_fragment;          my $plc = $res->pl_code_fragment ($factory);
739          unless ($plc) {          unless ($plc) {
740            die "Resource <".$res->uri."> does not have Perl test code";            die "Resource <".$res->uri."> does not have Perl test code";
741          }          }
742    
743          $block->append_code_fragment ($plc);          $block->append_child ($plc);
744                    
745        } # test resource type        } # test resource type
746      } # test:Test      } # test:Test
Legend:
Removed from v.1.9  
changed lines
  Added in v.1.12
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24