manakai/bin/dac2test.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#>,
  test => q<http://suika.fam.cx/~wakaba/archive/2004/dis/Test#>,
  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 (
  'source-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};

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

use Message::Util::DIS::DNLite;
use Message::Util::DIS::Test;
use Message::DOM::GenericLS;

my $start_time;
BEGIN { $start_time = time }

my $impl = $Message::DOM::ImplementationRegistry->get_implementation
               ({
                 ExpandedURI q<DOMLS:Generic> => '3.0',
                 '+' . ExpandedURI q<DIS:Core> => '1.0',
                 '+' . ExpandedURI q<Util:PerlCode> => '1.0',
                 '+' . ExpandedURI q<DIS:TDT> => '1.0',
                });
my $pc = $impl->get_feature (ExpandedURI q<Util:PerlCode> => '1.0');
my $di = $impl->get_feature (ExpandedURI q<DIS:Core> => '1.0');
my $tdt_parser;

  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 test from <$mod_uri> for <$mod_for>...>;

  my $pl = $pc->create_perl_file;
  my $pack = $pl->get_last_package ("Manakai::Test", make_new_package => 1);
  $pack->add_use_perl_module_name ("Message::Util::DIS::Test");
  $pack->add_use_perl_module_name ("Message::Util::Error");
  $pack->add_require_perl_module_name ($mod->pl_fully_qualified_name);

  $pl->source_file ($mod->get_property_text (ExpandedURI q<DIS:sourceFile>, ""));
  $pl->source_module ($mod->name_uri);
  $pl->source_for ($mod->for_uri);
  $pl->license_uri ($mod->get_property_resource (ExpandedURI q<dis:License>)
                        ->uri);

  $pack->append_code
    ($pc->create_perl_statement
       ('my $impl = $Message::DOM::ImplementationRegistry->get_implementation ({
           "http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#Test"
             => "1.0",
         })'));

  $pack->append_code
      (my $num_statement = $pc->create_perl_statement 
                                  ('my $test = $impl->create_test_manager'));

  my $total_tests = 0;
  my %processed;
  for my $res (@{$mod->get_resource_list}) {
    next if $res->owner_module ne $mod or $processed{$res->uri};
    $processed{$res->uri} = 1;

    if ($res->is_type_uri (ExpandedURI q<test:Test>)) {
      if ($res->is_type_uri (ExpandedURI q<test:StandaloneTest>)) {
        $total_tests++;
        $pack->append_code ('$test->start_new_test (');
        $pack->append_new_pc_literal ($res->name_uri || $res->uri);
        $pack->append_code (');');
        
        $pack->append_code ('try {');
        
        my $test_pc = $res->pl_code_fragment;
        if (not defined $test_pc) {
          die "Perl test code not defined for <".$res->uri.">";
        }
        
        $pack->append_code_fragment ($test_pc);
        
        $pack->append_code ('$test->ok;');
        
        $pack->append_code ('} catch Message::Util::IF::DTException with {
          ##
        };');

      } elsif ($res->is_type_uri (ExpandedURI q<test:ParserTestSet>)) {
        my $block = $pack->append_new_pc_block;
        my @test;
        
        for my $tres (@{$res->get_child_resource_list_by_type
                                (ExpandedURI q<test:ParserTest>)}) {
          $total_tests++;
          push @test, my $ttest = {entity => {}};
          $ttest->{uri} = $tres->uri;
          for my $eres (@{$tres->get_child_resource_list_by_type
                                   (ExpandedURI q<test:Entity>)}) {
            my $tent = $ttest->{entity}->{$eres->uri} = {};
            for (ExpandedURI q<test:uri>, ExpandedURI q<test:baseURI>,
                 ExpandedURI q<test:value>) {
              my $v = $eres->get_property_text ($_);
              $tent->{$_} = $v if defined $v;
            }
            $ttest->{root_uri} = $eres->uri
              if $eres->is_type_uri (ExpandedURI q<test:RootEntity>) or
                 not defined $ttest->{root_uri};
          }
          my $tree_t = $tres->get_property_text (ExpandedURI q<test:domTree>); 
          if (defined $tree_t) {
            unless ($tdt_parser) {
              $tdt_parser = $impl->create_gls_parser
                                     ({
                                       ExpandedURI q<DIS:TDT> => '1.0',
                                      });
            }
            $ttest->{dom_tree} = $tdt_parser->parse_string ($tree_t);
          }
        }

        for ($block->append_statement
                   ->append_new_pc_expression ('=')) {
          $_->append_new_pc_variable ('$', undef, 'TestData')
            ->variable_scope ('my');
          $_->append_new_pc_literal (\@test);
        }
        
        $block->append_code_fragment ($res->pl_code_fragment);
        
      } # test resource type
    } # test:Test
  }
  
  $num_statement->append_code (' (' . $total_tests . ')');
  
  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 test script %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/11/23 11:21:09 $
1	wakaba	1.1	#!/usr/bin/perl -w
2			use strict;
3
4			=head1 NAME
5
6			dac2pm - Generating Perl Module from "dac" File
7
8			=head1 SYNOPSIS
9
10			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			perl path/to/dac2pm.pl input.dac \
16			--create-perl-module="module-uri ModuleName.pm [for-uri]" \
17			[--create-perl-module="..." ...]
18			perl path/to/dac2pm.pl --help
19
20			=head1 DESCRIPTION
21
22			The C<dac2pm.pl> script generates Perl modules from a "dac" database file
23			created by C<dac.pl>.
24
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.5	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			pc => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/PerlCode#>,
37			test => q<http://suika.fam.cx/~wakaba/archive/2004/dis/Test#>,
38			Util => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/>,
39			};
40
41			=head1 OPTIONS
42
43			=over 4
44
45			=item --enable-assertion / --noenable-assertion (default)
46
47			Whether assertion codes should be outputed or not.
48
49			=item --create-perl-module="I<module-uri> I<ModuleName.pm> [I<for-uri>]" (Zero or more)
50
51			The C<--create-perl-module> option can be used to specify
52			I<--module-uri>, I<--output-file-path>, and I<--for> options
53			once. Its value is a space-separated triplet of "dis" module name URI,
54			Perl module file path (environment dependent), and optional
55			"dis" module "for" URI.
56
57			This option can be specified more than once; it would
58			make multiple Perl module files to be created. If
59			both I<--module-uri> and this options are specified,
60			I<--module-uri>, I<--output-file-path>, and I<--for>
61			options are treated as if there is another I<--create-perl-module>
62			option specified.
63
64			=item --for=I<for-uri> (Optional)
65
66			Specifies the "For" URI reference for which the outputed module is.
67			If this parameter is ommitted, the default "For" URI reference
68			for the module specified by the C<dis:DefaultFor> attribute
69			of the C<dis:Module> element, if any, or C<ManakaiDOM:all> is assumed.
70
71			=item --help
72
73			Shows the help message.
74
75			=item --module-uri=I<module-uri>
76
77			A URI reference that identifies a module from which a Perl
78			module file is generated. This argument is I<required>.
79
80			=item --output-file-path=I<perl-module-file-path> (default: the standard output)
81
82			A platform-dependent file path to which the Perl module
83			is written down.
84
85			=item C<--output-line> / C<--nooutput-line> (default: C<--nooutput-line>)
86
87			Whether C<#line> directives should be included to the generated
88			Perl module files.
89
90			=item --verbose / --noverbose (default)
91
92			Whether a verbose message mode should be selected or not.
93
94			=back
95
96			=cut
97
98			use Getopt::Long;
99			use Pod::Usage;
100			my %Opt = (
101			create_module => [],
102			);
103			GetOptions (
104			'source-module=s' => sub {
105			shift;
106			push @{$Opt{create_module}}, [split /\s+/, shift, 3];
107			},
108			'dis-file-suffix=s' => \$Opt{dis_suffix},
109			'daem-file-suffix=s' => \$Opt{daem_suffix},
110			'debug' => \$Opt{debug},
111			'enable-assertion!' => \$Opt{outputAssertion},
112			'for=s' => \$Opt{For},
113			'help' => \$Opt{help},
114			'module-uri=s' => \$Opt{module_uri},
115			'output-file-path=s' => \$Opt{output_file_name},
116			'output-line' => \$Opt{output_line},
117			'search-path\|I=s' => sub {
118			shift;
119			my @value = split /\s+/, shift;
120			while (my ($ns, $path) = splice @value, 0, 2, ()) {
121			unless (defined $path) {
122			die qq[$0: Search-path parameter without path: "$ns"];
123			}
124			push @{$Opt{input_search_path}->{$ns} \|\|= []}, $path;
125			}
126			},
127			'search-path-catalog-file-name=s' => sub {
128			shift;
129			require File::Spec;
130			my $path = my $path_base = shift;
131			$path_base =~ s#[^/]+$##;
132			$Opt{search_path_base} = $path_base;
133			open my $file, '<', $path or die "$0: $path: $!";
134			while (<$file>) {
135			if (s/^\s*\@//) { ## Processing instruction
136			my ($target, $data) = split /\s+/;
137			if ($target eq 'base') {
138			$Opt{search_path_base} = File::Spec->rel2abs ($data, $path_base);
139			} else {
140			die "$0: $target: Unknown target";
141			}
142			} elsif (/^\s*\#/) { ## Comment
143			#
144			} elsif (/\S/) { ## Catalog entry
145			s/^\s+//;
146			my ($ns, $path) = split /\s+/;
147			push @{$Opt{input_search_path}->{$ns} \|\|= []},
148			File::Spec->rel2abs ($path, $Opt{search_path_base});
149			}
150			}
151			## NOTE: File paths with SPACEs are not supported
152			## NOTE: Future version might use file: URI instead of file path.
153			},
154			'verbose!' => \$Opt{verbose},
155			) or pod2usage (2);
156			pod2usage ({-exitval => 0, -verbose => 1}) if $Opt{help};
157			$Opt{file_name} = shift;
158			pod2usage ({-exitval => 2, -verbose => 0}) unless $Opt{file_name};
159	wakaba	1.4
160			require Error;
161			$Error::Debug = 1 if $Opt{debug};
162			$Message::Util::Error::VERBOSE = 1 if $Opt{verbose};
163
164	wakaba	1.1	$Opt{daem_suffix} = '.daem' unless defined $Opt{daem_suffix};
165			$Opt{dis_suffix} = '.dis' unless defined $Opt{dis_suffix};
166
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
196			use Message::Util::DIS::DNLite;
197	wakaba	1.5	use Message::Util::DIS::Test;
198			use Message::DOM::GenericLS;
199	wakaba	1.1
200			my $start_time;
201			BEGIN { $start_time = time }
202
203			my $impl = $Message::DOM::ImplementationRegistry->get_implementation
204			({
205	wakaba	1.5	ExpandedURI q<DOMLS:Generic> => '3.0',
206	wakaba	1.1	'+' . ExpandedURI q<DIS:Core> => '1.0',
207			'+' . ExpandedURI q<Util:PerlCode> => '1.0',
208	wakaba	1.5	'+' . ExpandedURI q<DIS:TDT> => '1.0',
209	wakaba	1.1	});
210			my $pc = $impl->get_feature (ExpandedURI q<Util:PerlCode> => '1.0');
211			my $di = $impl->get_feature (ExpandedURI q<DIS:Core> => '1.0');
212	wakaba	1.5	my $tdt_parser;
213	wakaba	1.1
214			status_msg_ qq<Loading the database "$Opt{file_name}"...>;
215			my $db = $di->pl_load_dis_database ($Opt{file_name}, sub ($$) {
216			my ($db, $mod) = @_;
217			my $ns = $mod->namespace_uri;
218			my $ln = $mod->local_name;
219			verbose_msg qq<Database module <$ns$ln> is requested>;
220			my $name = dac_search_file_path_stem ($ns, $ln, $Opt{daem_suffix});
221			if (defined $name) {
222			return $name.$Opt{daem_suffix};
223			} else {
224			return $ln.$Opt{daem_suffix};
225			}
226			});
227			status_msg q<done>;
228
229			for (@{$Opt{create_module}}) {
230			my ($mod_uri, $out_file_path, $mod_for) = @$_;
231
232			my $mod = $db->get_module ($mod_uri, for_arg => $mod_for);
233			unless ($mod_for) {
234			$mod_for = $mod->get_property_text (ExpandedURI q<dis:DefaultFor>, undef);
235			if (defined $mod_for) {
236			$mod = $db->get_module ($mod_uri, for_arg => $mod_for);
237			}
238			}
239			unless ($mod->is_defined) {
240			die qq<$0: Module <$mod_uri> for <$mod_for> is not defined>;
241			}
242
243			status_msg_ qq<Generating Perl test from <$mod_uri> for <$mod_for>...>;
244
245			my $pl = $pc->create_perl_file;
246			my $pack = $pl->get_last_package ("Manakai::Test", make_new_package => 1);
247			$pack->add_use_perl_module_name ("Message::Util::DIS::Test");
248			$pack->add_use_perl_module_name ("Message::Util::Error");
249	wakaba	1.2	$pack->add_require_perl_module_name ($mod->pl_fully_qualified_name);
250	wakaba	1.1
251			$pl->source_file ($mod->get_property_text (ExpandedURI q<DIS:sourceFile>, ""));
252			$pl->source_module ($mod->name_uri);
253			$pl->source_for ($mod->for_uri);
254			$pl->license_uri ($mod->get_property_resource (ExpandedURI q<dis:License>)
255			->uri);
256
257			$pack->append_code
258			($pc->create_perl_statement
259			('my $impl = $Message::DOM::ImplementationRegistry->get_implementation ({
260			"http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#Test"
261			=> "1.0",
262			})'));
263
264			$pack->append_code
265			(my $num_statement = $pc->create_perl_statement
266			('my $test = $impl->create_test_manager'));
267
268			my $total_tests = 0;
269			my %processed;
270			for my $res (@{$mod->get_resource_list}) {
271			next if $res->owner_module ne $mod or $processed{$res->uri};
272			$processed{$res->uri} = 1;
273
274			if ($res->is_type_uri (ExpandedURI q<test:Test>)) {
275	wakaba	1.5	if ($res->is_type_uri (ExpandedURI q<test:StandaloneTest>)) {
276			$total_tests++;
277			$pack->append_code ('$test->start_new_test (');
278			$pack->append_new_pc_literal ($res->name_uri \|\| $res->uri);
279			$pack->append_code (');');
280
281			$pack->append_code ('try {');
282
283			my $test_pc = $res->pl_code_fragment;
284			if (not defined $test_pc) {
285			die "Perl test code not defined for <".$res->uri.">";
286			}
287
288			$pack->append_code_fragment ($test_pc);
289
290			$pack->append_code ('$test->ok;');
291
292			$pack->append_code ('} catch Message::Util::IF::DTException with {
293			##
294			};');
295
296			} elsif ($res->is_type_uri (ExpandedURI q<test:ParserTestSet>)) {
297			my $block = $pack->append_new_pc_block;
298			my @test;
299
300			for my $tres (@{$res->get_child_resource_list_by_type
301			(ExpandedURI q<test:ParserTest>)}) {
302			$total_tests++;
303			push @test, my $ttest = {entity => {}};
304			$ttest->{uri} = $tres->uri;
305			for my $eres (@{$tres->get_child_resource_list_by_type
306			(ExpandedURI q<test:Entity>)}) {
307			my $tent = $ttest->{entity}->{$eres->uri} = {};
308			for (ExpandedURI q<test:uri>, ExpandedURI q<test:baseURI>,
309			ExpandedURI q<test:value>) {
310			my $v = $eres->get_property_text ($_);
311			$tent->{$_} = $v if defined $v;
312			}
313			$ttest->{root_uri} = $eres->uri
314			if $eres->is_type_uri (ExpandedURI q<test:RootEntity>) or
315			not defined $ttest->{root_uri};
316			}
317			my $tree_t = $tres->get_property_text (ExpandedURI q<test:domTree>);
318			if (defined $tree_t) {
319			unless ($tdt_parser) {
320			$tdt_parser = $impl->create_gls_parser
321			({
322			ExpandedURI q<DIS:TDT> => '1.0',
323			});
324			}
325			$ttest->{dom_tree} = $tdt_parser->parse_string ($tree_t);
326			}
327			}
328	wakaba	1.1
329	wakaba	1.5	for ($block->append_statement
330			->append_new_pc_expression ('=')) {
331			$_->append_new_pc_variable ('$', undef, 'TestData')
332			->variable_scope ('my');
333			$_->append_new_pc_literal (\@test);
334			}
335
336			$block->append_code_fragment ($res->pl_code_fragment);
337
338			} # test resource type
339			} # test:Test
340	wakaba	1.1	}
341
342			$num_statement->append_code (' (' . $total_tests . ')');
343
344			status_msg qq<done>;
345
346			my $output;
347			defined $out_file_path
348			? (open $output, '>', $out_file_path or die "$0: $out_file_path: $!")
349			: ($output = \*STDOUT);
350
351			if ($Opt{output_line}) {
352			$pl->owner_document->dom_config->set_parameter (ExpandedURI q<pc:line> => 1);
353			}
354
355			status_msg_ sprintf qq<Writing Perl test script %s...>,
356			defined $out_file_path
357			? q<">.$out_file_path.q<">
358			: 'to stdout';
359			print $output $pl->stringify;
360			close $output;
361			status_msg q<done>;
362			} # create_module
363
364			status_msg_ "Checking undefined resources...";
365			$db->check_undefined_resource;
366			status_msg q<done>;
367
368			status_msg_ "Closing the database...";
369			$db->free;
370			undef $db;
371			status_msg q<done>;
372
373			END {
374			use integer;
375			my $time = time - $start_time;
376			status_msg sprintf qq<%d'%02d''>, $time / 60, $time % 60;
377			}
378			exit;
379
380			sub dac_search_file_path_stem ($$$) {
381			my ($ns, $ln, $suffix) = @_;
382			require Cwd;
383			require File::Spec;
384			for my $dir ('.', @{$Opt{input_search_path}->{$ns}\|\|[]}) {
385			my $name = Cwd::abs_path
386			(File::Spec->canonpath
387			(File::Spec->catfile ($dir, $ln)));
388			if (-f $name.$suffix) {
389			return $name;
390			}
391			}
392			return undef;
393			} # dac_search_file_path_stem;
394
395			=head1 SEE ALSO
396
397			L<lib/Message/Util/DIS.dis> - The <QUOTE::dis> object implementation.
398
399			L<lib/Message/Util/DIS/Perl.dis> - The <QUOTE::dis> object implementation,
400			submodule for Perl modules.
401
402			L<lib/Message/Util/PerlCode.dis> - The Perl code generator.
403
404			L<lib/manakai/DISCore.dis> - The definition for the "dis" format.
405
406			L<lib/manakai/DISPerl.dis> - The definition for the "dis" Perl-specific
407			vocabulary.
408
409			L<bin/dac.pl> - The "dac" database generator.
410
411			=head1 LICENSE
412
413			Copyright 2004-2005 Wakaba <w@suika.fam.cx>. All rights reserved.
414
415			This program is free software; you can redistribute it and/or
416			modify it under the same terms as Perl itself.
417
418			=cut
419
420	wakaba	1.5	1; # $Date: 2005/11/23 11:21:09 $