/[pub]/suikawiki/script/bin/mkplugin2.pl
Suika

Diff of /suikawiki/script/bin/mkplugin2.pl

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

revision 1.6 by wakaba, Wed Nov 26 09:11:01 2003 UTC revision 1.17 by wakaba, Sat May 1 03:55:05 2004 UTC
# Line 56  sub barecode ($) { Line 56  sub barecode ($) {
56  sub code ($$) {  sub code ($$) {
57    my ($Info, $code) = @_;    my ($Info, $code) = @_;
58    for (keys %{$Info->{const}}) {    for (keys %{$Info->{const}}) {
59      $code =~ s/\$$_\b/literal $Info->{const}->{$_}/ge;      $code =~ s/\$$_\b/$Info->{const}->{$_}/ge;
60    }    }
61    $code =~ s/__FUNCPACK__/$Info->{module_name}/g;    $code =~ s/__FUNCPACK__/$Info->{module_name}/g;
62      $code =~ s{<Q:([^:]+):([^>]+)>}{
63        if ($Info->{Namespace}->{$1}) {
64          literal $Info->{Namespace}->{$1}.$2;
65        } else {
66          warn qq(Namespace prefix "$1" not defined);
67          literal $2;
68        }
69      }ge;
70      
71      $Info->{-message_error_used} = 1 if $code =~ /\buse\s+Message::Util::Error\b/;
72      if (not $Info->{-message_error_used} and
73         ($code =~ /\btry\s*\{/ or $code =~ /\bcatch\s*\{/)) {
74        warn "Message::Util::Error MUST be 'use'd before 'try'...'catch' block used";
75      }
76    $code;    $code;
77  }  }
78  sub change_package ($$) {  sub change_package ($$) {
# Line 88  sub line ($;%) { Line 102  sub line ($;%) {
102                             $Info->{Name},                             $Info->{Name},
103                             $opt{realfile};                             $opt{realfile};
104      } else {      } else {
105        $opt{file} = sprintf '(WikiPlugin module %s, block %s)',        $opt{file} = sprintf '(WikiPlugin module source %s, block %s)',
106                             $Info->{Name},                             $Info->{source_file},
107                             $opt{node_path};                             $opt{node_path};
108      }      }
109    }    }
# Line 97  sub line ($;%) { Line 111  sub line ($;%) {
111    $opt{file} =~ s/"/''/g;    $opt{file} =~ s/"/''/g;
112    sprintf '%s#line %d "%s"%s', "\n", $opt{line_no} || 1, $opt{file}, "\n";    sprintf '%s#line %d "%s"%s', "\n", $opt{line_no} || 1, $opt{file}, "\n";
113  }  }
114    sub literal_or_code ($$) {
115      my ($Info, $s) = @_;
116      substr ($s, 0, 1) ne '{' ? literal ($s)
117                               : code ($Info, substr ($s, 1, length ($s) - 2));
118    }
119    
120  my $parser = Message::Markup::SuikaWikiConfig20::Parser->new;  my $parser = Message::Markup::SuikaWikiConfig20::Parser->new;
121  my $plugins = $parser->parse_text ($src);  my $plugins = $parser->parse_text ($src);
# Line 104  my $meta = $plugins->get_attribute ('Plu Line 123  my $meta = $plugins->get_attribute ('Plu
123            or die "$0: Required 'Plugin' section not found";            or die "$0: Required 'Plugin' section not found";
124  my %Info = (provide => {},  my %Info = (provide => {},
125              Name => n11n $meta->get_attribute ('Name')->value);              Name => n11n $meta->get_attribute ('Name')->value);
126    $Info{source_file} = $srcfile;
127  $Info{name_literal} = literal $Info{Name};  $Info{name_literal} = literal $Info{Name};
128  my @date = gmtime;  my @date = gmtime;
129  $Info{LastModified} = sprintf '%04d-%02d-%02dT%02d:%02d:%02d+00:00',  $Info{LastModified} = sprintf '%04d-%02d-%02dT%02d:%02d:%02d+00:00',
# Line 122  our \%Info; Line 142  our \%Info;
142  \$Info{$Info{name_literal}}->{Name} = $Info{name_literal};  \$Info{$Info{name_literal}}->{Name} = $Info{name_literal};
143  EOH  EOH
144  for (qw/Version InterfaceVersion mkpluginVersion module_name/) {  for (qw/Version InterfaceVersion mkpluginVersion module_name/) {
145    print qq{\$Info{$Info{name_literal}}->{$_} = @{[literal $Info{$_}]};\n};    print qq{\$Info{$Info{name_literal}}->{@{[literal $_]}} = @{[literal $Info{$_}]};\n};
146  }  }
147  for (qw/LastModified/) {  for (qw/LastModified Date.RCS/) {
148    $Info{$_} = n11n $meta->get_attribute ($_,make_new_node=>1)->value;    $Info{$_} = n11n $meta->get_attribute ($_,make_new_node=>1)->value;
149    next unless length $Info{$_};    next unless length $Info{$_};
150    print qq{\$Info{$Info{name_literal}}->{$_} = } . literal $Info{$_};    print qq{\$Info{$Info{name_literal}}->{@{[literal $_]}} = } . literal $Info{$_};
151    print ";\n";    print ";\n";
152  }  }
153  for (qw/RequiredPlugin RequiredModule/) {  for (qw/RequiredPlugin RequiredModule/) {
# Line 152  print qq{\$Info{$Info{name_literal}}->{A Line 172  print qq{\$Info{$Info{name_literal}}->{A
172  } grep { $_->local_name eq 'Author' } @{$meta->child_nodes}  } grep { $_->local_name eq 'Author' } @{$meta->child_nodes}
173  ). qq{];\n};  ). qq{];\n};
174    
175    for (@{$meta->get_attribute ('Namespace', make_new_node => 1)->child_nodes}) {
176      $Info{Namespace}->{$_->local_name} = $_->value;
177    }
178    
179  my $use = $meta->get_attribute ('Use');  my $use = $meta->get_attribute ('Use');
180  if (ref $use) {  if (ref $use) {
181    print change_package \%Info, $Info{module_name};    print change_package \%Info, $Info{module_name};
182    print line \%Info, node_path => 'Plugin/Use';    print line \%Info, node_path => 'Plugin/Use';
183    print $use->inner_text, "\n";    print code \%Info, $use->inner_text;
184    print line \%Info, reset => 1;    print line \%Info, reset => 1;
185  }  }
186    
# Line 175  for (@{$plugins->child_nodes}) { Line 199  for (@{$plugins->child_nodes}) {
199      register_plugin_const ($_, \%Info);      register_plugin_const ($_, \%Info);
200    } elsif ($_->local_name eq 'Format') {    } elsif ($_->local_name eq 'Format') {
201      print "\n", make_format ($_, \%Info);      print "\n", make_format ($_, \%Info);
202      } elsif ($_->local_name eq 'FormattingRuleAlias') {
203        print "\n", make_rule_alias ($_, \%Info);
204    # Parameter
205    # PluginCategory
206    }    }
207  }  }
208    
# Line 190  sub make_format ($$) { Line 218  sub make_format ($$) {
218    my ($src, $Info) = @_;    my ($src, $Info) = @_;
219    my $module_name = 'SuikaWiki::Format::Definition::'.$src->get_attribute_value ('ModuleName');    my $module_name = 'SuikaWiki::Format::Definition::'.$src->get_attribute_value ('ModuleName');
220    my $r = change_package $Info, $module_name;    my $r = change_package $Info, $module_name;
221      local $Info->{-message_error_used} = 0;  
222    $r .= qq{our \@ISA;\n};    $r .= qq{our \@ISA;\n};
223    if (my $isa = $src->get_attribute_value ('Inherit')) {    if (my $isa = $src->get_attribute_value ('Inherit')) {
224      for (@$isa) {      for (@$isa) {
# Line 199  sub make_format ($$) { Line 228  sub make_format ($$) {
228      $r .= qq{push \@ISA, 'SuikaWiki::Format::Definition::template';\n};          $r .= qq{push \@ISA, 'SuikaWiki::Format::Definition::template';\n};    
229    }    }
230    if (my $name = $src->get_attribute_value ('Name')) {    if (my $name = $src->get_attribute_value ('Name')) {
231      $r .= qq{\$SuikaWiki::Format::Definition::Class{@{[literal '/'.$name.'/'.$src->get_attribute_value ('Version', default => '').'//']}} = '$module_name';\n};      $r .= qq{\$SuikaWiki::Format::Definition::Class{@{[literal 'MAGIC:'.$name.'/'.$src->get_attribute_value ('Version', default => '').'##']}} = '$module_name';\n};
232    }    }
233    if (my $type = $src->get_attribute_value ('Type')) {    if (my $type = $src->get_attribute_value ('Type')) {
234      $r .= qq{\$SuikaWiki::Format::Definition::Class{@{[literal $type.'//']}} = '$module_name';\n};      $type .= join '', map {
235                   ';'. $_->local_name .'='. quoted_string $_->inner_text
236                 } sort {
237                   $a->local_name cmp $b->local_name
238                 } @{$src->get_attribute ('Type')->child_nodes};
239        $r .= qq{\$SuikaWiki::Format::Definition::Class{@{[literal 'IMT:'.$type.'##']}} = '$module_name';\n};
240    }    }
241        
242    $r .= line $Info, line_no => __LINE__ + 2, realfile => __FILE__;    my $convert = line $Info, line_no => __LINE__ + 2, realfile => __FILE__;
243    $r .= <<'EOH';    $convert .= <<'EOH';
244  our $Converter;  our $Converter;
245  sub convert ($$;%) {  sub convert ($$;%) {
246    my ($self, $source, %opt) = @_;    my ($self, $source, %opt) = @_;
247    my $converter;    my $t = SuikaWiki::Format::Definition->serialize_media_type (%opt);
248    my $flag = '//';    my $converter = $Converter->{$t->{_}};
249    $flag .= 'f' if $opt{IsFragment};    return ($converter->{$opt{return_type} or 'Main'} or
250    $flag .= 'p' if $opt{IsPlaceholder};            CORE::die "Buggy implementation: $t->{_}/@{[$opt{return_type} or 'Main']} not defined")
251    if ($Converter->{$opt{Type}.$flag}) {           ->($self, $source, \%opt)
252      $converter = $Converter->{$opt{Type}.$flag};      if $converter;
   } elsif ($Converter->{$opt{Name}.'/'.$opt{Version}.$flag}) {  
     $converter = $Converter->{'/'.$opt{Name}.'/'.$opt{Version}.$flag};  
   }  
   return $converter->{Main}->($self, $source, \%opt) if $converter;  
253    $self->SUPER::convert ($source, %opt);    $self->SUPER::convert ($source, %opt);
254  }  }
255  EOH  EOH
256        
   my $reset = 0;  
257    for (@{$src->child_nodes}) {    for (@{$src->child_nodes}) {
258      if ($_->local_name eq 'Converter') {      if ($_->local_name eq 'Converter') {
259        $r .= line $Info, reset => 1 unless $reset;        if ($convert) {
260            $r .= $convert;
261            $r .= line $Info, reset => 1;
262            undef $convert;
263          }
264        $r .= make_format_converter ($_, $Info);        $r .= make_format_converter ($_, $Info);
265        $reset = 1;      } elsif ($_->local_name eq 'WikiForm') {
266          $r .= q(sub wikiform {)."\n".q(my ($self, $source, %opt) = @_;);
267          $r .= line $Info, node_path => qq(Format[module-name()=$module_name]/WikiForm);
268          $r .= code $Info, $_->get_attribute_value ('Main');
269          $r .= line $Info, reset => 1;
270          $r .= qq(}\n);
271        } elsif ($_->local_name eq 'HeadSummary') {
272          $r .= q(sub headsummary {)."\n".q(my ($self, $source, %opt) = @_;);
273          $r .= line $Info, node_path => qq(Format[module-name()=$module_name]/HeadSummary);
274          $r .= code $Info, $_->get_attribute_value ('Main');
275          $r .= line $Info, reset => 1;
276          $r .= qq(}\n);
277        } elsif ($_->local_name eq 'NextIndex') {
278          my $name = $_->get_attribute_value ('Name', default => '');
279          $r .= q(sub next_index_for_).$name
280             .  q( {)."\n".q(my ($self, $source, %opt) = @_;)
281             .  line $Info, node_path => qq(Format[module-name()=$module_name]/NextIndex[Name=$name]);
282          $r .= code $Info, $_->get_attribute_value ('Main');
283          $r .= line $Info, reset => 1;
284          $r .= qq(}\n);
285      } elsif ($_->local_name eq 'Use') {      } elsif ($_->local_name eq 'Use') {
286        $r .= line $Info, node_path => qq(Format[module-name()=$module_name]/Use);        $r .= line $Info, node_path => qq(Format[module-name()=$module_name]/Use);
287        $r .= $_->inner_text;        $r .= code $Info, $_->inner_text;
       $reset = 0;  
288      }      }
289    }    }
   $r .= line $Info, reset => 1 unless $reset;  
     
290    $r;    $r;
291  }  }
292    
293  sub make_format_converter ($$) {  sub make_format_converter ($$) {
294    my ($src, $Info) = @_;    my ($src, $Info) = @_;
295    my %def;    my %def;
296    $def{Type} = $src->get_attribute ('Type');    for (qw/Type Name Version TypeURIReference IsFragment IsPlaceholder/) {
297    if (ref $def{Type}) {      $def{$_} = $src->get_attribute_value ($_);
298      $def{Type} = $def{Type}->inner_text      delete $def{$_} unless defined $def{$_};
299            . join '', map {    }
300                ';'. $_->local_name .'='. quoted_string $_->inner_text    $def{Type_param} = {map {$_->local_name => $_->value}
301              } sort {                                @{$src->get_attribute ('Type', make_new_node => 1)
302                $a->local_name cmp $b->local_name                                    ->child_nodes}};
303              } @{$def{Type}->child_nodes};    my $type = serialize_media_type ($Info,
304    } else {                 Type => $def{Type},
305      delete $def{Type};                 Type_param => $def{Type_param},
306                   Name => $def{Name},
307                   Version => $def{Version},
308                   URIReference => $def{TypeURIReference},
309                   IsFragment => $def{IsFragment},
310                   IsPlaceholder => $def{IsPlaceholder});
311      $def{serialized_type} = $type->{_};
312      
313      for (qw/Main ToString ToOctetStream/) {
314        my $def = $src->get_attribute_value ($_);
315        next unless $def;
316        $def{$_} = line ($Info, node_path => '//Converter/'.$_)
317                   . $def
318                   . line ($Info, reset => 1);
319        if ($def{$_} =~ /\$r\b/) {
320          $def{$_} = 'my $r;'."\n".$def{$_}."\n".'$r';
321        }
322        $def{$_} = barecode code $Info,
323                     'sub {my ($self, $source, $opt) = @_;'
324                   . $def{$_} . '}';
325    }    }
   $def{Name} = $src->get_attribute_value ('Name');  
   delete $def{Name} unless defined $def{Name};  
   $def{Version} = $src->get_attribute_value ('Version');  
   delete $def{Version} if not defined $def{Version} or  
                           not defined $def{Name};  
     
   my $flag = '//';  
   $flag .= 'f' and $def{IsFragment} = 1  
     if $src->get_attribute_value ('IsFragment');  
   $flag .= 'p' and $def{IsPlaceholder} = 1  
     if $src->get_attribute_value ('IsPlaceholder');  
     
   $def{Main} = $src->get_attribute_value ('Main');  
   $def{Main} = line ($Info, node_path => '//Converter/Main')  
              . $def{Main}  
              . line ($Info, reset => 1);  
   if ($def{Main} =~ /\$r\b/) {  
     $def{Main} = 'my $r;'."\n".$def{Main}."\n".'$r';  
   }  
   $def{Main} = barecode code $Info,  
                'sub {my ($self, $source, $opt) = @_;'  
              . $def{Main} . '}';  
326        
327    my $r = list %def;    my $r = list %def;
328    if ($def{Type}) {    if ($type->{Type}) {
329      $r = qq{\$Converter->{@{[literal $def{Type}.$flag]}} = {$r};\n};      $r = qq{\$Converter->{@{[literal $type->{Type}]}} = {$r};\n};
330      $r .= qq{\$Converter->{@{[literal '/'.$def{Name}.'/'.$def{Version}.$flag]}} = \$Converter->{@{[literal $def{Type}.$flag]}};\n}      $r .= qq{\$Converter->{@{[literal $type->{Magic}]}} = \$Converter->{@{[literal $type->{Type}]}};\n}
331        if $def{Name};        if $type->{Magic};
332    } elsif ($def{Name}) {      $r .= qq{\$Converter->{@{[literal $type->{URIReference}]}} = \$Converter->{@{[literal $type->{Type}]}};\n}
333      $r = qq{\$Converter->{@{[literal '/'.$def{Name}.'/'.$def{Version}.$flag]}} = {$r};\n};        if $type->{URIReference};
334      $r    } elsif ($type->{Magic}) {
335        $r = qq{\$Converter->{@{[literal $type->{Magic}]}} = {$r};\n};
336        $r .= qq{\$Converter->{@{[literal $type->{URIReference}]}} = \$Converter->{@{[literal $type->{Magic}]}};\n}
337          if $type->{URIReference};
338      } elsif ($type->{URIReference}) {
339        $r = qq{\$Converter->{@{[literal $type->{URIReference}]}} = {$r};\n};
340      } else {
341        $r = 'BEGIN { die "Invalid Syntax of Converter: Type or Name or TypeURIReference property required" }';
342    }    }
343    $r;    $r;
344  }  }
345    
346    sub serialize_media_type ($%) {
347      my ($Info, %opt) = @_;
348      my %return;
349      if ($opt{Type}) {
350        $return{Type} = 'IMT:'.$opt{Type};
351        if ($opt{Type_param}) {
352          $return{Type} .= join '', map {my $s;
353                             ';'. $_ .'="'
354                           . (($s = $opt{Type_param}->{$_}) =~ s/([\\"])/\\$1/g, $s)
355                           . '"'
356                           } sort {
357                             $a cmp $b
358                           } keys %{$opt{Type_param}};
359        }
360      }
361      if ($opt{Magic}) {
362        $return{Magic} = 'MAGIC:'.$opt{Magic};
363      } elsif ($opt{Name}) {
364        $return{Name} = 'MAGIC:'.$opt{Name}.'/*';
365        $return{Magic} = 'MAGIC:'.$opt{Name}.'/'.$opt{Version} if $opt{Version};
366      }
367      if ($opt{URIReference}) {
368        $return{URIReference} = $opt{URIReference};
369      }
370      my $flag = '##';
371      $flag .= 'f' if $opt{IsFragment};
372      $flag .= 'p' if $opt{IsPlaceholder};
373      for (qw/URIReference Type Magic Name/) {
374        $return{$_} .= $flag if $return{$_};
375      }
376      $return{_} = $return{URIReference} || $return{Type}
377                || $return{Magic} || $return{Name};
378      \%return;
379    }
380    
381    
382  sub make_function ($$) {  sub make_function ($$) {
383    my ($src, $Info) = @_;    my ($src, $Info) = @_;
384    ## TODO: support of ARGV property    ## TODO: support of ARGV property
# Line 299  sub make_function ($$) { Line 388  sub make_function ($$) {
388  sub @{[$name = $src->get_attribute_value ('Name')]} {  sub @{[$name = $src->get_attribute_value ('Name')]} {
389  @{[line $Info, node_path => "Function[Name='$name']/Main"]}@{[  @{[line $Info, node_path => "Function[Name='$name']/Main"]}@{[
390    code $Info, $src->get_attribute_value ('Main')    code $Info, $src->get_attribute_value ('Main')
391  ]}@{[line $Info, reset => 1]}  ]}
392  }  }
393    @{[line $Info, reset => 1]}
394  EOH  EOH
395  }  }
396    
397  sub register_plugin_const ($$) {  sub register_plugin_const ($$) {
398    my ($src, $Info) = @_;    my ($src, $Info) = @_;
399    for (@{$src->child_nodes}) {    for (@{$src->child_nodes}) {
400      $Info->{const}->{$_->local_name} = $_->value;      $Info->{const}->{$_->local_name} = literal_or_code $Info, $_->value;
401    }    }
402  }  }
403    
404  sub make_resdef ($$) {  sub make_resdef ($$) {
405    my ($src, $Info) = @_;    my ($src, $Info) = @_;
406    my $r = change_package $Info, 'SuikaWiki::Plugin::Resource';    my $r = change_package $Info, 'SuikaWiki::Plugin::Resource';
407      local $Info->{-message_error_used} = 0;  
408    $r .= qq{our \$BaseResource;\n};    $r .= qq{our \$BaseResource;\n};
409    for (@{$src->child_nodes}) {    for (@{$src->child_nodes}) {
410      if ($_->node_type eq '#element') {      if ($_->node_type eq '#element') {
# Line 361  sub make_viewdef ($$) { Line 452  sub make_viewdef ($$) {
452    my $ViewProp = {};    my $ViewProp = {};
453    my $r = '';    my $r = '';
454    $ViewProp->{Name} = n11n $src->get_attribute_value ('Mode');    $ViewProp->{Name} = n11n $src->get_attribute_value ('Mode');
455      $ViewProp->{Name} =~ s/(?<=.)-/_/g;
456    $ViewProp->{pack_name} = random_module_name ($Info, $ViewProp->{Name});    $ViewProp->{pack_name} = random_module_name ($Info, $ViewProp->{Name});
457        
458    $ViewProp->{condition_stringified} = hash    $ViewProp->{condition_stringified} = hash
# Line 376  push \@SuikaWiki::View::Implementation:: Line 468  push \@SuikaWiki::View::Implementation::
468  @{[change_package $Info, $ViewProp->{pack_name}]}  @{[change_package $Info, $ViewProp->{pack_name}]}
469  our \@ISA = q#SuikaWiki::View::template#;  our \@ISA = q#SuikaWiki::View::template#;
470  EOH  EOH
471      local $Info->{-message_error_used} = 0;  
472      my $use = $src->get_attribute ('Use');
473      if (ref $use) {
474        $r .= line $Info, node_path => "ViewDefinition[Mode='$ViewProp->{Name}']/Use";
475        $r .= code $Info, $use->inner_text;
476        $r .= "\n\n";
477      }
478      
479    for (@{$src->child_nodes}) {    for (@{$src->child_nodes}) {
480      if ($_->local_name eq 'template') {      if ($_->local_name eq 'template') {
481        $r .= make_view_template_method ($_, $Info);        $r .= make_view_template_method ($_, $Info, $ViewProp);
482      } elsif ($_->local_name eq 'method') {      } elsif ($_->local_name eq 'method') {
483        my $method_name = $_->get_attribute_value ('Name');        my $method_name = $_->get_attribute_value ('Name');
484        $r .= ({        $r .= ({
485                main => q(sub main ($$) {)."\n".q(my ($self, $opt) = @_;)."\n",                main => q(sub main ($$) {)."\n".q(my ($self, $opt, $opt2) = @_;)."\n",
486                main_pre => q(sub main_pre ($$$) {)."\n".q(my ($self, $opt, $opt2) = @_;)."\n",                main_pre => q(sub main_pre ($$$) {)."\n".q(my ($self, $opt, $opt2) = @_;)."\n",
487                main_post => q(sub main_post ($$$) {)."\n".q(my ($self, $opt, $opt2) = @_;)."\n",                                    main_post => q(sub main_post ($$$) {)."\n".q(my ($self, $opt, $opt2) = @_;)."\n",                    
488               }->{$method_name}               }->{$method_name}
489               ||qq(sub @{[$method_name]} {\n))               ||qq(sub @{[$method_name]} {\n))
490           . line ($Info, node_path => "ViewDefinition[Mode='$ViewProp->{Name}']/method[Name='$method_name']")           . line ($Info, node_path => "ViewDefinition[Mode='$ViewProp->{Name}']/method[Name='$method_name']")
491           . code ($Info, $_->value)           . code ($Info, $_->value)
492           . line ($Info, reset => 1)           . qq(}\n)
493           . qq(}\n);           . line ($Info, reset => 1);
494      }      }
495    }    }
496    my $prop = {Name => $ViewProp->{Name},    my $prop = {Name => $ViewProp->{Name},
# Line 400  EOH Line 500  EOH
500  }  }
501    
502  sub make_view_template_method ($$) {  sub make_view_template_method ($$) {
503    my ($src, $info) = @_;    my ($src, $Info, $ViewProp) = @_;
504    my $r = <<EOH;    my $r = <<EOH;
505    
506  sub main (\$\$\$) {  sub main (\$\$\$) {
# Line 416  sub main (\$\$\$) { Line 516  sub main (\$\$\$) {
516        
517    \$opt2->{template} = @{[literal $src->get_attribute ('body', make_new_node => 1)->inner_text]};    \$opt2->{template} = @{[literal $src->get_attribute ('body', make_new_node => 1)->inner_text]};
518    \$opt2->{o} = bless {    \$opt2->{o} = bless {
                      ## Compatible options for SuikaWiki 2 WikiPlugin interface  
                        param => \\\%main::form,  
                        page => \$main::form{mypage},  
                        toc => [],  
                        #magic  
                        #content  
                        #use_anchor_name  
                        media => {@{[hash  
     type => ($src->get_attribute ('media-type',make_new_node=>1)->inner_text  
              || 'application/octet-stream'),  
     charset => ($src->get_attribute ('use-media-type-charset',make_new_node=>1)  
                     ->inner_text || 0),  
     ## In fact, this value is not referred from any SuikaWiki 2 WikiPlugin rule.  
     #expires => ($src->get_attribute ('expires',make_new_node=>1)->inner_text  
     #                             || 0)  
     ]}},  
519                        ## SuikaWiki 3 WikiPlugin interface                        ## SuikaWiki 3 WikiPlugin interface
520                          wiki => \$self->{view}->{wiki},                          wiki => \$self->{view}->{wiki},
521                          plugin => \$self->{view}->{wiki}->{plugin},                          plugin => \$self->{view}->{wiki}->{plugin},
# Line 440  sub main (\$\$\$) { Line 524  sub main (\$\$\$) {
524    @{[do{my $x=$src->get_attribute('http-status-code',make_new_node=>1)->inner_text;    @{[do{my $x=$src->get_attribute('http-status-code',make_new_node=>1)->inner_text;
525       $x?q{$opt2->{output}->{status_code} = }.(0 + $x).q{;}:q{}}]}       $x?q{$opt2->{output}->{status_code} = }.(0 + $x).q{;}:q{}}]}
526    @{[do{my $x=$src->get_attribute('http-status-phrase',make_new_node=>1)->inner_text;    @{[do{my $x=$src->get_attribute('http-status-phrase',make_new_node=>1)->inner_text;
527       $x?q{$opt2->{output}->{reason_phrase} = }.literal($x).q{;}:q{}}]}       $x?q{$opt2->{output}->{status_phrase} = }.literal($x).q{;}:q{}}]}
528    \$opt2->{output}->{entity}->{media_type} = @{[literal    \$opt2->{output}->{entity}->{media_type} = @{[literal
529                             $src->get_attribute ('media-type',make_new_node=>1)                             $src->get_attribute ('media-type',make_new_node=>1)
530                                 ->inner_text || 'application/octet-stream']};                                 ->inner_text || 'application/octet-stream']};
# Line 455  sub main (\$\$\$) { Line 539  sub main (\$\$\$) {
539              qq{\$opt2->{output}->set_expires (delta => @{[0 + $x]});};              qq{\$opt2->{output}->set_expires (delta => @{[0 + $x]});};
540            }            }
541        }]}        }]}
542      \$opt2->{output}->{entity}->{body_is_octet_stream} = @{[
543        $src->get_attribute ('body')->get_attribute_value ('is-octet-stream', default_value => 0)
544        or 0
545      ]};
546        
547    \$self->{view}->{wiki}->init_db;    \$self->{view}->{wiki}->init_db;
548    \$self->main_pre (\$opt, \$opt2);    \$self->main_pre (\$opt, \$opt2);
549        
550    my \$fmt = SuikaWiki::Plugin->formatter ('view');    use Message::Util::Error;
551    \$opt2->{output}->{entity}->{body}    try {
552      = \$fmt->replace (\$opt2->{template}, param => \$opt2->{o});      \$opt2->{output}->{entity}->{body}
553          = SuikaWiki::Plugin->formatter ('view')
554            ->replace (\$opt2->{template}, param => \$opt2->{o});
555      } \$self->{view}->{wiki}->{config}->{catch}->{ @{[
556           $ViewProp->{Name} eq '-error' ? 'formatter_view_error'
557                                         : 'formatter_view' ]} };
558    \$opt2->{output}->output (output => 'http-cgi');    \$opt2->{output}->output (output => 'http-cgi');
559        
560    \$self->main_post (\$opt, \$opt2);    \$self->main_post (\$opt, \$opt2);
# Line 474  sub make_rule ($$) { Line 567  sub make_rule ($$) {
567    my $type = $src->get_attribute ('Category', make_new_node => 1)->value || [];    my $type = $src->get_attribute ('Category', make_new_node => 1)->value || [];
568    my $name = $src->get_attribute ('Name', make_new_node => 1)->value;    my $name = $src->get_attribute ('Name', make_new_node => 1)->value;
569    $name =~ s/(?<=.)-/_/g;    $name =~ s/(?<=.)-/_/g;
   my $main = line ($Info, node_path => "FormattingRule[name()='@{[list $type]}/$name']/Formatting")  
            . code ($Info, $src->get_attribute_value ('Formatting'))  
            . line ($Info, reset => 1);  
570        
571    my $reg_block;    my $reg_block;
572    $reg_block = qr/[^{}]*(?>[^{}]+|{(??{$reg_block})})*/;    $reg_block = qr/[^{}]*(?>[^{}]+|{(??{$reg_block})})*/;
573    my $reg_attr = qr/__ATTR(TEXT|NODE)?:%(\w+)(?:->{($reg_block)})?__;/;    my %code;
574        for my $codename ([qw/Formatting main/], [qw/After after/],
575    $main = q{my ($f, $rule_name, $p, $o, %opt) = @_;}."\n".$main                      [qw/Before before/], [qw/Pre pre/], [qw/Post post/],
576      if $main =~ /\$f\b/                      [qw/Attribute attr/]) {
577      or $main =~ /\$rule_name\b/      my $main = code $Info, $src->get_attribute_value ($codename->[0]);
578      or $main =~ /\$[opr]\b/      next unless $main;
579      or $main =~ /[%\$]opt\b/;      $main = line ($Info, node_path =>
580    if ($main =~ /\$r\b/) {                "FormattingRule[name()='@{[list $type]}/$name']/".$codename->[0])
581      warn qq(Rule @{[list $type]}/$name: Use of \$r is deprecated);            . $main;
582      $main = q{my $r = '';} . "\n" . $main . "\n"      
583            . q{$p->{-parent}->append_node ($r, node_or_text => 1);};      if ( $main =~ /\$f\b/
584    }        or $main =~ /\$rule_name\b/
585    $main =~ s{$reg_attr}        or $main =~ /\$[opr]\b/
586              {($1 eq 'TEXT' ? '$p->{'.literal($2).'} = do { my $r = ' : '')        or $main =~ /[%\$]opt\b/
587               .'$f->parse_attr ($p=>'.literal($2).', $o, '        or $main =~ /\$param_(?:name|value)\n/) {
588                               .($3?'-parent => '.$3.', ':'')        if ($codename->[0] ne 'Attribute') {
589                               .($1?'-non_parsed_to_node => 1, ':'')          $main = q{my ($f, $rule_name, $p, $o, %opt) = @_;}."\n".$main;
590                               .'%opt)'        } else {
591                               .($1 eq 'TEXT' ? '; ref $r?$r->inner_text:$r}' : '')          $main = q{my ($f, $rule_name, $p, $o, $param_name => $param_value, %opt) = @_;}."\n".$main;
592                               .';'}ge;        }
593          }
594    my $main = <<EOH;      if ($main =~ /\$r\b/) {
595          warn qq(Rule @{[list $type]}/$name: Use of \$r is deprecated);
596          $main = q{my $r = '';} . "\n" . $main . "\n"
597                . q{$p->{-parent}->append_node ($r, node_or_text => 1);};
598        }
599        $main =~ s{__ATTR(TEXT|NODE)?:%(\w+|{$reg_block})(?:->{($reg_block)})?__;}
600                  {($1 eq 'TEXT' ? '$p->{'.literal_or_code($Info, $2)
601                                          .'} = do { my $r = ' : '')
602                   .'$f->parse_attr ($p=>'.literal_or_code($Info, $2).', $o, '
603                                   .($3?'-parent => '.$3.', ':'')
604                                   .($1?'-non_parsed_to_node => 1, ':'')
605                                   .'%opt)'
606                                   .($1 eq 'TEXT' ? '; ref $r?$r->inner_text:$r}'
607                                                  : '')
608                                   .';'}ge;
609        $code{$codename->[1]} = barecode "sub {$main}";
610      }
611      
612      my $main = literal {
613        Description => [barecode m13ed_val_list $src, 'Description'],
614        Parameter => {do {
615          my @r;
616          for (@{$src->child_nodes}) {
617            if ($_->local_name eq 'Parameter') {
618              push @r, $_->get_attribute_value ('Name')
619                       => {Type => $_->get_attribute_value ('Type'),
620                           Default => $_->get_attribute_value ('Default'),
621                           Description => [barecode m13ed_val_list $_, 'Description']};
622            }
623          }
624          @r;
625        }},
626        %code,
627      };
628      $main .= line $Info, reset => 1;
629    
630    
631    my  $amain = <<EOH;
632  {  {
633    main => sub {$main},    main => sub {$main},
634    @{[line ($Info, reset => 1)]}
635    Description => [@{[m13ed_val_list $src, 'Description']}],    Description => [@{[m13ed_val_list $src, 'Description']}],
636    Parameter => {@{[do{    Parameter => {@{[do{
     my @r;  
     for (@{$src->child_nodes}) {  
       if ($_->local_name eq 'Parameter') {  
         push @r, $_->get_attribute_value ('Name')  
                  => {Type => $_->get_attribute_value ('Type'),  
                      Default => $_->get_attribute_value ('Default'),  
                      Description => [barecode m13ed_val_list $_, 'Description']};  
       }  
     }  
     list @r;  
637    }]}},    }]}},
638  }  }
639  EOH  EOH
640    my $r = change_package $Info, $Info->{module_name};    my $r = change_package $Info, $Info->{module_name};
641      local $Info->{-message_error_used} = 0;  
642    if (@$type == 1) {    if (@$type == 1) {
643      $type->[0] =~ tr/-/_/;      $type->[0] =~ tr/-/_/;
644      $r .= qq{\$SuikaWiki::Plugin::Rule{$type->[0]}->{$name} = $main;\n};      $r .= qq{\$SuikaWiki::Plugin::Rule{$type->[0]}->{$name} = $main;\n};
# Line 536  EOH Line 655  EOH
655    $r;    $r;
656  }  }
657    
658    =item FormattingRuleAlias
659    
660    Generating an alias name for a formatting rule that is already loaded.
661    Example:
662    
663      FormattingRuleAlias:
664        @Category[list]:
665          category-1
666          category-2
667          ...
668        @Name: new-rule-name
669        @Reference:
670          @@Category: one-of-category
671          @@Name: one-of-name
672    
673    associates C<(I<category-1>, I<new-rule-name>)>,
674    C<(I<category-2>, I<new-rule-name>)>, ...
675    with C<(I<one-of-category>, I<one-of-name>)>.
676    
677    =cut
678    
679    sub make_rule_alias ($$) {
680      my ($src, $Info) = @_;
681      my $type = $src->get_attribute ('Category', make_new_node => 1)->value || [];
682      my $name = $src->get_attribute ('Name', make_new_node => 1)->value;
683      
684      my $ref = $src->get_attribute ('Reference', make_new_node => 1);
685      my $c = $ref->get_attribute_value ('Category');
686      my $n = $ref->get_attribute_value ('Name');
687      
688      s/(?<=.)-/_/g for $n, $name;
689      tr/-/_/ for $c, @$type;
690      
691      my $def = qq{\$SuikaWiki::Plugin::Rule{@{[literal $c]}}->{@{[literal $n]}} or warn qq{Formatting rule "$c/$n" not defined}};
692      
693      my $r = change_package $Info, $Info->{module_name};
694      for my $type (@$type) {
695        $r .= qq{\$SuikaWiki::Plugin::Rule{@{[literal $type]}}->{@{[literal $name]}} = $def;\n};
696        push @{$Info->{provide}->{rule}->{$type}}, $name;
697      }
698      $r;
699    }
700    
701    
702  sub random_module_name ($;$) {  sub random_module_name ($;$) {
703    my ($Info, $subname) = @_;    my ($Info, $subname) = @_;
# Line 546  sub random_module_name ($;$) { Line 708  sub random_module_name ($;$) {
708      sprintf ('%02d%02d%02d%02d%02d%02d', @date[5,4,3,2,1,0]),      sprintf ('%02d%02d%02d%02d%02d%02d', @date[5,4,3,2,1,0]),
709      join ('', @rand[rand@rand,rand@rand,rand@rand,rand@rand]);      join ('', @rand[rand@rand,rand@rand,rand@rand,rand@rand]);
710  }  }
711    
712    =head1 NAME
713    
714    mkplugin2.pl - SuikaWiki: WikiPlugin Generator
715    
716    =head1 SYNOPSIS
717    
718      mkplugin2.pl pluginsrc.wp2 > plugin.pm
719    
720    =head1 DESCRIPTION
721    
722    C<mkplugin2.pl> generates WikiPlugin module as a Perl module file
723    from WikiPlugin source description.  WikiPlugin source description
724    is described in SuikaWikiConfig/2.0 format and it contains
725    definitions of wiki constructions (such as formatting rules and
726    WikiView definitions) as both machine understandable code and
727    human readable documentation.  For more information, see
728    <http://suika.fam.cx/~wakaba/-temp/wiki/wiki?WikiPlugin>.
729    
730    This script is part of SuikaWiki.
731    
732    =head1 HISTORY AND COMPATIBILITY
733    
734    C<mkplugin2.pl> introduced as part of SuikaWiki 3.
735    It converts SuikaWiki 3 WikiPlugin source descriptions
736    (in SuikaWikiConfig/2.0) into Perl modules with SuikaWiki 3 interface.
737    
738    SuikaWiki 2 has C<mkplugin.pl>.  It also converts WikiPlugin
739    source descriptions into Perl modules.  But it support
740    SuikaWiki 2 format of WikiPlugin source description that differs from
741    SuikaWiki 3 format.  Wiki programming interface (not limited to
742    WikiPlugin related one) of SuikaWiki 3 also incompatible with that
743    of SuikaWiki 2 so that it is impossible to use SuikaWiki 2 WikiPlugin
744    module with SuikaWiki 3 and vice versa.
745    
746    =head1 SEE ALSO
747    
748    C<SuikaWiki::Plugin>, SuikaWiki:WikiPlugin
749    <http://suika.fam.cx/~wakaba/-temp/wiki/wiki?WikiPlugin>.
750    
751    =head1 LICENSE
752    
753    Copyright 2003-2004 Wakaba <w@suika.fam.cx>.  All rights reserved.
754    
755    This program is free software; you can redistribute it and/or
756    modify it under the same terms as Perl itself.
757    
758    =cut
759    
760    1; # $Date$
Legend:
Removed from v.1.6  
changed lines
  Added in v.1.17
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24