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},
  'dafx-file-suffix=s' => \$Opt{dummy1},
  '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-2006 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: 2006/02/25 16:49:55 $
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	'dafx-file-suffix=s' => \$Opt{dummy1},
110	'debug' => \$Opt{debug},
111	'enable-assertion!' => \$Opt{outputAssertion},
112	'for=s' => \$Opt{For},
113	'help' => \$Opt{help},
114	'module-uri=s' => \$Opt{module_uri},
115	'output-file-path=s' => \$Opt{output_file_name},
116	'output-line' => \$Opt{output_line},
117	'search-path\|I=s' => sub {
118	shift;
119	my @value = split /\s+/, shift;
120	while (my ($ns, $path) = splice @value, 0, 2, ()) {
121	unless (defined $path) {
122	die qq[$0: Search-path parameter without path: "$ns"];
123	}
124	push @{$Opt{input_search_path}->{$ns} \|\|= []}, $path;
125	}
126	},
127	'search-path-catalog-file-name=s' => sub {
128	shift;
129	require File::Spec;
130	my $path = my $path_base = shift;
131	$path_base =~ s#[^/]+$##;
132	$Opt{search_path_base} = $path_base;
133	open my $file, '<', $path or die "$0: $path: $!";
134	while (<$file>) {
135	if (s/^\s*\@//) { ## Processing instruction
136	my ($target, $data) = split /\s+/;
137	if ($target eq 'base') {
138	$Opt{search_path_base} = File::Spec->rel2abs ($data, $path_base);
139	} else {
140	die "$0: $target: Unknown target";
141	}
142	} elsif (/^\s*\#/) { ## Comment
143	#
144	} elsif (/\S/) { ## Catalog entry
145	s/^\s+//;
146	my ($ns, $path) = split /\s+/;
147	push @{$Opt{input_search_path}->{$ns} \|\|= []},
148	File::Spec->rel2abs ($path, $Opt{search_path_base});
149	}
150	}
151	## NOTE: File paths with SPACEs are not supported
152	## NOTE: Future version might use file: URI instead of file path.
153	},
154	'verbose!' => \$Opt{verbose},
155	) or pod2usage (2);
156	pod2usage ({-exitval => 0, -verbose => 1}) if $Opt{help};
157	$Opt{file_name} = shift;
158	pod2usage ({-exitval => 2, -verbose => 0}) unless $Opt{file_name};
159
160	$Message::DOM::DOMFeature::DEBUG = 1 if $Opt{debug};
161	require Error;
162	$Error::Debug = 1 if $Opt{debug};
163	$Message::Util::Error::VERBOSE = 1 if $Opt{verbose};
164
165	$Opt{daem_suffix} = '.daem' unless defined $Opt{daem_suffix};
166	$Opt{dis_suffix} = '.dis' unless defined $Opt{dis_suffix};
167
168	if ($Opt{module_uri}) {
169	push @{$Opt{create_module}},
170	[$Opt{module_uri}, $Opt{output_file_name}, $Opt{For}];
171	}
172
173	pod2usage (2) unless @{$Opt{create_module}};
174
175	sub status_msg ($) {
176	my $s = shift;
177	$s .= "\n" unless $s =~ /\n$/;
178	print STDERR $s;
179	}
180
181	sub status_msg_ ($) {
182	my $s = shift;
183	print STDERR $s;
184	}
185
186	sub verbose_msg ($) {
187	my $s = shift;
188	$s .= "\n" unless $s =~ /\n$/;
189	print STDERR $s if $Opt{verbose};
190	}
191
192	sub verbose_msg_ ($) {
193	my $s = shift;
194	print STDERR $s if $Opt{verbose};
195	}
196
197	## TODO: Assertion control
198
199	use Message::Util::DIS::DNLite;
200	use Message::Util::DIS::DPG;
201	use Message::DOM::GenericLS;
202
203	my $start_time;
204	BEGIN { $start_time = time }
205
206	my $impl = $Message::DOM::ImplementationRegistry->get_implementation
207	({
208	ExpandedURI q<ManakaiDOM:Minimum> => '3.0',
209	'+' . ExpandedURI q<DIS:Core> => '1.0',
210	'+' . ExpandedURI q<Util:PerlCode> => '1.0',
211	'+' . ExpandedURI q<DOMLS:Generic> => '3.0',
212	});
213	my $pc = $impl->get_feature (ExpandedURI q<Util:PerlCode> => '1.0');
214	my $di = $impl->get_feature (ExpandedURI q<DIS:Core> => '1.0');
215
216	status_msg_ qq<Loading the database "$Opt{file_name}"...>;
217	my $db = $di->pl_load_dis_database ($Opt{file_name}, sub ($$) {
218	my ($db, $mod) = @_;
219	my $ns = $mod->namespace_uri;
220	my $ln = $mod->local_name;
221	verbose_msg qq<Database module <$ns$ln> is requested>;
222	my $name = dac_search_file_path_stem ($ns, $ln, $Opt{daem_suffix});
223	if (defined $name) {
224	return $name.$Opt{daem_suffix};
225	} else {
226	return $ln.$Opt{daem_suffix};
227	}
228	});
229	status_msg q<done>;
230
231	for (@{$Opt{create_module}}) {
232	my ($mod_uri, $out_file_path, $mod_for) = @$_;
233
234	my $mod = $db->get_module ($mod_uri, for_arg => $mod_for);
235	unless ($mod_for) {
236	$mod_for = $mod->get_property_text (ExpandedURI q<dis:DefaultFor>, undef);
237	if (defined $mod_for) {
238	$mod = $db->get_module ($mod_uri, for_arg => $mod_for);
239	}
240	}
241	unless ($mod->is_defined) {
242	die qq<$0: Module <$mod_uri> for <$mod_for> is not defined>;
243	}
244
245	status_msg_ qq<Generating Perl module from <$mod_uri> for <$mod_for>...>;
246	my $pl = $mod->pl_generate_perl_module_file;
247	status_msg qq<done>;
248
249	my $output;
250	defined $out_file_path
251	? (open $output, '>', $out_file_path or die "$0: $out_file_path: $!")
252	: ($output = \*STDOUT);
253
254	if ($Opt{output_line}) {
255	$pl->owner_document->dom_config->set_parameter (ExpandedURI q<pc:line> => 1);
256	}
257
258	status_msg_ sprintf qq<Writing Perl module %s...>,
259	defined $out_file_path
260	? q<">.$out_file_path.q<">
261	: 'to stdout';
262	print $output $pl->stringify;
263	close $output;
264	status_msg q<done>;
265	} # create_module
266
267	status_msg_ "Checking undefined resources...";
268	$db->check_undefined_resource;
269	status_msg q<done>;
270
271	status_msg_ "Closing the database...";
272	$db->free;
273	undef $db;
274	status_msg q<done>;
275
276	END {
277	use integer;
278	my $time = time - $start_time;
279	status_msg sprintf qq<%d'%02d''>, $time / 60, $time % 60;
280	}
281	exit;
282
283	sub dac_search_file_path_stem ($$$) {
284	my ($ns, $ln, $suffix) = @_;
285	require Cwd;
286	require File::Spec;
287	for my $dir ('.', @{$Opt{input_search_path}->{$ns}\|\|[]}) {
288	my $name = Cwd::abs_path
289	(File::Spec->canonpath
290	(File::Spec->catfile ($dir, $ln)));
291	if (-f $name.$suffix) {
292	return $name;
293	}
294	}
295	return undef;
296	} # dac_search_file_path_stem;
297
298	=head1 SEE ALSO
299
300	L<lib/Message/Util/DIS.dis> - The <QUOTE::dis> object implementation.
301
302	L<lib/Message/Util/DIS/Perl.dis> - The <QUOTE::dis> object implementation,
303	submodule for Perl modules.
304
305	L<lib/Message/Util/PerlCode.dis> - The Perl code generator.
306
307	L<lib/manakai/DISCore.dis> - The definition for the "dis" format.
308
309	L<lib/manakai/DISPerl.dis> - The definition for the "dis" Perl-specific
310	vocabulary.
311
312	L<bin/dac.pl> - The "dac" database generator.
313
314	=head1 LICENSE
315
316	Copyright 2004-2006 Wakaba <w@suika.fam.cx>. All rights reserved.
317
318	This program is free software; you can redistribute it and/or
319	modify it under the same terms as Perl itself.
320
321	=cut
322
323	1; # $Date: 2006/02/25 16:49:55 $