/[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.2 by wakaba, Sat Oct 18 07:08:34 2003 UTC revision 1.18 by wakaba, Thu Jun 3 06:38:48 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 ({qw/content_written 1 content_removed 1 content_type_changed_from 1/}
286                 ->{my $node_name = $_->local_name}) {
287          $r .= q(sub ).$node_name
288             .  q( {)."\n".q(my ($self, %opt) = @_;)
289             .  line $Info, node_path => qq(Format[module-name()=$module_name]/$node_name]);
290          $r .= code $Info, $_->get_attribute_value ('Main');
291          $r .= line $Info, reset => 1;
292          $r .= qq(}\n);
293        } elsif ($_->local_name eq 'Use') {
294          $r .= line $Info, node_path => qq(Format[module-name()=$module_name]/Use);
295          $r .= code $Info, $_->inner_text;
296        }
297      }
298      $r;
299    }
300    
301    sub make_format_converter ($$) {
302      my ($src, $Info) = @_;
303      my %def;
304      for (qw/Type Name Version TypeURIReference IsFragment IsPlaceholder/) {
305        $def{$_} = $src->get_attribute_value ($_);
306        delete $def{$_} unless defined $def{$_};
307      }
308      $def{Type_param} = {map {$_->local_name => $_->value}
309                                  @{$src->get_attribute ('Type', make_new_node => 1)
310                                      ->child_nodes}};
311      my $type = serialize_media_type ($Info,
312                   Type => $def{Type},
313                   Type_param => $def{Type_param},
314                   Name => $def{Name},
315                   Version => $def{Version},
316                   URIReference => $def{TypeURIReference},
317                   IsFragment => $def{IsFragment},
318                   IsPlaceholder => $def{IsPlaceholder});
319      $def{serialized_type} = $type->{_};
320      
321      for (qw/Main ToString ToOctetStream/) {
322        my $def = $src->get_attribute_value ($_);
323        next unless $def;
324        $def{$_} = line ($Info, node_path => '//Converter/'.$_)
325                   . $def
326                   . line ($Info, reset => 1);
327        if ($def{$_} =~ /\$r\b/) {
328          $def{$_} = 'my $r;'."\n".$def{$_}."\n".'$r';
329        }
330        $def{$_} = barecode code $Info,
331                     'sub {my ($self, $source, $opt) = @_;'
332                   . $def{$_} . '}';
333      }
334      
335      my $r = list %def;
336      if ($type->{Type}) {
337        $r = qq{\$Converter->{@{[literal $type->{Type}]}} = {$r};\n};
338        $r .= qq{\$Converter->{@{[literal $type->{Magic}]}} = \$Converter->{@{[literal $type->{Type}]}};\n}
339          if $type->{Magic};
340        $r .= qq{\$Converter->{@{[literal $type->{URIReference}]}} = \$Converter->{@{[literal $type->{Type}]}};\n}
341          if $type->{URIReference};
342      } elsif ($type->{Magic}) {
343        $r = qq{\$Converter->{@{[literal $type->{Magic}]}} = {$r};\n};
344        $r .= qq{\$Converter->{@{[literal $type->{URIReference}]}} = \$Converter->{@{[literal $type->{Magic}]}};\n}
345          if $type->{URIReference};
346      } elsif ($type->{URIReference}) {
347        $r = qq{\$Converter->{@{[literal $type->{URIReference}]}} = {$r};\n};
348      } else {
349        $r = 'BEGIN { die "Invalid Syntax of Converter: Type or Name or TypeURIReference property required" }';
350      }
351      $r;
352    }
353    
354    sub serialize_media_type ($%) {
355      my ($Info, %opt) = @_;
356      my %return;
357      if ($opt{Type}) {
358        $return{Type} = 'IMT:'.$opt{Type};
359        if ($opt{Type_param}) {
360          $return{Type} .= join '', map {my $s;
361                             ';'. $_ .'="'
362                           . (($s = $opt{Type_param}->{$_}) =~ s/([\\"])/\\$1/g, $s)
363                           . '"'
364                           } sort {
365                             $a cmp $b
366                           } keys %{$opt{Type_param}};
367        }
368      }
369      if ($opt{Magic}) {
370        $return{Magic} = 'MAGIC:'.$opt{Magic};
371      } elsif ($opt{Name}) {
372        $return{Name} = 'MAGIC:'.$opt{Name}.'/*';
373        $return{Magic} = 'MAGIC:'.$opt{Name}.'/'.$opt{Version} if $opt{Version};
374      }
375      if ($opt{URIReference}) {
376        $return{URIReference} = $opt{URIReference};
377      }
378      my $flag = '##';
379      $flag .= 'f' if $opt{IsFragment};
380      $flag .= 'p' if $opt{IsPlaceholder};
381      for (qw/URIReference Type Magic Name/) {
382        $return{$_} .= $flag if $return{$_};
383      }
384      $return{_} = $return{URIReference} || $return{Type}
385                || $return{Magic} || $return{Name};
386      \%return;
387    }
388    
389    
390  sub make_function ($$) {  sub make_function ($$) {
391    my ($src, $Info) = @_;    my ($src, $Info) = @_;
392    ## TODO: support of ARGV property    ## TODO: support of ARGV property
393      my $name;
394    my $r = <<EOH;    my $r = <<EOH;
395  package $Info->{module_name};  @{[change_package $Info, $Info->{module_name}]}
396  sub @{[$src->get_attribute_value ('Name')]} {  sub @{[$name = $src->get_attribute_value ('Name')]} {
397    @{[code $Info, $src->get_attribute_value ('Main')]}  @{[line $Info, node_path => "Function[Name='$name']/Main"]}@{[
398      code $Info, $src->get_attribute_value ('Main')
399    ]}
400  }  }
401    @{[line $Info, reset => 1]}
402  EOH  EOH
403  }  }
404    
405  sub register_plugin_const ($$) {  sub register_plugin_const ($$) {
406    my ($src, $Info) = @_;    my ($src, $Info) = @_;
407    for (@{$src->child_nodes}) {    for (@{$src->child_nodes}) {
408      $Info->{const}->{$_->local_name} = $_->value;      $Info->{const}->{$_->local_name} = literal_or_code $Info, $_->value;
409    }    }
410  }  }
411    
412  sub make_resdef ($$) {  sub make_resdef ($$) {
413    my ($src, $Info) = @_;    my ($src, $Info) = @_;
414    my $r = qq{package SuikaWiki::Plugin::Resource;\nour \$BaseResource;\n};    my $r = change_package $Info, 'SuikaWiki::Plugin::Resource';
415      local $Info->{-message_error_used} = 0;  
416      $r .= qq{our \$BaseResource;\n};
417    for (@{$src->child_nodes}) {    for (@{$src->child_nodes}) {
418      if ($_->node_type eq '#element') {      if ($_->node_type eq '#element') {
419        my $lang = literal ($_->get_attribute_value ('lang') || 'und');        my $lang = literal ($_->get_attribute_value ('lang') || 'und');
# Line 176  sub make_resdef ($$) { Line 429  sub make_resdef ($$) {
429  sub make_viewfragment ($$) {  sub make_viewfragment ($$) {
430    my ($src, $Info) = @_;    my ($src, $Info) = @_;
431    my $r = '';    my $r = '';
432    my $name = $src->get_attribute_value ('Name');    my $body = <<EOH;
433    $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]}}}, {  
434      Main => @{[literal $src->get_attribute_value ('Formatting')]},      Main => @{[literal $src->get_attribute_value ('Formatting')]},
435      Order => @{[0+$src->get_attribute_value ('Order')]},      Order => @{[0+$src->get_attribute_value ('Order')]},
436      Description => [@{[m13ed_val_list $src, 'Description']}],      Description => [@{[m13ed_val_list $src, 'Description']}],
437    };    };
438  EOH  EOH
439    push @{$Info->{provide}->{viewfragment}},    ## Recommended format
440         {Name => $src->get_attribute ('Name')->value};    my $name = $src->get_attribute_value ('Template');
441      if (ref ($name) and @$name > 1) {
442        $r .= qq({my \$def = $body;\n);
443        for (@$name) {
444          my $name = $_; $name =~ tr/-/_/;
445          $r .= qq(push \@{\$SuikaWiki::View::Implementation::TemplateFragment{@{[literal $name]}}}, \$def;\n);
446          push @{$Info->{provide}->{viewfragment}}, {Name => $name};
447        }
448        $r .= qq(}\n);
449      } else {                           ## Obsoleted format
450        $name = ref $name ? $name->[0] : $src->get_attribute_value ('Name');
451        $name =~ tr/-/_/;
452        $r .= qq(push \@{\$SuikaWiki::View::Implementation::TemplateFragment{@{[literal $name]}}}, $body);
453        push @{$Info->{provide}->{viewfragment}}, {Name => $name};
454      }
455    $r;    $r;
456  }  }
457    
# Line 198  sub make_viewdef ($$) { Line 459  sub make_viewdef ($$) {
459    my ($src, $Info) = @_;    my ($src, $Info) = @_;
460    my $ViewProp = {};    my $ViewProp = {};
461    my $r = '';    my $r = '';
462    $ViewProp->{Name} = n11n $src->get_attribute ('Mode')->value;    $ViewProp->{Name} = n11n $src->get_attribute_value ('Mode');
463      $ViewProp->{Name} =~ s/(?<=.)-/_/g;
464    $ViewProp->{pack_name} = random_module_name ($Info, $ViewProp->{Name});    $ViewProp->{pack_name} = random_module_name ($Info, $ViewProp->{Name});
465        
466    $ViewProp->{condition_stringified} = hash    $ViewProp->{condition_stringified} = hash
# Line 211  push \@SuikaWiki::View::Implementation:: Line 473  push \@SuikaWiki::View::Implementation::
473    condition => {$ViewProp->{condition_stringified}},    condition => {$ViewProp->{condition_stringified}},
474    object_class => q#$ViewProp->{pack_name}#,    object_class => q#$ViewProp->{pack_name}#,
475  };  };
476  package $ViewProp->{pack_name};  @{[change_package $Info, $ViewProp->{pack_name}]}
477  our \@ISA = q#SuikaWiki::View::template#;  our \@ISA = q#SuikaWiki::View::template#;
478  EOH  EOH
479      local $Info->{-message_error_used} = 0;  
480      my $use = $src->get_attribute ('Use');
481      if (ref $use) {
482        $r .= line $Info, node_path => "ViewDefinition[Mode='$ViewProp->{Name}']/Use";
483        $r .= code $Info, $use->inner_text;
484        $r .= "\n\n";
485      }
486      
487    for (@{$src->child_nodes}) {    for (@{$src->child_nodes}) {
488      if ($_->local_name eq 'template') {      if ($_->local_name eq 'template') {
489        $r .= make_view_template_method ($_, $Info);        $r .= make_view_template_method ($_, $Info, $ViewProp);
490      } elsif ($_->local_name eq 'method') {      } elsif ($_->local_name eq 'method') {
491          my $method_name = $_->get_attribute_value ('Name');
492        $r .= ({        $r .= ({
493                main => q(sub main ($$) {)."\n".q(my ($self, $opt) = @_;)."\n",                main => q(sub main ($$) {)."\n".q(my ($self, $opt, $opt2) = @_;)."\n",
494                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",
495                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",                    
496               }->{$_->get_attribute ('Name')->value}               }->{$method_name}
497               ||qq(sub @{[$_->get_attribute ('Name')->value]} {\n))               ||qq(sub @{[$method_name]} {\n))
498             . line ($Info, node_path => "ViewDefinition[Mode='$ViewProp->{Name}']/method[Name='$method_name']")
499           . code ($Info, $_->value)           . code ($Info, $_->value)
500           . qq(\n}\n);           . qq(}\n)
501             . line ($Info, reset => 1);
502      }      }
503    }    }
504    my $prop = {Name => $ViewProp->{Name},    my $prop = {Name => $ViewProp->{Name},
# Line 235  EOH Line 508  EOH
508  }  }
509    
510  sub make_view_template_method ($$) {  sub make_view_template_method ($$) {
511    my ($src, $info) = @_;    my ($src, $Info, $ViewProp) = @_;
512      my $media_type = $src->get_attribute_value
513                                ('media-type',
514                                 default => q<application/octet-stream>);
515    my $r = <<EOH;    my $r = <<EOH;
516    
517  sub main (\$\$\$) {  sub main (\$\$\$) {
# Line 251  sub main (\$\$\$) { Line 527  sub main (\$\$\$) {
527        
528    \$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]};
529    \$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)  
     ]}},  
530                        ## SuikaWiki 3 WikiPlugin interface                        ## SuikaWiki 3 WikiPlugin interface
531                          wiki => \$self->{view}->{wiki},                          wiki => \$self->{view}->{wiki},
532                          plugin => \$self->{view}->{wiki}->{plugin},                          plugin => \$self->{view}->{wiki}->{plugin},
# Line 275  sub main (\$\$\$) { Line 535  sub main (\$\$\$) {
535    @{[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;
536       $x?q{$opt2->{output}->{status_code} = }.(0 + $x).q{;}:q{}}]}       $x?q{$opt2->{output}->{status_code} = }.(0 + $x).q{;}:q{}}]}
537    @{[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;
538       $x?q{$opt2->{output}->{reason_phrase} = }.literal($x).q{;}:q{}}]}       $x?q{$opt2->{output}->{status_phrase} = }.literal($x).q{;}:q{}}]}
539    \$opt2->{output}->{entity}->{media_type} = @{[literal    \$opt2->{output}->{entity}->{media_type} = @{[literal $media_type]};
540                             $src->get_attribute ('media-type',make_new_node=>1)  
                                ->inner_text || 'application/octet-stream']};  
541    @{[($src->get_attribute ('use-media-type-charset',make_new_node=>1)    @{[($src->get_attribute ('use-media-type-charset',make_new_node=>1)
542              ->inner_text || 0) ?              ->inner_text || 0) ?
543       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 549  sub main (\$\$\$) {
549              qq{\$opt2->{output}->set_expires (delta => @{[0 + $x]});};              qq{\$opt2->{output}->set_expires (delta => @{[0 + $x]});};
550            }            }
551        }]}        }]}
552      \$opt2->{output}->{entity}->{body_is_octet_stream} = @{[
553        $src->get_attribute ('body')->get_attribute_value ('is-octet-stream', default_value => 0)
554        or 0
555      ]};
556        
557    \$self->{view}->{wiki}->init_db;    \$self->{view}->{wiki}->init_db;
558    \$self->main_pre (\$opt, \$opt2);    \$self->main_pre (\$opt, \$opt2);
559        
560    ## TODO: formal SuikaWiki 3 interface    @{[$media_type eq 'text/html' ? q{require Message::Markup::XML::Serialize::HTML;} : '']}
561    my \$fmt = SuikaWiki::Plugin->formatter ('view');    use Message::Util::Error;
562    \$opt2->{output}->{entity}->{body}    try {
563      = \$fmt->replace (\$opt2->{template} => \$opt2->{o},      \$opt2->{output}->{entity}->{body}
564                        {formatter => \$fmt});        = @{[$media_type eq 'text/html' ? q{Message::Markup::XML::Serialize::HTML::html_simple} : '']}
565            (SuikaWiki::Plugin->formatter ('view')
566            ->replace (\$opt2->{template}, param => \$opt2->{o}));
567      } \$self->{view}->{wiki}->{config}->{catch}->{ @{[
568           $ViewProp->{Name} eq '-error' ? 'formatter_view_error'
569                                         : 'formatter_view' ]} };
570    \$opt2->{output}->output (output => 'http-cgi');    \$opt2->{output}->output (output => 'http-cgi');
571        
572    \$self->main_post (\$opt, \$opt2);    \$self->main_post (\$opt, \$opt2);
# Line 306  sub main (\$\$\$) { Line 574  sub main (\$\$\$) {
574  EOH  EOH
575  }  }
576    
 ## TODO: Implements SuikaWiki 3 interface  
577  sub make_rule ($$) {  sub make_rule ($$) {
578    my ($src, $Info) = @_;    my ($src, $Info) = @_;
579    my $type = $src->get_attribute ('Category', make_new_node => 1)->value || [];    my $type = $src->get_attribute ('Category', make_new_node => 1)->value || [];
580    my $name = $src->get_attribute ('Name', make_new_node => 1)->value;    my $name = $src->get_attribute ('Name', make_new_node => 1)->value;
581    $name =~ s/(?=.)-/_/g;    $name =~ s/(?<=.)-/_/g;
582    my $main = code $Info, $src->get_attribute_value ('Formatting');    
583    $main = q{my ($p, $o) = @_;}."\n" . $main    my $reg_block;
584      if $main =~ /\$p/ || $main =~ /\$o/;    $reg_block = qr/[^{}]*(?>[^{}]+|{(??{$reg_block})})*/;
585    if ($main =~ /\$r/) {    my %code;
586      $main = q{my $r = '';} . "\n" . $main;    for my $codename ([qw/Formatting main/], [qw/After after/],
587      $main .= q{$r};                      [qw/Before before/], [qw/Pre pre/], [qw/Post post/],
588                        [qw/Attribute attr/]) {
589        my $main = code $Info, $src->get_attribute_value ($codename->[0]);
590        next unless $main;
591        $main = line ($Info, node_path =>
592                  "FormattingRule[name()='@{[list $type]}/$name']/".$codename->[0])
593              . $main;
594        
595        if ( $main =~ /\$f\b/
596          or $main =~ /\$rule_name\b/
597          or $main =~ /\$[opr]\b/
598          or $main =~ /[%\$]opt\b/
599          or $main =~ /\$param_(?:name|value)\n/) {
600          if ($codename->[0] ne 'Attribute') {
601            $main = q{my ($f, $rule_name, $p, $o, %opt) = @_;}."\n".$main;
602          } else {
603            $main = q{my ($f, $rule_name, $p, $o, $param_name => $param_value, %opt) = @_;}."\n".$main;
604          }
605        }
606        if ($main =~ /\$r\b/) {
607          warn qq(Rule @{[list $type]}/$name: Use of \$r is deprecated);
608          $main = q{my $r = '';} . "\n" . $main . "\n"
609                . q{$p->{-parent}->append_node ($r, node_or_text => 1);};
610        }
611        $main =~ s{__ATTR(TEXT|NODE)?:%(\w+|{$reg_block})(?:->{($reg_block)})?__;}
612                  {($1 eq 'TEXT' ? '$p->{'.literal_or_code($Info, $2)
613                                          .'} = do { my $r = ' : '')
614                   .'$f->parse_attr ($p=>'.literal_or_code($Info, $2).', $o, '
615                                   .($3?'-parent => '.$3.', ':'')
616                                   .($1?'-non_parsed_to_node => 1, ':'')
617                                   .'%opt)'
618                                   .($1 eq 'TEXT' ? '; ref $r?$r->inner_text:$r}'
619                                                  : '')
620                                   .';'}ge;
621        $code{$codename->[1]} = barecode "sub {$main}";
622    }    }
623        
624    my $main = <<EOH;    my $main = literal {
625        Description => [barecode m13ed_val_list $src, 'Description'],
626        Parameter => {do {
627          my @r;
628          for (@{$src->child_nodes}) {
629            if ($_->local_name eq 'Parameter') {
630              push @r, $_->get_attribute_value ('Name')
631                       => {Type => $_->get_attribute_value ('Type'),
632                           Default => $_->get_attribute_value ('Default'),
633                           Description => [barecode m13ed_val_list $_, 'Description']};
634            }
635          }
636          @r;
637        }},
638        %code,
639      };
640      $main .= line $Info, reset => 1;
641    
642    
643    my  $amain = <<EOH;
644  {  {
645    Formatting => sub {$main},    main => sub {$main},
646    @{[line ($Info, reset => 1)]}
647    Description => [@{[m13ed_val_list $src, 'Description']}],    Description => [@{[m13ed_val_list $src, 'Description']}],
648    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;  
649    }]}},    }]}},
650  }  }
651  EOH  EOH
652    my $r;    my $r = change_package $Info, $Info->{module_name};
653      local $Info->{-message_error_used} = 0;  
654    if (@$type == 1) {    if (@$type == 1) {
655      $type->[0] =~ tr/-/_/;      $type->[0] =~ tr/-/_/;
656      $r = qq{\$SuikaWiki::Plugin::Rule{$type->[0]}->{$name} = $main;\n};      $r .= qq{\$SuikaWiki::Plugin::Rule{$type->[0]}->{$name} = $main;\n};
657      push @{$Info->{provide}->{rule}->{$type->[0]}}, $name;      push @{$Info->{provide}->{rule}->{$type->[0]}}, $name;
658    } else {    } else {
659      $r = qq({my \$def = $main;\n);      $r .= qq({my \$def = $main;\n);
660      for my $type (@$type) {      for my $type (@$type) {
661        $type =~ tr/-/_/;        $type =~ tr/-/_/;
662        $r .= qq{\$SuikaWiki::Plugin::Rule{$type}->{$name} = \$def;\n};        $r .= qq{\$SuikaWiki::Plugin::Rule{$type}->{$name} = \$def;\n};
# Line 355  EOH Line 667  EOH
667    $r;    $r;
668  }  }
669    
670    =item FormattingRuleAlias
671    
672    Generating an alias name for a formatting rule that is already loaded.
673    Example:
674    
675      FormattingRuleAlias:
676        @Category[list]:
677          category-1
678          category-2
679          ...
680        @Name: new-rule-name
681        @Reference:
682          @@Category: one-of-category
683          @@Name: one-of-name
684    
685    associates C<(I<category-1>, I<new-rule-name>)>,
686    C<(I<category-2>, I<new-rule-name>)>, ...
687    with C<(I<one-of-category>, I<one-of-name>)>.
688    
689    =cut
690    
691    sub make_rule_alias ($$) {
692      my ($src, $Info) = @_;
693      my $type = $src->get_attribute ('Category', make_new_node => 1)->value || [];
694      my $name = $src->get_attribute ('Name', make_new_node => 1)->value;
695      
696      my $ref = $src->get_attribute ('Reference', make_new_node => 1);
697      my $c = $ref->get_attribute_value ('Category');
698      my $n = $ref->get_attribute_value ('Name');
699      
700      s/(?<=.)-/_/g for $n, $name;
701      tr/-/_/ for $c, @$type;
702      
703      my $def = qq{\$SuikaWiki::Plugin::Rule{@{[literal $c]}}->{@{[literal $n]}} or warn qq{Formatting rule "$c/$n" not defined}};
704      
705      my $r = change_package $Info, $Info->{module_name};
706      for my $type (@$type) {
707        $r .= qq{\$SuikaWiki::Plugin::Rule{@{[literal $type]}}->{@{[literal $name]}} = $def;\n};
708        push @{$Info->{provide}->{rule}->{$type}}, $name;
709      }
710      $r;
711    }
712    
713    
714  sub random_module_name ($;$) {  sub random_module_name ($;$) {
715    my ($Info, $subname) = @_;    my ($Info, $subname) = @_;
# Line 365  sub random_module_name ($;$) { Line 720  sub random_module_name ($;$) {
720      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]),
721      join ('', @rand[rand@rand,rand@rand,rand@rand,rand@rand]);      join ('', @rand[rand@rand,rand@rand,rand@rand,rand@rand]);
722  }  }
723    
724    =head1 NAME
725    
726    mkplugin2.pl - SuikaWiki: WikiPlugin Generator
727    
728    =head1 SYNOPSIS
729    
730      mkplugin2.pl pluginsrc.wp2 > plugin.pm
731    
732    =head1 DESCRIPTION
733    
734    C<mkplugin2.pl> generates WikiPlugin module as a Perl module file
735    from WikiPlugin source description.  WikiPlugin source description
736    is described in SuikaWikiConfig/2.0 format and it contains
737    definitions of wiki constructions (such as formatting rules and
738    WikiView definitions) as both machine understandable code and
739    human readable documentation.  For more information, see
740    <http://suika.fam.cx/~wakaba/-temp/wiki/wiki?WikiPlugin>.
741    
742    This script is part of SuikaWiki.
743    
744    =head1 HISTORY AND COMPATIBILITY
745    
746    C<mkplugin2.pl> introduced as part of SuikaWiki 3.
747    It converts SuikaWiki 3 WikiPlugin source descriptions
748    (in SuikaWikiConfig/2.0) into Perl modules with SuikaWiki 3 interface.
749    
750    SuikaWiki 2 has C<mkplugin.pl>.  It also converts WikiPlugin
751    source descriptions into Perl modules.  But it support
752    SuikaWiki 2 format of WikiPlugin source description that differs from
753    SuikaWiki 3 format.  Wiki programming interface (not limited to
754    WikiPlugin related one) of SuikaWiki 3 also incompatible with that
755    of SuikaWiki 2 so that it is impossible to use SuikaWiki 2 WikiPlugin
756    module with SuikaWiki 3 and vice versa.
757    
758    =head1 SEE ALSO
759    
760    C<SuikaWiki::Plugin>, SuikaWiki:WikiPlugin
761    <http://suika.fam.cx/~wakaba/-temp/wiki/wiki?WikiPlugin>.
762    
763    =head1 LICENSE
764    
765    Copyright 2003-2004 Wakaba <w@suika.fam.cx>.  All rights reserved.
766    
767    This program is free software; you can redistribute it and/or
768    modify it under the same terms as Perl itself.
769    
770    =cut
771    
772    1; # $Date$
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.18
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24