script/bin/mkplugin2.pl

#!/usr/bin/perl
use strict;
our $VERSION = do{my @r=(q$Revision: 1.17 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
require Message::Markup::SuikaWikiConfig20::Parser;

{
my $src = '';
my $srcfile = shift;
open SRC, $srcfile or die "$0: $!"; {
  local $/ = undef;
  $src = <SRC>;
} close SRC;

sub literal ($) {
  my $s = shift;
  if (ref ($s) eq 'ARRAY') {
    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 = 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 = (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;
@{[change_package \%Info, 'SuikaWiki::Plugin::Registry']}
our \%Info;
\$Info{$Info{name_literal}}->{Name} = $Info{name_literal};
EOH
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 $_]}} = } . literal $Info{$_};
  print ";\n";
}
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 '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 ({qw/content_written 1 content_removed 1 content_type_changed_from 1/}
             ->{my $node_name = $_->local_name}) {
      $r .= q(sub ).$node_name
         .  q( {)."\n".q(my ($self, %opt) = @_;)
         .  line $Info, node_path => qq(Format[module-name()=$module_name]/$node_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 = '';
  my $body = <<EOH;
  {
    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;
}

sub make_viewdef ($$) {
  my ($src, $Info) = @_;
  my $ViewProp = {};
  my $r = '';
  $ViewProp->{Name} = n11n $src->get_attribute_value ('Mode');
  $ViewProp->{Name} =~ s/(?<=.)-/_/g;
  $ViewProp->{pack_name} = random_module_name ($Info, $ViewProp->{Name});
  
  $ViewProp->{condition_stringified} = hash
    mode => $ViewProp->{Name}, 
    map {($_->local_name => $_->value)}
      @{$src->get_attribute ('Condition',make_new_node=>1)->child_nodes};
  
  $r .= <<EOH;
push \@SuikaWiki::View::Implementation::CommonViewDefs, {
  condition => {$ViewProp->{condition_stringified}},
  object_class => q#$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 '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, $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",                     
             }->{$method_name}
             ||qq(sub @{[$method_name]} {\n))
         . line ($Info, node_path => "ViewDefinition[Mode='$ViewProp->{Name}']/method[Name='$method_name']")
         . 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 $media_type = $src->get_attribute_value 
                            ('media-type',
                             default => q<application/octet-stream>);
  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 $media_type]};

  @{[($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);
  
  @{[$media_type eq 'text/html' ? q{require Message::Markup::XML::Serialize::HTML;} : '']}
  use Message::Util::Error;
  try {
    \$opt2->{output}->{entity}->{body} 
      = @{[$media_type eq 'text/html' ? q{Message::Markup::XML::Serialize::HTML::html_simple} : '']}
        (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;
}


sub random_module_name ($;$) {
  my ($Info, $subname) = @_;
  $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 ('%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

1; # $Date: 2004/05/01 03:55:05 $