/[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.2 by wakaba, Sun Feb 26 06:42:55 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<DIS:DNLite> => '1.0',                               '+' . ExpandedURI q<DIS:DNLite> => '1.0',
125                               '+' . ExpandedURI q<DIS:Core> => '1.0',                               '+' . ExpandedURI q<DIS:Core> => '1.0',
126                               '+' . ExpandedURI q<Util:PerlCode> => '1.0',                               '+' . ExpandedURI q<Util:PerlCode> => '1.0',
127                                 '+' . ExpandedURI q<DIS:TDT> => '1.0',
128                             });                             });
129  my $impl = $limpl->get_feature (ExpandedURI q<DIS:Core> => '1.0');  my $impl = $limpl->get_feature (ExpandedURI q<DIS:Core> => '1.0');
130  my $parser = $impl->create_dis_parser;  my $pc = $impl->get_feature (ExpandedURI q<Util:PerlCode> => '1.0');
131  our $DNi = $impl->get_feature (ExpandedURI q<DIS:DNLite> => '1.0');  my $di = $impl->get_feature (ExpandedURI q<DIS:Core> => '1.0');
132    my $tdt_parser;
133    
134    ## --- Loading and Updating the Database
135    
136  my $HasError;  my $HasError;
137  my $db = $impl->create_dis_database;  my $db = $impl->create_dis_database;
138  $db->pl_database_module_resolver (\&daf_db_module_resolver);  $db->pl_database_module_resolver (\&daf_db_module_resolver);
139  $db->dom_config->set_parameter ('error-handler' => \&daf_on_error);  $db->dom_config->set_parameter ('error-handler' => \&daf_on_error);
140    
141    my $parser = $impl->create_dis_parser;
142    my $DNi = $impl->get_feature (ExpandedURI q<DIS:DNLite> => '1.0');
143  my %ModuleSourceDISDocument;  my %ModuleSourceDISDocument;
144  my %ModuleSourceDNLDocument;  my %ModuleSourceDNLDocument;
145  my %ModuleNameNamespaceBinding = (  my %ModuleNameNamespaceBinding = (
# 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 $output;
314        defined $out_file_path
315            ? (open $output, '>', $out_file_path or die "$0: $out_file_path: $!")
316              : ($output = \*STDOUT);
317    
318        status_msg_ sprintf qq<Writing Perl test %s...>,
319                              defined $out_file_path
320                                ? q<">.$out_file_path.q<">
321                                : 'to stdout';
322        print $output $pl->stringify;
323        close $output;
324        status_msg q<done>;
325    }    }
326  }  }
327    
328  daf_check_undefined ();  daf_check_undefined ();
329    
330    ## --- The END
331    
332  status_msg_ "Closing the database...";  status_msg_ "Closing the database...";
333  $db->free;  $db->free;
334  undef $db;  undef $db;
 undef %ModuleSourceDNLDocument;  
335  status_msg "done";  status_msg "done";
336    
 undef $DNi;  
   
337  {  {
338    use integer;    use integer;
339    my $time = time - $start_time;    my $time = time - $start_time;
# Line 303  END { Line 345  END {
345    $db->free if $db;    $db->free if $db;
346  }  }
347    
348    ## ---- Subroutines
349    
350  sub daf_open_source_dis_document ($) {  sub daf_open_source_dis_document ($) {
351    my ($module_uri) = @_;    my ($module_uri) = @_;
352    
# Line 531  sub daf_check_undefined () { Line 575  sub daf_check_undefined () {
575    }    }
576  } # daf_check_undefined  } # daf_check_undefined
577    
578    sub daf_generate_perl_test_file ($) {
579      my $mod = shift;
580      my $pl = $pc->create_perl_file;
581      my $pack = $pl->get_last_package ("Manakai::Test", make_new_package => 1);
582      $pack->add_use_perl_module_name ("Message::Util::DIS::Test");
583      $pack->add_use_perl_module_name ("Message::Util::Error");
584      $pack->add_require_perl_module_name ($mod->pl_fully_qualified_name);
585    
586      $pl->source_file ($mod->get_property_text (ExpandedURI q<DIS:sourceFile>, ""));
587      $pl->source_module ($mod->name_uri);
588      $pl->source_for ($mod->for_uri);
589      $pl->license_uri ($mod->get_property_resource (ExpandedURI q<dis:License>)
590                            ->uri);
591    
592      $pack->append_code
593        ($pc->create_perl_statement
594           ('my $impl = $Message::DOM::ImplementationRegistry->get_implementation ({
595               "http://suika.fam.cx/~wakaba/archive/2005/manakai/Util/DIS#Test"
596                 => "1.0",
597             })'));
598    
599      $pack->append_code
600          (my $num_statement = $pc->create_perl_statement
601                                      ('my $test = $impl->create_test_manager'));
602    
603      my $total_tests = 0;
604      my %processed;
605      for my $res (@{$mod->get_resource_list}) {
606        next if $res->owner_module ne $mod or $processed{$res->uri};
607        $processed{$res->uri} = 1;
608    
609        if ($res->is_type_uri (ExpandedURI q<test:Test>)) {
610          if ($res->is_type_uri (ExpandedURI q<test:StandaloneTest>)) {
611            $total_tests++;
612            $pack->append_code ('$test->start_new_test (');
613            $pack->append_new_pc_literal ($res->name_uri || $res->uri);
614            $pack->append_code (');');
615            
616            $pack->append_code ('try {');
617            
618            my $test_pc = $res->pl_code_fragment;
619            if (not defined $test_pc) {
620              die "Perl test code not defined for <".$res->uri.">";
621            }
622            
623            $pack->append_code_fragment ($test_pc);
624            
625            $pack->append_code ('$test->ok;');
626            
627            $pack->append_code ('} catch Message::Util::IF::DTException with {
628              ##
629            } otherwise {
630              my $err = shift;
631              warn $err;
632              $test->not_ok;
633            };');
634    
635          } elsif ($res->is_type_uri (ExpandedURI q<test:ParserTestSet>)) {
636            my $block = $pack->append_new_pc_block;
637            my @test;
638            
639            $tdt_parser ||= $impl->create_gls_parser
640                                     ({
641                                       ExpandedURI q<DIS:TDT> => '1.0',
642                                      });
643            for my $tres (@{$res->get_child_resource_list_by_type
644                                    (ExpandedURI q<test:ParserTest>)}) {
645              $total_tests++;
646              push @test, my $ttest = {entity => {}};
647              $ttest->{uri} = $tres->uri;
648              for my $eres (@{$tres->get_child_resource_list_by_type
649                                       (ExpandedURI q<test:Entity>)}) {
650                my $tent = $ttest->{entity}->{$eres->uri} = {};
651                for (ExpandedURI q<test:uri>, ExpandedURI q<test:baseURI>,
652                     ExpandedURI q<test:value>) {
653                  my $v = $eres->get_property_text ($_);
654                  $tent->{$_} = $v if defined $v;
655                }
656                $ttest->{root_uri} = $eres->uri
657                  if $eres->is_type_uri (ExpandedURI q<test:RootEntity>) or
658                     not defined $ttest->{root_uri};
659              }
660    
661              ## Result DOM tree
662              my $tree_t = $tres->get_property_text (ExpandedURI q<test:domTree>);
663              if (defined $tree_t) {
664                $ttest->{dom_tree} = $tdt_parser->parse_string ($tree_t);
665              }
666    
667              ## Expected |DOMError|s
668              for (@{$tres->get_property_value_list (ExpandedURI q<c:erred>)}) {
669                my $err = $tdt_parser->parse_tdt_error_string
670                                         ($_->string_value, $db, $_,
671                                          undef, $tres->for_uri);
672                push @{$ttest->{dom_error}->{$err->{type}->{value}} ||= []}, $err;
673              }
674            }
675    
676            for ($block->append_statement
677                       ->append_new_pc_expression ('=')) {
678              $_->append_new_pc_variable ('$', undef, 'TestData')
679                ->variable_scope ('my');
680              $_->append_new_pc_literal (\@test);
681            }
682            
683            my $plc = $res->pl_code_fragment;
684            unless ($plc) {
685              die "Resource <".$res->uri."> does not have Perl test code";
686            }
687    
688            $block->append_code_fragment ($plc);
689            
690          } # test resource type
691        } # test:Test
692      }
693      
694      $num_statement->append_code (' (' . $total_tests . ')');
695    
696      return $pl;
697    } # daf_generate_perl_test_file
698    
699  __END__  __END__
700    
701  =head1 NAME  =head1 NAME
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24