#!/usr/bin/perl
use strict;
our $VERSION = do{my @r=(q$Revision: 1.4 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
require SuikaWiki::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/literal $Info->{const}->{$_}/ge;
  }
  $code =~ s/__FUNCPACK__/$Info->{module_name}/g;
  $code;
}

my $parser = SuikaWiki::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{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;
our \%Info;
\$Info{$Info{name_literal}}->{Name} = $Info{name_literal};
EOH
for (qw/Version InterfaceVersion mkpluginVersion/) {
  print qq{\$Info{$Info{name_literal}}->{$_} = v$Info{$_};\n};
}
for (qw/LastModified/) {
  $Info{$_} = n11n $meta->get_attribute ($_,make_new_node=>1)->value;
  next unless length $Info{$_};
  print qq{\$Info{$Info{name_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 (@{$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);
  }
}

print qq{\npackage SuikaWiki::Plugin::Registry;\n\n};
print qq{\$Info{$Info{name_literal}}->{provide} = } . literal $Info{provide};
print qq{;\n};

print "\n1;\n";
exit;
}

sub make_function ($$) {
  my ($src, $Info) = @_;
  ## TODO: support of ARGV property
  my $r = <<EOH;
package $Info->{module_name};
sub @{[$src->get_attribute_value ('Name')]} {
  @{[code $Info, $src->get_attribute_value ('Main')]}
}
EOH
}

sub register_plugin_const ($$) {
  my ($src, $Info) = @_;
  for (@{$src->child_nodes}) {
    $Info->{const}->{$_->local_name} = $_->value;
  }
}

sub make_resdef ($$) {
  my ($src, $Info) = @_;
  my $r = qq{package SuikaWiki::Plugin::Resource;\nour \$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 ('Mode')->value;
  $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}#,
};
package $ViewProp->{pack_name};
our \@ISA = q#SuikaWiki::View::template#;
EOH
  for (@{$src->child_nodes}) {
    if ($_->local_name eq 'template') {
      $r .= make_view_template_method ($_, $Info);
    } elsif ($_->local_name eq 'method') {
      $r .= ({
              main => q(sub main ($$) {)."\n".q(my ($self, $opt) = @_;)."\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}
             ||qq(sub @{[$_->get_attribute ('Name')->value]} {\n))
         . code ($Info, $_->value)
         . qq(\n}\n);
    }
  }
  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) = @_;
  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 {
                     ## 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)
    ]}},
                      ## 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}->{reason_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]});};
          }
      }]}
  
  \$self->{view}->{wiki}->init_db;
  \$self->main_pre (\$opt, \$opt2);
  
  ## TODO: formal SuikaWiki 3 interface
  my \$fmt = SuikaWiki::Plugin->formatter ('view');
  \$opt2->{output}->{entity}->{body} 
    = \$fmt->replace (\$opt2->{template} => \$opt2->{o},
                      {formatter => \$fmt});
  \$opt2->{output}->output (output => 'http-cgi');
  
  \$self->main_post (\$opt, \$opt2);
}
EOH
}

## TODO: Implements SuikaWiki 3 interface
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 $main = code $Info, $src->get_attribute_value ('Formatting');
  $main = q{my ($p, $o) = @_;}."\n" . $main 
    if $main =~ /\$p/ || $main =~ /\$o/;
  if ($main =~ /\$r/) {
    $main = q{my $r = '';} . "\n" . $main;
    $main .= q{$r};
  }
  
  my $main = <<EOH;
{
  Formatting => sub {$main},
  Description => [@{[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']};
      }
    }
    list @r;
  }]}},
}
EOH
  my $r;
  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;
}


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]);
}