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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.19 - (hide annotations) (download)
Sun Jul 25 06:54:28 2004 UTC (20 years, 3 months ago) by wakaba
Branch: MAIN
Changes since 1.18: +23 -3 lines
File MIME type: text/plain
Property Editor implemented

1 wakaba 1.1 #!/usr/bin/perl
2     use strict;
3 wakaba 1.19 our $VERSION = do{my @r=(q$Revision: 1.18 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
4 wakaba 1.5 require Message::Markup::SuikaWikiConfig20::Parser;
5 wakaba 1.1
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 wakaba 1.11 $code =~ s/\$$_\b/$Info->{const}->{$_}/ge;
60 wakaba 1.2 }
61     $code =~ s/__FUNCPACK__/$Info->{module_name}/g;
62 wakaba 1.19 $code =~ s/__FUNCPACK{([^{}]+)}__/(\$SuikaWiki::Plugin::Registry::Info{@{[literal $1]}}->{module_name} || SuikaWiki::Plugin->module_package (@{[literal $1]}))/g;
63 wakaba 1.17 $code =~ s{<Q:([^:]+):([^>]+)>}{
64     if ($Info->{Namespace}->{$1}) {
65     literal $Info->{Namespace}->{$1}.$2;
66     } else {
67     warn qq(Namespace prefix "$1" not defined);
68     literal $2;
69     }
70     }ge;
71 wakaba 1.16
72 wakaba 1.13 $Info->{-message_error_used} = 1 if $code =~ /\buse\s+Message::Util::Error\b/;
73     if (not $Info->{-message_error_used} and
74     ($code =~ /\btry\s*\{/ or $code =~ /\bcatch\s*\{/)) {
75     warn "Message::Util::Error MUST be 'use'd before 'try'...'catch' block used";
76     }
77 wakaba 1.2 $code;
78     }
79 wakaba 1.5 sub change_package ($$) {
80     my ($Info, $pack) = @_;
81     unless ($Info->{current_package} eq $pack) {
82     $Info->{current_package} = $pack;
83     return qq{package $pack;\n\n};
84     } else {
85     return '';
86     }
87     }
88     sub quoted_string ($) {
89     my $s = shift;
90     $s =~ s/([\\"])/\\$1/g;
91     '"'.$s.'"';
92     }
93 wakaba 1.6 sub line ($;%) {
94     my ($Info, %opt) = @_;
95    
96     unless ($opt{file}) {
97     if ($opt{reset}) {
98     $opt{file} = sprintf '(WikiPlugin module %s, chunk %d)',
99     $Info->{Name},
100     ++$Info->{chunk_count};
101     } elsif ($opt{realfile}) {
102     $opt{file} = sprintf '(WikiPlugin module %s, chunk from %s)',
103     $Info->{Name},
104     $opt{realfile};
105     } else {
106 wakaba 1.7 $opt{file} = sprintf '(WikiPlugin module source %s, block %s)',
107     $Info->{source_file},
108 wakaba 1.6 $opt{node_path};
109     }
110     }
111    
112     $opt{file} =~ s/"/''/g;
113     sprintf '%s#line %d "%s"%s', "\n", $opt{line_no} || 1, $opt{file}, "\n";
114     }
115 wakaba 1.9 sub literal_or_code ($$) {
116     my ($Info, $s) = @_;
117     substr ($s, 0, 1) ne '{' ? literal ($s)
118     : code ($Info, substr ($s, 1, length ($s) - 2));
119     }
120 wakaba 1.19 sub expanded_uri ($$$) {
121     my ($Info, $prefix, $lname) = @_;
122     warn "$0: $prefix: Namespace prefix not declared";
123     $Info->{Namespace}->{$prefix} . $lname;
124     }
125 wakaba 1.1
126 wakaba 1.5 my $parser = Message::Markup::SuikaWikiConfig20::Parser->new;
127 wakaba 1.1 my $plugins = $parser->parse_text ($src);
128     my $meta = $plugins->get_attribute ('Plugin')
129     or die "$0: Required 'Plugin' section not found";
130 wakaba 1.2 my %Info = (provide => {},
131     Name => n11n $meta->get_attribute ('Name')->value);
132 wakaba 1.7 $Info{source_file} = $srcfile;
133 wakaba 1.1 $Info{name_literal} = literal $Info{Name};
134     my @date = gmtime;
135     $Info{LastModified} = sprintf '%04d-%02d-%02dT%02d:%02d:%02d+00:00',
136     $date[5] + 1900, $date[4] + 1, @date[3,2,1,0];
137     $Info{Version} = sprintf '%04d.%02d%02d.%02d%02d',
138     $date[5] + 1900, $date[4] + 1, @date[3,2,1];
139 wakaba 1.2 $Info{InterfaceVersion} = '2.9.1';
140     $Info{mkpluginVersion} = '2.'.$VERSION;
141 wakaba 1.1 $Info{module_name} = q#SuikaWiki::Plugin::plugin#;
142     $Info{module_name} = random_module_name (\%Info, $Info{Name});
143    
144     print <<EOH;
145     use strict;
146 wakaba 1.5 @{[change_package \%Info, 'SuikaWiki::Plugin::Registry']}
147 wakaba 1.1 our \%Info;
148     \$Info{$Info{name_literal}}->{Name} = $Info{name_literal};
149     EOH
150 wakaba 1.5 for (qw/Version InterfaceVersion mkpluginVersion module_name/) {
151 wakaba 1.13 print qq{\$Info{$Info{name_literal}}->{@{[literal $_]}} = @{[literal $Info{$_}]};\n};
152 wakaba 1.2 }
153 wakaba 1.13 for (qw/LastModified Date.RCS/) {
154 wakaba 1.1 $Info{$_} = n11n $meta->get_attribute ($_,make_new_node=>1)->value;
155     next unless length $Info{$_};
156 wakaba 1.13 print qq{\$Info{$Info{name_literal}}->{@{[literal $_]}} = } . literal $Info{$_};
157 wakaba 1.1 print ";\n";
158     }
159 wakaba 1.2 for (qw/RequiredPlugin RequiredModule/) {
160 wakaba 1.1 $Info{$_} = $meta->get_attribute ($_);
161     next unless ref $Info{$_}; $Info{$_} = $Info{$_}->value;
162     print qq{\$Info{$Info{name_literal}}->{$_} = [};
163     print join ', ', map {literal $_} @{$Info{$_}};
164     print "];\n";
165     }
166 wakaba 1.2 for (qw/Description License RelatedWikiPage RelatedURI/) {
167     my $r = m13ed_val_list $meta, $_;
168     next unless $r;
169     print qq{\$Info{$Info{name_literal}}->{$_} = [$r];\n};
170     }
171    
172     print qq{\$Info{$Info{name_literal}}->{Author} = [} .( list map {
173     [
174     [ barecode m13ed_val_list ($_, 'Name') ],
175     [ $_->get_attribute ('Mail', make_new_node => 1)->value ],
176     [ $_->get_attribute ('URI', make_new_node => 1)->value ],
177     ]
178     } grep { $_->local_name eq 'Author' } @{$meta->child_nodes}
179     ). qq{];\n};
180 wakaba 1.1
181 wakaba 1.16 for (@{$meta->get_attribute ('Namespace', make_new_node => 1)->child_nodes}) {
182     $Info{Namespace}->{$_->local_name} = $_->value;
183     }
184    
185 wakaba 1.5 my $use = $meta->get_attribute ('Use');
186     if (ref $use) {
187     print change_package \%Info, $Info{module_name};
188 wakaba 1.6 print line \%Info, node_path => 'Plugin/Use';
189 wakaba 1.13 print code \%Info, $use->inner_text;
190 wakaba 1.6 print line \%Info, reset => 1;
191 wakaba 1.5 }
192    
193 wakaba 1.1 for (@{$plugins->child_nodes}) {
194 wakaba 1.2 if ($_->local_name eq 'FormattingRule') {
195     print "\n", make_rule ($_, \%Info);
196     } elsif ($_->local_name eq 'ViewDefinition') {
197 wakaba 1.1 print "\n", make_viewdef ($_, \%Info);
198     } elsif ($_->local_name eq 'ViewFragment') {
199     print "\n", make_viewfragment ($_, \%Info);
200 wakaba 1.2 } elsif ($_->local_name eq 'Function') {
201     print "\n", make_function ($_, \%Info);
202     } elsif ($_->local_name eq 'Resource') {
203     print "\n", make_resdef ($_, \%Info);
204     } elsif ($_->local_name eq 'PluginConst') {
205     register_plugin_const ($_, \%Info);
206 wakaba 1.5 } elsif ($_->local_name eq 'Format') {
207     print "\n", make_format ($_, \%Info);
208 wakaba 1.15 } elsif ($_->local_name eq 'FormattingRuleAlias') {
209     print "\n", make_rule_alias ($_, \%Info);
210 wakaba 1.9 # Parameter
211     # PluginCategory
212 wakaba 1.1 }
213     }
214    
215 wakaba 1.5 print change_package \%Info, q(SuikaWiki::Plugin::Registry);
216 wakaba 1.2 print qq{\$Info{$Info{name_literal}}->{provide} = } . literal $Info{provide};
217     print qq{;\n};
218    
219 wakaba 1.1 print "\n1;\n";
220     exit;
221 wakaba 1.2 }
222    
223 wakaba 1.5 sub make_format ($$) {
224     my ($src, $Info) = @_;
225     my $module_name = 'SuikaWiki::Format::Definition::'.$src->get_attribute_value ('ModuleName');
226     my $r = change_package $Info, $module_name;
227 wakaba 1.13 local $Info->{-message_error_used} = 0;
228 wakaba 1.5 $r .= qq{our \@ISA;\n};
229     if (my $isa = $src->get_attribute_value ('Inherit')) {
230     for (@$isa) {
231     $r .= qq{push \@ISA, @{[literal 'SuikaWiki::Format::Definition::'.$_]};\n};
232     }
233     } else {
234     $r .= qq{push \@ISA, 'SuikaWiki::Format::Definition::template';\n};
235     }
236     if (my $name = $src->get_attribute_value ('Name')) {
237 wakaba 1.16 $r .= qq{\$SuikaWiki::Format::Definition::Class{@{[literal 'MAGIC:'.$name.'/'.$src->get_attribute_value ('Version', default => '').'##']}} = '$module_name';\n};
238 wakaba 1.5 }
239     if (my $type = $src->get_attribute_value ('Type')) {
240 wakaba 1.10 $type .= join '', map {
241     ';'. $_->local_name .'='. quoted_string $_->inner_text
242     } sort {
243     $a->local_name cmp $b->local_name
244     } @{$src->get_attribute ('Type')->child_nodes};
245 wakaba 1.16 $r .= qq{\$SuikaWiki::Format::Definition::Class{@{[literal 'IMT:'.$type.'##']}} = '$module_name';\n};
246 wakaba 1.5 }
247    
248 wakaba 1.8 my $convert = line $Info, line_no => __LINE__ + 2, realfile => __FILE__;
249     $convert .= <<'EOH';
250 wakaba 1.5 our $Converter;
251     sub convert ($$;%) {
252     my ($self, $source, %opt) = @_;
253 wakaba 1.16 my $t = SuikaWiki::Format::Definition->serialize_media_type (%opt);
254     my $converter = $Converter->{$t->{_}};
255 wakaba 1.12 return ($converter->{$opt{return_type} or 'Main'} or
256 wakaba 1.16 CORE::die "Buggy implementation: $t->{_}/@{[$opt{return_type} or 'Main']} not defined")
257 wakaba 1.12 ->($self, $source, \%opt)
258     if $converter;
259 wakaba 1.5 $self->SUPER::convert ($source, %opt);
260     }
261     EOH
262    
263     for (@{$src->child_nodes}) {
264     if ($_->local_name eq 'Converter') {
265 wakaba 1.8 if ($convert) {
266     $r .= $convert;
267     $r .= line $Info, reset => 1;
268     undef $convert;
269     }
270 wakaba 1.5 $r .= make_format_converter ($_, $Info);
271 wakaba 1.10 } elsif ($_->local_name eq 'WikiForm') {
272     $r .= q(sub wikiform {)."\n".q(my ($self, $source, %opt) = @_;);
273     $r .= line $Info, node_path => qq(Format[module-name()=$module_name]/WikiForm);
274     $r .= code $Info, $_->get_attribute_value ('Main');
275     $r .= line $Info, reset => 1;
276     $r .= qq(}\n);
277 wakaba 1.11 } elsif ($_->local_name eq 'HeadSummary') {
278     $r .= q(sub headsummary {)."\n".q(my ($self, $source, %opt) = @_;);
279     $r .= line $Info, node_path => qq(Format[module-name()=$module_name]/HeadSummary);
280     $r .= code $Info, $_->get_attribute_value ('Main');
281     $r .= line $Info, reset => 1;
282     $r .= qq(}\n);
283 wakaba 1.10 } elsif ($_->local_name eq 'NextIndex') {
284     my $name = $_->get_attribute_value ('Name', default => '');
285     $r .= q(sub next_index_for_).$name
286     . q( {)."\n".q(my ($self, $source, %opt) = @_;)
287     . line $Info, node_path => qq(Format[module-name()=$module_name]/NextIndex[Name=$name]);
288     $r .= code $Info, $_->get_attribute_value ('Main');
289     $r .= line $Info, reset => 1;
290     $r .= qq(}\n);
291 wakaba 1.19 } elsif ({qw/content_written 1 content_removed 1 content_type_changed_from 1
292     content_prop_modified 1/}
293 wakaba 1.18 ->{my $node_name = $_->local_name}) {
294     $r .= q(sub ).$node_name
295     . q( {)."\n".q(my ($self, %opt) = @_;)
296     . line $Info, node_path => qq(Format[module-name()=$module_name]/$node_name]);
297     $r .= code $Info, $_->get_attribute_value ('Main');
298     $r .= line $Info, reset => 1;
299     $r .= qq(}\n);
300 wakaba 1.5 } elsif ($_->local_name eq 'Use') {
301 wakaba 1.6 $r .= line $Info, node_path => qq(Format[module-name()=$module_name]/Use);
302 wakaba 1.13 $r .= code $Info, $_->inner_text;
303 wakaba 1.19 } elsif ($_->local_name eq 'Prop') {
304     $r .= q<sub prop ($$;%) { my ($self, $name, %opt) = @_;>;
305     my $f = 0;
306     for my $prop (@{$_->child_nodes}) {
307     if ($prop->local_name =~ /^([^:]+):([^:]+)$/) {
308     $r .= qq{if (\$name eq @{[literal expanded_uri $Info, $1, $2]}) { return @{[literal $prop->value]} } els};
309     $f = 1;
310     }
311     }
312     $r .= q<e {> if $f;
313     $r .= q{$self->SUPER::prop ($name, %opt);};
314     $r .= q<}> if $f;
315     $r .= qq<\n}\n>;
316 wakaba 1.5 }
317     }
318     $r;
319     }
320    
321     sub make_format_converter ($$) {
322     my ($src, $Info) = @_;
323     my %def;
324 wakaba 1.16 for (qw/Type Name Version TypeURIReference IsFragment IsPlaceholder/) {
325     $def{$_} = $src->get_attribute_value ($_);
326     delete $def{$_} unless defined $def{$_};
327     }
328     $def{Type_param} = {map {$_->local_name => $_->value}
329     @{$src->get_attribute ('Type', make_new_node => 1)
330     ->child_nodes}};
331     my $type = serialize_media_type ($Info,
332     Type => $def{Type},
333     Type_param => $def{Type_param},
334     Name => $def{Name},
335     Version => $def{Version},
336     URIReference => $def{TypeURIReference},
337     IsFragment => $def{IsFragment},
338     IsPlaceholder => $def{IsPlaceholder});
339     $def{serialized_type} = $type->{_};
340 wakaba 1.5
341 wakaba 1.12 for (qw/Main ToString ToOctetStream/) {
342     my $def = $src->get_attribute_value ($_);
343     next unless $def;
344     $def{$_} = line ($Info, node_path => '//Converter/'.$_)
345     . $def
346     . line ($Info, reset => 1);
347     if ($def{$_} =~ /\$r\b/) {
348     $def{$_} = 'my $r;'."\n".$def{$_}."\n".'$r';
349     }
350     $def{$_} = barecode code $Info,
351     'sub {my ($self, $source, $opt) = @_;'
352     . $def{$_} . '}';
353     }
354 wakaba 1.5
355     my $r = list %def;
356 wakaba 1.16 if ($type->{Type}) {
357     $r = qq{\$Converter->{@{[literal $type->{Type}]}} = {$r};\n};
358     $r .= qq{\$Converter->{@{[literal $type->{Magic}]}} = \$Converter->{@{[literal $type->{Type}]}};\n}
359     if $type->{Magic};
360     $r .= qq{\$Converter->{@{[literal $type->{URIReference}]}} = \$Converter->{@{[literal $type->{Type}]}};\n}
361     if $type->{URIReference};
362     } elsif ($type->{Magic}) {
363     $r = qq{\$Converter->{@{[literal $type->{Magic}]}} = {$r};\n};
364     $r .= qq{\$Converter->{@{[literal $type->{URIReference}]}} = \$Converter->{@{[literal $type->{Magic}]}};\n}
365     if $type->{URIReference};
366     } elsif ($type->{URIReference}) {
367     $r = qq{\$Converter->{@{[literal $type->{URIReference}]}} = {$r};\n};
368 wakaba 1.9 } else {
369 wakaba 1.16 $r = 'BEGIN { die "Invalid Syntax of Converter: Type or Name or TypeURIReference property required" }';
370 wakaba 1.5 }
371     $r;
372     }
373    
374 wakaba 1.16 sub serialize_media_type ($%) {
375     my ($Info, %opt) = @_;
376     my %return;
377     if ($opt{Type}) {
378     $return{Type} = 'IMT:'.$opt{Type};
379     if ($opt{Type_param}) {
380     $return{Type} .= join '', map {my $s;
381     ';'. $_ .'="'
382     . (($s = $opt{Type_param}->{$_}) =~ s/([\\"])/\\$1/g, $s)
383     . '"'
384     } sort {
385     $a cmp $b
386     } keys %{$opt{Type_param}};
387     }
388     }
389     if ($opt{Magic}) {
390     $return{Magic} = 'MAGIC:'.$opt{Magic};
391     } elsif ($opt{Name}) {
392     $return{Name} = 'MAGIC:'.$opt{Name}.'/*';
393     $return{Magic} = 'MAGIC:'.$opt{Name}.'/'.$opt{Version} if $opt{Version};
394     }
395     if ($opt{URIReference}) {
396     $return{URIReference} = $opt{URIReference};
397     }
398     my $flag = '##';
399     $flag .= 'f' if $opt{IsFragment};
400     $flag .= 'p' if $opt{IsPlaceholder};
401     for (qw/URIReference Type Magic Name/) {
402     $return{$_} .= $flag if $return{$_};
403     }
404     $return{_} = $return{URIReference} || $return{Type}
405     || $return{Magic} || $return{Name};
406     \%return;
407     }
408    
409    
410 wakaba 1.2 sub make_function ($$) {
411     my ($src, $Info) = @_;
412     ## TODO: support of ARGV property
413 wakaba 1.6 my $name;
414 wakaba 1.2 my $r = <<EOH;
415 wakaba 1.5 @{[change_package $Info, $Info->{module_name}]}
416 wakaba 1.6 sub @{[$name = $src->get_attribute_value ('Name')]} {
417     @{[line $Info, node_path => "Function[Name='$name']/Main"]}@{[
418     code $Info, $src->get_attribute_value ('Main')
419 wakaba 1.9 ]}
420 wakaba 1.2 }
421 wakaba 1.9 @{[line $Info, reset => 1]}
422 wakaba 1.2 EOH
423     }
424    
425     sub register_plugin_const ($$) {
426     my ($src, $Info) = @_;
427     for (@{$src->child_nodes}) {
428 wakaba 1.11 $Info->{const}->{$_->local_name} = literal_or_code $Info, $_->value;
429 wakaba 1.2 }
430     }
431    
432     sub make_resdef ($$) {
433     my ($src, $Info) = @_;
434 wakaba 1.5 my $r = change_package $Info, 'SuikaWiki::Plugin::Resource';
435 wakaba 1.13 local $Info->{-message_error_used} = 0;
436 wakaba 1.5 $r .= qq{our \$BaseResource;\n};
437 wakaba 1.2 for (@{$src->child_nodes}) {
438     if ($_->node_type eq '#element') {
439     my $lang = literal ($_->get_attribute_value ('lang') || 'und');
440     my $script = literal $_->get_attribute_value ('script');
441     my $name = literal $_->local_name;
442     my $val = literal n11n $_->value;
443     $r .= qq{\$BaseResource->{$lang}->{$script}->{$name} = $val;\n};
444     }
445     }
446     $r;
447     }
448 wakaba 1.1
449     sub make_viewfragment ($$) {
450     my ($src, $Info) = @_;
451     my $r = '';
452 wakaba 1.4 my $body = <<EOH;
453     {
454 wakaba 1.2 Main => @{[literal $src->get_attribute_value ('Formatting')]},
455     Order => @{[0+$src->get_attribute_value ('Order')]},
456     Description => [@{[m13ed_val_list $src, 'Description']}],
457     };
458     EOH
459 wakaba 1.4 ## Recommended format
460     my $name = $src->get_attribute_value ('Template');
461     if (ref ($name) and @$name > 1) {
462     $r .= qq({my \$def = $body;\n);
463     for (@$name) {
464     my $name = $_; $name =~ tr/-/_/;
465     $r .= qq(push \@{\$SuikaWiki::View::Implementation::TemplateFragment{@{[literal $name]}}}, \$def;\n);
466     push @{$Info->{provide}->{viewfragment}}, {Name => $name};
467     }
468     $r .= qq(}\n);
469     } else { ## Obsoleted format
470     $name = ref $name ? $name->[0] : $src->get_attribute_value ('Name');
471     $name =~ tr/-/_/;
472     $r .= qq(push \@{\$SuikaWiki::View::Implementation::TemplateFragment{@{[literal $name]}}}, $body);
473     push @{$Info->{provide}->{viewfragment}}, {Name => $name};
474     }
475 wakaba 1.1 $r;
476     }
477    
478     sub make_viewdef ($$) {
479     my ($src, $Info) = @_;
480     my $ViewProp = {};
481     my $r = '';
482 wakaba 1.6 $ViewProp->{Name} = n11n $src->get_attribute_value ('Mode');
483 wakaba 1.10 $ViewProp->{Name} =~ s/(?<=.)-/_/g;
484 wakaba 1.1 $ViewProp->{pack_name} = random_module_name ($Info, $ViewProp->{Name});
485    
486 wakaba 1.2 $ViewProp->{condition_stringified} = hash
487 wakaba 1.1 mode => $ViewProp->{Name},
488     map {($_->local_name => $_->value)}
489     @{$src->get_attribute ('Condition',make_new_node=>1)->child_nodes};
490    
491     $r .= <<EOH;
492     push \@SuikaWiki::View::Implementation::CommonViewDefs, {
493     condition => {$ViewProp->{condition_stringified}},
494     object_class => q#$ViewProp->{pack_name}#,
495     };
496 wakaba 1.5 @{[change_package $Info, $ViewProp->{pack_name}]}
497 wakaba 1.1 our \@ISA = q#SuikaWiki::View::template#;
498     EOH
499 wakaba 1.13 local $Info->{-message_error_used} = 0;
500 wakaba 1.11 my $use = $src->get_attribute ('Use');
501     if (ref $use) {
502     $r .= line $Info, node_path => "ViewDefinition[Mode='$ViewProp->{Name}']/Use";
503 wakaba 1.13 $r .= code $Info, $use->inner_text;
504     $r .= "\n\n";
505 wakaba 1.11 }
506    
507 wakaba 1.1 for (@{$src->child_nodes}) {
508 wakaba 1.2 if ($_->local_name eq 'template') {
509 wakaba 1.8 $r .= make_view_template_method ($_, $Info, $ViewProp);
510 wakaba 1.2 } elsif ($_->local_name eq 'method') {
511 wakaba 1.6 my $method_name = $_->get_attribute_value ('Name');
512 wakaba 1.1 $r .= ({
513 wakaba 1.8 main => q(sub main ($$) {)."\n".q(my ($self, $opt, $opt2) = @_;)."\n",
514 wakaba 1.1 main_pre => q(sub main_pre ($$$) {)."\n".q(my ($self, $opt, $opt2) = @_;)."\n",
515     main_post => q(sub main_post ($$$) {)."\n".q(my ($self, $opt, $opt2) = @_;)."\n",
516 wakaba 1.6 }->{$method_name}
517     ||qq(sub @{[$method_name]} {\n))
518     . line ($Info, node_path => "ViewDefinition[Mode='$ViewProp->{Name}']/method[Name='$method_name']")
519 wakaba 1.2 . code ($Info, $_->value)
520 wakaba 1.9 . qq(}\n)
521     . line ($Info, reset => 1);
522 wakaba 1.1 }
523     }
524 wakaba 1.2 my $prop = {Name => $ViewProp->{Name},
525     Description => barecode m13ed_val_list $_, 'Description'};
526     push @{$Info->{provide}->{viewdef}}, $prop;
527     $r;
528     }
529    
530     sub make_view_template_method ($$) {
531 wakaba 1.8 my ($src, $Info, $ViewProp) = @_;
532 wakaba 1.18 my $media_type = $src->get_attribute_value
533     ('media-type',
534     default => q<application/octet-stream>);
535 wakaba 1.2 my $r = <<EOH;
536    
537     sub main (\$\$\$) {
538     my (\$self, \$opt, \$opt2) = \@_;
539     require SuikaWiki::Output::HTTP;
540     \$opt2->{output} = SuikaWiki::Output::HTTP->new
541     (wiki => \$self->{view}->{wiki},
542     view => \$self->{view}, viewobj => \$self);
543     for (\@{\$self->{view}->{wiki}->{var}->{client}->{used_for_negotiate}},
544     'Accept-Language') {
545     \$opt2->{output}->add_negotiate_header_field (\$_);
546     }
547    
548     \$opt2->{template} = @{[literal $src->get_attribute ('body', make_new_node => 1)->inner_text]};
549     \$opt2->{o} = bless {
550     ## SuikaWiki 3 WikiPlugin interface
551     wiki => \$self->{view}->{wiki},
552     plugin => \$self->{view}->{wiki}->{plugin},
553     var => {},
554     }, 'SuikaWiki::Plugin';
555     @{[do{my $x=$src->get_attribute('http-status-code',make_new_node=>1)->inner_text;
556     $x?q{$opt2->{output}->{status_code} = }.(0 + $x).q{;}:q{}}]}
557     @{[do{my $x=$src->get_attribute('http-status-phrase',make_new_node=>1)->inner_text;
558 wakaba 1.8 $x?q{$opt2->{output}->{status_phrase} = }.literal($x).q{;}:q{}}]}
559 wakaba 1.18 \$opt2->{output}->{entity}->{media_type} = @{[literal $media_type]};
560    
561 wakaba 1.2 @{[($src->get_attribute ('use-media-type-charset',make_new_node=>1)
562     ->inner_text || 0) ?
563     q{$opt2->{output}->{entity}->{charset} = $self->{view}->{wiki}->{config}->{charset}->{output};}:
564     q{}]}
565     @{[do{my $x = $src->get_attribute ('expires',make_new_node=>1)->inner_text;
566     if ($x =~ /%%(\w+)%%/) {
567     qq{\$opt2->{output}->set_expires (%{\$self->{view}->{wiki}->{config}->{entity}->{expires}->{@{[literal $1]}}});};
568     } else {
569     qq{\$opt2->{output}->set_expires (delta => @{[0 + $x]});};
570     }
571     }]}
572 wakaba 1.12 \$opt2->{output}->{entity}->{body_is_octet_stream} = @{[
573     $src->get_attribute ('body')->get_attribute_value ('is-octet-stream', default_value => 0)
574     or 0
575     ]};
576 wakaba 1.2
577     \$self->{view}->{wiki}->init_db;
578     \$self->main_pre (\$opt, \$opt2);
579    
580 wakaba 1.18 @{[$media_type eq 'text/html' ? q{require Message::Markup::XML::Serialize::HTML;} : '']}
581 wakaba 1.8 use Message::Util::Error;
582     try {
583     \$opt2->{output}->{entity}->{body}
584 wakaba 1.18 = @{[$media_type eq 'text/html' ? q{Message::Markup::XML::Serialize::HTML::html_simple} : '']}
585     (SuikaWiki::Plugin->formatter ('view')
586     ->replace (\$opt2->{template}, param => \$opt2->{o}));
587 wakaba 1.8 } \$self->{view}->{wiki}->{config}->{catch}->{ @{[
588     $ViewProp->{Name} eq '-error' ? 'formatter_view_error'
589     : 'formatter_view' ]} };
590 wakaba 1.2 \$opt2->{output}->output (output => 'http-cgi');
591    
592     \$self->main_post (\$opt, \$opt2);
593     }
594     EOH
595     }
596    
597     sub make_rule ($$) {
598     my ($src, $Info) = @_;
599     my $type = $src->get_attribute ('Category', make_new_node => 1)->value || [];
600     my $name = $src->get_attribute ('Name', make_new_node => 1)->value;
601 wakaba 1.5 $name =~ s/(?<=.)-/_/g;
602    
603     my $reg_block;
604     $reg_block = qr/[^{}]*(?>[^{}]+|{(??{$reg_block})})*/;
605 wakaba 1.10 my %code;
606     for my $codename ([qw/Formatting main/], [qw/After after/],
607     [qw/Before before/], [qw/Pre pre/], [qw/Post post/],
608     [qw/Attribute attr/]) {
609     my $main = code $Info, $src->get_attribute_value ($codename->[0]);
610     next unless $main;
611     $main = line ($Info, node_path =>
612     "FormattingRule[name()='@{[list $type]}/$name']/".$codename->[0])
613     . $main;
614    
615 wakaba 1.11 if ( $main =~ /\$f\b/
616 wakaba 1.10 or $main =~ /\$rule_name\b/
617     or $main =~ /\$[opr]\b/
618 wakaba 1.11 or $main =~ /[%\$]opt\b/
619     or $main =~ /\$param_(?:name|value)\n/) {
620     if ($codename->[0] ne 'Attribute') {
621     $main = q{my ($f, $rule_name, $p, $o, %opt) = @_;}."\n".$main;
622     } else {
623     $main = q{my ($f, $rule_name, $p, $o, $param_name => $param_value, %opt) = @_;}."\n".$main;
624     }
625     }
626 wakaba 1.10 if ($main =~ /\$r\b/) {
627     warn qq(Rule @{[list $type]}/$name: Use of \$r is deprecated);
628     $main = q{my $r = '';} . "\n" . $main . "\n"
629     . q{$p->{-parent}->append_node ($r, node_or_text => 1);};
630     }
631     $main =~ s{__ATTR(TEXT|NODE)?:%(\w+|{$reg_block})(?:->{($reg_block)})?__;}
632     {($1 eq 'TEXT' ? '$p->{'.literal_or_code($Info, $2)
633     .'} = do { my $r = ' : '')
634     .'$f->parse_attr ($p=>'.literal_or_code($Info, $2).', $o, '
635     .($3?'-parent => '.$3.', ':'')
636     .($1?'-non_parsed_to_node => 1, ':'')
637     .'%opt)'
638     .($1 eq 'TEXT' ? '; ref $r?$r->inner_text:$r}'
639     : '')
640     .';'}ge;
641     $code{$codename->[1]} = barecode "sub {$main}";
642     }
643    
644     my $main = literal {
645     Description => [barecode m13ed_val_list $src, 'Description'],
646     Parameter => {do {
647     my @r;
648     for (@{$src->child_nodes}) {
649     if ($_->local_name eq 'Parameter') {
650     push @r, $_->get_attribute_value ('Name')
651     => {Type => $_->get_attribute_value ('Type'),
652     Default => $_->get_attribute_value ('Default'),
653     Description => [barecode m13ed_val_list $_, 'Description']};
654     }
655     }
656     @r;
657     }},
658     %code,
659     };
660     $main .= line $Info, reset => 1;
661    
662    
663     my $amain = <<EOH;
664 wakaba 1.2 {
665 wakaba 1.5 main => sub {$main},
666 wakaba 1.9 @{[line ($Info, reset => 1)]}
667 wakaba 1.2 Description => [@{[m13ed_val_list $src, 'Description']}],
668     Parameter => {@{[do{
669     }]}},
670     }
671     EOH
672 wakaba 1.5 my $r = change_package $Info, $Info->{module_name};
673 wakaba 1.13 local $Info->{-message_error_used} = 0;
674 wakaba 1.2 if (@$type == 1) {
675     $type->[0] =~ tr/-/_/;
676 wakaba 1.5 $r .= qq{\$SuikaWiki::Plugin::Rule{$type->[0]}->{$name} = $main;\n};
677 wakaba 1.2 push @{$Info->{provide}->{rule}->{$type->[0]}}, $name;
678     } else {
679 wakaba 1.5 $r .= qq({my \$def = $main;\n);
680 wakaba 1.2 for my $type (@$type) {
681     $type =~ tr/-/_/;
682     $r .= qq{\$SuikaWiki::Plugin::Rule{$type}->{$name} = \$def;\n};
683     push @{$Info->{provide}->{rule}->{$type}}, $name;
684     }
685     $r .= qq(};\n);
686     }
687 wakaba 1.1 $r;
688     }
689    
690 wakaba 1.15 =item FormattingRuleAlias
691    
692     Generating an alias name for a formatting rule that is already loaded.
693     Example:
694    
695     FormattingRuleAlias:
696     @Category[list]:
697     category-1
698     category-2
699     ...
700     @Name: new-rule-name
701     @Reference:
702     @@Category: one-of-category
703     @@Name: one-of-name
704    
705     associates C<(I<category-1>, I<new-rule-name>)>,
706     C<(I<category-2>, I<new-rule-name>)>, ...
707     with C<(I<one-of-category>, I<one-of-name>)>.
708    
709     =cut
710    
711     sub make_rule_alias ($$) {
712     my ($src, $Info) = @_;
713     my $type = $src->get_attribute ('Category', make_new_node => 1)->value || [];
714     my $name = $src->get_attribute ('Name', make_new_node => 1)->value;
715    
716     my $ref = $src->get_attribute ('Reference', make_new_node => 1);
717     my $c = $ref->get_attribute_value ('Category');
718     my $n = $ref->get_attribute_value ('Name');
719    
720     s/(?<=.)-/_/g for $n, $name;
721     tr/-/_/ for $c, @$type;
722    
723     my $def = qq{\$SuikaWiki::Plugin::Rule{@{[literal $c]}}->{@{[literal $n]}} or warn qq{Formatting rule "$c/$n" not defined}};
724    
725     my $r = change_package $Info, $Info->{module_name};
726     for my $type (@$type) {
727     $r .= qq{\$SuikaWiki::Plugin::Rule{@{[literal $type]}}->{@{[literal $name]}} = $def;\n};
728     push @{$Info->{provide}->{rule}->{$type}}, $name;
729     }
730     $r;
731     }
732    
733 wakaba 1.1
734     sub random_module_name ($;$) {
735     my ($Info, $subname) = @_;
736     $subname =~ s/[^0-9A-Za-z_:]//g;
737     my @date = gmtime;
738     my @rand = ('A'..'Z','a'..'z',0..9,'_');
739 wakaba 1.2 sprintf '%s::%s%s%s', $Info->{module_name}, $subname,
740 wakaba 1.1 sprintf ('%02d%02d%02d%02d%02d%02d', @date[5,4,3,2,1,0]),
741     join ('', @rand[rand@rand,rand@rand,rand@rand,rand@rand]);
742     }
743 wakaba 1.14
744     =head1 NAME
745    
746     mkplugin2.pl - SuikaWiki: WikiPlugin Generator
747    
748     =head1 SYNOPSIS
749    
750     mkplugin2.pl pluginsrc.wp2 > plugin.pm
751    
752     =head1 DESCRIPTION
753    
754     C<mkplugin2.pl> generates WikiPlugin module as a Perl module file
755     from WikiPlugin source description. WikiPlugin source description
756     is described in SuikaWikiConfig/2.0 format and it contains
757     definitions of wiki constructions (such as formatting rules and
758     WikiView definitions) as both machine understandable code and
759     human readable documentation. For more information, see
760     <http://suika.fam.cx/~wakaba/-temp/wiki/wiki?WikiPlugin>.
761    
762     This script is part of SuikaWiki.
763    
764     =head1 HISTORY AND COMPATIBILITY
765    
766     C<mkplugin2.pl> introduced as part of SuikaWiki 3.
767     It converts SuikaWiki 3 WikiPlugin source descriptions
768     (in SuikaWikiConfig/2.0) into Perl modules with SuikaWiki 3 interface.
769    
770     SuikaWiki 2 has C<mkplugin.pl>. It also converts WikiPlugin
771     source descriptions into Perl modules. But it support
772     SuikaWiki 2 format of WikiPlugin source description that differs from
773     SuikaWiki 3 format. Wiki programming interface (not limited to
774     WikiPlugin related one) of SuikaWiki 3 also incompatible with that
775     of SuikaWiki 2 so that it is impossible to use SuikaWiki 2 WikiPlugin
776     module with SuikaWiki 3 and vice versa.
777    
778     =head1 SEE ALSO
779    
780     C<SuikaWiki::Plugin>, SuikaWiki:WikiPlugin
781     <http://suika.fam.cx/~wakaba/-temp/wiki/wiki?WikiPlugin>.
782    
783     =head1 LICENSE
784    
785     Copyright 2003-2004 Wakaba <w@suika.fam.cx>. All rights reserved.
786    
787     This program is free software; you can redistribute it and/or
788     modify it under the same terms as Perl itself.
789    
790     =cut
791    
792 wakaba 1.19 1; # $Date: 2004/06/03 06:38:48 $

admin@suikawiki.org
ViewVC Help
Powered by ViewVC 1.1.24