--- messaging/manakai/bin/daf.pl	2006/03/16 08:52:31	1.6
+++ messaging/manakai/bin/daf.pl	2006/04/09 14:29:41	1.12
@@ -12,6 +12,7 @@
   swcfg21 => q<http://suika.fam.cx/~wakaba/archive/2005/swcfg21#>,
   test => q<http://suika.fam.cx/~wakaba/archive/2004/dis/Test#>,
   Util => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/>,
+  xp => q<http://suika.fam.cx/~wakaba/archive/2004/dom/xml-parser#>,
 };
 
 use Cwd;
@@ -34,6 +35,7 @@
   'debug' => \$Opt{debug},
   'dis-file-suffix=s' => \$Opt{dis_suffix},
   'daem-file-suffix=s' => \$Opt{daem_suffix},
+  'dafs-file-suffix=s' => \$Opt{dafs_suffix},
   'dafx-file-suffix=s' => \$Opt{dafx_suffix},
   'help' => \$Opt{help},
   'search-path|I=s' => sub {
@@ -82,6 +84,7 @@
 $Opt{dis_suffix} = '.dis' unless defined $Opt{dis_suffix};
 $Opt{daem_suffix} = '.dafm' unless defined $Opt{daem_suffix};
 $Opt{dafx_suffix} = '.dafx' unless defined $Opt{dafx_suffix};
+$Opt{dafs_suffix} = '.dafs' unless defined $Opt{dafs_suffix};
 $Message::DOM::DOMFeature::DEBUG = 1 if $Opt{debug};
 require Error;
 $Error::Debug = 1 if $Opt{debug};
@@ -278,8 +281,6 @@
 
 undef $DNi;
 undef %ModuleSourceDNLDocument;
-undef $limpl;
-undef $impl;
 exit $HasError if $HasError;
 
 ## --- Creating Files
@@ -295,7 +296,10 @@
 
   if ($out_type eq 'perl-pm') {
     status_msg_ qq<Generating Perl module from <$mod_uri> for <$mod_for>...>;
-    my $pl = $mod->pl_generate_perl_module_file;
+    local $Message::Util::DIS::Perl::Implementation
+        = $impl->get_feature (ExpandedURI q<Util:PerlCode> => '1.0');
+    my $pl = $mod->pl_generate_perl_module_file
+                    ($impl->get_feature (ExpandedURI q<Util:PerlCode> => '1.0'));
     status_msg qq<done>;
 
     my $output;
@@ -342,6 +346,9 @@
 undef $db;
 status_msg "done";
 
+undef $limpl;
+undef $impl;
+
 {
   use integer;
   my $time = time - $start_time;
@@ -480,7 +487,7 @@
 sub dac_search_file_path_stem ($$$) {
   my ($ns, $ln, $suffix) = @_;
   require File::Spec;
-  for my $dir ('.', @{$Opt{input_search_path}->{$ns}||[]}) {
+  for my $dir (@{$Opt{input_search_path}->{$ns}||[]}) {
     my $name = Cwd::abs_path
         (File::Spec->canonpath
          (File::Spec->catfile ($dir, $ln)));
@@ -539,8 +546,11 @@
   my ($db, $mod, $type) = @_;
   my $ns = $mod->namespace_uri;
   my $ln = $mod->local_name;
-  my $suffix = $type eq ExpandedURI q<dp:ModuleIndexFile>
-                 ? $Opt{dafx_suffix} : $Opt{daem_suffix};
+  my $suffix = {
+    ExpandedURI q<dp:ModuleIndexFile> => $Opt{dafx_suffix},
+    ExpandedURI q<dp:ModuleResourceFile> => $Opt{daem_suffix},
+    ExpandedURI q<dp:ModuleNodeStorageFile> => $Opt{dafs_suffix},
+  }->{$type} or die "Unsupported type: <$type>";
   verbose_msg qq<Database module <$ns$ln> is requested>;
   my $name = dac_search_file_path_stem ($ns, $ln, $suffix);
   if (defined $name) {
@@ -586,7 +596,9 @@
 sub daf_generate_perl_test_file ($) {
   my $mod = shift;
   my $pc = $impl->get_feature (ExpandedURI q<Util:PerlCode> => '1.0');
-  my $pl = $pc->create_perl_file;
+  local $Message::Util::DIS::Perl::Implementation = $pc;
+  my $pl = $pc->create_pc_file;
+  my $factory = $pl->owner_document;
   my $pack = $pl->get_last_package ("Manakai::Test", make_new_package => 1);
   $pack->add_use_perl_module_name ("Message::Util::DIS::Test");
   $pack->add_use_perl_module_name ("Message::Util::Error");
@@ -598,16 +610,33 @@
   $pl->license_uri ($mod->get_property_resource (ExpandedURI q<dis:License>)
                         ->uri);
 
-  $pack->append_code
-    ($pc->create_perl_statement
-       ('my $impl = $Message::DOM::ImplementationRegistry->get_implementation ({
-           "http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#Test"
-             => "1.0",
-         })'));
-
-  $pack->append_code
-      (my $num_statement = $pc->create_perl_statement 
-                                  ('my $test = $impl->create_test_manager'));
+  $pack->append_code ('
+    use Getopt::Long;
+    my %Skip;
+    GetOptions (
+      "Skip=s" => sub {
+        shift;
+        for (split /\s+/, shift) {
+          if (/^(\d+)-(\d+)$/) {
+            $Skip{$_} = 1 for $1..$2;
+          } else {
+            $Skip{$_} = 1;
+          }
+        }
+      },
+    );
+  ');
+
+  $pack->append_child ($factory->create_pc_statement)
+       ->append_code
+           ('my $impl = $Message::DOM::ImplementationRegistry
+                            ->get_implementation ({
+                "http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#Test"
+                    => "1.0",
+            })');
+
+  my $num_statement = $pack->append_child ($factory->create_pc_statement);
+  $num_statement->append_code ('my $test = $impl->create_test_manager');
 
   my $total_tests = 0;
   my %processed;
@@ -617,19 +646,25 @@
 
     if ($res->is_type_uri (ExpandedURI q<test:Test>)) {
       if ($res->is_type_uri (ExpandedURI q<test:StandaloneTest>)) {
-        $total_tests++;
+        my $test_num = ++$total_tests;
+        my $test_uri = $res->name_uri || $res->uri;
+
         $pack->append_code ('$test->start_new_test (');
-        $pack->append_new_pc_literal ($res->name_uri || $res->uri);
+        $pack->append_new_pc_literal ($test_uri);
         $pack->append_code (');');
+
+        $pack->append_code ('if (not $Skip{'.$test_num.'} and not $Skip{');
+        $pack->append_new_pc_literal ($test_uri);
+        $pack->append_code ('}) {');
         
         $pack->append_code ('try {');
         
-        my $test_pc = $res->pl_code_fragment;
+        my $test_pc = $res->pl_code_fragment ($factory);
         if (not defined $test_pc) {
           die "Perl test code not defined for <".$res->uri.">";
         }
         
-        $pack->append_code_fragment ($test_pc);
+        $pack->append_child ($test_pc);
         
         $pack->append_code ('$test->ok;');
         
@@ -641,6 +676,8 @@
           $test->not_ok;
         };');
 
+        $pack->append_code ('} else { warn "'.$test_num.' skipped\n" }');
+
       } elsif ($res->is_type_uri (ExpandedURI q<test:ParserTestSet>)) {
         my $block = $pack->append_new_pc_block;
         my @test;
@@ -658,7 +695,7 @@
                                    (ExpandedURI q<test:Entity>)}) {
             my $tent = $ttest->{entity}->{$eres->uri} = {};
             for (ExpandedURI q<test:uri>, ExpandedURI q<test:baseURI>,
-                 ExpandedURI q<test:value>) {
+                 ExpandedURI q<test:value>, ExpandedURI q<xp:encoding>) {
               my $v = $eres->get_property_text ($_);
               $tent->{$_} = $v if defined $v;
             }
@@ -698,12 +735,12 @@
           $_->append_new_pc_literal (\@test);
         }
         
-        my $plc = $res->pl_code_fragment;
+        my $plc = $res->pl_code_fragment ($factory);
         unless ($plc) {
           die "Resource <".$res->uri."> does not have Perl test code";
         }
 
-        $block->append_code_fragment ($plc);
+        $block->append_child ($plc);
         
       } # test resource type
     } # test:Test