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);
        }
        
        my $plc = $res->pl_code_fragment;
        unless ($plc) {
          die "Resource <".$res->uri."> does not have Perl test code";
        }

        $block->append_code_fragment ($plc);
        
      } # 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-2006 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: 2006/01/21 16:28:13 $
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	wakaba	1.6	my $plc = $res->pl_code_fragment;
337			unless ($plc) {
338			die "Resource <".$res->uri."> does not have Perl test code";
339			}
340
341			$block->append_code_fragment ($plc);
342	wakaba	1.5
343			} # test resource type
344			} # test:Test
345	wakaba	1.1	}
346
347			$num_statement->append_code (' (' . $total_tests . ')');
348
349			status_msg qq<done>;
350
351			my $output;
352			defined $out_file_path
353			? (open $output, '>', $out_file_path or die "$0: $out_file_path: $!")
354			: ($output = \*STDOUT);
355
356			if ($Opt{output_line}) {
357			$pl->owner_document->dom_config->set_parameter (ExpandedURI q<pc:line> => 1);
358			}
359
360			status_msg_ sprintf qq<Writing Perl test script %s...>,
361			defined $out_file_path
362			? q<">.$out_file_path.q<">
363			: 'to stdout';
364			print $output $pl->stringify;
365			close $output;
366			status_msg q<done>;
367			} # create_module
368
369			status_msg_ "Checking undefined resources...";
370			$db->check_undefined_resource;
371			status_msg q<done>;
372
373			status_msg_ "Closing the database...";
374			$db->free;
375			undef $db;
376			status_msg q<done>;
377
378			END {
379			use integer;
380			my $time = time - $start_time;
381			status_msg sprintf qq<%d'%02d''>, $time / 60, $time % 60;
382			}
383			exit;
384
385			sub dac_search_file_path_stem ($$$) {
386			my ($ns, $ln, $suffix) = @_;
387			require Cwd;
388			require File::Spec;
389			for my $dir ('.', @{$Opt{input_search_path}->{$ns}\|\|[]}) {
390			my $name = Cwd::abs_path
391			(File::Spec->canonpath
392			(File::Spec->catfile ($dir, $ln)));
393			if (-f $name.$suffix) {
394			return $name;
395			}
396			}
397			return undef;
398			} # dac_search_file_path_stem;
399
400			=head1 SEE ALSO
401
402			L<lib/Message/Util/DIS.dis> - The <QUOTE::dis> object implementation.
403
404			L<lib/Message/Util/DIS/Perl.dis> - The <QUOTE::dis> object implementation,
405			submodule for Perl modules.
406
407			L<lib/Message/Util/PerlCode.dis> - The Perl code generator.
408
409			L<lib/manakai/DISCore.dis> - The definition for the "dis" format.
410
411			L<lib/manakai/DISPerl.dis> - The definition for the "dis" Perl-specific
412			vocabulary.
413
414			L<bin/dac.pl> - The "dac" database generator.
415
416			=head1 LICENSE
417
418	wakaba	1.7	Copyright 2004-2006 Wakaba <w@suika.fam.cx>. All rights reserved.
419	wakaba	1.1
420			This program is free software; you can redistribute it and/or
421			modify it under the same terms as Perl itself.
422
423			=cut
424
425	wakaba	1.7	1; # $Date: 2006/01/21 16:28:13 $