/[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.1 by wakaba, Sat Feb 25 16:49:55 2006 UTC revision 1.18 by wakaba, Sat Nov 4 12:25:10 2006 UTC
# Line 1  Line 1 
1  #!/usr/bin/perl -w  #!/usr/bin/perl -w
2  use strict;  use strict;
3  use Message::Util::QName::Filter {  use Message::Util::QName::Filter {
4      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-->,
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#>,
11    swcfg21 => q<http://suika.fam.cx/~wakaba/archive/2005/swcfg21#>,    swcfg21 => q<http://suika.fam.cx/~wakaba/archive/2005/swcfg21#>,
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    
15    our$VERSION=do{my @r=(q$Revision$=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
16  use Cwd;  use Cwd;
17  use Getopt::Long;  use Getopt::Long;
18  use Pod::Usage;  use Pod::Usage;
19  my %Opt = (create_module => []);  our %Opt = (create_module => []);
20    my @target_modules;
21  GetOptions (  GetOptions (
22      'create-dtd-driver=s' => sub {
23        shift;
24        my $i = [split /\s+/, shift, 3];
25        $i->[3] = 'dtd-driver';
26        push @{$Opt{create_module}}, $i;
27      },
28      'create-dtd-modules=s' => sub {
29        shift;
30        my $i = [split /\s+/, shift, 3];
31        $i->[3] = 'dtd-modules';
32        push @{$Opt{create_module}}, $i;
33      },
34    'create-perl-module=s' => sub {    'create-perl-module=s' => sub {
35      shift;      shift;
36      my $i = [split /\s+/, shift, 3];      my $i = [split /\s+/, shift, 3];
37      $i->[3] = 'pm';      $i->[3] = 'perl-pm';
38      push @{$Opt{create_module}}, $i;      push @{$Opt{create_module}}, $i;
39        push @target_modules, [$i->[0], $i->[2]];
40      },
41      'create-perl-test=s' => sub {
42        shift;
43        my $i = [split /\s+/, shift, 3];
44        $i->[3] = 'perl-t';
45        push @{$Opt{create_module}}, $i;
46        push @target_modules, [$i->[0], $i->[2]];
47    },    },
48    'debug' => \$Opt{debug},    'debug' => \$Opt{debug},
49    'dis-file-suffix=s' => \$Opt{dis_suffix},    'dis-file-suffix=s' => \$Opt{dis_suffix},
50    'daem-file-suffix=s' => \$Opt{daem_suffix},    'daem-file-suffix=s' => \$Opt{daem_suffix},
51      'dafs-file-suffix=s' => \$Opt{dafs_suffix},
52    'dafx-file-suffix=s' => \$Opt{dafx_suffix},    'dafx-file-suffix=s' => \$Opt{dafx_suffix},
53      'dtd-file-suffix=s' => \$Opt{dtd_suffix},
54    'help' => \$Opt{help},    'help' => \$Opt{help},
55      'load-module=s' => sub {
56        shift;
57        my $i = [split /\s+/, shift, 2];
58        push @target_modules, [$i->[0], $i->[1]];
59      },
60      'mod-file-suffix=s' => \$Opt{mod_suffix},
61    'search-path|I=s' => sub {    'search-path|I=s' => sub {
62      shift;      shift;
63      my @value = split /\s+/, shift;      my @value = split /\s+/, shift;
# Line 72  $Opt{no_undef_check} = defined $Opt{no_u Line 104  $Opt{no_undef_check} = defined $Opt{no_u
104  $Opt{dis_suffix} = '.dis' unless defined $Opt{dis_suffix};  $Opt{dis_suffix} = '.dis' unless defined $Opt{dis_suffix};
105  $Opt{daem_suffix} = '.dafm' unless defined $Opt{daem_suffix};  $Opt{daem_suffix} = '.dafm' unless defined $Opt{daem_suffix};
106  $Opt{dafx_suffix} = '.dafx' unless defined $Opt{dafx_suffix};  $Opt{dafx_suffix} = '.dafx' unless defined $Opt{dafx_suffix};
107  $Message::DOM::DOMFeature::DEBUG = 1 if $Opt{debug};  $Opt{dafs_suffix} = '.dafs' unless defined $Opt{dafs_suffix};
108    $Opt{dtd_suffix} = '.dtd' unless defined $Opt{dtd_suffix};
109    $Opt{mod_suffix} = '.mod' unless defined $Opt{mod_suffix};
110  require Error;  require Error;
111  $Error::Debug = 1 if $Opt{debug};  $Error::Debug = 1 if $Opt{debug};
112  $Message::Util::Error::VERBOSE = 1 if $Opt{verbose};  $Message::Util::Error::VERBOSE = 1 if $Opt{verbose};
# Line 99  sub verbose_msg_ ($) { Line 133  sub verbose_msg_ ($) {
133    print STDERR $s if $Opt{verbose};    print STDERR $s if $Opt{verbose};
134  }  }
135    
136    ## ---- The MAIN Program
137    
138  my $start_time;  my $start_time;
139  BEGIN { $start_time = time }  BEGIN { $start_time = time }
140    
141  use Message::Util::DIS::DNLite;  use Message::Util::DIS::DNLite;
 use Message::Util::PerlCode;  
142    
143  my $limpl = $Message::DOM::ImplementationRegistry->get_implementation  my %feature;
144    
145    for (@{$Opt{create_module}}) {
146      my (undef, undef, undef, $out_type) = @$_;
147    
148      if ($out_type eq 'perl-pm') {
149        require 'manakai/daf-perl-pm.pl';
150        $feature{'+' . ExpandedURI q<Util:PerlCode>} = '1.0';
151      } elsif ($out_type eq 'perl-t') {
152        require 'manakai/daf-perl-t.pl';
153        $feature{ExpandedURI q<fe:GenericLS>} = '3.0';
154        $feature{'+' . ExpandedURI q<DIS:TDT>} = '1.0';
155        $feature{'+' . ExpandedURI q<Util:PerlCode>} = '1.0';
156      } elsif ($out_type eq 'dtd-modules') {
157        require 'manakai/daf-dtd-modules.pl';
158        $feature{ExpandedURI q<fe:GenericLS>} = '3.0';
159        $feature{'+' . ExpandedURI q<fe:XDP>} = '3.0';
160      } elsif ($out_type eq 'dtd-driver') {
161        require 'manakai/daf-dtd-modules.pl';
162        $feature{ExpandedURI q<fe:GenericLS>} = '3.0';
163        $feature{'+' . ExpandedURI q<fe:XDP>} = '3.0';
164      }
165    }
166    
167    our $limpl = $Message::DOM::ImplementationRegistry->get_implementation
168                             ({ExpandedURI q<fe:Min> => '3.0',                             ({ExpandedURI q<fe:Min> => '3.0',
169                               '+' . ExpandedURI q<DIS:DNLite> => '1.0',                               '+' . ExpandedURI q<DIS:DNLite> => '1.0',
170                               '+' . ExpandedURI q<DIS:Core> => '1.0',                               '+' . ExpandedURI q<DIS:Core> => '1.0',
171                               '+' . ExpandedURI q<Util:PerlCode> => '1.0',                               %feature,
172                             });                             });
173  my $impl = $limpl->get_feature (ExpandedURI q<DIS:Core> => '1.0');  our $impl = $limpl->get_feature (ExpandedURI q<DIS:Core> => '1.0');
174  my $parser = $impl->create_dis_parser;  
175  our $DNi = $impl->get_feature (ExpandedURI q<DIS:DNLite> => '1.0');  ## --- Loading and Updating the Database
176    
177  my $HasError;  my $HasError;
178  my $db = $impl->create_dis_database;  our $db = $impl->create_dis_database;
179  $db->pl_database_module_resolver (\&daf_db_module_resolver);  $db->pl_database_module_resolver (\&daf_db_module_resolver);
180  $db->dom_config->set_parameter ('error-handler' => \&daf_on_error);  $db->dom_config->set_parameter ('error-handler' => \&daf_on_error);
181    
182    my $parser = $impl->create_dis_parser;
183    my $DNi = $impl->get_feature (ExpandedURI q<DIS:DNLite> => '1.0');
184  my %ModuleSourceDISDocument;  my %ModuleSourceDISDocument;
185  my %ModuleSourceDNLDocument;  my %ModuleSourceDNLDocument;
186  my %ModuleNameNamespaceBinding = (  my %ModuleNameNamespaceBinding = (
# Line 129  my %ModuleNameNamespaceBinding = ( Line 190  my %ModuleNameNamespaceBinding = (
190      ## property.      ## property.
191  );  );
192    
 my @target_modules;  
 for (@{$Opt{create_module}}) {  
   my ($mod_uri, $out_path, $mod_for, $out_type) = @$_;  
   push @target_modules, [$mod_uri, $mod_for];  
 }  
   
193  my $ResourceCount = 0;  my $ResourceCount = 0;
194  $db->pl_update_module (\@target_modules,  $db->pl_update_module (\@target_modules,
195  get_module_index_file_name => sub {  get_module_index_file_name => sub {
# Line 189  get_referring_module_uri_list => sub { Line 244  get_referring_module_uri_list => sub {
244      unless (defined $ModuleSourceDISDocument{$module_uri}) {      unless (defined $ModuleSourceDISDocument{$module_uri}) {
245        daf_open_source_dis_document ($module_uri);        daf_open_source_dis_document ($module_uri);
246      }      }
     daf_convert_dis_document_to_dnl_document ();  
247    }    }
248    return daf_get_referring_module_uri_list ($module_uri);    return daf_get_referring_module_uri_list ($module_uri);
249  },  },
# Line 219  $db->read_properties (on_resource_read = Line 273  $db->read_properties (on_resource_read =
273      status_msg_ " " if ($ResourceCount % (10 * 10)) == 0;      status_msg_ " " if ($ResourceCount % (10 * 10)) == 0;
274      status_msg '' if ($ResourceCount % (10 * 50)) == 0;      status_msg '' if ($ResourceCount % (10 * 50)) == 0;
275    }    }
276  });  }, implementation => $impl);
277  status_msg '';  status_msg '';
278  status_msg "done";  status_msg "done";
279    
# Line 253  status_msg "done"; Line 307  status_msg "done";
307    
308  daf_check_undefined ();  daf_check_undefined ();
309    
310    undef $DNi;
311    undef %ModuleSourceDNLDocument;
312    exit $HasError if $HasError;
313    
314    ## --- Creating Files
315    
316  for (@{$Opt{create_module}}) {  for (@{$Opt{create_module}}) {
317    my ($mod_uri, $out_file_path, $mod_for, $out_type) = @$_;    my ($mod_uri, $out_file_path, $mod_for, $out_type) = @$_;
318    unless (defined $mod_for) {  
319      $mod_for = $db->get_module ($mod_uri)    if ($out_type eq 'perl-pm') {
320                    ->get_property_text (ExpandedURI q<dis:DefaultFor>,      daf_perl_pm ($mod_uri, $out_file_path, $mod_for);
321                                         ExpandedURI q<ManakaiDOM:all>);    } elsif ($out_type eq 'perl-t') {
322    }      daf_perl_t ($mod_uri, $out_file_path, $mod_for);
323    my $mod = $db->get_module ($mod_uri, for_arg => $mod_for);    } elsif ($out_type eq 'dtd-modules') {
324        daf_dtd_modules ($mod_uri, $out_file_path, $mod_for);
325    if ($out_type eq 'pm') {    } elsif ($out_type eq 'dtd-driver') {
326      status_msg_ qq<Generating Perl module from <$mod_uri> for <$mod_for>...>;      daf_dtd_driver ($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>;  
327    }    }
328  }  }
329    
330  daf_check_undefined ();  daf_check_undefined ();
331    
332    ## --- The END
333    
334  status_msg_ "Closing the database...";  status_msg_ "Closing the database...";
335  $db->free;  $db->free;
336  undef $db;  undef $db;
 undef %ModuleSourceDNLDocument;  
337  status_msg "done";  status_msg "done";
338    
339  undef $DNi;  undef $limpl;
340    undef $impl;
341    
342  {  {
343    use integer;    use integer;
# Line 303  END { Line 350  END {
350    $db->free if $db;    $db->free if $db;
351  }  }
352    
353    ## ---- Subroutines
354    
355  sub daf_open_source_dis_document ($) {  sub daf_open_source_dis_document ($) {
356    my ($module_uri) = @_;    my ($module_uri) = @_;
357    
# Line 428  sub daf_get_referring_module_uri_list ($ Line 477  sub daf_get_referring_module_uri_list ($
477  sub dac_search_file_path_stem ($$$) {  sub dac_search_file_path_stem ($$$) {
478    my ($ns, $ln, $suffix) = @_;    my ($ns, $ln, $suffix) = @_;
479    require File::Spec;    require File::Spec;
480    for my $dir ('.', @{$Opt{input_search_path}->{$ns}||[]}) {    for my $dir (@{$Opt{input_search_path}->{$ns}||[]}) {
481      my $name = Cwd::abs_path      my $name = Cwd::abs_path
482          (File::Spec->canonpath          (File::Spec->canonpath
483           (File::Spec->catfile ($dir, $ln)));           (File::Spec->catfile ($dir, $ln)));
# Line 487  sub daf_db_module_resolver ($$$) { Line 536  sub daf_db_module_resolver ($$$) {
536    my ($db, $mod, $type) = @_;    my ($db, $mod, $type) = @_;
537    my $ns = $mod->namespace_uri;    my $ns = $mod->namespace_uri;
538    my $ln = $mod->local_name;    my $ln = $mod->local_name;
539    my $suffix = $type eq ExpandedURI q<dp:ModuleIndexFile>    my $suffix = {
540                   ? $Opt{dafx_suffix} : $Opt{daem_suffix};      ExpandedURI q<dp:ModuleIndexFile> => $Opt{dafx_suffix},
541        ExpandedURI q<dp:ModuleResourceFile> => $Opt{daem_suffix},
542        ExpandedURI q<dp:ModuleNodeStorageFile> => $Opt{dafs_suffix},
543      }->{$type} or die "Unsupported type: <$type>";
544    verbose_msg qq<Database module <$ns$ln> is requested>;    verbose_msg qq<Database module <$ns$ln> is requested>;
545    my $name = dac_search_file_path_stem ($ns, $ln, $suffix);    my $name = dac_search_file_path_stem ($ns, $ln, $suffix);
546    if (defined $name) {    if (defined $name) {
# Line 571  option is specified, the database file i Line 623  option is specified, the database file i
623  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.
624  Otherwise, a new database is created.  Otherwise, a new database is created.
625    
 =item C<--output-file-name=I<file-name>> (Required)  
   
 The  
   
626  =back  =back
627    
628  =head1 SEE ALSO  =head1 SEE ALSO
629    
 L<bin/dac2pm.pl> - Generating Perl module from "dac" file.  
   
630  L<lib/Message/Util/DIS.dis> - The actual implementation  L<lib/Message/Util/DIS.dis> - The actual implementation
631  of the "dis" interpretation.  of the "dis" interpretation.
632    
633  =head1 LICENSE  =head1 LICENSE
634    
635  Copyright 2004-2005 Wakaba <w@suika.fam.cx>.  All rights reserved.  Copyright 2004-2006 Wakaba <w@suika.fam.cx>.  All rights reserved.
636    
637  This program is free software; you can redistribute it and/or  This program is free software; you can redistribute it and/or
638  modify it under the same terms as Perl itself.  modify it under the same terms as Perl itself.
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.18
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24