/[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.5 by wakaba, Tue Nov 25 12:47:19 2003 UTC revision 1.18 by wakaba, Thu Jun 3 06:38:48 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 75  sub quoted_string ($) { Line 89  sub quoted_string ($) {
89    $s =~ s/([\\"])/\\$1/g;    $s =~ s/([\\"])/\\$1/g;
90    '"'.$s.'"';    '"'.$s.'"';
91  }  }
92    sub line ($;%) {
93      my ($Info, %opt) = @_;
94      
95      unless ($opt{file}) {
96        if ($opt{reset}) {
97          $opt{file} = sprintf '(WikiPlugin module %s, chunk %d)',
98                               $Info->{Name},
99                               ++$Info->{chunk_count};
100        } elsif ($opt{realfile}) {
101          $opt{file} = sprintf '(WikiPlugin module %s, chunk from %s)',
102                               $Info->{Name},
103                               $opt{realfile};
104        } else {
105          $opt{file} = sprintf '(WikiPlugin module source %s, block %s)',
106                               $Info->{source_file},
107                               $opt{node_path};
108        }
109      }
110      
111      $opt{file} =~ s/"/''/g;
112      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 82  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 100  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 130  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 $use->inner_text;    print line \%Info, node_path => 'Plugin/Use';
183      print code \%Info, $use->inner_text;
184      print line \%Info, reset => 1;
185  }  }
186    
187  for (@{$plugins->child_nodes}) {  for (@{$plugins->child_nodes}) {
# Line 151  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 166  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 175  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 .= <<'EOH';    my $convert = line $Info, line_no => __LINE__ + 2, realfile => __FILE__;
243      $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        
257    for (@{$src->child_nodes}) {    for (@{$src->child_nodes}) {
258      if ($_->local_name eq 'Converter') {      if ($_->local_name eq 'Converter') {
259          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        } 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 ({qw/content_written 1 content_removed 1 content_type_changed_from 1/}
286                 ->{my $node_name = $_->local_name}) {
287          $r .= q(sub ).$node_name
288             .  q( {)."\n".q(my ($self, %opt) = @_;)
289             .  line $Info, node_path => qq(Format[module-name()=$module_name]/$node_name]);
290          $r .= code $Info, $_->get_attribute_value ('Main');
291          $r .= line $Info, reset => 1;
292          $r .= qq(}\n);
293      } elsif ($_->local_name eq 'Use') {      } elsif ($_->local_name eq 'Use') {
294        $r .= $_->inner_text;        $r .= line $Info, node_path => qq(Format[module-name()=$module_name]/Use);
295          $r .= code $Info, $_->inner_text;
296      }      }
297    }    }
     
298    $r;    $r;
299  }  }
300    
301  sub make_format_converter ($$) {  sub make_format_converter ($$) {
302    my ($src, $Info) = @_;    my ($src, $Info) = @_;
303    my %def;    my %def;
304    $def{Type} = $src->get_attribute ('Type');    for (qw/Type Name Version TypeURIReference IsFragment IsPlaceholder/) {
305    if (ref $def{Type}) {      $def{$_} = $src->get_attribute_value ($_);
306      $def{Type} = $def{Type}->inner_text      delete $def{$_} unless defined $def{$_};
307            . join '', map {    }
308                ';'. $_->local_name .'='. quoted_string $_->inner_text    $def{Type_param} = {map {$_->local_name => $_->value}
309              } sort {                                @{$src->get_attribute ('Type', make_new_node => 1)
310                $a->local_name cmp $b->local_name                                    ->child_nodes}};
311              } @{$def{Type}->child_nodes};    my $type = serialize_media_type ($Info,
312    } else {                 Type => $def{Type},
313      delete $def{Type};                 Type_param => $def{Type_param},
314                   Name => $def{Name},
315                   Version => $def{Version},
316                   URIReference => $def{TypeURIReference},
317                   IsFragment => $def{IsFragment},
318                   IsPlaceholder => $def{IsPlaceholder});
319      $def{serialized_type} = $type->{_};
320      
321      for (qw/Main ToString ToOctetStream/) {
322        my $def = $src->get_attribute_value ($_);
323        next unless $def;
324        $def{$_} = line ($Info, node_path => '//Converter/'.$_)
325                   . $def
326                   . line ($Info, reset => 1);
327        if ($def{$_} =~ /\$r\b/) {
328          $def{$_} = 'my $r;'."\n".$def{$_}."\n".'$r';
329        }
330        $def{$_} = barecode code $Info,
331                     'sub {my ($self, $source, $opt) = @_;'
332                   . $def{$_} . '}';
333    }    }
   $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} = 'my $r;'.$def{Main}.'$r' if $def{Main} =~ /\$r\b/;  
   $def{Main} = barecode code $Info,  
                'sub {my ($self, $source, $opt) = @_;'  
              . $def{Main} . '}';  
334        
335    my $r = list %def;    my $r = list %def;
336    if ($def{Type}) {    if ($type->{Type}) {
337      $r = qq{\$Converter->{@{[literal $def{Type}.$flag]}} = {$r};\n};      $r = qq{\$Converter->{@{[literal $type->{Type}]}} = {$r};\n};
338      $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}
339        if $def{Name};        if $type->{Magic};
340    } elsif ($def{Name}) {      $r .= qq{\$Converter->{@{[literal $type->{URIReference}]}} = \$Converter->{@{[literal $type->{Type}]}};\n}
341      $r = qq{\$Converter->{@{[literal '/'.$def{Name}.'/'.$def{Version}.$flag]}} = {$r};\n};        if $type->{URIReference};
342      $r    } elsif ($type->{Magic}) {
343        $r = qq{\$Converter->{@{[literal $type->{Magic}]}} = {$r};\n};
344        $r .= qq{\$Converter->{@{[literal $type->{URIReference}]}} = \$Converter->{@{[literal $type->{Magic}]}};\n}
345          if $type->{URIReference};
346      } elsif ($type->{URIReference}) {
347        $r = qq{\$Converter->{@{[literal $type->{URIReference}]}} = {$r};\n};
348      } else {
349        $r = 'BEGIN { die "Invalid Syntax of Converter: Type or Name or TypeURIReference property required" }';
350    }    }
351    $r;    $r;
352  }  }
353    
354    sub serialize_media_type ($%) {
355      my ($Info, %opt) = @_;
356      my %return;
357      if ($opt{Type}) {
358        $return{Type} = 'IMT:'.$opt{Type};
359        if ($opt{Type_param}) {
360          $return{Type} .= join '', map {my $s;
361                             ';'. $_ .'="'
362                           . (($s = $opt{Type_param}->{$_}) =~ s/([\\"])/\\$1/g, $s)
363                           . '"'
364                           } sort {
365                             $a cmp $b
366                           } keys %{$opt{Type_param}};
367        }
368      }
369      if ($opt{Magic}) {
370        $return{Magic} = 'MAGIC:'.$opt{Magic};
371      } elsif ($opt{Name}) {
372        $return{Name} = 'MAGIC:'.$opt{Name}.'/*';
373        $return{Magic} = 'MAGIC:'.$opt{Name}.'/'.$opt{Version} if $opt{Version};
374      }
375      if ($opt{URIReference}) {
376        $return{URIReference} = $opt{URIReference};
377      }
378      my $flag = '##';
379      $flag .= 'f' if $opt{IsFragment};
380      $flag .= 'p' if $opt{IsPlaceholder};
381      for (qw/URIReference Type Magic Name/) {
382        $return{$_} .= $flag if $return{$_};
383      }
384      $return{_} = $return{URIReference} || $return{Type}
385                || $return{Magic} || $return{Name};
386      \%return;
387    }
388    
389    
390  sub make_function ($$) {  sub make_function ($$) {
391    my ($src, $Info) = @_;    my ($src, $Info) = @_;
392    ## TODO: support of ARGV property    ## TODO: support of ARGV property
393      my $name;
394    my $r = <<EOH;    my $r = <<EOH;
395  @{[change_package $Info, $Info->{module_name}]}  @{[change_package $Info, $Info->{module_name}]}
396  sub @{[$src->get_attribute_value ('Name')]} {  sub @{[$name = $src->get_attribute_value ('Name')]} {
397    @{[code $Info, $src->get_attribute_value ('Main')]}  @{[line $Info, node_path => "Function[Name='$name']/Main"]}@{[
398      code $Info, $src->get_attribute_value ('Main')
399    ]}
400  }  }
401    @{[line $Info, reset => 1]}
402  EOH  EOH
403  }  }
404    
405  sub register_plugin_const ($$) {  sub register_plugin_const ($$) {
406    my ($src, $Info) = @_;    my ($src, $Info) = @_;
407    for (@{$src->child_nodes}) {    for (@{$src->child_nodes}) {
408      $Info->{const}->{$_->local_name} = $_->value;      $Info->{const}->{$_->local_name} = literal_or_code $Info, $_->value;
409    }    }
410  }  }
411    
412  sub make_resdef ($$) {  sub make_resdef ($$) {
413    my ($src, $Info) = @_;    my ($src, $Info) = @_;
414    my $r = change_package $Info, 'SuikaWiki::Plugin::Resource';    my $r = change_package $Info, 'SuikaWiki::Plugin::Resource';
415      local $Info->{-message_error_used} = 0;  
416    $r .= qq{our \$BaseResource;\n};    $r .= qq{our \$BaseResource;\n};
417    for (@{$src->child_nodes}) {    for (@{$src->child_nodes}) {
418      if ($_->node_type eq '#element') {      if ($_->node_type eq '#element') {
# Line 321  sub make_viewdef ($$) { Line 459  sub make_viewdef ($$) {
459    my ($src, $Info) = @_;    my ($src, $Info) = @_;
460    my $ViewProp = {};    my $ViewProp = {};
461    my $r = '';    my $r = '';
462    $ViewProp->{Name} = n11n $src->get_attribute ('Mode')->value;    $ViewProp->{Name} = n11n $src->get_attribute_value ('Mode');
463      $ViewProp->{Name} =~ s/(?<=.)-/_/g;
464    $ViewProp->{pack_name} = random_module_name ($Info, $ViewProp->{Name});    $ViewProp->{pack_name} = random_module_name ($Info, $ViewProp->{Name});
465        
466    $ViewProp->{condition_stringified} = hash    $ViewProp->{condition_stringified} = hash
# Line 337  push \@SuikaWiki::View::Implementation:: Line 476  push \@SuikaWiki::View::Implementation::
476  @{[change_package $Info, $ViewProp->{pack_name}]}  @{[change_package $Info, $ViewProp->{pack_name}]}
477  our \@ISA = q#SuikaWiki::View::template#;  our \@ISA = q#SuikaWiki::View::template#;
478  EOH  EOH
479      local $Info->{-message_error_used} = 0;  
480      my $use = $src->get_attribute ('Use');
481      if (ref $use) {
482        $r .= line $Info, node_path => "ViewDefinition[Mode='$ViewProp->{Name}']/Use";
483        $r .= code $Info, $use->inner_text;
484        $r .= "\n\n";
485      }
486      
487    for (@{$src->child_nodes}) {    for (@{$src->child_nodes}) {
488      if ($_->local_name eq 'template') {      if ($_->local_name eq 'template') {
489        $r .= make_view_template_method ($_, $Info);        $r .= make_view_template_method ($_, $Info, $ViewProp);
490      } elsif ($_->local_name eq 'method') {      } elsif ($_->local_name eq 'method') {
491          my $method_name = $_->get_attribute_value ('Name');
492        $r .= ({        $r .= ({
493                main => q(sub main ($$) {)."\n".q(my ($self, $opt) = @_;)."\n",                main => q(sub main ($$) {)."\n".q(my ($self, $opt, $opt2) = @_;)."\n",
494                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",
495                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",                    
496               }->{$_->get_attribute ('Name')->value}               }->{$method_name}
497               ||qq(sub @{[$_->get_attribute ('Name')->value]} {\n))               ||qq(sub @{[$method_name]} {\n))
498             . line ($Info, node_path => "ViewDefinition[Mode='$ViewProp->{Name}']/method[Name='$method_name']")
499           . code ($Info, $_->value)           . code ($Info, $_->value)
500           . qq(\n}\n);           . qq(}\n)
501             . line ($Info, reset => 1);
502      }      }
503    }    }
504    my $prop = {Name => $ViewProp->{Name},    my $prop = {Name => $ViewProp->{Name},
# Line 358  EOH Line 508  EOH
508  }  }
509    
510  sub make_view_template_method ($$) {  sub make_view_template_method ($$) {
511    my ($src, $info) = @_;    my ($src, $Info, $ViewProp) = @_;
512      my $media_type = $src->get_attribute_value
513                                ('media-type',
514                                 default => q<application/octet-stream>);
515    my $r = <<EOH;    my $r = <<EOH;
516    
517  sub main (\$\$\$) {  sub main (\$\$\$) {
# Line 374  sub main (\$\$\$) { Line 527  sub main (\$\$\$) {
527        
528    \$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]};
529    \$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)  
     ]}},  
530                        ## SuikaWiki 3 WikiPlugin interface                        ## SuikaWiki 3 WikiPlugin interface
531                          wiki => \$self->{view}->{wiki},                          wiki => \$self->{view}->{wiki},
532                          plugin => \$self->{view}->{wiki}->{plugin},                          plugin => \$self->{view}->{wiki}->{plugin},
# Line 398  sub main (\$\$\$) { Line 535  sub main (\$\$\$) {
535    @{[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;
536       $x?q{$opt2->{output}->{status_code} = }.(0 + $x).q{;}:q{}}]}       $x?q{$opt2->{output}->{status_code} = }.(0 + $x).q{;}:q{}}]}
537    @{[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;
538       $x?q{$opt2->{output}->{reason_phrase} = }.literal($x).q{;}:q{}}]}       $x?q{$opt2->{output}->{status_phrase} = }.literal($x).q{;}:q{}}]}
539    \$opt2->{output}->{entity}->{media_type} = @{[literal    \$opt2->{output}->{entity}->{media_type} = @{[literal $media_type]};
540                             $src->get_attribute ('media-type',make_new_node=>1)  
                                ->inner_text || 'application/octet-stream']};  
541    @{[($src->get_attribute ('use-media-type-charset',make_new_node=>1)    @{[($src->get_attribute ('use-media-type-charset',make_new_node=>1)
542              ->inner_text || 0) ?              ->inner_text || 0) ?
543       q{$opt2->{output}->{entity}->{charset} = $self->{view}->{wiki}->{config}->{charset}->{output};}:       q{$opt2->{output}->{entity}->{charset} = $self->{view}->{wiki}->{config}->{charset}->{output};}:
# Line 413  sub main (\$\$\$) { Line 549  sub main (\$\$\$) {
549              qq{\$opt2->{output}->set_expires (delta => @{[0 + $x]});};              qq{\$opt2->{output}->set_expires (delta => @{[0 + $x]});};
550            }            }
551        }]}        }]}
552      \$opt2->{output}->{entity}->{body_is_octet_stream} = @{[
553        $src->get_attribute ('body')->get_attribute_value ('is-octet-stream', default_value => 0)
554        or 0
555      ]};
556        
557    \$self->{view}->{wiki}->init_db;    \$self->{view}->{wiki}->init_db;
558    \$self->main_pre (\$opt, \$opt2);    \$self->main_pre (\$opt, \$opt2);
559        
560    my \$fmt = SuikaWiki::Plugin->formatter ('view');    @{[$media_type eq 'text/html' ? q{require Message::Markup::XML::Serialize::HTML;} : '']}
561    \$opt2->{output}->{entity}->{body}    use Message::Util::Error;
562      = \$fmt->replace (\$opt2->{template}, param => \$opt2->{o});    try {
563        \$opt2->{output}->{entity}->{body}
564          = @{[$media_type eq 'text/html' ? q{Message::Markup::XML::Serialize::HTML::html_simple} : '']}
565            (SuikaWiki::Plugin->formatter ('view')
566            ->replace (\$opt2->{template}, param => \$opt2->{o}));
567      } \$self->{view}->{wiki}->{config}->{catch}->{ @{[
568           $ViewProp->{Name} eq '-error' ? 'formatter_view_error'
569                                         : 'formatter_view' ]} };
570    \$opt2->{output}->output (output => 'http-cgi');    \$opt2->{output}->output (output => 'http-cgi');
571        
572    \$self->main_post (\$opt, \$opt2);    \$self->main_post (\$opt, \$opt2);
# Line 432  sub make_rule ($$) { Line 579  sub make_rule ($$) {
579    my $type = $src->get_attribute ('Category', make_new_node => 1)->value || [];    my $type = $src->get_attribute ('Category', make_new_node => 1)->value || [];
580    my $name = $src->get_attribute ('Name', make_new_node => 1)->value;    my $name = $src->get_attribute ('Name', make_new_node => 1)->value;
581    $name =~ s/(?<=.)-/_/g;    $name =~ s/(?<=.)-/_/g;
   my $main = code $Info, $src->get_attribute_value ('Formatting');  
582        
583    my $reg_block;    my $reg_block;
584    $reg_block = qr/[^{}]*(?>[^{}]+|{(??{$reg_block})})*/;    $reg_block = qr/[^{}]*(?>[^{}]+|{(??{$reg_block})})*/;
585    my $reg_attr = qr/__ATTR(TEXT|NODE)?:%(\w+)(?:->{($reg_block)})?__;/;    my %code;
586        for my $codename ([qw/Formatting main/], [qw/After after/],
587    $main = q{my ($f, $rule_name, $p, $o, %opt) = @_;}."\n".$main                      [qw/Before before/], [qw/Pre pre/], [qw/Post post/],
588      if $main =~ /\$f\b/                      [qw/Attribute attr/]) {
589      or $main =~ /\$rule_name\b/      my $main = code $Info, $src->get_attribute_value ($codename->[0]);
590      or $main =~ /\$[opr]\b/      next unless $main;
591      or $main =~ /[%\$]opt\b/;      $main = line ($Info, node_path =>
592    if ($main =~ /\$r\b/) {                "FormattingRule[name()='@{[list $type]}/$name']/".$codename->[0])
593      warn qq(Rule @{[list $type]}/$name: Use of \$r is deprecated);            . $main;
594      $main = q{my $r = '';} . "\n" . $main . "\n"      
595            . q{$p->{-parent}->append_node ($r, node_or_text => 1);};      if ( $main =~ /\$f\b/
596    }        or $main =~ /\$rule_name\b/
597    $main =~ s{$reg_attr}        or $main =~ /\$[opr]\b/
598              {($1 eq 'TEXT' ? '$p->{'.literal($2).'} = do { my $r = ' : '')        or $main =~ /[%\$]opt\b/
599               .'$f->parse_attr ($p=>'.literal($2).', $o, '        or $main =~ /\$param_(?:name|value)\n/) {
600                               .($3?'-parent => '.$3.', ':'')        if ($codename->[0] ne 'Attribute') {
601                               .($1?'-non_parsed_to_node => 1, ':'')          $main = q{my ($f, $rule_name, $p, $o, %opt) = @_;}."\n".$main;
602                               .'%opt)'        } else {
603                               .($1 eq 'TEXT' ? '; ref $r?$r->inner_text:$r}' : '')          $main = q{my ($f, $rule_name, $p, $o, $param_name => $param_value, %opt) = @_;}."\n".$main;
604                               .';'}ge;        }
605          }
606    my $main = <<EOH;      if ($main =~ /\$r\b/) {
607          warn qq(Rule @{[list $type]}/$name: Use of \$r is deprecated);
608          $main = q{my $r = '';} . "\n" . $main . "\n"
609                . q{$p->{-parent}->append_node ($r, node_or_text => 1);};
610        }
611        $main =~ s{__ATTR(TEXT|NODE)?:%(\w+|{$reg_block})(?:->{($reg_block)})?__;}
612                  {($1 eq 'TEXT' ? '$p->{'.literal_or_code($Info, $2)
613                                          .'} = do { my $r = ' : '')
614                   .'$f->parse_attr ($p=>'.literal_or_code($Info, $2).', $o, '
615                                   .($3?'-parent => '.$3.', ':'')
616                                   .($1?'-non_parsed_to_node => 1, ':'')
617                                   .'%opt)'
618                                   .($1 eq 'TEXT' ? '; ref $r?$r->inner_text:$r}'
619                                                  : '')
620                                   .';'}ge;
621        $code{$codename->[1]} = barecode "sub {$main}";
622      }
623      
624      my $main = literal {
625        Description => [barecode m13ed_val_list $src, 'Description'],
626        Parameter => {do {
627          my @r;
628          for (@{$src->child_nodes}) {
629            if ($_->local_name eq 'Parameter') {
630              push @r, $_->get_attribute_value ('Name')
631                       => {Type => $_->get_attribute_value ('Type'),
632                           Default => $_->get_attribute_value ('Default'),
633                           Description => [barecode m13ed_val_list $_, 'Description']};
634            }
635          }
636          @r;
637        }},
638        %code,
639      };
640      $main .= line $Info, reset => 1;
641    
642    
643    my  $amain = <<EOH;
644  {  {
645    main => sub {$main},    main => sub {$main},
646    @{[line ($Info, reset => 1)]}
647    Description => [@{[m13ed_val_list $src, 'Description']}],    Description => [@{[m13ed_val_list $src, 'Description']}],
648    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;  
649    }]}},    }]}},
650  }  }
651  EOH  EOH
652    my $r = change_package $Info, $Info->{module_name};    my $r = change_package $Info, $Info->{module_name};
653      local $Info->{-message_error_used} = 0;  
654    if (@$type == 1) {    if (@$type == 1) {
655      $type->[0] =~ tr/-/_/;      $type->[0] =~ tr/-/_/;
656      $r .= qq{\$SuikaWiki::Plugin::Rule{$type->[0]}->{$name} = $main;\n};      $r .= qq{\$SuikaWiki::Plugin::Rule{$type->[0]}->{$name} = $main;\n};
# Line 492  EOH Line 667  EOH
667    $r;    $r;
668  }  }
669    
670    =item FormattingRuleAlias
671    
672    Generating an alias name for a formatting rule that is already loaded.
673    Example:
674    
675      FormattingRuleAlias:
676        @Category[list]:
677          category-1
678          category-2
679          ...
680        @Name: new-rule-name
681        @Reference:
682          @@Category: one-of-category
683          @@Name: one-of-name
684    
685    associates C<(I<category-1>, I<new-rule-name>)>,
686    C<(I<category-2>, I<new-rule-name>)>, ...
687    with C<(I<one-of-category>, I<one-of-name>)>.
688    
689    =cut
690    
691    sub make_rule_alias ($$) {
692      my ($src, $Info) = @_;
693      my $type = $src->get_attribute ('Category', make_new_node => 1)->value || [];
694      my $name = $src->get_attribute ('Name', make_new_node => 1)->value;
695      
696      my $ref = $src->get_attribute ('Reference', make_new_node => 1);
697      my $c = $ref->get_attribute_value ('Category');
698      my $n = $ref->get_attribute_value ('Name');
699      
700      s/(?<=.)-/_/g for $n, $name;
701      tr/-/_/ for $c, @$type;
702      
703      my $def = qq{\$SuikaWiki::Plugin::Rule{@{[literal $c]}}->{@{[literal $n]}} or warn qq{Formatting rule "$c/$n" not defined}};
704      
705      my $r = change_package $Info, $Info->{module_name};
706      for my $type (@$type) {
707        $r .= qq{\$SuikaWiki::Plugin::Rule{@{[literal $type]}}->{@{[literal $name]}} = $def;\n};
708        push @{$Info->{provide}->{rule}->{$type}}, $name;
709      }
710      $r;
711    }
712    
713    
714  sub random_module_name ($;$) {  sub random_module_name ($;$) {
715    my ($Info, $subname) = @_;    my ($Info, $subname) = @_;
# Line 502  sub random_module_name ($;$) { Line 720  sub random_module_name ($;$) {
720      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]),
721      join ('', @rand[rand@rand,rand@rand,rand@rand,rand@rand]);      join ('', @rand[rand@rand,rand@rand,rand@rand,rand@rand]);
722  }  }
723    
724    =head1 NAME
725    
726    mkplugin2.pl - SuikaWiki: WikiPlugin Generator
727    
728    =head1 SYNOPSIS
729    
730      mkplugin2.pl pluginsrc.wp2 > plugin.pm
731    
732    =head1 DESCRIPTION
733    
734    C<mkplugin2.pl> generates WikiPlugin module as a Perl module file
735    from WikiPlugin source description.  WikiPlugin source description
736    is described in SuikaWikiConfig/2.0 format and it contains
737    definitions of wiki constructions (such as formatting rules and
738    WikiView definitions) as both machine understandable code and
739    human readable documentation.  For more information, see
740    <http://suika.fam.cx/~wakaba/-temp/wiki/wiki?WikiPlugin>.
741    
742    This script is part of SuikaWiki.
743    
744    =head1 HISTORY AND COMPATIBILITY
745    
746    C<mkplugin2.pl> introduced as part of SuikaWiki 3.
747    It converts SuikaWiki 3 WikiPlugin source descriptions
748    (in SuikaWikiConfig/2.0) into Perl modules with SuikaWiki 3 interface.
749    
750    SuikaWiki 2 has C<mkplugin.pl>.  It also converts WikiPlugin
751    source descriptions into Perl modules.  But it support
752    SuikaWiki 2 format of WikiPlugin source description that differs from
753    SuikaWiki 3 format.  Wiki programming interface (not limited to
754    WikiPlugin related one) of SuikaWiki 3 also incompatible with that
755    of SuikaWiki 2 so that it is impossible to use SuikaWiki 2 WikiPlugin
756    module with SuikaWiki 3 and vice versa.
757    
758    =head1 SEE ALSO
759    
760    C<SuikaWiki::Plugin>, SuikaWiki:WikiPlugin
761    <http://suika.fam.cx/~wakaba/-temp/wiki/wiki?WikiPlugin>.
762    
763    =head1 LICENSE
764    
765    Copyright 2003-2004 Wakaba <w@suika.fam.cx>.  All rights reserved.
766    
767    This program is free software; you can redistribute it and/or
768    modify it under the same terms as Perl itself.
769    
770    =cut
771    
772    1; # $Date$
Legend:
Removed from v.1.5  
changed lines
  Added in v.1.18
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24