/[suikacvs]/messaging/manakai/bin/dac2test.pl
Suika

Contents of /messaging/manakai/bin/dac2test.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (hide annotations) (download)
Tue Nov 15 14:18:23 2005 UTC (19 years ago) by wakaba
Branch: MAIN
Changes since 1.1: +2 -1 lines
File MIME type: text/plain
++ manakai/t/ChangeLog	15 Nov 2005 14:18:08 -0000
2005-11-15  Wakaba  <wakaba@suika.fam.cx>

	* Makefile: Rules to make |dom-feature.t| and |dom-genericls.t|
	added.

++ manakai/bin/ChangeLog	15 Nov 2005 13:09:10 -0000
2005-11-15  Wakaba  <wakaba@suika.fam.cx>

	* dac2test.pl: Adds the module as |require|d module.

	* mkdisdump.pl: Requests |DOMLS:Generic| feature
	instead of obsoleted |DOMLS:LS| feature.

2005-11-13  Wakaba  <wakaba@suika.fam.cx>

	* dac2test.pl: New script.

++ manakai/lib/Message/Util/ChangeLog	15 Nov 2005 14:09:17 -0000
	* Makefile: Missing rule to make |Message/DOM/core.dae| added.

2005-11-15  Wakaba  <wakaba@suika.fam.cx>

++ manakai/lib/Message/Util/Error/ChangeLog	15 Nov 2005 14:17:04 -0000
2005-11-15  Wakaba  <wakaba@suika.fam.cx>

	* DOMException.dis (dx:Exception): Attributes copied
	from |ManakaiDOM:ManakaiDOMExceptionOrWarning|.

++ manakai/lib/Message/Util/DIS/ChangeLog	15 Nov 2005 14:16:32 -0000
	* Test.dis (assertNull, assertEquals, assertNotEquals,
	assertException): New methods.

2005-11-15  Wakaba  <wakaba@suika.fam.cx>

++ manakai/lib/Message/DOM/ChangeLog	15 Nov 2005 13:12:17 -0000
	* DOMFeature.dis (MinimumImplementation.eq): Added.

	* DOMMain.dis: |DISPerl:ISA| reference fixed.

	* Generic.dis: Implements new |DOMLS:Generic| feature.

2005-11-15  Wakaba  <wakaba@suika.fam.cx>

1 wakaba 1.1 #!/usr/bin/perl -w
2     use strict;
3    
4     =head1 NAME
5    
6     dac2pm - Generating Perl Module from "dac" File
7    
8     =head1 SYNOPSIS
9    
10     perl path/to/dac2pm.pl input.dac \
11     --module-uri=module-uri [--for=for-uri] [options] > ModuleName.pm
12     perl path/to/dac2pm.pl input.dac \
13     --module-uri=module-uri [--for=for-uri] [options] \
14     --output-file-path=ModuleName.pm
15     perl path/to/dac2pm.pl input.dac \
16     --create-perl-module="module-uri ModuleName.pm [for-uri]" \
17     [--create-perl-module="..." ...]
18     perl path/to/dac2pm.pl --help
19    
20     =head1 DESCRIPTION
21    
22     The C<dac2pm.pl> script generates Perl modules from a "dac" database file
23     created by C<dac.pl>.
24    
25     This script is part of manakai.
26    
27     =cut
28    
29     use strict;
30     use Message::Util::QName::Filter {
31     DIS => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#>,
32     dis => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/lang#dis-->,
33     ManakaiDOM => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/manakai-dom#>,
34     Markup => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Markup#>,
35     pc => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/PerlCode#>,
36     test => q<http://suika.fam.cx/~wakaba/archive/2004/dis/Test#>,
37     Util => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/>,
38     };
39    
40     =head1 OPTIONS
41    
42     =over 4
43    
44     =item --enable-assertion / --noenable-assertion (default)
45    
46     Whether assertion codes should be outputed or not.
47    
48     =item --create-perl-module="I<module-uri> I<ModuleName.pm> [I<for-uri>]" (Zero or more)
49    
50     The C<--create-perl-module> option can be used to specify
51     I<--module-uri>, I<--output-file-path>, and I<--for> options
52     once. Its value is a space-separated triplet of "dis" module name URI,
53     Perl module file path (environment dependent), and optional
54     "dis" module "for" URI.
55    
56     This option can be specified more than once; it would
57     make multiple Perl module files to be created. If
58     both I<--module-uri> and this options are specified,
59     I<--module-uri>, I<--output-file-path>, and I<--for>
60     options are treated as if there is another I<--create-perl-module>
61     option specified.
62    
63     =item --for=I<for-uri> (Optional)
64    
65     Specifies the "For" URI reference for which the outputed module is.
66     If this parameter is ommitted, the default "For" URI reference
67     for the module specified by the C<dis:DefaultFor> attribute
68     of the C<dis:Module> element, if any, or C<ManakaiDOM:all> is assumed.
69    
70     =item --help
71    
72     Shows the help message.
73    
74     =item --module-uri=I<module-uri>
75    
76     A URI reference that identifies a module from which a Perl
77     module file is generated. This argument is I<required>.
78    
79     =item --output-file-path=I<perl-module-file-path> (default: the standard output)
80    
81     A platform-dependent file path to which the Perl module
82     is written down.
83    
84     =item C<--output-line> / C<--nooutput-line> (default: C<--nooutput-line>)
85    
86     Whether C<#line> directives should be included to the generated
87     Perl module files.
88    
89     =item --verbose / --noverbose (default)
90    
91     Whether a verbose message mode should be selected or not.
92    
93     =back
94    
95     =cut
96    
97     use Getopt::Long;
98     use Pod::Usage;
99     my %Opt = (
100     create_module => [],
101     );
102     GetOptions (
103     'source-module=s' => sub {
104     shift;
105     push @{$Opt{create_module}}, [split /\s+/, shift, 3];
106     },
107     'dis-file-suffix=s' => \$Opt{dis_suffix},
108     'daem-file-suffix=s' => \$Opt{daem_suffix},
109     'debug' => \$Opt{debug},
110     'enable-assertion!' => \$Opt{outputAssertion},
111     'for=s' => \$Opt{For},
112     'help' => \$Opt{help},
113     'module-uri=s' => \$Opt{module_uri},
114     'output-file-path=s' => \$Opt{output_file_name},
115     'output-line' => \$Opt{output_line},
116     'search-path|I=s' => sub {
117     shift;
118     my @value = split /\s+/, shift;
119     while (my ($ns, $path) = splice @value, 0, 2, ()) {
120     unless (defined $path) {
121     die qq[$0: Search-path parameter without path: "$ns"];
122     }
123     push @{$Opt{input_search_path}->{$ns} ||= []}, $path;
124     }
125     },
126     'search-path-catalog-file-name=s' => sub {
127     shift;
128     require File::Spec;
129     my $path = my $path_base = shift;
130     $path_base =~ s#[^/]+$##;
131     $Opt{search_path_base} = $path_base;
132     open my $file, '<', $path or die "$0: $path: $!";
133     while (<$file>) {
134     if (s/^\s*\@//) { ## Processing instruction
135     my ($target, $data) = split /\s+/;
136     if ($target eq 'base') {
137     $Opt{search_path_base} = File::Spec->rel2abs ($data, $path_base);
138     } else {
139     die "$0: $target: Unknown target";
140     }
141     } elsif (/^\s*\#/) { ## Comment
142     #
143     } elsif (/\S/) { ## Catalog entry
144     s/^\s+//;
145     my ($ns, $path) = split /\s+/;
146     push @{$Opt{input_search_path}->{$ns} ||= []},
147     File::Spec->rel2abs ($path, $Opt{search_path_base});
148     }
149     }
150     ## NOTE: File paths with SPACEs are not supported
151     ## NOTE: Future version might use file: URI instead of file path.
152     },
153     'verbose!' => \$Opt{verbose},
154     ) or pod2usage (2);
155     pod2usage ({-exitval => 0, -verbose => 1}) if $Opt{help};
156     $Opt{file_name} = shift;
157     pod2usage ({-exitval => 2, -verbose => 0}) unless $Opt{file_name};
158     $Message::DOM::DOMFeature::DEBUG = 1 if $Opt{debug};
159     $Opt{daem_suffix} = '.daem' unless defined $Opt{daem_suffix};
160     $Opt{dis_suffix} = '.dis' unless defined $Opt{dis_suffix};
161    
162     if ($Opt{module_uri}) {
163     push @{$Opt{create_module}},
164     [$Opt{module_uri}, $Opt{output_file_name}, $Opt{For}];
165     }
166    
167     pod2usage (2) unless @{$Opt{create_module}};
168    
169     sub status_msg ($) {
170     my $s = shift;
171     $s .= "\n" unless $s =~ /\n$/;
172     print STDERR $s;
173     }
174    
175     sub status_msg_ ($) {
176     my $s = shift;
177     print STDERR $s;
178     }
179    
180     sub verbose_msg ($) {
181     my $s = shift;
182     $s .= "\n" unless $s =~ /\n$/;
183     print STDERR $s if $Opt{verbose};
184     }
185    
186     sub verbose_msg_ ($) {
187     my $s = shift;
188     print STDERR $s if $Opt{verbose};
189     }
190    
191     use Message::Util::DIS::DNLite;
192    
193     my $start_time;
194     BEGIN { $start_time = time }
195    
196     my $impl = $Message::DOM::ImplementationRegistry->get_implementation
197     ({
198     ExpandedURI q<ManakaiDOM:Minimum> => '3.0',
199     '+' . ExpandedURI q<DIS:Core> => '1.0',
200     '+' . ExpandedURI q<Util:PerlCode> => '1.0',
201     });
202     my $pc = $impl->get_feature (ExpandedURI q<Util:PerlCode> => '1.0');
203     my $di = $impl->get_feature (ExpandedURI q<DIS:Core> => '1.0');
204    
205     status_msg_ qq<Loading the database "$Opt{file_name}"...>;
206     my $db = $di->pl_load_dis_database ($Opt{file_name}, sub ($$) {
207     my ($db, $mod) = @_;
208     my $ns = $mod->namespace_uri;
209     my $ln = $mod->local_name;
210     verbose_msg qq<Database module <$ns$ln> is requested>;
211     my $name = dac_search_file_path_stem ($ns, $ln, $Opt{daem_suffix});
212     if (defined $name) {
213     return $name.$Opt{daem_suffix};
214     } else {
215     return $ln.$Opt{daem_suffix};
216     }
217     });
218     status_msg q<done>;
219    
220     for (@{$Opt{create_module}}) {
221     my ($mod_uri, $out_file_path, $mod_for) = @$_;
222    
223     my $mod = $db->get_module ($mod_uri, for_arg => $mod_for);
224     unless ($mod_for) {
225     $mod_for = $mod->get_property_text (ExpandedURI q<dis:DefaultFor>, undef);
226     if (defined $mod_for) {
227     $mod = $db->get_module ($mod_uri, for_arg => $mod_for);
228     }
229     }
230     unless ($mod->is_defined) {
231     die qq<$0: Module <$mod_uri> for <$mod_for> is not defined>;
232     }
233    
234     status_msg_ qq<Generating Perl test from <$mod_uri> for <$mod_for>...>;
235    
236     my $pl = $pc->create_perl_file;
237     my $pack = $pl->get_last_package ("Manakai::Test", make_new_package => 1);
238     $pack->add_use_perl_module_name ("Message::Util::DIS::Test");
239     $pack->add_use_perl_module_name ("Message::Util::Error");
240 wakaba 1.2 $pack->add_require_perl_module_name ($mod->pl_fully_qualified_name);
241 wakaba 1.1
242     $pl->source_file ($mod->get_property_text (ExpandedURI q<DIS:sourceFile>, ""));
243     $pl->source_module ($mod->name_uri);
244     $pl->source_for ($mod->for_uri);
245     $pl->license_uri ($mod->get_property_resource (ExpandedURI q<dis:License>)
246     ->uri);
247    
248     $pack->append_code
249     ($pc->create_perl_statement
250     ('my $impl = $Message::DOM::ImplementationRegistry->get_implementation ({
251     "http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#Test"
252     => "1.0",
253     })'));
254    
255     $pack->append_code
256     (my $num_statement = $pc->create_perl_statement
257     ('my $test = $impl->create_test_manager'));
258    
259     my $total_tests = 0;
260     my %processed;
261     for my $res (@{$mod->get_resource_list}) {
262     next if $res->owner_module ne $mod or $processed{$res->uri};
263     $processed{$res->uri} = 1;
264    
265     if ($res->is_type_uri (ExpandedURI q<test:Test>)) {
266     $total_tests++;
267     $pack->append_code ('$test->start_new_test (');
268     $pack->append_new_pc_literal ($res->name_uri || $res->uri);
269     $pack->append_code (');');
270    
271     $pack->append_code ('try {');
272    
273     my $test_pc = $res->pl_code_fragment;
274    
275     $pack->append_code_fragment ($test_pc);
276    
277     $pack->append_code ('$test->ok;');
278    
279     $pack->append_code ('} catch Message::Util::IF::DTException with {
280     ##
281     };');
282     }
283     }
284    
285     $num_statement->append_code (' (' . $total_tests . ')');
286    
287     status_msg qq<done>;
288    
289     my $output;
290     defined $out_file_path
291     ? (open $output, '>', $out_file_path or die "$0: $out_file_path: $!")
292     : ($output = \*STDOUT);
293    
294     if ($Opt{output_line}) {
295     $pl->owner_document->dom_config->set_parameter (ExpandedURI q<pc:line> => 1);
296     }
297    
298     status_msg_ sprintf qq<Writing Perl test script %s...>,
299     defined $out_file_path
300     ? q<">.$out_file_path.q<">
301     : 'to stdout';
302     print $output $pl->stringify;
303     close $output;
304     status_msg q<done>;
305     } # create_module
306    
307     status_msg_ "Checking undefined resources...";
308     $db->check_undefined_resource;
309     status_msg q<done>;
310    
311     status_msg_ "Closing the database...";
312     $db->free;
313     undef $db;
314     status_msg q<done>;
315    
316     END {
317     use integer;
318     my $time = time - $start_time;
319     status_msg sprintf qq<%d'%02d''>, $time / 60, $time % 60;
320     }
321     exit;
322    
323     sub dac_search_file_path_stem ($$$) {
324     my ($ns, $ln, $suffix) = @_;
325     require Cwd;
326     require File::Spec;
327     for my $dir ('.', @{$Opt{input_search_path}->{$ns}||[]}) {
328     my $name = Cwd::abs_path
329     (File::Spec->canonpath
330     (File::Spec->catfile ($dir, $ln)));
331     if (-f $name.$suffix) {
332     return $name;
333     }
334     }
335     return undef;
336     } # dac_search_file_path_stem;
337    
338     =head1 SEE ALSO
339    
340     L<lib/Message/Util/DIS.dis> - The <QUOTE::dis> object implementation.
341    
342     L<lib/Message/Util/DIS/Perl.dis> - The <QUOTE::dis> object implementation,
343     submodule for Perl modules.
344    
345     L<lib/Message/Util/PerlCode.dis> - The Perl code generator.
346    
347     L<lib/manakai/DISCore.dis> - The definition for the "dis" format.
348    
349     L<lib/manakai/DISPerl.dis> - The definition for the "dis" Perl-specific
350     vocabulary.
351    
352     L<bin/dac.pl> - The "dac" database generator.
353    
354     =head1 LICENSE
355    
356     Copyright 2004-2005 Wakaba <w@suika.fam.cx>. All rights reserved.
357    
358     This program is free software; you can redistribute it and/or
359     modify it under the same terms as Perl itself.
360    
361     =cut
362    
363 wakaba 1.2 1; # $Date: 2005/11/15 03:12:55 $

admin@suikawiki.org
ViewVC Help
Powered by ViewVC 1.1.24