/[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.16 by wakaba, Sun Apr 25 07:06:50 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:([^:]+):([^>]+)>/literal $Info->{Namespace}->{$1}.$2/ge;
63      
64      $Info->{-message_error_used} = 1 if $code =~ /\buse\s+Message::Util::Error\b/;
65      if (not $Info->{-message_error_used} and
66         ($code =~ /\btry\s*\{/ or $code =~ /\bcatch\s*\{/)) {
67        warn "Message::Util::Error MUST be 'use'd before 'try'...'catch' block used";
68      }
69    $code;    $code;
70  }  }
71  sub change_package ($$) {  sub change_package ($$) {
# Line 75  sub quoted_string ($) { Line 82  sub quoted_string ($) {
82    $s =~ s/([\\"])/\\$1/g;    $s =~ s/([\\"])/\\$1/g;
83    '"'.$s.'"';    '"'.$s.'"';
84  }  }
85    sub line ($;%) {
86      my ($Info, %opt) = @_;
87      
88      unless ($opt{file}) {
89        if ($opt{reset}) {
90          $opt{file} = sprintf '(WikiPlugin module %s, chunk %d)',
91                               $Info->{Name},
92                               ++$Info->{chunk_count};
93        } elsif ($opt{realfile}) {
94          $opt{file} = sprintf '(WikiPlugin module %s, chunk from %s)',
95                               $Info->{Name},
96                               $opt{realfile};
97        } else {
98          $opt{file} = sprintf '(WikiPlugin module source %s, block %s)',
99                               $Info->{source_file},
100                               $opt{node_path};
101        }
102      }
103      
104      $opt{file} =~ s/"/''/g;
105      sprintf '%s#line %d "%s"%s', "\n", $opt{line_no} || 1, $opt{file}, "\n";
106    }
107    sub literal_or_code ($$) {
108      my ($Info, $s) = @_;
109      substr ($s, 0, 1) ne '{' ? literal ($s)
110                               : code ($Info, substr ($s, 1, length ($s) - 2));
111    }
112    
113  my $parser = Message::Markup::SuikaWikiConfig20::Parser->new;  my $parser = Message::Markup::SuikaWikiConfig20::Parser->new;
114  my $plugins = $parser->parse_text ($src);  my $plugins = $parser->parse_text ($src);
# Line 82  my $meta = $plugins->get_attribute ('Plu Line 116  my $meta = $plugins->get_attribute ('Plu
116            or die "$0: Required 'Plugin' section not found";            or die "$0: Required 'Plugin' section not found";
117  my %Info = (provide => {},  my %Info = (provide => {},
118              Name => n11n $meta->get_attribute ('Name')->value);              Name => n11n $meta->get_attribute ('Name')->value);
119    $Info{source_file} = $srcfile;
120  $Info{name_literal} = literal $Info{Name};  $Info{name_literal} = literal $Info{Name};
121  my @date = gmtime;  my @date = gmtime;
122  $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 135  our \%Info;
135  \$Info{$Info{name_literal}}->{Name} = $Info{name_literal};  \$Info{$Info{name_literal}}->{Name} = $Info{name_literal};
136  EOH  EOH
137  for (qw/Version InterfaceVersion mkpluginVersion module_name/) {  for (qw/Version InterfaceVersion mkpluginVersion module_name/) {
138    print qq{\$Info{$Info{name_literal}}->{$_} = @{[literal $Info{$_}]};\n};    print qq{\$Info{$Info{name_literal}}->{@{[literal $_]}} = @{[literal $Info{$_}]};\n};
139  }  }
140  for (qw/LastModified/) {  for (qw/LastModified Date.RCS/) {
141    $Info{$_} = n11n $meta->get_attribute ($_,make_new_node=>1)->value;    $Info{$_} = n11n $meta->get_attribute ($_,make_new_node=>1)->value;
142    next unless length $Info{$_};    next unless length $Info{$_};
143    print qq{\$Info{$Info{name_literal}}->{$_} = } . literal $Info{$_};    print qq{\$Info{$Info{name_literal}}->{@{[literal $_]}} = } . literal $Info{$_};
144    print ";\n";    print ";\n";
145  }  }
146  for (qw/RequiredPlugin RequiredModule/) {  for (qw/RequiredPlugin RequiredModule/) {
# Line 130  print qq{\$Info{$Info{name_literal}}->{A Line 165  print qq{\$Info{$Info{name_literal}}->{A
165  } grep { $_->local_name eq 'Author' } @{$meta->child_nodes}  } grep { $_->local_name eq 'Author' } @{$meta->child_nodes}
166  ). qq{];\n};  ). qq{];\n};
167    
168    for (@{$meta->get_attribute ('Namespace', make_new_node => 1)->child_nodes}) {
169      $Info{Namespace}->{$_->local_name} = $_->value;
170    }
171    
172  my $use = $meta->get_attribute ('Use');  my $use = $meta->get_attribute ('Use');
173  if (ref $use) {  if (ref $use) {
174    print change_package \%Info, $Info{module_name};    print change_package \%Info, $Info{module_name};
175    print $use->inner_text;    print line \%Info, node_path => 'Plugin/Use';
176      print code \%Info, $use->inner_text;
177      print line \%Info, reset => 1;
178  }  }
179    
180  for (@{$plugins->child_nodes}) {  for (@{$plugins->child_nodes}) {
# Line 151  for (@{$plugins->child_nodes}) { Line 192  for (@{$plugins->child_nodes}) {
192      register_plugin_const ($_, \%Info);      register_plugin_const ($_, \%Info);
193    } elsif ($_->local_name eq 'Format') {    } elsif ($_->local_name eq 'Format') {
194      print "\n", make_format ($_, \%Info);      print "\n", make_format ($_, \%Info);
195      } elsif ($_->local_name eq 'FormattingRuleAlias') {
196        print "\n", make_rule_alias ($_, \%Info);
197    # Parameter
198    # PluginCategory
199    }    }
200  }  }
201    
# Line 166  sub make_format ($$) { Line 211  sub make_format ($$) {
211    my ($src, $Info) = @_;    my ($src, $Info) = @_;
212    my $module_name = 'SuikaWiki::Format::Definition::'.$src->get_attribute_value ('ModuleName');    my $module_name = 'SuikaWiki::Format::Definition::'.$src->get_attribute_value ('ModuleName');
213    my $r = change_package $Info, $module_name;    my $r = change_package $Info, $module_name;
214      local $Info->{-message_error_used} = 0;  
215    $r .= qq{our \@ISA;\n};    $r .= qq{our \@ISA;\n};
216    if (my $isa = $src->get_attribute_value ('Inherit')) {    if (my $isa = $src->get_attribute_value ('Inherit')) {
217      for (@$isa) {      for (@$isa) {
# Line 175  sub make_format ($$) { Line 221  sub make_format ($$) {
221      $r .= qq{push \@ISA, 'SuikaWiki::Format::Definition::template';\n};          $r .= qq{push \@ISA, 'SuikaWiki::Format::Definition::template';\n};    
222    }    }
223    if (my $name = $src->get_attribute_value ('Name')) {    if (my $name = $src->get_attribute_value ('Name')) {
224      $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};
225    }    }
226    if (my $type = $src->get_attribute_value ('Type')) {    if (my $type = $src->get_attribute_value ('Type')) {
227      $r .= qq{\$SuikaWiki::Format::Definition::Class{@{[literal $type.'//']}} = '$module_name';\n};      $type .= join '', map {
228                   ';'. $_->local_name .'='. quoted_string $_->inner_text
229                 } sort {
230                   $a->local_name cmp $b->local_name
231                 } @{$src->get_attribute ('Type')->child_nodes};
232        $r .= qq{\$SuikaWiki::Format::Definition::Class{@{[literal 'IMT:'.$type.'##']}} = '$module_name';\n};
233    }    }
234        
235    $r .= <<'EOH';    my $convert = line $Info, line_no => __LINE__ + 2, realfile => __FILE__;
236      $convert .= <<'EOH';
237  our $Converter;  our $Converter;
238  sub convert ($$;%) {  sub convert ($$;%) {
239    my ($self, $source, %opt) = @_;    my ($self, $source, %opt) = @_;
240    my $converter;    my $t = SuikaWiki::Format::Definition->serialize_media_type (%opt);
241    my $flag = '//';    my $converter = $Converter->{$t->{_}};
242    $flag .= 'f' if $opt{IsFragment};    return ($converter->{$opt{return_type} or 'Main'} or
243    $flag .= 'p' if $opt{IsPlaceholder};            CORE::die "Buggy implementation: $t->{_}/@{[$opt{return_type} or 'Main']} not defined")
244    if ($Converter->{$opt{Type}.$flag}) {           ->($self, $source, \%opt)
245      $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;  
246    $self->SUPER::convert ($source, %opt);    $self->SUPER::convert ($source, %opt);
247  }  }
248  EOH  EOH
249        
250    for (@{$src->child_nodes}) {    for (@{$src->child_nodes}) {
251      if ($_->local_name eq 'Converter') {      if ($_->local_name eq 'Converter') {
252          if ($convert) {
253            $r .= $convert;
254            $r .= line $Info, reset => 1;
255            undef $convert;
256          }
257        $r .= make_format_converter ($_, $Info);        $r .= make_format_converter ($_, $Info);
258        } elsif ($_->local_name eq 'WikiForm') {
259          $r .= q(sub wikiform {)."\n".q(my ($self, $source, %opt) = @_;);
260          $r .= line $Info, node_path => qq(Format[module-name()=$module_name]/WikiForm);
261          $r .= code $Info, $_->get_attribute_value ('Main');
262          $r .= line $Info, reset => 1;
263          $r .= qq(}\n);
264        } elsif ($_->local_name eq 'HeadSummary') {
265          $r .= q(sub headsummary {)."\n".q(my ($self, $source, %opt) = @_;);
266          $r .= line $Info, node_path => qq(Format[module-name()=$module_name]/HeadSummary);
267          $r .= code $Info, $_->get_attribute_value ('Main');
268          $r .= line $Info, reset => 1;
269          $r .= qq(}\n);
270        } elsif ($_->local_name eq 'NextIndex') {
271          my $name = $_->get_attribute_value ('Name', default => '');
272          $r .= q(sub next_index_for_).$name
273             .  q( {)."\n".q(my ($self, $source, %opt) = @_;)
274             .  line $Info, node_path => qq(Format[module-name()=$module_name]/NextIndex[Name=$name]);
275          $r .= code $Info, $_->get_attribute_value ('Main');
276          $r .= line $Info, reset => 1;
277          $r .= qq(}\n);
278      } elsif ($_->local_name eq 'Use') {      } elsif ($_->local_name eq 'Use') {
279        $r .= $_->inner_text;        $r .= line $Info, node_path => qq(Format[module-name()=$module_name]/Use);
280          $r .= code $Info, $_->inner_text;
281      }      }
282    }    }
     
283    $r;    $r;
284  }  }
285    
286  sub make_format_converter ($$) {  sub make_format_converter ($$) {
287    my ($src, $Info) = @_;    my ($src, $Info) = @_;
288    my %def;    my %def;
289    $def{Type} = $src->get_attribute ('Type');    for (qw/Type Name Version TypeURIReference IsFragment IsPlaceholder/) {
290    if (ref $def{Type}) {      $def{$_} = $src->get_attribute_value ($_);
291      $def{Type} = $def{Type}->inner_text      delete $def{$_} unless defined $def{$_};
292            . join '', map {    }
293                ';'. $_->local_name .'='. quoted_string $_->inner_text    $def{Type_param} = {map {$_->local_name => $_->value}
294              } sort {                                @{$src->get_attribute ('Type', make_new_node => 1)
295                $a->local_name cmp $b->local_name                                    ->child_nodes}};
296              } @{$def{Type}->child_nodes};    my $type = serialize_media_type ($Info,
297    } else {                 Type => $def{Type},
298      delete $def{Type};                 Type_param => $def{Type_param},
299                   Name => $def{Name},
300                   Version => $def{Version},
301                   URIReference => $def{TypeURIReference},
302                   IsFragment => $def{IsFragment},
303                   IsPlaceholder => $def{IsPlaceholder});
304      $def{serialized_type} = $type->{_};
305      
306      for (qw/Main ToString ToOctetStream/) {
307        my $def = $src->get_attribute_value ($_);
308        next unless $def;
309        $def{$_} = line ($Info, node_path => '//Converter/'.$_)
310                   . $def
311                   . line ($Info, reset => 1);
312        if ($def{$_} =~ /\$r\b/) {
313          $def{$_} = 'my $r;'."\n".$def{$_}."\n".'$r';
314        }
315        $def{$_} = barecode code $Info,
316                     'sub {my ($self, $source, $opt) = @_;'
317                   . $def{$_} . '}';
318    }    }
   $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} . '}';  
319        
320    my $r = list %def;    my $r = list %def;
321    if ($def{Type}) {    if ($type->{Type}) {
322      $r = qq{\$Converter->{@{[literal $def{Type}.$flag]}} = {$r};\n};      $r = qq{\$Converter->{@{[literal $type->{Type}]}} = {$r};\n};
323      $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}
324        if $def{Name};        if $type->{Magic};
325    } elsif ($def{Name}) {      $r .= qq{\$Converter->{@{[literal $type->{URIReference}]}} = \$Converter->{@{[literal $type->{Type}]}};\n}
326      $r = qq{\$Converter->{@{[literal '/'.$def{Name}.'/'.$def{Version}.$flag]}} = {$r};\n};        if $type->{URIReference};
327      $r    } elsif ($type->{Magic}) {
328        $r = qq{\$Converter->{@{[literal $type->{Magic}]}} = {$r};\n};
329        $r .= qq{\$Converter->{@{[literal $type->{URIReference}]}} = \$Converter->{@{[literal $type->{Magic}]}};\n}
330          if $type->{URIReference};
331      } elsif ($type->{URIReference}) {
332        $r = qq{\$Converter->{@{[literal $type->{URIReference}]}} = {$r};\n};
333      } else {
334        $r = 'BEGIN { die "Invalid Syntax of Converter: Type or Name or TypeURIReference property required" }';
335    }    }
336    $r;    $r;
337  }  }
338    
339    sub serialize_media_type ($%) {
340      my ($Info, %opt) = @_;
341      my %return;
342      if ($opt{Type}) {
343        $return{Type} = 'IMT:'.$opt{Type};
344        if ($opt{Type_param}) {
345          $return{Type} .= join '', map {my $s;
346                             ';'. $_ .'="'
347                           . (($s = $opt{Type_param}->{$_}) =~ s/([\\"])/\\$1/g, $s)
348                           . '"'
349                           } sort {
350                             $a cmp $b
351                           } keys %{$opt{Type_param}};
352        }
353      }
354      if ($opt{Magic}) {
355        $return{Magic} = 'MAGIC:'.$opt{Magic};
356      } elsif ($opt{Name}) {
357        $return{Name} = 'MAGIC:'.$opt{Name}.'/*';
358        $return{Magic} = 'MAGIC:'.$opt{Name}.'/'.$opt{Version} if $opt{Version};
359      }
360      if ($opt{URIReference}) {
361        $return{URIReference} = $opt{URIReference};
362      }
363      my $flag = '##';
364      $flag .= 'f' if $opt{IsFragment};
365      $flag .= 'p' if $opt{IsPlaceholder};
366      for (qw/URIReference Type Magic Name/) {
367        $return{$_} .= $flag if $return{$_};
368      }
369      $return{_} = $return{URIReference} || $return{Type}
370                || $return{Magic} || $return{Name};
371      \%return;
372    }
373    
374    
375  sub make_function ($$) {  sub make_function ($$) {
376    my ($src, $Info) = @_;    my ($src, $Info) = @_;
377    ## TODO: support of ARGV property    ## TODO: support of ARGV property
378      my $name;
379    my $r = <<EOH;    my $r = <<EOH;
380  @{[change_package $Info, $Info->{module_name}]}  @{[change_package $Info, $Info->{module_name}]}
381  sub @{[$src->get_attribute_value ('Name')]} {  sub @{[$name = $src->get_attribute_value ('Name')]} {
382    @{[code $Info, $src->get_attribute_value ('Main')]}  @{[line $Info, node_path => "Function[Name='$name']/Main"]}@{[
383      code $Info, $src->get_attribute_value ('Main')
384    ]}
385  }  }
386    @{[line $Info, reset => 1]}
387  EOH  EOH
388  }  }
389    
390  sub register_plugin_const ($$) {  sub register_plugin_const ($$) {
391    my ($src, $Info) = @_;    my ($src, $Info) = @_;
392    for (@{$src->child_nodes}) {    for (@{$src->child_nodes}) {
393      $Info->{const}->{$_->local_name} = $_->value;      $Info->{const}->{$_->local_name} = literal_or_code $Info, $_->value;
394    }    }
395  }  }
396    
397  sub make_resdef ($$) {  sub make_resdef ($$) {
398    my ($src, $Info) = @_;    my ($src, $Info) = @_;
399    my $r = change_package $Info, 'SuikaWiki::Plugin::Resource';    my $r = change_package $Info, 'SuikaWiki::Plugin::Resource';
400      local $Info->{-message_error_used} = 0;  
401    $r .= qq{our \$BaseResource;\n};    $r .= qq{our \$BaseResource;\n};
402    for (@{$src->child_nodes}) {    for (@{$src->child_nodes}) {
403      if ($_->node_type eq '#element') {      if ($_->node_type eq '#element') {
# Line 321  sub make_viewdef ($$) { Line 444  sub make_viewdef ($$) {
444    my ($src, $Info) = @_;    my ($src, $Info) = @_;
445    my $ViewProp = {};    my $ViewProp = {};
446    my $r = '';    my $r = '';
447    $ViewProp->{Name} = n11n $src->get_attribute ('Mode')->value;    $ViewProp->{Name} = n11n $src->get_attribute_value ('Mode');
448      $ViewProp->{Name} =~ s/(?<=.)-/_/g;
449    $ViewProp->{pack_name} = random_module_name ($Info, $ViewProp->{Name});    $ViewProp->{pack_name} = random_module_name ($Info, $ViewProp->{Name});
450        
451    $ViewProp->{condition_stringified} = hash    $ViewProp->{condition_stringified} = hash
# Line 337  push \@SuikaWiki::View::Implementation:: Line 461  push \@SuikaWiki::View::Implementation::
461  @{[change_package $Info, $ViewProp->{pack_name}]}  @{[change_package $Info, $ViewProp->{pack_name}]}
462  our \@ISA = q#SuikaWiki::View::template#;  our \@ISA = q#SuikaWiki::View::template#;
463  EOH  EOH
464      local $Info->{-message_error_used} = 0;  
465      my $use = $src->get_attribute ('Use');
466      if (ref $use) {
467        $r .= line $Info, node_path => "ViewDefinition[Mode='$ViewProp->{Name}']/Use";
468        $r .= code $Info, $use->inner_text;
469        $r .= "\n\n";
470      }
471      
472    for (@{$src->child_nodes}) {    for (@{$src->child_nodes}) {
473      if ($_->local_name eq 'template') {      if ($_->local_name eq 'template') {
474        $r .= make_view_template_method ($_, $Info);        $r .= make_view_template_method ($_, $Info, $ViewProp);
475      } elsif ($_->local_name eq 'method') {      } elsif ($_->local_name eq 'method') {
476          my $method_name = $_->get_attribute_value ('Name');
477        $r .= ({        $r .= ({
478                main => q(sub main ($$) {)."\n".q(my ($self, $opt) = @_;)."\n",                main => q(sub main ($$) {)."\n".q(my ($self, $opt, $opt2) = @_;)."\n",
479                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",
480                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",                    
481               }->{$_->get_attribute ('Name')->value}               }->{$method_name}
482               ||qq(sub @{[$_->get_attribute ('Name')->value]} {\n))               ||qq(sub @{[$method_name]} {\n))
483             . line ($Info, node_path => "ViewDefinition[Mode='$ViewProp->{Name}']/method[Name='$method_name']")
484           . code ($Info, $_->value)           . code ($Info, $_->value)
485           . qq(\n}\n);           . qq(}\n)
486             . line ($Info, reset => 1);
487      }      }
488    }    }
489    my $prop = {Name => $ViewProp->{Name},    my $prop = {Name => $ViewProp->{Name},
# Line 358  EOH Line 493  EOH
493  }  }
494    
495  sub make_view_template_method ($$) {  sub make_view_template_method ($$) {
496    my ($src, $info) = @_;    my ($src, $Info, $ViewProp) = @_;
497    my $r = <<EOH;    my $r = <<EOH;
498    
499  sub main (\$\$\$) {  sub main (\$\$\$) {
# Line 374  sub main (\$\$\$) { Line 509  sub main (\$\$\$) {
509        
510    \$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]};
511    \$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)  
     ]}},  
512                        ## SuikaWiki 3 WikiPlugin interface                        ## SuikaWiki 3 WikiPlugin interface
513                          wiki => \$self->{view}->{wiki},                          wiki => \$self->{view}->{wiki},
514                          plugin => \$self->{view}->{wiki}->{plugin},                          plugin => \$self->{view}->{wiki}->{plugin},
# Line 398  sub main (\$\$\$) { Line 517  sub main (\$\$\$) {
517    @{[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;
518       $x?q{$opt2->{output}->{status_code} = }.(0 + $x).q{;}:q{}}]}       $x?q{$opt2->{output}->{status_code} = }.(0 + $x).q{;}:q{}}]}
519    @{[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;
520       $x?q{$opt2->{output}->{reason_phrase} = }.literal($x).q{;}:q{}}]}       $x?q{$opt2->{output}->{status_phrase} = }.literal($x).q{;}:q{}}]}
521    \$opt2->{output}->{entity}->{media_type} = @{[literal    \$opt2->{output}->{entity}->{media_type} = @{[literal
522                             $src->get_attribute ('media-type',make_new_node=>1)                             $src->get_attribute ('media-type',make_new_node=>1)
523                                 ->inner_text || 'application/octet-stream']};                                 ->inner_text || 'application/octet-stream']};
# Line 413  sub main (\$\$\$) { Line 532  sub main (\$\$\$) {
532              qq{\$opt2->{output}->set_expires (delta => @{[0 + $x]});};              qq{\$opt2->{output}->set_expires (delta => @{[0 + $x]});};
533            }            }
534        }]}        }]}
535      \$opt2->{output}->{entity}->{body_is_octet_stream} = @{[
536        $src->get_attribute ('body')->get_attribute_value ('is-octet-stream', default_value => 0)
537        or 0
538      ]};
539        
540    \$self->{view}->{wiki}->init_db;    \$self->{view}->{wiki}->init_db;
541    \$self->main_pre (\$opt, \$opt2);    \$self->main_pre (\$opt, \$opt2);
542        
543    my \$fmt = SuikaWiki::Plugin->formatter ('view');    use Message::Util::Error;
544    \$opt2->{output}->{entity}->{body}    try {
545      = \$fmt->replace (\$opt2->{template}, param => \$opt2->{o});      \$opt2->{output}->{entity}->{body}
546          = SuikaWiki::Plugin->formatter ('view')
547            ->replace (\$opt2->{template}, param => \$opt2->{o});
548      } \$self->{view}->{wiki}->{config}->{catch}->{ @{[
549           $ViewProp->{Name} eq '-error' ? 'formatter_view_error'
550                                         : 'formatter_view' ]} };
551    \$opt2->{output}->output (output => 'http-cgi');    \$opt2->{output}->output (output => 'http-cgi');
552        
553    \$self->main_post (\$opt, \$opt2);    \$self->main_post (\$opt, \$opt2);
# Line 432  sub make_rule ($$) { Line 560  sub make_rule ($$) {
560    my $type = $src->get_attribute ('Category', make_new_node => 1)->value || [];    my $type = $src->get_attribute ('Category', make_new_node => 1)->value || [];
561    my $name = $src->get_attribute ('Name', make_new_node => 1)->value;    my $name = $src->get_attribute ('Name', make_new_node => 1)->value;
562    $name =~ s/(?<=.)-/_/g;    $name =~ s/(?<=.)-/_/g;
   my $main = code $Info, $src->get_attribute_value ('Formatting');  
563        
564    my $reg_block;    my $reg_block;
565    $reg_block = qr/[^{}]*(?>[^{}]+|{(??{$reg_block})})*/;    $reg_block = qr/[^{}]*(?>[^{}]+|{(??{$reg_block})})*/;
566    my $reg_attr = qr/__ATTR(TEXT|NODE)?:%(\w+)(?:->{($reg_block)})?__;/;    my %code;
567        for my $codename ([qw/Formatting main/], [qw/After after/],
568    $main = q{my ($f, $rule_name, $p, $o, %opt) = @_;}."\n".$main                      [qw/Before before/], [qw/Pre pre/], [qw/Post post/],
569      if $main =~ /\$f\b/                      [qw/Attribute attr/]) {
570      or $main =~ /\$rule_name\b/      my $main = code $Info, $src->get_attribute_value ($codename->[0]);
571      or $main =~ /\$[opr]\b/      next unless $main;
572      or $main =~ /[%\$]opt\b/;      $main = line ($Info, node_path =>
573    if ($main =~ /\$r\b/) {                "FormattingRule[name()='@{[list $type]}/$name']/".$codename->[0])
574      warn qq(Rule @{[list $type]}/$name: Use of \$r is deprecated);            . $main;
575      $main = q{my $r = '';} . "\n" . $main . "\n"      
576            . q{$p->{-parent}->append_node ($r, node_or_text => 1);};      if ( $main =~ /\$f\b/
577    }        or $main =~ /\$rule_name\b/
578    $main =~ s{$reg_attr}        or $main =~ /\$[opr]\b/
579              {($1 eq 'TEXT' ? '$p->{'.literal($2).'} = do { my $r = ' : '')        or $main =~ /[%\$]opt\b/
580               .'$f->parse_attr ($p=>'.literal($2).', $o, '        or $main =~ /\$param_(?:name|value)\n/) {
581                               .($3?'-parent => '.$3.', ':'')        if ($codename->[0] ne 'Attribute') {
582                               .($1?'-non_parsed_to_node => 1, ':'')          $main = q{my ($f, $rule_name, $p, $o, %opt) = @_;}."\n".$main;
583                               .'%opt)'        } else {
584                               .($1 eq 'TEXT' ? '; ref $r?$r->inner_text:$r}' : '')          $main = q{my ($f, $rule_name, $p, $o, $param_name => $param_value, %opt) = @_;}."\n".$main;
585                               .';'}ge;        }
586          }
587    my $main = <<EOH;      if ($main =~ /\$r\b/) {
588          warn qq(Rule @{[list $type]}/$name: Use of \$r is deprecated);
589          $main = q{my $r = '';} . "\n" . $main . "\n"
590                . q{$p->{-parent}->append_node ($r, node_or_text => 1);};
591        }
592        $main =~ s{__ATTR(TEXT|NODE)?:%(\w+|{$reg_block})(?:->{($reg_block)})?__;}
593                  {($1 eq 'TEXT' ? '$p->{'.literal_or_code($Info, $2)
594                                          .'} = do { my $r = ' : '')
595                   .'$f->parse_attr ($p=>'.literal_or_code($Info, $2).', $o, '
596                                   .($3?'-parent => '.$3.', ':'')
597                                   .($1?'-non_parsed_to_node => 1, ':'')
598                                   .'%opt)'
599                                   .($1 eq 'TEXT' ? '; ref $r?$r->inner_text:$r}'
600                                                  : '')
601                                   .';'}ge;
602        $code{$codename->[1]} = barecode "sub {$main}";
603      }
604      
605      my $main = literal {
606        Description => [barecode m13ed_val_list $src, 'Description'],
607        Parameter => {do {
608          my @r;
609          for (@{$src->child_nodes}) {
610            if ($_->local_name eq 'Parameter') {
611              push @r, $_->get_attribute_value ('Name')
612                       => {Type => $_->get_attribute_value ('Type'),
613                           Default => $_->get_attribute_value ('Default'),
614                           Description => [barecode m13ed_val_list $_, 'Description']};
615            }
616          }
617          @r;
618        }},
619        %code,
620      };
621      $main .= line $Info, reset => 1;
622    
623    
624    my  $amain = <<EOH;
625  {  {
626    main => sub {$main},    main => sub {$main},
627    @{[line ($Info, reset => 1)]}
628    Description => [@{[m13ed_val_list $src, 'Description']}],    Description => [@{[m13ed_val_list $src, 'Description']}],
629    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;  
630    }]}},    }]}},
631  }  }
632  EOH  EOH
633    my $r = change_package $Info, $Info->{module_name};    my $r = change_package $Info, $Info->{module_name};
634      local $Info->{-message_error_used} = 0;  
635    if (@$type == 1) {    if (@$type == 1) {
636      $type->[0] =~ tr/-/_/;      $type->[0] =~ tr/-/_/;
637      $r .= qq{\$SuikaWiki::Plugin::Rule{$type->[0]}->{$name} = $main;\n};      $r .= qq{\$SuikaWiki::Plugin::Rule{$type->[0]}->{$name} = $main;\n};
# Line 492  EOH Line 648  EOH
648    $r;    $r;
649  }  }
650    
651    =item FormattingRuleAlias
652    
653    Generating an alias name for a formatting rule that is already loaded.
654    Example:
655    
656      FormattingRuleAlias:
657        @Category[list]:
658          category-1
659          category-2
660          ...
661        @Name: new-rule-name
662        @Reference:
663          @@Category: one-of-category
664          @@Name: one-of-name
665    
666    associates C<(I<category-1>, I<new-rule-name>)>,
667    C<(I<category-2>, I<new-rule-name>)>, ...
668    with C<(I<one-of-category>, I<one-of-name>)>.
669    
670    =cut
671    
672    sub make_rule_alias ($$) {
673      my ($src, $Info) = @_;
674      my $type = $src->get_attribute ('Category', make_new_node => 1)->value || [];
675      my $name = $src->get_attribute ('Name', make_new_node => 1)->value;
676      
677      my $ref = $src->get_attribute ('Reference', make_new_node => 1);
678      my $c = $ref->get_attribute_value ('Category');
679      my $n = $ref->get_attribute_value ('Name');
680      
681      s/(?<=.)-/_/g for $n, $name;
682      tr/-/_/ for $c, @$type;
683      
684      my $def = qq{\$SuikaWiki::Plugin::Rule{@{[literal $c]}}->{@{[literal $n]}} or warn qq{Formatting rule "$c/$n" not defined}};
685      
686      my $r = change_package $Info, $Info->{module_name};
687      for my $type (@$type) {
688        $r .= qq{\$SuikaWiki::Plugin::Rule{@{[literal $type]}}->{@{[literal $name]}} = $def;\n};
689        push @{$Info->{provide}->{rule}->{$type}}, $name;
690      }
691      $r;
692    }
693    
694    
695  sub random_module_name ($;$) {  sub random_module_name ($;$) {
696    my ($Info, $subname) = @_;    my ($Info, $subname) = @_;
# Line 502  sub random_module_name ($;$) { Line 701  sub random_module_name ($;$) {
701      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]),
702      join ('', @rand[rand@rand,rand@rand,rand@rand,rand@rand]);      join ('', @rand[rand@rand,rand@rand,rand@rand,rand@rand]);
703  }  }
704    
705    =head1 NAME
706    
707    mkplugin2.pl - SuikaWiki: WikiPlugin Generator
708    
709    =head1 SYNOPSIS
710    
711      mkplugin2.pl pluginsrc.wp2 > plugin.pm
712    
713    =head1 DESCRIPTION
714    
715    C<mkplugin2.pl> generates WikiPlugin module as a Perl module file
716    from WikiPlugin source description.  WikiPlugin source description
717    is described in SuikaWikiConfig/2.0 format and it contains
718    definitions of wiki constructions (such as formatting rules and
719    WikiView definitions) as both machine understandable code and
720    human readable documentation.  For more information, see
721    <http://suika.fam.cx/~wakaba/-temp/wiki/wiki?WikiPlugin>.
722    
723    This script is part of SuikaWiki.
724    
725    =head1 HISTORY AND COMPATIBILITY
726    
727    C<mkplugin2.pl> introduced as part of SuikaWiki 3.
728    It converts SuikaWiki 3 WikiPlugin source descriptions
729    (in SuikaWikiConfig/2.0) into Perl modules with SuikaWiki 3 interface.
730    
731    SuikaWiki 2 has C<mkplugin.pl>.  It also converts WikiPlugin
732    source descriptions into Perl modules.  But it support
733    SuikaWiki 2 format of WikiPlugin source description that differs from
734    SuikaWiki 3 format.  Wiki programming interface (not limited to
735    WikiPlugin related one) of SuikaWiki 3 also incompatible with that
736    of SuikaWiki 2 so that it is impossible to use SuikaWiki 2 WikiPlugin
737    module with SuikaWiki 3 and vice versa.
738    
739    =head1 SEE ALSO
740    
741    C<SuikaWiki::Plugin>, SuikaWiki:WikiPlugin
742    <http://suika.fam.cx/~wakaba/-temp/wiki/wiki?WikiPlugin>.
743    
744    =head1 LICENSE
745    
746    Copyright 2003-2004 Wakaba <w@suika.fam.cx>.  All rights reserved.
747    
748    This program is free software; you can redistribute it and/or
749    modify it under the same terms as Perl itself.
750    
751    =cut
752    
753    1; # $Date$
Legend:
Removed from v.1.5  
changed lines
  Added in v.1.16
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24