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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (hide annotations) (download)
Tue Nov 15 03:12:55 2005 UTC (19 years ago) by wakaba
Branch: MAIN
File MIME type: text/plain
++ manakai/lib/Message/Util/ChangeLog	15 Nov 2005 03:09:25 -0000
2005-11-15  Wakaba  <wakaba@suika.fam.cx>

	* Makefile: Rules to make |DIS/Test.pm| added. |DIS/common.dis| rules
	added.

	* DIS.dis (DIS:): Removed (moved to |DIS/common.dis|).

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

	* PerlCode.dis (PCList, PCArrayRefLiteral, PCHashRefLiteral):
	New interfaces.
	(createPCLiteral, appendNewPCLiteral): New methods.
	(PCDocument): New interface.
	(factory methods): Namespace URI and local name of document
	element arguments added to |createDocument| to obtain
	an instance of |PCDocument|.

++ manakai/lib/Message/Util/DIS/ChangeLog	15 Nov 2005 03:11:47 -0000
2005-11-15  Wakaba  <wakaba@suika.fam.cx>

	* DISDoc.dis, DISDump.dis, DISPerl.dis (Require): References
	new |common.dis| module for the sake of |DIS:| module group.

	* common.dis: New module.

	* DISPerl.dis (plCodeFragment): Throws an exception
	if a "ISA" package does not have Perl name.

	* Value.dis: Type name |dis:TypeQName| changed to |DISCore:QName|.

++ manakai/lib/Message/DOM/ChangeLog	15 Nov 2005 03:09:45 -0000
2005-11-15  Wakaba  <wakaba@suika.fam.cx>

	* DOMFeature.dis (stringifyFeatures): Don't double |SPACE|
	characters between feature names and versions.

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

	* DOMFeature.dis (stringifyFeatures): A test code added.

++ manakai/lib/manakai/ChangeLog	15 Nov 2005 03:12:39 -0000
	* Test.dis: New module.

	* Makefile: |Test.dis| added.

2005-11-13  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    
241     $pl->source_file ($mod->get_property_text (ExpandedURI q<DIS:sourceFile>, ""));
242     $pl->source_module ($mod->name_uri);
243     $pl->source_for ($mod->for_uri);
244     $pl->license_uri ($mod->get_property_resource (ExpandedURI q<dis:License>)
245     ->uri);
246    
247     $pack->append_code
248     ($pc->create_perl_statement
249     ('my $impl = $Message::DOM::ImplementationRegistry->get_implementation ({
250     "http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#Test"
251     => "1.0",
252     })'));
253    
254     $pack->append_code
255     (my $num_statement = $pc->create_perl_statement
256     ('my $test = $impl->create_test_manager'));
257    
258     my $total_tests = 0;
259     my %processed;
260     for my $res (@{$mod->get_resource_list}) {
261     next if $res->owner_module ne $mod or $processed{$res->uri};
262     $processed{$res->uri} = 1;
263    
264     if ($res->is_type_uri (ExpandedURI q<test:Test>)) {
265     $total_tests++;
266     $pack->append_code ('$test->start_new_test (');
267     $pack->append_new_pc_literal ($res->name_uri || $res->uri);
268     $pack->append_code (');');
269    
270     $pack->append_code ('try {');
271    
272     my $test_pc = $res->pl_code_fragment;
273    
274     $pack->append_code_fragment ($test_pc);
275    
276     $pack->append_code ('$test->ok;');
277    
278     $pack->append_code ('} catch Message::Util::IF::DTException with {
279     ##
280     };');
281     }
282     }
283    
284     $num_statement->append_code (' (' . $total_tests . ')');
285    
286     status_msg qq<done>;
287    
288     my $output;
289     defined $out_file_path
290     ? (open $output, '>', $out_file_path or die "$0: $out_file_path: $!")
291     : ($output = \*STDOUT);
292    
293     if ($Opt{output_line}) {
294     $pl->owner_document->dom_config->set_parameter (ExpandedURI q<pc:line> => 1);
295     }
296    
297     status_msg_ sprintf qq<Writing Perl test script %s...>,
298     defined $out_file_path
299     ? q<">.$out_file_path.q<">
300     : 'to stdout';
301     print $output $pl->stringify;
302     close $output;
303     status_msg q<done>;
304     } # create_module
305    
306     status_msg_ "Checking undefined resources...";
307     $db->check_undefined_resource;
308     status_msg q<done>;
309    
310     status_msg_ "Closing the database...";
311     $db->free;
312     undef $db;
313     status_msg q<done>;
314    
315     END {
316     use integer;
317     my $time = time - $start_time;
318     status_msg sprintf qq<%d'%02d''>, $time / 60, $time % 60;
319     }
320     exit;
321    
322     sub dac_search_file_path_stem ($$$) {
323     my ($ns, $ln, $suffix) = @_;
324     require Cwd;
325     require File::Spec;
326     for my $dir ('.', @{$Opt{input_search_path}->{$ns}||[]}) {
327     my $name = Cwd::abs_path
328     (File::Spec->canonpath
329     (File::Spec->catfile ($dir, $ln)));
330     if (-f $name.$suffix) {
331     return $name;
332     }
333     }
334     return undef;
335     } # dac_search_file_path_stem;
336    
337     =head1 SEE ALSO
338    
339     L<lib/Message/Util/DIS.dis> - The <QUOTE::dis> object implementation.
340    
341     L<lib/Message/Util/DIS/Perl.dis> - The <QUOTE::dis> object implementation,
342     submodule for Perl modules.
343    
344     L<lib/Message/Util/PerlCode.dis> - The Perl code generator.
345    
346     L<lib/manakai/DISCore.dis> - The definition for the "dis" format.
347    
348     L<lib/manakai/DISPerl.dis> - The definition for the "dis" Perl-specific
349     vocabulary.
350    
351     L<bin/dac.pl> - The "dac" database generator.
352    
353     =head1 LICENSE
354    
355     Copyright 2004-2005 Wakaba <w@suika.fam.cx>. All rights reserved.
356    
357     This program is free software; you can redistribute it and/or
358     modify it under the same terms as Perl itself.
359    
360     =cut
361    
362     1; # $Date: 2005/10/16 06:08:22 $

admin@suikawiki.org
ViewVC Help
Powered by ViewVC 1.1.24