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 { |
|
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#>, |
|
4 |
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#>, |
|
5 |
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/>, |
|
fe => q<http://suika.fam.cx/www/2006/feature/>, |
|
6 |
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#>, |
|
pc => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/PerlCode#>, |
|
7 |
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#>, |
|
|
Util => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/>, |
|
8 |
}; |
}; |
9 |
|
|
10 |
|
our$VERSION=do{my @r=(q$Revision$=~/\d+/g);sprintf "%d."."%02d" x $#r,@r}; |
11 |
use Cwd; |
use Cwd; |
12 |
use Getopt::Long; |
use Getopt::Long; |
13 |
use Pod::Usage; |
use Pod::Usage; |
14 |
my %Opt = (create_module => []); |
our %Opt = (create_module => []); |
15 |
|
my @target_modules; |
16 |
GetOptions ( |
GetOptions ( |
17 |
|
'create-dtd-driver=s' => sub { |
18 |
|
shift; |
19 |
|
my $i = [split /\s+/, shift, 3]; |
20 |
|
$i->[3] = 'dtd-driver'; |
21 |
|
push @{$Opt{create_module}}, $i; |
22 |
|
}, |
23 |
|
'create-dtd-modules=s' => sub { |
24 |
|
shift; |
25 |
|
my $i = [split /\s+/, shift, 3]; |
26 |
|
$i->[3] = 'dtd-modules'; |
27 |
|
push @{$Opt{create_module}}, $i; |
28 |
|
}, |
29 |
'create-perl-module=s' => sub { |
'create-perl-module=s' => sub { |
30 |
shift; |
shift; |
31 |
my $i = [split /\s+/, shift, 3]; |
my $i = [split /\s+/, shift, 3]; |
32 |
$i->[3] = 'perl-pm'; |
$i->[3] = 'perl-pm'; |
33 |
push @{$Opt{create_module}}, $i; |
push @{$Opt{create_module}}, $i; |
34 |
|
push @target_modules, $i->[0]; |
35 |
}, |
}, |
36 |
'create-perl-test=s' => sub { |
'create-perl-test=s' => sub { |
37 |
shift; |
shift; |
38 |
my $i = [split /\s+/, shift, 3]; |
my $i = [split /\s+/, shift, 3]; |
39 |
$i->[3] = 'perl-t'; |
$i->[3] = 'perl-t'; |
40 |
push @{$Opt{create_module}}, $i; |
push @{$Opt{create_module}}, $i; |
41 |
|
push @target_modules, $i->[0]; |
42 |
}, |
}, |
43 |
'debug' => \$Opt{debug}, |
'debug' => \$Opt{debug}, |
44 |
'dis-file-suffix=s' => \$Opt{dis_suffix}, |
'dis-file-suffix=s' => \$Opt{dis_suffix}, |
45 |
'daem-file-suffix=s' => \$Opt{daem_suffix}, |
'daem-file-suffix=s' => \$Opt{daem_suffix}, |
46 |
|
'dafs-file-suffix=s' => \$Opt{dafs_suffix}, |
47 |
'dafx-file-suffix=s' => \$Opt{dafx_suffix}, |
'dafx-file-suffix=s' => \$Opt{dafx_suffix}, |
48 |
|
'dtd-file-suffix=s' => \$Opt{dtd_suffix}, |
49 |
'help' => \$Opt{help}, |
'help' => \$Opt{help}, |
50 |
|
'load-module=s' => sub { |
51 |
|
shift; |
52 |
|
my $i = [split /\s+/, shift, 2]; |
53 |
|
push @target_modules, $i->[0]; |
54 |
|
}, |
55 |
|
'mod-file-suffix=s' => \$Opt{mod_suffix}, |
56 |
'search-path|I=s' => sub { |
'search-path|I=s' => sub { |
57 |
shift; |
shift; |
58 |
my @value = split /\s+/, shift; |
my @value = split /\s+/, shift; |
99 |
$Opt{dis_suffix} = '.dis' unless defined $Opt{dis_suffix}; |
$Opt{dis_suffix} = '.dis' unless defined $Opt{dis_suffix}; |
100 |
$Opt{daem_suffix} = '.dafm' unless defined $Opt{daem_suffix}; |
$Opt{daem_suffix} = '.dafm' unless defined $Opt{daem_suffix}; |
101 |
$Opt{dafx_suffix} = '.dafx' unless defined $Opt{dafx_suffix}; |
$Opt{dafx_suffix} = '.dafx' unless defined $Opt{dafx_suffix}; |
102 |
$Message::DOM::DOMFeature::DEBUG = 1 if $Opt{debug}; |
$Opt{dafs_suffix} = '.dafs' unless defined $Opt{dafs_suffix}; |
103 |
|
$Opt{dtd_suffix} = '.dtd' unless defined $Opt{dtd_suffix}; |
104 |
|
$Opt{mod_suffix} = '.mod' unless defined $Opt{mod_suffix}; |
105 |
require Error; |
require Error; |
106 |
$Error::Debug = 1 if $Opt{debug}; |
$Error::Debug = 1 if $Opt{debug}; |
107 |
$Message::Util::Error::VERBOSE = 1 if $Opt{verbose}; |
$Message::Util::Error::VERBOSE = 1 if $Opt{verbose}; |
128 |
print STDERR $s if $Opt{verbose}; |
print STDERR $s if $Opt{verbose}; |
129 |
} |
} |
130 |
|
|
131 |
|
sub daf_open_source_dis_document ($); |
132 |
|
sub daf_open_current_module_index ($$); |
133 |
|
sub daf_convert_dis_document_to_dnl_document (); |
134 |
|
sub daf_get_referring_module_uri_list ($); |
135 |
|
sub dac_search_file_path_stem ($$$); |
136 |
|
sub daf_get_module_index_file_name ($); |
137 |
|
sub daf_check_undefined (); |
138 |
|
|
139 |
## ---- The MAIN Program |
## ---- The MAIN Program |
140 |
|
|
141 |
my $start_time; |
my $start_time; |
142 |
BEGIN { $start_time = time } |
BEGIN { $start_time = time } |
143 |
|
|
144 |
use Message::Util::DIS::DNLite; |
use Message::DOM::DOMCore; |
145 |
use Message::Util::PerlCode; |
|
146 |
use Message::Util::DIS::Test; |
for (@{$Opt{create_module}}) { |
147 |
use Message::DOM::GenericLS; |
my (undef, undef, undef, $out_type) = @$_; |
148 |
|
|
149 |
my $limpl = $Message::DOM::ImplementationRegistry->get_implementation |
if ($out_type eq 'perl-pm') { |
150 |
({ExpandedURI q<fe:Min> => '3.0', |
require 'manakai/daf-perl-pm.pl'; |
151 |
ExpandedURI q<fe:GenericLS> => '3.0', |
} elsif ($out_type eq 'perl-t') { |
152 |
'+' . ExpandedURI q<DIS:DNLite> => '1.0', |
require 'manakai/daf-perl-t.pl'; |
153 |
'+' . ExpandedURI q<DIS:Core> => '1.0', |
} elsif ($out_type eq 'dtd-modules') { |
154 |
'+' . ExpandedURI q<Util:PerlCode> => '1.0', |
require 'manakai/daf-dtd-modules.pl'; |
155 |
'+' . ExpandedURI q<DIS:TDT> => '1.0', |
} elsif ($out_type eq 'dtd-driver') { |
156 |
}); |
require 'manakai/daf-dtd-modules.pl'; |
157 |
my $impl = $limpl->get_feature (ExpandedURI q<DIS:Core> => '1.0'); |
} |
158 |
my $pc = $impl->get_feature (ExpandedURI q<Util:PerlCode> => '1.0'); |
} |
159 |
my $di = $impl->get_feature (ExpandedURI q<DIS:Core> => '1.0'); |
|
160 |
my $tdt_parser; |
our $impl = $Message::DOM::ImplementationRegistry->get_dom_implementation; |
161 |
|
|
162 |
## --- Loading and Updating the Database |
## --- Loading and Updating the Database |
163 |
|
|
164 |
my $HasError; |
my $HasError; |
165 |
my $db = $impl->create_dis_database; |
our $db = $impl->create_dis_database; |
166 |
$db->pl_database_module_resolver (\&daf_db_module_resolver); |
$db->pl_database_module_resolver (\&daf_db_module_resolver); |
167 |
$db->dom_config->set_parameter ('error-handler' => \&daf_on_error); |
$db->dom_config->set_parameter ('error-handler' => \&daf_on_error); |
168 |
|
|
169 |
my $parser = $impl->create_dis_parser; |
my $parser = $impl->create_dis_parser; |
|
my $DNi = $impl->get_feature (ExpandedURI q<DIS:DNLite> => '1.0'); |
|
170 |
my %ModuleSourceDISDocument; |
my %ModuleSourceDISDocument; |
171 |
my %ModuleSourceDNLDocument; |
my %ModuleSourceDNLDocument; |
172 |
my %ModuleNameNamespaceBinding = ( |
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 { |
182 |
shift; # $db |
shift; # $db |
183 |
daf_get_module_index_file_name (@_); |
daf_get_module_index_file_name (shift); |
184 |
}, |
}, |
185 |
get_module_source_document_from_uri => sub { |
get_module_source_document_from_uri => sub { |
186 |
my ($db, $module_uri, $module_for) = @_; |
my ($db, $module_uri, $module_for) = @_; |
196 |
} |
} |
197 |
return $ModuleSourceDNLDocument{$module_uri}; |
return $ModuleSourceDNLDocument{$module_uri}; |
198 |
}, |
}, |
199 |
get_module_source_document_from_resource => sub ($$$$$$) { |
get_module_source_document_from_resource => sub ($$$$$) { |
200 |
my ($self, $db, $uri, $ns, $ln, $for) = @_; |
my ($self, $db, $uri, $ns, $ln) = @_; |
201 |
status_msg ''; |
status_msg ''; |
202 |
status_msg qq<Loading module "$ln" for <$for>...>; |
status_msg qq<Loading module "$ln"...>; |
203 |
$ResourceCount = 0; |
$ResourceCount = 0; |
204 |
|
|
205 |
my $module_uri = $ns.$ln; |
my $module_uri = $ns.$ln; |
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 |
}, |
}, |
259 |
status_msg_ " " if ($ResourceCount % (10 * 10)) == 0; |
status_msg_ " " if ($ResourceCount % (10 * 10)) == 0; |
260 |
status_msg '' if ($ResourceCount % (10 * 50)) == 0; |
status_msg '' if ($ResourceCount % (10 * 50)) == 0; |
261 |
} |
} |
262 |
}); |
}, implementation => $impl); |
263 |
status_msg ''; |
status_msg ''; |
264 |
status_msg "done"; |
status_msg "done"; |
265 |
|
|
293 |
|
|
294 |
daf_check_undefined (); |
daf_check_undefined (); |
295 |
|
|
|
undef $DNi; |
|
296 |
undef %ModuleSourceDNLDocument; |
undef %ModuleSourceDNLDocument; |
297 |
exit $HasError if $HasError; |
exit $HasError if $HasError; |
298 |
|
|
299 |
## --- Creating Files |
## --- Creating Files |
300 |
|
|
301 |
for (@{$Opt{create_module}}) { |
for (@{$Opt{create_module}}) { |
302 |
my ($mod_uri, $out_file_path, $mod_for, $out_type) = @$_; |
my ($mod_uri, $out_file_path, undef, $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); |
|
303 |
|
|
304 |
if ($out_type eq 'perl-pm') { |
if ($out_type eq 'perl-pm') { |
305 |
status_msg_ qq<Generating Perl module from <$mod_uri> for <$mod_for>...>; |
daf_perl_pm ($mod_uri, $out_file_path); |
|
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>; |
|
306 |
} elsif ($out_type eq 'perl-t') { |
} elsif ($out_type eq 'perl-t') { |
307 |
status_msg_ qq<Generating Perl test from <$mod_uri> for <$mod_for>...>; |
daf_perl_t ($mod_uri, $out_file_path); |
308 |
my $pl = daf_generate_perl_test_file ($mod); |
} elsif ($out_type eq 'dtd-modules') { |
309 |
status_msg qq<done>; |
daf_dtd_modules ($mod_uri, $out_file_path); |
310 |
|
} elsif ($out_type eq 'dtd-driver') { |
311 |
my $cfg = $pl->owner_document->dom_config; |
daf_dtd_driver ($mod_uri, $out_file_path); |
|
$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>; |
|
312 |
} |
} |
313 |
} |
} |
314 |
|
|
321 |
undef $db; |
undef $db; |
322 |
status_msg "done"; |
status_msg "done"; |
323 |
|
|
324 |
|
undef $impl; |
325 |
|
|
326 |
{ |
{ |
327 |
use integer; |
use integer; |
328 |
my $time = time - $start_time; |
my $time = time - $start_time; |
413 |
my $dis_doc = $ModuleSourceDISDocument{$module_uri}; |
my $dis_doc = $ModuleSourceDISDocument{$module_uri}; |
414 |
next M unless $dis_doc; |
next M unless $dis_doc; |
415 |
verbose_msg_ qq<Converting <$module_uri>...>; |
verbose_msg_ qq<Converting <$module_uri>...>; |
416 |
my $dnl_doc = $DNi->convert_dis_document_to_dnl_document |
my $dnl_doc = $impl->convert_dis_document_to_dnl_document |
417 |
($dis_doc, database_arg => $db, |
($dis_doc, database_arg => $db, |
418 |
base_namespace_binding => |
base_namespace_binding => |
419 |
{(map {$_->local_name => $_->target_namespace_uri} |
{(map {$_->local_name => $_->target_namespace_uri} |
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))); |
472 |
return undef; |
return undef; |
473 |
} # dac_search_file_path_stem; |
} # dac_search_file_path_stem; |
474 |
|
|
475 |
sub daf_get_module_index_file_name ($$) { |
sub daf_get_module_index_file_name ($) { |
476 |
my ($module_uri) = @_; |
my ($module_uri) = @_; |
477 |
my $ns = $module_uri; |
my $ns = $module_uri; |
478 |
$ns =~ s/(\w+)\z//; |
$ns =~ s/(\w+)\z//; |
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) { |
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 ||= $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 |
|
|
|
|
570 |
__END__ |
__END__ |
571 |
|
|
572 |
=head1 NAME |
=head1 NAME |
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. |