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