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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (hide annotations) (download)
Sat Oct 18 07:08:34 2003 UTC (21 years, 1 month ago) by wakaba
Branch: MAIN
Changes since 1.1: +259 -15 lines
File MIME type: text/plain
Imporoved SuikaWiki 3 implementation

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     }

admin@suikawiki.org
ViewVC Help
Powered by ViewVC 1.1.24