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	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	wakaba	1.15	DOMLS => q<http://suika.fam.cx/~wakaba/archive/2004/dom/ls#>,
34	wakaba	1.1	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	wakaba	1.13	pc => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/PerlCode#>,
37	wakaba	1.1	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	wakaba	1.8	=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	wakaba	1.1	=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	wakaba	1.5	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	wakaba	1.1
70			=item --help
71
72			Shows the help message.
73
74			=item --module-uri=I<module-uri>
75
76	wakaba	1.5	A URI reference that identifies a module from which a Perl
77			module file is generated. This argument is I<required>.
78	wakaba	1.4
79	wakaba	1.5	=item --output-file-path=I<perl-module-file-path> (default: the standard output)
80	wakaba	1.1
81	wakaba	1.5	A platform-dependent file path to which the Perl module
82			is written down.
83	wakaba	1.1
84	wakaba	1.13	=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	wakaba	1.1	=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	wakaba	1.8	my %Opt = (
100			create_module => [],
101			);
102	wakaba	1.1	GetOptions (
103	wakaba	1.8	'create-perl-module=s' => sub {
104			shift;
105			push @{$Opt{create_module}}, [split /\s+/, shift, 3];
106			},
107	wakaba	1.10	'dis-file-suffix=s' => \$Opt{dis_suffix},
108			'daem-file-suffix=s' => \$Opt{daem_suffix},
109	wakaba	1.9	'debug' => \$Opt{debug},
110	wakaba	1.1	'enable-assertion!' => \$Opt{outputAssertion},
111			'for=s' => \$Opt{For},
112			'help' => \$Opt{help},
113			'module-uri=s' => \$Opt{module_uri},
114	wakaba	1.4	'output-file-path=s' => \$Opt{output_file_name},
115	wakaba	1.13	'output-line' => \$Opt{output_line},
116	wakaba	1.10	'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	wakaba	1.1	) 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	wakaba	1.14
159	wakaba	1.9	$Message::DOM::DOMFeature::DEBUG = 1 if $Opt{debug};
160	wakaba	1.14	require Error;
161			$Error::Debug = 1 if $Opt{debug};
162			$Message::Util::Error::VERBOSE = 1 if $Opt{verbose};
163
164	wakaba	1.10	$Opt{daem_suffix} = '.daem' unless defined $Opt{daem_suffix};
165	wakaba	1.11	$Opt{dis_suffix} = '.dis' unless defined $Opt{dis_suffix};
166	wakaba	1.8
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	wakaba	1.1
196			## TODO: Assertion control
197
198	wakaba	1.8	use Message::Util::DIS::DNLite;
199	wakaba	1.16	use Message::Util::DIS::DPG;
200	wakaba	1.15	use Message::DOM::GenericLS;
201	wakaba	1.1
202	wakaba	1.12	my $start_time;
203			BEGIN { $start_time = time }
204
205	wakaba	1.5	my $impl = $Message::DOM::ImplementationRegistry->get_implementation
206	wakaba	1.1	({
207			ExpandedURI q<ManakaiDOM:Minimum> => '3.0',
208			'+' . ExpandedURI q<DIS:Core> => '1.0',
209			'+' . ExpandedURI q<Util:PerlCode> => '1.0',
210	wakaba	1.15	'+' . ExpandedURI q<DOMLS:Generic> => '3.0',
211	wakaba	1.1	});
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	wakaba	1.10	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	wakaba	1.1
230	wakaba	1.8	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	wakaba	1.6	}
239	wakaba	1.1	}
240	wakaba	1.8	unless ($mod->is_defined) {
241			die qq<$0: Module <$mod_uri> for <$mod_for> is not defined>;
242			}
243	wakaba	1.1
244	wakaba	1.8	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	wakaba	1.4	: ($output = \*STDOUT);
252	wakaba	1.13
253			if ($Opt{output_line}) {
254			$pl->owner_document->dom_config->set_parameter (ExpandedURI q<pc:line> => 1);
255			}
256	wakaba	1.8
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	wakaba	1.4
266	wakaba	1.8	status_msg_ "Checking undefined resources...";
267	wakaba	1.1	$db->check_undefined_resource;
268	wakaba	1.8	status_msg q<done>;
269	wakaba	1.5
270	wakaba	1.8	status_msg_ "Closing the database...";
271	wakaba	1.5	$db->free;
272	wakaba	1.7	undef $db;
273	wakaba	1.8	status_msg q<done>;
274	wakaba	1.12
275			END {
276			use integer;
277			my $time = time - $start_time;
278			status_msg sprintf qq<%d'%02d''>, $time / 60, $time % 60;
279			}
280	wakaba	1.10	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	wakaba	1.1
297			=head1 SEE ALSO
298
299			L<lib/Message/Util/DIS.dis> - The <QUOTE::dis> object implementation.
300
301	wakaba	1.8	L<lib/Message/Util/DIS/Perl.dis> - The <QUOTE::dis> object implementation,
302			submodule for Perl modules.
303
304	wakaba	1.1	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	wakaba	1.5	L<bin/dac.pl> - The "dac" database generator.
312
313	wakaba	1.1	=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	wakaba	1.16	1; # $Date: 2005/12/20 12:16:49 $