manakai/bin/dac2pm.pl

#!/usr/bin/perl -w 
use strict;

=head1 NAME

dac2pm - Generating Perl Module from "dac" File

=head1 SYNOPSIS

  perl path/to/dac2pm.pl input.dac \
            --module-uri=module-uri [--for=for-uri] [options] > ModuleName.pm
  perl path/to/dac2pm.pl input.dac \
            --module-uri=module-uri [--for=for-uri] [options] \
            --output-file-path=ModuleName.pm
  perl path/to/dac2pm.pl input.dac \
            --create-perl-module="module-uri ModuleName.pm [for-uri]" \
            [--create-perl-module="..." ...]
  perl path/to/dac2pm.pl --help

=head1 DESCRIPTION

The C<dac2pm.pl> script generates Perl modules from a "dac" database file
created by C<dac.pl>.

This script is part of manakai. 

=cut

use strict;
use Message::Util::QName::Filter {
  DIS => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/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#>,
  ManakaiDOM => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/manakai-dom#>,
  Markup => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Markup#>,
  pc => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/PerlCode#>,
  Util => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/>,
};

=head1 OPTIONS

=over 4

=item --enable-assertion / --noenable-assertion (default)

Whether assertion codes should be outputed or not. 

=item --create-perl-module="I<module-uri> I<ModuleName.pm> [I<for-uri>]" (Zero or more)

The C<--create-perl-module> option can be used to specify
I<--module-uri>, I<--output-file-path>, and I<--for> options
once.  Its value is a space-separated triplet of "dis" module name URI,
Perl module file path (environment dependent), and optional
"dis" module "for" URI.

This option can be specified more than once; it would
make multiple Perl module files to be created.  If 
both I<--module-uri> and this options are specified,
I<--module-uri>, I<--output-file-path>, and I<--for>
options are treated as if there is another I<--create-perl-module>
option specified.

=item --for=I<for-uri> (Optional)

Specifies the "For" URI reference for which the outputed module is. 
If this parameter is ommitted, the default "For" URI reference 
for the module specified by the C<dis:DefaultFor> attribute
of the C<dis:Module> element, if any, or C<ManakaiDOM:all> is assumed. 

=item --help

Shows the help message. 

=item --module-uri=I<module-uri>

A URI reference that identifies a module from which a Perl
module file is generated.  This argument is I<required>.

=item --output-file-path=I<perl-module-file-path> (default: the standard output)

A platform-dependent file path to which the Perl module
is written down.

=item C<--output-line> / C<--nooutput-line> (default: C<--nooutput-line>)

Whether C<#line> directives should be included to the generated
Perl module files.

=item --verbose / --noverbose (default)

Whether a verbose message mode should be selected or not. 

=back

=cut

use Getopt::Long;
use Pod::Usage;
my %Opt = (
  create_module => [],
);
GetOptions (
  'create-perl-module=s' => sub {
    shift;
    push @{$Opt{create_module}}, [split /\s+/, shift, 3];
  },
  'dis-file-suffix=s' => \$Opt{dis_suffix},
  'daem-file-suffix=s' => \$Opt{daem_suffix},
  'debug' => \$Opt{debug},
  'enable-assertion!' => \$Opt{outputAssertion},
  'for=s' => \$Opt{For},
  'help' => \$Opt{help},
  'module-uri=s' => \$Opt{module_uri},
  'output-file-path=s' => \$Opt{output_file_name},
  'output-line' => \$Opt{output_line},
  'search-path|I=s' => sub {
    shift;
    my @value = split /\s+/, shift;
    while (my ($ns, $path) = splice @value, 0, 2, ()) {
      unless (defined $path) {
        die qq[$0: Search-path parameter without path: "$ns"];
      }
      push @{$Opt{input_search_path}->{$ns} ||= []}, $path;
    }
  },
  'search-path-catalog-file-name=s' => sub {
    shift;
    require File::Spec;
    my $path = my $path_base = shift;
    $path_base =~ s#[^/]+$##;
    $Opt{search_path_base} = $path_base;
    open my $file, '<', $path or die "$0: $path: $!";
    while (<$file>) {
      if (s/^\s*\@//) {     ## Processing instruction
        my ($target, $data) = split /\s+/;
        if ($target eq 'base') {
          $Opt{search_path_base} = File::Spec->rel2abs ($data, $path_base);
        } else {
          die "$0: $target: Unknown target";
        }
      } elsif (/^\s*\#/) {  ## Comment
        #
      } elsif (/\S/) {      ## Catalog entry
        s/^\s+//;
        my ($ns, $path) = split /\s+/;
        push @{$Opt{input_search_path}->{$ns} ||= []},
             File::Spec->rel2abs ($path, $Opt{search_path_base});
      }
    }
    ## NOTE: File paths with SPACEs are not supported
    ## NOTE: Future version might use file: URI instead of file path.
  },
  'verbose!' => \$Opt{verbose},
) or pod2usage (2);
pod2usage ({-exitval => 0, -verbose => 1}) if $Opt{help};
$Opt{file_name} = shift;
pod2usage ({-exitval => 2, -verbose => 0}) unless $Opt{file_name};

$Message::DOM::DOMFeature::DEBUG = 1 if $Opt{debug};
require Error;
$Error::Debug = 1 if $Opt{debug};
$Message::Util::Error::VERBOSE = 1 if $Opt{verbose};

$Opt{daem_suffix} = '.daem' unless defined $Opt{daem_suffix};
$Opt{dis_suffix} = '.dis' unless defined $Opt{dis_suffix};

if ($Opt{module_uri}) {
  push @{$Opt{create_module}},
       [$Opt{module_uri}, $Opt{output_file_name}, $Opt{For}];
}

pod2usage (2) unless @{$Opt{create_module}};

sub status_msg ($) {
  my $s = shift;
  $s .= "\n" unless $s =~ /\n$/;
  print STDERR $s;
}

sub status_msg_ ($) {
  my $s = shift;
  print STDERR $s;
}

sub verbose_msg ($) {
  my $s = shift;
  $s .= "\n" unless $s =~ /\n$/;
  print STDERR $s if $Opt{verbose};
}

sub verbose_msg_ ($) {
  my $s = shift;
  print STDERR $s if $Opt{verbose};
}

## TODO: Assertion control

use Message::Util::DIS::DNLite;
use Message::Util::DIS::DPG;
use Message::DOM::GenericLS;

my $start_time;
BEGIN { $start_time = time }

my $impl = $Message::DOM::ImplementationRegistry->get_implementation
               ({
                 ExpandedURI q<ManakaiDOM:Minimum> => '3.0',
                 '+' . ExpandedURI q<DIS:Core> => '1.0',
                 '+' . ExpandedURI q<Util:PerlCode> => '1.0',
                 '+' . ExpandedURI q<DOMLS:Generic> => '3.0',
                });
my $pc = $impl->get_feature (ExpandedURI q<Util:PerlCode> => '1.0');
my $di = $impl->get_feature (ExpandedURI q<DIS:Core> => '1.0');

  status_msg_ qq<Loading the database "$Opt{file_name}"...>;
  my $db = $di->pl_load_dis_database ($Opt{file_name}, sub ($$) {
    my ($db, $mod) = @_;
    my $ns = $mod->namespace_uri;
    my $ln = $mod->local_name;
    verbose_msg qq<Database module <$ns$ln> is requested>;
    my $name = dac_search_file_path_stem ($ns, $ln, $Opt{daem_suffix});
    if (defined $name) {
      return $name.$Opt{daem_suffix};
    } else {
      return $ln.$Opt{daem_suffix};
    }
  });
  status_msg q<done>;

for (@{$Opt{create_module}}) {
  my ($mod_uri, $out_file_path, $mod_for) = @$_;
  
  my $mod = $db->get_module ($mod_uri, for_arg => $mod_for);
  unless ($mod_for) {
    $mod_for = $mod->get_property_text (ExpandedURI q<dis:DefaultFor>, undef);
    if (defined $mod_for) {
      $mod = $db->get_module ($mod_uri, for_arg => $mod_for);
    }
  }
  unless ($mod->is_defined) {
    die qq<$0: Module <$mod_uri> for <$mod_for> is not defined>;
  }

  status_msg_ qq<Generating Perl module from <$mod_uri> for <$mod_for>...>;
  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);

  if ($Opt{output_line}) {
    $pl->owner_document->dom_config->set_parameter (ExpandedURI q<pc:line> => 1);
  }
  
  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>;
} # create_module

status_msg_ "Checking undefined resources...";
$db->check_undefined_resource;
status_msg q<done>;

status_msg_ "Closing the database...";
$db->free;
undef $db;
status_msg q<done>;

END {
  use integer;
  my $time = time - $start_time;
  status_msg sprintf qq<%d'%02d''>, $time / 60, $time % 60;
}
exit;

sub dac_search_file_path_stem ($$$) {
  my ($ns, $ln, $suffix) = @_;
  require Cwd;
  require File::Spec;
  for my $dir ('.', @{$Opt{input_search_path}->{$ns}||[]}) {
    my $name = Cwd::abs_path
        (File::Spec->canonpath
         (File::Spec->catfile ($dir, $ln)));
    if (-f $name.$suffix) {
      return $name;
    }
  }
  return undef;
} # dac_search_file_path_stem;

=head1 SEE ALSO

L<lib/Message/Util/DIS.dis> - The <QUOTE::dis> object implementation.

L<lib/Message/Util/DIS/Perl.dis> - The <QUOTE::dis> object implementation,
submodule for Perl modules.

L<lib/Message/Util/PerlCode.dis> - The Perl code generator.

L<lib/manakai/DISCore.dis> - The definition for the "dis" format. 

L<lib/manakai/DISPerl.dis> - The definition for the "dis" Perl-specific 
vocabulary. 

L<bin/dac.pl> - The "dac" database generator.

=head1 LICENSE

Copyright 2004-2005 Wakaba <w@suika.fam.cx>.  All rights reserved.

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

1; # $Date: 2005/12/20 12:16:49 $
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	DOMLS => q<http://suika.fam.cx/~wakaba/archive/2004/dom/ls#>,
34	ManakaiDOM => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/manakai-dom#>,
35	Markup => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Markup#>,
36	pc => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/PerlCode#>,
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	'create-perl-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
159	$Message::DOM::DOMFeature::DEBUG = 1 if $Opt{debug};
160	require Error;
161	$Error::Debug = 1 if $Opt{debug};
162	$Message::Util::Error::VERBOSE = 1 if $Opt{verbose};
163
164	$Opt{daem_suffix} = '.daem' unless defined $Opt{daem_suffix};
165	$Opt{dis_suffix} = '.dis' unless defined $Opt{dis_suffix};
166
167	if ($Opt{module_uri}) {
168	push @{$Opt{create_module}},
169	[$Opt{module_uri}, $Opt{output_file_name}, $Opt{For}];
170	}
171
172	pod2usage (2) unless @{$Opt{create_module}};
173
174	sub status_msg ($) {
175	my $s = shift;
176	$s .= "\n" unless $s =~ /\n$/;
177	print STDERR $s;
178	}
179
180	sub status_msg_ ($) {
181	my $s = shift;
182	print STDERR $s;
183	}
184
185	sub verbose_msg ($) {
186	my $s = shift;
187	$s .= "\n" unless $s =~ /\n$/;
188	print STDERR $s if $Opt{verbose};
189	}
190
191	sub verbose_msg_ ($) {
192	my $s = shift;
193	print STDERR $s if $Opt{verbose};
194	}
195
196	## TODO: Assertion control
197
198	use Message::Util::DIS::DNLite;
199	use Message::Util::DIS::DPG;
200	use Message::DOM::GenericLS;
201
202	my $start_time;
203	BEGIN { $start_time = time }
204
205	my $impl = $Message::DOM::ImplementationRegistry->get_implementation
206	({
207	ExpandedURI q<ManakaiDOM:Minimum> => '3.0',
208	'+' . ExpandedURI q<DIS:Core> => '1.0',
209	'+' . ExpandedURI q<Util:PerlCode> => '1.0',
210	'+' . ExpandedURI q<DOMLS:Generic> => '3.0',
211	});
212	my $pc = $impl->get_feature (ExpandedURI q<Util:PerlCode> => '1.0');
213	my $di = $impl->get_feature (ExpandedURI q<DIS:Core> => '1.0');
214
215	status_msg_ qq<Loading the database "$Opt{file_name}"...>;
216	my $db = $di->pl_load_dis_database ($Opt{file_name}, sub ($$) {
217	my ($db, $mod) = @_;
218	my $ns = $mod->namespace_uri;
219	my $ln = $mod->local_name;
220	verbose_msg qq<Database module <$ns$ln> is requested>;
221	my $name = dac_search_file_path_stem ($ns, $ln, $Opt{daem_suffix});
222	if (defined $name) {
223	return $name.$Opt{daem_suffix};
224	} else {
225	return $ln.$Opt{daem_suffix};
226	}
227	});
228	status_msg q<done>;
229
230	for (@{$Opt{create_module}}) {
231	my ($mod_uri, $out_file_path, $mod_for) = @$_;
232
233	my $mod = $db->get_module ($mod_uri, for_arg => $mod_for);
234	unless ($mod_for) {
235	$mod_for = $mod->get_property_text (ExpandedURI q<dis:DefaultFor>, undef);
236	if (defined $mod_for) {
237	$mod = $db->get_module ($mod_uri, for_arg => $mod_for);
238	}
239	}
240	unless ($mod->is_defined) {
241	die qq<$0: Module <$mod_uri> for <$mod_for> is not defined>;
242	}
243
244	status_msg_ qq<Generating Perl module from <$mod_uri> for <$mod_for>...>;
245	my $pl = $mod->pl_generate_perl_module_file;
246	status_msg qq<done>;
247
248	my $output;
249	defined $out_file_path
250	? (open $output, '>', $out_file_path or die "$0: $out_file_path: $!")
251	: ($output = \*STDOUT);
252
253	if ($Opt{output_line}) {
254	$pl->owner_document->dom_config->set_parameter (ExpandedURI q<pc:line> => 1);
255	}
256
257	status_msg_ sprintf qq<Writing Perl module %s...>,
258	defined $out_file_path
259	? q<">.$out_file_path.q<">
260	: 'to stdout';
261	print $output $pl->stringify;
262	close $output;
263	status_msg q<done>;
264	} # create_module
265
266	status_msg_ "Checking undefined resources...";
267	$db->check_undefined_resource;
268	status_msg q<done>;
269
270	status_msg_ "Closing the database...";
271	$db->free;
272	undef $db;
273	status_msg q<done>;
274
275	END {
276	use integer;
277	my $time = time - $start_time;
278	status_msg sprintf qq<%d'%02d''>, $time / 60, $time % 60;
279	}
280	exit;
281
282	sub dac_search_file_path_stem ($$$) {
283	my ($ns, $ln, $suffix) = @_;
284	require Cwd;
285	require File::Spec;
286	for my $dir ('.', @{$Opt{input_search_path}->{$ns}\|\|[]}) {
287	my $name = Cwd::abs_path
288	(File::Spec->canonpath
289	(File::Spec->catfile ($dir, $ln)));
290	if (-f $name.$suffix) {
291	return $name;
292	}
293	}
294	return undef;
295	} # dac_search_file_path_stem;
296
297	=head1 SEE ALSO
298
299	L<lib/Message/Util/DIS.dis> - The <QUOTE::dis> object implementation.
300
301	L<lib/Message/Util/DIS/Perl.dis> - The <QUOTE::dis> object implementation,
302	submodule for Perl modules.
303
304	L<lib/Message/Util/PerlCode.dis> - The Perl code generator.
305
306	L<lib/manakai/DISCore.dis> - The definition for the "dis" format.
307
308	L<lib/manakai/DISPerl.dis> - The definition for the "dis" Perl-specific
309	vocabulary.
310
311	L<bin/dac.pl> - The "dac" database generator.
312
313	=head1 LICENSE
314
315	Copyright 2004-2005 Wakaba <w@suika.fam.cx>. All rights reserved.
316
317	This program is free software; you can redistribute it and/or
318	modify it under the same terms as Perl itself.
319
320	=cut
321
322	1; # $Date: 2005/12/20 12:16:49 $