/[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.2 by wakaba, Sun Feb 26 06:42:55 2006 UTC revision 1.14 by wakaba, Fri May 19 11:02:11 2006 UTC
# Line 4  use Message::Util::QName::Filter { Line 4  use Message::Util::QName::Filter {
4    c => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/dom-core#>,    c => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/dom-core#>,
5    DIS => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#>,    DIS => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#>,
6    dis => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/lang#dis-->,    dis => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/lang#dis-->,
   DOMLS => q<http://suika.fam.cx/~wakaba/archive/2004/dom/ls#>,  
7    dp => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#Perl/>,    dp => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#Perl/>,
8    fe => q<http://suika.fam.cx/www/2006/feature/>,    fe => q<http://suika.fam.cx/www/2006/feature/>,
9    ManakaiDOM => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/manakai-dom#>,    ManakaiDOM => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/manakai-dom#>,
10    pc => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/PerlCode#>,    pc => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/PerlCode#>,
11    swcfg21 => q<http://suika.fam.cx/~wakaba/archive/2005/swcfg21#>,    swcfg21 => q<http://suika.fam.cx/~wakaba/archive/2005/swcfg21#>,
   test => q<http://suika.fam.cx/~wakaba/archive/2004/dis/Test#>,  
12    Util => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/>,    Util => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/>,
13  };  };
14    
# Line 18  use Cwd; Line 16  use Cwd;
16  use Getopt::Long;  use Getopt::Long;
17  use Pod::Usage;  use Pod::Usage;
18  my %Opt = (create_module => []);  my %Opt = (create_module => []);
19    my @target_modules;
20  GetOptions (  GetOptions (
21      'create-dtd-modules=s' => sub {
22        shift;
23        my $i = [split /\s+/, shift, 3];
24        $i->[3] = 'dtd-modules';
25        push @{$Opt{create_module}}, $i;
26      },
27    'create-perl-module=s' => sub {    'create-perl-module=s' => sub {
28      shift;      shift;
29      my $i = [split /\s+/, shift, 3];      my $i = [split /\s+/, shift, 3];
30      $i->[3] = 'perl-pm';      $i->[3] = 'perl-pm';
31      push @{$Opt{create_module}}, $i;      push @{$Opt{create_module}}, $i;
32        push @target_modules, [$i->[0], $i->[2]];
33    },    },
34    'create-perl-test=s' => sub {    'create-perl-test=s' => sub {
35      shift;      shift;
36      my $i = [split /\s+/, shift, 3];      my $i = [split /\s+/, shift, 3];
37      $i->[3] = 'perl-t';      $i->[3] = 'perl-t';
38      push @{$Opt{create_module}}, $i;      push @{$Opt{create_module}}, $i;
39        push @target_modules, [$i->[0], $i->[2]];
40    },    },
41    'debug' => \$Opt{debug},    'debug' => \$Opt{debug},
42    'dis-file-suffix=s' => \$Opt{dis_suffix},    'dis-file-suffix=s' => \$Opt{dis_suffix},
43    'daem-file-suffix=s' => \$Opt{daem_suffix},    'daem-file-suffix=s' => \$Opt{daem_suffix},
44      'dafs-file-suffix=s' => \$Opt{dafs_suffix},
45    'dafx-file-suffix=s' => \$Opt{dafx_suffix},    'dafx-file-suffix=s' => \$Opt{dafx_suffix},
46    'help' => \$Opt{help},    'help' => \$Opt{help},
47      'load-module=s' => sub {
48        shift;
49        my $i = [split /\s+/, shift, 2];
50        push @target_modules, [$i->[0], $i->[1]];
51      },
52    'search-path|I=s' => sub {    'search-path|I=s' => sub {
53      shift;      shift;
54      my @value = split /\s+/, shift;      my @value = split /\s+/, shift;
# Line 82  $Opt{no_undef_check} = defined $Opt{no_u Line 95  $Opt{no_undef_check} = defined $Opt{no_u
95  $Opt{dis_suffix} = '.dis' unless defined $Opt{dis_suffix};  $Opt{dis_suffix} = '.dis' unless defined $Opt{dis_suffix};
96  $Opt{daem_suffix} = '.dafm' unless defined $Opt{daem_suffix};  $Opt{daem_suffix} = '.dafm' unless defined $Opt{daem_suffix};
97  $Opt{dafx_suffix} = '.dafx' unless defined $Opt{dafx_suffix};  $Opt{dafx_suffix} = '.dafx' unless defined $Opt{dafx_suffix};
98    $Opt{dafs_suffix} = '.dafs' unless defined $Opt{dafs_suffix};
99  $Message::DOM::DOMFeature::DEBUG = 1 if $Opt{debug};  $Message::DOM::DOMFeature::DEBUG = 1 if $Opt{debug};
100  require Error;  require Error;
101  $Error::Debug = 1 if $Opt{debug};  $Error::Debug = 1 if $Opt{debug};
# Line 115  my $start_time; Line 129  my $start_time;
129  BEGIN { $start_time = time }  BEGIN { $start_time = time }
130    
131  use Message::Util::DIS::DNLite;  use Message::Util::DIS::DNLite;
 use Message::Util::PerlCode;  
 use Message::Util::DIS::Test;  
 use Message::DOM::GenericLS;  
132    
133  my $limpl = $Message::DOM::ImplementationRegistry->get_implementation  my %feature;
134    
135    for (@{$Opt{create_module}}) {
136      my (undef, undef, undef, $out_type) = @$_;
137    
138      if ($out_type eq 'perl-pm') {
139        require 'manakai/daf-perl-pm.pl';
140        $feature{'+' . ExpandedURI q<Util:PerlCode>} = '1.0';
141      } elsif ($out_type eq 'perl-t') {
142        require 'manakai/daf-perl-t.pl';
143        $feature{ExpandedURI q<fe:GenericLS>} = '3.0';
144        $feature{'+' . ExpandedURI q<DIS:TDT>} = '1.0';
145        $feature{'+' . ExpandedURI q<Util:PerlCode>} = '1.0';
146      } elsif ($out_type eq 'dtd-modules') {
147        require 'manakai/daf-dtd-modules.pl';
148        $feature{ExpandedURI q<fe:GenericLS>} = '3.0';
149        $feature{'+' . ExpandedURI q<fe:XDP>} = '3.0';
150      }
151    }
152    
153    our $limpl = $Message::DOM::ImplementationRegistry->get_implementation
154                             ({ExpandedURI q<fe:Min> => '3.0',                             ({ExpandedURI q<fe:Min> => '3.0',
155                               '+' . ExpandedURI q<DIS:DNLite> => '1.0',                               '+' . ExpandedURI q<DIS:DNLite> => '1.0',
156                               '+' . ExpandedURI q<DIS:Core> => '1.0',                               '+' . ExpandedURI q<DIS:Core> => '1.0',
157                               '+' . ExpandedURI q<Util:PerlCode> => '1.0',                               %feature,
                              '+' . ExpandedURI q<DIS:TDT> => '1.0',  
158                             });                             });
159  my $impl = $limpl->get_feature (ExpandedURI q<DIS:Core> => '1.0');  our $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');  
 my $tdt_parser;  
160    
161  ## --- Loading and Updating the Database  ## --- Loading and Updating the Database
162    
163  my $HasError;  my $HasError;
164  my $db = $impl->create_dis_database;  our $db = $impl->create_dis_database;
165  $db->pl_database_module_resolver (\&daf_db_module_resolver);  $db->pl_database_module_resolver (\&daf_db_module_resolver);
166  $db->dom_config->set_parameter ('error-handler' => \&daf_on_error);  $db->dom_config->set_parameter ('error-handler' => \&daf_on_error);
167    
# Line 149  my %ModuleNameNamespaceBinding = ( Line 176  my %ModuleNameNamespaceBinding = (
176      ## property.      ## property.
177  );  );
178    
 my @target_modules;  
 for (@{$Opt{create_module}}) {  
   my ($mod_uri, $out_path, $mod_for, $out_type) = @$_;  
   push @target_modules, [$mod_uri, $mod_for];  
 }  
   
179  my $ResourceCount = 0;  my $ResourceCount = 0;
180  $db->pl_update_module (\@target_modules,  $db->pl_update_module (\@target_modules,
181  get_module_index_file_name => sub {  get_module_index_file_name => sub {
# Line 209  get_referring_module_uri_list => sub { Line 230  get_referring_module_uri_list => sub {
230      unless (defined $ModuleSourceDISDocument{$module_uri}) {      unless (defined $ModuleSourceDISDocument{$module_uri}) {
231        daf_open_source_dis_document ($module_uri);        daf_open_source_dis_document ($module_uri);
232      }      }
     daf_convert_dis_document_to_dnl_document ();  
233    }    }
234    return daf_get_referring_module_uri_list ($module_uri);    return daf_get_referring_module_uri_list ($module_uri);
235  },  },
# Line 281  exit $HasError if $HasError; Line 301  exit $HasError if $HasError;
301    
302  for (@{$Opt{create_module}}) {  for (@{$Opt{create_module}}) {
303    my ($mod_uri, $out_file_path, $mod_for, $out_type) = @$_;    my ($mod_uri, $out_file_path, $mod_for, $out_type) = @$_;
   unless (defined $mod_for) {  
     $mod_for = $db->get_module ($mod_uri)  
                   ->get_property_text (ExpandedURI q<dis:DefaultFor>,  
                                        ExpandedURI q<ManakaiDOM:all>);  
   }  
   my $mod = $db->get_module ($mod_uri, for_arg => $mod_for);  
304    
305    if ($out_type eq 'perl-pm') {    if ($out_type eq 'perl-pm') {
306      status_msg_ qq<Generating Perl module from <$mod_uri> for <$mod_for>...>;      daf_perl_pm ($mod_uri, $out_file_path, $mod_for);
     my $pl = $mod->pl_generate_perl_module_file;  
     status_msg qq<done>;  
   
     my $output;  
     defined $out_file_path  
         ? (open $output, '>', $out_file_path or die "$0: $out_file_path: $!")  
         : ($output = \*STDOUT);  
   
     status_msg_ sprintf qq<Writing Perl module %s...>,  
                           defined $out_file_path  
                             ? q<">.$out_file_path.q<">  
                             : 'to stdout';  
     print $output $pl->stringify;  
     close $output;  
     status_msg q<done>;  
307    } elsif ($out_type eq 'perl-t') {    } elsif ($out_type eq 'perl-t') {
308      status_msg_ qq<Generating Perl test from <$mod_uri> for <$mod_for>...>;      daf_perl_t ($mod_uri, $out_file_path, $mod_for);
309      my $pl = daf_generate_perl_test_file ($mod);    } elsif ($out_type eq 'dtd-modules') {
310      status_msg qq<done>;      daf_dtd_modules ($mod_uri, $out_file_path, $mod_for);
   
     my $output;  
     defined $out_file_path  
         ? (open $output, '>', $out_file_path or die "$0: $out_file_path: $!")  
           : ($output = \*STDOUT);  
   
     status_msg_ sprintf qq<Writing Perl test %s...>,  
                           defined $out_file_path  
                             ? q<">.$out_file_path.q<">  
                             : 'to stdout';  
     print $output $pl->stringify;  
     close $output;  
     status_msg q<done>;  
311    }    }
312  }  }
313    
# Line 334  $db->free; Line 320  $db->free;
320  undef $db;  undef $db;
321  status_msg "done";  status_msg "done";
322    
323    undef $limpl;
324    undef $impl;
325    
326  {  {
327    use integer;    use integer;
328    my $time = time - $start_time;    my $time = time - $start_time;
# Line 472  sub daf_get_referring_module_uri_list ($ Line 461  sub daf_get_referring_module_uri_list ($
461  sub dac_search_file_path_stem ($$$) {  sub dac_search_file_path_stem ($$$) {
462    my ($ns, $ln, $suffix) = @_;    my ($ns, $ln, $suffix) = @_;
463    require File::Spec;    require File::Spec;
464    for my $dir ('.', @{$Opt{input_search_path}->{$ns}||[]}) {    for my $dir (@{$Opt{input_search_path}->{$ns}||[]}) {
465      my $name = Cwd::abs_path      my $name = Cwd::abs_path
466          (File::Spec->canonpath          (File::Spec->canonpath
467           (File::Spec->catfile ($dir, $ln)));           (File::Spec->catfile ($dir, $ln)));
# Line 531  sub daf_db_module_resolver ($$$) { Line 520  sub daf_db_module_resolver ($$$) {
520    my ($db, $mod, $type) = @_;    my ($db, $mod, $type) = @_;
521    my $ns = $mod->namespace_uri;    my $ns = $mod->namespace_uri;
522    my $ln = $mod->local_name;    my $ln = $mod->local_name;
523    my $suffix = $type eq ExpandedURI q<dp:ModuleIndexFile>    my $suffix = {
524                   ? $Opt{dafx_suffix} : $Opt{daem_suffix};      ExpandedURI q<dp:ModuleIndexFile> => $Opt{dafx_suffix},
525        ExpandedURI q<dp:ModuleResourceFile> => $Opt{daem_suffix},
526        ExpandedURI q<dp:ModuleNodeStorageFile> => $Opt{dafs_suffix},
527      }->{$type} or die "Unsupported type: <$type>";
528    verbose_msg qq<Database module <$ns$ln> is requested>;    verbose_msg qq<Database module <$ns$ln> is requested>;
529    my $name = dac_search_file_path_stem ($ns, $ln, $suffix);    my $name = dac_search_file_path_stem ($ns, $ln, $suffix);
530    if (defined $name) {    if (defined $name) {
# Line 575  sub daf_check_undefined () { Line 567  sub daf_check_undefined () {
567    }    }
568  } # daf_check_undefined  } # daf_check_undefined
569    
 sub daf_generate_perl_test_file ($) {  
   my $mod = shift;  
   my $pl = $pc->create_perl_file;  
   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");  
   $pack->add_require_perl_module_name ($mod->pl_fully_qualified_name);  
   
   $pl->source_file ($mod->get_property_text (ExpandedURI q<DIS:sourceFile>, ""));  
   $pl->source_module ($mod->name_uri);  
   $pl->source_for ($mod->for_uri);  
   $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'));  
   
   my $total_tests = 0;  
   my %processed;  
   for my $res (@{$mod->get_resource_list}) {  
     next if $res->owner_module ne $mod or $processed{$res->uri};  
     $processed{$res->uri} = 1;  
   
     if ($res->is_type_uri (ExpandedURI q<test:Test>)) {  
       if ($res->is_type_uri (ExpandedURI q<test:StandaloneTest>)) {  
         $total_tests++;  
         $pack->append_code ('$test->start_new_test (');  
         $pack->append_new_pc_literal ($res->name_uri || $res->uri);  
         $pack->append_code (');');  
           
         $pack->append_code ('try {');  
           
         my $test_pc = $res->pl_code_fragment;  
         if (not defined $test_pc) {  
           die "Perl test code not defined for <".$res->uri.">";  
         }  
           
         $pack->append_code_fragment ($test_pc);  
           
         $pack->append_code ('$test->ok;');  
           
         $pack->append_code ('} catch Message::Util::IF::DTException with {  
           ##  
         } otherwise {  
           my $err = shift;  
           warn $err;  
           $test->not_ok;  
         };');  
   
       } elsif ($res->is_type_uri (ExpandedURI q<test:ParserTestSet>)) {  
         my $block = $pack->append_new_pc_block;  
         my @test;  
           
         $tdt_parser ||= $impl->create_gls_parser  
                                  ({  
                                    ExpandedURI q<DIS:TDT> => '1.0',  
                                   });  
         for my $tres (@{$res->get_child_resource_list_by_type  
                                 (ExpandedURI q<test:ParserTest>)}) {  
           $total_tests++;  
           push @test, my $ttest = {entity => {}};  
           $ttest->{uri} = $tres->uri;  
           for my $eres (@{$tres->get_child_resource_list_by_type  
                                    (ExpandedURI q<test:Entity>)}) {  
             my $tent = $ttest->{entity}->{$eres->uri} = {};  
             for (ExpandedURI q<test:uri>, ExpandedURI q<test:baseURI>,  
                  ExpandedURI q<test:value>) {  
               my $v = $eres->get_property_text ($_);  
               $tent->{$_} = $v if defined $v;  
             }  
             $ttest->{root_uri} = $eres->uri  
               if $eres->is_type_uri (ExpandedURI q<test:RootEntity>) or  
                  not defined $ttest->{root_uri};  
           }  
   
           ## Result DOM tree  
           my $tree_t = $tres->get_property_text (ExpandedURI q<test:domTree>);  
           if (defined $tree_t) {  
             $ttest->{dom_tree} = $tdt_parser->parse_string ($tree_t);  
           }  
   
           ## Expected |DOMError|s  
           for (@{$tres->get_property_value_list (ExpandedURI q<c:erred>)}) {  
             my $err = $tdt_parser->parse_tdt_error_string  
                                      ($_->string_value, $db, $_,  
                                       undef, $tres->for_uri);  
             push @{$ttest->{dom_error}->{$err->{type}->{value}} ||= []}, $err;  
           }  
         }  
   
         for ($block->append_statement  
                    ->append_new_pc_expression ('=')) {  
           $_->append_new_pc_variable ('$', undef, 'TestData')  
             ->variable_scope ('my');  
           $_->append_new_pc_literal (\@test);  
         }  
           
         my $plc = $res->pl_code_fragment;  
         unless ($plc) {  
           die "Resource <".$res->uri."> does not have Perl test code";  
         }  
   
         $block->append_code_fragment ($plc);  
           
       } # test resource type  
     } # test:Test  
   }  
     
   $num_statement->append_code (' (' . $total_tests . ')');  
   
   return $pl;  
 } # daf_generate_perl_test_file  
   
570  __END__  __END__
571    
572  =head1 NAME  =head1 NAME
# Line 736  option is specified, the database file i Line 607  option is specified, the database file i
607  and then I<input.dis> file is loaded in the context of it.  and then I<input.dis> file is loaded in the context of it.
608  Otherwise, a new database is created.  Otherwise, a new database is created.
609    
 =item C<--output-file-name=I<file-name>> (Required)  
   
 The  
   
610  =back  =back
611    
612  =head1 SEE ALSO  =head1 SEE ALSO
613    
 L<bin/dac2pm.pl> - Generating Perl module from "dac" file.  
   
614  L<lib/Message/Util/DIS.dis> - The actual implementation  L<lib/Message/Util/DIS.dis> - The actual implementation
615  of the "dis" interpretation.  of the "dis" interpretation.
616    
617  =head1 LICENSE  =head1 LICENSE
618    
619  Copyright 2004-2005 Wakaba <w@suika.fam.cx>.  All rights reserved.  Copyright 2004-2006 Wakaba <w@suika.fam.cx>.  All rights reserved.
620    
621  This program is free software; you can redistribute it and/or  This program is free software; you can redistribute it and/or
622  modify it under the same terms as Perl itself.  modify it under the same terms as Perl itself.
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.14
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24