/[suikacvs]/messaging/manakai/bin/cdis2pm.pl
Suika

Contents of /messaging/manakai/bin/cdis2pm.pl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.15 - (hide annotations) (download)
Wed Dec 29 12:17:42 2004 UTC (19 years, 10 months ago) by wakaba
Branch: MAIN
Changes since 1.14: +6 -11 lines
File MIME type: text/plain
DOMLS and DOMEvents rewritten in new style

1 wakaba 1.1 #!/usr/bin/perl -w
2     use strict;
3     use Message::Util::QName::Filter {
4     d => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/lang#dis-->,
5     dis2pm => q<http://suika.fam.cx/~wakaba/archive/2004/11/8/dis2pm#>,
6 wakaba 1.10 DISCore => q<http://suika.fam.cx/~wakaba/archive/2004/dis/Core#>,
7     DISLang => q<http://suika.fam.cx/~wakaba/archive/2004/dis/Lang#>,
8 wakaba 1.9 DISPerl => q<http://suika.fam.cx/~wakaba/archive/2004/dis/Perl#>,
9 wakaba 1.4 disPerl => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/lang#dis--Perl-->,
10 wakaba 1.1 DOMCore => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/dom-core#>,
11 wakaba 1.15 DOMEvents => q<http://suika.fam.cx/~wakaba/archive/2004/dom/events#>,
12 wakaba 1.1 DOMMain => q<http://suika.fam.cx/~wakaba/archive/2004/dom/main#>,
13 wakaba 1.12 DOMXML => q<http://suika.fam.cx/~wakaba/archive/2004/dom/xml#>,
14 wakaba 1.1 lang => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/lang#>,
15     Perl => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/lang#Perl-->,
16     license => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/license#>,
17     ManakaiDOM => q<http://suika.fam.cx/~wakaba/archive/2004/8/18/manakai-dom#>,
18 wakaba 1.3 MDOMX => q<http://suika.fam.cx/~wakaba/archive/2004/8/4/manakai-dom-exception#>,
19 wakaba 1.1 owl => q<http://www.w3.org/2002/07/owl#>,
20     rdf => q<http://www.w3.org/1999/02/22-rdf-syntax-ns#>,
21     rdfs => q<http://www.w3.org/2000/01/rdf-schema#>,
22 wakaba 1.10 TreeCore => q<>,
23 wakaba 1.1 };
24    
25     use Getopt::Long;
26     use Pod::Usage;
27     use Storable;
28     my %Opt;
29     GetOptions (
30     'for=s' => \$Opt{For},
31     'help' => \$Opt{help},
32     'module-name=s' => \$Opt{module_name},
33     'module-uri=s' => \$Opt{module_uri},
34     'verbose!' => $Opt{verbose},
35     ) or pod2usage (2);
36     pod2usage ({-exitval => 0, -verbose => 1}) if $Opt{help};
37     $Opt{file_name} = shift;
38     pod2usage ({-exitval => 2, -verbose => 0}) unless $Opt{file_name};
39     pod2usage (2) if not $Opt{module_uri} and not $Opt{module_name};
40    
41     BEGIN {
42     require 'manakai/genlib.pl';
43     require 'manakai/dis.pl';
44     }
45     our $State = retrieve ($Opt{file_name})
46     or die "$0: $Opt{file_name}: Cannot load";
47    
48     eval q{
49     sub impl_msg ($;%) {
50     warn shift () . "\n";
51     }
52     } unless $Opt{verbose};
53    
54     sub perl_change_package (%) {
55     my %opt = @_;
56     my $fn = $opt{full_name};
57     impl_err (qq<$fn: Bad package name>) unless $fn;
58     unless ($fn eq $State->{ExpandedURI q<dis2pm:currentPackage>}) {
59 wakaba 1.11 my $r = dispm_package_declarations (%opt);
60 wakaba 1.1 $State->{ExpandedURI q<dis2pm:currentPackage>} = $fn;
61 wakaba 1.11 $State->{ExpandedURI q<dis2pm:referredPackage>}->{$fn} = -1;
62     return $r . perl_statement qq<package $fn>;
63 wakaba 1.1 } else {
64     return '';
65     }
66     } # perl_change_package
67    
68 wakaba 1.11 =item $code = dispm_package_declarations (%opt)
69    
70     Generates a code fragment that declares what is required
71     in the current package, including import statements for
72     character classes.
73    
74     =cut
75    
76     sub dispm_package_declarations (%) {
77     my %opt = @_;
78     my $pack_name = $State->{ExpandedURI q<dis2pm:currentPackage>};
79     my $pack = $State->{ExpandedURI q<dis2pm:Package>}->{$pack_name};
80     my $r = '';
81     my @xml_class;
82     for (keys %{$pack->{ExpandedURI q<dis2pm:requiredCharClass>}||{}}) {
83     my $val = $pack->{ExpandedURI q<dis2pm:requiredCharClass>}->{$_};
84     next if not ref $val and $val <= 0;
85     if (/^InXML/) {
86     push @xml_class, $_;
87     $pack->{ExpandedURI q<dis2pm:requiredCharClass>}->{$_} = -1;
88     } else {
89     valid_err (qq<"$_": Unknown character class>,
90     node => ref $val ? $val : $opt{node});
91     }
92     }
93     if (@xml_class) {
94     $State->{Module}->{$State->{module}}
95     ->{ExpandedURI q<dis2pm:requiredModule>}
96     ->{'Char::Class::XML'} = 1;
97     $r .= perl_statement 'Char::Class::XML->import ('.
98     perl_list (@xml_class).')';
99     }
100     $r;
101     } # dispm_package_declarations
102    
103 wakaba 1.3 =item $code = dispm_perl_throws (%opt)
104    
105     Generates a code to throw an exception.
106    
107     =cut
108    
109     sub dispm_perl_throws (%) {
110     my %opt = @_;
111 wakaba 1.8 my $x = $opt{class_resource} || $State->{Type}->{$opt{class}};
112 wakaba 1.3 my $r = 'report ';
113     unless (defined $x->{Name}) {
114     $opt{class} = dis_typeforuris_to_uri ($opt{class}, $opt{class_for}, %opt);
115     $x = $State->{Type}->{$opt{class}};
116     }
117     valid_err (qq<Exception class <$opt{class}> is not defined>,
118     node => $opt{node}) unless defined $x->{Name};
119     if ($x->{ExpandedURI q<dis2pm:type>} and
120     {
121     ExpandedURI q<ManakaiDOM:ExceptionClass> => 1,
122     ExpandedURI q<ManakaiDOM:WarningClass> => 1,
123     }->{$x->{ExpandedURI q<dis2pm:type>}}) {
124 wakaba 1.8 $opt{type} = $opt{type_resource}->{Name} unless defined $opt{type};
125     valid_err qq{Exception code must be specified},
126     node => $opt{type_resource}->{src} || $opt{node}
127     unless defined $opt{type};
128 wakaba 1.10 $opt{subtype} = $opt{subtype_resource}->{NameURI} ||
129     $opt{subtype_resource}->{URI} unless defined $opt{subtype};
130 wakaba 1.8 $opt{xparam}->{ExpandedURI q<MDOMX:subtype>} = $opt{subtype}
131     if defined $opt{subtype};
132 wakaba 1.3 $r .= $x->{ExpandedURI q<dis2pm:packageName>} . ' ' .
133     perl_list -type => $opt{type},
134     -object => perl_code_literal ('$self'),
135     %{$opt{xparam} || {}};
136     } else {
137     no warnings 'uninitialized';
138 wakaba 1.8 valid_err (qq{Resource <$opt{class}> [<$x->{ExpandedURI q<dis2pm:type>}>] }.
139     q<is neither an exception class nor >.
140     q<a warning class>, node => $opt{node});
141 wakaba 1.3 }
142     return $r;
143     } # dispm_perl_throw
144    
145 wakaba 1.11 my $RegQNameChar = qr/[^\s<>"'\\\[\]\{\},=]/;
146 wakaba 1.3 {
147     use re 'eval';
148     my $RegBlockContent;
149     $RegBlockContent = qr/(?>[^{}\\]*)(?>(?>[^{}\\]+|\\.|\{(??{$RegBlockContent})\})*)/s;
150     ## Defined by genlib.pl but overridden.
151     sub perl_code ($;%) {
152     my ($s, %opt) = @_;
153     valid_err q<Uninitialized value in perl_code>,
154     node => $opt{node} unless defined $s;
155     local $State->{Namespace}
156     = $State->{Module}->{$opt{resource}->{parentModule}}->{nsBinding};
157 wakaba 1.11 $s =~ s[(?<![qwr])<($RegQNameChar[^<>]+)>|\b(null|true|false)\b][
158 wakaba 1.3 my ($q, $l) = ($1, $2);
159 wakaba 1.4 my $r;
160 wakaba 1.3 if (defined $q) {
161     if ($q =~ /\}/) {
162 wakaba 1.11 valid_warn qq<Inline element "<$q>" has a "}" - it might be a typo>;
163     }
164     if ($q =~ /=$/) {
165     valid_warn qq<Inline element "<$q>" ends with a "=" - >.
166     q{should "=" be used place of "=>"?};
167 wakaba 1.4 }
168     if ($q =~ s/^(.+?):://) {
169     my $et = dis_qname_to_uri
170     ($1, %opt,
171     use_default_namespace => ExpandedURI q<disPerl:>);
172     if ($et eq ExpandedURI q<disPerl:Q>) { ## QName constant
173     $r = perl_literal (dis_qname_to_uri ($q, use_default_namespace => 1,
174     %opt));
175 wakaba 1.10 } elsif ({
176     ExpandedURI q<disPerl:M> => 1,
177     ExpandedURI q<disPerl:ClassM> => 1,
178     ExpandedURI q<disPerl:AG> => 1,
179     ExpandedURI q<disPerl:AS> => 1,
180     }->{$et}) { ## Method call
181 wakaba 1.6 my ($clsq, $mtdq) = split /\s*\.\s*/, $q, 2;
182 wakaba 1.4 my $clsu = dis_typeforqnames_to_uri ($clsq,
183     use_default_namespace => 1, %opt);
184     my $cls = $State->{Type}->{$clsu};
185     my $clsp = $cls->{ExpandedURI q<dis2pm:packageName>};
186 wakaba 1.6 if ($cls->{ExpandedURI q<dis2pm:type>} and
187     {
188     ExpandedURI q<ManakaiDOM:IF> => 1,
189     ExpandedURI q<ManakaiDOM:ExceptionIF> => 1,
190     }->{$cls->{ExpandedURI q<dis2pm:type>}}) {
191     valid_err q<"disPerl:ClassM" cannot be used for interface methods>,
192     node => $opt{node} if $et eq ExpandedURI q<disPerl:ClassM>;
193     $clsp = '';
194     } else {
195     valid_err qq<Package name of class <$clsu> must be defined>,
196     node => $opt{node} unless defined $clsp;
197     $State->{Module}->{$State->{module}}
198     ->{ExpandedURI q<dis2pm:requiredModule>}
199     ->{$State->{Module}->{$cls->{parentModule}}
200     ->{ExpandedURI q<dis2pm:packageName>}} = 1;
201     }
202 wakaba 1.4 if ($mtdq =~ /:/) {
203     valid_err qq<$mtdq: Prefixed method name not supported>,
204     node => $opt{node};
205     } else {
206     my $mtd;
207     for (values %{$cls->{ExpandedURI q<dis2pm:method>}}) {
208     if (defined $_->{Name} and $_->{Name} eq $mtdq) {
209     $mtd = $_;
210     last;
211     }
212     }
213     valid_err qq<Perl method name for method "$clsp.$mtdq" must >.
214     q<be defined>, node => $mtd->{src} || $opt{node}
215     if not defined $mtd or
216     not defined $mtd->{ExpandedURI q<dis2pm:methodName>};
217 wakaba 1.6 $r = ' ' . ($clsp ? $clsp .
218 wakaba 1.10 {
219     ExpandedURI q<disPerl:M> => '::',
220     ExpandedURI q<disPerl:AG> => '::',
221     ExpandedURI q<disPerl:AS> => '::',
222     ExpandedURI q<disPerl:ClassM> => '->',
223     }->{$et}
224 wakaba 1.6 : '') .
225 wakaba 1.4 $mtd->{ExpandedURI q<dis2pm:methodName>} . ' ';
226     }
227 wakaba 1.12 } elsif ({
228     ExpandedURI q<disPerl:Class> => 1,
229     ExpandedURI q<disPerl:IF> => 1,
230     ExpandedURI q<disPerl:ClassName> => 1,
231     ExpandedURI q<disPerl:IFName> => 1,
232     }->{$et}) { ## Perl package name
233 wakaba 1.4 my $uri = dis_typeforqnames_to_uri ($q,
234     use_default_namespace => 1, %opt);
235     if (defined $State->{Type}->{$uri}->{Name} and
236     defined $State->{Type}->{$uri}
237     ->{ExpandedURI q<dis2pm:packageName>}) {
238 wakaba 1.12 $r = $State->{Type}->{$uri}->{ExpandedURI q<dis2pm:packageName>};
239     if ({
240     ExpandedURI q<disPerl:ClassName> => 1,
241     ExpandedURI q<disPerl:IFName> => 1,
242     }->{$et}) {
243     $r = perl_literal $r;
244     }
245 wakaba 1.4 } else {
246     valid_err qq<Package name of class <$uri> must be defined>,
247     node => $opt{node};
248     }
249 wakaba 1.9 } elsif ($et eq ExpandedURI q<disPerl:Code>) { ## CODE constant
250 wakaba 1.11 my ($nm);
251     $q =~ s/^\s+//;
252     if ($q =~ s/^((?>(?!::).)+)//) {
253     $nm = $1;
254     } else {
255     valid_err qq<"$q": Code name required>, node => $opt{node};
256     }
257     $q =~ s/^::\s*//;
258     my $param = dispm_parse_param (\$q, %opt,
259     ExpandedURI q<dis2pm:endOrErr> => 1,
260     use_default_namespace => '');
261     my $uri = dis_typeforqnames_to_uri
262     ($nm, use_default_namespace => 1,
263     %opt);
264 wakaba 1.4 if (defined $State->{Type}->{$uri}->{Name} and
265     dis_resource_ctype_match (ExpandedURI q<dis2pm:InlineCode>,
266     $State->{Type}->{$uri}, %opt)) {
267 wakaba 1.11 local $State->{ExpandedURI q<dis2pm:blockCodeParam>} = $param;
268 wakaba 1.5 ## ISSUE: It might be required to check loop referring
269 wakaba 1.4 $r = dispm_get_code (%opt, resource => $State->{Type}->{$uri},
270     For => [keys %{$State->{Type}->{$uri}
271     ->{For}}]->[0],
272 wakaba 1.14 'For+' => [keys %{$State->{Type}->{$uri}
273     ->{'For+'}||{}}],
274 wakaba 1.11 is_inline => 1,
275     ExpandedURI q<dis2pm:selParent> => $param,
276     ExpandedURI q<dis2pm:DefKeyName>
277     => ExpandedURI q<d:Def>);
278     for (grep {/^\$/} keys %$param) {
279     $r =~ s/\Q$_\E\b/ $param->{$_} /g;
280     }
281 wakaba 1.4 } else {
282     valid_err qq<Inline code constant <$uri> must be defined>,
283     node => $opt{node};
284     }
285 wakaba 1.11 } elsif ($et eq ExpandedURI q<disPerl:C>) {
286     if ($q =~ /^((?>(?!\.)$RegQNameChar)*)\.($RegQNameChar+)$/o) {
287     my ($cls, $constn) = ($1, $2);
288     if (length $cls) {
289     my $clsu = dis_typeforqnames_to_uri ($cls, %opt,
290     use_default_namespace => 1,
291     node => $_);
292     $cls = $State->{Type}->{$clsu};
293     valid_err qq<Class/IF <$clsu> must be defined>, node => $_
294     unless defined $cls->{Name};
295     } else {
296     $cls = $State->{ExpandedURI q<dis2pm:thisClass>};
297     valid_err q<Class/IF name required in this context>, node => $_
298     unless defined $cls->{Name};
299     }
300    
301     my $const = $cls->{ExpandedURI q<dis2pm:const>}->{$constn};
302     valid_err qq<Constant value "$constn" not defined in class/IF >.
303     qq{"$cls->{Name}" (<$cls->{URI}>)}, node => $_
304     unless defined $const->{Name};
305     $r = dispm_const_value (resource => $const);
306     } else {
307     valid_err qq<"$q": Syntax error>, node => $opt{node};
308     }
309 wakaba 1.4 } else {
310     valid_err qq<"$et": Unknown element type>, node => $opt{node};
311     }
312     } else {
313     valid_err qq<"<$q>": Element type must be specified>, node => $opt{node};
314 wakaba 1.3 }
315     } else {
316 wakaba 1.4 $r = {true => 1, false => 0, null => 'undef'}->{$l};
317 wakaba 1.3 }
318 wakaba 1.4 $r;
319 wakaba 1.3 ]ge;
320     ## TODO: Ensure Message::Util::Error imported if "try"ing.
321     ## ISSUE: __FILE__ & __LINE__ will break if multiline substition happens.
322     $s =~ s{
323 wakaba 1.11 \b__($RegQNameChar+)
324 wakaba 1.3 (?:\{($RegBlockContent)\})?
325     __\b
326     }{
327     my ($name, $data) = ($1, $2);
328     my $r;
329 wakaba 1.7 my $et = dis_qname_to_uri
330     ($name, %opt,
331     use_default_namespace => ExpandedURI q<disPerl:>);
332 wakaba 1.11 if ($et eq ExpandedURI q<disPerl:DEEP>) { ## Deep Method Call
333 wakaba 1.6 $r = '{'.perl_statement ('local $Error::Depth = $Error::Depth + 1').
334     perl_code ($data) .
335 wakaba 1.3 '}';
336 wakaba 1.11 } elsif ({
337     ExpandedURI q<disPerl:EXCEPTION> => 1,
338     ExpandedURI q<disPerl:WARNING> => 1,
339     }->{$et}) {
340 wakaba 1.3 ## Raising an Exception or Warning
341 wakaba 1.8 if ($data =~ s/^ \s* ((?>(?! ::|\.)$RegQNameChar)+) \s*
342     (?: \. \s* ((?>(?! ::|\.)$RegQNameChar)+) \s*
343     (?: \. \s* ((?>(>! ::|\.)$RegQNameChar)+) \s*
344     )?
345     )?
346     (?: ::\s* | $)//ox) {
347     my ($q, $constq, $subtypeq) = ($1, $2, $3);
348     $q =~ s/\|\|/::/g;
349     my $clsuri;
350     my $cls;
351     my $consturi;
352     my $const;
353     my $subtypeuri;
354     my $subtype;
355     if (defined $constq and not defined $subtypeq) {
356     $clsuri = dis_typeforqnames_to_uri ($q,
357     use_default_namespace => 1,
358     %opt);
359     $cls = $State->{Type}->{$clsuri};
360     valid_err qq{Exception/warning class definition for }.
361     qq{<$clsuri> is required}, node => $opt{node}
362     unless defined $cls->{Name};
363     my ($consttq, $constfq) = split /\|\|/, $constq, 2;
364     if (defined $constfq) {
365     if ($consttq !~ /:/) {
366     valid_err qq<"$constq": Unprefixed exception code QName must >.
367     q<not be followed by a "For" QName>,
368     node => $opt{node};
369     } else {
370     $consturi = dis_typeforqnames_to_uri ($consttq.'::'.$constfq,
371     use_default_namespace => 1,
372     %opt);
373     }
374     } else {
375     if ($consttq !~ /:/) {
376     $consturi = $consttq;
377     CONSTCLS: {
378     for (values %{$cls->{ExpandedURI q<dis2pm:xConst>}}) {
379     if (defined $_->{Name} and $_->{Name} eq $consturi) {
380     $const = $_;
381     last CONSTCLS;
382     }
383     }
384     valid_err qq{Exception/warning code "$consturi" must be }.
385     qq{defined in the exception/warning class }.
386     qq{<$clsuri>}, node => $opt{node};
387     }
388     } else {
389     $consturi = dis_typeforqnames_to_uri ($consttq.'::'.$constfq,
390     use_default_namespace => 1,
391     %opt);
392     }
393     }
394     unless ($const) {
395     CONSTCLS: {
396     for (values %{$cls->{ExpandedURI q<dis2pm:xConst>}}) {
397     if (defined $_->{Name} and $_->{URI} and
398     $_->{URI} eq $consturi) {
399     $const = $_;
400     last CONSTCLS;
401     }
402     }
403     valid_err qq{Exception/warning code <$consturi> must be }.
404     qq{defined in the exception/warning class }.
405     qq{<$clsuri>}, node => $opt{node};
406     }
407     }
408     } else { ## By code/subtype QName
409     $subtypeq = $q unless defined $constq;
410     $subtypeuri = dis_typeforqnames_to_uri ($subtypeq,
411     use_default_namespace => 1,
412     %opt);
413     $subtype = $State->{Type}->{$subtypeuri};
414     valid_err qq{Exception/warning code/subtype <$subtypeuri> must }.
415     qq{be defined}, node => $opt{node}
416     unless defined $subtype->{Name} and
417     defined $subtype->{ExpandedURI q<dis2pm:type>};
418     if ($subtype->{ExpandedURI q<dis2pm:type>} eq
419     ExpandedURI q<ManakaiDOM:ExceptionOrWarningSubType>) {
420     $const = $subtype->{ExpandedURI q<dis2pm:parentResource>};
421     $cls = $subtype->{ExpandedURI q<dis2pm:grandGrandParentResource>};
422     } elsif ($subtype->{ExpandedURI q<dis2pm:type>} eq
423     ExpandedURI q<ManakaiDOM:Const>) {
424     $const = $subtype;
425     $subtype = undef;
426     $cls = $const->{ExpandedURI q<dis2pm:grandParentResource>};
427     } else {
428     valid_err qq{Type of <$subtypeuri> must be either }.
429     q{"ManakaiDOM:Const" or }.
430     q{"ManakaiDOM:ExceptionOrWarningSubType"},
431     node => $opt{node};
432     }
433     }
434    
435     ## Parameter
436     my %xparam;
437     while ($data =~ s/^\s*($RegQNameChar+)\s*//) {
438     my $pnameuri = dis_qname_to_uri ($1, use_default_namespace => 1, %opt);
439     if (defined $xparam{$pnameuri}) {
440     valid_err qq<Exception parameter <$pnameuri> is already specified>,
441     node => $opt{node};
442     }
443     if ($data =~ s/^=>\s*'([^']*)'\s*//) { ## String
444     $xparam{$pnameuri} = $1;
445     } elsif ($data =~ s/^=>\s*\{($RegBlockContent)\}\s*//) { ## Code
446     $xparam{$pnameuri} = perl_code_literal ($1);
447     } elsif ($data =~ /^,|$/) { ## Boolean
448     $xparam{$pnameuri} = 1;
449     } else {
450     valid_err qq<<$pnameuri>: Parameter value is expected>,
451     node => $opt{node};
452     }
453     $data =~ s/^\,\s*// or last;
454     }
455     valid_err qq<"$data": Broken exception parameter specification>,
456     node => $opt{node} if length $data;
457     for (
458     ExpandedURI q<MDOMX:class>,
459     ExpandedURI q<MDOMX:method>,
460     ExpandedURI q<MDOMX:attr>,
461     ExpandedURI q<MDOMX:on>,
462     ) {
463     $xparam{$_} = $opt{$_} if defined $opt{$_};
464     }
465    
466     $r = dispm_perl_throws
467     (%opt,
468     class_resource => $cls,
469     class_for => $opt{For},
470     type_resource => $const,
471     subtype_resource => $subtype,
472     xparam => \%xparam);
473 wakaba 1.3 } else {
474     valid_err qq<Exception type and name required: "$data">,
475     node => $opt{node};
476     }
477 wakaba 1.7 } elsif ($et eq ExpandedURI q<disPerl:CODE>) {
478 wakaba 1.11 my ($nm);
479 wakaba 1.7 $data =~ s/^\s+//;
480     if ($data =~ s/^((?>(?!::).)+)//) {
481 wakaba 1.3 $nm = $1;
482     } else {
483 wakaba 1.7 valid_err q<Code name required>, node => $opt{node};
484 wakaba 1.3 }
485 wakaba 1.7 $data =~ s/^::\s*//;
486 wakaba 1.11 my $param = dispm_parse_param (\$data, %opt,
487     use_default_namespace => '',
488     ExpandedURI q<dis2pm:endOrErr> => 1);
489 wakaba 1.7 my $uri = dis_typeforqnames_to_uri ($nm, use_default_namespace => 1,
490     %opt);
491     if (defined $State->{Type}->{$uri}->{Name} and
492     dis_resource_ctype_match (ExpandedURI q<dis2pm:BlockCode>,
493     $State->{Type}->{$uri}, %opt)) {
494 wakaba 1.11 local $State->{ExpandedURI q<dis2pm:blockCodeParam>} = $param;
495 wakaba 1.10 ## ISSUE: It might be required to detect a loop
496 wakaba 1.7 $r = dispm_get_code (%opt, resource => $State->{Type}->{$uri},
497     For => [keys %{$State->{Type}->{$uri}
498 wakaba 1.11 ->{For}}]->[0],
499 wakaba 1.14 'For+' => [keys %{$State->{Type}->{$uri}
500     ->{'For+'}||{}}],
501 wakaba 1.11 ExpandedURI q<dis2pm:selParent> => $param,
502     ExpandedURI q<dis2pm:DefKeyName>
503     => ExpandedURI q<d:Def>);
504     for (grep {/^\$/} keys %$param) {
505     $r =~ s/\Q$_\E\b/ $param->{$_} /g;
506 wakaba 1.7 }
507 wakaba 1.11 valid_err qq<Block code <$uri> is empty>, node => $opt{node}
508     unless length $r;
509 wakaba 1.7 $r = "\n{\n$r\n}\n";
510     } else {
511     valid_err qq<Block code constant <$uri> must be defined>,
512     node => $opt{node};
513     }
514 wakaba 1.11 } elsif ($et eq ExpandedURI q<ManakaiDOM:InputNormalize>) {
515     my $method = $opt{ExpandedURI q<dis2pm:currentMethodResource>};
516     valid_err q<Element <ManakaiDOM:InputNroamlize> cannot be used here>,
517     node => $opt{node} unless defined $method->{Name};
518     PARAM: {
519     for my $param (@{$method->{ExpandedURI q<dis2pm:param>}||[]}) {
520     if ($data eq $param->{ExpandedURI q<dis2pm:paramName>}) {
521     ## NOTE: <ManakaiDOM:noInputNormalize> property is not
522     ## checked for this element.
523     my $nm = dispm_get_code
524     (%opt, resource => $State->{Type}
525     ->{$param->{ExpandedURI q<d:actualType>}},
526     ExpandedURI q<dis2pm:DefKeyName>
527     => ExpandedURI q<ManakaiDOM:inputNormalizer>,
528     ExpandedURI q<dis2pm:getCodeNoTypeCheck> => 1,
529     ExpandedURI q<dis2pm:selParent>
530     => $param->{ExpandedURI q<dis2pm:actualTypeNode>});
531     if (defined $nm) {
532     $nm =~ s[\$INPUT\b][\$$param->{ExpandedURI q<dis2pm:paramName>} ]g;
533     $r = $nm;
534     } else {
535     $r = '';
536     }
537     last PARAM;
538     }
539     }
540     valid_err q<Parameter "$data" is not found>, node => $opt{node};
541 wakaba 1.3 }
542 wakaba 1.10 } elsif ($et eq ExpandedURI q<disPerl:WHEN>) {
543 wakaba 1.3 if ($data =~ s/^\s*IS\s*\{($RegBlockContent)\}::\s*//o) {
544 wakaba 1.10 my $v = dis_qname_to_uri ($1, use_default_namespace => 1, %opt);
545     if ($State->{ExpandedURI q<dis2pm:blockCodeParam>}->{$v}) {
546     $r = perl_code ($data, %opt);
547 wakaba 1.3 }
548     } else {
549     valid_err qq<Syntax for preprocessing macro "WHEN" is invalid>,
550     node => $opt{node};
551     }
552 wakaba 1.10 } elsif ($et eq ExpandedURI q<disPerl:FOR>) {
553     if ($data =~ s/^((?>(?!::).)*)::\s*//) {
554     my @For = ($opt{For} || ExpandedURI q<ManakaiDOM:all>,
555     @{$opt{'For+'} || []});
556     V: for (split /\s*\|\s*/, $1) {
557     my $for = dis_qname_to_uri ($_, %opt, use_default_namespace => 1,
558     node => $opt{node});
559     for (@For) {
560     if (dis_uri_for_match ($for, $_, %opt)) {
561     $r = perl_code ($data, %opt);
562     last V;
563     }
564     }
565     }
566     } else {
567     valid_err (qq<Broken <$et> block: "$data">, node => $opt{node});
568     }
569 wakaba 1.11 } elsif ({
570     ExpandedURI q<disPerl:FILE> => 1,
571     ExpandedURI q<disPerl:LINE> => 1,
572     ExpandedURI q<disPerl:PACKAGE> => 1,
573     }->{$et}) {
574 wakaba 1.3 $r = qq<__${name}__>;
575 wakaba 1.11 valid_err (q<Block element content cannot be specified for >.
576     qq<element type <$et>>, node => $opt{node})
577     if length $data;
578 wakaba 1.3 } else {
579 wakaba 1.10 valid_err qq<Preprocessing macro <$et> not supported>, node => $opt{node};
580 wakaba 1.3 }
581     $r;
582     }goex;
583 wakaba 1.11
584     ## Checks \p character classes
585     while ($s =~ /\\p{([^{}]+)}/gs) {
586     my $name = $1;
587     $State->{ExpandedURI q<dis2pm:Package>}
588     ->{$State->{ExpandedURI q<dis2pm:currentPackage>}}
589     ->{ExpandedURI q<dis2pm:requiredCharClass>}
590     ->{$name} ||= $opt{node} || 1;
591     }
592    
593 wakaba 1.3 $s;
594     }
595     }
596    
597 wakaba 1.11 =item {%param} = dispm_parse_param (\$paramspec, %opt)
598    
599     Parses parameter specification and returns it as a reference
600     to hash.
601    
602     =cut
603    
604     sub dispm_parse_param ($%) {
605     my ($src, %opt) = @_;
606     my %param;
607     while ($$src =~ s/^
608     ## Parameter name
609     (\$? $RegQNameChar+)\s*
610    
611     (?: =>? \s*
612    
613     ## Parameter value
614     (
615     ## Bare string
616     $RegQNameChar+ |
617    
618     ## Quoted string
619     '(?>[^'\\]*)' ## ISSUE: escape mechanism required?
620    
621     )
622    
623     \s*)?
624    
625     (?:,\s*|$)//ox) {
626     my ($n, $v) = ($1, $2);
627     if (defined $v) {
628     if ($v =~ /^'/) {
629     $v = substr ($v, 1, length ($v) - 2);
630     } else {
631     #
632     }
633     } else {
634     $v = 1;
635     }
636    
637     if ($n =~ /^\$/) {
638     $param{$n} = $v;
639     } else {
640     $param{dis_qname_to_uri ($n, %opt)} = $v;
641     }
642     }
643     if ($opt{ExpandedURI q<dis2pm:endOrErr>} and length $$src) {
644     valid_err qq<Broken parameter specification: "$$src">, node => $opt{node};
645     }
646     \%param;
647     } # dispm_parse_param
648    
649 wakaba 1.3 ## Defined in genlib.pl but overridden.
650     sub perl_code_source ($%) {
651     my ($s, %opt) = @_;
652     my $npk = [qw/Name QName Label/];
653     my $f1 = sprintf q<File <%s> Node <%s> [Chunk #%d]>,
654     $opt{file} || $State->{Module}->{$opt{resource}->{parentModule}}->{FileName},
655     $opt{path} || ($opt{resource}->{src}
656     ? $opt{resource}->{src}->node_path (key => $npk)
657     : $opt{node} ? $opt{node}->node_path (key => $npk)
658     : 'x:unknown ()'),
659     ++($State->{ExpandedURI q<dis2pm:generatedChunk>} ||= 0);
660     my $f2 = sprintf q<Module <%s> [Chunk #%d]>,
661     $opt{file} || $State->{Module}->{$State->{module}}->{URI},
662     ++($State->{ExpandedURI q<dis2pm:generatedChunk>} ||= 0);
663     $f1 =~ s/"/\"/g; $f2 =~ s/"/\"/g;
664     sprintf qq<\n#line %d "%s"\n%s\n#line 1 "%s"\n>,
665     $opt{line} || 1, $f1, $s, $f2;
666     }
667    
668    
669    
670    
671     =item $code = dispm_get_code (resource => $res, %opt)
672    
673     Generates a Perl code fragment from resource(s).
674    
675     =cut
676    
677     sub dispm_get_code (%) {
678     my %opt = @_;
679 wakaba 1.7 if (($opt{ExpandedURI q<dis2pm:getCodeNoTypeCheck>} and
680     defined $opt{resource}->{Name}) or
681     ($opt{resource}->{ExpandedURI q<dis2pm:type>} and
682 wakaba 1.4 {
683     ExpandedURI q<ManakaiDOM:DOMMethodReturn> => 1,
684     ExpandedURI q<ManakaiDOM:DOMAttrGet> => 1,
685     ExpandedURI q<ManakaiDOM:DOMAttrSet> => 1,
686     }->{$opt{resource}->{ExpandedURI q<dis2pm:type>}}) or
687     (dis_resource_ctype_match ([ExpandedURI q<dis2pm:InlineCode>,
688     ExpandedURI q<dis2pm:BlockCode>],
689     $opt{resource}, %opt,
690     node => $opt{resource}->{src}))) {
691 wakaba 1.10 local $State->{Namespace}
692     = $State->{Module}->{$opt{resource}->{parentModule}}->{nsBinding}
693     if defined $opt{resource}->{Name};
694 wakaba 1.4 my $key = $opt{ExpandedURI q<dis2pm:DefKeyName>} || ExpandedURI q<d:Def>;
695 wakaba 1.9
696 wakaba 1.4 my $n = dis_get_attr_node (%opt, parent => $opt{resource}->{src},
697     name => {uri => $key},
698 wakaba 1.10 ContentType => ExpandedURI q<d:Perl>) ||
699     dis_get_attr_node (%opt, parent => $opt{resource}->{src},
700     name => {uri => $key},
701     ContentType => ExpandedURI q<lang:dis>);
702 wakaba 1.9 if ($n) {
703     return disperl_to_perl (%opt, node => $n);
704     }
705    
706     $n = dis_get_attr_node (%opt, parent => $opt{resource}->{src},
707     name => {uri => $key},
708 wakaba 1.4 ContentType => ExpandedURI q<lang:Perl>);
709     if ($n) {
710 wakaba 1.6 my $code = '';
711     for (@{dis_get_elements_nodes (%opt, parent => $n,
712     name => 'require')}) {
713     $code .= perl_statement 'require ' . $_->value;
714     }
715 wakaba 1.11 my $v = $n->value;
716     valid_err q<Perl code is required>, node => $n unless defined $v;
717     $code .= perl_code ($v, %opt, node => $n);
718 wakaba 1.4 if ($opt{is_inline} and
719     dis_resource_ctype_match ([ExpandedURI q<dis2pm:InlineCode>],
720     $opt{resource}, %opt,
721     node => $opt{resource}->{src})) {
722     $code =~ s/\n/\x20/g;
723     return $code;
724     } else {
725     return perl_code_source ($code, %opt, node => $n);
726     }
727     }
728     return undef;
729     } else {
730     impl_err ("Bad resource for dispm_get_code: ".
731     $opt{resource}->{ExpandedURI q<dis2pm:type>},
732     node => $opt{resource}->{src});
733 wakaba 1.3 }
734     } # dispm_get_code
735    
736     =item $code = dispm_get_value (%opt)
737    
738     Gets value property and returns it as a Perl code fragment.
739    
740     =cut
741    
742     sub dispm_get_value (%) {
743     my %opt = @_;
744     my $key = $opt{ExpandedURI q<dis2pm:DefKeyName>} || ExpandedURI q<d:Value>;
745     my $vt = $opt{ExpandedURI q<dis2pm:valueType>} || ExpandedURI q<DOMMain:any>;
746 wakaba 1.10 local $State->{Namespace}
747     = $State->{Module}->{$opt{resource}->{parentModule}}->{nsBinding}
748     if defined $opt{resource}->{Name};
749     my $n = $opt{node} ? [$opt{node}]
750     : dis_get_elements_nodes
751     (%opt, parent => $opt{resource}->{src},
752 wakaba 1.3 name => {uri => $key});
753     for my $n (@$n) {
754     my $t = dis_get_attr_node (%opt, parent => $n, name => 'ContentType');
755     my $type;
756     if ($t) {
757     $type = dis_qname_to_uri ($t->value, %opt, node => $t);
758     } else {
759 wakaba 1.5 $type = ExpandedURI q<lang:dis>;
760 wakaba 1.3 }
761     valid_err (qq<Type <$type> is not defined>, node => $t || $n)
762     unless defined $State->{Type}->{$type}->{Name};
763    
764     if (dis_uri_ctype_match (ExpandedURI q<lang:Perl>, $type, %opt)) {
765     ## ISSUE: Is some pre-process required?
766     return $n->value;
767 wakaba 1.10 } elsif (dis_uri_ctype_match (ExpandedURI q<DISCore:String>, $type, %opt)) {
768     return perl_literal $n->value;
769 wakaba 1.5 } elsif (dis_uri_ctype_match (ExpandedURI q<lang:dis>, $type, %opt)) {
770     ## NOTE: This might not be a valid Perl code fragment.
771     return $n->value;
772     }
773 wakaba 1.3 }
774    
775     ## No explicit value specified
776     if ($opt{ExpandedURI q<dis2pm:useDefaultValue>}) {
777     if (dis_uri_ctype_match (ExpandedURI q<DOMMain:DOMString>, $vt, %opt)) {
778     return q<"">;
779     }
780     }
781     return undef;
782     } # dispm_get_value
783    
784    
785 wakaba 1.5
786     =item $code = dispm_const_value (resource => $const, %opt)
787    
788 wakaba 1.10 Returns a code fragment corresponding to the vaue of C<$const>.
789 wakaba 1.5
790     =cut
791    
792     sub dispm_const_value (%) {
793     my %opt = @_;
794     my $for = [keys %{$opt{resource}->{For}}]->[0];
795 wakaba 1.14 local $opt{'For+'} = [keys %{$opt{resource}->{'For+'}||{}}];
796 wakaba 1.5 my $value = dispm_get_value
797     (%opt,
798     ExpandedURI q<dis2pm:ValueKeyName>
799     => ExpandedURI q<d:Value>,
800     ExpandedURI q<dis2pm:valueType>
801     => $opt{resource}
802     ->{ExpandedURI q<dis2pm:actualType>},
803     For => $for);
804     valid_err q<Constant value must be specified>, node => $opt{resource}->{src}
805     unless defined $value;
806 wakaba 1.10 return $value;
807     } # dispm_const_value
808    
809     =item $code = dispm_const_value_sub (resource => $const, %opt)
810    
811     Returns a code fragment to declare and define a constant function
812     corresponding to the definition of C<$const>.
813    
814     =cut
815    
816     sub dispm_const_value_sub (%) {
817     my %opt = @_;
818     my $value = dispm_const_value (%opt);
819 wakaba 1.5 return perl_sub
820     (name => $opt{resource}->{ExpandedURI q<dis2pm:constName>},
821     prototype => '',
822     code => $value);
823 wakaba 1.10 } # dispm_const_value_sub
824 wakaba 1.5
825     =item $code = dispm_const_group (resource => $const_group, %opt)
826    
827     Returns a code fragment to define a constant value group.
828    
829     =cut
830    
831     sub dispm_const_group (%) {
832     my %opt = @_;
833     my $name = $opt{resource}->{ExpandedURI q<dis2pm:constGroupName>};
834     for my $cg (values %{$opt{resource}->{ExpandedURI q<dis2pm:constGroup>}}) {
835     if (defined $cg->{ExpandedURI q<dis2pm:constGroupName>}) {
836     valid_err (qq{"$name"."$cg->{ExpandedURI q<dis2pm:constGroupName>}": }.
837     qq{Nesting constant group not supported},
838     node => $cg->{src});
839     }
840     }
841     my $result = '';
842     my @cname;
843     if (length $name) {
844     if (defined $opt{ExpandedURI q<dis2pm:constGroupParentPackage>}->{$name}) {
845     valid_err qq<Const group "$name" is already defined>,
846     node => $opt{resource}->{src};
847     }
848     $opt{ExpandedURI q<dis2pm:constGroupParentPackage>}->{$name} = \@cname;
849     }
850     for my $cv (values %{$opt{resource}->{ExpandedURI q<dis2pm:const>}}) {
851     next unless defined $cv->{ExpandedURI q<dis2pm:constName>};
852 wakaba 1.11 #$result .= dispm_const_value_sub (%opt, resource => $cv);
853 wakaba 1.5 push @cname, $cv->{ExpandedURI q<dis2pm:constName>};
854     }
855     return $result;
856     } # dispm_const_group
857 wakaba 1.9
858     =item $code = disperl_to_perl (node => $node, %opt)
859    
860     Converts a C<d:Perl> node to a Perl code fragment.
861    
862     =cut
863    
864     sub disperl_to_perl (%) {
865     my %opt = @_;
866     my $code = '';
867     for (@{$opt{node}->child_nodes}) {
868     next unless $_->node_type eq '#element';
869     next unless dis_node_for_match ($_, $opt{For}, %opt);
870     my $et = dis_element_type_to_uri ($_->local_name, %opt, node => $_);
871 wakaba 1.10 if ($et eq ExpandedURI q<DISLang:constValue>) {
872     my $cn = $_->value;
873     if ($cn =~ /^((?>(?!\.)$RegQNameChar)*)\.($RegQNameChar+)$/o) {
874     my ($cls, $constn) = ($1, $2);
875     if (length $cls) {
876     my $clsu = dis_typeforqnames_to_uri ($cls, %opt,
877     use_default_namespace => 1,
878     node => $_);
879     $cls = $State->{Type}->{$clsu};
880     valid_err qq<Class/IF <$clsu> must be defined>, node => $_
881     unless defined $cls->{Name};
882     } else {
883     $cls = $State->{ExpandedURI q<dis2pm:thisClass>};
884     valid_err q<Class/IF name required in this context>, node => $_
885     unless defined $cls->{Name};
886     }
887    
888     my $const = $cls->{ExpandedURI q<dis2pm:const>}->{$constn};
889     valid_err qq<Constant value "$constn" not defined in class/IF >.
890     qq{"$cls->{Name}" (<$cls->{URI}>)}, node => $_
891     unless defined $const->{Name};
892     $code .= perl_statement
893     perl_assign
894     perl_var (type => '$', local_name => 'r')
895     => dispm_const_value (resource => $const);
896     } else {
897     valid_err q<Syntax error>, node => $_;
898     }
899     } elsif ($et eq ExpandedURI q<DISLang:value>) {
900     my $v = dispm_get_value (%opt, node => $_);
901     $code .= perl_statement
902     perl_assign
903     perl_var (type => '$', local_name => 'r') => $v;
904     } elsif ($et eq ExpandedURI q<d:GetProp> or
905     $et eq ExpandedURI q<d:GetPropNode>) {
906     my $uri = dis_qname_to_uri ($_->value, %opt, node => $_,
907     use_default_namespace => 1);
908     $code .= perl_statement
909     perl_assign
910     perl_var (type => '$', local_name => 'r')
911     => '$self->{'.(ExpandedURI q<TreeCore:node>).
912     '}->{'.(perl_literal $uri).'}';
913     if ($et eq ExpandedURI q<d:GetPropNode>) {
914     $code .= perl_if
915     'defined $r',
916 wakaba 1.11 perl_code (q{<ClassM::ManakaiDOMNode.getNodeReference> ($r)},
917 wakaba 1.10 %opt, node => $_);
918     }
919 wakaba 1.11 } elsif ($et eq ExpandedURI q<d:SetProp>) {
920     my $uri = dis_qname_to_uri ($_->value, %opt, node => $_,
921     use_default_namespace => 1);
922     my $chk = dis_get_attr_node (%opt, parent => $_, name => 'CheckReadOnly');
923     if ($chk and $chk->value) {
924     my $for1 = $opt{For} || ExpandedURI q<ManakaiDOM:all>;
925     unless (dis_uri_for_match (ExpandedURI q<ManakaiDOM:ManakaiDOM1>,
926     $for1, node => $_)) {
927     $for1 = ExpandedURI q<ManakaiDOM:ManakaiDOMLatest>;
928     }
929     $code .= perl_if
930     q[$self->{].(perl_literal ExpandedURI q<TreeCore:node>).
931     q[}->{].(perl_literal ExpandedURI q<DOMCore:read-only>).
932     q[}],
933     perl_statement
934     dispm_perl_throws
935     (%opt, class_for => $for1,
936     class => ExpandedURI q<DOMCore:ManakaiDOMException>,
937     type => 'NO_MODIFICATION_ALLOWED_ERR',
938     subtype => ExpandedURI q<MDOMX:NOMOD_THIS>);
939     }
940     $code .= perl_statement
941     perl_assign
942     '$self->{'.(ExpandedURI q<TreeCore:node>).
943     '}->{'.(perl_literal $uri).'}'
944     => perl_var (type => '$', local_name => 'given');
945     } elsif ($et eq ExpandedURI q<DISPerl:cloneCode>) {
946     my $memref = $_->value;
947     my $mem = dispm_memref_to_resource
948     ($memref, %opt, node => $_,
949 wakaba 1.14 return_method_returner => 1,
950 wakaba 1.11 use_default_type_resource =>
951     $State->{ExpandedURI q<dis2pm:thisClass>},
952     ## ISSUE: Reference in a resource that is
953     ## referred from another resource might
954     ## not be interpreted correctly.
955     );
956     ## ISSUE: It might be required to detect a loop
957     $code .= dispm_get_code (%opt, resource => $mem,
958     For => [keys %{$mem->{For}}]->[0],
959 wakaba 1.14 'For+' => [keys %{$mem->{'For+'}||{}}],
960 wakaba 1.11 ExpandedURI q<dis2pm:DefKeyName>
961     => ExpandedURI q<d:Def>);
962 wakaba 1.10 } elsif ($et eq ExpandedURI q<DISPerl:selectByProp>) {
963 wakaba 1.11 my $cprop = dis_get_attr_node
964 wakaba 1.9 (%opt, parent => $_,
965     name => {uri => ExpandedURI q<DISPerl:propName>});
966 wakaba 1.11 my $propvalue;
967     if ($cprop) {
968     my $cpropuri = dis_qname_to_uri ($cprop->value,
969     use_default_namespace => 1,
970     %opt, node => $cprop);
971     my $prop;
972     if ($opt{ExpandedURI q<dis2pm:selParent>}) {
973     if (ref $opt{ExpandedURI q<dis2pm:selParent>} eq 'HASH') {
974     $prop = $opt{ExpandedURI q<dis2pm:selParent>};
975     if (defined $prop->{$cpropuri}) {
976     $propvalue = $prop->{$cpropuri};
977     } else {
978     $propvalue = '';
979     }
980     } else {
981 wakaba 1.9 $prop = dis_get_attr_node
982 wakaba 1.11 (%opt, parent => $opt{ExpandedURI q<dis2pm:selParent>},
983     name => {uri => $cpropuri});
984     if ($prop) {
985     $propvalue = $prop->value;
986 wakaba 1.9 } else {
987 wakaba 1.11 $propvalue = '';
988 wakaba 1.9 }
989     }
990 wakaba 1.11 } else {
991     valid_err q<Element "DISPerl:selectByProp" cannot be used here>,
992     node => $_;
993     }
994     } else {
995     valid_err q<Attribute "DISPerl:propName" required>,
996     node => $_;
997     }
998     my $selcase;
999     for my $case (@{$_->child_nodes}) {
1000     next unless $case->node_type eq '#element';
1001     next unless dis_node_for_match ($case, $opt{For}, %opt);
1002     my $et = dis_element_type_to_uri ($case->local_name,
1003     %opt, node => $case);
1004     if ($et eq ExpandedURI q<DISPerl:case>) {
1005     my $val = dis_get_attr_node
1006 wakaba 1.9 (%opt, parent => $case,
1007     name => 'Value',
1008     ContentType => ExpandedURI q<lang:dis>,
1009     defaultContentType => ExpandedURI q<lang:dis>);
1010 wakaba 1.11 if ($val and $val->value eq $propvalue) {
1011     $selcase = $case; last;
1012     } elsif ($propvalue eq '' and (not $val or not $val->value)) {
1013     $selcase = $case; last;
1014 wakaba 1.9 }
1015 wakaba 1.11 } elsif ($et eq ExpandedURI q<DISPerl:else>) {
1016     $selcase = $case; last;
1017     } elsif ({
1018     ExpandedURI q<DISPerl:propName> => 1,
1019     }->{$et}) {
1020     #
1021     } else {
1022     valid_err qq<Element type <$et> not allowed here>,
1023     node => $case;
1024     }
1025     }
1026 wakaba 1.9 if ($selcase) {
1027     my $lcode = perl_code ($selcase->value, %opt, node => $selcase);
1028 wakaba 1.11 if ($opt{is_inline}) {
1029     $code .= $lcode;
1030     } else {
1031     $code .= perl_code_source ($lcode, %opt, node => $selcase);
1032     }
1033 wakaba 1.9 }
1034     } elsif ({
1035     ExpandedURI q<d:ContentType> => 1,
1036     ExpandedURI q<d:For> => 1,
1037     ExpandedURI q<d:ForCheck> => 1,
1038     ExpandedURI q<d:ImplNote> => 1,
1039     }->{$et}) {
1040     #
1041     } else {
1042     valid_err qq<Element type <$et> not supported>,
1043     node => $opt{node};
1044     }
1045     }
1046    
1047     my $val = $opt{node}->value;
1048 wakaba 1.10 if (defined $val and length $val) {
1049 wakaba 1.11 my $lcode = perl_code ($val, %opt);
1050     if ($opt{is_inline}) {
1051     $code .= $lcode;
1052     } else {
1053     $code .= perl_code_source ($lcode, %opt);
1054     }
1055 wakaba 1.9 }
1056     return $code;
1057     } # disperl_to_perl
1058 wakaba 1.5
1059 wakaba 1.11 =item $res = dispm_memref_to_resource ($memref, %opt)
1060    
1061     Converts a C<DISPerl:MemRef> (a reference to a class member,
1062     i.e. either method, attribute, attribute getter or attribute
1063     setter) to a resource.
1064    
1065     =cut
1066    
1067     sub dispm_memref_to_resource ($%) {
1068     my ($memref, %opt) = @_;
1069     my ($clsq, $memq) = split /\./, $memref, 2;
1070     unless (defined $memq) {
1071     valid_err qq<"$memref": Member name required>. node => $opt{node};
1072     } elsif ($memq =~ /:/) {
1073     valid_err qq<"$memref": Prefixed member name not supported>,
1074     node => $opt{node};
1075     }
1076    
1077     ## Class
1078     my $cls;
1079     my $clsuri;
1080     if ($clsq eq '') {
1081     if (defined $opt{use_default_type_resource}->{Name}) {
1082     $cls = $opt{use_default_type_resource};
1083     $clsuri = $cls->{URI};
1084     } elsif ($opt{use_default_type}) {
1085     $clsuri = $opt{use_default_type};
1086     } else {
1087     $clsuri = dis_typeforqnames_to_uri
1088     ($clsq, use_default_namespace => 1, %opt);
1089     }
1090     } else {
1091     $clsuri = dis_typeforqnames_to_uri
1092     ($clsq, use_default_namespace => 1, %opt);
1093     }
1094     unless ($cls) {
1095     $cls = $State->{Type}->{$clsuri};
1096     valid_err qq<Class <$clsuri> must be defined>, node => $opt{node}
1097     unless defined $cls->{Name};
1098     }
1099    
1100     ## Method or attribute
1101     my $memname = $memq;
1102     my $mem;
1103     for (values %{$cls->{ExpandedURI q<dis2pm:method>}||{}}) {
1104     if (defined $_->{Name} and $_->{Name} eq $memname) {
1105     $mem = $_;
1106     last;
1107     }
1108     }
1109     if ($mem) {
1110     if ($opt{return_method_returner}) {
1111     if (defined $mem->{ExpandedURI q<dis2pm:return>}->{Name}) {
1112     $mem = $mem->{ExpandedURI q<dis2pm:return>};
1113     } elsif (defined $mem->{ExpandedURI q<dis2pm:getter>}->{Name}) {
1114     $mem = $mem->{ExpandedURI q<dis2pm:getter>};
1115     } else {
1116     valid_err qq{Neither "return" nor "getter" is defined for }.
1117     qq{the class "$cls->{Name}" <$cls->{URI}>},
1118     node => $opt{node};
1119     }
1120     }
1121     } elsif ($memname =~ s/^([gs]et)(?=.)//) {
1122     my $gs = $1;
1123     $memname = lcfirst $memname;
1124     my $memp;
1125     for (values %{$cls->{ExpandedURI q<dis2pm:method>}||{}}) {
1126     if (defined $_->{Name} and $_->{Name} eq $memname) {
1127     $memp = $_;
1128     last;
1129     }
1130     }
1131     if ($memp) {
1132     if ($gs eq 'set') {
1133     $mem = $memp->{ExpandedURI q<dis2pm:setter>};
1134     unless (defined $mem->{Name}) {
1135     valid_err qq{Setter for "$memp->{Name}" <$memp->{URI}> is not defined},
1136     node => $opt{node};
1137     }
1138     } else {
1139     $mem = $memp->{ExpandedURI q<dis2pm:getter>};
1140     unless (defined $mem->{Name}) {
1141     valid_err qq{Getter for "$memp->{Name}" <$memp->{URI}> is not defined},
1142     node => $opt{node};
1143     }
1144     }
1145     }
1146     }
1147     valid_err qq<Member "$memq" for class <$clsuri> is not defined>,
1148     node => $opt{node} unless defined $mem->{Name};
1149     return $mem;
1150     } # dispm_memref_to_resource
1151    
1152 wakaba 1.12 =item $hash = dispm_collect_hash_prop_value ($resource, $propuri, %opt)
1153    
1154     Get property values from a resource and its superclasses
1155     (C<dis:ISA>s - C<dis:Implement>s are not checked).
1156    
1157     =cut
1158    
1159     ## TODO: Loop test might be required
1160     sub dispm_collect_hash_prop_value ($$%) {
1161     my ($res, $propu, %opt) = @_;
1162     my %r;
1163     for (@{$res->{ISA}||[]}) {
1164     %r = (%{dispm_collect_hash_prop_value ($State->{Type}->{$_}, $propu, %opt)},
1165     %r);
1166     }
1167     %r = (%r, %{$res->{$propu}||{}});
1168     \%r;
1169     } # dispm_collect_hash_prop_value
1170 wakaba 1.5
1171 wakaba 1.1 ## Outputed module and "For"
1172     my $mf = dis_get_module_uri (module_name => $Opt{module_name},
1173     module_uri => $Opt{module_uri},
1174     For => $Opt{For});
1175     $State->{DefaultFor} = $mf->{For};
1176     $State->{module} = $mf->{module};
1177 wakaba 1.11 our $result = '';
1178 wakaba 1.1
1179 wakaba 1.3 valid_err
1180     (qq{Perl module <$State->{module}> not defined for <$State->{DefaultFor}>},
1181     node => $State->{Module}->{$State->{module}}->{src})
1182     unless $State->{Module}->{$State->{module}}
1183     ->{ExpandedURI q<dis2pm:packageName>};
1184    
1185 wakaba 1.1 $State->{ExpandedURI q<dis2pm:currentPackage>} = 'main';
1186 wakaba 1.11 my $header = "#!/usr/bin/perl \n";
1187     $header .= perl_comment q<This file is automatically generated from> . "\n" .
1188 wakaba 1.1 q<"> . $Opt{file_name} . q<" at > .
1189     rfc3339_date (time) . qq<.\n> .
1190     q<Don't edit by hand!>;
1191 wakaba 1.11 $header .= perl_comment qq{Module <$State->{module}>};
1192     $header .= perl_comment qq{For <$State->{DefaultFor}>};
1193     $header .= perl_statement q<use strict>;
1194     $header .= perl_change_package
1195 wakaba 1.1 (full_name => $State->{Module}->{$State->{module}}
1196     ->{ExpandedURI q<dis2pm:packageName>});
1197 wakaba 1.11 $header .= perl_statement
1198 wakaba 1.1 perl_assign
1199     perl_var (type => '$', local_name => 'VERSION',
1200     scope => 'our')
1201     => perl_literal version_date time;
1202    
1203 wakaba 1.5 ## -- Classes
1204 wakaba 1.8 my %opt;
1205 wakaba 1.1 for my $pack (values %{$State->{Module}->{$State->{module}}
1206     ->{ExpandedURI q<dis2pm:package>}||{}}) {
1207     next unless defined $pack->{Name};
1208     if ({
1209     ExpandedURI q<ManakaiDOM:Class> => 1,
1210     ExpandedURI q<ManakaiDOM:IF> => 1,
1211     ExpandedURI q<ManakaiDOM:ExceptionClass> => 1,
1212     ExpandedURI q<ManakaiDOM:ExceptionIF> => 1,
1213 wakaba 1.5 ExpandedURI q<ManakaiDOM:WarningClass> => 1,
1214 wakaba 1.1 }->{$pack->{ExpandedURI q<dis2pm:type>}}) {
1215     ## Package name and version
1216     $result .= perl_change_package
1217     (full_name => $pack->{ExpandedURI q<dis2pm:packageName>});
1218     $result .= perl_statement
1219     perl_assign
1220     perl_var (type => '$', local_name => 'VERSION',
1221     scope => 'our')
1222     => perl_literal version_date time;
1223     ## Inheritance
1224 wakaba 1.5 ## TODO: IF "isa" should be expanded
1225 wakaba 1.12 my $isa = $pack->{ExpandedURI q<dis2pm:AppISA>} || [];
1226     for (@$isa) {
1227     $State->{Module}->{$State->{module}}
1228     ->{ExpandedURI q<dis2pm:requiredModule>}->{$_} ||= 1;
1229     }
1230 wakaba 1.1 for my $uri (@{$pack->{ISA}||[]}, @{$pack->{Implement}||[]}) {
1231     my $pack = $State->{Type}->{$uri};
1232     if (defined $pack->{ExpandedURI q<dis2pm:packageName>}) {
1233 wakaba 1.2 push @$isa, $pack->{ExpandedURI q<dis2pm:packageName>};
1234 wakaba 1.1 } else {
1235     impl_msg ("Inheriting package name for <$uri> not defined",
1236     node => $pack->{src}) if $Opt{verbose};
1237     }
1238     }
1239 wakaba 1.2 $isa = array_uniq $isa;
1240     $result .= perl_inherit $isa;
1241 wakaba 1.11 $State->{ExpandedURI q<dis2pm:referredPackage>}->{$_} ||= $pack->{src} || 1
1242     for @$isa;
1243 wakaba 1.12
1244     ## Role
1245     my $role = dispm_collect_hash_prop_value
1246     ($pack, ExpandedURI q<d:Role>, %opt);
1247     my $feature;
1248     for (values %$role) {
1249     my $roleres = $State->{Type}->{$_->{Role}};
1250     my $compatres;
1251     $compatres = $State->{Type}->{$_->{compat}} if defined $_->{compat};
1252     valid_err qq{Perl package name for interface <$_->{Role}> must be defined},
1253     node => $roleres->{src}
1254     unless defined $roleres->{ExpandedURI q<dis2pm:packageName>};
1255     valid_err qq{Perl package name for class <$_->{compat}> must be defined},
1256     node => $compatres->{src}
1257     if $compatres and
1258     not defined $compatres->{ExpandedURI q<dis2pm:packageName>};
1259     if ({
1260     dis_typeforuris_to_uri
1261     (ExpandedURI q<DOMCore:DOMImplementation>,
1262     ExpandedURI q<ManakaiDOM:ManakaiDOM>, %opt) => 1,
1263    
1264     dis_typeforuris_to_uri
1265     (ExpandedURI q<DOMCore:ManakaiDOMNode>,
1266     ExpandedURI q<ManakaiDOM:ManakaiDOMLatest>, %opt) => 1,
1267     dis_typeforuris_to_uri
1268     (ExpandedURI q<DOMCore:ManakaiDOMAttr>,
1269     ExpandedURI q<ManakaiDOM:ManakaiDOMLatest>, %opt) => 1,
1270     dis_typeforuris_to_uri
1271     (ExpandedURI q<DOMXML:ManakaiDOMCDATASection>,
1272     ExpandedURI q<ManakaiDOM:ManakaiDOMLatest>, %opt) => 1,
1273     dis_typeforuris_to_uri
1274     (ExpandedURI q<DOMCore:ManakaiDOMComment>,
1275     ExpandedURI q<ManakaiDOM:ManakaiDOMLatest>, %opt) => 1,
1276     dis_typeforuris_to_uri
1277     (ExpandedURI q<DOMCore:ManakaiDOMDocument>,
1278     ExpandedURI q<ManakaiDOM:ManakaiDOMLatest>, %opt) => 1,
1279     dis_typeforuris_to_uri
1280     (ExpandedURI q<DOMCore:ManakaiDOMDocumentFragment>,
1281     ExpandedURI q<ManakaiDOM:ManakaiDOMLatest>, %opt) => 1,
1282     dis_typeforuris_to_uri
1283     (ExpandedURI q<DOMXML:ManakaiDOMDocumentType>,
1284     ExpandedURI q<ManakaiDOM:ManakaiDOMLatest>, %opt) => 1,
1285     dis_typeforuris_to_uri
1286     (ExpandedURI q<DOMCore:ManakaiDOMElement>,
1287     ExpandedURI q<ManakaiDOM:ManakaiDOMLatest>, %opt) => 1,
1288     dis_typeforuris_to_uri
1289     (ExpandedURI q<DOMXML:ManakaiDOMEntity>,
1290     ExpandedURI q<ManakaiDOM:ManakaiDOMLatest>, %opt) => 1,
1291     dis_typeforuris_to_uri
1292     (ExpandedURI q<DOMXML:ManakaiDOMEntityReference>,
1293     ExpandedURI q<ManakaiDOM:ManakaiDOMLatest>, %opt) => 1,
1294     dis_typeforuris_to_uri
1295     (ExpandedURI q<DOMXML:ManakaiDOMNotation>,
1296     ExpandedURI q<ManakaiDOM:ManakaiDOMLatest>, %opt) => 1,
1297     dis_typeforuris_to_uri
1298     (ExpandedURI q<DOMXML:ManakaiDOMProcessingInstruction>,
1299     ExpandedURI q<ManakaiDOM:ManakaiDOMLatest>, %opt) => 1,
1300     dis_typeforuris_to_uri
1301     (ExpandedURI q<DOMCore:ManakaiDOMText>,
1302     ExpandedURI q<ManakaiDOM:ManakaiDOMLatest>, %opt) => 1,
1303 wakaba 1.15
1304     dis_typeforuris_to_uri
1305     (ExpandedURI q<DOMEvents:ManakaiDOMEvent>,
1306     ExpandedURI q<ManakaiDOM:ManakaiDOMLatest>, %opt) => 1,
1307 wakaba 1.12 }->{$_->{Role}}) {
1308     unless ($feature) {
1309     $feature = {};
1310     for (keys %{dispm_collect_hash_prop_value
1311     ($pack, ExpandedURI q<DOMMain:implementFeature>, %opt)}) {
1312 wakaba 1.13 my @f = ([$State->{Type}->{$_}, []]);
1313     while (defined (my $f = shift @f)) {
1314     my $version = $f->[0]->{ExpandedURI q<d:Version>};
1315     $version = '' unless defined $version;
1316     for (keys %{$f->[0]->{ExpandedURI q<dis2pm:featureName>}}) {
1317     $feature->{$_}->{$version}
1318     = length $version
1319     ? $f->[0]->{ExpandedURI q<dis2pm:notImplemented>}
1320     ? 0 : 1
1321     : 1;
1322     unless ($feature->{$_}->{$version}) {
1323     $feature->{$_}->{$f->[2]} = 0 for @{$f->[1]};
1324     }
1325     }
1326     push @f,
1327     map {[$State->{Type}->{$_},
1328     [keys %{$f->[0]->{ExpandedURI q<dis2pm:featureName>}}],
1329     $version]}
1330     @{$f->[0]->{ISA}||[]};
1331 wakaba 1.12 }
1332     }
1333     }
1334     my %f = (
1335     packageName => $pack->{ExpandedURI q<dis2pm:packageName>},
1336     feature => $feature,
1337     );
1338    
1339     $result .= perl_statement
1340     (($compatres
1341     ? perl_var (type => '$',
1342     package => $compatres
1343     ->{ExpandedURI q<dis2pm:packageName>},
1344     local_name => 'Class').
1345     '{'.(perl_literal ($f{packageName})).'} = '
1346     : '').
1347     perl_var (type => '$',
1348     package => $roleres
1349     ->{ExpandedURI q<dis2pm:packageName>},
1350     local_name => 'Class').
1351     '{'.(perl_literal ($f{packageName})).'} = '.
1352     perl_literal \%f);
1353     } elsif ({
1354     dis_typeforuris_to_uri
1355     (ExpandedURI q<DOMCore:DOMImplementationSource>,
1356     ExpandedURI q<ManakaiDOM:ManakaiDOM>, %opt) => 1,
1357     }->{$_->{Role}}) {
1358     $result .= perl_statement
1359     'push @org::w3c::dom::DOMImplementationSourceList, '.
1360     perl_literal ($pack->{ExpandedURI q<dis2pm:packageName>});
1361     } else {
1362     valid_err qq{Role <$_->{Role}> not supported}, $_->{node};
1363     }
1364     }
1365    
1366 wakaba 1.1 ## Members
1367     if ({
1368     ExpandedURI q<ManakaiDOM:Class> => 1,
1369     ExpandedURI q<ManakaiDOM:ExceptionClass> => 1,
1370     ExpandedURI q<ManakaiDOM:WarningClass> => 1,
1371     }->{$pack->{ExpandedURI q<dis2pm:type>}}) {
1372 wakaba 1.11 local $State->{ExpandedURI q<dis2pm:thisClass>} = $pack;
1373 wakaba 1.8 local $opt{ExpandedURI q<MDOMX:class>}
1374     = $pack->{ExpandedURI q<dis2pm:packageName>};
1375 wakaba 1.1 for my $method (values %{$pack->{ExpandedURI q<dis2pm:method>}}) {
1376     next unless defined $method->{Name};
1377     if ($method->{ExpandedURI q<dis2pm:type>} eq
1378     ExpandedURI q<ManakaiDOM:DOMMethod>) {
1379 wakaba 1.8 local $opt{ExpandedURI q<MDOMX:method>}
1380 wakaba 1.14 = $method->{ExpandedURI q<dis2pm:methodName+>};
1381 wakaba 1.11 local $opt{ExpandedURI q<dis2pm:currentMethodResource>} = $method;
1382 wakaba 1.3 my $proto = '$';
1383 wakaba 1.11 my @param = ('$self');
1384 wakaba 1.7 my $param_norm = '';
1385 wakaba 1.3 my $param_opt = 0;
1386 wakaba 1.7 my $for = [keys %{$method->{For}}]->[0];
1387 wakaba 1.14 local $opt{'For+'} = [keys %{$method->{'For+'}||{}}];
1388 wakaba 1.3 for my $param (@{$method->{ExpandedURI q<dis2pm:param>}||[]}) {
1389 wakaba 1.11 my $atype = $param->{ExpandedURI q<d:actualType>};
1390 wakaba 1.3 if ($param->{ExpandedURI q<dis2pm:nullable>}) {
1391     $proto .= ';' unless $param_opt;
1392     $param_opt++;
1393     }
1394 wakaba 1.12 if (dis_uri_ctype_match (ExpandedURI q<Perl:Array>, $atype, %opt)) {
1395 wakaba 1.11 $proto .= '@';
1396     push @param, '@'.$param->{ExpandedURI q<dis2pm:paramName>};
1397 wakaba 1.12 } elsif (dis_uri_ctype_match (ExpandedURI q<Perl:Hash>, $atype,
1398 wakaba 1.11 %opt)) {
1399     $proto .= '%';
1400     push @param, '%'.$param->{ExpandedURI q<dis2pm:paramName>};
1401     } else {
1402     $proto .= '$';
1403     push @param, '$'.$param->{ExpandedURI q<dis2pm:paramName>};
1404     }
1405     my $nin = dis_get_attr_node
1406     (%opt,
1407     parent =>
1408     $param->{ExpandedURI q<dis2pm:actualTypeNode>},
1409     name => {uri =>
1410     ExpandedURI q<ManakaiDOM:noInputNormalize>},
1411     );
1412     if ($nin and $nin->value) {
1413     ## No input normalizing
1414     } else {
1415     my $nm = dispm_get_code
1416     (%opt, resource => $State->{Type}->{$atype},
1417 wakaba 1.7 ExpandedURI q<dis2pm:DefKeyName>
1418     => ExpandedURI q<ManakaiDOM:inputNormalizer>,
1419     For => $for,
1420 wakaba 1.11 ExpandedURI q<dis2pm:getCodeNoTypeCheck> => 1,
1421     ExpandedURI q<dis2pm:selParent>
1422     => $param->{ExpandedURI q<dis2pm:actualTypeNode>});
1423     if (defined $nm) {
1424 wakaba 1.12 $nm =~ s/\$INPUT\b/$param[-1] /g;
1425     ## NOTE: "Perl:Array" or "Perl:Hash" is not supported.
1426 wakaba 1.11 $param_norm .= $nm;
1427     }
1428 wakaba 1.7 }
1429 wakaba 1.3 }
1430     my $code = dispm_get_code
1431 wakaba 1.8 (%opt,
1432     resource => $method->{ExpandedURI q<dis2pm:return>},
1433 wakaba 1.11 For => $for,
1434     ExpandedURI q<dis2pm:DefKeyName>
1435     => ExpandedURI q<d:Def>);
1436 wakaba 1.3 if (defined $code) {
1437 wakaba 1.11 my $my = perl_statement ('my ('.join (", ", @param).
1438 wakaba 1.3 ') = @_');
1439     my $return = defined $method->{ExpandedURI q<dis2pm:return>}->{Name}
1440     ? $method->{ExpandedURI q<dis2pm:return>} : undef;
1441     if ($return->{ExpandedURI q<d:actualType>} ? 1 : 0) {
1442     my $default = dispm_get_value
1443 wakaba 1.8 (%opt, resource => $return,
1444 wakaba 1.3 ExpandedURI q<dis2pm:ValueKeyName>
1445     => ExpandedURI q<d:DefaultValue>,
1446     ExpandedURI q<dis2pm:useDefaultValue> => 1,
1447     ExpandedURI q<dis2pm:valueType>
1448     => $return->{ExpandedURI q<d:actualType>});
1449 wakaba 1.7 $code = $my . $param_norm .
1450 wakaba 1.3 perl_statement
1451     (defined $default ? 'my $r = '.$default : 'my $r').
1452     $code . "\n" .
1453     perl_statement ('$r');
1454     } else {
1455     $code = $my . $code;
1456     }
1457     } else { ## Code not defined
1458 wakaba 1.4 my $for1 = $for;
1459 wakaba 1.3 unless (dis_uri_for_match (ExpandedURI q<ManakaiDOM:ManakaiDOM1>,
1460     $for, node => $method->{src})) {
1461 wakaba 1.4 $for1 = ExpandedURI q<ManakaiDOM:ManakaiDOMLatest>;
1462 wakaba 1.3 }
1463 wakaba 1.11 $code = perl_statement 'my $self = shift;';
1464     $code .= perl_statement
1465 wakaba 1.3 dispm_perl_throws
1466     class => ExpandedURI q<DOMCore:ManakaiDOMException>,
1467 wakaba 1.4 class_for => $for1,
1468 wakaba 1.3 type => 'NOT_SUPPORTED_ERR',
1469     subtype =>
1470     ExpandedURI q<MDOMX:MDOM_IMPL_METHOD_NOT_IMPLEMENTED>,
1471     xparam => {
1472     ExpandedURI q<MDOMX:class>
1473     => $pack->{ExpandedURI q<dis2pm:packageName>},
1474     ExpandedURI q<MDOMX:method>
1475 wakaba 1.14 => $method->{ExpandedURI q<dis2pm:methodName+>},
1476 wakaba 1.3 };
1477     }
1478 wakaba 1.14 if (length $method->{ExpandedURI q<dis2pm:methodName>}) {
1479     $result .= perl_sub
1480     (name => $method->{ExpandedURI q<dis2pm:methodName>},
1481     code => $code, prototype => $proto);
1482     } else {
1483     $method->{ExpandedURI q<dis2pm:methodCodeRef>}
1484     = perl_sub (name => '', code => $code, prototype => $proto);
1485     }
1486 wakaba 1.1 } elsif ($method->{ExpandedURI q<dis2pm:type>} eq
1487     ExpandedURI q<ManakaiDOM:DOMAttribute>) {
1488 wakaba 1.8 local $opt{ExpandedURI q<MDOMX:attr>}
1489 wakaba 1.14 = $method->{ExpandedURI q<dis2pm:methodName+>};
1490 wakaba 1.3 my $getter = $method->{ExpandedURI q<dis2pm:getter>};
1491 wakaba 1.5 valid_err qq{Getter for attribute "$method->{Name}" must be }.
1492     q{defined}, node => $method->{src} unless $getter;
1493 wakaba 1.3 my $setter = defined $method->{ExpandedURI q<dis2pm:setter>}->{Name}
1494     ? $method->{ExpandedURI q<dis2pm:setter>} : undef;
1495     my $for = [keys %{$method->{For}}]->[0];
1496 wakaba 1.14 local $opt{'For+'} = [keys %{$method->{'For+'}||{}}];
1497 wakaba 1.4 my $for1 = $for;
1498 wakaba 1.3 unless (dis_uri_for_match (ExpandedURI q<ManakaiDOM:ManakaiDOM1>,
1499     $for, node => $method->{src})) {
1500 wakaba 1.4 $for1 = ExpandedURI q<ManakaiDOM:ManakaiDOMLatest>;
1501 wakaba 1.3 }
1502 wakaba 1.8 local $opt{ExpandedURI q<MDOMX:on>} = 'get';
1503 wakaba 1.14 my $get_code = dispm_get_code (%opt, resource => $getter, For => $for,
1504 wakaba 1.11 ExpandedURI q<dis2pm:DefKeyName>
1505     => ExpandedURI q<d:Def>);
1506 wakaba 1.3 if (defined $get_code) {
1507     my $default = dispm_get_value
1508 wakaba 1.8 (%opt, resource => $getter,
1509 wakaba 1.3 ExpandedURI q<dis2pm:ValueKeyName>
1510     => ExpandedURI q<d:DefaultValue>,
1511     ExpandedURI q<dis2pm:useDefaultValue> => 1,
1512     ExpandedURI q<dis2pm:valueType>
1513     => $getter->{ExpandedURI q<d:actualType>});
1514     $get_code = perl_statement
1515     (defined $default ? 'my $r = '.$default : 'my $r').
1516     $get_code. "\n" .
1517     perl_statement ('$r');
1518     } else { ## Get code not defined
1519     $get_code = perl_statement
1520     dispm_perl_throws
1521     class => ExpandedURI q<DOMCore:ManakaiDOMException>,
1522 wakaba 1.4 class_for => $for1,
1523 wakaba 1.3 type => 'NOT_SUPPORTED_ERR',
1524     subtype =>
1525     ExpandedURI q<MDOMX:MDOM_IMPL_ATTR_NOT_IMPLEMENTED>,
1526     xparam => {
1527     ExpandedURI q<MDOMX:class>
1528     => $pack->{ExpandedURI q<dis2pm:packageName>},
1529     ExpandedURI q<MDOMX:attr>
1530 wakaba 1.14 => $method->{ExpandedURI q<dis2pm:methodName+>},
1531 wakaba 1.3 ExpandedURI q<MDOMX:on> => 'get',
1532     };
1533     }
1534     if ($setter) {
1535 wakaba 1.8 local $opt{ExpandedURI q<MDOMX:on>} = 'set';
1536     my $set_code = dispm_get_code
1537 wakaba 1.11 (%opt, resource => $setter, For => $for,
1538     ExpandedURI q<dis2pm:DefKeyName>
1539     => ExpandedURI q<d:Def>);
1540 wakaba 1.3 if (defined $set_code) {
1541 wakaba 1.7 my $nm = dispm_get_code
1542 wakaba 1.8 (%opt, resource => $State->{Type}
1543 wakaba 1.7 ->{$setter->{ExpandedURI q<d:actualType>}},
1544     ExpandedURI q<dis2pm:DefKeyName>
1545     => ExpandedURI q<ManakaiDOM:inputNormalizer>,
1546     For => $for,
1547     ExpandedURI q<dis2pm:getCodeNoTypeCheck> => 1);
1548     if (defined $nm) {
1549     $nm =~ s/\$INPUT\b/\$given /g;
1550     } else {
1551     $nm = '';
1552     }
1553     $set_code = $nm .
1554 wakaba 1.15 $set_code. "\n";
1555 wakaba 1.3 } else { ## Set code not defined
1556     $set_code = perl_statement
1557     dispm_perl_throws
1558     class => ExpandedURI q<DOMCore:ManakaiDOMException>,
1559 wakaba 1.4 class_for => $for1,
1560 wakaba 1.3 type => 'NOT_SUPPORTED_ERR',
1561     subtype =>
1562     ExpandedURI q<MDOMX:MDOM_IMPL_ATTR_NOT_IMPLEMENTED>,
1563     xparam => {
1564     ExpandedURI q<MDOMX:class>
1565     => $pack->{ExpandedURI q<dis2pm:packageName>},
1566     ExpandedURI q<MDOMX:attr>
1567 wakaba 1.14 => $method->{ExpandedURI q<dis2pm:methodName+>},
1568 wakaba 1.3 ExpandedURI q<MDOMX:on> => 'set',
1569     };
1570     }
1571     $get_code = perl_if '@_ == 2',
1572     perl_statement ('my ($self, $given) = @_').
1573     $set_code,
1574     perl_statement ('my ($self) = @_').
1575     $get_code;
1576     } else {
1577     $get_code = perl_statement ('my ($self) = @_').
1578     $get_code;
1579     }
1580 wakaba 1.14 if (length $method->{ExpandedURI q<dis2pm:methodName>}) {
1581     $result .= perl_sub
1582     (name => $method->{ExpandedURI q<dis2pm:methodName>},
1583     prototype => $setter ? '$;$' : '$',
1584     code => $get_code);
1585     } else {
1586     $method->{ExpandedURI q<dis2pm:methodCodeRef>}
1587     = perl_sub (name => '', code => $get_code,
1588     prototype => $setter ? '$;$' : '$');
1589     }
1590 wakaba 1.1 }
1591     } # package method
1592 wakaba 1.14
1593     ## -- Constants
1594 wakaba 1.5 for my $cg (values %{$pack->{ExpandedURI q<dis2pm:constGroup>}}) {
1595     next unless defined $cg->{Name};
1596     $result .= dispm_const_group (resource => $cg);
1597     } # package const group
1598     for my $cv (values %{$pack->{ExpandedURI q<dis2pm:const>}}) {
1599     next unless defined $cv->{Name};
1600 wakaba 1.11 $result .= dispm_const_value_sub (resource => $cv);
1601 wakaba 1.5 } # package const value
1602 wakaba 1.14
1603     ## -- Operators
1604     my %ol;
1605     for (values %{$pack->{ExpandedURI q<dis2pm:overload>}||{}}) {
1606     next unless defined $_->{resource}->{Name};
1607     if ($_->{resource}->{ExpandedURI q<dis2pm:methodName+>} =~ /^\#/) {
1608     if ($_->{operator} =~ /^[A-Z]+$/) {
1609     my $code = $_->{resource}->{ExpandedURI q<dis2pm:methodCodeRef>};
1610     $code =~ s/\bsub /sub $_->{operator} /;
1611     $result .= $code;
1612     } else {
1613     $ol{$_->{operator}} = perl_code_literal $_->{resource}
1614     ->{ExpandedURI q<dis2pm:methodCodeRef>};
1615     }
1616     } else {
1617     if ($_->{operator} =~ /^[A-Z]+$/) {
1618     $result .= perl_statement
1619     perl_assign
1620     perl_var (type => '*',
1621     local_name => $_->{operator})
1622     => perl_var (type => '\&',
1623     local_name => $_->{resource}
1624     ->{ExpandedURI q<dis2pm:methodName>});
1625     } else {
1626     $ol{$_->{operator}}
1627     = $_->{resource}->{ExpandedURI q<dis2pm:methodName>};
1628     }
1629     }
1630     }
1631     if (keys %ol) {
1632     $ol{fallback} = 1;
1633     $result .= perl_statement 'use overload '.perl_list %ol;
1634     }
1635     for (values %{$pack->{ExpandedURI q<d:Operator>}||{}}) {
1636     next unless defined $_->{resource}->{Name};
1637     if ($_->{operator} eq ExpandedURI q<ManakaiDOM:MUErrorHandler>) {
1638     if ($_->{resource}->{ExpandedURI q<dis2pm:methodName+>} =~ /^\#/) {
1639     my $code = $_->{resource}->{ExpandedURI q<dis2pm:methodCodeRef>};
1640     $code =~ s/\bsub /sub ___error_handler /;
1641     $result .= $code;
1642     } else {
1643     $result .= perl_statement
1644     perl_assign
1645     perl_var (type => '*',
1646     local_name => '___error_handler')
1647     => perl_var (type => '\&',
1648     local_name => $_->{resource}
1649     ->{ExpandedURI q<dis2pm:methodName>});
1650     }
1651     } else {
1652     valid_err qq{Operator <$_->{operator}> is not supported},
1653     node => $_->{resource}->{src};
1654     }
1655     }
1656 wakaba 1.5 }
1657 wakaba 1.1 } # root object
1658 wakaba 1.6 }
1659    
1660 wakaba 1.11 $result .= dispm_package_declarations;
1661     my $begin = '';
1662 wakaba 1.6 for (keys %{$State->{Module}->{$State->{module}}
1663     ->{ExpandedURI q<dis2pm:requiredModule>}||{}}) {
1664     next if $_ eq $State->{Module}->{$State->{module}}
1665     ->{ExpandedURI q<dis2pm:packageName>};
1666 wakaba 1.11 $begin .= perl_statement ('require ' . $_);
1667 wakaba 1.12 $State->{ExpandedURI q<dis2pm:referredPackage>}->{$_} = -1;
1668 wakaba 1.11 }
1669     $result = $begin . $result if $begin;
1670    
1671     my @ref;
1672     for (keys %{$State->{ExpandedURI q<dis2pm:referredPackage>}||{}}) {
1673     my $v = $State->{ExpandedURI q<dis2pm:referredPackage>}->{$_};
1674     if (ref $v or $v >= 0) {
1675     push @ref, $_;
1676     }
1677 wakaba 1.1 }
1678 wakaba 1.11 $result .= "for (" . join (", ", map {'$'.$_.'::'} @ref) . ") {}"
1679     if @ref;
1680 wakaba 1.1
1681 wakaba 1.11 $result = $header . $result . perl_statement 1;
1682 wakaba 1.1
1683     output_result $result;
1684    
1685     1;

admin@suikawiki.org
ViewVC Help
Powered by ViewVC 1.1.24