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