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/09 10:23:19 $
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	c => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/dom-core#>,
32	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	DOMLS => q<http://suika.fam.cx/~wakaba/archive/2004/dom/ls#>,
35	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
161	require Error;
162	$Error::Debug = 1 if $Opt{debug};
163	$Message::Util::Error::VERBOSE = 1 if $Opt{verbose};
164
165	$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	use Message::Util::DIS::Test;
199	use Message::DOM::GenericLS;
200
201	my $start_time;
202	BEGIN { $start_time = time }
203
204	my $impl = $Message::DOM::ImplementationRegistry->get_implementation
205	({
206	ExpandedURI q<DOMLS:Generic> => '3.0',
207	'+' . ExpandedURI q<DIS:Core> => '1.0',
208	'+' . ExpandedURI q<Util:PerlCode> => '1.0',
209	'+' . ExpandedURI q<DIS:TDT> => '1.0',
210	});
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	my $tdt_parser;
214
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	$pack->add_require_perl_module_name ($mod->pl_fully_qualified_name);
251
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	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	} otherwise {
296	my $err = shift;
297	warn $err;
298	$test->not_ok;
299	};');
300
301	} elsif ($res->is_type_uri (ExpandedURI q<test:ParserTestSet>)) {
302	my $block = $pack->append_new_pc_block;
303	my @test;
304
305	$tdt_parser \|\|= $impl->create_gls_parser
306	({
307	ExpandedURI q<DIS:TDT> => '1.0',
308	});
309	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
327	## Result DOM tree
328	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
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	}
341
342	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	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
356	} # test resource type
357	} # test:Test
358	}
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	my $cfg = $pl->owner_document->dom_config;
370	$cfg->set_parameter (ExpandedURI q<pc:preserve-line-break> => 1);
371	if ($Opt{output_line}) {
372	$cfg->set_parameter (ExpandedURI q<pc:line> => 1);
373	}
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	Copyright 2004-2006 Wakaba <w@suika.fam.cx>. All rights reserved.
434
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	1; # $Date: 2006/02/09 10:23:19 $