/[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.14 by wakaba, Thu Mar 11 04:04:06 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    # Parameter
190    # PluginCategory
191    }    }
192  }  }
193    
194    print change_package \%Info, q(SuikaWiki::Plugin::Registry);
195    print qq{\$Info{$Info{name_literal}}->{provide} = } . literal $Info{provide};
196    print qq{;\n};
197    
198  print "\n1;\n";  print "\n1;\n";
199  exit;  exit;
200    }
201    
202    sub make_format ($$) {
203      my ($src, $Info) = @_;
204      my $module_name = 'SuikaWiki::Format::Definition::'.$src->get_attribute_value ('ModuleName');
205      my $r = change_package $Info, $module_name;
206      local $Info->{-message_error_used} = 0;  
207      $r .= qq{our \@ISA;\n};
208      if (my $isa = $src->get_attribute_value ('Inherit')) {
209        for (@$isa) {
210          $r .= qq{push \@ISA, @{[literal 'SuikaWiki::Format::Definition::'.$_]};\n};
211        }
212      } else {
213        $r .= qq{push \@ISA, 'SuikaWiki::Format::Definition::template';\n};    
214      }
215      if (my $name = $src->get_attribute_value ('Name')) {
216        $r .= qq{\$SuikaWiki::Format::Definition::Class{@{[literal '/'.$name.'/'.$src->get_attribute_value ('Version', default => '').'//']}} = '$module_name';\n};
217      }
218      if (my $type = $src->get_attribute_value ('Type')) {
219        $type .= join '', map {
220                   ';'. $_->local_name .'='. quoted_string $_->inner_text
221                 } sort {
222                   $a->local_name cmp $b->local_name
223                 } @{$src->get_attribute ('Type')->child_nodes};
224        $r .= qq{\$SuikaWiki::Format::Definition::Class{@{[literal $type.'//']}} = '$module_name';\n};
225      }
226      
227      my $convert = line $Info, line_no => __LINE__ + 2, realfile => __FILE__;
228      $convert .= <<'EOH';
229    our $Converter;
230    sub convert ($$;%) {
231      my ($self, $source, %opt) = @_;
232      my $converter;
233      my $flag = '//';
234      $flag .= 'f' if $opt{IsFragment};
235      $flag .= 'p' if $opt{IsPlaceholder};
236      my $type = $opt{Type} ?
237                    $opt{Type} .
238                    SuikaWiki::Format::Definition->__get_param_string
239                      ($opt{Type_param}) : undef;
240      if ($Converter->{$type.$flag}) {
241        $converter = $Converter->{$type.$flag};
242      } elsif ($Converter->{$opt{Name}.'/'.$opt{Version}.$flag}) {
243        $converter = $Converter->{'/'.$opt{Name}.'/'.$opt{Version}.$flag};
244      }
245      return ($converter->{$opt{return_type} or 'Main'} or
246              CORE::die "Buggy implementation: $type $opt{Name}/$opt{Version}$flag/@{[$opt{return_type} or 'Main']} not defined")
247             ->($self, $source, \%opt)
248        if $converter;
249      $self->SUPER::convert ($source, %opt);
250    }
251    EOH
252      
253      for (@{$src->child_nodes}) {
254        if ($_->local_name eq 'Converter') {
255          if ($convert) {
256            $r .= $convert;
257            $r .= line $Info, reset => 1;
258            undef $convert;
259          }
260          $r .= make_format_converter ($_, $Info);
261        } elsif ($_->local_name eq 'WikiForm') {
262          $r .= q(sub wikiform {)."\n".q(my ($self, $source, %opt) = @_;);
263          $r .= line $Info, node_path => qq(Format[module-name()=$module_name]/WikiForm);
264          $r .= code $Info, $_->get_attribute_value ('Main');
265          $r .= line $Info, reset => 1;
266          $r .= qq(}\n);
267        } elsif ($_->local_name eq 'HeadSummary') {
268          $r .= q(sub headsummary {)."\n".q(my ($self, $source, %opt) = @_;);
269          $r .= line $Info, node_path => qq(Format[module-name()=$module_name]/HeadSummary);
270          $r .= code $Info, $_->get_attribute_value ('Main');
271          $r .= line $Info, reset => 1;
272          $r .= qq(}\n);
273        } elsif ($_->local_name eq 'NextIndex') {
274          my $name = $_->get_attribute_value ('Name', default => '');
275          $r .= q(sub next_index_for_).$name
276             .  q( {)."\n".q(my ($self, $source, %opt) = @_;)
277             .  line $Info, node_path => qq(Format[module-name()=$module_name]/NextIndex[Name=$name]);
278          $r .= code $Info, $_->get_attribute_value ('Main');
279          $r .= line $Info, reset => 1;
280          $r .= qq(}\n);
281        } elsif ($_->local_name eq 'Use') {
282          $r .= line $Info, node_path => qq(Format[module-name()=$module_name]/Use);
283          $r .= code $Info, $_->inner_text;
284        }
285      }
286      $r;
287    }
288    
289    sub make_format_converter ($$) {
290      my ($src, $Info) = @_;
291      my %def;
292      $def{Type} = $src->get_attribute ('Type');
293      if (ref $def{Type}) {
294        $def{Type} = $def{Type}->inner_text
295              . join '', map {
296                  ';'. $_->local_name .'='. quoted_string $_->inner_text
297                } sort {
298                  $a->local_name cmp $b->local_name
299                } @{$def{Type}->child_nodes};
300      } else {
301        delete $def{Type};
302      }
303      $def{Name} = $src->get_attribute_value ('Name');
304      delete $def{Name} unless defined $def{Name};
305      $def{Version} = $src->get_attribute_value ('Version');
306      delete $def{Version} if not defined $def{Version} or
307                              not defined $def{Name};
308      
309      my $flag = '//';
310      $flag .= 'f' and $def{IsFragment} = 1
311        if $src->get_attribute_value ('IsFragment');
312      $flag .= 'p' and $def{IsPlaceholder} = 1
313        if $src->get_attribute_value ('IsPlaceholder');
314      
315      for (qw/Main ToString ToOctetStream/) {
316        my $def = $src->get_attribute_value ($_);
317        next unless $def;
318        $def{$_} = line ($Info, node_path => '//Converter/'.$_)
319                   . $def
320                   . line ($Info, reset => 1);
321        if ($def{$_} =~ /\$r\b/) {
322          $def{$_} = 'my $r;'."\n".$def{$_}."\n".'$r';
323        }
324        $def{$_} = barecode code $Info,
325                     'sub {my ($self, $source, $opt) = @_;'
326                   . $def{$_} . '}';
327      }
328      
329      my $r = list %def;
330      if ($def{Type}) {
331        $r = qq{\$Converter->{@{[literal $def{Type}.$flag]}} = {$r};\n};
332        $r .= qq{\$Converter->{@{[literal '/'.$def{Name}.'/'.$def{Version}.$flag]}} = \$Converter->{@{[literal $def{Type}.$flag]}};\n}
333          if $def{Name};
334      } elsif ($def{Name}) {
335        $r = qq{\$Converter->{@{[literal '/'.$def{Name}.'/'.$def{Version}.$flag]}} = {$r};\n};
336      } else {
337        $r = 'BEGIN { die "Invalid Syntax of Converter: Type or Name property required" }';
338      }
339      $r;
340    }
341    
342    sub make_function ($$) {
343      my ($src, $Info) = @_;
344      ## TODO: support of ARGV property
345      my $name;
346      my $r = <<EOH;
347    @{[change_package $Info, $Info->{module_name}]}
348    sub @{[$name = $src->get_attribute_value ('Name')]} {
349    @{[line $Info, node_path => "Function[Name='$name']/Main"]}@{[
350      code $Info, $src->get_attribute_value ('Main')
351    ]}
352    }
353    @{[line $Info, reset => 1]}
354    EOH
355    }
356    
357    sub register_plugin_const ($$) {
358      my ($src, $Info) = @_;
359      for (@{$src->child_nodes}) {
360        $Info->{const}->{$_->local_name} = literal_or_code $Info, $_->value;
361      }
362    }
363    
364    sub make_resdef ($$) {
365      my ($src, $Info) = @_;
366      my $r = change_package $Info, 'SuikaWiki::Plugin::Resource';
367      local $Info->{-message_error_used} = 0;  
368      $r .= qq{our \$BaseResource;\n};
369      for (@{$src->child_nodes}) {
370        if ($_->node_type eq '#element') {
371          my $lang = literal ($_->get_attribute_value ('lang') || 'und');
372          my $script = literal $_->get_attribute_value ('script');
373          my $name = literal $_->local_name;
374          my $val = literal n11n $_->value;
375          $r .= qq{\$BaseResource->{$lang}->{$script}->{$name} = $val;\n};
376        }
377      }
378      $r;
379    }
380    
381  sub make_viewfragment ($$) {  sub make_viewfragment ($$) {
382    my ($src, $Info) = @_;    my ($src, $Info) = @_;
383    my $r = '';    my $r = '';
384    for (@{$src->child_nodes}) {    my $body = <<EOH;
385      ## TODO: use SuikaWiki2 interface    {
386      $r .= qq(SuikaWiki::View->template (@{[literal $_->local_name]})->add_line (@{[literal $_->value]});\n);      Main => @{[literal $src->get_attribute_value ('Formatting')]},
387        Order => @{[0+$src->get_attribute_value ('Order')]},
388        Description => [@{[m13ed_val_list $src, 'Description']}],
389      };
390    EOH
391      ## Recommended format
392      my $name = $src->get_attribute_value ('Template');
393      if (ref ($name) and @$name > 1) {
394        $r .= qq({my \$def = $body;\n);
395        for (@$name) {
396          my $name = $_; $name =~ tr/-/_/;
397          $r .= qq(push \@{\$SuikaWiki::View::Implementation::TemplateFragment{@{[literal $name]}}}, \$def;\n);
398          push @{$Info->{provide}->{viewfragment}}, {Name => $name};
399        }
400        $r .= qq(}\n);
401      } else {                           ## Obsoleted format
402        $name = ref $name ? $name->[0] : $src->get_attribute_value ('Name');
403        $name =~ tr/-/_/;
404        $r .= qq(push \@{\$SuikaWiki::View::Implementation::TemplateFragment{@{[literal $name]}}}, $body);
405        push @{$Info->{provide}->{viewfragment}}, {Name => $name};
406    }    }
407    $r;    $r;
408  }  }
# Line 80  sub make_viewdef ($$) { Line 411  sub make_viewdef ($$) {
411    my ($src, $Info) = @_;    my ($src, $Info) = @_;
412    my $ViewProp = {};    my $ViewProp = {};
413    my $r = '';    my $r = '';
414    $ViewProp->{Name} = n11n $src->get_attribute ('Mode')->value;    $ViewProp->{Name} = n11n $src->get_attribute_value ('Mode');
415      $ViewProp->{Name} =~ s/(?<=.)-/_/g;
416    $ViewProp->{pack_name} = random_module_name ($Info, $ViewProp->{Name});    $ViewProp->{pack_name} = random_module_name ($Info, $ViewProp->{Name});
417        
418    $ViewProp->{condition_stringified} = join ', ', map {literal $_}    $ViewProp->{condition_stringified} = hash
419      mode => $ViewProp->{Name},      mode => $ViewProp->{Name},
420      map {($_->local_name => $_->value)}      map {($_->local_name => $_->value)}
421        @{$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 425  push \@SuikaWiki::View::Implementation::
425    condition => {$ViewProp->{condition_stringified}},    condition => {$ViewProp->{condition_stringified}},
426    object_class => q#$ViewProp->{pack_name}#,    object_class => q#$ViewProp->{pack_name}#,
427  };  };
428  package $ViewProp->{pack_name};  @{[change_package $Info, $ViewProp->{pack_name}]}
429  our \@ISA = q#SuikaWiki::View::template#;  our \@ISA = q#SuikaWiki::View::template#;
430  EOH  EOH
431      local $Info->{-message_error_used} = 0;  
432      my $use = $src->get_attribute ('Use');
433      if (ref $use) {
434        $r .= line $Info, node_path => "ViewDefinition[Mode='$ViewProp->{Name}']/Use";
435        $r .= code $Info, $use->inner_text;
436        $r .= "\n\n";
437      }
438      
439    for (@{$src->child_nodes}) {    for (@{$src->child_nodes}) {
440      if ($_->local_name eq 'method') {      if ($_->local_name eq 'template') {
441          $r .= make_view_template_method ($_, $Info, $ViewProp);
442        } elsif ($_->local_name eq 'method') {
443          my $method_name = $_->get_attribute_value ('Name');
444        $r .= ({        $r .= ({
445                main => q(sub main ($$) {)."\n".q(my ($self, $opt) = @_;)."\n",                main => q(sub main ($$) {)."\n".q(my ($self, $opt, $opt2) = @_;)."\n",
446                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",
447                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",                    
448               }->{$_->get_attribute ('Name')->value}               }->{$method_name}
449               ||qq(sub @{[$_->get_attribute ('Name')->value]} {\n))               ||qq(sub @{[$method_name]} {\n))
450           . $_->inner_text           . line ($Info, node_path => "ViewDefinition[Mode='$ViewProp->{Name}']/method[Name='$method_name']")
451           . qq(\n}\n);           . code ($Info, $_->value)
452             . qq(}\n)
453             . line ($Info, reset => 1);
454        }
455      }
456      my $prop = {Name => $ViewProp->{Name},
457                  Description => barecode m13ed_val_list $_, 'Description'};
458      push @{$Info->{provide}->{viewdef}}, $prop;
459      $r;
460    }
461    
462    sub make_view_template_method ($$) {
463      my ($src, $Info, $ViewProp) = @_;
464      my $r = <<EOH;
465    
466    sub main (\$\$\$) {
467      my (\$self, \$opt, \$opt2) = \@_;
468      require SuikaWiki::Output::HTTP;
469      \$opt2->{output} = SuikaWiki::Output::HTTP->new
470        (wiki => \$self->{view}->{wiki},
471         view => \$self->{view}, viewobj => \$self);
472      for (\@{\$self->{view}->{wiki}->{var}->{client}->{used_for_negotiate}},
473           'Accept-Language') {
474        \$opt2->{output}->add_negotiate_header_field (\$_);
475      }
476      
477      \$opt2->{template} = @{[literal $src->get_attribute ('body', make_new_node => 1)->inner_text]};
478      \$opt2->{o} = bless {
479                          ## SuikaWiki 3 WikiPlugin interface
480                            wiki => \$self->{view}->{wiki},
481                            plugin => \$self->{view}->{wiki}->{plugin},
482                            var => {},
483                          }, 'SuikaWiki::Plugin';  
484      @{[do{my $x=$src->get_attribute('http-status-code',make_new_node=>1)->inner_text;
485         $x?q{$opt2->{output}->{status_code} = }.(0 + $x).q{;}:q{}}]}
486      @{[do{my $x=$src->get_attribute('http-status-phrase',make_new_node=>1)->inner_text;
487         $x?q{$opt2->{output}->{status_phrase} = }.literal($x).q{;}:q{}}]}
488      \$opt2->{output}->{entity}->{media_type} = @{[literal
489                               $src->get_attribute ('media-type',make_new_node=>1)
490                                   ->inner_text || 'application/octet-stream']};
491      @{[($src->get_attribute ('use-media-type-charset',make_new_node=>1)
492                ->inner_text || 0) ?
493         q{$opt2->{output}->{entity}->{charset} = $self->{view}->{wiki}->{config}->{charset}->{output};}:
494         q{}]}
495      @{[do{my $x = $src->get_attribute ('expires',make_new_node=>1)->inner_text;
496              if ($x =~ /%%(\w+)%%/) {
497                qq{\$opt2->{output}->set_expires (%{\$self->{view}->{wiki}->{config}->{entity}->{expires}->{@{[literal $1]}}});};
498              } else {
499                qq{\$opt2->{output}->set_expires (delta => @{[0 + $x]});};
500              }
501          }]}
502      \$opt2->{output}->{entity}->{body_is_octet_stream} = @{[
503        $src->get_attribute ('body')->get_attribute_value ('is-octet-stream', default_value => 0)
504        or 0
505      ]};
506      
507      \$self->{view}->{wiki}->init_db;
508      \$self->main_pre (\$opt, \$opt2);
509      
510      use Message::Util::Error;
511      try {
512        \$opt2->{output}->{entity}->{body}
513          = SuikaWiki::Plugin->formatter ('view')
514            ->replace (\$opt2->{template}, param => \$opt2->{o});
515      } \$self->{view}->{wiki}->{config}->{catch}->{ @{[
516           $ViewProp->{Name} eq '-error' ? 'formatter_view_error'
517                                         : 'formatter_view' ]} };
518      \$opt2->{output}->output (output => 'http-cgi');
519      
520      \$self->main_post (\$opt, \$opt2);
521    }
522    EOH
523    }
524    
525    sub make_rule ($$) {
526      my ($src, $Info) = @_;
527      my $type = $src->get_attribute ('Category', make_new_node => 1)->value || [];
528      my $name = $src->get_attribute ('Name', make_new_node => 1)->value;
529      $name =~ s/(?<=.)-/_/g;
530      
531      my $reg_block;
532      $reg_block = qr/[^{}]*(?>[^{}]+|{(??{$reg_block})})*/;
533      my %code;
534      for my $codename ([qw/Formatting main/], [qw/After after/],
535                        [qw/Before before/], [qw/Pre pre/], [qw/Post post/],
536                        [qw/Attribute attr/]) {
537        my $main = code $Info, $src->get_attribute_value ($codename->[0]);
538        next unless $main;
539        $main = line ($Info, node_path =>
540                  "FormattingRule[name()='@{[list $type]}/$name']/".$codename->[0])
541              . $main;
542        
543        if ( $main =~ /\$f\b/
544          or $main =~ /\$rule_name\b/
545          or $main =~ /\$[opr]\b/
546          or $main =~ /[%\$]opt\b/
547          or $main =~ /\$param_(?:name|value)\n/) {
548          if ($codename->[0] ne 'Attribute') {
549            $main = q{my ($f, $rule_name, $p, $o, %opt) = @_;}."\n".$main;
550          } else {
551            $main = q{my ($f, $rule_name, $p, $o, $param_name => $param_value, %opt) = @_;}."\n".$main;
552          }
553      }      }
554        if ($main =~ /\$r\b/) {
555          warn qq(Rule @{[list $type]}/$name: Use of \$r is deprecated);
556          $main = q{my $r = '';} . "\n" . $main . "\n"
557                . q{$p->{-parent}->append_node ($r, node_or_text => 1);};
558        }
559        $main =~ s{__ATTR(TEXT|NODE)?:%(\w+|{$reg_block})(?:->{($reg_block)})?__;}
560                  {($1 eq 'TEXT' ? '$p->{'.literal_or_code($Info, $2)
561                                          .'} = do { my $r = ' : '')
562                   .'$f->parse_attr ($p=>'.literal_or_code($Info, $2).', $o, '
563                                   .($3?'-parent => '.$3.', ':'')
564                                   .($1?'-non_parsed_to_node => 1, ':'')
565                                   .'%opt)'
566                                   .($1 eq 'TEXT' ? '; ref $r?$r->inner_text:$r}'
567                                                  : '')
568                                   .';'}ge;
569        $code{$codename->[1]} = barecode "sub {$main}";
570      }
571      
572      my $main = literal {
573        Description => [barecode m13ed_val_list $src, 'Description'],
574        Parameter => {do {
575          my @r;
576          for (@{$src->child_nodes}) {
577            if ($_->local_name eq 'Parameter') {
578              push @r, $_->get_attribute_value ('Name')
579                       => {Type => $_->get_attribute_value ('Type'),
580                           Default => $_->get_attribute_value ('Default'),
581                           Description => [barecode m13ed_val_list $_, 'Description']};
582            }
583          }
584          @r;
585        }},
586        %code,
587      };
588      $main .= line $Info, reset => 1;
589    
590    
591    my  $amain = <<EOH;
592    {
593      main => sub {$main},
594    @{[line ($Info, reset => 1)]}
595      Description => [@{[m13ed_val_list $src, 'Description']}],
596      Parameter => {@{[do{
597      }]}},
598    }
599    EOH
600      my $r = change_package $Info, $Info->{module_name};
601      local $Info->{-message_error_used} = 0;  
602      if (@$type == 1) {
603        $type->[0] =~ tr/-/_/;
604        $r .= qq{\$SuikaWiki::Plugin::Rule{$type->[0]}->{$name} = $main;\n};
605        push @{$Info->{provide}->{rule}->{$type->[0]}}, $name;
606      } else {
607        $r .= qq({my \$def = $main;\n);
608        for my $type (@$type) {
609          $type =~ tr/-/_/;
610          $r .= qq{\$SuikaWiki::Plugin::Rule{$type}->{$name} = \$def;\n};
611          push @{$Info->{provide}->{rule}->{$type}}, $name;
612        }
613        $r .= qq(};\n);
614    }    }
615    $r;    $r;
616  }  }
# Line 117  sub random_module_name ($;$) { Line 621  sub random_module_name ($;$) {
621    $subname =~ s/[^0-9A-Za-z_:]//g;    $subname =~ s/[^0-9A-Za-z_:]//g;
622    my @date = gmtime;    my @date = gmtime;
623    my @rand = ('A'..'Z','a'..'z',0..9,'_');    my @rand = ('A'..'Z','a'..'z',0..9,'_');
624    sprintf '%s::%s%s%s', $Info{module_name}, $subname,    sprintf '%s::%s%s%s', $Info->{module_name}, $subname,
625      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]),
626      join ('', @rand[rand@rand,rand@rand,rand@rand,rand@rand]);      join ('', @rand[rand@rand,rand@rand,rand@rand,rand@rand]);
627  }  }
628    
629    =head1 NAME
630    
631    mkplugin2.pl - SuikaWiki: WikiPlugin Generator
632    
633    =head1 SYNOPSIS
634    
635      mkplugin2.pl pluginsrc.wp2 > plugin.pm
636    
637    =head1 DESCRIPTION
638    
639    C<mkplugin2.pl> generates WikiPlugin module as a Perl module file
640    from WikiPlugin source description.  WikiPlugin source description
641    is described in SuikaWikiConfig/2.0 format and it contains
642    definitions of wiki constructions (such as formatting rules and
643    WikiView definitions) as both machine understandable code and
644    human readable documentation.  For more information, see
645    <http://suika.fam.cx/~wakaba/-temp/wiki/wiki?WikiPlugin>.
646    
647    This script is part of SuikaWiki.
648    
649    =head1 HISTORY AND COMPATIBILITY
650    
651    C<mkplugin2.pl> introduced as part of SuikaWiki 3.
652    It converts SuikaWiki 3 WikiPlugin source descriptions
653    (in SuikaWikiConfig/2.0) into Perl modules with SuikaWiki 3 interface.
654    
655    SuikaWiki 2 has C<mkplugin.pl>.  It also converts WikiPlugin
656    source descriptions into Perl modules.  But it support
657    SuikaWiki 2 format of WikiPlugin source description that differs from
658    SuikaWiki 3 format.  Wiki programming interface (not limited to
659    WikiPlugin related one) of SuikaWiki 3 also incompatible with that
660    of SuikaWiki 2 so that it is impossible to use SuikaWiki 2 WikiPlugin
661    module with SuikaWiki 3 and vice versa.
662    
663    =head1 SEE ALSO
664    
665    C<SuikaWiki::Plugin>, SuikaWiki:WikiPlugin
666    <http://suika.fam.cx/~wakaba/-temp/wiki/wiki?WikiPlugin>.
667    
668    =head1 LICENSE
669    
670    Copyright 2003-2004 Wakaba <w@suika.fam.cx>.  All rights reserved.
671    
672    This program is free software; you can redistribute it and/or
673    modify it under the same terms as Perl itself.
674    
675    =cut
676    
677    1; # $Date$
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.14
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24