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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide annotations) (download)
Wed Nov 16 10:07:11 2005 UTC (19 years ago) by wakaba
Branch: MAIN
Changes since 1.2: +4 -1 lines
File MIME type: text/plain
++ manakai/t/ChangeLog	16 Nov 2005 10:07:00 -0000
2005-11-16  Wakaba  <wakaba@suika.fam.cx>

	* Makefile: Rules to make |dom-mdomls2003.t| and |util-perlcode.t|
	added.

++ manakai/bin/ChangeLog	16 Nov 2005 09:50:31 -0000
2005-11-16  Wakaba  <wakaba@suika.fam.cx>

	* dac2text.pl: Dies if test code is not defined.

++ manakai/lib/Message/Markup/XML/ChangeLog	16 Nov 2005 09:59:26 -0000
2005-11-16  Wakaba  <wakaba@suika.fam.cx>

	* Parser.pm: A typo fix and |undef|-checking added.

++ manakai/lib/Message/Util/ChangeLog	16 Nov 2005 10:02:10 -0000
2005-11-16  Wakaba  <wakaba@suika.fam.cx>

	* PerlCode.dis: A test code added.  Typos in |ISA|
	properties fixed.
	(PerlSub.stringify): Generates prototype specification
	even if |prototype| attribute value's length is zero
	in case the |pc:prototype| attribute /is/ found.

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

	* Test.dis (assertTrue, assertFalse, assertNever): New methods.
	(assertNull, assertNotNull): The |actualValue| parameters
	fixed to parameters rather than named parameters.

++ manakai/lib/Message/DOM/ChangeLog	16 Nov 2005 09:58:21 -0000
2005-11-16  Wakaba  <wakaba@suika.fam.cx>

	* ManakaiDOMLS2003.dis: Tests added.
	(domConfig): Method name in the code fixed to |flag|.

	* DOMMain.dis (findOffset32): Missing |^| in regular expressions
	added.

	* DOMCore.dis (hasChildNodes): Returns |false| if the node type
	is defined not to have any children.
	(CharacterData): Typos in element type names and function names fixed.

++ manakai/lib/manakai/ChangeLog	16 Nov 2005 10:06:30 -0000
2005-11-16  Wakaba  <wakaba@suika.fam.cx>

	* domtest.pl (skip_rest): Exits test after generating comments.
	(assertEqualsCollection): Array reference dereferencing
	syntax fixed (it was mistakenly coded in JavaScript like style).

	* DISPerl.dis (StringRef): Don't |weaken| reference if
	there is already a weak reference.

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 wakaba 1.3 if (not defined $test_pc) {
275     die "Perl test code not defined for <".$res->uri.">";
276     }
277 wakaba 1.1
278     $pack->append_code_fragment ($test_pc);
279    
280     $pack->append_code ('$test->ok;');
281    
282     $pack->append_code ('} catch Message::Util::IF::DTException with {
283     ##
284     };');
285     }
286     }
287    
288     $num_statement->append_code (' (' . $total_tests . ')');
289    
290     status_msg qq<done>;
291    
292     my $output;
293     defined $out_file_path
294     ? (open $output, '>', $out_file_path or die "$0: $out_file_path: $!")
295     : ($output = \*STDOUT);
296    
297     if ($Opt{output_line}) {
298     $pl->owner_document->dom_config->set_parameter (ExpandedURI q<pc:line> => 1);
299     }
300    
301     status_msg_ sprintf qq<Writing Perl test script %s...>,
302     defined $out_file_path
303     ? q<">.$out_file_path.q<">
304     : 'to stdout';
305     print $output $pl->stringify;
306     close $output;
307     status_msg q<done>;
308     } # create_module
309    
310     status_msg_ "Checking undefined resources...";
311     $db->check_undefined_resource;
312     status_msg q<done>;
313    
314     status_msg_ "Closing the database...";
315     $db->free;
316     undef $db;
317     status_msg q<done>;
318    
319     END {
320     use integer;
321     my $time = time - $start_time;
322     status_msg sprintf qq<%d'%02d''>, $time / 60, $time % 60;
323     }
324     exit;
325    
326     sub dac_search_file_path_stem ($$$) {
327     my ($ns, $ln, $suffix) = @_;
328     require Cwd;
329     require File::Spec;
330     for my $dir ('.', @{$Opt{input_search_path}->{$ns}||[]}) {
331     my $name = Cwd::abs_path
332     (File::Spec->canonpath
333     (File::Spec->catfile ($dir, $ln)));
334     if (-f $name.$suffix) {
335     return $name;
336     }
337     }
338     return undef;
339     } # dac_search_file_path_stem;
340    
341     =head1 SEE ALSO
342    
343     L<lib/Message/Util/DIS.dis> - The <QUOTE::dis> object implementation.
344    
345     L<lib/Message/Util/DIS/Perl.dis> - The <QUOTE::dis> object implementation,
346     submodule for Perl modules.
347    
348     L<lib/Message/Util/PerlCode.dis> - The Perl code generator.
349    
350     L<lib/manakai/DISCore.dis> - The definition for the "dis" format.
351    
352     L<lib/manakai/DISPerl.dis> - The definition for the "dis" Perl-specific
353     vocabulary.
354    
355     L<bin/dac.pl> - The "dac" database generator.
356    
357     =head1 LICENSE
358    
359     Copyright 2004-2005 Wakaba <w@suika.fam.cx>. All rights reserved.
360    
361     This program is free software; you can redistribute it and/or
362     modify it under the same terms as Perl itself.
363    
364     =cut
365    
366 wakaba 1.3 1; # $Date: 2005/11/15 14:18:23 $

admin@suikawiki.org
ViewVC Help
Powered by ViewVC 1.1.24