/[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.13 by wakaba, Sat Feb 14 10:59:55 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  }  }
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.13
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24