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-->,
  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;

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',
                });
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/10/16 06:08:22 $
1	wakaba	1.1	#!/usr/bin/perl -w
2			use strict;
3
4			=head1 NAME
5
6	wakaba	1.5	dac2pm - Generating Perl Module from "dac" File
7	wakaba	1.1
8			=head1 SYNOPSIS
9
10	wakaba	1.5	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	wakaba	1.8	perl path/to/dac2pm.pl input.dac \
16			--create-perl-module="module-uri ModuleName.pm [for-uri]" \
17			[--create-perl-module="..." ...]
18	wakaba	1.5	perl path/to/dac2pm.pl --help
19	wakaba	1.1
20			=head1 DESCRIPTION
21
22	wakaba	1.8	The C<dac2pm.pl> script generates Perl modules from a "dac" database file
23			created by C<dac.pl>.
24	wakaba	1.1
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	wakaba	1.13	pc => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/PerlCode#>,
36	wakaba	1.1	Util => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/>,
37			};
38
39			=head1 OPTIONS
40
41			=over 4
42
43			=item --enable-assertion / --noenable-assertion (default)
44
45			Whether assertion codes should be outputed or not.
46
47	wakaba	1.8	=item --create-perl-module="I<module-uri> I<ModuleName.pm> [I<for-uri>]" (Zero or more)
48
49			The C<--create-perl-module> option can be used to specify
50			I<--module-uri>, I<--output-file-path>, and I<--for> options
51			once. Its value is a space-separated triplet of "dis" module name URI,
52			Perl module file path (environment dependent), and optional
53			"dis" module "for" URI.
54
55			This option can be specified more than once; it would
56			make multiple Perl module files to be created. If
57			both I<--module-uri> and this options are specified,
58			I<--module-uri>, I<--output-file-path>, and I<--for>
59			options are treated as if there is another I<--create-perl-module>
60			option specified.
61
62	wakaba	1.1	=item --for=I<for-uri> (Optional)
63
64			Specifies the "For" URI reference for which the outputed module is.
65			If this parameter is ommitted, the default "For" URI reference
66	wakaba	1.5	for the module specified by the C<dis:DefaultFor> attribute
67			of the C<dis:Module> element, if any, or C<ManakaiDOM:all> is assumed.
68	wakaba	1.1
69			=item --help
70
71			Shows the help message.
72
73			=item --module-uri=I<module-uri>
74
75	wakaba	1.5	A URI reference that identifies a module from which a Perl
76			module file is generated. This argument is I<required>.
77	wakaba	1.4
78	wakaba	1.5	=item --output-file-path=I<perl-module-file-path> (default: the standard output)
79	wakaba	1.1
80	wakaba	1.5	A platform-dependent file path to which the Perl module
81			is written down.
82	wakaba	1.1
83	wakaba	1.13	=item C<--output-line> / C<--nooutput-line> (default: C<--nooutput-line>)
84
85			Whether C<#line> directives should be included to the generated
86			Perl module files.
87
88	wakaba	1.1	=item --verbose / --noverbose (default)
89
90			Whether a verbose message mode should be selected or not.
91
92			=back
93
94			=cut
95
96			use Getopt::Long;
97			use Pod::Usage;
98	wakaba	1.8	my %Opt = (
99			create_module => [],
100			);
101	wakaba	1.1	GetOptions (
102	wakaba	1.8	'create-perl-module=s' => sub {
103			shift;
104			push @{$Opt{create_module}}, [split /\s+/, shift, 3];
105			},
106	wakaba	1.10	'dis-file-suffix=s' => \$Opt{dis_suffix},
107			'daem-file-suffix=s' => \$Opt{daem_suffix},
108	wakaba	1.9	'debug' => \$Opt{debug},
109	wakaba	1.1	'enable-assertion!' => \$Opt{outputAssertion},
110			'for=s' => \$Opt{For},
111			'help' => \$Opt{help},
112			'module-uri=s' => \$Opt{module_uri},
113	wakaba	1.4	'output-file-path=s' => \$Opt{output_file_name},
114	wakaba	1.13	'output-line' => \$Opt{output_line},
115	wakaba	1.10	'search-path\|I=s' => sub {
116			shift;
117			my @value = split /\s+/, shift;
118			while (my ($ns, $path) = splice @value, 0, 2, ()) {
119			unless (defined $path) {
120			die qq[$0: Search-path parameter without path: "$ns"];
121			}
122			push @{$Opt{input_search_path}->{$ns} \|\|= []}, $path;
123			}
124			},
125			'search-path-catalog-file-name=s' => sub {
126			shift;
127			require File::Spec;
128			my $path = my $path_base = shift;
129			$path_base =~ s#[^/]+$##;
130			$Opt{search_path_base} = $path_base;
131			open my $file, '<', $path or die "$0: $path: $!";
132			while (<$file>) {
133			if (s/^\s*\@//) { ## Processing instruction
134			my ($target, $data) = split /\s+/;
135			if ($target eq 'base') {
136			$Opt{search_path_base} = File::Spec->rel2abs ($data, $path_base);
137			} else {
138			die "$0: $target: Unknown target";
139			}
140			} elsif (/^\s*\#/) { ## Comment
141			#
142			} elsif (/\S/) { ## Catalog entry
143			s/^\s+//;
144			my ($ns, $path) = split /\s+/;
145			push @{$Opt{input_search_path}->{$ns} \|\|= []},
146			File::Spec->rel2abs ($path, $Opt{search_path_base});
147			}
148			}
149			## NOTE: File paths with SPACEs are not supported
150			## NOTE: Future version might use file: URI instead of file path.
151			},
152			'verbose!' => \$Opt{verbose},
153	wakaba	1.1	) or pod2usage (2);
154			pod2usage ({-exitval => 0, -verbose => 1}) if $Opt{help};
155			$Opt{file_name} = shift;
156			pod2usage ({-exitval => 2, -verbose => 0}) unless $Opt{file_name};
157	wakaba	1.14
158	wakaba	1.9	$Message::DOM::DOMFeature::DEBUG = 1 if $Opt{debug};
159	wakaba	1.14	require Error;
160			$Error::Debug = 1 if $Opt{debug};
161			$Message::Util::Error::VERBOSE = 1 if $Opt{verbose};
162
163	wakaba	1.10	$Opt{daem_suffix} = '.daem' unless defined $Opt{daem_suffix};
164	wakaba	1.11	$Opt{dis_suffix} = '.dis' unless defined $Opt{dis_suffix};
165	wakaba	1.8
166			if ($Opt{module_uri}) {
167			push @{$Opt{create_module}},
168			[$Opt{module_uri}, $Opt{output_file_name}, $Opt{For}];
169			}
170
171			pod2usage (2) unless @{$Opt{create_module}};
172
173			sub status_msg ($) {
174			my $s = shift;
175			$s .= "\n" unless $s =~ /\n$/;
176			print STDERR $s;
177			}
178
179			sub status_msg_ ($) {
180			my $s = shift;
181			print STDERR $s;
182			}
183
184			sub verbose_msg ($) {
185			my $s = shift;
186			$s .= "\n" unless $s =~ /\n$/;
187			print STDERR $s if $Opt{verbose};
188			}
189
190			sub verbose_msg_ ($) {
191			my $s = shift;
192			print STDERR $s if $Opt{verbose};
193			}
194	wakaba	1.1
195			## TODO: Assertion control
196
197	wakaba	1.8	use Message::Util::DIS::DNLite;
198	wakaba	1.1
199	wakaba	1.12	my $start_time;
200			BEGIN { $start_time = time }
201
202	wakaba	1.5	my $impl = $Message::DOM::ImplementationRegistry->get_implementation
203	wakaba	1.1	({
204			ExpandedURI q<ManakaiDOM:Minimum> => '3.0',
205			'+' . ExpandedURI q<DIS:Core> => '1.0',
206			'+' . ExpandedURI q<Util:PerlCode> => '1.0',
207			});
208			my $pc = $impl->get_feature (ExpandedURI q<Util:PerlCode> => '1.0');
209			my $di = $impl->get_feature (ExpandedURI q<DIS:Core> => '1.0');
210
211	wakaba	1.10	status_msg_ qq<Loading the database "$Opt{file_name}"...>;
212			my $db = $di->pl_load_dis_database ($Opt{file_name}, sub ($$) {
213			my ($db, $mod) = @_;
214			my $ns = $mod->namespace_uri;
215			my $ln = $mod->local_name;
216			verbose_msg qq<Database module <$ns$ln> is requested>;
217			my $name = dac_search_file_path_stem ($ns, $ln, $Opt{daem_suffix});
218			if (defined $name) {
219			return $name.$Opt{daem_suffix};
220			} else {
221			return $ln.$Opt{daem_suffix};
222			}
223			});
224			status_msg q<done>;
225	wakaba	1.1
226	wakaba	1.8	for (@{$Opt{create_module}}) {
227			my ($mod_uri, $out_file_path, $mod_for) = @$_;
228
229			my $mod = $db->get_module ($mod_uri, for_arg => $mod_for);
230			unless ($mod_for) {
231			$mod_for = $mod->get_property_text (ExpandedURI q<dis:DefaultFor>, undef);
232			if (defined $mod_for) {
233			$mod = $db->get_module ($mod_uri, for_arg => $mod_for);
234	wakaba	1.6	}
235	wakaba	1.1	}
236	wakaba	1.8	unless ($mod->is_defined) {
237			die qq<$0: Module <$mod_uri> for <$mod_for> is not defined>;
238			}
239	wakaba	1.1
240	wakaba	1.8	status_msg_ qq<Generating Perl module from <$mod_uri> for <$mod_for>...>;
241			my $pl = $mod->pl_generate_perl_module_file;
242			status_msg qq<done>;
243
244			my $output;
245			defined $out_file_path
246			? (open $output, '>', $out_file_path or die "$0: $out_file_path: $!")
247	wakaba	1.4	: ($output = \*STDOUT);
248	wakaba	1.13
249			if ($Opt{output_line}) {
250			$pl->owner_document->dom_config->set_parameter (ExpandedURI q<pc:line> => 1);
251			}
252	wakaba	1.8
253			status_msg_ sprintf qq<Writing Perl module %s...>,
254			defined $out_file_path
255			? q<">.$out_file_path.q<">
256			: 'to stdout';
257			print $output $pl->stringify;
258			close $output;
259			status_msg q<done>;
260			} # create_module
261	wakaba	1.4
262	wakaba	1.8	status_msg_ "Checking undefined resources...";
263	wakaba	1.1	$db->check_undefined_resource;
264	wakaba	1.8	status_msg q<done>;
265	wakaba	1.5
266	wakaba	1.8	status_msg_ "Closing the database...";
267	wakaba	1.5	$db->free;
268	wakaba	1.7	undef $db;
269	wakaba	1.8	status_msg q<done>;
270	wakaba	1.12
271			END {
272			use integer;
273			my $time = time - $start_time;
274			status_msg sprintf qq<%d'%02d''>, $time / 60, $time % 60;
275			}
276	wakaba	1.10	exit;
277
278			sub dac_search_file_path_stem ($$$) {
279			my ($ns, $ln, $suffix) = @_;
280			require Cwd;
281			require File::Spec;
282			for my $dir ('.', @{$Opt{input_search_path}->{$ns}\|\|[]}) {
283			my $name = Cwd::abs_path
284			(File::Spec->canonpath
285			(File::Spec->catfile ($dir, $ln)));
286			if (-f $name.$suffix) {
287			return $name;
288			}
289			}
290			return undef;
291			} # dac_search_file_path_stem;
292	wakaba	1.1
293			=head1 SEE ALSO
294
295			L<lib/Message/Util/DIS.dis> - The <QUOTE::dis> object implementation.
296
297	wakaba	1.8	L<lib/Message/Util/DIS/Perl.dis> - The <QUOTE::dis> object implementation,
298			submodule for Perl modules.
299
300	wakaba	1.1	L<lib/Message/Util/PerlCode.dis> - The Perl code generator.
301
302			L<lib/manakai/DISCore.dis> - The definition for the "dis" format.
303
304			L<lib/manakai/DISPerl.dis> - The definition for the "dis" Perl-specific
305			vocabulary.
306
307	wakaba	1.5	L<bin/dac.pl> - The "dac" database generator.
308
309	wakaba	1.1	=head1 LICENSE
310
311			Copyright 2004-2005 Wakaba <w@suika.fam.cx>. All rights reserved.
312
313			This program is free software; you can redistribute it and/or
314			modify it under the same terms as Perl itself.
315
316			=cut
317
318	wakaba	1.14	1; # $Date: 2005/10/16 06:08:22 $