/[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.6 by wakaba, Thu Mar 16 08:52:31 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 278  daf_check_undefined (); Line 281  daf_check_undefined ();
281    
282  undef $DNi;  undef $DNi;
283  undef %ModuleSourceDNLDocument;  undef %ModuleSourceDNLDocument;
 undef $limpl;  
 undef $impl;  
284  exit $HasError if $HasError;  exit $HasError if $HasError;
285    
286  ## --- Creating Files  ## --- Creating Files
# Line 295  for (@{$Opt{create_module}}) { Line 296  for (@{$Opt{create_module}}) {
296    
297    if ($out_type eq 'perl-pm') {    if ($out_type eq 'perl-pm') {
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      my $pl = $mod->pl_generate_perl_module_file;      local $Message::Util::DIS::Perl::Implementation
300            = $impl->get_feature (ExpandedURI q<Util:PerlCode> => '1.0');
301        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 342  $db->free; Line 346  $db->free;
346  undef $db;  undef $db;
347  status_msg "done";  status_msg "done";
348    
349    undef $limpl;
350    undef $impl;
351    
352  {  {
353    use integer;    use integer;
354    my $time = time - $start_time;    my $time = time - $start_time;
# Line 480  sub daf_get_referring_module_uri_list ($ Line 487  sub daf_get_referring_module_uri_list ($
487  sub dac_search_file_path_stem ($$$) {  sub dac_search_file_path_stem ($$$) {
488    my ($ns, $ln, $suffix) = @_;    my ($ns, $ln, $suffix) = @_;
489    require File::Spec;    require File::Spec;
490    for my $dir ('.', @{$Opt{input_search_path}->{$ns}||[]}) {    for my $dir (@{$Opt{input_search_path}->{$ns}||[]}) {
491      my $name = Cwd::abs_path      my $name = Cwd::abs_path
492          (File::Spec->canonpath          (File::Spec->canonpath
493           (File::Spec->catfile ($dir, $ln)));           (File::Spec->catfile ($dir, $ln)));
# Line 539  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 586  sub daf_check_undefined () { Line 596  sub daf_check_undefined () {
596  sub daf_generate_perl_test_file ($) {  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    my $pl = $pc->create_perl_file;    local $Message::Util::DIS::Perl::Implementation = $pc;
600      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 598  sub daf_generate_perl_test_file ($) { Line 610  sub daf_generate_perl_test_file ($) {
610    $pl->license_uri ($mod->get_property_resource (ExpandedURI q<dis:License>)    $pl->license_uri ($mod->get_property_resource (ExpandedURI q<dis:License>)
611                          ->uri);                          ->uri);
612    
613    $pack->append_code    $pack->append_code ('
614      ($pc->create_perl_statement      use Getopt::Long;
615         ('my $impl = $Message::DOM::ImplementationRegistry->get_implementation ({      my %Skip;
616             "http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#Test"      GetOptions (
617               => "1.0",        "Skip=s" => sub {
618           })'));          shift;
619            for (split /\s+/, shift) {
620    $pack->append_code            if (/^(\d+)-(\d+)$/) {
621        (my $num_statement = $pc->create_perl_statement              $Skip{$_} = 1 for $1..$2;
622                                    ('my $test = $impl->create_test_manager'));            } else {
623                $Skip{$_} = 1;
624              }
625            }
626          },
627        );
628      ');
629    
630      $pack->append_child ($factory->create_pc_statement)
631           ->append_code
632               ('my $impl = $Message::DOM::ImplementationRegistry
633                                ->get_implementation ({
634                    "http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#Test"
635                        => "1.0",
636                })');
637    
638      my $num_statement = $pack->append_child ($factory->create_pc_statement);
639      $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 617  sub daf_generate_perl_test_file ($) { Line 646  sub daf_generate_perl_test_file ($) {
646    
647      if ($res->is_type_uri (ExpandedURI q<test:Test>)) {      if ($res->is_type_uri (ExpandedURI q<test:Test>)) {
648        if ($res->is_type_uri (ExpandedURI q<test:StandaloneTest>)) {        if ($res->is_type_uri (ExpandedURI q<test:StandaloneTest>)) {
649          $total_tests++;          my $test_num = ++$total_tests;
650            my $test_uri = $res->name_uri || $res->uri;
651    
652          $pack->append_code ('$test->start_new_test (');          $pack->append_code ('$test->start_new_test (');
653          $pack->append_new_pc_literal ($res->name_uri || $res->uri);          $pack->append_new_pc_literal ($test_uri);
654          $pack->append_code (');');          $pack->append_code (');');
655    
656            $pack->append_code ('if (not $Skip{'.$test_num.'} and not $Skip{');
657            $pack->append_new_pc_literal ($test_uri);
658            $pack->append_code ('}) {');
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 641  sub daf_generate_perl_test_file ($) { Line 676  sub daf_generate_perl_test_file ($) {
676            $test->not_ok;            $test->not_ok;
677          };');          };');
678    
679            $pack->append_code ('} else { warn "'.$test_num.' skipped\n" }');
680    
681        } elsif ($res->is_type_uri (ExpandedURI q<test:ParserTestSet>)) {        } elsif ($res->is_type_uri (ExpandedURI q<test:ParserTestSet>)) {
682          my $block = $pack->append_new_pc_block;          my $block = $pack->append_new_pc_block;
683          my @test;          my @test;
# Line 658  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 698  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.6  
changed lines
  Added in v.1.12
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24