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; |