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::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/11/23 11:21:09 $
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::DOM::GenericLS;
200
201	my $start_time;
202	BEGIN { $start_time = time }
203
204	my $impl = $Message::DOM::ImplementationRegistry->get_implementation
205	({
206	ExpandedURI q<ManakaiDOM:Minimum> => '3.0',
207	'+' . ExpandedURI q<DIS:Core> => '1.0',
208	'+' . ExpandedURI q<Util:PerlCode> => '1.0',
209	'+' . ExpandedURI q<DOMLS:Generic> => '3.0',
210	});
211	my $pc = $impl->get_feature (ExpandedURI q<Util:PerlCode> => '1.0');
212	my $di = $impl->get_feature (ExpandedURI q<DIS:Core> => '1.0');
213
214	status_msg_ qq<Loading the database "$Opt{file_name}"...>;
215	my $db = $di->pl_load_dis_database ($Opt{file_name}, sub ($$) {
216	my ($db, $mod) = @_;
217	my $ns = $mod->namespace_uri;
218	my $ln = $mod->local_name;
219	verbose_msg qq<Database module <$ns$ln> is requested>;
220	my $name = dac_search_file_path_stem ($ns, $ln, $Opt{daem_suffix});
221	if (defined $name) {
222	return $name.$Opt{daem_suffix};
223	} else {
224	return $ln.$Opt{daem_suffix};
225	}
226	});
227	status_msg q<done>;
228
229	for (@{$Opt{create_module}}) {
230	my ($mod_uri, $out_file_path, $mod_for) = @$_;
231
232	my $mod = $db->get_module ($mod_uri, for_arg => $mod_for);
233	unless ($mod_for) {
234	$mod_for = $mod->get_property_text (ExpandedURI q<dis:DefaultFor>, undef);
235	if (defined $mod_for) {
236	$mod = $db->get_module ($mod_uri, for_arg => $mod_for);
237	}
238	}
239	unless ($mod->is_defined) {
240	die qq<$0: Module <$mod_uri> for <$mod_for> is not defined>;
241	}
242
243	status_msg_ qq<Generating Perl module from <$mod_uri> for <$mod_for>...>;
244	my $pl = $mod->pl_generate_perl_module_file;
245	status_msg qq<done>;
246
247	my $output;
248	defined $out_file_path
249	? (open $output, '>', $out_file_path or die "$0: $out_file_path: $!")
250	: ($output = \*STDOUT);
251
252	if ($Opt{output_line}) {
253	$pl->owner_document->dom_config->set_parameter (ExpandedURI q<pc:line> => 1);
254	}
255
256	status_msg_ sprintf qq<Writing Perl module %s...>,
257	defined $out_file_path
258	? q<">.$out_file_path.q<">
259	: 'to stdout';
260	print $output $pl->stringify;
261	close $output;
262	status_msg q<done>;
263	} # create_module
264
265	status_msg_ "Checking undefined resources...";
266	$db->check_undefined_resource;
267	status_msg q<done>;
268
269	status_msg_ "Closing the database...";
270	$db->free;
271	undef $db;
272	status_msg q<done>;
273
274	END {
275	use integer;
276	my $time = time - $start_time;
277	status_msg sprintf qq<%d'%02d''>, $time / 60, $time % 60;
278	}
279	exit;
280
281	sub dac_search_file_path_stem ($$$) {
282	my ($ns, $ln, $suffix) = @_;
283	require Cwd;
284	require File::Spec;
285	for my $dir ('.', @{$Opt{input_search_path}->{$ns}\|\|[]}) {
286	my $name = Cwd::abs_path
287	(File::Spec->canonpath
288	(File::Spec->catfile ($dir, $ln)));
289	if (-f $name.$suffix) {
290	return $name;
291	}
292	}
293	return undef;
294	} # dac_search_file_path_stem;
295
296	=head1 SEE ALSO
297
298	L<lib/Message/Util/DIS.dis> - The <QUOTE::dis> object implementation.
299
300	L<lib/Message/Util/DIS/Perl.dis> - The <QUOTE::dis> object implementation,
301	submodule for Perl modules.
302
303	L<lib/Message/Util/PerlCode.dis> - The Perl code generator.
304
305	L<lib/manakai/DISCore.dis> - The definition for the "dis" format.
306
307	L<lib/manakai/DISPerl.dis> - The definition for the "dis" Perl-specific
308	vocabulary.
309
310	L<bin/dac.pl> - The "dac" database generator.
311
312	=head1 LICENSE
313
314	Copyright 2004-2005 Wakaba <w@suika.fam.cx>. All rights reserved.
315
316	This program is free software; you can redistribute it and/or
317	modify it under the same terms as Perl itself.
318
319	=cut
320
321	1; # $Date: 2005/11/23 11:21:09 $