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