--- messaging/manakai/bin/daf.pl 2006/04/04 14:30:29 1.11 +++ messaging/manakai/bin/daf.pl 2006/12/30 12:49:58 1.22 @@ -1,42 +1,58 @@ #!/usr/bin/perl -w use strict; use Message::Util::QName::Filter { - c => q, - DIS => q, dis => q, - DOMLS => q, dp => q, - fe => q, ManakaiDOM => q, - pc => q, swcfg21 => q, - test => q, - Util => q, }; +our$VERSION=do{my @r=(q$Revision: 1.22 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r}; use Cwd; use Getopt::Long; use Pod::Usage; -my %Opt = (create_module => []); +our %Opt = (create_module => []); +my @target_modules; GetOptions ( + 'create-dtd-driver=s' => sub { + shift; + my $i = [split /\s+/, shift, 3]; + $i->[3] = 'dtd-driver'; + push @{$Opt{create_module}}, $i; + }, + '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]; }, '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]; }, '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}, + 'dtd-file-suffix=s' => \$Opt{dtd_suffix}, 'help' => \$Opt{help}, + 'load-module=s' => sub { + shift; + my $i = [split /\s+/, shift, 2]; + push @target_modules, $i->[0]; + }, + 'mod-file-suffix=s' => \$Opt{mod_suffix}, 'search-path|I=s' => sub { shift; my @value = split /\s+/, shift; @@ -84,7 +100,8 @@ $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}; +$Opt{dtd_suffix} = '.dtd' unless defined $Opt{dtd_suffix}; +$Opt{mod_suffix} = '.mod' unless defined $Opt{mod_suffix}; require Error; $Error::Debug = 1 if $Opt{debug}; $Message::Util::Error::VERBOSE = 1 if $Opt{verbose}; @@ -111,41 +128,45 @@ print STDERR $s if $Opt{verbose}; } +sub daf_open_source_dis_document ($); +sub daf_open_current_module_index ($$); +sub daf_convert_dis_document_to_dnl_document (); +sub daf_get_referring_module_uri_list ($); +sub dac_search_file_path_stem ($$$); +sub daf_get_module_index_file_name ($); +sub daf_check_undefined (); + ## ---- The MAIN Program my $start_time; BEGIN { $start_time = time } -use Message::Util::DIS::DNLite; -use Message::Util::PerlCode; +use Message::DOM::DOMCore; -my %feature; -eval q{ - use Message::Util::DIS::Test; - use Message::DOM::GenericLS; - $feature{ExpandedURI q} = '3.0'; - $feature{'+' . ExpandedURI q} = '1.0'; -}; +for (@{$Opt{create_module}}) { + my (undef, undef, undef, $out_type) = @$_; + + if ($out_type eq 'perl-pm') { + require 'manakai/daf-perl-pm.pl'; + } elsif ($out_type eq 'perl-t') { + require 'manakai/daf-perl-t.pl'; + } elsif ($out_type eq 'dtd-modules') { + require 'manakai/daf-dtd-modules.pl'; + } elsif ($out_type eq 'dtd-driver') { + require 'manakai/daf-dtd-modules.pl'; + } +} -my $limpl = $Message::DOM::ImplementationRegistry->get_implementation - ({ExpandedURI q => '3.0', - '+' . ExpandedURI q => '1.0', - '+' . ExpandedURI q => '1.0', - '+' . ExpandedURI q => '1.0', - %feature, - }); -my $impl = $limpl->get_feature (ExpandedURI q => '1.0'); -my $tdt_parser; +our $impl = $Message::DOM::ImplementationRegistry->get_dom_implementation; ## --- 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); my $parser = $impl->create_dis_parser; -my $DNi = $impl->get_feature (ExpandedURI q => '1.0'); my %ModuleSourceDISDocument; my %ModuleSourceDNLDocument; my %ModuleNameNamespaceBinding = ( @@ -155,17 +176,11 @@ ## 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 { shift; # $db - daf_get_module_index_file_name (@_); + daf_get_module_index_file_name (shift); }, get_module_source_document_from_uri => sub { my ($db, $module_uri, $module_for) = @_; @@ -244,7 +259,7 @@ status_msg_ " " if ($ResourceCount % (10 * 10)) == 0; status_msg '' if ($ResourceCount % (10 * 50)) == 0; } -}); +}, implementation => $impl); status_msg ''; status_msg "done"; @@ -278,7 +293,6 @@ daf_check_undefined (); -undef $DNi; undef %ModuleSourceDNLDocument; exit $HasError if $HasError; @@ -286,53 +300,15 @@ 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, - ExpandedURI q); - } - my $mod = $db->get_module ($mod_uri, for_arg => $mod_for); if ($out_type eq 'perl-pm') { - status_msg_ qq for <$mod_for>...>; - local $Message::Util::DIS::Perl::Implementation - = $impl->get_feature (ExpandedURI q => '1.0'); - my $pl = $mod->pl_generate_perl_module_file - ($impl->get_feature (ExpandedURI q => '1.0')); - status_msg qq; - - my $output; - defined $out_file_path - ? (open $output, '>', $out_file_path or die "$0: $out_file_path: $!") - : ($output = \*STDOUT); - - status_msg_ sprintf qq, - defined $out_file_path - ? q<">.$out_file_path.q<"> - : 'to stdout'; - print $output $pl->stringify; - close $output; - status_msg q; + daf_perl_pm ($mod_uri, $out_file_path); } elsif ($out_type eq 'perl-t') { - status_msg_ qq for <$mod_for>...>; - my $pl = daf_generate_perl_test_file ($mod); - status_msg qq; - - my $cfg = $pl->owner_document->dom_config; - $cfg->set_parameter (ExpandedURI q => 1); - - my $output; - defined $out_file_path - ? (open $output, '>', $out_file_path or die "$0: $out_file_path: $!") - : ($output = \*STDOUT); - - status_msg_ sprintf qq, - defined $out_file_path - ? q<">.$out_file_path.q<"> - : 'to stdout'; - print $output $pl->stringify; - close $output; - status_msg q; + daf_perl_t ($mod_uri, $out_file_path); + } elsif ($out_type eq 'dtd-modules') { + daf_dtd_modules ($mod_uri, $out_file_path, $mod_for); + } elsif ($out_type eq 'dtd-driver') { + daf_dtd_driver ($mod_uri, $out_file_path, $mod_for); } } @@ -345,7 +321,6 @@ undef $db; status_msg "done"; -undef $limpl; undef $impl; { @@ -438,7 +413,7 @@ my $dis_doc = $ModuleSourceDISDocument{$module_uri}; next M unless $dis_doc; verbose_msg_ qq...>; - my $dnl_doc = $DNi->convert_dis_document_to_dnl_document + my $dnl_doc = $impl->convert_dis_document_to_dnl_document ($dis_doc, database_arg => $db, base_namespace_binding => {(map {$_->local_name => $_->target_namespace_uri} @@ -497,7 +472,7 @@ return undef; } # dac_search_file_path_stem; -sub daf_get_module_index_file_name ($$) { +sub daf_get_module_index_file_name ($) { my ($module_uri) = @_; my $ns = $module_uri; $ns =~ s/(\w+)\z//; @@ -592,164 +567,6 @@ } } # daf_check_undefined -sub daf_generate_perl_test_file ($) { - my $mod = shift; - my $pc = $impl->get_feature (ExpandedURI q => '1.0'); - 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"); - $pack->add_require_perl_module_name ($mod->pl_fully_qualified_name); - - $pl->source_file ($mod->get_property_text (ExpandedURI q, "")); - $pl->source_module ($mod->name_uri); - $pl->source_for ($mod->for_uri); - $pl->license_uri ($mod->get_property_resource (ExpandedURI q) - ->uri); - - $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_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)) { - if ($res->is_type_uri (ExpandedURI q)) { - 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 ($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 ($factory); - 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; - };'); - - $pack->append_code ('} else { warn "'.$test_num.' skipped\n" }'); - - } elsif ($res->is_type_uri (ExpandedURI q)) { - my $block = $pack->append_new_pc_block; - my @test; - - $tdt_parser ||= $limpl->create_gls_parser - ({ - ExpandedURI q => '1.0', - }); - for my $tres (@{$res->get_child_resource_list_by_type - (ExpandedURI q)}) { - $total_tests++; - push @test, my $ttest = {entity => {}}; - $ttest->{uri} = $tres->uri; - for my $eres (@{$tres->get_child_resource_list_by_type - (ExpandedURI q)}) { - my $tent = $ttest->{entity}->{$eres->uri} = {}; - for (ExpandedURI q, ExpandedURI q, - ExpandedURI q) { - my $v = $eres->get_property_text ($_); - $tent->{$_} = $v if defined $v; - } - $ttest->{root_uri} = $eres->uri - if $eres->is_type_uri (ExpandedURI q) or - not defined $ttest->{root_uri}; - } - - ## DOM configuration parameters - for my $v (@{$tres->get_property_value_list - (ExpandedURI q)}) { - my $cpuri = $v->name; - my $cp = $db->get_resource ($cpuri, for_arg => $tres->for_uri); - $ttest->{dom_config}->{$cp->get_dom_configuration_parameter_name} - = $v->get_perl_code ($block->owner_document, $tres); - } - - ## Result DOM tree - my $tree_t = $tres->get_property_text (ExpandedURI q); - if (defined $tree_t) { - $ttest->{dom_tree} = $tdt_parser->parse_string ($tree_t); - } - - ## Expected |DOMError|s - for (@{$tres->get_property_value_list (ExpandedURI q)}) { - 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 ($factory); - 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 @@ -790,22 +607,16 @@ and then I file is loaded in the context of it. Otherwise, a new database is created. -=item C<--output-file-name=I> (Required) - -The - =back =head1 SEE ALSO -L - Generating Perl module from "dac" file. - L - The actual implementation of the "dis" interpretation. =head1 LICENSE -Copyright 2004-2005 Wakaba . All rights reserved. +Copyright 2004-2006 Wakaba . All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.