/[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.10 by wakaba, Mon Apr 3 12:53:22 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 543  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 621  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 658  sub daf_generate_perl_test_file ($) { Line 664  sub daf_generate_perl_test_file ($) {
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 689  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 734  sub daf_generate_perl_test_file ($) { Line 740  sub daf_generate_perl_test_file ($) {
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.10  
changed lines
  Added in v.1.12
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24