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 {
          ##
        } otherwise {
          my $err = shift;
          warn $err;
          $test->not_ok;
        };');

      } 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/23 12:43:33 $
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	wakaba	1.8	} otherwise {
295			my $err = shift;
296			warn $err;
297			$test->not_ok;
298	wakaba	1.5	};');
299
300			} elsif ($res->is_type_uri (ExpandedURI q<test:ParserTestSet>)) {
301			my $block = $pack->append_new_pc_block;
302			my @test;
303
304			for my $tres (@{$res->get_child_resource_list_by_type
305			(ExpandedURI q<test:ParserTest>)}) {
306			$total_tests++;
307			push @test, my $ttest = {entity => {}};
308			$ttest->{uri} = $tres->uri;
309			for my $eres (@{$tres->get_child_resource_list_by_type
310			(ExpandedURI q<test:Entity>)}) {
311			my $tent = $ttest->{entity}->{$eres->uri} = {};
312			for (ExpandedURI q<test:uri>, ExpandedURI q<test:baseURI>,
313			ExpandedURI q<test:value>) {
314			my $v = $eres->get_property_text ($_);
315			$tent->{$_} = $v if defined $v;
316			}
317			$ttest->{root_uri} = $eres->uri
318			if $eres->is_type_uri (ExpandedURI q<test:RootEntity>) or
319			not defined $ttest->{root_uri};
320			}
321			my $tree_t = $tres->get_property_text (ExpandedURI q<test:domTree>);
322			if (defined $tree_t) {
323			unless ($tdt_parser) {
324			$tdt_parser = $impl->create_gls_parser
325			({
326			ExpandedURI q<DIS:TDT> => '1.0',
327			});
328			}
329			$ttest->{dom_tree} = $tdt_parser->parse_string ($tree_t);
330			}
331			}
332	wakaba	1.1
333	wakaba	1.5	for ($block->append_statement
334			->append_new_pc_expression ('=')) {
335			$_->append_new_pc_variable ('$', undef, 'TestData')
336			->variable_scope ('my');
337			$_->append_new_pc_literal (\@test);
338			}
339
340	wakaba	1.6	my $plc = $res->pl_code_fragment;
341			unless ($plc) {
342			die "Resource <".$res->uri."> does not have Perl test code";
343			}
344
345			$block->append_code_fragment ($plc);
346	wakaba	1.5
347			} # test resource type
348			} # test:Test
349	wakaba	1.1	}
350
351			$num_statement->append_code (' (' . $total_tests . ')');
352
353			status_msg qq<done>;
354
355			my $output;
356			defined $out_file_path
357			? (open $output, '>', $out_file_path or die "$0: $out_file_path: $!")
358			: ($output = \*STDOUT);
359
360			if ($Opt{output_line}) {
361			$pl->owner_document->dom_config->set_parameter (ExpandedURI q<pc:line> => 1);
362			}
363
364			status_msg_ sprintf qq<Writing Perl test script %s...>,
365			defined $out_file_path
366			? q<">.$out_file_path.q<">
367			: 'to stdout';
368			print $output $pl->stringify;
369			close $output;
370			status_msg q<done>;
371			} # create_module
372
373			status_msg_ "Checking undefined resources...";
374			$db->check_undefined_resource;
375			status_msg q<done>;
376
377			status_msg_ "Closing the database...";
378			$db->free;
379			undef $db;
380			status_msg q<done>;
381
382			END {
383			use integer;
384			my $time = time - $start_time;
385			status_msg sprintf qq<%d'%02d''>, $time / 60, $time % 60;
386			}
387			exit;
388
389			sub dac_search_file_path_stem ($$$) {
390			my ($ns, $ln, $suffix) = @_;
391			require Cwd;
392			require File::Spec;
393			for my $dir ('.', @{$Opt{input_search_path}->{$ns}\|\|[]}) {
394			my $name = Cwd::abs_path
395			(File::Spec->canonpath
396			(File::Spec->catfile ($dir, $ln)));
397			if (-f $name.$suffix) {
398			return $name;
399			}
400			}
401			return undef;
402			} # dac_search_file_path_stem;
403
404			=head1 SEE ALSO
405
406			L<lib/Message/Util/DIS.dis> - The <QUOTE::dis> object implementation.
407
408			L<lib/Message/Util/DIS/Perl.dis> - The <QUOTE::dis> object implementation,
409			submodule for Perl modules.
410
411			L<lib/Message/Util/PerlCode.dis> - The Perl code generator.
412
413			L<lib/manakai/DISCore.dis> - The definition for the "dis" format.
414
415			L<lib/manakai/DISPerl.dis> - The definition for the "dis" Perl-specific
416			vocabulary.
417
418			L<bin/dac.pl> - The "dac" database generator.
419
420			=head1 LICENSE
421
422	wakaba	1.7	Copyright 2004-2006 Wakaba <w@suika.fam.cx>. All rights reserved.
423	wakaba	1.1
424			This program is free software; you can redistribute it and/or
425			modify it under the same terms as Perl itself.
426
427			=cut
428
429	wakaba	1.8	1; # $Date: 2006/01/23 12:43:33 $