/[suikacvs]/messaging/manakai/bin/daf.pl
Suika

Diff of /messaging/manakai/bin/daf.pl

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by wakaba, Sat Feb 25 16:49:55 2006 UTC revision 1.4 by wakaba, Mon Mar 6 07:32:51 2006 UTC
# Line 1  Line 1 
1  #!/usr/bin/perl -w  #!/usr/bin/perl -w
2  use strict;  use strict;
3  use Message::Util::QName::Filter {  use Message::Util::QName::Filter {
4      c => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/dom-core#>,
5    DIS => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#>,    DIS => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#>,
6    dis => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/lang#dis-->,    dis => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/lang#dis-->,
7      DOMLS => q<http://suika.fam.cx/~wakaba/archive/2004/dom/ls#>,
8    dp => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#Perl/>,    dp => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#Perl/>,
9    fe => q<http://suika.fam.cx/www/2006/feature/>,    fe => q<http://suika.fam.cx/www/2006/feature/>,
10    ManakaiDOM => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/manakai-dom#>,    ManakaiDOM => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/manakai-dom#>,
11      pc => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/PerlCode#>,
12    swcfg21 => q<http://suika.fam.cx/~wakaba/archive/2005/swcfg21#>,    swcfg21 => q<http://suika.fam.cx/~wakaba/archive/2005/swcfg21#>,
13      test => q<http://suika.fam.cx/~wakaba/archive/2004/dis/Test#>,
14    Util => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/>,    Util => q<http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/>,
15  };  };
16    
# Line 18  GetOptions ( Line 22  GetOptions (
22    'create-perl-module=s' => sub {    'create-perl-module=s' => sub {
23      shift;      shift;
24      my $i = [split /\s+/, shift, 3];      my $i = [split /\s+/, shift, 3];
25      $i->[3] = 'pm';      $i->[3] = 'perl-pm';
26        push @{$Opt{create_module}}, $i;
27      },
28      'create-perl-test=s' => sub {
29        shift;
30        my $i = [split /\s+/, shift, 3];
31        $i->[3] = 'perl-t';
32      push @{$Opt{create_module}}, $i;      push @{$Opt{create_module}}, $i;
33    },    },
34    'debug' => \$Opt{debug},    'debug' => \$Opt{debug},
# Line 99  sub verbose_msg_ ($) { Line 109  sub verbose_msg_ ($) {
109    print STDERR $s if $Opt{verbose};    print STDERR $s if $Opt{verbose};
110  }  }
111    
112    ## ---- The MAIN Program
113    
114  my $start_time;  my $start_time;
115  BEGIN { $start_time = time }  BEGIN { $start_time = time }
116    
117  use Message::Util::DIS::DNLite;  use Message::Util::DIS::DNLite;
118  use Message::Util::PerlCode;  use Message::Util::PerlCode;
119    use Message::Util::DIS::Test;
120    use Message::DOM::GenericLS;
121    
122  my $limpl = $Message::DOM::ImplementationRegistry->get_implementation  my $limpl = $Message::DOM::ImplementationRegistry->get_implementation
123                             ({ExpandedURI q<fe:Min> => '3.0',                             ({ExpandedURI q<fe:Min> => '3.0',
124                                 ExpandedURI q<fe:GenericLS> => '3.0',
125                               '+' . ExpandedURI q<DIS:DNLite> => '1.0',                               '+' . ExpandedURI q<DIS:DNLite> => '1.0',
126                               '+' . ExpandedURI q<DIS:Core> => '1.0',                               '+' . ExpandedURI q<DIS:Core> => '1.0',
127                               '+' . ExpandedURI q<Util:PerlCode> => '1.0',                               '+' . ExpandedURI q<Util:PerlCode> => '1.0',
128                                 '+' . ExpandedURI q<DIS:TDT> => '1.0',
129                             });                             });
130  my $impl = $limpl->get_feature (ExpandedURI q<DIS:Core> => '1.0');  my $impl = $limpl->get_feature (ExpandedURI q<DIS:Core> => '1.0');
131  my $parser = $impl->create_dis_parser;  my $pc = $impl->get_feature (ExpandedURI q<Util:PerlCode> => '1.0');
132  our $DNi = $impl->get_feature (ExpandedURI q<DIS:DNLite> => '1.0');  my $di = $impl->get_feature (ExpandedURI q<DIS:Core> => '1.0');
133    my $tdt_parser;
134    
135    ## --- Loading and Updating the Database
136    
137  my $HasError;  my $HasError;
138  my $db = $impl->create_dis_database;  my $db = $impl->create_dis_database;
139  $db->pl_database_module_resolver (\&daf_db_module_resolver);  $db->pl_database_module_resolver (\&daf_db_module_resolver);
140  $db->dom_config->set_parameter ('error-handler' => \&daf_on_error);  $db->dom_config->set_parameter ('error-handler' => \&daf_on_error);
141    
142    my $parser = $impl->create_dis_parser;
143    my $DNi = $impl->get_feature (ExpandedURI q<DIS:DNLite> => '1.0');
144  my %ModuleSourceDISDocument;  my %ModuleSourceDISDocument;
145  my %ModuleSourceDNLDocument;  my %ModuleSourceDNLDocument;
146  my %ModuleNameNamespaceBinding = (  my %ModuleNameNamespaceBinding = (
# Line 189  get_referring_module_uri_list => sub { Line 210  get_referring_module_uri_list => sub {
210      unless (defined $ModuleSourceDISDocument{$module_uri}) {      unless (defined $ModuleSourceDISDocument{$module_uri}) {
211        daf_open_source_dis_document ($module_uri);        daf_open_source_dis_document ($module_uri);
212      }      }
     daf_convert_dis_document_to_dnl_document ();  
213    }    }
214    return daf_get_referring_module_uri_list ($module_uri);    return daf_get_referring_module_uri_list ($module_uri);
215  },  },
# Line 253  status_msg "done"; Line 273  status_msg "done";
273    
274  daf_check_undefined ();  daf_check_undefined ();
275    
276    undef $DNi;
277    undef %ModuleSourceDNLDocument;
278    exit $HasError if $HasError;
279    
280    ## --- Creating Files
281    
282  for (@{$Opt{create_module}}) {  for (@{$Opt{create_module}}) {
283    my ($mod_uri, $out_file_path, $mod_for, $out_type) = @$_;    my ($mod_uri, $out_file_path, $mod_for, $out_type) = @$_;
284    unless (defined $mod_for) {    unless (defined $mod_for) {
# Line 262  for (@{$Opt{create_module}}) { Line 288  for (@{$Opt{create_module}}) {
288    }    }
289    my $mod = $db->get_module ($mod_uri, for_arg => $mod_for);    my $mod = $db->get_module ($mod_uri, for_arg => $mod_for);
290    
291    if ($out_type eq 'pm') {    if ($out_type eq 'perl-pm') {
292      status_msg_ qq<Generating Perl module from <$mod_uri> for <$mod_for>...>;      status_msg_ qq<Generating Perl module from <$mod_uri> for <$mod_for>...>;
293      my $pl = $mod->pl_generate_perl_module_file;      my $pl = $mod->pl_generate_perl_module_file;
294      status_msg qq<done>;      status_msg qq<done>;
# Line 279  for (@{$Opt{create_module}}) { Line 305  for (@{$Opt{create_module}}) {
305      print $output $pl->stringify;      print $output $pl->stringify;
306      close $output;      close $output;
307      status_msg q<done>;      status_msg q<done>;
308      } elsif ($out_type eq 'perl-t') {
309        status_msg_ qq<Generating Perl test from <$mod_uri> for <$mod_for>...>;
310        my $pl = daf_generate_perl_test_file ($mod);
311        status_msg qq<done>;
312    
313        my $cfg = $pl->owner_document->dom_config;
314        $cfg->set_parameter (ExpandedURI q<pc:preserve-line-break> => 1);
315    
316        my $output;
317        defined $out_file_path
318            ? (open $output, '>', $out_file_path or die "$0: $out_file_path: $!")
319              : ($output = \*STDOUT);
320    
321        status_msg_ sprintf qq<Writing Perl test %s...>,
322                              defined $out_file_path
323                                ? q<">.$out_file_path.q<">
324                                : 'to stdout';
325        print $output $pl->stringify;
326        close $output;
327        status_msg q<done>;
328    }    }
329  }  }
330    
331  daf_check_undefined ();  daf_check_undefined ();
332    
333    ## --- The END
334    
335  status_msg_ "Closing the database...";  status_msg_ "Closing the database...";
336  $db->free;  $db->free;
337  undef $db;  undef $db;
 undef %ModuleSourceDNLDocument;  
338  status_msg "done";  status_msg "done";
339    
 undef $DNi;  
   
340  {  {
341    use integer;    use integer;
342    my $time = time - $start_time;    my $time = time - $start_time;
# Line 303  END { Line 348  END {
348    $db->free if $db;    $db->free if $db;
349  }  }
350    
351    ## ---- Subroutines
352    
353  sub daf_open_source_dis_document ($) {  sub daf_open_source_dis_document ($) {
354    my ($module_uri) = @_;    my ($module_uri) = @_;
355    
# Line 531  sub daf_check_undefined () { Line 578  sub daf_check_undefined () {
578    }    }
579  } # daf_check_undefined  } # daf_check_undefined
580    
581    sub daf_generate_perl_test_file ($) {
582      my $mod = shift;
583      my $pl = $pc->create_perl_file;
584      my $pack = $pl->get_last_package ("Manakai::Test", make_new_package => 1);
585      $pack->add_use_perl_module_name ("Message::Util::DIS::Test");
586      $pack->add_use_perl_module_name ("Message::Util::Error");
587      $pack->add_require_perl_module_name ($mod->pl_fully_qualified_name);
588    
589      $pl->source_file ($mod->get_property_text (ExpandedURI q<DIS:sourceFile>, ""));
590      $pl->source_module ($mod->name_uri);
591      $pl->source_for ($mod->for_uri);
592      $pl->license_uri ($mod->get_property_resource (ExpandedURI q<dis:License>)
593                            ->uri);
594    
595      $pack->append_code
596        ($pc->create_perl_statement
597           ('my $impl = $Message::DOM::ImplementationRegistry->get_implementation ({
598               "http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#Test"
599                 => "1.0",
600             })'));
601    
602      $pack->append_code
603          (my $num_statement = $pc->create_perl_statement
604                                      ('my $test = $impl->create_test_manager'));
605    
606      my $total_tests = 0;
607      my %processed;
608      for my $res (@{$mod->get_resource_list}) {
609        next if $res->owner_module ne $mod or $processed{$res->uri};
610        $processed{$res->uri} = 1;
611    
612        if ($res->is_type_uri (ExpandedURI q<test:Test>)) {
613          if ($res->is_type_uri (ExpandedURI q<test:StandaloneTest>)) {
614            $total_tests++;
615            $pack->append_code ('$test->start_new_test (');
616            $pack->append_new_pc_literal ($res->name_uri || $res->uri);
617            $pack->append_code (');');
618            
619            $pack->append_code ('try {');
620            
621            my $test_pc = $res->pl_code_fragment;
622            if (not defined $test_pc) {
623              die "Perl test code not defined for <".$res->uri.">";
624            }
625            
626            $pack->append_code_fragment ($test_pc);
627            
628            $pack->append_code ('$test->ok;');
629            
630            $pack->append_code ('} catch Message::Util::IF::DTException with {
631              ##
632            } otherwise {
633              my $err = shift;
634              warn $err;
635              $test->not_ok;
636            };');
637    
638          } elsif ($res->is_type_uri (ExpandedURI q<test:ParserTestSet>)) {
639            my $block = $pack->append_new_pc_block;
640            my @test;
641            
642            $tdt_parser ||= $limpl->create_gls_parser
643                                     ({
644                                       ExpandedURI q<DIS:TDT> => '1.0',
645                                      });
646            for my $tres (@{$res->get_child_resource_list_by_type
647                                    (ExpandedURI q<test:ParserTest>)}) {
648              $total_tests++;
649              push @test, my $ttest = {entity => {}};
650              $ttest->{uri} = $tres->uri;
651              for my $eres (@{$tres->get_child_resource_list_by_type
652                                       (ExpandedURI q<test:Entity>)}) {
653                my $tent = $ttest->{entity}->{$eres->uri} = {};
654                for (ExpandedURI q<test:uri>, ExpandedURI q<test:baseURI>,
655                     ExpandedURI q<test:value>) {
656                  my $v = $eres->get_property_text ($_);
657                  $tent->{$_} = $v if defined $v;
658                }
659                $ttest->{root_uri} = $eres->uri
660                  if $eres->is_type_uri (ExpandedURI q<test:RootEntity>) or
661                     not defined $ttest->{root_uri};
662              }
663    
664              ## Result DOM tree
665              my $tree_t = $tres->get_property_text (ExpandedURI q<test:domTree>);
666              if (defined $tree_t) {
667                $ttest->{dom_tree} = $tdt_parser->parse_string ($tree_t);
668              }
669    
670              ## Expected |DOMError|s
671              for (@{$tres->get_property_value_list (ExpandedURI q<c:erred>)}) {
672                my $err = $tdt_parser->parse_tdt_error_string
673                                         ($_->string_value, $db, $_,
674                                          undef, $tres->for_uri);
675                push @{$ttest->{dom_error}->{$err->{type}->{value}} ||= []}, $err;
676              }
677            }
678    
679            for ($block->append_statement
680                       ->append_new_pc_expression ('=')) {
681              $_->append_new_pc_variable ('$', undef, 'TestData')
682                ->variable_scope ('my');
683              $_->append_new_pc_literal (\@test);
684            }
685            
686            my $plc = $res->pl_code_fragment;
687            unless ($plc) {
688              die "Resource <".$res->uri."> does not have Perl test code";
689            }
690    
691            $block->append_code_fragment ($plc);
692            
693          } # test resource type
694        } # test:Test
695      }
696      
697      $num_statement->append_code (' (' . $total_tests . ')');
698    
699      return $pl;
700    } # daf_generate_perl_test_file
701    
702  __END__  __END__
703    
704  =head1 NAME  =head1 NAME
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.4
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24