manakai/bin/dac.pl

#!/usr/bin/perl -w 
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#>,
  swcfg21 => q<http://suika.fam.cx/~wakaba/archive/2005/swcfg21#>,
};

use Getopt::Long;
use Pod::Usage;
my %Opt = ();
GetOptions (
  'db-base-directory-path=s' => \$Opt{db_base_path},
  'for=s' => \$Opt{For},
  'help' => \$Opt{help},
  'input-db-file-name=s' => \$Opt{input_file_name},
  'output-file-name=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.
  },
  'undef-check!' => \$Opt{no_undef_check},
  '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};
pod2usage ({-exitval => 2, -verbose => 0}) unless $Opt{output_file_name};
$Opt{no_undef_check} = defined $Opt{no_undef_check}
                         ? $Opt{no_undef_check} ? 0 : 1 : 0;

use Message::Util::DIS;

my $impl = $Message::DOM::ImplementationRegistry->get_implementation
                           ({ExpandedURI q<ManakaiDOM:Minimum> => '3.0',
                             '+' . ExpandedURI q<DIS:Core> => '1.0'})
                 ->get_feature (ExpandedURI q<DIS:Core> => '1.0');
my $parser = $impl->create_dis_parser;

my $db;

if (defined $Opt{input_file_name}) {
  $db = $impl->pl_load_dis_database ($Opt{input_file_name});
} else {  ## New database
  $db = $impl->create_dis_database;
}

require Cwd;
my $file_name = Cwd::abs_path ($Opt{file_name});
my $base_path = Cwd::abs_path ($Opt{db_base_path}) if length $Opt{db_base_path};
my $doc = dac_load_module_file ($db, $parser, $file_name, $base_path);
$doc->dis_database ($db);

my $for = $Opt{For};
$for = $doc->module_element->default_for_uri unless length $for;
$db->get_for ($for)->is_referred ($doc);
print STDERR qq<Loading definition of "$file_name" for <$for>...\n>;

my $ResourceCount = 0;
$db->load_module ($doc, sub ($$$$$$) {
  my ($self, $db, $uri, $ns, $ln, $for) = @_;
  print STDERR qq<\n>;
  print STDERR qq<Loading definition of "$ln" for <$for>...\n>;
  $ResourceCount = 0;

  ## -- Already in database
  my $doc = $db->get_source_file ($ns.$ln);
  return $doc if $doc;
  
  ## -- Finds the source file
  require File::Spec;
  for my $dir ('.', @{$Opt{input_search_path}->{$ns}||[]}) {
    my $name = Cwd::abs_path
                  (File::Spec->canonpath
                       (File::Spec->catfile ($dir, $ln.'.dis')));
    if (-f $name) {
      my $doc = dac_load_module_file ($db, $parser, $name, $base_path);
      $doc->dis_database ($db);
      return $doc;
    }
  }

  ## -- Not found
  return undef;
}, for_arg => $for, on_resource_read => sub ($$) {
  if ((++$ResourceCount % 10) == 0) {
    print STDERR "*";
    print STDERR " " if ($ResourceCount % (10 * 10)) == 0;
    print STDERR "\n" if ($ResourceCount % (10 * 50)) == 0;
  }
});

print STDERR "\n";

unless ($Opt{no_undef_check}) {
  print STDERR "Checking undefined resources...";
  $db->check_undefined_resource;
  print STDERR "done\n";
}

print STDERR qq<Writing file "$Opt{output_file_name}"...>;
$db->pl_store ($Opt{output_file_name});
print STDERR "done\n";

print STDERR "Closing the database...";
$db->free;
undef $db;
print STDERR "done\n";

exit;

END {
  $db->free if $db;
}

## (db, parser, abs file path, abs base path) -> dis doc obj
sub dac_load_module_file ($$$;$) {
  my ($db, $parser, $file_name, $base_path) = @_;
  require URI::file;
  my $base_uri = length $base_path ? URI::file->new ($base_path.'/')
                                   : 'http://dummy.invalid/';
  my $file_uri = URI::file->new ($file_name)->rel ($base_uri);
  my $dis = $db->get_source_file ($file_uri);
  unless ($dis) {
    print STDERR qq<Opening file <$file_uri>...>;
    open my $file, '<', $file_name or die "$0: $file_name: $!";
    $dis = $parser->parse ({character_stream => $file});
    $db->set_source_file ($file_uri => $dis);
    $dis->flag (ExpandedURI q<swcfg21:fileName> => $file_uri);
    print STDERR qq<done\n>;
  }
  $dis;
}

__END__

=head1 NAME

dac - Creating "dac" Database File from "dis" Source Files

=head1 SYNOPSIS

  perl path/to/dac.pl ...
  perl path/to/dac.pl --help

=head1 DESCRIPTION

The C<dac.pl> script loads "dis" source files and
writes a "dac" database file.

This script is part of manakai.

=head1 OPTIONS

...

=head1 SEE ALSO

L<bin/dac2pm.pl> - Generating Perl module from "dac" file.

L<lib/Message/Util/DIS.dis> - The actual implementation
of the "dis" interpretation.

=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	wakaba	1.1	#!/usr/bin/perl -w
2			use strict;
3			use Message::Util::QName::Filter {
4			DIS => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#>,
5			dis => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/lang#dis-->,
6			ManakaiDOM => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/manakai-dom#>,
7	wakaba	1.3	swcfg21 => q<http://suika.fam.cx/~wakaba/archive/2005/swcfg21#>,
8	wakaba	1.1	};
9
10			use Getopt::Long;
11			use Pod::Usage;
12	wakaba	1.4	my %Opt = ();
13	wakaba	1.1	GetOptions (
14			'db-base-directory-path=s' => \$Opt{db_base_path},
15			'for=s' => \$Opt{For},
16			'help' => \$Opt{help},
17	wakaba	1.4	'input-db-file-name=s' => \$Opt{input_file_name},
18	wakaba	1.1	'output-file-name=s' => \$Opt{output_file_name},
19	wakaba	1.2	'search-path\|I=s' => sub {
20			shift;
21			my @value = split /\s+/, shift;
22			while (my ($ns, $path) = splice @value, 0, 2, ()) {
23	wakaba	1.4	unless (defined $path) {
24			die qq[$0: Search-path parameter without path: "$ns"];
25			}
26	wakaba	1.2	push @{$Opt{input_search_path}->{$ns} \|\|= []}, $path;
27			}
28			},
29	wakaba	1.4	'search-path-catalog-file-name=s' => sub {
30			shift;
31			require File::Spec;
32			my $path = my $path_base = shift;
33			$path_base =~ s#[^/]+$##;
34			$Opt{search_path_base} = $path_base;
35			open my $file, '<', $path or die "$0: $path: $!";
36			while (<$file>) {
37			if (s/^\s*\@//) { ## Processing instruction
38			my ($target, $data) = split /\s+/;
39			if ($target eq 'base') {
40			$Opt{search_path_base} = File::Spec->rel2abs ($data, $path_base);
41			} else {
42			die "$0: $target: Unknown target";
43			}
44			} elsif (/^\s*\#/) { ## Comment
45			#
46			} elsif (/\S/) { ## Catalog entry
47			s/^\s+//;
48			my ($ns, $path) = split /\s+/;
49			push @{$Opt{input_search_path}->{$ns} \|\|= []},
50			File::Spec->rel2abs ($path, $Opt{search_path_base});
51			}
52			}
53			## NOTE: File paths with SPACEs are not supported
54			## NOTE: Future version might use file: URI instead of file path.
55			},
56	wakaba	1.1	'undef-check!' => \$Opt{no_undef_check},
57			'verbose!' => $Opt{verbose},
58			) or pod2usage (2);
59			pod2usage ({-exitval => 0, -verbose => 1}) if $Opt{help};
60			$Opt{file_name} = shift;
61			pod2usage ({-exitval => 2, -verbose => 0}) unless $Opt{file_name};
62			pod2usage ({-exitval => 2, -verbose => 0}) unless $Opt{output_file_name};
63			$Opt{no_undef_check} = defined $Opt{no_undef_check}
64			? $Opt{no_undef_check} ? 0 : 1 : 0;
65
66	wakaba	1.8	use Message::Util::DIS;
67	wakaba	1.5
68	wakaba	1.8	my $impl = $Message::DOM::ImplementationRegistry->get_implementation
69	wakaba	1.1	({ExpandedURI q<ManakaiDOM:Minimum> => '3.0',
70			'+' . ExpandedURI q<DIS:Core> => '1.0'})
71			->get_feature (ExpandedURI q<DIS:Core> => '1.0');
72			my $parser = $impl->create_dis_parser;
73
74			my $db;
75
76			if (defined $Opt{input_file_name}) {
77	wakaba	1.3	$db = $impl->pl_load_dis_database ($Opt{input_file_name});
78	wakaba	1.1	} else { ## New database
79			$db = $impl->create_dis_database;
80			}
81
82			require Cwd;
83			my $file_name = Cwd::abs_path ($Opt{file_name});
84			my $base_path = Cwd::abs_path ($Opt{db_base_path}) if length $Opt{db_base_path};
85			my $doc = dac_load_module_file ($db, $parser, $file_name, $base_path);
86			$doc->dis_database ($db);
87
88	wakaba	1.7	my $for = $Opt{For};
89	wakaba	1.1	$for = $doc->module_element->default_for_uri unless length $for;
90	wakaba	1.3	$db->get_for ($for)->is_referred ($doc);
91	wakaba	1.2	print STDERR qq<Loading definition of "$file_name" for <$for>...\n>;
92	wakaba	1.1
93	wakaba	1.6	my $ResourceCount = 0;
94	wakaba	1.1	$db->load_module ($doc, sub ($$$$$$) {
95			my ($self, $db, $uri, $ns, $ln, $for) = @_;
96	wakaba	1.6	print STDERR qq<\n>;
97	wakaba	1.2	print STDERR qq<Loading definition of "$ln" for <$for>...\n>;
98	wakaba	1.6	$ResourceCount = 0;
99	wakaba	1.2
100			## -- Already in database
101	wakaba	1.1	my $doc = $db->get_source_file ($ns.$ln);
102	wakaba	1.2	return $doc if $doc;
103	wakaba	1.1
104	wakaba	1.2	## -- Finds the source file
105			require File::Spec;
106			for my $dir ('.', @{$Opt{input_search_path}->{$ns}\|\|[]}) {
107			my $name = Cwd::abs_path
108			(File::Spec->canonpath
109			(File::Spec->catfile ($dir, $ln.'.dis')));
110			if (-f $name) {
111			my $doc = dac_load_module_file ($db, $parser, $name, $base_path);
112			$doc->dis_database ($db);
113			return $doc;
114			}
115			}
116
117			## -- Not found
118			return undef;
119	wakaba	1.6	}, for_arg => $for, on_resource_read => sub ($$) {
120			if ((++$ResourceCount % 10) == 0) {
121			print STDERR "*";
122			print STDERR " " if ($ResourceCount % (10 * 10)) == 0;
123			print STDERR "\n" if ($ResourceCount % (10 * 50)) == 0;
124			}
125			});
126	wakaba	1.1
127	wakaba	1.8	print STDERR "\n";
128	wakaba	1.3
129	wakaba	1.8	unless ($Opt{no_undef_check}) {
130			print STDERR "Checking undefined resources...";
131			$db->check_undefined_resource;
132			print STDERR "done\n";
133			}
134	wakaba	1.3
135	wakaba	1.8	print STDERR qq<Writing file "$Opt{output_file_name}"...>;
136	wakaba	1.3	$db->pl_store ($Opt{output_file_name});
137	wakaba	1.8	print STDERR "done\n";
138
139			print STDERR "Closing the database...";
140			$db->free;
141			undef $db;
142			print STDERR "done\n";
143
144	wakaba	1.1	exit;
145
146	wakaba	1.8	END {
147			$db->free if $db;
148			}
149
150	wakaba	1.1	## (db, parser, abs file path, abs base path) -> dis doc obj
151			sub dac_load_module_file ($$$;$) {
152			my ($db, $parser, $file_name, $base_path) = @_;
153			require URI::file;
154			my $base_uri = length $base_path ? URI::file->new ($base_path.'/')
155			: 'http://dummy.invalid/';
156			my $file_uri = URI::file->new ($file_name)->rel ($base_uri);
157			my $dis = $db->get_source_file ($file_uri);
158			unless ($dis) {
159	wakaba	1.4	print STDERR qq<Opening file <$file_uri>...>;
160	wakaba	1.1	open my $file, '<', $file_name or die "$0: $file_name: $!";
161			$dis = $parser->parse ({character_stream => $file});
162			$db->set_source_file ($file_uri => $dis);
163	wakaba	1.3	$dis->flag (ExpandedURI q<swcfg21:fileName> => $file_uri);
164	wakaba	1.2	print STDERR qq<done\n>;
165	wakaba	1.1	}
166			$dis;
167			}
168
169			__END__
170
171			=head1 NAME
172
173	wakaba	1.8	dac - Creating "dac" Database File from "dis" Source Files
174
175			=head1 SYNOPSIS
176
177			perl path/to/dac.pl ...
178			perl path/to/dac.pl --help
179
180			=head1 DESCRIPTION
181
182			The C<dac.pl> script loads "dis" source files and
183			writes a "dac" database file.
184
185			This script is part of manakai.
186	wakaba	1.1
187			=head1 OPTIONS
188
189			...
190	wakaba	1.8
191			=head1 SEE ALSO
192
193			L<bin/dac2pm.pl> - Generating Perl module from "dac" file.
194
195			L<lib/Message/Util/DIS.dis> - The actual implementation
196			of the "dis" interpretation.
197
198			=head1 LICENSE
199
200			Copyright 2004-2005 Wakaba <w@suika.fam.cx>. All rights reserved.
201
202			This program is free software; you can redistribute it and/or
203			modify it under the same terms as Perl itself.
204	wakaba	1.2
205			=cut