--- messaging/manakai/bin/daf.pl 2006/02/26 14:32:38 1.3
+++ messaging/manakai/bin/daf.pl 2006/05/19 11:02:11 1.14
@@ -4,13 +4,11 @@
c => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/dom-core#>,
DIS => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/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#>,
dp => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#Perl/>,
fe => q<http://suika.fam.cx/www/2006/feature/>,
ManakaiDOM => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/manakai-dom#>,
pc => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/PerlCode#>,
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/>,
};
@@ -18,24 +16,39 @@
use Getopt::Long;
use Pod::Usage;
my %Opt = (create_module => []);
+my @target_modules;
GetOptions (
+ 'create-dtd-modules=s' => sub {
+ shift;
+ my $i = [split /\s+/, shift, 3];
+ $i->[3] = 'dtd-modules';
+ push @{$Opt{create_module}}, $i;
+ },
'create-perl-module=s' => sub {
shift;
my $i = [split /\s+/, shift, 3];
$i->[3] = 'perl-pm';
push @{$Opt{create_module}}, $i;
+ push @target_modules, [$i->[0], $i->[2]];
},
'create-perl-test=s' => sub {
shift;
my $i = [split /\s+/, shift, 3];
$i->[3] = 'perl-t';
push @{$Opt{create_module}}, $i;
+ push @target_modules, [$i->[0], $i->[2]];
},
'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},
+ 'load-module=s' => sub {
+ shift;
+ my $i = [split /\s+/, shift, 2];
+ push @target_modules, [$i->[0], $i->[1]];
+ },
'search-path|I=s' => sub {
shift;
my @value = split /\s+/, shift;
@@ -82,6 +95,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};
@@ -115,27 +129,39 @@
BEGIN { $start_time = time }
use Message::Util::DIS::DNLite;
-use Message::Util::PerlCode;
-use Message::Util::DIS::Test;
-use Message::DOM::GenericLS;
-my $limpl = $Message::DOM::ImplementationRegistry->get_implementation
+my %feature;
+
+for (@{$Opt{create_module}}) {
+ my (undef, undef, undef, $out_type) = @$_;
+
+ if ($out_type eq 'perl-pm') {
+ require 'manakai/daf-perl-pm.pl';
+ $feature{'+' . ExpandedURI q<Util:PerlCode>} = '1.0';
+ } elsif ($out_type eq 'perl-t') {
+ require 'manakai/daf-perl-t.pl';
+ $feature{ExpandedURI q<fe:GenericLS>} = '3.0';
+ $feature{'+' . ExpandedURI q<DIS:TDT>} = '1.0';
+ $feature{'+' . ExpandedURI q<Util:PerlCode>} = '1.0';
+ } elsif ($out_type eq 'dtd-modules') {
+ require 'manakai/daf-dtd-modules.pl';
+ $feature{ExpandedURI q<fe:GenericLS>} = '3.0';
+ $feature{'+' . ExpandedURI q<fe:XDP>} = '3.0';
+ }
+}
+
+our $limpl = $Message::DOM::ImplementationRegistry->get_implementation
({ExpandedURI q<fe:Min> => '3.0',
- ExpandedURI q<fe:GenericLS> => '3.0',
'+' . ExpandedURI q<DIS:DNLite> => '1.0',
'+' . ExpandedURI q<DIS:Core> => '1.0',
- '+' . ExpandedURI q<Util:PerlCode> => '1.0',
- '+' . ExpandedURI q<DIS:TDT> => '1.0',
+ %feature,
});
-my $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;
+our $impl = $limpl->get_feature (ExpandedURI q<DIS:Core> => '1.0');
## --- Loading and Updating the Database
my $HasError;
-my $db = $impl->create_dis_database;
+our $db = $impl->create_dis_database;
$db->pl_database_module_resolver (\&daf_db_module_resolver);
$db->dom_config->set_parameter ('error-handler' => \&daf_on_error);
@@ -150,12 +176,6 @@
## property.
);
-my @target_modules;
-for (@{$Opt{create_module}}) {
- my ($mod_uri, $out_path, $mod_for, $out_type) = @$_;
- push @target_modules, [$mod_uri, $mod_for];
-}
-
my $ResourceCount = 0;
$db->pl_update_module (\@target_modules,
get_module_index_file_name => sub {
@@ -210,7 +230,6 @@
unless (defined $ModuleSourceDISDocument{$module_uri}) {
daf_open_source_dis_document ($module_uri);
}
- daf_convert_dis_document_to_dnl_document ();
}
return daf_get_referring_module_uri_list ($module_uri);
},
@@ -282,50 +301,13 @@
for (@{$Opt{create_module}}) {
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);
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;
- 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>;
+ daf_perl_pm ($mod_uri, $out_file_path, $mod_for);
} elsif ($out_type eq 'perl-t') {
- status_msg_ qq<Generating Perl test from <$mod_uri> for <$mod_for>...>;
- my $pl = daf_generate_perl_test_file ($mod);
- status_msg qq<done>;
-
- my $cfg = $pl->owner_document->dom_config;
- $cfg->set_parameter (ExpandedURI q<pc:preserve-line-break> => 1);
-
- 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>;
+ daf_perl_t ($mod_uri, $out_file_path, $mod_for);
+ } elsif ($out_type eq 'dtd-modules') {
+ daf_dtd_modules ($mod_uri, $out_file_path, $mod_for);
}
}
@@ -338,6 +320,9 @@
undef $db;
status_msg "done";
+undef $limpl;
+undef $impl;
+
{
use integer;
my $time = time - $start_time;
@@ -476,7 +461,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)));
@@ -535,8 +520,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) {
@@ -579,127 +567,6 @@
}
} # daf_check_undefined
-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 ||= $limpl->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
-
__END__
=head1 NAME
@@ -740,22 +607,16 @@
and then I<input.dis> file is loaded in the context of it.
Otherwise, a new database is created.
-=item C<--output-file-name=I<file-name>> (Required)
-
-The
-
=back
=head1 SEE ALSO
-L<bin/dac2pm.pl> - Generating Perl module from "dac" file.
-
L<lib/Message/Util/DIS.dis> - The actual implementation
of the "dis" interpretation.
=head1 LICENSE
-Copyright 2004-2005 Wakaba <w@suika.fam.cx>. All rights reserved.
+Copyright 2004-2006 Wakaba <w@suika.fam.cx>. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.