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;
use Storable qw/nstore retrieve/;
my %Opt;
GetOptions (
  'db-base-directory-path=s' => \$Opt{db_base_path},
  'for=s' => \$Opt{For},
  'help' => \$Opt{help},
  'input-cdis-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, ()) {
      push @{$Opt{input_search_path}->{$ns} ||= []}, $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;
push @{$Opt{module_file_search_path}}, '.';

use Message::DOM::DOMMetaImpl;
use Message::Util::DIS;
my $impl = $Message::DOM::DOMImplementationRegistry
                 ->get_dom_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>;

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

  ## -- 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);


$db->check_undefined_resource unless $Opt{no_undef_check};

#if (dis_uri_for_match (ExpandedURI q<ManakaiDOM:Perl>, $State->{DefaultFor})) {
#  dis_perl_init ($source, For => $State->{DefaultFor});
#}

$db->pl_store ($Opt{output_file_name});
exit;

## (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_name"...>;
    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

...

=head1 OPTIONS

...

=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			use Storable qw/nstore retrieve/;
13			my %Opt;
14			GetOptions (
15			'db-base-directory-path=s' => \$Opt{db_base_path},
16			'for=s' => \$Opt{For},
17			'help' => \$Opt{help},
18			'input-cdis-file-name=s' => \$Opt{input_file_name},
19			'output-file-name=s' => \$Opt{output_file_name},
20	wakaba	1.2	'search-path\|I=s' => sub {
21			shift;
22			my @value = split /\s+/, shift;
23			while (my ($ns, $path) = splice @value, 0, 2, ()) {
24			push @{$Opt{input_search_path}->{$ns} \|\|= []}, $path;
25			}
26			},
27	wakaba	1.1	'undef-check!' => \$Opt{no_undef_check},
28			'verbose!' => $Opt{verbose},
29			) or pod2usage (2);
30			pod2usage ({-exitval => 0, -verbose => 1}) if $Opt{help};
31			$Opt{file_name} = shift;
32			pod2usage ({-exitval => 2, -verbose => 0}) unless $Opt{file_name};
33			pod2usage ({-exitval => 2, -verbose => 0}) unless $Opt{output_file_name};
34			$Opt{no_undef_check} = defined $Opt{no_undef_check}
35			? $Opt{no_undef_check} ? 0 : 1 : 0;
36			push @{$Opt{module_file_search_path}}, '.';
37
38			use Message::DOM::DOMMetaImpl;
39			use Message::Util::DIS;
40			my $impl = $Message::DOM::DOMImplementationRegistry
41			->get_dom_implementation
42			({ExpandedURI q<ManakaiDOM:Minimum> => '3.0',
43			'+' . ExpandedURI q<DIS:Core> => '1.0'})
44			->get_feature (ExpandedURI q<DIS:Core> => '1.0');
45			my $parser = $impl->create_dis_parser;
46
47			my $db;
48
49			if (defined $Opt{input_file_name}) {
50	wakaba	1.3	$db = $impl->pl_load_dis_database ($Opt{input_file_name});
51	wakaba	1.1	} else { ## New database
52			$db = $impl->create_dis_database;
53			}
54
55			require Cwd;
56			my $file_name = Cwd::abs_path ($Opt{file_name});
57			my $base_path = Cwd::abs_path ($Opt{db_base_path}) if length $Opt{db_base_path};
58			my $doc = dac_load_module_file ($db, $parser, $file_name, $base_path);
59			$doc->dis_database ($db);
60
61			my $for = $Opt{for};
62			$for = $doc->module_element->default_for_uri unless length $for;
63	wakaba	1.3	$db->get_for ($for)->is_referred ($doc);
64	wakaba	1.2	print STDERR qq<Loading definition of "$file_name" for <$for>...\n>;
65	wakaba	1.1
66			$db->load_module ($doc, sub ($$$$$$) {
67			my ($self, $db, $uri, $ns, $ln, $for) = @_;
68	wakaba	1.2	print STDERR qq<Loading definition of "$ln" for <$for>...\n>;
69
70			## -- Already in database
71	wakaba	1.1	my $doc = $db->get_source_file ($ns.$ln);
72	wakaba	1.2	return $doc if $doc;
73	wakaba	1.1
74	wakaba	1.2	## -- Finds the source file
75			require File::Spec;
76			for my $dir ('.', @{$Opt{input_search_path}->{$ns}\|\|[]}) {
77			my $name = Cwd::abs_path
78			(File::Spec->canonpath
79			(File::Spec->catfile ($dir, $ln.'.dis')));
80			if (-f $name) {
81			my $doc = dac_load_module_file ($db, $parser, $name, $base_path);
82			$doc->dis_database ($db);
83			return $doc;
84			}
85			}
86
87			## -- Not found
88			return undef;
89	wakaba	1.1	}, for_arg => $for);
90
91	wakaba	1.3
92			$db->check_undefined_resource unless $Opt{no_undef_check};
93
94	wakaba	1.1	#if (dis_uri_for_match (ExpandedURI q<ManakaiDOM:Perl>, $State->{DefaultFor})) {
95			# dis_perl_init ($source, For => $State->{DefaultFor});
96			#}
97
98	wakaba	1.3	$db->pl_store ($Opt{output_file_name});
99	wakaba	1.1	exit;
100
101			## (db, parser, abs file path, abs base path) -> dis doc obj
102			sub dac_load_module_file ($$$;$) {
103			my ($db, $parser, $file_name, $base_path) = @_;
104			require URI::file;
105			my $base_uri = length $base_path ? URI::file->new ($base_path.'/')
106			: 'http://dummy.invalid/';
107			my $file_uri = URI::file->new ($file_name)->rel ($base_uri);
108			my $dis = $db->get_source_file ($file_uri);
109			unless ($dis) {
110	wakaba	1.2	print STDERR qq<Opening file "$file_name"...>;
111	wakaba	1.1	open my $file, '<', $file_name or die "$0: $file_name: $!";
112			$dis = $parser->parse ({character_stream => $file});
113			$db->set_source_file ($file_uri => $dis);
114	wakaba	1.3	$dis->flag (ExpandedURI q<swcfg21:fileName> => $file_uri);
115	wakaba	1.2	print STDERR qq<done\n>;
116	wakaba	1.1	}
117			$dis;
118			}
119
120			__END__
121
122			=head1 NAME
123
124			...
125
126			=head1 OPTIONS
127
128			...
129	wakaba	1.2
130			=cut