/[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.8 by wakaba, Mon Dec 1 07:46:42 2003 UTC revision 1.21 by wakaba, Mon Nov 8 09:57:49 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/__FUNCPACK{([^{}]+)}__/(\$SuikaWiki::Plugin::Registry::Info{@{[literal $1]}}->{module_name} || SuikaWiki::Plugin->module_package (@{[literal $1]}))/g;
63      $code =~ s{<Q:([^:]+):([^>]+)>}{
64        if ($Info->{Namespace}->{$1}) {
65          literal $Info->{Namespace}->{$1}.$2;
66        } else {
67          warn qq(Namespace prefix "$1" not defined);
68          literal $2;
69        }
70      }ge;
71      
72      $Info->{-message_error_used} = 1 if $code =~ /\buse\s+Message::Util::Error\b/;
73      if (not $Info->{-message_error_used} and
74         ($code =~ /\btry\s*\{/ or $code =~ /\bcatch\s*\{/)) {
75        warn "Message::Util::Error MUST be 'use'd before 'try'...'catch' block used";
76      }
77    $code;    $code;
78  }  }
79  sub change_package ($$) {  sub change_package ($$) {
# Line 97  sub line ($;%) { Line 112  sub line ($;%) {
112    $opt{file} =~ s/"/''/g;    $opt{file} =~ s/"/''/g;
113    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";
114  }  }
115    sub literal_or_code ($$) {
116      my ($Info, $s) = @_;
117      substr ($s, 0, 1) ne '{' ? literal ($s)
118                               : code ($Info, substr ($s, 1, length ($s) - 2));
119    }
120    sub expanded_uri ($$$) {
121      my ($Info, $prefix, $lname) = @_;
122      warn "$0: $prefix: Namespace prefix not declared"
123        unless $Info->{Namespace}->{$prefix};
124      $Info->{Namespace}->{$prefix} . $lname;
125    }
126    
127  my $parser = Message::Markup::SuikaWikiConfig20::Parser->new;  my $parser = Message::Markup::SuikaWikiConfig20::Parser->new;
128  my $plugins = $parser->parse_text ($src);  my $plugins = $parser->parse_text ($src);
# Line 123  our \%Info; Line 149  our \%Info;
149  \$Info{$Info{name_literal}}->{Name} = $Info{name_literal};  \$Info{$Info{name_literal}}->{Name} = $Info{name_literal};
150  EOH  EOH
151  for (qw/Version InterfaceVersion mkpluginVersion module_name/) {  for (qw/Version InterfaceVersion mkpluginVersion module_name/) {
152    print qq{\$Info{$Info{name_literal}}->{$_} = @{[literal $Info{$_}]};\n};    print qq{\$Info{$Info{name_literal}}->{@{[literal $_]}} = @{[literal $Info{$_}]};\n};
153  }  }
154  for (qw/LastModified/) {  for (qw/LastModified Date.RCS/) {
155    $Info{$_} = n11n $meta->get_attribute ($_,make_new_node=>1)->value;    $Info{$_} = n11n $meta->get_attribute ($_,make_new_node=>1)->value;
156    next unless length $Info{$_};    next unless length $Info{$_};
157    print qq{\$Info{$Info{name_literal}}->{$_} = } . literal $Info{$_};    print qq{\$Info{$Info{name_literal}}->{@{[literal $_]}} = } . literal $Info{$_};
158    print ";\n";    print ";\n";
159  }  }
160  for (qw/RequiredPlugin RequiredModule/) {  for (qw/RequiredPlugin RequiredModule/) {
# Line 153  print qq{\$Info{$Info{name_literal}}->{A Line 179  print qq{\$Info{$Info{name_literal}}->{A
179  } grep { $_->local_name eq 'Author' } @{$meta->child_nodes}  } grep { $_->local_name eq 'Author' } @{$meta->child_nodes}
180  ). qq{];\n};  ). qq{];\n};
181    
182    for (@{$meta->get_attribute ('Namespace', make_new_node => 1)->child_nodes}) {
183      $Info{Namespace}->{$_->local_name} = $_->value;
184    }
185    
186  my $use = $meta->get_attribute ('Use');  my $use = $meta->get_attribute ('Use');
187  if (ref $use) {  if (ref $use) {
188    print change_package \%Info, $Info{module_name};    print change_package \%Info, $Info{module_name};
189    print line \%Info, node_path => 'Plugin/Use';    print line \%Info, node_path => 'Plugin/Use';
190    print $use->inner_text, "\n";    print code \%Info, $use->inner_text;
191    print line \%Info, reset => 1;    print line \%Info, reset => 1;
192  }  }
193    
# Line 176  for (@{$plugins->child_nodes}) { Line 206  for (@{$plugins->child_nodes}) {
206      register_plugin_const ($_, \%Info);      register_plugin_const ($_, \%Info);
207    } elsif ($_->local_name eq 'Format') {    } elsif ($_->local_name eq 'Format') {
208      print "\n", make_format ($_, \%Info);      print "\n", make_format ($_, \%Info);
209      } elsif ($_->local_name eq 'FormattingRuleAlias') {
210        print "\n", make_rule_alias ($_, \%Info);
211    # Parameter
212    # PluginCategory
213    }    }
214  }  }
215    
# Line 191  sub make_format ($$) { Line 225  sub make_format ($$) {
225    my ($src, $Info) = @_;    my ($src, $Info) = @_;
226    my $module_name = 'SuikaWiki::Format::Definition::'.$src->get_attribute_value ('ModuleName');    my $module_name = 'SuikaWiki::Format::Definition::'.$src->get_attribute_value ('ModuleName');
227    my $r = change_package $Info, $module_name;    my $r = change_package $Info, $module_name;
228      local $Info->{-message_error_used} = 0;  
229    $r .= qq{our \@ISA;\n};    $r .= qq{our \@ISA;\n};
230    if (my $isa = $src->get_attribute_value ('Inherit')) {    if (my $isa = $src->get_attribute_value ('Inherit')) {
231      for (@$isa) {      for (@$isa) {
# Line 200  sub make_format ($$) { Line 235  sub make_format ($$) {
235      $r .= qq{push \@ISA, 'SuikaWiki::Format::Definition::template';\n};          $r .= qq{push \@ISA, 'SuikaWiki::Format::Definition::template';\n};    
236    }    }
237    if (my $name = $src->get_attribute_value ('Name')) {    if (my $name = $src->get_attribute_value ('Name')) {
238      $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};
239    }    }
240    if (my $type = $src->get_attribute_value ('Type')) {    if (my $type = $src->get_attribute_value ('Type')) {
241      $r .= qq{\$SuikaWiki::Format::Definition::Class{@{[literal $type.'//']}} = '$module_name';\n};      $type .= join '', map {
242                   ';'. $_->local_name .'='. quoted_string $_->inner_text
243                 } sort {
244                   $a->local_name cmp $b->local_name
245                 } @{$src->get_attribute ('Type')->child_nodes};
246        $r .= qq{\$SuikaWiki::Format::Definition::Class{@{[literal 'IMT:'.$type.'##']}} = '$module_name';\n};
247    }    }
248        
249    my $convert = line $Info, line_no => __LINE__ + 2, realfile => __FILE__;    my $convert = line $Info, line_no => __LINE__ + 2, realfile => __FILE__;
# Line 211  sub make_format ($$) { Line 251  sub make_format ($$) {
251  our $Converter;  our $Converter;
252  sub convert ($$;%) {  sub convert ($$;%) {
253    my ($self, $source, %opt) = @_;    my ($self, $source, %opt) = @_;
254    my $converter;    my $t = SuikaWiki::Format::Definition->serialize_media_type (%opt);
255    my $flag = '//';    my $converter = $Converter->{$t->{_}};
256    $flag .= 'f' if $opt{IsFragment};    return ($converter->{$opt{return_type} or 'Main'} or
257    $flag .= 'p' if $opt{IsPlaceholder};            CORE::die "Buggy implementation: $t->{_}/@{[$opt{return_type} or 'Main']} not defined")
258    if ($Converter->{$opt{Type}.$flag}) {           ->($self, $source, \%opt)
259      $converter = $Converter->{$opt{Type}.$flag};      if $converter;
260    } elsif ($Converter->{$opt{Name}.'/'.$opt{Version}.$flag}) {    local $Error::Depth = $Error::Depth + 1;
     $converter = $Converter->{'/'.$opt{Name}.'/'.$opt{Version}.$flag};  
   }  
   return $converter->{Main}->($self, $source, \%opt) if $converter;  
261    $self->SUPER::convert ($source, %opt);    $self->SUPER::convert ($source, %opt);
262  }  }
263  EOH  EOH
# Line 233  EOH Line 270  EOH
270          undef $convert;          undef $convert;
271        }        }
272        $r .= make_format_converter ($_, $Info);        $r .= make_format_converter ($_, $Info);
273        } elsif ($_->local_name eq 'WikiForm') {
274          $r .= q(sub wikiform {)."\n".q(my ($self, $source, %opt) = @_;);
275          $r .= line $Info, node_path => qq(Format[module-name()=$module_name]/WikiForm);
276          $r .= code $Info, $_->get_attribute_value ('Main');
277          $r .= line $Info, reset => 1;
278          $r .= qq(}\n);
279        } elsif ($_->local_name eq 'HeadSummary') {
280          $r .= q(sub headsummary {)."\n".q(my ($self, $source, %opt) = @_;);
281          $r .= line $Info, node_path => qq(Format[module-name()=$module_name]/HeadSummary);
282          $r .= code $Info, $_->get_attribute_value ('Main');
283          $r .= line $Info, reset => 1;
284          $r .= qq(}\n);
285        } elsif ($_->local_name eq 'NextIndex') {
286          my $name = $_->get_attribute_value ('Name', default => '');
287          $r .= q(sub next_index_for_).$name
288             .  q( {)."\n".q(my ($self, $source, %opt) = @_;)
289             .  line $Info, node_path => qq(Format[module-name()=$module_name]/NextIndex[Name=$name]);
290          $r .= code $Info, $_->get_attribute_value ('Main');
291          $r .= line $Info, reset => 1;
292          $r .= qq(}\n);
293        } elsif ({qw/content_written 1 content_removed 1 content_type_changed_from 1
294                     content_prop_modified 1/}
295                 ->{my $node_name = $_->local_name}) {
296          $r .= q(sub ).$node_name
297             .  q( {)."\n".q(my ($self, %opt) = @_;)
298             .  line $Info, node_path => qq(Format[module-name()=$module_name]/$node_name]);
299          $r .= code $Info, $_->get_attribute_value ('Main');
300          $r .= line $Info, reset => 1;
301          $r .= qq(}\n);
302      } elsif ($_->local_name eq 'Use') {      } elsif ($_->local_name eq 'Use') {
303        $r .= line $Info, node_path => qq(Format[module-name()=$module_name]/Use);        $r .= line $Info, node_path => qq(Format[module-name()=$module_name]/Use);
304        $r .= $_->inner_text;        $r .= code $Info, $_->inner_text;
305        } elsif ($_->local_name eq 'Prop') {
306          $r .= q<sub prop ($$;%) { my ($self, $name, %opt) = @_;>;
307          my $f = 0;
308          for my $prop (@{$_->child_nodes}) {
309            if ($prop->local_name =~ /^([^:]+):([^:]+)$/) {
310              $r .= qq{if (\$name eq @{[literal expanded_uri $Info, $1, $2]}) { return @{[literal $prop->value]} } els};
311              $f = 1;
312            }
313          }
314          $r .= q<e {> if $f;
315          $r .= q{$self->SUPER::prop ($name, %opt);};
316          $r .= q<}> if $f;
317          $r .= qq<\n}\n>;
318      }      }
319    }    }
320    $r;    $r;
# Line 244  EOH Line 323  EOH
323  sub make_format_converter ($$) {  sub make_format_converter ($$) {
324    my ($src, $Info) = @_;    my ($src, $Info) = @_;
325    my %def;    my %def;
326    $def{Type} = $src->get_attribute ('Type');    for (qw/Type Name Version TypeURIReference IsFragment IsPlaceholder/) {
327    if (ref $def{Type}) {      $def{$_} = $src->get_attribute_value ($_);
328      $def{Type} = $def{Type}->inner_text      delete $def{$_} unless defined $def{$_};
329            . join '', map {    }
330                ';'. $_->local_name .'='. quoted_string $_->inner_text    $def{Type_param} = {map {$_->local_name => $_->value}
331              } sort {                                @{$src->get_attribute ('Type', make_new_node => 1)
332                $a->local_name cmp $b->local_name                                    ->child_nodes}};
333              } @{$def{Type}->child_nodes};    my $type = serialize_media_type ($Info,
334    } else {                 Type => $def{Type},
335      delete $def{Type};                 Type_param => $def{Type_param},
336                   Name => $def{Name},
337                   Version => $def{Version},
338                   URIReference => $def{TypeURIReference},
339                   IsFragment => $def{IsFragment},
340                   IsPlaceholder => $def{IsPlaceholder});
341      $def{serialized_type} = $type->{_};
342      
343      for (qw/Main ToString ToOctetStream/) {
344        my $def = $src->get_attribute_value ($_);
345        next unless $def;
346        $def{$_} = line ($Info, node_path => '//Converter/'.$_)
347                   . $def
348                   . line ($Info, reset => 1);
349        if ($def{$_} =~ /\$r\b/) {
350          $def{$_} = 'my $r;'."\n".$def{$_}."\n".'$r';
351        }
352        $def{$_} = barecode code $Info,
353                     'sub {my ($self, $source, $opt) = @_;'
354                   . $def{$_} . '}';
355    }    }
   $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} . '}';  
356        
357    my $r = list %def;    my $r = list %def;
358    if ($def{Type}) {    if ($type->{Type}) {
359      $r = qq{\$Converter->{@{[literal $def{Type}.$flag]}} = {$r};\n};      $r = qq{\$Converter->{@{[literal $type->{Type}]}} = {$r};\n};
360      $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}
361        if $def{Name};        if $type->{Magic};
362    } elsif ($def{Name}) {      $r .= qq{\$Converter->{@{[literal $type->{URIReference}]}} = \$Converter->{@{[literal $type->{Type}]}};\n}
363      $r = qq{\$Converter->{@{[literal '/'.$def{Name}.'/'.$def{Version}.$flag]}} = {$r};\n};        if $type->{URIReference};
364      $r    } elsif ($type->{Magic}) {
365        $r = qq{\$Converter->{@{[literal $type->{Magic}]}} = {$r};\n};
366        $r .= qq{\$Converter->{@{[literal $type->{URIReference}]}} = \$Converter->{@{[literal $type->{Magic}]}};\n}
367          if $type->{URIReference};
368      } elsif ($type->{URIReference}) {
369        $r = qq{\$Converter->{@{[literal $type->{URIReference}]}} = {$r};\n};
370      } else {
371        $r = 'BEGIN { die "Invalid Syntax of Converter: Type or Name or TypeURIReference property required" }';
372    }    }
373    $r;    $r;
374  }  }
375    
376    sub serialize_media_type ($%) {
377      my ($Info, %opt) = @_;
378      my %return;
379      if ($opt{Type}) {
380        $return{Type} = 'IMT:'.$opt{Type};
381        if ($opt{Type_param}) {
382          $return{Type} .= join '', map {my $s;
383                             ';'. $_ .'="'
384                           . (($s = $opt{Type_param}->{$_}) =~ s/([\\"])/\\$1/g, $s)
385                           . '"'
386                           } sort {
387                             $a cmp $b
388                           } keys %{$opt{Type_param}};
389        }
390      }
391      if ($opt{Magic}) {
392        $return{Magic} = 'MAGIC:'.$opt{Magic};
393      } elsif ($opt{Name}) {
394        $return{Name} = 'MAGIC:'.$opt{Name}.'/*';
395        $return{Magic} = 'MAGIC:'.$opt{Name}.'/'.$opt{Version} if $opt{Version};
396      }
397      if ($opt{URIReference}) {
398        $return{URIReference} = $opt{URIReference};
399      }
400      my $flag = '##';
401      $flag .= 'f' if $opt{IsFragment};
402      $flag .= 'p' if $opt{IsPlaceholder};
403      for (qw/URIReference Type Magic Name/) {
404        $return{$_} .= $flag if $return{$_};
405      }
406      $return{_} = $return{URIReference} || $return{Type}
407                || $return{Magic} || $return{Name};
408      \%return;
409    }
410    
411    
412  sub make_function ($$) {  sub make_function ($$) {
413    my ($src, $Info) = @_;    my ($src, $Info) = @_;
414    ## TODO: support of ARGV property    ## TODO: support of ARGV property
# Line 299  sub make_function ($$) { Line 418  sub make_function ($$) {
418  sub @{[$name = $src->get_attribute_value ('Name')]} {  sub @{[$name = $src->get_attribute_value ('Name')]} {
419  @{[line $Info, node_path => "Function[Name='$name']/Main"]}@{[  @{[line $Info, node_path => "Function[Name='$name']/Main"]}@{[
420    code $Info, $src->get_attribute_value ('Main')    code $Info, $src->get_attribute_value ('Main')
421  ]}@{[line $Info, reset => 1]}  ]}
422  }  }
423    @{[line $Info, reset => 1]}
424  EOH  EOH
425  }  }
426    
427  sub register_plugin_const ($$) {  sub register_plugin_const ($$) {
428    my ($src, $Info) = @_;    my ($src, $Info) = @_;
429    for (@{$src->child_nodes}) {    for (@{$src->child_nodes}) {
430      $Info->{const}->{$_->local_name} = $_->value;      $Info->{const}->{$_->local_name} = literal_or_code $Info, $_->value;
431    }    }
432  }  }
433    
434  sub make_resdef ($$) {  sub make_resdef ($$) {
435    my ($src, $Info) = @_;    my ($src, $Info) = @_;
436    my $r = change_package $Info, 'SuikaWiki::Plugin::Resource';    my $r = change_package $Info, 'SuikaWiki::Plugin::Resource';
437      local $Info->{-message_error_used} = 0;  
438    $r .= qq{our \$BaseResource;\n};    $r .= qq{our \$BaseResource;\n};
439    for (@{$src->child_nodes}) {    for (@{$src->child_nodes}) {
440      if ($_->node_type eq '#element') {      if ($_->node_type eq '#element') {
# Line 361  sub make_viewdef ($$) { Line 482  sub make_viewdef ($$) {
482    my $ViewProp = {};    my $ViewProp = {};
483    my $r = '';    my $r = '';
484    $ViewProp->{Name} = n11n $src->get_attribute_value ('Mode');    $ViewProp->{Name} = n11n $src->get_attribute_value ('Mode');
485      $ViewProp->{Name} =~ s/(?<=.)-/_/g;
486    $ViewProp->{pack_name} = random_module_name ($Info, $ViewProp->{Name});    $ViewProp->{pack_name} = random_module_name ($Info, $ViewProp->{Name});
487        
488    $ViewProp->{condition_stringified} = hash    $ViewProp->{condition_stringified} = hash
# Line 376  push \@SuikaWiki::View::Implementation:: Line 498  push \@SuikaWiki::View::Implementation::
498  @{[change_package $Info, $ViewProp->{pack_name}]}  @{[change_package $Info, $ViewProp->{pack_name}]}
499  our \@ISA = q#SuikaWiki::View::template#;  our \@ISA = q#SuikaWiki::View::template#;
500  EOH  EOH
501      local $Info->{-message_error_used} = 0;  
502      my $use = $src->get_attribute ('Use');
503      if (ref $use) {
504        $r .= line $Info, node_path => "ViewDefinition[Mode='$ViewProp->{Name}']/Use";
505        $r .= code $Info, $use->inner_text;
506        $r .= "\n\n";
507      }
508      
509    for (@{$src->child_nodes}) {    for (@{$src->child_nodes}) {
510      if ($_->local_name eq 'template') {      if ($_->local_name eq 'template') {
511        $r .= make_view_template_method ($_, $Info, $ViewProp);        $r .= make_view_template_method ($_, $Info, $ViewProp);
# Line 389  EOH Line 519  EOH
519               ||qq(sub @{[$method_name]} {\n))               ||qq(sub @{[$method_name]} {\n))
520           . line ($Info, node_path => "ViewDefinition[Mode='$ViewProp->{Name}']/method[Name='$method_name']")           . line ($Info, node_path => "ViewDefinition[Mode='$ViewProp->{Name}']/method[Name='$method_name']")
521           . code ($Info, $_->value)           . code ($Info, $_->value)
522           . line ($Info, reset => 1)           . qq(}\n)
523           . qq(}\n);           . line ($Info, reset => 1);
524      }      }
525    }    }
526    my $prop = {Name => $ViewProp->{Name},    my $prop = {Name => $ViewProp->{Name},
# Line 401  EOH Line 531  EOH
531    
532  sub make_view_template_method ($$) {  sub make_view_template_method ($$) {
533    my ($src, $Info, $ViewProp) = @_;    my ($src, $Info, $ViewProp) = @_;
534      my $media_type = $src->get_attribute_value
535                                ('media-type',
536                                 default => q<application/octet-stream>);
537    my $r = <<EOH;    my $r = <<EOH;
538    
539  sub main (\$\$\$) {  sub main (\$\$\$) {
# Line 416  sub main (\$\$\$) { Line 549  sub main (\$\$\$) {
549        
550    \$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]};
551    \$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)  
     ]}},  
552                        ## SuikaWiki 3 WikiPlugin interface                        ## SuikaWiki 3 WikiPlugin interface
553                          wiki => \$self->{view}->{wiki},                          wiki => \$self->{view}->{wiki},
554                          plugin => \$self->{view}->{wiki}->{plugin},                          plugin => \$self->{view}->{wiki}->{plugin},
# Line 441  sub main (\$\$\$) { Line 558  sub main (\$\$\$) {
558       $x?q{$opt2->{output}->{status_code} = }.(0 + $x).q{;}:q{}}]}       $x?q{$opt2->{output}->{status_code} = }.(0 + $x).q{;}:q{}}]}
559    @{[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;
560       $x?q{$opt2->{output}->{status_phrase} = }.literal($x).q{;}:q{}}]}       $x?q{$opt2->{output}->{status_phrase} = }.literal($x).q{;}:q{}}]}
561    \$opt2->{output}->{entity}->{media_type} = @{[literal    \$opt2->{output}->{entity}->{media_type} = @{[literal $media_type]};
562                             $src->get_attribute ('media-type',make_new_node=>1)  
                                ->inner_text || 'application/octet-stream']};  
563    @{[($src->get_attribute ('use-media-type-charset',make_new_node=>1)    @{[($src->get_attribute ('use-media-type-charset',make_new_node=>1)
564              ->inner_text || 0) ?              ->inner_text || 0) ?
565       q{$opt2->{output}->{entity}->{charset} = $self->{view}->{wiki}->{config}->{charset}->{output};}:       q{$opt2->{output}->{entity}->{charset} = $self->{view}->{wiki}->{config}->{charset}->{output};}:
# Line 455  sub main (\$\$\$) { Line 571  sub main (\$\$\$) {
571              qq{\$opt2->{output}->set_expires (delta => @{[0 + $x]});};              qq{\$opt2->{output}->set_expires (delta => @{[0 + $x]});};
572            }            }
573        }]}        }]}
574      \$opt2->{output}->{entity}->{body_is_octet_stream} = @{[
575        $src->get_attribute ('body')->get_attribute_value ('is-octet-stream', default_value => 0)
576        or 0
577      ]};
578        
579    \$self->{view}->{wiki}->init_db;    \$self->{view}->{wiki}->init_db;
580    \$self->main_pre (\$opt, \$opt2);    \$self->main_pre (\$opt, \$opt2);
581        
582      @{[$media_type eq 'text/html' ? q{require Message::Markup::XML::Serialize::HTML;} : '']}
583    use Message::Util::Error;    use Message::Util::Error;
584    try {    try {
585      \$opt2->{output}->{entity}->{body}      \$opt2->{output}->{entity}->{body}
586        = SuikaWiki::Plugin->formatter ('view')        = @{[$media_type eq 'text/html' ? q{Message::Markup::XML::Serialize::HTML::html_simple} : '']}
587          ->replace (\$opt2->{template}, param => \$opt2->{o});          (SuikaWiki::Plugin->formatter ('view')
588            ->replace (\$opt2->{template}, param => \$opt2->{o}));
589    } \$self->{view}->{wiki}->{config}->{catch}->{ @{[    } \$self->{view}->{wiki}->{config}->{catch}->{ @{[
590         $ViewProp->{Name} eq '-error' ? 'formatter_view_error'         $ViewProp->{Name} eq '-error' ? 'formatter_view_error'
591                                       : 'formatter_view' ]} };                                       : 'formatter_view' ]} };
# Line 479  sub make_rule ($$) { Line 601  sub make_rule ($$) {
601    my $type = $src->get_attribute ('Category', make_new_node => 1)->value || [];    my $type = $src->get_attribute ('Category', make_new_node => 1)->value || [];
602    my $name = $src->get_attribute ('Name', make_new_node => 1)->value;    my $name = $src->get_attribute ('Name', make_new_node => 1)->value;
603    $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);  
604        
605    my $reg_block;    my $reg_block;
606    $reg_block = qr/[^{}]*(?>[^{}]+|{(??{$reg_block})})*/;    $reg_block = qr/[^{}]*(?>[^{}]+|{(??{$reg_block})})*/;
607    my $reg_attr = qr/__ATTR(TEXT|NODE)?:%(\w+)(?:->{($reg_block)})?__;/;    my %code;
608        for my $codename ([qw/Formatting main/], [qw/After after/],
609    $main = q{my ($f, $rule_name, $p, $o, %opt) = @_;}."\n".$main                      [qw/Before before/], [qw/Pre pre/], [qw/Post post/],
610      if $main =~ /\$f\b/                      [qw/Attribute attr/]) {
611      or $main =~ /\$rule_name\b/      my $main = code $Info, $src->get_attribute_value ($codename->[0]);
612      or $main =~ /\$[opr]\b/      next unless $main;
613      or $main =~ /[%\$]opt\b/;      $main = line ($Info, node_path =>
614    if ($main =~ /\$r\b/) {                "FormattingRule[name()='@{[list $type]}/$name']/".$codename->[0])
615      warn qq(Rule @{[list $type]}/$name: Use of \$r is deprecated);            . $main;
616      $main = q{my $r = '';} . "\n" . $main . "\n"      
617            . q{$p->{-parent}->append_node ($r, node_or_text => 1);};      if ( $main =~ /\$f\b/
618    }        or $main =~ /\$rule_name\b/
619    $main =~ s{$reg_attr}        or $main =~ /\$[opr]\b/
620              {($1 eq 'TEXT' ? '$p->{'.literal($2).'} = do { my $r = ' : '')        or $main =~ /[%\$]opt\b/
621               .'$f->parse_attr ($p=>'.literal($2).', $o, '        or $main =~ /\$param_(?:name|value)\n/) {
622                               .($3?'-parent => '.$3.', ':'')        if ($codename->[0] ne 'Attribute') {
623                               .($1?'-non_parsed_to_node => 1, ':'')          $main = q{my ($f, $rule_name, $p, $o, %opt) = @_;}."\n".$main;
624                               .'%opt)'        } else {
625                               .($1 eq 'TEXT' ? '; ref $r?$r->inner_text:$r}' : '')          $main = q{my ($f, $rule_name, $p, $o, $param_name => $param_value, %opt) = @_;}."\n".$main;
626                               .';'}ge;        }
627          }
628    my $main = <<EOH;      if ($main =~ /\$r\b/) {
629          warn qq(Rule @{[list $type]}/$name: Use of \$r is deprecated);
630          $main = q{my $r = '';} . "\n" . $main . "\n"
631                . q{$p->{-parent}->append_node ($r, node_or_text => 1);};
632        }
633        $main =~ s{__ATTR(TEXT|NODE)?:%(\w+|{$reg_block})(?:->{($reg_block)})?__;}
634                  {($1 eq 'TEXT' ? '$p->{'.literal_or_code($Info, $2)
635                                          .'} = do { my $r = ' : '')
636                   .'$f->parse_attr ($p=>'.literal_or_code($Info, $2).', $o, '
637                                   .($3?'-parent => '.$3.', ':'')
638                                   .($1?'-non_parsed_to_node => 1, ':'')
639                                   .'%opt)'
640                                   .($1 eq 'TEXT' ? '; ref $r?$r->inner_text:$r}'
641                                                  : '')
642                                   .';'}ge;
643        $code{$codename->[1]} = barecode "sub {$main}";
644      }
645      
646      my $main = literal {
647        Description => [barecode m13ed_val_list $src, 'Description'],
648        Parameter => {do {
649          my @r;
650          for (@{$src->child_nodes}) {
651            if ($_->local_name eq 'Parameter') {
652              push @r, $_->get_attribute_value ('Name')
653                       => {Type => $_->get_attribute_value ('Type'),
654                           Default => $_->get_attribute_value ('Default'),
655                           Description => [barecode m13ed_val_list $_, 'Description']};
656            }
657          }
658          @r;
659        }},
660        %code,
661      };
662      $main .= line $Info, reset => 1;
663    
664    
665    my  $amain = <<EOH;
666  {  {
667    main => sub {$main},    main => sub {$main},
668    @{[line ($Info, reset => 1)]}
669    Description => [@{[m13ed_val_list $src, 'Description']}],    Description => [@{[m13ed_val_list $src, 'Description']}],
670    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;  
671    }]}},    }]}},
672  }  }
673  EOH  EOH
674    my $r = change_package $Info, $Info->{module_name};    my $r = change_package $Info, $Info->{module_name};
675      local $Info->{-message_error_used} = 0;  
676    if (@$type == 1) {    if (@$type == 1) {
677      $type->[0] =~ tr/-/_/;      $type->[0] =~ tr/-/_/;
678      $r .= qq{\$SuikaWiki::Plugin::Rule{$type->[0]}->{$name} = $main;\n};      $r .= qq{\$SuikaWiki::Plugin::Rule{$type->[0]}->{$name} = $main;\n};
# Line 541  EOH Line 689  EOH
689    $r;    $r;
690  }  }
691    
692    =item FormattingRuleAlias
693    
694    Generating an alias name for a formatting rule that is already loaded.
695    Example:
696    
697      FormattingRuleAlias:
698        @Category[list]:
699          category-1
700          category-2
701          ...
702        @Name: new-rule-name
703        @Reference:
704          @@Category: one-of-category
705          @@Name: one-of-name
706    
707    associates C<(I<category-1>, I<new-rule-name>)>,
708    C<(I<category-2>, I<new-rule-name>)>, ...
709    with C<(I<one-of-category>, I<one-of-name>)>.
710    
711    =cut
712    
713    sub make_rule_alias ($$) {
714      my ($src, $Info) = @_;
715      my $type = $src->get_attribute ('Category', make_new_node => 1)->value || [];
716      my $name = $src->get_attribute ('Name', make_new_node => 1)->value;
717      
718      my $ref = $src->get_attribute ('Reference', make_new_node => 1);
719      my $c = $ref->get_attribute_value ('Category');
720      my $n = $ref->get_attribute_value ('Name');
721      
722      s/(?<=.)-/_/g for $n, $name;
723      tr/-/_/ for $c, @$type;
724      
725      my $def = qq{\$SuikaWiki::Plugin::Rule{@{[literal $c]}}->{@{[literal $n]}} or warn qq{Formatting rule "$c/$n" not defined}};
726      
727      my $r = change_package $Info, $Info->{module_name};
728      for my $type (@$type) {
729        $r .= qq{\$SuikaWiki::Plugin::Rule{@{[literal $type]}}->{@{[literal $name]}} = $def;\n};
730        push @{$Info->{provide}->{rule}->{$type}}, $name;
731      }
732      $r;
733    }
734    
735    
736  sub random_module_name ($;$) {  sub random_module_name ($;$) {
737    my ($Info, $subname) = @_;    my ($Info, $subname) = @_;
# Line 551  sub random_module_name ($;$) { Line 742  sub random_module_name ($;$) {
742      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]),
743      join ('', @rand[rand@rand,rand@rand,rand@rand,rand@rand]);      join ('', @rand[rand@rand,rand@rand,rand@rand,rand@rand]);
744  }  }
745    
746    =head1 NAME
747    
748    mkplugin2.pl - SuikaWiki: WikiPlugin Generator
749    
750    =head1 SYNOPSIS
751    
752      mkplugin2.pl pluginsrc.wp2 > plugin.pm
753    
754    =head1 DESCRIPTION
755    
756    C<mkplugin2.pl> generates WikiPlugin module as a Perl module file
757    from WikiPlugin source description.  WikiPlugin source description
758    is described in SuikaWikiConfig/2.0 format and it contains
759    definitions of wiki constructions (such as formatting rules and
760    WikiView definitions) as both machine understandable code and
761    human readable documentation.  For more information, see
762    <http://suika.fam.cx/~wakaba/-temp/wiki/wiki?WikiPlugin>.
763    
764    This script is part of SuikaWiki.
765    
766    =head1 HISTORY AND COMPATIBILITY
767    
768    C<mkplugin2.pl> introduced as part of SuikaWiki 3.
769    It converts SuikaWiki 3 WikiPlugin source descriptions
770    (in SuikaWikiConfig/2.0) into Perl modules with SuikaWiki 3 interface.
771    
772    SuikaWiki 2 has C<mkplugin.pl>.  It also converts WikiPlugin
773    source descriptions into Perl modules.  But it support
774    SuikaWiki 2 format of WikiPlugin source description that differs from
775    SuikaWiki 3 format.  Wiki programming interface (not limited to
776    WikiPlugin related one) of SuikaWiki 3 also incompatible with that
777    of SuikaWiki 2 so that it is impossible to use SuikaWiki 2 WikiPlugin
778    module with SuikaWiki 3 and vice versa.
779    
780    =head1 SEE ALSO
781    
782    C<SuikaWiki::Plugin>, SuikaWiki:WikiPlugin
783    <http://suika.fam.cx/~wakaba/-temp/wiki/wiki?WikiPlugin>.
784    
785    =head1 LICENSE
786    
787    Copyright 2003-2004 Wakaba <w@suika.fam.cx>.  All rights reserved.
788    
789    This program is free software; you can redistribute it and/or
790    modify it under the same terms as Perl itself.
791    
792    =cut
793    
794    1; # $Date$
Legend:
Removed from v.1.8  
changed lines
  Added in v.1.21
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24