/[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.17 by wakaba, Sat May 1 03:55:05 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:([^:]+):([^>]+)>}{
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 ($$) {
79      my ($Info, $pack) = @_;
80      unless ($Info->{current_package} eq $pack) {
81        $Info->{current_package} = $pack;
82        return qq{package $pack;\n\n};
83      } else {
84        return '';
85      }
86    }
87    sub quoted_string ($) {
88      my $s = shift;
89      $s =~ s/([\\"])/\\$1/g;
90      '"'.$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 = SuikaWiki::Markup::SuikaWikiConfig20::Parser->new;  my $parser = Message::Markup::SuikaWikiConfig20::Parser->new;
121  my $plugins = $parser->parse_text ($src);  my $plugins = $parser->parse_text ($src);
122  my $meta = $plugins->get_attribute ('Plugin')  my $meta = $plugins->get_attribute ('Plugin')
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 81  $Info{module_name} = random_module_name Line 137  $Info{module_name} = random_module_name
137    
138  print <<EOH;  print <<EOH;
139  use strict;  use strict;
140  package SuikaWiki::Plugin::Registry;  @{[change_package \%Info, 'SuikaWiki::Plugin::Registry']}
141  our \%Info;  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/) {  for (qw/Version InterfaceVersion mkpluginVersion module_name/) {
145    print qq{\$Info{$Info{name_literal}}->{$_} = v$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 116  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');
180    if (ref $use) {
181      print change_package \%Info, $Info{module_name};
182      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}) {
188    if ($_->local_name eq 'FormattingRule') {    if ($_->local_name eq 'FormattingRule') {
189      print "\n", make_rule ($_, \%Info);      print "\n", make_rule ($_, \%Info);
# Line 129  for (@{$plugins->child_nodes}) { Line 197  for (@{$plugins->child_nodes}) {
197      print "\n", make_resdef ($_, \%Info);      print "\n", make_resdef ($_, \%Info);
198    } elsif ($_->local_name eq 'PluginConst') {    } elsif ($_->local_name eq 'PluginConst') {
199      register_plugin_const ($_, \%Info);      register_plugin_const ($_, \%Info);
200      } elsif ($_->local_name eq 'Format') {
201        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    
209  print qq{\npackage SuikaWiki::Plugin::Registry;\n\n};  print change_package \%Info, q(SuikaWiki::Plugin::Registry);
210  print qq{\$Info{$Info{name_literal}}->{provide} = } . literal $Info{provide};  print qq{\$Info{$Info{name_literal}}->{provide} = } . literal $Info{provide};
211  print qq{;\n};  print qq{;\n};
212    
# Line 140  print "\n1;\n"; Line 214  print "\n1;\n";
214  exit;  exit;
215  }  }
216    
217    sub make_format ($$) {
218      my ($src, $Info) = @_;
219      my $module_name = 'SuikaWiki::Format::Definition::'.$src->get_attribute_value ('ModuleName');
220      my $r = change_package $Info, $module_name;
221      local $Info->{-message_error_used} = 0;  
222      $r .= qq{our \@ISA;\n};
223      if (my $isa = $src->get_attribute_value ('Inherit')) {
224        for (@$isa) {
225          $r .= qq{push \@ISA, @{[literal 'SuikaWiki::Format::Definition::'.$_]};\n};
226        }
227      } else {
228        $r .= qq{push \@ISA, 'SuikaWiki::Format::Definition::template';\n};    
229      }
230      if (my $name = $src->get_attribute_value ('Name')) {
231        $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')) {
234        $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      my $convert = line $Info, line_no => __LINE__ + 2, realfile => __FILE__;
243      $convert .= <<'EOH';
244    our $Converter;
245    sub convert ($$;%) {
246      my ($self, $source, %opt) = @_;
247      my $t = SuikaWiki::Format::Definition->serialize_media_type (%opt);
248      my $converter = $Converter->{$t->{_}};
249      return ($converter->{$opt{return_type} or 'Main'} or
250              CORE::die "Buggy implementation: $t->{_}/@{[$opt{return_type} or 'Main']} not defined")
251             ->($self, $source, \%opt)
252        if $converter;
253      $self->SUPER::convert ($source, %opt);
254    }
255    EOH
256      
257      for (@{$src->child_nodes}) {
258        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);
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 ($_->local_name eq 'Use') {
286          $r .= line $Info, node_path => qq(Format[module-name()=$module_name]/Use);
287          $r .= code $Info, $_->inner_text;
288        }
289      }
290      $r;
291    }
292    
293    sub make_format_converter ($$) {
294      my ($src, $Info) = @_;
295      my %def;
296      for (qw/Type Name Version TypeURIReference IsFragment IsPlaceholder/) {
297        $def{$_} = $src->get_attribute_value ($_);
298        delete $def{$_} unless defined $def{$_};
299      }
300      $def{Type_param} = {map {$_->local_name => $_->value}
301                                  @{$src->get_attribute ('Type', make_new_node => 1)
302                                      ->child_nodes}};
303      my $type = serialize_media_type ($Info,
304                   Type => $def{Type},
305                   Type_param => $def{Type_param},
306                   Name => $def{Name},
307                   Version => $def{Version},
308                   URIReference => $def{TypeURIReference},
309                   IsFragment => $def{IsFragment},
310                   IsPlaceholder => $def{IsPlaceholder});
311      $def{serialized_type} = $type->{_};
312      
313      for (qw/Main ToString ToOctetStream/) {
314        my $def = $src->get_attribute_value ($_);
315        next unless $def;
316        $def{$_} = line ($Info, node_path => '//Converter/'.$_)
317                   . $def
318                   . line ($Info, reset => 1);
319        if ($def{$_} =~ /\$r\b/) {
320          $def{$_} = 'my $r;'."\n".$def{$_}."\n".'$r';
321        }
322        $def{$_} = barecode code $Info,
323                     'sub {my ($self, $source, $opt) = @_;'
324                   . $def{$_} . '}';
325      }
326      
327      my $r = list %def;
328      if ($type->{Type}) {
329        $r = qq{\$Converter->{@{[literal $type->{Type}]}} = {$r};\n};
330        $r .= qq{\$Converter->{@{[literal $type->{Magic}]}} = \$Converter->{@{[literal $type->{Type}]}};\n}
331          if $type->{Magic};
332        $r .= qq{\$Converter->{@{[literal $type->{URIReference}]}} = \$Converter->{@{[literal $type->{Type}]}};\n}
333          if $type->{URIReference};
334      } elsif ($type->{Magic}) {
335        $r = qq{\$Converter->{@{[literal $type->{Magic}]}} = {$r};\n};
336        $r .= qq{\$Converter->{@{[literal $type->{URIReference}]}} = \$Converter->{@{[literal $type->{Magic}]}};\n}
337          if $type->{URIReference};
338      } elsif ($type->{URIReference}) {
339        $r = qq{\$Converter->{@{[literal $type->{URIReference}]}} = {$r};\n};
340      } else {
341        $r = 'BEGIN { die "Invalid Syntax of Converter: Type or Name or TypeURIReference property required" }';
342      }
343      $r;
344    }
345    
346    sub serialize_media_type ($%) {
347      my ($Info, %opt) = @_;
348      my %return;
349      if ($opt{Type}) {
350        $return{Type} = 'IMT:'.$opt{Type};
351        if ($opt{Type_param}) {
352          $return{Type} .= join '', map {my $s;
353                             ';'. $_ .'="'
354                           . (($s = $opt{Type_param}->{$_}) =~ s/([\\"])/\\$1/g, $s)
355                           . '"'
356                           } sort {
357                             $a cmp $b
358                           } keys %{$opt{Type_param}};
359        }
360      }
361      if ($opt{Magic}) {
362        $return{Magic} = 'MAGIC:'.$opt{Magic};
363      } elsif ($opt{Name}) {
364        $return{Name} = 'MAGIC:'.$opt{Name}.'/*';
365        $return{Magic} = 'MAGIC:'.$opt{Name}.'/'.$opt{Version} if $opt{Version};
366      }
367      if ($opt{URIReference}) {
368        $return{URIReference} = $opt{URIReference};
369      }
370      my $flag = '##';
371      $flag .= 'f' if $opt{IsFragment};
372      $flag .= 'p' if $opt{IsPlaceholder};
373      for (qw/URIReference Type Magic Name/) {
374        $return{$_} .= $flag if $return{$_};
375      }
376      $return{_} = $return{URIReference} || $return{Type}
377                || $return{Magic} || $return{Name};
378      \%return;
379    }
380    
381    
382  sub make_function ($$) {  sub make_function ($$) {
383    my ($src, $Info) = @_;    my ($src, $Info) = @_;
384    ## TODO: support of ARGV property    ## TODO: support of ARGV property
385      my $name;
386    my $r = <<EOH;    my $r = <<EOH;
387  package $Info->{module_name};  @{[change_package $Info, $Info->{module_name}]}
388  sub @{[$src->get_attribute_value ('Name')]} {  sub @{[$name = $src->get_attribute_value ('Name')]} {
389    @{[code $Info, $src->get_attribute_value ('Main')]}  @{[line $Info, node_path => "Function[Name='$name']/Main"]}@{[
390      code $Info, $src->get_attribute_value ('Main')
391    ]}
392  }  }
393    @{[line $Info, reset => 1]}
394  EOH  EOH
395  }  }
396    
397  sub register_plugin_const ($$) {  sub register_plugin_const ($$) {
398    my ($src, $Info) = @_;    my ($src, $Info) = @_;
399    for (@{$src->child_nodes}) {    for (@{$src->child_nodes}) {
400      $Info->{const}->{$_->local_name} = $_->value;      $Info->{const}->{$_->local_name} = literal_or_code $Info, $_->value;
401    }    }
402  }  }
403    
404  sub make_resdef ($$) {  sub make_resdef ($$) {
405    my ($src, $Info) = @_;    my ($src, $Info) = @_;
406    my $r = qq{package SuikaWiki::Plugin::Resource;\nour \$BaseResource;\n};    my $r = change_package $Info, 'SuikaWiki::Plugin::Resource';
407      local $Info->{-message_error_used} = 0;  
408      $r .= qq{our \$BaseResource;\n};
409    for (@{$src->child_nodes}) {    for (@{$src->child_nodes}) {
410      if ($_->node_type eq '#element') {      if ($_->node_type eq '#element') {
411        my $lang = literal ($_->get_attribute_value ('lang') || 'und');        my $lang = literal ($_->get_attribute_value ('lang') || 'und');
# Line 206  sub make_viewdef ($$) { Line 451  sub make_viewdef ($$) {
451    my ($src, $Info) = @_;    my ($src, $Info) = @_;
452    my $ViewProp = {};    my $ViewProp = {};
453    my $r = '';    my $r = '';
454    $ViewProp->{Name} = n11n $src->get_attribute ('Mode')->value;    $ViewProp->{Name} = n11n $src->get_attribute_value ('Mode');
455      $ViewProp->{Name} =~ s/(?<=.)-/_/g;
456    $ViewProp->{pack_name} = random_module_name ($Info, $ViewProp->{Name});    $ViewProp->{pack_name} = random_module_name ($Info, $ViewProp->{Name});
457        
458    $ViewProp->{condition_stringified} = hash    $ViewProp->{condition_stringified} = hash
# Line 219  push \@SuikaWiki::View::Implementation:: Line 465  push \@SuikaWiki::View::Implementation::
465    condition => {$ViewProp->{condition_stringified}},    condition => {$ViewProp->{condition_stringified}},
466    object_class => q#$ViewProp->{pack_name}#,    object_class => q#$ViewProp->{pack_name}#,
467  };  };
468  package $ViewProp->{pack_name};  @{[change_package $Info, $ViewProp->{pack_name}]}
469  our \@ISA = q#SuikaWiki::View::template#;  our \@ISA = q#SuikaWiki::View::template#;
470  EOH  EOH
471      local $Info->{-message_error_used} = 0;  
472      my $use = $src->get_attribute ('Use');
473      if (ref $use) {
474        $r .= line $Info, node_path => "ViewDefinition[Mode='$ViewProp->{Name}']/Use";
475        $r .= code $Info, $use->inner_text;
476        $r .= "\n\n";
477      }
478      
479    for (@{$src->child_nodes}) {    for (@{$src->child_nodes}) {
480      if ($_->local_name eq 'template') {      if ($_->local_name eq 'template') {
481        $r .= make_view_template_method ($_, $Info);        $r .= make_view_template_method ($_, $Info, $ViewProp);
482      } elsif ($_->local_name eq 'method') {      } elsif ($_->local_name eq 'method') {
483          my $method_name = $_->get_attribute_value ('Name');
484        $r .= ({        $r .= ({
485                main => q(sub main ($$) {)."\n".q(my ($self, $opt) = @_;)."\n",                main => q(sub main ($$) {)."\n".q(my ($self, $opt, $opt2) = @_;)."\n",
486                main_pre => q(sub main_pre ($$$) {)."\n".q(my ($self, $opt, $opt2) = @_;)."\n",                main_pre => q(sub main_pre ($$$) {)."\n".q(my ($self, $opt, $opt2) = @_;)."\n",
487                main_post => q(sub main_post ($$$) {)."\n".q(my ($self, $opt, $opt2) = @_;)."\n",                                    main_post => q(sub main_post ($$$) {)."\n".q(my ($self, $opt, $opt2) = @_;)."\n",                    
488               }->{$_->get_attribute ('Name')->value}               }->{$method_name}
489               ||qq(sub @{[$_->get_attribute ('Name')->value]} {\n))               ||qq(sub @{[$method_name]} {\n))
490             . line ($Info, node_path => "ViewDefinition[Mode='$ViewProp->{Name}']/method[Name='$method_name']")
491           . code ($Info, $_->value)           . code ($Info, $_->value)
492           . qq(\n}\n);           . qq(}\n)
493             . line ($Info, reset => 1);
494      }      }
495    }    }
496    my $prop = {Name => $ViewProp->{Name},    my $prop = {Name => $ViewProp->{Name},
# Line 243  EOH Line 500  EOH
500  }  }
501    
502  sub make_view_template_method ($$) {  sub make_view_template_method ($$) {
503    my ($src, $info) = @_;    my ($src, $Info, $ViewProp) = @_;
504    my $r = <<EOH;    my $r = <<EOH;
505    
506  sub main (\$\$\$) {  sub main (\$\$\$) {
# Line 259  sub main (\$\$\$) { Line 516  sub main (\$\$\$) {
516        
517    \$opt2->{template} = @{[literal $src->get_attribute ('body', make_new_node => 1)->inner_text]};    \$opt2->{template} = @{[literal $src->get_attribute ('body', make_new_node => 1)->inner_text]};
518    \$opt2->{o} = bless {    \$opt2->{o} = bless {
                      ## Compatible options for SuikaWiki 2 WikiPlugin interface  
                        param => \\\%main::form,  
                        page => \$main::form{mypage},  
                        toc => [],  
                        #magic  
                        #content  
                        #use_anchor_name  
                        media => {@{[hash  
     type => ($src->get_attribute ('media-type',make_new_node=>1)->inner_text  
              || 'application/octet-stream'),  
     charset => ($src->get_attribute ('use-media-type-charset',make_new_node=>1)  
                     ->inner_text || 0),  
     ## In fact, this value is not referred from any SuikaWiki 2 WikiPlugin rule.  
     #expires => ($src->get_attribute ('expires',make_new_node=>1)->inner_text  
     #                             || 0)  
     ]}},  
519                        ## SuikaWiki 3 WikiPlugin interface                        ## SuikaWiki 3 WikiPlugin interface
520                          wiki => \$self->{view}->{wiki},                          wiki => \$self->{view}->{wiki},
521                          plugin => \$self->{view}->{wiki}->{plugin},                          plugin => \$self->{view}->{wiki}->{plugin},
# Line 283  sub main (\$\$\$) { Line 524  sub main (\$\$\$) {
524    @{[do{my $x=$src->get_attribute('http-status-code',make_new_node=>1)->inner_text;    @{[do{my $x=$src->get_attribute('http-status-code',make_new_node=>1)->inner_text;
525       $x?q{$opt2->{output}->{status_code} = }.(0 + $x).q{;}:q{}}]}       $x?q{$opt2->{output}->{status_code} = }.(0 + $x).q{;}:q{}}]}
526    @{[do{my $x=$src->get_attribute('http-status-phrase',make_new_node=>1)->inner_text;    @{[do{my $x=$src->get_attribute('http-status-phrase',make_new_node=>1)->inner_text;
527       $x?q{$opt2->{output}->{reason_phrase} = }.literal($x).q{;}:q{}}]}       $x?q{$opt2->{output}->{status_phrase} = }.literal($x).q{;}:q{}}]}
528    \$opt2->{output}->{entity}->{media_type} = @{[literal    \$opt2->{output}->{entity}->{media_type} = @{[literal
529                             $src->get_attribute ('media-type',make_new_node=>1)                             $src->get_attribute ('media-type',make_new_node=>1)
530                                 ->inner_text || 'application/octet-stream']};                                 ->inner_text || 'application/octet-stream']};
# Line 298  sub main (\$\$\$) { Line 539  sub main (\$\$\$) {
539              qq{\$opt2->{output}->set_expires (delta => @{[0 + $x]});};              qq{\$opt2->{output}->set_expires (delta => @{[0 + $x]});};
540            }            }
541        }]}        }]}
542      \$opt2->{output}->{entity}->{body_is_octet_stream} = @{[
543        $src->get_attribute ('body')->get_attribute_value ('is-octet-stream', default_value => 0)
544        or 0
545      ]};
546        
547    \$self->{view}->{wiki}->init_db;    \$self->{view}->{wiki}->init_db;
548    \$self->main_pre (\$opt, \$opt2);    \$self->main_pre (\$opt, \$opt2);
549        
550    ## TODO: formal SuikaWiki 3 interface    use Message::Util::Error;
551    my \$fmt = SuikaWiki::Plugin->formatter ('view');    try {
552    \$opt2->{output}->{entity}->{body}      \$opt2->{output}->{entity}->{body}
553      = \$fmt->replace (\$opt2->{template} => \$opt2->{o},        = SuikaWiki::Plugin->formatter ('view')
554                        {formatter => \$fmt});          ->replace (\$opt2->{template}, param => \$opt2->{o});
555      } \$self->{view}->{wiki}->{config}->{catch}->{ @{[
556           $ViewProp->{Name} eq '-error' ? 'formatter_view_error'
557                                         : 'formatter_view' ]} };
558    \$opt2->{output}->output (output => 'http-cgi');    \$opt2->{output}->output (output => 'http-cgi');
559        
560    \$self->main_post (\$opt, \$opt2);    \$self->main_post (\$opt, \$opt2);
# Line 314  sub main (\$\$\$) { Line 562  sub main (\$\$\$) {
562  EOH  EOH
563  }  }
564    
 ## TODO: Implements SuikaWiki 3 interface  
565  sub make_rule ($$) {  sub make_rule ($$) {
566    my ($src, $Info) = @_;    my ($src, $Info) = @_;
567    my $type = $src->get_attribute ('Category', make_new_node => 1)->value || [];    my $type = $src->get_attribute ('Category', make_new_node => 1)->value || [];
568    my $name = $src->get_attribute ('Name', make_new_node => 1)->value;    my $name = $src->get_attribute ('Name', make_new_node => 1)->value;
569    $name =~ s/(?=.)-/_/g;    $name =~ s/(?<=.)-/_/g;
570    my $main = code $Info, $src->get_attribute_value ('Formatting');    
571    $main = q{my ($p, $o) = @_;}."\n" . $main    my $reg_block;
572      if $main =~ /\$p/ || $main =~ /\$o/;    $reg_block = qr/[^{}]*(?>[^{}]+|{(??{$reg_block})})*/;
573    if ($main =~ /\$r/) {    my %code;
574      $main = q{my $r = '';} . "\n" . $main;    for my $codename ([qw/Formatting main/], [qw/After after/],
575      $main .= q{$r};                      [qw/Before before/], [qw/Pre pre/], [qw/Post post/],
576                        [qw/Attribute attr/]) {
577        my $main = code $Info, $src->get_attribute_value ($codename->[0]);
578        next unless $main;
579        $main = line ($Info, node_path =>
580                  "FormattingRule[name()='@{[list $type]}/$name']/".$codename->[0])
581              . $main;
582        
583        if ( $main =~ /\$f\b/
584          or $main =~ /\$rule_name\b/
585          or $main =~ /\$[opr]\b/
586          or $main =~ /[%\$]opt\b/
587          or $main =~ /\$param_(?:name|value)\n/) {
588          if ($codename->[0] ne 'Attribute') {
589            $main = q{my ($f, $rule_name, $p, $o, %opt) = @_;}."\n".$main;
590          } else {
591            $main = q{my ($f, $rule_name, $p, $o, $param_name => $param_value, %opt) = @_;}."\n".$main;
592          }
593        }
594        if ($main =~ /\$r\b/) {
595          warn qq(Rule @{[list $type]}/$name: Use of \$r is deprecated);
596          $main = q{my $r = '';} . "\n" . $main . "\n"
597                . q{$p->{-parent}->append_node ($r, node_or_text => 1);};
598        }
599        $main =~ s{__ATTR(TEXT|NODE)?:%(\w+|{$reg_block})(?:->{($reg_block)})?__;}
600                  {($1 eq 'TEXT' ? '$p->{'.literal_or_code($Info, $2)
601                                          .'} = do { my $r = ' : '')
602                   .'$f->parse_attr ($p=>'.literal_or_code($Info, $2).', $o, '
603                                   .($3?'-parent => '.$3.', ':'')
604                                   .($1?'-non_parsed_to_node => 1, ':'')
605                                   .'%opt)'
606                                   .($1 eq 'TEXT' ? '; ref $r?$r->inner_text:$r}'
607                                                  : '')
608                                   .';'}ge;
609        $code{$codename->[1]} = barecode "sub {$main}";
610    }    }
611        
612    my $main = <<EOH;    my $main = literal {
613        Description => [barecode m13ed_val_list $src, 'Description'],
614        Parameter => {do {
615          my @r;
616          for (@{$src->child_nodes}) {
617            if ($_->local_name eq 'Parameter') {
618              push @r, $_->get_attribute_value ('Name')
619                       => {Type => $_->get_attribute_value ('Type'),
620                           Default => $_->get_attribute_value ('Default'),
621                           Description => [barecode m13ed_val_list $_, 'Description']};
622            }
623          }
624          @r;
625        }},
626        %code,
627      };
628      $main .= line $Info, reset => 1;
629    
630    
631    my  $amain = <<EOH;
632  {  {
633    Formatting => sub {$main},    main => sub {$main},
634    @{[line ($Info, reset => 1)]}
635    Description => [@{[m13ed_val_list $src, 'Description']}],    Description => [@{[m13ed_val_list $src, 'Description']}],
636    Parameter => {@{[do{    Parameter => {@{[do{
     my @r;  
     for (@{$src->child_nodes}) {  
       if ($_->local_name eq 'Parameter') {  
         push @r, $_->get_attribute_value ('Name')  
                  => {Type => $_->get_attribute_value ('Type'),  
                      Default => $_->get_attribute_value ('Default'),  
                      Description => [barecode m13ed_val_list $_, 'Description']};  
       }  
     }  
     list @r;  
637    }]}},    }]}},
638  }  }
639  EOH  EOH
640    my $r;    my $r = change_package $Info, $Info->{module_name};
641      local $Info->{-message_error_used} = 0;  
642    if (@$type == 1) {    if (@$type == 1) {
643      $type->[0] =~ tr/-/_/;      $type->[0] =~ tr/-/_/;
644      $r = qq{\$SuikaWiki::Plugin::Rule{$type->[0]}->{$name} = $main;\n};      $r .= qq{\$SuikaWiki::Plugin::Rule{$type->[0]}->{$name} = $main;\n};
645      push @{$Info->{provide}->{rule}->{$type->[0]}}, $name;      push @{$Info->{provide}->{rule}->{$type->[0]}}, $name;
646    } else {    } else {
647      $r = qq({my \$def = $main;\n);      $r .= qq({my \$def = $main;\n);
648      for my $type (@$type) {      for my $type (@$type) {
649        $type =~ tr/-/_/;        $type =~ tr/-/_/;
650        $r .= qq{\$SuikaWiki::Plugin::Rule{$type}->{$name} = \$def;\n};        $r .= qq{\$SuikaWiki::Plugin::Rule{$type}->{$name} = \$def;\n};
# Line 363  EOH Line 655  EOH
655    $r;    $r;
656  }  }
657    
658    =item FormattingRuleAlias
659    
660    Generating an alias name for a formatting rule that is already loaded.
661    Example:
662    
663      FormattingRuleAlias:
664        @Category[list]:
665          category-1
666          category-2
667          ...
668        @Name: new-rule-name
669        @Reference:
670          @@Category: one-of-category
671          @@Name: one-of-name
672    
673    associates C<(I<category-1>, I<new-rule-name>)>,
674    C<(I<category-2>, I<new-rule-name>)>, ...
675    with C<(I<one-of-category>, I<one-of-name>)>.
676    
677    =cut
678    
679    sub make_rule_alias ($$) {
680      my ($src, $Info) = @_;
681      my $type = $src->get_attribute ('Category', make_new_node => 1)->value || [];
682      my $name = $src->get_attribute ('Name', make_new_node => 1)->value;
683      
684      my $ref = $src->get_attribute ('Reference', make_new_node => 1);
685      my $c = $ref->get_attribute_value ('Category');
686      my $n = $ref->get_attribute_value ('Name');
687      
688      s/(?<=.)-/_/g for $n, $name;
689      tr/-/_/ for $c, @$type;
690      
691      my $def = qq{\$SuikaWiki::Plugin::Rule{@{[literal $c]}}->{@{[literal $n]}} or warn qq{Formatting rule "$c/$n" not defined}};
692      
693      my $r = change_package $Info, $Info->{module_name};
694      for my $type (@$type) {
695        $r .= qq{\$SuikaWiki::Plugin::Rule{@{[literal $type]}}->{@{[literal $name]}} = $def;\n};
696        push @{$Info->{provide}->{rule}->{$type}}, $name;
697      }
698      $r;
699    }
700    
701    
702  sub random_module_name ($;$) {  sub random_module_name ($;$) {
703    my ($Info, $subname) = @_;    my ($Info, $subname) = @_;
# Line 373  sub random_module_name ($;$) { Line 708  sub random_module_name ($;$) {
708      sprintf ('%02d%02d%02d%02d%02d%02d', @date[5,4,3,2,1,0]),      sprintf ('%02d%02d%02d%02d%02d%02d', @date[5,4,3,2,1,0]),
709      join ('', @rand[rand@rand,rand@rand,rand@rand,rand@rand]);      join ('', @rand[rand@rand,rand@rand,rand@rand,rand@rand]);
710  }  }
711    
712    =head1 NAME
713    
714    mkplugin2.pl - SuikaWiki: WikiPlugin Generator
715    
716    =head1 SYNOPSIS
717    
718      mkplugin2.pl pluginsrc.wp2 > plugin.pm
719    
720    =head1 DESCRIPTION
721    
722    C<mkplugin2.pl> generates WikiPlugin module as a Perl module file
723    from WikiPlugin source description.  WikiPlugin source description
724    is described in SuikaWikiConfig/2.0 format and it contains
725    definitions of wiki constructions (such as formatting rules and
726    WikiView definitions) as both machine understandable code and
727    human readable documentation.  For more information, see
728    <http://suika.fam.cx/~wakaba/-temp/wiki/wiki?WikiPlugin>.
729    
730    This script is part of SuikaWiki.
731    
732    =head1 HISTORY AND COMPATIBILITY
733    
734    C<mkplugin2.pl> introduced as part of SuikaWiki 3.
735    It converts SuikaWiki 3 WikiPlugin source descriptions
736    (in SuikaWikiConfig/2.0) into Perl modules with SuikaWiki 3 interface.
737    
738    SuikaWiki 2 has C<mkplugin.pl>.  It also converts WikiPlugin
739    source descriptions into Perl modules.  But it support
740    SuikaWiki 2 format of WikiPlugin source description that differs from
741    SuikaWiki 3 format.  Wiki programming interface (not limited to
742    WikiPlugin related one) of SuikaWiki 3 also incompatible with that
743    of SuikaWiki 2 so that it is impossible to use SuikaWiki 2 WikiPlugin
744    module with SuikaWiki 3 and vice versa.
745    
746    =head1 SEE ALSO
747    
748    C<SuikaWiki::Plugin>, SuikaWiki:WikiPlugin
749    <http://suika.fam.cx/~wakaba/-temp/wiki/wiki?WikiPlugin>.
750    
751    =head1 LICENSE
752    
753    Copyright 2003-2004 Wakaba <w@suika.fam.cx>.  All rights reserved.
754    
755    This program is free software; you can redistribute it and/or
756    modify it under the same terms as Perl itself.
757    
758    =cut
759    
760    1; # $Date$
Legend:
Removed from v.1.4  
changed lines
  Added in v.1.17
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24