/[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.1 by wakaba, Sun Oct 5 11:11:13 2003 UTC revision 1.15 by wakaba, Fri Mar 19 03:46:22 2004 UTC
# Line 1  Line 1 
1  #!/usr/bin/perl  #!/usr/bin/perl
2  use strict;  use strict;
3  require SuikaWiki::Markup::SuikaWikiConfig20::Parser;  our $VERSION = do{my @r=(q$Revision$=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
4    require Message::Markup::SuikaWikiConfig20::Parser;
5    
6    {
7  my $src = '';  my $src = '';
8  my $srcfile = shift;  my $srcfile = shift;
9  open SRC, $srcfile or die "$0: $!"; {  open SRC, $srcfile or die "$0: $!"; {
# Line 11  open SRC, $srcfile or die "$0: $!"; { Line 13  open SRC, $srcfile or die "$0: $!"; {
13    
14  sub literal ($) {  sub literal ($) {
15    my $s = shift;    my $s = shift;
16    $s =~ s/([#\\])/\\$1/g;    if (ref ($s) eq 'ARRAY') {
17    q<q#> . $s . q<#>;      q<[> . list (@$s) . q<]>;
18      } elsif (ref ($s) eq 'HASH') {
19        q<{> . hash (%$s) . q<}>;
20      } elsif (ref ($s) eq 'bare') {
21        $$s;
22      } else {
23        $s =~ s/([#\\])/\\$1/g;
24        q<q#> . $s . q<#>;
25      }
26    }
27    sub list (@) {
28      join ', ', map {literal $_} @_;
29    }
30    sub hash (%) {
31      my $i = 0;
32      list map {($i++ % 2) ? $_ : do {my $s = $_; $s =~ s/(?<=.)-/_/; $s}} @_;
33  }  }
34  sub n11n ($) {  sub n11n ($) {
35    my $s = shift;    my $s = shift;
36    $s =~ s/\s+/ /g;    $s =~ s/\s+/ /g;
37    $s;    $s;
38  }  }
39    sub m13ed_val_list ($$) {
40      my ($src, $key) = @_;
41      my @r;
42      for (@{$src->child_nodes}) {
43        if ($_->local_name eq $key) {
44          push @r, [scalar $_->inner_text,
45                    scalar $_->get_attribute ('lang', make_new_node => 1)
46                             ->inner_text,
47                    scalar $_->get_attribute ('script', make_new_node => 1)
48                             ->inner_text];
49        }
50      }
51      list @r;
52    }
53    sub barecode ($) {
54      bless \$_[0], 'bare';
55    }
56    sub code ($$) {
57      my ($Info, $code) = @_;
58      for (keys %{$Info->{const}}) {
59        $code =~ s/\$$_\b/$Info->{const}->{$_}/ge;
60      }
61      $code =~ s/__FUNCPACK__/$Info->{module_name}/g;
62      $Info->{-message_error_used} = 1 if $code =~ /\buse\s+Message::Util::Error\b/;
63      if (not $Info->{-message_error_used} and
64         ($code =~ /\btry\s*\{/ or $code =~ /\bcatch\s*\{/)) {
65        warn "Message::Util::Error MUST be 'use'd before 'try'...'catch' block used";
66      }
67      $code;
68    }
69    sub change_package ($$) {
70      my ($Info, $pack) = @_;
71      unless ($Info->{current_package} eq $pack) {
72        $Info->{current_package} = $pack;
73        return qq{package $pack;\n\n};
74      } else {
75        return '';
76      }
77    }
78    sub quoted_string ($) {
79      my $s = shift;
80      $s =~ s/([\\"])/\\$1/g;
81      '"'.$s.'"';
82    }
83    sub line ($;%) {
84      my ($Info, %opt) = @_;
85      
86      unless ($opt{file}) {
87        if ($opt{reset}) {
88          $opt{file} = sprintf '(WikiPlugin module %s, chunk %d)',
89                               $Info->{Name},
90                               ++$Info->{chunk_count};
91        } elsif ($opt{realfile}) {
92          $opt{file} = sprintf '(WikiPlugin module %s, chunk from %s)',
93                               $Info->{Name},
94                               $opt{realfile};
95        } else {
96          $opt{file} = sprintf '(WikiPlugin module source %s, block %s)',
97                               $Info->{source_file},
98                               $opt{node_path};
99        }
100      }
101      
102      $opt{file} =~ s/"/''/g;
103      sprintf '%s#line %d "%s"%s', "\n", $opt{line_no} || 1, $opt{file}, "\n";
104    }
105    sub literal_or_code ($$) {
106      my ($Info, $s) = @_;
107      substr ($s, 0, 1) ne '{' ? literal ($s)
108                               : code ($Info, substr ($s, 1, length ($s) - 2));
109    }
110    
111  my $parser = SuikaWiki::Markup::SuikaWikiConfig20::Parser->new;  my $parser = Message::Markup::SuikaWikiConfig20::Parser->new;
112  my $plugins = $parser->parse_text ($src);  my $plugins = $parser->parse_text ($src);
113  my $meta = $plugins->get_attribute ('Plugin')  my $meta = $plugins->get_attribute ('Plugin')
114            or die "$0: Required 'Plugin' section not found";            or die "$0: Required 'Plugin' section not found";
115  my %Info = (Name => n11n $meta->get_attribute ('Name')->value);  my %Info = (provide => {},
116                Name => n11n $meta->get_attribute ('Name')->value);
117    $Info{source_file} = $srcfile;
118  $Info{name_literal} = literal $Info{Name};  $Info{name_literal} = literal $Info{Name};
119  my @date = gmtime;  my @date = gmtime;
120  $Info{LastModified} = sprintf '%04d-%02d-%02dT%02d:%02d:%02d+00:00',  $Info{LastModified} = sprintf '%04d-%02d-%02dT%02d:%02d:%02d+00:00',
121                                $date[5] + 1900, $date[4] + 1, @date[3,2,1,0];                                $date[5] + 1900, $date[4] + 1, @date[3,2,1,0];
122  $Info{Version} = sprintf '%04d.%02d%02d.%02d%02d',  $Info{Version} = sprintf '%04d.%02d%02d.%02d%02d',
123                           $date[5] + 1900, $date[4] + 1, @date[3,2,1];                           $date[5] + 1900, $date[4] + 1, @date[3,2,1];
124    $Info{InterfaceVersion} = '2.9.1';
125    $Info{mkpluginVersion} = '2.'.$VERSION;
126  $Info{module_name} = q#SuikaWiki::Plugin::plugin#;  $Info{module_name} = q#SuikaWiki::Plugin::plugin#;
127  $Info{module_name} = random_module_name (\%Info, $Info{Name});  $Info{module_name} = random_module_name (\%Info, $Info{Name});
128    
129  print <<EOH;  print <<EOH;
130  use strict;  use strict;
131  package SuikaWiki::Plugin::Registry;  @{[change_package \%Info, 'SuikaWiki::Plugin::Registry']}
132  our \%Info;  our \%Info;
133  \$Info{$Info{name_literal}}->{Name} = $Info{name_literal};  \$Info{$Info{name_literal}}->{Name} = $Info{name_literal};
 \$Info{$Info{name_literal}}->{Version} = q#$Info{Version}#;  
134  EOH  EOH
135  for (qw/Description LastModified License/) {  for (qw/Version InterfaceVersion mkpluginVersion module_name/) {
136      print qq{\$Info{$Info{name_literal}}->{@{[literal $_]}} = @{[literal $Info{$_}]};\n};
137    }
138    for (qw/LastModified Date.RCS/) {
139    $Info{$_} = n11n $meta->get_attribute ($_,make_new_node=>1)->value;    $Info{$_} = n11n $meta->get_attribute ($_,make_new_node=>1)->value;
140    next unless length $Info{$_};    next unless length $Info{$_};
141    print qq{\$Info{$Info{name_literal}}->{$_} = } . literal $Info{$_};    print qq{\$Info{$Info{name_literal}}->{@{[literal $_]}} = } . literal $Info{$_};
142    print ";\n";    print ";\n";
143  }  }
144  for (qw/Author RelatedURI RelatedWikiPage RequiredPlugin RequiredModule/) {  for (qw/RequiredPlugin RequiredModule/) {
145    $Info{$_} = $meta->get_attribute ($_);    $Info{$_} = $meta->get_attribute ($_);
146    next unless ref $Info{$_}; $Info{$_} = $Info{$_}->value;    next unless ref $Info{$_}; $Info{$_} = $Info{$_}->value;
147    print qq{\$Info{$Info{name_literal}}->{$_} = [};    print qq{\$Info{$Info{name_literal}}->{$_} = [};
148    print join ', ', map {literal $_} @{$Info{$_}};    print join ', ', map {literal $_} @{$Info{$_}};
149    print "];\n";    print "];\n";
150  }  }
151    for (qw/Description License RelatedWikiPage RelatedURI/) {
152      my $r = m13ed_val_list $meta, $_;
153      next unless $r;
154      print qq{\$Info{$Info{name_literal}}->{$_} = [$r];\n};
155    }
156    
157    print qq{\$Info{$Info{name_literal}}->{Author} = [} .( list map {
158            [
159              [ barecode m13ed_val_list ($_, 'Name') ],
160              [ $_->get_attribute ('Mail', make_new_node => 1)->value ],
161              [ $_->get_attribute ('URI', make_new_node => 1)->value ],
162            ]
163    } grep { $_->local_name eq 'Author' } @{$meta->child_nodes}
164    ). qq{];\n};
165    
166    my $use = $meta->get_attribute ('Use');
167    if (ref $use) {
168      print change_package \%Info, $Info{module_name};
169      print line \%Info, node_path => 'Plugin/Use';
170      print code \%Info, $use->inner_text;
171      print line \%Info, reset => 1;
172    }
173    
174  for (@{$plugins->child_nodes}) {  for (@{$plugins->child_nodes}) {
175    if ($_->local_name eq 'ViewDefinition') {    if ($_->local_name eq 'FormattingRule') {
176        print "\n", make_rule ($_, \%Info);
177      } elsif ($_->local_name eq 'ViewDefinition') {
178      print "\n", make_viewdef ($_, \%Info);      print "\n", make_viewdef ($_, \%Info);
179    } elsif ($_->local_name eq 'ViewFragment') {    } elsif ($_->local_name eq 'ViewFragment') {
180      print "\n", make_viewfragment ($_, \%Info);      print "\n", make_viewfragment ($_, \%Info);
181      } elsif ($_->local_name eq 'Function') {
182        print "\n", make_function ($_, \%Info);
183      } elsif ($_->local_name eq 'Resource') {
184        print "\n", make_resdef ($_, \%Info);
185      } elsif ($_->local_name eq 'PluginConst') {
186        register_plugin_const ($_, \%Info);
187      } elsif ($_->local_name eq 'Format') {
188        print "\n", make_format ($_, \%Info);
189      } elsif ($_->local_name eq 'FormattingRuleAlias') {
190        print "\n", make_rule_alias ($_, \%Info);
191    # Parameter
192    # PluginCategory
193    }    }
194  }  }
195    
196    print change_package \%Info, q(SuikaWiki::Plugin::Registry);
197    print qq{\$Info{$Info{name_literal}}->{provide} = } . literal $Info{provide};
198    print qq{;\n};
199    
200  print "\n1;\n";  print "\n1;\n";
201  exit;  exit;
202    }
203    
204    sub make_format ($$) {
205      my ($src, $Info) = @_;
206      my $module_name = 'SuikaWiki::Format::Definition::'.$src->get_attribute_value ('ModuleName');
207      my $r = change_package $Info, $module_name;
208      local $Info->{-message_error_used} = 0;  
209      $r .= qq{our \@ISA;\n};
210      if (my $isa = $src->get_attribute_value ('Inherit')) {
211        for (@$isa) {
212          $r .= qq{push \@ISA, @{[literal 'SuikaWiki::Format::Definition::'.$_]};\n};
213        }
214      } else {
215        $r .= qq{push \@ISA, 'SuikaWiki::Format::Definition::template';\n};    
216      }
217      if (my $name = $src->get_attribute_value ('Name')) {
218        $r .= qq{\$SuikaWiki::Format::Definition::Class{@{[literal '/'.$name.'/'.$src->get_attribute_value ('Version', default => '').'//']}} = '$module_name';\n};
219      }
220      if (my $type = $src->get_attribute_value ('Type')) {
221        $type .= join '', map {
222                   ';'. $_->local_name .'='. quoted_string $_->inner_text
223                 } sort {
224                   $a->local_name cmp $b->local_name
225                 } @{$src->get_attribute ('Type')->child_nodes};
226        $r .= qq{\$SuikaWiki::Format::Definition::Class{@{[literal $type.'//']}} = '$module_name';\n};
227      }
228      
229      my $convert = line $Info, line_no => __LINE__ + 2, realfile => __FILE__;
230      $convert .= <<'EOH';
231    our $Converter;
232    sub convert ($$;%) {
233      my ($self, $source, %opt) = @_;
234      my $converter;
235      my $flag = '//';
236      $flag .= 'f' if $opt{IsFragment};
237      $flag .= 'p' if $opt{IsPlaceholder};
238      my $type = $opt{Type} ?
239                    $opt{Type} .
240                    SuikaWiki::Format::Definition->__get_param_string
241                      ($opt{Type_param}) : undef;
242      if ($Converter->{$type.$flag}) {
243        $converter = $Converter->{$type.$flag};
244      } elsif ($Converter->{$opt{Name}.'/'.$opt{Version}.$flag}) {
245        $converter = $Converter->{'/'.$opt{Name}.'/'.$opt{Version}.$flag};
246      }
247      return ($converter->{$opt{return_type} or 'Main'} or
248              CORE::die "Buggy implementation: $type $opt{Name}/$opt{Version}$flag/@{[$opt{return_type} or 'Main']} not defined")
249             ->($self, $source, \%opt)
250        if $converter;
251      $self->SUPER::convert ($source, %opt);
252    }
253    EOH
254      
255      for (@{$src->child_nodes}) {
256        if ($_->local_name eq 'Converter') {
257          if ($convert) {
258            $r .= $convert;
259            $r .= line $Info, reset => 1;
260            undef $convert;
261          }
262          $r .= make_format_converter ($_, $Info);
263        } elsif ($_->local_name eq 'WikiForm') {
264          $r .= q(sub wikiform {)."\n".q(my ($self, $source, %opt) = @_;);
265          $r .= line $Info, node_path => qq(Format[module-name()=$module_name]/WikiForm);
266          $r .= code $Info, $_->get_attribute_value ('Main');
267          $r .= line $Info, reset => 1;
268          $r .= qq(}\n);
269        } elsif ($_->local_name eq 'HeadSummary') {
270          $r .= q(sub headsummary {)."\n".q(my ($self, $source, %opt) = @_;);
271          $r .= line $Info, node_path => qq(Format[module-name()=$module_name]/HeadSummary);
272          $r .= code $Info, $_->get_attribute_value ('Main');
273          $r .= line $Info, reset => 1;
274          $r .= qq(}\n);
275        } elsif ($_->local_name eq 'NextIndex') {
276          my $name = $_->get_attribute_value ('Name', default => '');
277          $r .= q(sub next_index_for_).$name
278             .  q( {)."\n".q(my ($self, $source, %opt) = @_;)
279             .  line $Info, node_path => qq(Format[module-name()=$module_name]/NextIndex[Name=$name]);
280          $r .= code $Info, $_->get_attribute_value ('Main');
281          $r .= line $Info, reset => 1;
282          $r .= qq(}\n);
283        } elsif ($_->local_name eq 'Use') {
284          $r .= line $Info, node_path => qq(Format[module-name()=$module_name]/Use);
285          $r .= code $Info, $_->inner_text;
286        }
287      }
288      $r;
289    }
290    
291    sub make_format_converter ($$) {
292      my ($src, $Info) = @_;
293      my %def;
294      $def{Type} = $src->get_attribute ('Type');
295      if (ref $def{Type}) {
296        $def{Type} = $def{Type}->inner_text
297              . join '', map {
298                  ';'. $_->local_name .'='. quoted_string $_->inner_text
299                } sort {
300                  $a->local_name cmp $b->local_name
301                } @{$def{Type}->child_nodes};
302      } else {
303        delete $def{Type};
304      }
305      $def{Name} = $src->get_attribute_value ('Name');
306      delete $def{Name} unless defined $def{Name};
307      $def{Version} = $src->get_attribute_value ('Version');
308      delete $def{Version} if not defined $def{Version} or
309                              not defined $def{Name};
310      
311      my $flag = '//';
312      $flag .= 'f' and $def{IsFragment} = 1
313        if $src->get_attribute_value ('IsFragment');
314      $flag .= 'p' and $def{IsPlaceholder} = 1
315        if $src->get_attribute_value ('IsPlaceholder');
316      
317      for (qw/Main ToString ToOctetStream/) {
318        my $def = $src->get_attribute_value ($_);
319        next unless $def;
320        $def{$_} = line ($Info, node_path => '//Converter/'.$_)
321                   . $def
322                   . line ($Info, reset => 1);
323        if ($def{$_} =~ /\$r\b/) {
324          $def{$_} = 'my $r;'."\n".$def{$_}."\n".'$r';
325        }
326        $def{$_} = barecode code $Info,
327                     'sub {my ($self, $source, $opt) = @_;'
328                   . $def{$_} . '}';
329      }
330      
331      my $r = list %def;
332      if ($def{Type}) {
333        $r = qq{\$Converter->{@{[literal $def{Type}.$flag]}} = {$r};\n};
334        $r .= qq{\$Converter->{@{[literal '/'.$def{Name}.'/'.$def{Version}.$flag]}} = \$Converter->{@{[literal $def{Type}.$flag]}};\n}
335          if $def{Name};
336      } elsif ($def{Name}) {
337        $r = qq{\$Converter->{@{[literal '/'.$def{Name}.'/'.$def{Version}.$flag]}} = {$r};\n};
338      } else {
339        $r = 'BEGIN { die "Invalid Syntax of Converter: Type or Name property required" }';
340      }
341      $r;
342    }
343    
344    sub make_function ($$) {
345      my ($src, $Info) = @_;
346      ## TODO: support of ARGV property
347      my $name;
348      my $r = <<EOH;
349    @{[change_package $Info, $Info->{module_name}]}
350    sub @{[$name = $src->get_attribute_value ('Name')]} {
351    @{[line $Info, node_path => "Function[Name='$name']/Main"]}@{[
352      code $Info, $src->get_attribute_value ('Main')
353    ]}
354    }
355    @{[line $Info, reset => 1]}
356    EOH
357    }
358    
359    sub register_plugin_const ($$) {
360      my ($src, $Info) = @_;
361      for (@{$src->child_nodes}) {
362        $Info->{const}->{$_->local_name} = literal_or_code $Info, $_->value;
363      }
364    }
365    
366    sub make_resdef ($$) {
367      my ($src, $Info) = @_;
368      my $r = change_package $Info, 'SuikaWiki::Plugin::Resource';
369      local $Info->{-message_error_used} = 0;  
370      $r .= qq{our \$BaseResource;\n};
371      for (@{$src->child_nodes}) {
372        if ($_->node_type eq '#element') {
373          my $lang = literal ($_->get_attribute_value ('lang') || 'und');
374          my $script = literal $_->get_attribute_value ('script');
375          my $name = literal $_->local_name;
376          my $val = literal n11n $_->value;
377          $r .= qq{\$BaseResource->{$lang}->{$script}->{$name} = $val;\n};
378        }
379      }
380      $r;
381    }
382    
383  sub make_viewfragment ($$) {  sub make_viewfragment ($$) {
384    my ($src, $Info) = @_;    my ($src, $Info) = @_;
385    my $r = '';    my $r = '';
386    for (@{$src->child_nodes}) {    my $body = <<EOH;
387      ## TODO: use SuikaWiki2 interface    {
388      $r .= qq(SuikaWiki::View->template (@{[literal $_->local_name]})->add_line (@{[literal $_->value]});\n);      Main => @{[literal $src->get_attribute_value ('Formatting')]},
389        Order => @{[0+$src->get_attribute_value ('Order')]},
390        Description => [@{[m13ed_val_list $src, 'Description']}],
391      };
392    EOH
393      ## Recommended format
394      my $name = $src->get_attribute_value ('Template');
395      if (ref ($name) and @$name > 1) {
396        $r .= qq({my \$def = $body;\n);
397        for (@$name) {
398          my $name = $_; $name =~ tr/-/_/;
399          $r .= qq(push \@{\$SuikaWiki::View::Implementation::TemplateFragment{@{[literal $name]}}}, \$def;\n);
400          push @{$Info->{provide}->{viewfragment}}, {Name => $name};
401        }
402        $r .= qq(}\n);
403      } else {                           ## Obsoleted format
404        $name = ref $name ? $name->[0] : $src->get_attribute_value ('Name');
405        $name =~ tr/-/_/;
406        $r .= qq(push \@{\$SuikaWiki::View::Implementation::TemplateFragment{@{[literal $name]}}}, $body);
407        push @{$Info->{provide}->{viewfragment}}, {Name => $name};
408    }    }
409    $r;    $r;
410  }  }
# Line 80  sub make_viewdef ($$) { Line 413  sub make_viewdef ($$) {
413    my ($src, $Info) = @_;    my ($src, $Info) = @_;
414    my $ViewProp = {};    my $ViewProp = {};
415    my $r = '';    my $r = '';
416    $ViewProp->{Name} = n11n $src->get_attribute ('Mode')->value;    $ViewProp->{Name} = n11n $src->get_attribute_value ('Mode');
417      $ViewProp->{Name} =~ s/(?<=.)-/_/g;
418    $ViewProp->{pack_name} = random_module_name ($Info, $ViewProp->{Name});    $ViewProp->{pack_name} = random_module_name ($Info, $ViewProp->{Name});
419        
420    $ViewProp->{condition_stringified} = join ', ', map {literal $_}    $ViewProp->{condition_stringified} = hash
421      mode => $ViewProp->{Name},      mode => $ViewProp->{Name},
422      map {($_->local_name => $_->value)}      map {($_->local_name => $_->value)}
423        @{$src->get_attribute ('Condition',make_new_node=>1)->child_nodes};        @{$src->get_attribute ('Condition',make_new_node=>1)->child_nodes};
# Line 93  push \@SuikaWiki::View::Implementation:: Line 427  push \@SuikaWiki::View::Implementation::
427    condition => {$ViewProp->{condition_stringified}},    condition => {$ViewProp->{condition_stringified}},
428    object_class => q#$ViewProp->{pack_name}#,    object_class => q#$ViewProp->{pack_name}#,
429  };  };
430  package $ViewProp->{pack_name};  @{[change_package $Info, $ViewProp->{pack_name}]}
431  our \@ISA = q#SuikaWiki::View::template#;  our \@ISA = q#SuikaWiki::View::template#;
432  EOH  EOH
433      local $Info->{-message_error_used} = 0;  
434      my $use = $src->get_attribute ('Use');
435      if (ref $use) {
436        $r .= line $Info, node_path => "ViewDefinition[Mode='$ViewProp->{Name}']/Use";
437        $r .= code $Info, $use->inner_text;
438        $r .= "\n\n";
439      }
440      
441    for (@{$src->child_nodes}) {    for (@{$src->child_nodes}) {
442      if ($_->local_name eq 'method') {      if ($_->local_name eq 'template') {
443          $r .= make_view_template_method ($_, $Info, $ViewProp);
444        } elsif ($_->local_name eq 'method') {
445          my $method_name = $_->get_attribute_value ('Name');
446        $r .= ({        $r .= ({
447                main => q(sub main ($$) {)."\n".q(my ($self, $opt) = @_;)."\n",                main => q(sub main ($$) {)."\n".q(my ($self, $opt, $opt2) = @_;)."\n",
448                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",
449                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",                    
450               }->{$_->get_attribute ('Name')->value}               }->{$method_name}
451               ||qq(sub @{[$_->get_attribute ('Name')->value]} {\n))               ||qq(sub @{[$method_name]} {\n))
452           . $_->inner_text           . line ($Info, node_path => "ViewDefinition[Mode='$ViewProp->{Name}']/method[Name='$method_name']")
453           . qq(\n}\n);           . code ($Info, $_->value)
454             . qq(}\n)
455             . line ($Info, reset => 1);
456      }      }
457    }    }
458      my $prop = {Name => $ViewProp->{Name},
459                  Description => barecode m13ed_val_list $_, 'Description'};
460      push @{$Info->{provide}->{viewdef}}, $prop;
461      $r;
462    }
463    
464    sub make_view_template_method ($$) {
465      my ($src, $Info, $ViewProp) = @_;
466      my $r = <<EOH;
467    
468    sub main (\$\$\$) {
469      my (\$self, \$opt, \$opt2) = \@_;
470      require SuikaWiki::Output::HTTP;
471      \$opt2->{output} = SuikaWiki::Output::HTTP->new
472        (wiki => \$self->{view}->{wiki},
473         view => \$self->{view}, viewobj => \$self);
474      for (\@{\$self->{view}->{wiki}->{var}->{client}->{used_for_negotiate}},
475           'Accept-Language') {
476        \$opt2->{output}->add_negotiate_header_field (\$_);
477      }
478      
479      \$opt2->{template} = @{[literal $src->get_attribute ('body', make_new_node => 1)->inner_text]};
480      \$opt2->{o} = bless {
481                          ## SuikaWiki 3 WikiPlugin interface
482                            wiki => \$self->{view}->{wiki},
483                            plugin => \$self->{view}->{wiki}->{plugin},
484                            var => {},
485                          }, 'SuikaWiki::Plugin';  
486      @{[do{my $x=$src->get_attribute('http-status-code',make_new_node=>1)->inner_text;
487         $x?q{$opt2->{output}->{status_code} = }.(0 + $x).q{;}:q{}}]}
488      @{[do{my $x=$src->get_attribute('http-status-phrase',make_new_node=>1)->inner_text;
489         $x?q{$opt2->{output}->{status_phrase} = }.literal($x).q{;}:q{}}]}
490      \$opt2->{output}->{entity}->{media_type} = @{[literal
491                               $src->get_attribute ('media-type',make_new_node=>1)
492                                   ->inner_text || 'application/octet-stream']};
493      @{[($src->get_attribute ('use-media-type-charset',make_new_node=>1)
494                ->inner_text || 0) ?
495         q{$opt2->{output}->{entity}->{charset} = $self->{view}->{wiki}->{config}->{charset}->{output};}:
496         q{}]}
497      @{[do{my $x = $src->get_attribute ('expires',make_new_node=>1)->inner_text;
498              if ($x =~ /%%(\w+)%%/) {
499                qq{\$opt2->{output}->set_expires (%{\$self->{view}->{wiki}->{config}->{entity}->{expires}->{@{[literal $1]}}});};
500              } else {
501                qq{\$opt2->{output}->set_expires (delta => @{[0 + $x]});};
502              }
503          }]}
504      \$opt2->{output}->{entity}->{body_is_octet_stream} = @{[
505        $src->get_attribute ('body')->get_attribute_value ('is-octet-stream', default_value => 0)
506        or 0
507      ]};
508      
509      \$self->{view}->{wiki}->init_db;
510      \$self->main_pre (\$opt, \$opt2);
511      
512      use Message::Util::Error;
513      try {
514        \$opt2->{output}->{entity}->{body}
515          = SuikaWiki::Plugin->formatter ('view')
516            ->replace (\$opt2->{template}, param => \$opt2->{o});
517      } \$self->{view}->{wiki}->{config}->{catch}->{ @{[
518           $ViewProp->{Name} eq '-error' ? 'formatter_view_error'
519                                         : 'formatter_view' ]} };
520      \$opt2->{output}->output (output => 'http-cgi');
521      
522      \$self->main_post (\$opt, \$opt2);
523    }
524    EOH
525    }
526    
527    sub make_rule ($$) {
528      my ($src, $Info) = @_;
529      my $type = $src->get_attribute ('Category', make_new_node => 1)->value || [];
530      my $name = $src->get_attribute ('Name', make_new_node => 1)->value;
531      $name =~ s/(?<=.)-/_/g;
532      
533      my $reg_block;
534      $reg_block = qr/[^{}]*(?>[^{}]+|{(??{$reg_block})})*/;
535      my %code;
536      for my $codename ([qw/Formatting main/], [qw/After after/],
537                        [qw/Before before/], [qw/Pre pre/], [qw/Post post/],
538                        [qw/Attribute attr/]) {
539        my $main = code $Info, $src->get_attribute_value ($codename->[0]);
540        next unless $main;
541        $main = line ($Info, node_path =>
542                  "FormattingRule[name()='@{[list $type]}/$name']/".$codename->[0])
543              . $main;
544        
545        if ( $main =~ /\$f\b/
546          or $main =~ /\$rule_name\b/
547          or $main =~ /\$[opr]\b/
548          or $main =~ /[%\$]opt\b/
549          or $main =~ /\$param_(?:name|value)\n/) {
550          if ($codename->[0] ne 'Attribute') {
551            $main = q{my ($f, $rule_name, $p, $o, %opt) = @_;}."\n".$main;
552          } else {
553            $main = q{my ($f, $rule_name, $p, $o, $param_name => $param_value, %opt) = @_;}."\n".$main;
554          }
555        }
556        if ($main =~ /\$r\b/) {
557          warn qq(Rule @{[list $type]}/$name: Use of \$r is deprecated);
558          $main = q{my $r = '';} . "\n" . $main . "\n"
559                . q{$p->{-parent}->append_node ($r, node_or_text => 1);};
560        }
561        $main =~ s{__ATTR(TEXT|NODE)?:%(\w+|{$reg_block})(?:->{($reg_block)})?__;}
562                  {($1 eq 'TEXT' ? '$p->{'.literal_or_code($Info, $2)
563                                          .'} = do { my $r = ' : '')
564                   .'$f->parse_attr ($p=>'.literal_or_code($Info, $2).', $o, '
565                                   .($3?'-parent => '.$3.', ':'')
566                                   .($1?'-non_parsed_to_node => 1, ':'')
567                                   .'%opt)'
568                                   .($1 eq 'TEXT' ? '; ref $r?$r->inner_text:$r}'
569                                                  : '')
570                                   .';'}ge;
571        $code{$codename->[1]} = barecode "sub {$main}";
572      }
573      
574      my $main = literal {
575        Description => [barecode m13ed_val_list $src, 'Description'],
576        Parameter => {do {
577          my @r;
578          for (@{$src->child_nodes}) {
579            if ($_->local_name eq 'Parameter') {
580              push @r, $_->get_attribute_value ('Name')
581                       => {Type => $_->get_attribute_value ('Type'),
582                           Default => $_->get_attribute_value ('Default'),
583                           Description => [barecode m13ed_val_list $_, 'Description']};
584            }
585          }
586          @r;
587        }},
588        %code,
589      };
590      $main .= line $Info, reset => 1;
591    
592    
593    my  $amain = <<EOH;
594    {
595      main => sub {$main},
596    @{[line ($Info, reset => 1)]}
597      Description => [@{[m13ed_val_list $src, 'Description']}],
598      Parameter => {@{[do{
599      }]}},
600    }
601    EOH
602      my $r = change_package $Info, $Info->{module_name};
603      local $Info->{-message_error_used} = 0;  
604      if (@$type == 1) {
605        $type->[0] =~ tr/-/_/;
606        $r .= qq{\$SuikaWiki::Plugin::Rule{$type->[0]}->{$name} = $main;\n};
607        push @{$Info->{provide}->{rule}->{$type->[0]}}, $name;
608      } else {
609        $r .= qq({my \$def = $main;\n);
610        for my $type (@$type) {
611          $type =~ tr/-/_/;
612          $r .= qq{\$SuikaWiki::Plugin::Rule{$type}->{$name} = \$def;\n};
613          push @{$Info->{provide}->{rule}->{$type}}, $name;
614        }
615        $r .= qq(};\n);
616      }
617      $r;
618    }
619    
620    =item FormattingRuleAlias
621    
622    Generating an alias name for a formatting rule that is already loaded.
623    Example:
624    
625      FormattingRuleAlias:
626        @Category[list]:
627          category-1
628          category-2
629          ...
630        @Name: new-rule-name
631        @Reference:
632          @@Category: one-of-category
633          @@Name: one-of-name
634    
635    associates C<(I<category-1>, I<new-rule-name>)>,
636    C<(I<category-2>, I<new-rule-name>)>, ...
637    with C<(I<one-of-category>, I<one-of-name>)>.
638    
639    =cut
640    
641    sub make_rule_alias ($$) {
642      my ($src, $Info) = @_;
643      my $type = $src->get_attribute ('Category', make_new_node => 1)->value || [];
644      my $name = $src->get_attribute ('Name', make_new_node => 1)->value;
645      
646      my $ref = $src->get_attribute ('Reference', make_new_node => 1);
647      my $c = $ref->get_attribute_value ('Category');
648      my $n = $ref->get_attribute_value ('Name');
649      
650      s/(?<=.)-/_/g for $n, $name;
651      tr/-/_/ for $c, @$type;
652      
653      my $def = qq{\$SuikaWiki::Plugin::Rule{@{[literal $c]}}->{@{[literal $n]}} or warn qq{Formatting rule "$c/$n" not defined}};
654      
655      my $r = change_package $Info, $Info->{module_name};
656      for my $type (@$type) {
657        $r .= qq{\$SuikaWiki::Plugin::Rule{@{[literal $type]}}->{@{[literal $name]}} = $def;\n};
658        push @{$Info->{provide}->{rule}->{$type}}, $name;
659      }
660    $r;    $r;
661  }  }
662    
# Line 117  sub random_module_name ($;$) { Line 666  sub random_module_name ($;$) {
666    $subname =~ s/[^0-9A-Za-z_:]//g;    $subname =~ s/[^0-9A-Za-z_:]//g;
667    my @date = gmtime;    my @date = gmtime;
668    my @rand = ('A'..'Z','a'..'z',0..9,'_');    my @rand = ('A'..'Z','a'..'z',0..9,'_');
669    sprintf '%s::%s%s%s', $Info{module_name}, $subname,    sprintf '%s::%s%s%s', $Info->{module_name}, $subname,
670      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]),
671      join ('', @rand[rand@rand,rand@rand,rand@rand,rand@rand]);      join ('', @rand[rand@rand,rand@rand,rand@rand,rand@rand]);
672  }  }
673    
674    =head1 NAME
675    
676    mkplugin2.pl - SuikaWiki: WikiPlugin Generator
677    
678    =head1 SYNOPSIS
679    
680      mkplugin2.pl pluginsrc.wp2 > plugin.pm
681    
682    =head1 DESCRIPTION
683    
684    C<mkplugin2.pl> generates WikiPlugin module as a Perl module file
685    from WikiPlugin source description.  WikiPlugin source description
686    is described in SuikaWikiConfig/2.0 format and it contains
687    definitions of wiki constructions (such as formatting rules and
688    WikiView definitions) as both machine understandable code and
689    human readable documentation.  For more information, see
690    <http://suika.fam.cx/~wakaba/-temp/wiki/wiki?WikiPlugin>.
691    
692    This script is part of SuikaWiki.
693    
694    =head1 HISTORY AND COMPATIBILITY
695    
696    C<mkplugin2.pl> introduced as part of SuikaWiki 3.
697    It converts SuikaWiki 3 WikiPlugin source descriptions
698    (in SuikaWikiConfig/2.0) into Perl modules with SuikaWiki 3 interface.
699    
700    SuikaWiki 2 has C<mkplugin.pl>.  It also converts WikiPlugin
701    source descriptions into Perl modules.  But it support
702    SuikaWiki 2 format of WikiPlugin source description that differs from
703    SuikaWiki 3 format.  Wiki programming interface (not limited to
704    WikiPlugin related one) of SuikaWiki 3 also incompatible with that
705    of SuikaWiki 2 so that it is impossible to use SuikaWiki 2 WikiPlugin
706    module with SuikaWiki 3 and vice versa.
707    
708    =head1 SEE ALSO
709    
710    C<SuikaWiki::Plugin>, SuikaWiki:WikiPlugin
711    <http://suika.fam.cx/~wakaba/-temp/wiki/wiki?WikiPlugin>.
712    
713    =head1 LICENSE
714    
715    Copyright 2003-2004 Wakaba <w@suika.fam.cx>.  All rights reserved.
716    
717    This program is free software; you can redistribute it and/or
718    modify it under the same terms as Perl itself.
719    
720    =cut
721    
722    1; # $Date$
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.15
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24