/[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.4 by wakaba, Thu Oct 30 07:48:04 2003 UTC revision 1.16 by wakaba, Sun Apr 25 07:06:50 2004 UTC
# Line 1  Line 1 
1  #!/usr/bin/perl  #!/usr/bin/perl
2  use strict;  use strict;
3  our $VERSION = do{my @r=(q$Revision$=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};  our $VERSION = do{my @r=(q$Revision$=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
4  require SuikaWiki::Markup::SuikaWikiConfig20::Parser;  require Message::Markup::SuikaWikiConfig20::Parser;
5    
6  {  {
7  my $src = '';  my $src = '';
# 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 ($$) {
72      my ($Info, $pack) = @_;
73      unless ($Info->{current_package} eq $pack) {
74        $Info->{current_package} = $pack;
75        return qq{package $pack;\n\n};
76      } else {
77        return '';
78      }
79    }
80    sub quoted_string ($) {
81      my $s = shift;
82      $s =~ s/([\\"])/\\$1/g;
83      '"'.$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 = SuikaWiki::Markup::SuikaWikiConfig20::Parser->new;  my $parser = Message::Markup::SuikaWikiConfig20::Parser->new;
114  my $plugins = $parser->parse_text ($src);  my $plugins = $parser->parse_text ($src);
115  my $meta = $plugins->get_attribute ('Plugin')  my $meta = $plugins->get_attribute ('Plugin')
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 81  $Info{module_name} = random_module_name Line 130  $Info{module_name} = random_module_name
130    
131  print <<EOH;  print <<EOH;
132  use strict;  use strict;
133  package SuikaWiki::Plugin::Registry;  @{[change_package \%Info, 'SuikaWiki::Plugin::Registry']}
134  our \%Info;  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/) {  for (qw/Version InterfaceVersion mkpluginVersion module_name/) {
138    print qq{\$Info{$Info{name_literal}}->{$_} = v$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 116  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');
173    if (ref $use) {
174      print change_package \%Info, $Info{module_name};
175      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}) {
181    if ($_->local_name eq 'FormattingRule') {    if ($_->local_name eq 'FormattingRule') {
182      print "\n", make_rule ($_, \%Info);      print "\n", make_rule ($_, \%Info);
# Line 129  for (@{$plugins->child_nodes}) { Line 190  for (@{$plugins->child_nodes}) {
190      print "\n", make_resdef ($_, \%Info);      print "\n", make_resdef ($_, \%Info);
191    } elsif ($_->local_name eq 'PluginConst') {    } elsif ($_->local_name eq 'PluginConst') {
192      register_plugin_const ($_, \%Info);      register_plugin_const ($_, \%Info);
193      } elsif ($_->local_name eq 'Format') {
194        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    
202  print qq{\npackage SuikaWiki::Plugin::Registry;\n\n};  print change_package \%Info, q(SuikaWiki::Plugin::Registry);
203  print qq{\$Info{$Info{name_literal}}->{provide} = } . literal $Info{provide};  print qq{\$Info{$Info{name_literal}}->{provide} = } . literal $Info{provide};
204  print qq{;\n};  print qq{;\n};
205    
# Line 140  print "\n1;\n"; Line 207  print "\n1;\n";
207  exit;  exit;
208  }  }
209    
210    sub make_format ($$) {
211      my ($src, $Info) = @_;
212      my $module_name = 'SuikaWiki::Format::Definition::'.$src->get_attribute_value ('ModuleName');
213      my $r = change_package $Info, $module_name;
214      local $Info->{-message_error_used} = 0;  
215      $r .= qq{our \@ISA;\n};
216      if (my $isa = $src->get_attribute_value ('Inherit')) {
217        for (@$isa) {
218          $r .= qq{push \@ISA, @{[literal 'SuikaWiki::Format::Definition::'.$_]};\n};
219        }
220      } else {
221        $r .= qq{push \@ISA, 'SuikaWiki::Format::Definition::template';\n};    
222      }
223      if (my $name = $src->get_attribute_value ('Name')) {
224        $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')) {
227        $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      my $convert = line $Info, line_no => __LINE__ + 2, realfile => __FILE__;
236      $convert .= <<'EOH';
237    our $Converter;
238    sub convert ($$;%) {
239      my ($self, $source, %opt) = @_;
240      my $t = SuikaWiki::Format::Definition->serialize_media_type (%opt);
241      my $converter = $Converter->{$t->{_}};
242      return ($converter->{$opt{return_type} or 'Main'} or
243              CORE::die "Buggy implementation: $t->{_}/@{[$opt{return_type} or 'Main']} not defined")
244             ->($self, $source, \%opt)
245        if $converter;
246      $self->SUPER::convert ($source, %opt);
247    }
248    EOH
249      
250      for (@{$src->child_nodes}) {
251        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);
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') {
279          $r .= line $Info, node_path => qq(Format[module-name()=$module_name]/Use);
280          $r .= code $Info, $_->inner_text;
281        }
282      }
283      $r;
284    }
285    
286    sub make_format_converter ($$) {
287      my ($src, $Info) = @_;
288      my %def;
289      for (qw/Type Name Version TypeURIReference IsFragment IsPlaceholder/) {
290        $def{$_} = $src->get_attribute_value ($_);
291        delete $def{$_} unless defined $def{$_};
292      }
293      $def{Type_param} = {map {$_->local_name => $_->value}
294                                  @{$src->get_attribute ('Type', make_new_node => 1)
295                                      ->child_nodes}};
296      my $type = serialize_media_type ($Info,
297                   Type => $def{Type},
298                   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      }
319      
320      my $r = list %def;
321      if ($type->{Type}) {
322        $r = qq{\$Converter->{@{[literal $type->{Type}]}} = {$r};\n};
323        $r .= qq{\$Converter->{@{[literal $type->{Magic}]}} = \$Converter->{@{[literal $type->{Type}]}};\n}
324          if $type->{Magic};
325        $r .= qq{\$Converter->{@{[literal $type->{URIReference}]}} = \$Converter->{@{[literal $type->{Type}]}};\n}
326          if $type->{URIReference};
327      } 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;
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  package $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 = qq{package SuikaWiki::Plugin::Resource;\nour \$BaseResource;\n};    my $r = change_package $Info, 'SuikaWiki::Plugin::Resource';
400      local $Info->{-message_error_used} = 0;  
401      $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') {
404        my $lang = literal ($_->get_attribute_value ('lang') || 'und');        my $lang = literal ($_->get_attribute_value ('lang') || 'und');
# Line 206  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 219  push \@SuikaWiki::View::Implementation:: Line 458  push \@SuikaWiki::View::Implementation::
458    condition => {$ViewProp->{condition_stringified}},    condition => {$ViewProp->{condition_stringified}},
459    object_class => q#$ViewProp->{pack_name}#,    object_class => q#$ViewProp->{pack_name}#,
460  };  };
461  package $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 243  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 259  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 283  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 298  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    ## TODO: formal SuikaWiki 3 interface    use Message::Util::Error;
544    my \$fmt = SuikaWiki::Plugin->formatter ('view');    try {
545    \$opt2->{output}->{entity}->{body}      \$opt2->{output}->{entity}->{body}
546      = \$fmt->replace (\$opt2->{template} => \$opt2->{o},        = SuikaWiki::Plugin->formatter ('view')
547                        {formatter => \$fmt});          ->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 314  sub main (\$\$\$) { Line 555  sub main (\$\$\$) {
555  EOH  EOH
556  }  }
557    
 ## TODO: Implements SuikaWiki 3 interface  
558  sub make_rule ($$) {  sub make_rule ($$) {
559    my ($src, $Info) = @_;    my ($src, $Info) = @_;
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;
563    my $main = code $Info, $src->get_attribute_value ('Formatting');    
564    $main = q{my ($p, $o) = @_;}."\n" . $main    my $reg_block;
565      if $main =~ /\$p/ || $main =~ /\$o/;    $reg_block = qr/[^{}]*(?>[^{}]+|{(??{$reg_block})})*/;
566    if ($main =~ /\$r/) {    my %code;
567      $main = q{my $r = '';} . "\n" . $main;    for my $codename ([qw/Formatting main/], [qw/After after/],
568      $main .= q{$r};                      [qw/Before before/], [qw/Pre pre/], [qw/Post post/],
569                        [qw/Attribute attr/]) {
570        my $main = code $Info, $src->get_attribute_value ($codename->[0]);
571        next unless $main;
572        $main = line ($Info, node_path =>
573                  "FormattingRule[name()='@{[list $type]}/$name']/".$codename->[0])
574              . $main;
575        
576        if ( $main =~ /\$f\b/
577          or $main =~ /\$rule_name\b/
578          or $main =~ /\$[opr]\b/
579          or $main =~ /[%\$]opt\b/
580          or $main =~ /\$param_(?:name|value)\n/) {
581          if ($codename->[0] ne 'Attribute') {
582            $main = q{my ($f, $rule_name, $p, $o, %opt) = @_;}."\n".$main;
583          } else {
584            $main = q{my ($f, $rule_name, $p, $o, $param_name => $param_value, %opt) = @_;}."\n".$main;
585          }
586        }
587        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 = <<EOH;    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    Formatting => 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;    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};
638      push @{$Info->{provide}->{rule}->{$type->[0]}}, $name;      push @{$Info->{provide}->{rule}->{$type->[0]}}, $name;
639    } else {    } else {
640      $r = qq({my \$def = $main;\n);      $r .= qq({my \$def = $main;\n);
641      for my $type (@$type) {      for my $type (@$type) {
642        $type =~ tr/-/_/;        $type =~ tr/-/_/;
643        $r .= qq{\$SuikaWiki::Plugin::Rule{$type}->{$name} = \$def;\n};        $r .= qq{\$SuikaWiki::Plugin::Rule{$type}->{$name} = \$def;\n};
# Line 363  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 373  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.4  
changed lines
  Added in v.1.16
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24