1 |
wakaba |
1.1 |
#!/usr/bin/perl |
2 |
|
|
use strict; |
3 |
wakaba |
1.2 |
our $VERSION = do{my @r=(q$Revision: 1.1 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r}; |
4 |
wakaba |
1.1 |
require SuikaWiki::Markup::SuikaWikiConfig20::Parser; |
5 |
|
|
|
6 |
wakaba |
1.2 |
{ |
7 |
wakaba |
1.1 |
my $src = ''; |
8 |
|
|
my $srcfile = shift; |
9 |
|
|
open SRC, $srcfile or die "$0: $!"; { |
10 |
|
|
local $/ = undef; |
11 |
|
|
$src = <SRC>; |
12 |
|
|
} close SRC; |
13 |
|
|
|
14 |
|
|
sub literal ($) { |
15 |
|
|
my $s = shift; |
16 |
wakaba |
1.2 |
if (ref ($s) eq 'ARRAY') { |
17 |
|
|
q<[> . list (@$s) . q<]>; |
18 |
|
|
} elsif (ref ($s) eq 'HASH') { |
19 |
|
|
q<{> . hash (%$s) . q<}>; |
20 |
|
|
} elsif (ref ($s) eq 'bare') { |
21 |
|
|
$$s; |
22 |
|
|
} else { |
23 |
|
|
$s =~ s/([#\\])/\\$1/g; |
24 |
|
|
q<q#> . $s . q<#>; |
25 |
|
|
} |
26 |
|
|
} |
27 |
|
|
sub list (@) { |
28 |
|
|
join ', ', map {literal $_} @_; |
29 |
|
|
} |
30 |
|
|
sub hash (%) { |
31 |
|
|
my $i = 0; |
32 |
|
|
list map {($i++ % 2) ? $_ : do {my $s = $_; $s =~ s/(?<=.)-/_/; $s}} @_; |
33 |
wakaba |
1.1 |
} |
34 |
|
|
sub n11n ($) { |
35 |
|
|
my $s = shift; |
36 |
|
|
$s =~ s/\s+/ /g; |
37 |
|
|
$s; |
38 |
|
|
} |
39 |
wakaba |
1.2 |
sub m13ed_val_list ($$) { |
40 |
|
|
my ($src, $key) = @_; |
41 |
|
|
my @r; |
42 |
|
|
for (@{$src->child_nodes}) { |
43 |
|
|
if ($_->local_name eq $key) { |
44 |
|
|
push @r, [scalar $_->inner_text, |
45 |
|
|
scalar $_->get_attribute ('lang', make_new_node => 1) |
46 |
|
|
->inner_text, |
47 |
|
|
scalar $_->get_attribute ('script', make_new_node => 1) |
48 |
|
|
->inner_text]; |
49 |
|
|
} |
50 |
|
|
} |
51 |
|
|
list @r; |
52 |
|
|
} |
53 |
|
|
sub barecode ($) { |
54 |
|
|
bless \$_[0], 'bare'; |
55 |
|
|
} |
56 |
|
|
sub code ($$) { |
57 |
|
|
my ($Info, $code) = @_; |
58 |
|
|
for (keys %{$Info->{const}}) { |
59 |
|
|
$code =~ s/\$$_\b/literal $Info->{const}->{$_}/ge; |
60 |
|
|
} |
61 |
|
|
$code =~ s/__FUNCPACK__/$Info->{module_name}/g; |
62 |
|
|
$code; |
63 |
|
|
} |
64 |
wakaba |
1.1 |
|
65 |
|
|
my $parser = SuikaWiki::Markup::SuikaWikiConfig20::Parser->new; |
66 |
|
|
my $plugins = $parser->parse_text ($src); |
67 |
|
|
my $meta = $plugins->get_attribute ('Plugin') |
68 |
|
|
or die "$0: Required 'Plugin' section not found"; |
69 |
wakaba |
1.2 |
my %Info = (provide => {}, |
70 |
|
|
Name => n11n $meta->get_attribute ('Name')->value); |
71 |
wakaba |
1.1 |
$Info{name_literal} = literal $Info{Name}; |
72 |
|
|
my @date = gmtime; |
73 |
|
|
$Info{LastModified} = sprintf '%04d-%02d-%02dT%02d:%02d:%02d+00:00', |
74 |
|
|
$date[5] + 1900, $date[4] + 1, @date[3,2,1,0]; |
75 |
|
|
$Info{Version} = sprintf '%04d.%02d%02d.%02d%02d', |
76 |
|
|
$date[5] + 1900, $date[4] + 1, @date[3,2,1]; |
77 |
wakaba |
1.2 |
$Info{InterfaceVersion} = '2.9.1'; |
78 |
|
|
$Info{mkpluginVersion} = '2.'.$VERSION; |
79 |
wakaba |
1.1 |
$Info{module_name} = q#SuikaWiki::Plugin::plugin#; |
80 |
|
|
$Info{module_name} = random_module_name (\%Info, $Info{Name}); |
81 |
|
|
|
82 |
|
|
print <<EOH; |
83 |
|
|
use strict; |
84 |
|
|
package SuikaWiki::Plugin::Registry; |
85 |
|
|
our \%Info; |
86 |
|
|
\$Info{$Info{name_literal}}->{Name} = $Info{name_literal}; |
87 |
|
|
EOH |
88 |
wakaba |
1.2 |
for (qw/Version InterfaceVersion mkpluginVersion/) { |
89 |
|
|
print qq{\$Info{$Info{name_literal}}->{$_} = v$Info{$_};\n}; |
90 |
|
|
} |
91 |
|
|
for (qw/LastModified/) { |
92 |
wakaba |
1.1 |
$Info{$_} = n11n $meta->get_attribute ($_,make_new_node=>1)->value; |
93 |
|
|
next unless length $Info{$_}; |
94 |
|
|
print qq{\$Info{$Info{name_literal}}->{$_} = } . literal $Info{$_}; |
95 |
|
|
print ";\n"; |
96 |
|
|
} |
97 |
wakaba |
1.2 |
for (qw/RequiredPlugin RequiredModule/) { |
98 |
wakaba |
1.1 |
$Info{$_} = $meta->get_attribute ($_); |
99 |
|
|
next unless ref $Info{$_}; $Info{$_} = $Info{$_}->value; |
100 |
|
|
print qq{\$Info{$Info{name_literal}}->{$_} = [}; |
101 |
|
|
print join ', ', map {literal $_} @{$Info{$_}}; |
102 |
|
|
print "];\n"; |
103 |
|
|
} |
104 |
wakaba |
1.2 |
for (qw/Description License RelatedWikiPage RelatedURI/) { |
105 |
|
|
my $r = m13ed_val_list $meta, $_; |
106 |
|
|
next unless $r; |
107 |
|
|
print qq{\$Info{$Info{name_literal}}->{$_} = [$r];\n}; |
108 |
|
|
} |
109 |
|
|
|
110 |
|
|
print qq{\$Info{$Info{name_literal}}->{Author} = [} .( list map { |
111 |
|
|
[ |
112 |
|
|
[ barecode m13ed_val_list ($_, 'Name') ], |
113 |
|
|
[ $_->get_attribute ('Mail', make_new_node => 1)->value ], |
114 |
|
|
[ $_->get_attribute ('URI', make_new_node => 1)->value ], |
115 |
|
|
] |
116 |
|
|
} grep { $_->local_name eq 'Author' } @{$meta->child_nodes} |
117 |
|
|
). qq{];\n}; |
118 |
wakaba |
1.1 |
|
119 |
|
|
for (@{$plugins->child_nodes}) { |
120 |
wakaba |
1.2 |
if ($_->local_name eq 'FormattingRule') { |
121 |
|
|
print "\n", make_rule ($_, \%Info); |
122 |
|
|
} elsif ($_->local_name eq 'ViewDefinition') { |
123 |
wakaba |
1.1 |
print "\n", make_viewdef ($_, \%Info); |
124 |
|
|
} elsif ($_->local_name eq 'ViewFragment') { |
125 |
|
|
print "\n", make_viewfragment ($_, \%Info); |
126 |
wakaba |
1.2 |
} elsif ($_->local_name eq 'Function') { |
127 |
|
|
print "\n", make_function ($_, \%Info); |
128 |
|
|
} elsif ($_->local_name eq 'Resource') { |
129 |
|
|
print "\n", make_resdef ($_, \%Info); |
130 |
|
|
} elsif ($_->local_name eq 'PluginConst') { |
131 |
|
|
register_plugin_const ($_, \%Info); |
132 |
wakaba |
1.1 |
} |
133 |
|
|
} |
134 |
|
|
|
135 |
wakaba |
1.2 |
print qq{\npackage SuikaWiki::Plugin::Registry;\n\n}; |
136 |
|
|
print qq{\$Info{$Info{name_literal}}->{provide} = } . literal $Info{provide}; |
137 |
|
|
print qq{;\n}; |
138 |
|
|
|
139 |
wakaba |
1.1 |
print "\n1;\n"; |
140 |
|
|
exit; |
141 |
wakaba |
1.2 |
} |
142 |
|
|
|
143 |
|
|
sub make_function ($$) { |
144 |
|
|
my ($src, $Info) = @_; |
145 |
|
|
## TODO: support of ARGV property |
146 |
|
|
my $r = <<EOH; |
147 |
|
|
package $Info->{module_name}; |
148 |
|
|
sub @{[$src->get_attribute_value ('Name')]} { |
149 |
|
|
@{[code $Info, $src->get_attribute_value ('Main')]} |
150 |
|
|
} |
151 |
|
|
EOH |
152 |
|
|
} |
153 |
|
|
|
154 |
|
|
sub register_plugin_const ($$) { |
155 |
|
|
my ($src, $Info) = @_; |
156 |
|
|
for (@{$src->child_nodes}) { |
157 |
|
|
$Info->{const}->{$_->local_name} = $_->value; |
158 |
|
|
} |
159 |
|
|
} |
160 |
|
|
|
161 |
|
|
sub make_resdef ($$) { |
162 |
|
|
my ($src, $Info) = @_; |
163 |
|
|
my $r = qq{package SuikaWiki::Plugin::Resource;\nour \$BaseResource;\n}; |
164 |
|
|
for (@{$src->child_nodes}) { |
165 |
|
|
if ($_->node_type eq '#element') { |
166 |
|
|
my $lang = literal ($_->get_attribute_value ('lang') || 'und'); |
167 |
|
|
my $script = literal $_->get_attribute_value ('script'); |
168 |
|
|
my $name = literal $_->local_name; |
169 |
|
|
my $val = literal n11n $_->value; |
170 |
|
|
$r .= qq{\$BaseResource->{$lang}->{$script}->{$name} = $val;\n}; |
171 |
|
|
} |
172 |
|
|
} |
173 |
|
|
$r; |
174 |
|
|
} |
175 |
wakaba |
1.1 |
|
176 |
|
|
sub make_viewfragment ($$) { |
177 |
|
|
my ($src, $Info) = @_; |
178 |
|
|
my $r = ''; |
179 |
wakaba |
1.2 |
my $name = $src->get_attribute_value ('Name'); |
180 |
|
|
$name =~ tr/-/_/; |
181 |
|
|
## SuikaWiki 2 Interface |
182 |
|
|
$r .= qq(SuikaWiki::View->template (@{[literal $name]}) |
183 |
|
|
->add_line (@{[literal $src->get_attribute_value ('Formatting')]});\n); |
184 |
|
|
## SuikaWiki 3 Interface |
185 |
|
|
$r .= <<EOH; |
186 |
|
|
push \@{\$SuikaWiki::View::Implementation::TemplateFragment{@{[literal $name]}}}, { |
187 |
|
|
Main => @{[literal $src->get_attribute_value ('Formatting')]}, |
188 |
|
|
Order => @{[0+$src->get_attribute_value ('Order')]}, |
189 |
|
|
Description => [@{[m13ed_val_list $src, 'Description']}], |
190 |
|
|
}; |
191 |
|
|
EOH |
192 |
|
|
push @{$Info->{provide}->{viewfragment}}, |
193 |
|
|
{Name => $src->get_attribute ('Name')->value}; |
194 |
wakaba |
1.1 |
$r; |
195 |
|
|
} |
196 |
|
|
|
197 |
|
|
sub make_viewdef ($$) { |
198 |
|
|
my ($src, $Info) = @_; |
199 |
|
|
my $ViewProp = {}; |
200 |
|
|
my $r = ''; |
201 |
|
|
$ViewProp->{Name} = n11n $src->get_attribute ('Mode')->value; |
202 |
|
|
$ViewProp->{pack_name} = random_module_name ($Info, $ViewProp->{Name}); |
203 |
|
|
|
204 |
wakaba |
1.2 |
$ViewProp->{condition_stringified} = hash |
205 |
wakaba |
1.1 |
mode => $ViewProp->{Name}, |
206 |
|
|
map {($_->local_name => $_->value)} |
207 |
|
|
@{$src->get_attribute ('Condition',make_new_node=>1)->child_nodes}; |
208 |
|
|
|
209 |
|
|
$r .= <<EOH; |
210 |
|
|
push \@SuikaWiki::View::Implementation::CommonViewDefs, { |
211 |
|
|
condition => {$ViewProp->{condition_stringified}}, |
212 |
|
|
object_class => q#$ViewProp->{pack_name}#, |
213 |
|
|
}; |
214 |
|
|
package $ViewProp->{pack_name}; |
215 |
|
|
our \@ISA = q#SuikaWiki::View::template#; |
216 |
|
|
EOH |
217 |
|
|
for (@{$src->child_nodes}) { |
218 |
wakaba |
1.2 |
if ($_->local_name eq 'template') { |
219 |
|
|
$r .= make_view_template_method ($_, $Info); |
220 |
|
|
} elsif ($_->local_name eq 'method') { |
221 |
wakaba |
1.1 |
$r .= ({ |
222 |
|
|
main => q(sub main ($$) {)."\n".q(my ($self, $opt) = @_;)."\n", |
223 |
|
|
main_pre => q(sub main_pre ($$$) {)."\n".q(my ($self, $opt, $opt2) = @_;)."\n", |
224 |
|
|
main_post => q(sub main_post ($$$) {)."\n".q(my ($self, $opt, $opt2) = @_;)."\n", |
225 |
|
|
}->{$_->get_attribute ('Name')->value} |
226 |
|
|
||qq(sub @{[$_->get_attribute ('Name')->value]} {\n)) |
227 |
wakaba |
1.2 |
. code ($Info, $_->value) |
228 |
wakaba |
1.1 |
. qq(\n}\n); |
229 |
|
|
} |
230 |
|
|
} |
231 |
wakaba |
1.2 |
my $prop = {Name => $ViewProp->{Name}, |
232 |
|
|
Description => barecode m13ed_val_list $_, 'Description'}; |
233 |
|
|
push @{$Info->{provide}->{viewdef}}, $prop; |
234 |
|
|
$r; |
235 |
|
|
} |
236 |
|
|
|
237 |
|
|
sub make_view_template_method ($$) { |
238 |
|
|
my ($src, $info) = @_; |
239 |
|
|
my $r = <<EOH; |
240 |
|
|
|
241 |
|
|
sub main (\$\$\$) { |
242 |
|
|
my (\$self, \$opt, \$opt2) = \@_; |
243 |
|
|
require SuikaWiki::Output::HTTP; |
244 |
|
|
\$opt2->{output} = SuikaWiki::Output::HTTP->new |
245 |
|
|
(wiki => \$self->{view}->{wiki}, |
246 |
|
|
view => \$self->{view}, viewobj => \$self); |
247 |
|
|
for (\@{\$self->{view}->{wiki}->{var}->{client}->{used_for_negotiate}}, |
248 |
|
|
'Accept-Language') { |
249 |
|
|
\$opt2->{output}->add_negotiate_header_field (\$_); |
250 |
|
|
} |
251 |
|
|
|
252 |
|
|
\$opt2->{template} = @{[literal $src->get_attribute ('body', make_new_node => 1)->inner_text]}; |
253 |
|
|
\$opt2->{o} = bless { |
254 |
|
|
## Compatible options for SuikaWiki 2 WikiPlugin interface |
255 |
|
|
param => \\\%main::form, |
256 |
|
|
page => \$main::form{mypage}, |
257 |
|
|
toc => [], |
258 |
|
|
#magic |
259 |
|
|
#content |
260 |
|
|
#use_anchor_name |
261 |
|
|
media => {@{[hash |
262 |
|
|
type => ($src->get_attribute ('media-type',make_new_node=>1)->inner_text |
263 |
|
|
|| 'application/octet-stream'), |
264 |
|
|
charset => ($src->get_attribute ('use-media-type-charset',make_new_node=>1) |
265 |
|
|
->inner_text || 0), |
266 |
|
|
## In fact, this value is not referred from any SuikaWiki 2 WikiPlugin rule. |
267 |
|
|
#expires => ($src->get_attribute ('expires',make_new_node=>1)->inner_text |
268 |
|
|
# || 0) |
269 |
|
|
]}}, |
270 |
|
|
## SuikaWiki 3 WikiPlugin interface |
271 |
|
|
wiki => \$self->{view}->{wiki}, |
272 |
|
|
plugin => \$self->{view}->{wiki}->{plugin}, |
273 |
|
|
var => {}, |
274 |
|
|
}, 'SuikaWiki::Plugin'; |
275 |
|
|
@{[do{my $x=$src->get_attribute('http-status-code',make_new_node=>1)->inner_text; |
276 |
|
|
$x?q{$opt2->{output}->{status_code} = }.(0 + $x).q{;}:q{}}]} |
277 |
|
|
@{[do{my $x=$src->get_attribute('http-status-phrase',make_new_node=>1)->inner_text; |
278 |
|
|
$x?q{$opt2->{output}->{reason_phrase} = }.literal($x).q{;}:q{}}]} |
279 |
|
|
\$opt2->{output}->{entity}->{media_type} = @{[literal |
280 |
|
|
$src->get_attribute ('media-type',make_new_node=>1) |
281 |
|
|
->inner_text || 'application/octet-stream']}; |
282 |
|
|
@{[($src->get_attribute ('use-media-type-charset',make_new_node=>1) |
283 |
|
|
->inner_text || 0) ? |
284 |
|
|
q{$opt2->{output}->{entity}->{charset} = $self->{view}->{wiki}->{config}->{charset}->{output};}: |
285 |
|
|
q{}]} |
286 |
|
|
@{[do{my $x = $src->get_attribute ('expires',make_new_node=>1)->inner_text; |
287 |
|
|
if ($x =~ /%%(\w+)%%/) { |
288 |
|
|
qq{\$opt2->{output}->set_expires (%{\$self->{view}->{wiki}->{config}->{entity}->{expires}->{@{[literal $1]}}});}; |
289 |
|
|
} else { |
290 |
|
|
qq{\$opt2->{output}->set_expires (delta => @{[0 + $x]});}; |
291 |
|
|
} |
292 |
|
|
}]} |
293 |
|
|
|
294 |
|
|
\$self->{view}->{wiki}->init_db; |
295 |
|
|
\$self->main_pre (\$opt, \$opt2); |
296 |
|
|
|
297 |
|
|
## TODO: formal SuikaWiki 3 interface |
298 |
|
|
my \$fmt = SuikaWiki::Plugin->formatter ('view'); |
299 |
|
|
\$opt2->{output}->{entity}->{body} |
300 |
|
|
= \$fmt->replace (\$opt2->{template} => \$opt2->{o}, |
301 |
|
|
{formatter => \$fmt}); |
302 |
|
|
\$opt2->{output}->output (output => 'http-cgi'); |
303 |
|
|
|
304 |
|
|
\$self->main_post (\$opt, \$opt2); |
305 |
|
|
} |
306 |
|
|
EOH |
307 |
|
|
} |
308 |
|
|
|
309 |
|
|
## TODO: Implements SuikaWiki 3 interface |
310 |
|
|
sub make_rule ($$) { |
311 |
|
|
my ($src, $Info) = @_; |
312 |
|
|
my $type = $src->get_attribute ('Category', make_new_node => 1)->value || []; |
313 |
|
|
my $name = $src->get_attribute ('Name', make_new_node => 1)->value; |
314 |
|
|
$name =~ s/(?=.)-/_/g; |
315 |
|
|
my $main = code $Info, $src->get_attribute_value ('Formatting'); |
316 |
|
|
$main = q{my ($p, $o) = @_;}."\n" . $main |
317 |
|
|
if $main =~ /\$p/ || $main =~ /\$o/; |
318 |
|
|
if ($main =~ /\$r/) { |
319 |
|
|
$main = q{my $r = '';} . "\n" . $main; |
320 |
|
|
$main .= q{$r}; |
321 |
|
|
} |
322 |
|
|
|
323 |
|
|
my $main = <<EOH; |
324 |
|
|
{ |
325 |
|
|
Formatting => sub {$main}, |
326 |
|
|
Description => [@{[m13ed_val_list $src, 'Description']}], |
327 |
|
|
Parameter => {@{[do{ |
328 |
|
|
my @r; |
329 |
|
|
for (@{$src->child_nodes}) { |
330 |
|
|
if ($_->local_name eq 'Parameter') { |
331 |
|
|
push @r, $_->get_attribute_value ('Name') |
332 |
|
|
=> {Type => $_->get_attribute_value ('Type'), |
333 |
|
|
Default => $_->get_attribute_value ('Default'), |
334 |
|
|
Description => [barecode m13ed_val_list $_, 'Description']}; |
335 |
|
|
} |
336 |
|
|
} |
337 |
|
|
list @r; |
338 |
|
|
}]}}, |
339 |
|
|
} |
340 |
|
|
EOH |
341 |
|
|
my $r; |
342 |
|
|
if (@$type == 1) { |
343 |
|
|
$type->[0] =~ tr/-/_/; |
344 |
|
|
$r = qq{\$SuikaWiki::Plugin::Rule{$type->[0]}->{$name} = $main;\n}; |
345 |
|
|
push @{$Info->{provide}->{rule}->{$type->[0]}}, $name; |
346 |
|
|
} else { |
347 |
|
|
$r = qq({my \$def = $main;\n); |
348 |
|
|
for my $type (@$type) { |
349 |
|
|
$type =~ tr/-/_/; |
350 |
|
|
$r .= qq{\$SuikaWiki::Plugin::Rule{$type}->{$name} = \$def;\n}; |
351 |
|
|
push @{$Info->{provide}->{rule}->{$type}}, $name; |
352 |
|
|
} |
353 |
|
|
$r .= qq(};\n); |
354 |
|
|
} |
355 |
wakaba |
1.1 |
$r; |
356 |
|
|
} |
357 |
|
|
|
358 |
|
|
|
359 |
|
|
sub random_module_name ($;$) { |
360 |
|
|
my ($Info, $subname) = @_; |
361 |
|
|
$subname =~ s/[^0-9A-Za-z_:]//g; |
362 |
|
|
my @date = gmtime; |
363 |
|
|
my @rand = ('A'..'Z','a'..'z',0..9,'_'); |
364 |
wakaba |
1.2 |
sprintf '%s::%s%s%s', $Info->{module_name}, $subname, |
365 |
wakaba |
1.1 |
sprintf ('%02d%02d%02d%02d%02d%02d', @date[5,4,3,2,1,0]), |
366 |
|
|
join ('', @rand[rand@rand,rand@rand,rand@rand,rand@rand]); |
367 |
|
|
} |