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 {
  c => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/dom-core#>,
  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;
        
        $tdt_parser ||= $impl->create_gls_parser
                                 ({
                                   ExpandedURI q<DIS:TDT> => '1.0',
                                  });
        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};
          }

          ## Result DOM tree
          my $tree_t = $tres->get_property_text (ExpandedURI q<test:domTree>); 
          if (defined $tree_t) {
            $ttest->{dom_tree} = $tdt_parser->parse_string ($tree_t);
          }

          ## Expected |DOMError|s
          for (@{$tres->get_property_value_list (ExpandedURI q<c:erred>)}) {
            my $err = $tdt_parser->parse_tdt_error_string
                                     ($_->string_value, $db, $_,
                                      undef, $tres->for_uri);
            push @{$ttest->{dom_error}->{$err->{type}->{value}} ||= []}, $err;
          }
        }

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

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