#!/usr/bin/perl use strict; our $VERSION = do{my @r=(q$Revision: 1.10 $=~/\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 = ; } 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 . $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; } 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 <{Name} = $Info{name_literal}; EOH for (qw/Version InterfaceVersion mkpluginVersion module_name/) { print qq{\$Info{$Info{name_literal}}->{$_} = @{[literal $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}; my $use = $meta->get_attribute ('Use'); if (ref $use) { print change_package \%Info, $Info{module_name}; print line \%Info, node_path => 'Plugin/Use'; print $use->inner_text, "\n"; 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); # 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; $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 '/'.$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 $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 $converter; my $flag = '//'; $flag .= 'f' if $opt{IsFragment}; $flag .= 'p' if $opt{IsPlaceholder}; if ($Converter->{$opt{Type}.$flag}) { $converter = $Converter->{$opt{Type}.$flag}; } elsif ($Converter->{$opt{Name}.'/'.$opt{Version}.$flag}) { $converter = $Converter->{'/'.$opt{Name}.'/'.$opt{Version}.$flag}; } return $converter->{Main}->($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 '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 .= $_->inner_text; } } $r; } sub make_format_converter ($$) { my ($src, $Info) = @_; my %def; $def{Type} = $src->get_attribute ('Type'); if (ref $def{Type}) { $def{Type} = $def{Type}->inner_text . join '', map { ';'. $_->local_name .'='. quoted_string $_->inner_text } sort { $a->local_name cmp $b->local_name } @{$def{Type}->child_nodes}; } else { delete $def{Type}; } $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} = line ($Info, node_path => '//Converter/Main') . $def{Main} . line ($Info, reset => 1); if ($def{Main} =~ /\$r\b/) { $def{Main} = 'my $r;'."\n".$def{Main}."\n".'$r'; } $def{Main} = barecode code $Info, 'sub {my ($self, $source, $opt) = @_;' . $def{Main} . '}'; my $r = list %def; if ($def{Type}) { $r = qq{\$Converter->{@{[literal $def{Type}.$flag]}} = {$r};\n}; $r .= qq{\$Converter->{@{[literal '/'.$def{Name}.'/'.$def{Version}.$flag]}} = \$Converter->{@{[literal $def{Type}.$flag]}};\n} if $def{Name}; } elsif ($def{Name}) { $r = qq{\$Converter->{@{[literal '/'.$def{Name}.'/'.$def{Version}.$flag]}} = {$r};\n}; } else { $r = 'BEGIN { die "Invalid Syntax of Converter: Type or Name property required" }'; } $r; } sub make_function ($$) { my ($src, $Info) = @_; ## TODO: support of ARGV property my $name; my $r = <{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} = $_->value; } } sub make_resdef ($$) { my ($src, $Info) = @_; my $r = change_package $Info, 'SuikaWiki::Plugin::Resource'; $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 = < @{[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 .= < {$ViewProp->{condition_stringified}}, object_class => q#$ViewProp->{pack_name}#, }; @{[change_package $Info, $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, $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 $r = <{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}->{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]});}; } }]} \$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; $main = q{my ($f, $rule_name, $p, $o, %opt) = @_;}."\n".$main if $main =~ /\$f\b/ or $main =~ /\$rule_name\b/ or $main =~ /\$[opr]\b/ or $main =~ /[%\$]opt\b/; 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 = < sub {$main}, @{[line ($Info, reset => 1)]} Description => [@{[m13ed_val_list $src, 'Description']}], Parameter => {@{[do{ }]}}, } EOH my $r = change_package $Info, $Info->{module_name}; 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]); }