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