/[pub]/suikawiki/script/bin/mkplugin2.pl

Diff of /suikawiki/script/bin/mkplugin2.pl

Parent Directory | Revision Log | View Patch Patch

-revision 1.1 by wakaba,
Sun Oct  5 11:11:13 2003 UTC
+revision 1.17 by wakaba,
Sat May  1 03:55:05 2004 UTC
 Line 1
  #!/usr/bin/perl
  use strict;
- require SuikaWiki::Markup::SuikaWikiConfig20::Parser;
+ our $VERSION = do{my @r=(q$Revision$=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
+ require Message::Markup::SuikaWikiConfig20::Parser;
+ {
  my $src = '';
  my $srcfile = shift;
  open SRC, $srcfile or die "$0: $!"; {
-Line 11 
 open SRC, $srcfile or die "$0: $!"; {
+Line 13 
 open SRC, $srcfile or die "$0: $!"; {
  sub literal ($) {
    my $s = shift;
-   $s =~ s/([#\\])/\\$1/g;
+   if (ref ($s) eq 'ARRAY') {
-   q<q#> . $s . q<#>;
+     q<[> . list (@$s) . q<]>;
+   } elsif (ref ($s) eq 'HASH') {
+     q<{> . hash (%$s) . q<}>;
+   } elsif (ref ($s) eq 'bare') {
+     $$s;
+   } else {
+     $s =~ s/([#\\])/\\$1/g;
+     q<q#> . $s . q<#>;
+   }
+ }
+ sub list (@) {
+   join ', ', map {literal $_} @_;
+ }
+ sub hash (%) {
+   my $i = 0;
+   list map {($i++ % 2) ? $_ : do {my $s = $_; $s =~ s/(?<=.)-/_/; $s}} @_;
  }
  sub n11n ($) {
    my $s = shift;
    $s =~ s/\s+/ /g;
    $s;
  }
+ sub m13ed_val_list ($$) {
+   my ($src, $key) = @_;
+   my @r;
+   for (@{$src->child_nodes}) {
+     if ($_->local_name eq $key) {
+       push @r, [scalar $_->inner_text,
+                 scalar $_->get_attribute ('lang', make_new_node => 1)
+                          ->inner_text,
+                 scalar $_->get_attribute ('script', make_new_node => 1)
+                          ->inner_text];
+     }
+   }
+   list @r;
+ }
+ sub barecode ($) {
+   bless \$_[0], 'bare';
+ }
+ sub code ($$) {
+   my ($Info, $code) = @_;
+   for (keys %{$Info->{const}}) {
+     $code =~ s/\$$_\b/$Info->{const}->{$_}/ge;
+   }
+   $code =~ s/__FUNCPACK__/$Info->{module_name}/g;
+   $code =~ s{<Q:([^:]+):([^>]+)>}{
+     if ($Info->{Namespace}->{$1}) {
+       literal $Info->{Namespace}->{$1}.$2;
+     } else {
+       warn qq(Namespace prefix "$1" not defined);
+       literal $2;
+     }
+   }ge;
+   $Info->{-message_error_used} = 1 if $code =~ /\buse\s+Message::Util::Error\b/;
+   if (not $Info->{-message_error_used} and
+      ($code =~ /\btry\s*\{/ or $code =~ /\bcatch\s*\{/)) {
+     warn "Message::Util::Error MUST be 'use'd before 'try'...'catch' block used";
+   }
+   $code;
+ }
+ sub change_package ($$) {
+   my ($Info, $pack) = @_;
+   unless ($Info->{current_package} eq $pack) {
+     $Info->{current_package} = $pack;
+     return qq{package $pack;\n\n};
+   } else {
+     return '';
+   }
+ }
+ sub quoted_string ($) {
+   my $s = shift;
+   $s =~ s/([\\"])/\\$1/g;
+   '"'.$s.'"';
+ }
+ sub line ($;%) {
+   my ($Info, %opt) = @_;
+   unless ($opt{file}) {
+     if ($opt{reset}) {
+       $opt{file} = sprintf '(WikiPlugin module %s, chunk %d)',
+                            $Info->{Name},
+                            ++$Info->{chunk_count};
+     } elsif ($opt{realfile}) {
+       $opt{file} = sprintf '(WikiPlugin module %s, chunk from %s)',
+                            $Info->{Name},
+                            $opt{realfile};
+     } else {
+       $opt{file} = sprintf '(WikiPlugin module source %s, block %s)',
+                            $Info->{source_file},
+                            $opt{node_path};
+     }
+   }
+   $opt{file} =~ s/"/''/g;
+   sprintf '%s#line %d "%s"%s', "\n", $opt{line_no} || 1, $opt{file}, "\n";
+ }
+ sub literal_or_code ($$) {
+   my ($Info, $s) = @_;
+   substr ($s, 0, 1) ne '{' ? literal ($s)
+                            : code ($Info, substr ($s, 1, length ($s) - 2));
+ }
- my $parser = SuikaWiki::Markup::SuikaWikiConfig20::Parser->new;
+ my $parser = Message::Markup::SuikaWikiConfig20::Parser->new;
  my $plugins = $parser->parse_text ($src);
  my $meta = $plugins->get_attribute ('Plugin')
            or die "$0: Required 'Plugin' section not found";
- my %Info = (Name => n11n $meta->get_attribute ('Name')->value);
+ my %Info = (provide => {},
+             Name => n11n $meta->get_attribute ('Name')->value);
+ $Info{source_file} = $srcfile;
  $Info{name_literal} = literal $Info{Name};
  my @date = gmtime;
  $Info{LastModified} = sprintf '%04d-%02d-%02dT%02d:%02d:%02d+00:00',
                                $date[5] + 1900, $date[4] + 1, @date[3,2,1,0];
  $Info{Version} = sprintf '%04d.%02d%02d.%02d%02d',
                           $date[5] + 1900, $date[4] + 1, @date[3,2,1];
+ $Info{InterfaceVersion} = '2.9.1';
+ $Info{mkpluginVersion} = '2.'.$VERSION;
  $Info{module_name} = q#SuikaWiki::Plugin::plugin#;
  $Info{module_name} = random_module_name (\%Info, $Info{Name});
  print <<EOH;
  use strict;
- package SuikaWiki::Plugin::Registry;
+ @{[change_package \%Info, 'SuikaWiki::Plugin::Registry']}
  our \%Info;
  \$Info{$Info{name_literal}}->{Name} = $Info{name_literal};
- \$Info{$Info{name_literal}}->{Version} = q#$Info{Version}#;
  EOH
- for (qw/Description LastModified License/) {
+ for (qw/Version InterfaceVersion mkpluginVersion module_name/) {
+   print qq{\$Info{$Info{name_literal}}->{@{[literal $_]}} = @{[literal $Info{$_}]};\n};
+ }
+ for (qw/LastModified Date.RCS/) {
    $Info{$_} = n11n $meta->get_attribute ($_,make_new_node=>1)->value;
    next unless length $Info{$_};
-   print qq{\$Info{$Info{name_literal}}->{$_} = } . literal $Info{$_};
+   print qq{\$Info{$Info{name_literal}}->{@{[literal $_]}} = } . literal $Info{$_};
    print ";\n";
  }
- for (qw/Author RelatedURI RelatedWikiPage RequiredPlugin RequiredModule/) {
+ for (qw/RequiredPlugin RequiredModule/) {
    $Info{$_} = $meta->get_attribute ($_);
    next unless ref $Info{$_}; $Info{$_} = $Info{$_}->value;
    print qq{\$Info{$Info{name_literal}}->{$_} = [};
    print join ', ', map {literal $_} @{$Info{$_}};
    print "];\n";
  }
+ for (qw/Description License RelatedWikiPage RelatedURI/) {
+   my $r = m13ed_val_list $meta, $_;
+   next unless $r;
+   print qq{\$Info{$Info{name_literal}}->{$_} = [$r];\n};
+ }
+ print qq{\$Info{$Info{name_literal}}->{Author} = [} .( list map {
+         [
+           [ barecode m13ed_val_list ($_, 'Name') ],
+           [ $_->get_attribute ('Mail', make_new_node => 1)->value ],
+           [ $_->get_attribute ('URI', make_new_node => 1)->value ],
+         ]
+ } grep { $_->local_name eq 'Author' } @{$meta->child_nodes}
+ ). qq{];\n};
+ for (@{$meta->get_attribute ('Namespace', make_new_node => 1)->child_nodes}) {
+   $Info{Namespace}->{$_->local_name} = $_->value;
+ }
+ my $use = $meta->get_attribute ('Use');
+ if (ref $use) {
+   print change_package \%Info, $Info{module_name};
+   print line \%Info, node_path => 'Plugin/Use';
+   print code \%Info, $use->inner_text;
+   print line \%Info, reset => 1;
+ }
  for (@{$plugins->child_nodes}) {
-   if ($_->local_name eq 'ViewDefinition') {
+   if ($_->local_name eq 'FormattingRule') {
+     print "\n", make_rule ($_, \%Info);
+   } elsif ($_->local_name eq 'ViewDefinition') {
      print "\n", make_viewdef ($_, \%Info);
    } elsif ($_->local_name eq 'ViewFragment') {
      print "\n", make_viewfragment ($_, \%Info);
+   } elsif ($_->local_name eq 'Function') {
+     print "\n", make_function ($_, \%Info);
+   } elsif ($_->local_name eq 'Resource') {
+     print "\n", make_resdef ($_, \%Info);
+   } elsif ($_->local_name eq 'PluginConst') {
+     register_plugin_const ($_, \%Info);
+   } elsif ($_->local_name eq 'Format') {
+     print "\n", make_format ($_, \%Info);
+   } elsif ($_->local_name eq 'FormattingRuleAlias') {
+     print "\n", make_rule_alias ($_, \%Info);
+ # Parameter
+ # PluginCategory
    }
  }
+ print change_package \%Info, q(SuikaWiki::Plugin::Registry);
+ print qq{\$Info{$Info{name_literal}}->{provide} = } . literal $Info{provide};
+ print qq{;\n};
  print "\n1;\n";
  exit;
+ }
+ sub make_format ($$) {
+   my ($src, $Info) = @_;
+   my $module_name = 'SuikaWiki::Format::Definition::'.$src->get_attribute_value ('ModuleName');
+   my $r = change_package $Info, $module_name;
+   local $Info->{-message_error_used} = 0;
+   $r .= qq{our \@ISA;\n};
+   if (my $isa = $src->get_attribute_value ('Inherit')) {
+     for (@$isa) {
+       $r .= qq{push \@ISA, @{[literal 'SuikaWiki::Format::Definition::'.$_]};\n};
+     }
+   } else {
+     $r .= qq{push \@ISA, 'SuikaWiki::Format::Definition::template';\n};
+   }
+   if (my $name = $src->get_attribute_value ('Name')) {
+     $r .= qq{\$SuikaWiki::Format::Definition::Class{@{[literal 'MAGIC:'.$name.'/'.$src->get_attribute_value ('Version', default => '').'##']}} = '$module_name';\n};
+   }
+   if (my $type = $src->get_attribute_value ('Type')) {
+     $type .= join '', map {
+                ';'. $_->local_name .'='. quoted_string $_->inner_text
+              } sort {
+                $a->local_name cmp $b->local_name
+              } @{$src->get_attribute ('Type')->child_nodes};
+     $r .= qq{\$SuikaWiki::Format::Definition::Class{@{[literal 'IMT:'.$type.'##']}} = '$module_name';\n};
+   }
+   my $convert = line $Info, line_no => __LINE__ + 2, realfile => __FILE__;
+   $convert .= <<'EOH';
+ our $Converter;
+ sub convert ($$;%) {
+   my ($self, $source, %opt) = @_;
+   my $t = SuikaWiki::Format::Definition->serialize_media_type (%opt);
+   my $converter = $Converter->{$t->{_}};
+   return ($converter->{$opt{return_type} or 'Main'} or
+           CORE::die "Buggy implementation: $t->{_}/@{[$opt{return_type} or 'Main']} not defined")
+          ->($self, $source, \%opt)
+     if $converter;
+   $self->SUPER::convert ($source, %opt);
+ }
+ EOH
+   for (@{$src->child_nodes}) {
+     if ($_->local_name eq 'Converter') {
+       if ($convert) {
+         $r .= $convert;
+         $r .= line $Info, reset => 1;
+         undef $convert;
+       }
+       $r .= make_format_converter ($_, $Info);
+     } elsif ($_->local_name eq 'WikiForm') {
+       $r .= q(sub wikiform {)."\n".q(my ($self, $source, %opt) = @_;);
+       $r .= line $Info, node_path => qq(Format[module-name()=$module_name]/WikiForm);
+       $r .= code $Info, $_->get_attribute_value ('Main');
+       $r .= line $Info, reset => 1;
+       $r .= qq(}\n);
+     } elsif ($_->local_name eq 'HeadSummary') {
+       $r .= q(sub headsummary {)."\n".q(my ($self, $source, %opt) = @_;);
+       $r .= line $Info, node_path => qq(Format[module-name()=$module_name]/HeadSummary);
+       $r .= code $Info, $_->get_attribute_value ('Main');
+       $r .= line $Info, reset => 1;
+       $r .= qq(}\n);
+     } elsif ($_->local_name eq 'NextIndex') {
+       my $name = $_->get_attribute_value ('Name', default => '');
+       $r .= q(sub next_index_for_).$name
+          .  q( {)."\n".q(my ($self, $source, %opt) = @_;)
+          .  line $Info, node_path => qq(Format[module-name()=$module_name]/NextIndex[Name=$name]);
+       $r .= code $Info, $_->get_attribute_value ('Main');
+       $r .= line $Info, reset => 1;
+       $r .= qq(}\n);
+     } elsif ($_->local_name eq 'Use') {
+       $r .= line $Info, node_path => qq(Format[module-name()=$module_name]/Use);
+       $r .= code $Info, $_->inner_text;
+     }
+   }
+   $r;
+ }
+ sub make_format_converter ($$) {
+   my ($src, $Info) = @_;
+   my %def;
+   for (qw/Type Name Version TypeURIReference IsFragment IsPlaceholder/) {
+     $def{$_} = $src->get_attribute_value ($_);
+     delete $def{$_} unless defined $def{$_};
+   }
+   $def{Type_param} = {map {$_->local_name => $_->value}
+                               @{$src->get_attribute ('Type', make_new_node => 1)
+                                   ->child_nodes}};
+   my $type = serialize_media_type ($Info,
+                Type => $def{Type},
+                Type_param => $def{Type_param},
+                Name => $def{Name},
+                Version => $def{Version},
+                URIReference => $def{TypeURIReference},
+                IsFragment => $def{IsFragment},
+                IsPlaceholder => $def{IsPlaceholder});
+   $def{serialized_type} = $type->{_};
+   for (qw/Main ToString ToOctetStream/) {
+     my $def = $src->get_attribute_value ($_);
+     next unless $def;
+     $def{$_} = line ($Info, node_path => '//Converter/'.$_)
+                . $def
+                . line ($Info, reset => 1);
+     if ($def{$_} =~ /\$r\b/) {
+       $def{$_} = 'my $r;'."\n".$def{$_}."\n".'$r';
+     }
+     $def{$_} = barecode code $Info,
+                  'sub {my ($self, $source, $opt) = @_;'
+                . $def{$_} . '}';
+   }
+   my $r = list %def;
+   if ($type->{Type}) {
+     $r = qq{\$Converter->{@{[literal $type->{Type}]}} = {$r};\n};
+     $r .= qq{\$Converter->{@{[literal $type->{Magic}]}} = \$Converter->{@{[literal $type->{Type}]}};\n}
+       if $type->{Magic};
+     $r .= qq{\$Converter->{@{[literal $type->{URIReference}]}} = \$Converter->{@{[literal $type->{Type}]}};\n}
+       if $type->{URIReference};
+   } elsif ($type->{Magic}) {
+     $r = qq{\$Converter->{@{[literal $type->{Magic}]}} = {$r};\n};
+     $r .= qq{\$Converter->{@{[literal $type->{URIReference}]}} = \$Converter->{@{[literal $type->{Magic}]}};\n}
+       if $type->{URIReference};
+   } elsif ($type->{URIReference}) {
+     $r = qq{\$Converter->{@{[literal $type->{URIReference}]}} = {$r};\n};
+   } else {
+     $r = 'BEGIN { die "Invalid Syntax of Converter: Type or Name or TypeURIReference property required" }';
+   }
+   $r;
+ }
+ sub serialize_media_type ($%) {
+   my ($Info, %opt) = @_;
+   my %return;
+   if ($opt{Type}) {
+     $return{Type} = 'IMT:'.$opt{Type};
+     if ($opt{Type_param}) {
+       $return{Type} .= join '', map {my $s;
+                          ';'. $_ .'="'
+                        . (($s = $opt{Type_param}->{$_}) =~ s/([\\"])/\\$1/g, $s)
+                        . '"'
+                        } sort {
+                          $a cmp $b
+                        } keys %{$opt{Type_param}};
+     }
+   }
+   if ($opt{Magic}) {
+     $return{Magic} = 'MAGIC:'.$opt{Magic};
+   } elsif ($opt{Name}) {
+     $return{Name} = 'MAGIC:'.$opt{Name}.'/*';
+     $return{Magic} = 'MAGIC:'.$opt{Name}.'/'.$opt{Version} if $opt{Version};
+   }
+   if ($opt{URIReference}) {
+     $return{URIReference} = $opt{URIReference};
+   }
+   my $flag = '##';
+   $flag .= 'f' if $opt{IsFragment};
+   $flag .= 'p' if $opt{IsPlaceholder};
+   for (qw/URIReference Type Magic Name/) {
+     $return{$_} .= $flag if $return{$_};
+   }
+   $return{_} = $return{URIReference} || $return{Type}
+             || $return{Magic} || $return{Name};
+   \%return;
+ }
+ sub make_function ($$) {
+   my ($src, $Info) = @_;
+   ## TODO: support of ARGV property
+   my $name;
+   my $r = <<EOH;
+ @{[change_package $Info, $Info->{module_name}]}
+ sub @{[$name = $src->get_attribute_value ('Name')]} {
+ @{[line $Info, node_path => "Function[Name='$name']/Main"]}@{[
+   code $Info, $src->get_attribute_value ('Main')
+ ]}
+ }
+ @{[line $Info, reset => 1]}
+ EOH
+ }
+ sub register_plugin_const ($$) {
+   my ($src, $Info) = @_;
+   for (@{$src->child_nodes}) {
+     $Info->{const}->{$_->local_name} = literal_or_code $Info, $_->value;
+   }
+ }
+ sub make_resdef ($$) {
+   my ($src, $Info) = @_;
+   my $r = change_package $Info, 'SuikaWiki::Plugin::Resource';
+   local $Info->{-message_error_used} = 0;
+   $r .= qq{our \$BaseResource;\n};
+   for (@{$src->child_nodes}) {
+     if ($_->node_type eq '#element') {
+       my $lang = literal ($_->get_attribute_value ('lang') || 'und');
+       my $script = literal $_->get_attribute_value ('script');
+       my $name = literal $_->local_name;
+       my $val = literal n11n $_->value;
+       $r .= qq{\$BaseResource->{$lang}->{$script}->{$name} = $val;\n};
+     }
+   }
+   $r;
+ }
  sub make_viewfragment ($$) {
    my ($src, $Info) = @_;
    my $r = '';
-   for (@{$src->child_nodes}) {
+   my $body = <<EOH;
-     ## TODO: use SuikaWiki2 interface
+   {
-     $r .= qq(SuikaWiki::View->template (@{[literal $_->local_name]})->add_line (@{[literal $_->value]});\n);
+     Main => @{[literal $src->get_attribute_value ('Formatting')]},
+     Order => @{[0+$src->get_attribute_value ('Order')]},
+     Description => [@{[m13ed_val_list $src, 'Description']}],
+   };
+ EOH
+   ## Recommended format
+   my $name = $src->get_attribute_value ('Template');
+   if (ref ($name) and @$name > 1) {
+     $r .= qq({my \$def = $body;\n);
+     for (@$name) {
+       my $name = $_; $name =~ tr/-/_/;
+       $r .= qq(push \@{\$SuikaWiki::View::Implementation::TemplateFragment{@{[literal $name]}}}, \$def;\n);
+       push @{$Info->{provide}->{viewfragment}}, {Name => $name};
+     }
+     $r .= qq(}\n);
+   } else {                           ## Obsoleted format
+     $name = ref $name ? $name->[0] : $src->get_attribute_value ('Name');
+     $name =~ tr/-/_/;
+     $r .= qq(push \@{\$SuikaWiki::View::Implementation::TemplateFragment{@{[literal $name]}}}, $body);
+     push @{$Info->{provide}->{viewfragment}}, {Name => $name};
    }
    $r;
  }
-Line 80 
 sub make_viewdef ($$) {
+Line 451 
 sub make_viewdef ($$) {
    my ($src, $Info) = @_;
    my $ViewProp = {};
    my $r = '';
-   $ViewProp->{Name} = n11n $src->get_attribute ('Mode')->value;
+   $ViewProp->{Name} = n11n $src->get_attribute_value ('Mode');
+   $ViewProp->{Name} =~ s/(?<=.)-/_/g;
    $ViewProp->{pack_name} = random_module_name ($Info, $ViewProp->{Name});
-   $ViewProp->{condition_stringified} = join ', ', map {literal $_}
+   $ViewProp->{condition_stringified} = hash
      mode => $ViewProp->{Name},
      map {($_->local_name => $_->value)}
        @{$src->get_attribute ('Condition',make_new_node=>1)->child_nodes};
-Line 93 
 push \@SuikaWiki::View::Implementation::
+Line 465 
 push \@SuikaWiki::View::Implementation::
    condition => {$ViewProp->{condition_stringified}},
    object_class => q#$ViewProp->{pack_name}#,
  };
- package $ViewProp->{pack_name};
+ @{[change_package $Info, $ViewProp->{pack_name}]}
  our \@ISA = q#SuikaWiki::View::template#;
  EOH
+   local $Info->{-message_error_used} = 0;
+   my $use = $src->get_attribute ('Use');
+   if (ref $use) {
+     $r .= line $Info, node_path => "ViewDefinition[Mode='$ViewProp->{Name}']/Use";
+     $r .= code $Info, $use->inner_text;
+     $r .= "\n\n";
+   }
    for (@{$src->child_nodes}) {
-     if ($_->local_name eq 'method') {
+     if ($_->local_name eq 'template') {
+       $r .= make_view_template_method ($_, $Info, $ViewProp);
+     } elsif ($_->local_name eq 'method') {
+       my $method_name = $_->get_attribute_value ('Name');
        $r .= ({
-               main => q(sub main ($$) {)."\n".q(my ($self, $opt) = @_;)."\n",
+               main => q(sub main ($$) {)."\n".q(my ($self, $opt, $opt2) = @_;)."\n",
                main_pre => q(sub main_pre ($$$) {)."\n".q(my ($self, $opt, $opt2) = @_;)."\n",
                main_post => q(sub main_post ($$$) {)."\n".q(my ($self, $opt, $opt2) = @_;)."\n",
-              }->{$_->get_attribute ('Name')->value}
+              }->{$method_name}
-              ||qq(sub @{[$_->get_attribute ('Name')->value]} {\n))
+              ||qq(sub @{[$method_name]} {\n))
-          . $_->inner_text
+          . line ($Info, node_path => "ViewDefinition[Mode='$ViewProp->{Name}']/method[Name='$method_name']")
-          . qq(\n}\n);
+          . code ($Info, $_->value)
+          . qq(}\n)
+          . line ($Info, reset => 1);
+     }
+   }
+   my $prop = {Name => $ViewProp->{Name},
+               Description => barecode m13ed_val_list $_, 'Description'};
+   push @{$Info->{provide}->{viewdef}}, $prop;
+   $r;
+ }
+ sub make_view_template_method ($$) {
+   my ($src, $Info, $ViewProp) = @_;
+   my $r = <<EOH;
+ sub main (\$\$\$) {
+   my (\$self, \$opt, \$opt2) = \@_;
+   require SuikaWiki::Output::HTTP;
+   \$opt2->{output} = SuikaWiki::Output::HTTP->new
+     (wiki => \$self->{view}->{wiki},
+      view => \$self->{view}, viewobj => \$self);
+   for (\@{\$self->{view}->{wiki}->{var}->{client}->{used_for_negotiate}},
+        'Accept-Language') {
+     \$opt2->{output}->add_negotiate_header_field (\$_);
+   }
+   \$opt2->{template} = @{[literal $src->get_attribute ('body', make_new_node => 1)->inner_text]};
+   \$opt2->{o} = bless {
+                       ## SuikaWiki 3 WikiPlugin interface
+                         wiki => \$self->{view}->{wiki},
+                         plugin => \$self->{view}->{wiki}->{plugin},
+                         var => {},
+                       }, 'SuikaWiki::Plugin';
+   @{[do{my $x=$src->get_attribute('http-status-code',make_new_node=>1)->inner_text;
+      $x?q{$opt2->{output}->{status_code} = }.(0 + $x).q{;}:q{}}]}
+   @{[do{my $x=$src->get_attribute('http-status-phrase',make_new_node=>1)->inner_text;
+      $x?q{$opt2->{output}->{status_phrase} = }.literal($x).q{;}:q{}}]}
+   \$opt2->{output}->{entity}->{media_type} = @{[literal
+                            $src->get_attribute ('media-type',make_new_node=>1)
+                                ->inner_text || 'application/octet-stream']};
+   @{[($src->get_attribute ('use-media-type-charset',make_new_node=>1)
+             ->inner_text || 0) ?
+      q{$opt2->{output}->{entity}->{charset} = $self->{view}->{wiki}->{config}->{charset}->{output};}:
+      q{}]}
+   @{[do{my $x = $src->get_attribute ('expires',make_new_node=>1)->inner_text;
+           if ($x =~ /%%(\w+)%%/) {
+             qq{\$opt2->{output}->set_expires (%{\$self->{view}->{wiki}->{config}->{entity}->{expires}->{@{[literal $1]}}});};
+           } else {
+             qq{\$opt2->{output}->set_expires (delta => @{[0 + $x]});};
+           }
+       }]}
+   \$opt2->{output}->{entity}->{body_is_octet_stream} = @{[
+     $src->get_attribute ('body')->get_attribute_value ('is-octet-stream', default_value => 0)
+     or 0
+   ]};
+   \$self->{view}->{wiki}->init_db;
+   \$self->main_pre (\$opt, \$opt2);
+   use Message::Util::Error;
+   try {
+     \$opt2->{output}->{entity}->{body}
+       = SuikaWiki::Plugin->formatter ('view')
+         ->replace (\$opt2->{template}, param => \$opt2->{o});
+   } \$self->{view}->{wiki}->{config}->{catch}->{ @{[
+        $ViewProp->{Name} eq '-error' ? 'formatter_view_error'
+                                      : 'formatter_view' ]} };
+   \$opt2->{output}->output (output => 'http-cgi');
+   \$self->main_post (\$opt, \$opt2);
+ }
+ EOH
+ }
+ sub make_rule ($$) {
+   my ($src, $Info) = @_;
+   my $type = $src->get_attribute ('Category', make_new_node => 1)->value || [];
+   my $name = $src->get_attribute ('Name', make_new_node => 1)->value;
+   $name =~ s/(?<=.)-/_/g;
+   my $reg_block;
+   $reg_block = qr/[^{}]*(?>[^{}]+|{(??{$reg_block})})*/;
+   my %code;
+   for my $codename ([qw/Formatting main/], [qw/After after/],
+                     [qw/Before before/], [qw/Pre pre/], [qw/Post post/],
+                     [qw/Attribute attr/]) {
+     my $main = code $Info, $src->get_attribute_value ($codename->[0]);
+     next unless $main;
+     $main = line ($Info, node_path =>
+               "FormattingRule[name()='@{[list $type]}/$name']/".$codename->[0])
+           . $main;
+     if ( $main =~ /\$f\b/
+       or $main =~ /\$rule_name\b/
+       or $main =~ /\$[opr]\b/
+       or $main =~ /[%\$]opt\b/
+       or $main =~ /\$param_(?:name|value)\n/) {
+       if ($codename->[0] ne 'Attribute') {
+         $main = q{my ($f, $rule_name, $p, $o, %opt) = @_;}."\n".$main;
+       } else {
+         $main = q{my ($f, $rule_name, $p, $o, $param_name => $param_value, %opt) = @_;}."\n".$main;
+       }
+     }
+     if ($main =~ /\$r\b/) {
+       warn qq(Rule @{[list $type]}/$name: Use of \$r is deprecated);
+       $main = q{my $r = '';} . "\n" . $main . "\n"
+             . q{$p->{-parent}->append_node ($r, node_or_text => 1);};
+     }
+     $main =~ s{__ATTR(TEXT|NODE)?:%(\w+|{$reg_block})(?:->{($reg_block)})?__;}
+               {($1 eq 'TEXT' ? '$p->{'.literal_or_code($Info, $2)
+                                       .'} = do { my $r = ' : '')
+                .'$f->parse_attr ($p=>'.literal_or_code($Info, $2).', $o, '
+                                .($3?'-parent => '.$3.', ':'')
+                                .($1?'-non_parsed_to_node => 1, ':'')
+                                .'%opt)'
+                                .($1 eq 'TEXT' ? '; ref $r?$r->inner_text:$r}'
+                                               : '')
+                                .';'}ge;
+     $code{$codename->[1]} = barecode "sub {$main}";
+   }
+   my $main = literal {
+     Description => [barecode m13ed_val_list $src, 'Description'],
+     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']};
+         }
+       }
+       @r;
+     }},
+     %code,
+   };
+   $main .= line $Info, reset => 1;
+ my  $amain = <<EOH;
+ {
+   main => sub {$main},
+ @{[line ($Info, reset => 1)]}
+   Description => [@{[m13ed_val_list $src, 'Description']}],
+   Parameter => {@{[do{
+   }]}},
+ }
+ EOH
+   my $r = change_package $Info, $Info->{module_name};
+   local $Info->{-message_error_used} = 0;
+   if (@$type == 1) {
+     $type->[0] =~ tr/-/_/;
+     $r .= qq{\$SuikaWiki::Plugin::Rule{$type->[0]}->{$name} = $main;\n};
+     push @{$Info->{provide}->{rule}->{$type->[0]}}, $name;
+   } else {
+     $r .= qq({my \$def = $main;\n);
+     for my $type (@$type) {
+       $type =~ tr/-/_/;
+       $r .= qq{\$SuikaWiki::Plugin::Rule{$type}->{$name} = \$def;\n};
+       push @{$Info->{provide}->{rule}->{$type}}, $name;
      }
+     $r .= qq(};\n);
+   }
+   $r;
+ }
+ =item FormattingRuleAlias
+ Generating an alias name for a formatting rule that is already loaded.
+ Example:
+   FormattingRuleAlias:
+     @Category[list]:
+       category-1
+       category-2
+       ...
+     @Name: new-rule-name
+     @Reference:
+       @@Category: one-of-category
+       @@Name: one-of-name
+ associates C<(I<category-1>, I<new-rule-name>)>,
+ C<(I<category-2>, I<new-rule-name>)>, ...
+ with C<(I<one-of-category>, I<one-of-name>)>.
+ =cut
+ sub make_rule_alias ($$) {
+   my ($src, $Info) = @_;
+   my $type = $src->get_attribute ('Category', make_new_node => 1)->value || [];
+   my $name = $src->get_attribute ('Name', make_new_node => 1)->value;
+   my $ref = $src->get_attribute ('Reference', make_new_node => 1);
+   my $c = $ref->get_attribute_value ('Category');
+   my $n = $ref->get_attribute_value ('Name');
+   s/(?<=.)-/_/g for $n, $name;
+   tr/-/_/ for $c, @$type;
+   my $def = qq{\$SuikaWiki::Plugin::Rule{@{[literal $c]}}->{@{[literal $n]}} or warn qq{Formatting rule "$c/$n" not defined}};
+   my $r = change_package $Info, $Info->{module_name};
+   for my $type (@$type) {
+     $r .= qq{\$SuikaWiki::Plugin::Rule{@{[literal $type]}}->{@{[literal $name]}} = $def;\n};
+     push @{$Info->{provide}->{rule}->{$type}}, $name;
    }
    $r;
  }
-Line 117 
 sub random_module_name ($;$) {
+Line 704 
 sub random_module_name ($;$) {
    $subname =~ s/[^0-9A-Za-z_:]//g;
    my @date = gmtime;
    my @rand = ('A'..'Z','a'..'z',0..9,'_');
-   sprintf '%s::%s%s%s', $Info{module_name}, $subname,
+   sprintf '%s::%s%s%s', $Info->{module_name}, $subname,
      sprintf ('%02d%02d%02d%02d%02d%02d', @date[5,4,3,2,1,0]),
      join ('', @rand[rand@rand,rand@rand,rand@rand,rand@rand]);
  }
+ =head1 NAME
+ mkplugin2.pl - SuikaWiki: WikiPlugin Generator
+ =head1 SYNOPSIS
+   mkplugin2.pl pluginsrc.wp2 > plugin.pm
+ =head1 DESCRIPTION
+ C<mkplugin2.pl> generates WikiPlugin module as a Perl module file
+ from WikiPlugin source description.  WikiPlugin source description
+ is described in SuikaWikiConfig/2.0 format and it contains
+ definitions of wiki constructions (such as formatting rules and
+ WikiView definitions) as both machine understandable code and
+ human readable documentation.  For more information, see
+ <http://suika.fam.cx/~wakaba/-temp/wiki/wiki?WikiPlugin>.
+ This script is part of SuikaWiki.
+ =head1 HISTORY AND COMPATIBILITY
+ C<mkplugin2.pl> introduced as part of SuikaWiki 3.
+ It converts SuikaWiki 3 WikiPlugin source descriptions
+ (in SuikaWikiConfig/2.0) into Perl modules with SuikaWiki 3 interface.
+ SuikaWiki 2 has C<mkplugin.pl>.  It also converts WikiPlugin
+ source descriptions into Perl modules.  But it support
+ SuikaWiki 2 format of WikiPlugin source description that differs from
+ SuikaWiki 3 format.  Wiki programming interface (not limited to
+ WikiPlugin related one) of SuikaWiki 3 also incompatible with that
+ of SuikaWiki 2 so that it is impossible to use SuikaWiki 2 WikiPlugin
+ module with SuikaWiki 3 and vice versa.
+ =head1 SEE ALSO
+ C<SuikaWiki::Plugin>, SuikaWiki:WikiPlugin
+ <http://suika.fam.cx/~wakaba/-temp/wiki/wiki?WikiPlugin>.
+ =head1 LICENSE
+ Copyright 2003-2004 Wakaba <w@suika.fam.cx>.  All rights reserved.
+ This program is free software; you can redistribute it and/or
+ modify it under the same terms as Perl itself.
+ =cut
+; # $Date$

 Legend:



Removed from v.1.1
 


changed lines


 
Added in v.1.17
 Legend:



Removed from v.1.1
 


changed lines


 
Added in v.1.17
-Removed from v.1.1
+Added in v.1.17

admin@suikawiki.org	ViewVC Help
Powered by ViewVC 1.1.24