1 |
wakaba |
1.1 |
package Message::DOM::Attr; |
2 |
|
|
use strict; |
3 |
wakaba |
1.11 |
our $VERSION=do{my @r=(q$Revision: 1.10 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r}; |
4 |
wakaba |
1.1 |
push our @ISA, 'Message::DOM::Node', 'Message::IF::Attr'; |
5 |
|
|
require Message::DOM::Node; |
6 |
|
|
|
7 |
|
|
sub ____new ($$$$$$) { |
8 |
|
|
my $self = shift->SUPER::____new (shift); |
9 |
|
|
($$self->{owner_element}, |
10 |
|
|
$$self->{namespace_uri}, |
11 |
|
|
$$self->{prefix}, |
12 |
|
|
$$self->{local_name}) = @_; |
13 |
|
|
Scalar::Util::weaken ($$self->{owner_element}); |
14 |
wakaba |
1.4 |
$$self->{child_nodes} = []; |
15 |
wakaba |
1.6 |
$$self->{specified} = 1; |
16 |
wakaba |
1.1 |
return $self; |
17 |
|
|
} # ____new |
18 |
|
|
|
19 |
|
|
sub AUTOLOAD { |
20 |
|
|
my $method_name = our $AUTOLOAD; |
21 |
|
|
$method_name =~ s/.*:://; |
22 |
|
|
return if $method_name eq 'DESTROY'; |
23 |
|
|
|
24 |
|
|
if ({ |
25 |
|
|
## Read-only attributes (trivial accessors) |
26 |
wakaba |
1.3 |
namespace_uri => 1, |
27 |
wakaba |
1.1 |
owner_element => 1, |
28 |
|
|
}->{$method_name}) { |
29 |
|
|
no strict 'refs'; |
30 |
|
|
eval qq{ |
31 |
|
|
sub $method_name (\$) { |
32 |
|
|
return \${\$_[0]}->{$method_name}; |
33 |
|
|
} |
34 |
|
|
}; |
35 |
|
|
goto &{ $AUTOLOAD }; |
36 |
|
|
} else { |
37 |
|
|
require Carp; |
38 |
|
|
Carp::croak (qq<Can't locate method "$AUTOLOAD">); |
39 |
|
|
} |
40 |
|
|
} # AUTOLOAD |
41 |
wakaba |
1.11 |
|
42 |
|
|
## |AttributeDefinition| constants |
43 |
|
|
|
44 |
|
|
## |DeclaredValueType| |
45 |
|
|
sub NO_TYPE_ATTR () { 0 } |
46 |
|
|
sub CDATA_ATTR () { 1 } |
47 |
|
|
sub ID_ATTR () { 2 } |
48 |
|
|
sub IDREF_ATTR () { 3 } |
49 |
|
|
sub IDREFS_ATTR () { 4 } |
50 |
|
|
sub ENTITY_ATTR () { 5 } |
51 |
|
|
sub ENTITIES_ATTR () { 6 } |
52 |
|
|
sub NMTOKEN_ATTR () { 7 } |
53 |
|
|
sub NMTOKENS_ATTR () { 8 } |
54 |
|
|
sub NOTATION_ATTR () { 9 } |
55 |
|
|
sub ENUMERATION_ATTR () { 10 } |
56 |
|
|
sub UNKNOWN_ATTR () { 11 } |
57 |
wakaba |
1.1 |
|
58 |
wakaba |
1.6 |
## |Node| attributes |
59 |
|
|
|
60 |
|
|
sub base_uri ($) { |
61 |
|
|
my $self = $_[0]; |
62 |
|
|
local $Error::Depth = $Error::Depth + 1; |
63 |
|
|
my $oe = $self->owner_element; |
64 |
|
|
if ($oe) { |
65 |
wakaba |
1.10 |
my $ln = $self->manakai_local_name; |
66 |
wakaba |
1.6 |
my $nsuri = $self->namespace_uri; |
67 |
|
|
if (($ln eq 'base' and |
68 |
|
|
defined $nsuri and $nsuri eq 'http://www.w3.org/XML/1998/namespace') or |
69 |
|
|
($ln eq 'xml:base' and not defined $nsuri)) { |
70 |
|
|
my $oep = $oe->parent_node; |
71 |
|
|
if ($oep) { |
72 |
|
|
return $oep->base_uri; |
73 |
|
|
} else { |
74 |
|
|
return $self->owner_document->base_uri; |
75 |
|
|
} |
76 |
|
|
} else { |
77 |
|
|
return $oe->base_uri; |
78 |
|
|
} |
79 |
|
|
} else { |
80 |
|
|
return $self->owner_document->base_uri; |
81 |
|
|
} |
82 |
|
|
} # base_uri |
83 |
wakaba |
1.1 |
|
84 |
wakaba |
1.3 |
sub local_name ($) { |
85 |
|
|
## TODO: HTML5 |
86 |
|
|
return ${+shift}->{local_name}; |
87 |
|
|
} # local_name |
88 |
|
|
|
89 |
|
|
sub manakai_local_name ($) { |
90 |
wakaba |
1.6 |
return ${$_[0]}->{local_name}; |
91 |
wakaba |
1.3 |
} # manakai_local_name |
92 |
|
|
|
93 |
|
|
sub namespace_uri ($); |
94 |
wakaba |
1.2 |
|
95 |
|
|
*node_name = \&name; |
96 |
|
|
|
97 |
|
|
sub node_type () { 2 } # ATTRIBUTE_NODE |
98 |
|
|
|
99 |
wakaba |
1.9 |
*node_value = \&Message::DOM::Node::text_content; |
100 |
wakaba |
1.1 |
|
101 |
wakaba |
1.11 |
sub owner_element ($); |
102 |
|
|
|
103 |
wakaba |
1.3 |
sub prefix ($;$) { |
104 |
wakaba |
1.5 |
## NOTE: No check for new value as Firefox doesn't do. |
105 |
|
|
## See <http://suika.fam.cx/gate/2005/sw/prefix>. |
106 |
|
|
|
107 |
|
|
## NOTE: Same as trivial setter except "" -> undef |
108 |
|
|
|
109 |
|
|
## NOTE: Same as |Element|'s |prefix|. |
110 |
|
|
|
111 |
|
|
if (@_ > 1) { |
112 |
wakaba |
1.6 |
if (${${$_[0]}->{owner_document}}->{strict_error_checking} and |
113 |
|
|
${$_[0]}->{manakai_read_only}) { |
114 |
wakaba |
1.5 |
report Message::DOM::DOMException |
115 |
|
|
-object => $_[0], |
116 |
|
|
-type => 'NO_MODIFICATION_ALLOWED_ERR', |
117 |
|
|
-subtype => 'READ_ONLY_NODE_ERR'; |
118 |
|
|
} |
119 |
|
|
if (defined $_[1] and $_[1] ne '') { |
120 |
|
|
${$_[0]}->{prefix} = ''.$_[1]; |
121 |
|
|
} else { |
122 |
|
|
delete ${$_[0]}->{prefix}; |
123 |
|
|
} |
124 |
|
|
} |
125 |
|
|
return ${$_[0]}->{prefix}; |
126 |
wakaba |
1.3 |
} # prefix |
127 |
|
|
|
128 |
wakaba |
1.8 |
## |Node| methods |
129 |
|
|
|
130 |
|
|
sub append_child ($$) { |
131 |
|
|
my $self = $_[0]; |
132 |
|
|
|
133 |
|
|
## NOTE: Depends on $self->node_type: |
134 |
|
|
my $self_od = $$self->{owner_document}; |
135 |
|
|
|
136 |
|
|
## -- Node Type check |
137 |
|
|
my @new_child; |
138 |
|
|
my $new_child_parent; |
139 |
|
|
if ($_[1]->node_type == 11) { # DOCUMENT_FRAGMENT_NODE |
140 |
|
|
push @new_child, @{$_[1]->child_nodes}; |
141 |
|
|
$new_child_parent = $_[1]; |
142 |
|
|
} else { |
143 |
|
|
@new_child = ($_[1]); |
144 |
|
|
$new_child_parent = $_[1]->parent_node; |
145 |
|
|
} |
146 |
|
|
|
147 |
|
|
## NOTE: Depends on $self->node_type: |
148 |
|
|
if ($$self_od->{strict_error_checking}) { |
149 |
|
|
my $child_od = $_[1]->owner_document || $_[1]; # might be DocumentType |
150 |
|
|
if ($self_od ne $child_od and $child_od->node_type != 10) { |
151 |
|
|
report Message::DOM::DOMException # DOCUMENT_TYPE_NODE |
152 |
|
|
-object => $self, |
153 |
|
|
-type => 'WRONG_DOCUMENT_ERR', |
154 |
|
|
-subtype => 'EXTERNAL_OBJECT_ERR'; |
155 |
|
|
} |
156 |
|
|
|
157 |
|
|
if ($$self->{manakai_read_only} or |
158 |
|
|
(@new_child and defined $new_child_parent and |
159 |
|
|
$$new_child_parent->{manakai_read_only})) { |
160 |
|
|
report Message::DOM::DOMException |
161 |
|
|
-object => $self, |
162 |
|
|
-type => 'NO_MODIFICATION_ALLOWED_ERR', |
163 |
|
|
-subtype => 'READ_ONLY_NODE_ERR'; |
164 |
|
|
} |
165 |
|
|
|
166 |
|
|
## NOTE: |Document| has children order check here. |
167 |
|
|
|
168 |
|
|
for my $cn (@new_child) { |
169 |
|
|
unless ({ |
170 |
|
|
3, 1, 5, 1, # TEXT_NODE, ENTITY_REFERENCE_NODE |
171 |
|
|
}->{$cn->node_type}) { |
172 |
|
|
report Message::DOM::DOMException |
173 |
|
|
-object => $self, |
174 |
|
|
-type => 'HIERARCHY_REQUEST_ERR', |
175 |
|
|
-subtype => 'CHILD_NODE_TYPE_ERR'; |
176 |
|
|
} |
177 |
|
|
} |
178 |
|
|
|
179 |
|
|
## NOTE: Ancestor check here in |Node|. |
180 |
|
|
} |
181 |
|
|
|
182 |
|
|
## NOTE: "Insert at" code only in insert_before and replace_child |
183 |
|
|
|
184 |
|
|
## -- Removes from parent |
185 |
|
|
if ($new_child_parent) { |
186 |
|
|
if (@new_child == 1) { |
187 |
|
|
my $v = $$new_child_parent->{child_nodes}; |
188 |
|
|
RP: for my $i (0..$#$v) { |
189 |
|
|
if ($v->[$i] eq $new_child[0]) { |
190 |
|
|
splice @$v, $i, 1, (); |
191 |
|
|
last RP; |
192 |
|
|
} |
193 |
|
|
} # RP |
194 |
|
|
} else { |
195 |
|
|
@{$$new_child_parent->{child_nodes}} = (); |
196 |
|
|
} |
197 |
|
|
} |
198 |
|
|
|
199 |
|
|
## -- Rewrite the |parentNode| properties |
200 |
|
|
for my $nc (@new_child) { |
201 |
|
|
$$nc->{parent_node} = $self; |
202 |
|
|
Scalar::Util::weaken ($$nc->{parent_node}); |
203 |
|
|
} |
204 |
|
|
|
205 |
|
|
## NOTE: Depends on method: |
206 |
|
|
push @{$$self->{child_nodes}}, @new_child; |
207 |
|
|
|
208 |
|
|
## NOTE: Setting |owner_document| in |Document|. |
209 |
|
|
|
210 |
|
|
return $_[1]; |
211 |
|
|
} # apepnd_child |
212 |
|
|
|
213 |
|
|
sub insert_before ($$) { |
214 |
|
|
my $self = $_[0]; |
215 |
|
|
|
216 |
|
|
## NOTE: Depends on $self->node_type: |
217 |
|
|
my $self_od = $$self->{owner_document}; |
218 |
|
|
|
219 |
|
|
## -- Node Type check |
220 |
|
|
my @new_child; |
221 |
|
|
my $new_child_parent; |
222 |
|
|
if ($_[1]->node_type == 11) { # DOCUMENT_FRAGMENT_NODE |
223 |
|
|
push @new_child, @{$_[1]->child_nodes}; |
224 |
|
|
$new_child_parent = $_[1]; |
225 |
|
|
} else { |
226 |
|
|
@new_child = ($_[1]); |
227 |
|
|
$new_child_parent = $_[1]->parent_node; |
228 |
|
|
} |
229 |
|
|
|
230 |
|
|
## NOTE: Depends on $self->node_type: |
231 |
|
|
if ($$self_od->{strict_error_checking}) { |
232 |
|
|
my $child_od = $_[1]->owner_document || $_[1]; # might be DocumentType |
233 |
|
|
if ($self_od ne $child_od and $child_od->node_type != 10) { |
234 |
|
|
report Message::DOM::DOMException # DOCUMENT_TYPE_NODE |
235 |
|
|
-object => $self, |
236 |
|
|
-type => 'WRONG_DOCUMENT_ERR', |
237 |
|
|
-subtype => 'EXTERNAL_OBJECT_ERR'; |
238 |
|
|
} |
239 |
|
|
|
240 |
|
|
if ($$self->{manakai_read_only} or |
241 |
|
|
(@new_child and defined $new_child_parent and |
242 |
|
|
$$new_child_parent->{manakai_read_only})) { |
243 |
|
|
report Message::DOM::DOMException |
244 |
|
|
-object => $self, |
245 |
|
|
-type => 'NO_MODIFICATION_ALLOWED_ERR', |
246 |
|
|
-subtype => 'READ_ONLY_NODE_ERR'; |
247 |
|
|
} |
248 |
|
|
|
249 |
|
|
## NOTE: |Document| has children order check here. |
250 |
|
|
|
251 |
|
|
for my $cn (@new_child) { |
252 |
|
|
unless ({ |
253 |
|
|
3, 1, 5, 1, # TEXT_NODE, ENTITY_REFERENCE_NODE |
254 |
|
|
}->{$cn->node_type}) { |
255 |
|
|
report Message::DOM::DOMException |
256 |
|
|
-object => $self, |
257 |
|
|
-type => 'HIERARCHY_REQUEST_ERR', |
258 |
|
|
-subtype => 'CHILD_NODE_TYPE_ERR'; |
259 |
|
|
} |
260 |
|
|
} |
261 |
|
|
|
262 |
|
|
## NOTE: Ancestor check here in |Node|. |
263 |
|
|
} |
264 |
|
|
|
265 |
|
|
## -- Insert at... ## NOTE: Only in insert_before and replace_child |
266 |
|
|
my $index = -1; # last |
267 |
|
|
if (defined $_[2]) { |
268 |
|
|
## error if $_[1] eq $_[2]; |
269 |
|
|
|
270 |
|
|
my $cns = $self->child_nodes; |
271 |
|
|
my $cnsl = @$cns; |
272 |
|
|
C: { |
273 |
|
|
$index = 0; |
274 |
|
|
for my $i (0..($cnsl-1)) { |
275 |
|
|
my $cn = $cns->[$i]; |
276 |
|
|
if ($cn eq $_[2]) { |
277 |
|
|
$index += $i; |
278 |
|
|
last C; |
279 |
|
|
} elsif ($cn eq $_[1]) { |
280 |
|
|
$index = -1; # offset |
281 |
|
|
} |
282 |
|
|
} |
283 |
|
|
|
284 |
|
|
report Message::DOM::DOMException |
285 |
|
|
-object => $self, |
286 |
|
|
-type => 'NOT_FOUND_ERR', |
287 |
|
|
-subtype => 'NOT_CHILD_ERR'; |
288 |
|
|
} # C |
289 |
|
|
} |
290 |
|
|
## NOTE: "else" only in replace_child |
291 |
|
|
|
292 |
|
|
## -- Removes from parent |
293 |
|
|
if ($new_child_parent) { |
294 |
|
|
if (@new_child == 1) { |
295 |
|
|
my $v = $$new_child_parent->{child_nodes}; |
296 |
|
|
RP: for my $i (0..$#$v) { |
297 |
|
|
if ($v->[$i] eq $new_child[0]) { |
298 |
|
|
splice @$v, $i, 1, (); |
299 |
|
|
last RP; |
300 |
|
|
} |
301 |
|
|
} # RP |
302 |
|
|
} else { |
303 |
|
|
@{$$new_child_parent->{child_nodes}} = (); |
304 |
|
|
} |
305 |
|
|
} |
306 |
|
|
|
307 |
|
|
## -- Rewrite the |parentNode| properties |
308 |
|
|
for my $nc (@new_child) { |
309 |
|
|
$$nc->{parent_node} = $self; |
310 |
|
|
Scalar::Util::weaken ($$nc->{parent_node}); |
311 |
|
|
} |
312 |
|
|
|
313 |
|
|
## NOTE: Depends on method: |
314 |
|
|
if ($index == -1) { |
315 |
|
|
push @{$$self->{child_nodes}}, @new_child; |
316 |
|
|
} else { |
317 |
|
|
splice @{$$self->{child_nodes}}, $index, 0, @new_child; |
318 |
|
|
} |
319 |
|
|
|
320 |
|
|
## NOTE: Setting |owner_document| in |Document|. |
321 |
|
|
|
322 |
|
|
return $_[1]; |
323 |
|
|
} # insert_before |
324 |
|
|
|
325 |
|
|
sub replace_child ($$) { |
326 |
|
|
my $self = $_[0]; |
327 |
|
|
|
328 |
|
|
## NOTE: Depends on $self->node_type: |
329 |
|
|
my $self_od = $$self->{owner_document}; |
330 |
|
|
|
331 |
|
|
## -- Node Type check |
332 |
|
|
my @new_child; |
333 |
|
|
my $new_child_parent; |
334 |
|
|
if ($_[1]->node_type == 11) { # DOCUMENT_FRAGMENT_NODE |
335 |
|
|
push @new_child, @{$_[1]->child_nodes}; |
336 |
|
|
$new_child_parent = $_[1]; |
337 |
|
|
} else { |
338 |
|
|
@new_child = ($_[1]); |
339 |
|
|
$new_child_parent = $_[1]->parent_node; |
340 |
|
|
} |
341 |
|
|
|
342 |
|
|
## NOTE: Depends on $self->node_type: |
343 |
|
|
if ($$self_od->{strict_error_checking}) { |
344 |
|
|
my $child_od = $_[1]->owner_document || $_[1]; # might be DocumentType |
345 |
|
|
if ($self_od ne $child_od and $child_od->node_type != 10) { |
346 |
|
|
report Message::DOM::DOMException # DOCUMENT_TYPE_NODE |
347 |
|
|
-object => $self, |
348 |
|
|
-type => 'WRONG_DOCUMENT_ERR', |
349 |
|
|
-subtype => 'EXTERNAL_OBJECT_ERR'; |
350 |
|
|
} |
351 |
|
|
|
352 |
|
|
if ($$self->{manakai_read_only} or |
353 |
|
|
(@new_child and defined $new_child_parent and |
354 |
|
|
$$new_child_parent->{manakai_read_only})) { |
355 |
|
|
report Message::DOM::DOMException |
356 |
|
|
-object => $self, |
357 |
|
|
-type => 'NO_MODIFICATION_ALLOWED_ERR', |
358 |
|
|
-subtype => 'READ_ONLY_NODE_ERR'; |
359 |
|
|
} |
360 |
|
|
|
361 |
|
|
## NOTE: |Document| has children order check here. |
362 |
|
|
|
363 |
|
|
for my $cn (@new_child) { |
364 |
|
|
unless ({ |
365 |
|
|
3, 1, 5, 1, # TEXT_NODE, ENTITY_REFERENCE_NODE |
366 |
|
|
}->{$cn->node_type}) { |
367 |
|
|
report Message::DOM::DOMException |
368 |
|
|
-object => $self, |
369 |
|
|
-type => 'HIERARCHY_REQUEST_ERR', |
370 |
|
|
-subtype => 'CHILD_NODE_TYPE_ERR'; |
371 |
|
|
} |
372 |
|
|
} |
373 |
|
|
|
374 |
|
|
## NOTE: Ancestor check here in |Node|. |
375 |
|
|
} |
376 |
|
|
|
377 |
|
|
## -- Insert at... ## NOTE: Only in insertBefore and replaceChild |
378 |
|
|
my $index = -1; # last |
379 |
|
|
if (defined $_[2]) { |
380 |
|
|
## error if $_[1] eq $_[2]; |
381 |
|
|
|
382 |
|
|
my $cns = $self->child_nodes; |
383 |
|
|
my $cnsl = @$cns; |
384 |
|
|
C: { |
385 |
|
|
$index = 0; |
386 |
|
|
for my $i (0..($cnsl-1)) { |
387 |
|
|
my $cn = $cns->[$i]; |
388 |
|
|
if ($cn eq $_[2]) { |
389 |
|
|
$index += $i; |
390 |
|
|
last C; |
391 |
|
|
} elsif ($cn eq $_[1]) { |
392 |
|
|
$index = -1; # offset |
393 |
|
|
} |
394 |
|
|
} |
395 |
|
|
|
396 |
|
|
report Message::DOM::DOMException |
397 |
|
|
-object => $self, |
398 |
|
|
-type => 'NOT_FOUND_ERR', |
399 |
|
|
-subtype => 'NOT_CHILD_ERR'; |
400 |
|
|
} # C |
401 |
|
|
} else { |
402 |
|
|
## NOTE: Only in replaceChild |
403 |
|
|
report Message::DOM::DOMException |
404 |
|
|
-object => $self, |
405 |
|
|
-type => 'NOT_FOUND_ERR', |
406 |
|
|
-subtype => 'NOT_CHILD_ERR'; |
407 |
|
|
} |
408 |
|
|
|
409 |
|
|
## -- Removes from parent |
410 |
|
|
if ($new_child_parent) { |
411 |
|
|
if (@new_child == 1) { |
412 |
|
|
my $v = $$new_child_parent->{child_nodes}; |
413 |
|
|
RP: for my $i (0..$#$v) { |
414 |
|
|
if ($v->[$i] eq $new_child[0]) { |
415 |
|
|
splice @$v, $i, 1, (); |
416 |
|
|
last RP; |
417 |
|
|
} |
418 |
|
|
} # RP |
419 |
|
|
} else { |
420 |
|
|
@{$$new_child_parent->{child_nodes}} = (); |
421 |
|
|
} |
422 |
|
|
} |
423 |
|
|
|
424 |
|
|
## -- Rewrite the |parentNode| properties |
425 |
|
|
for my $nc (@new_child) { |
426 |
|
|
$$nc->{parent_node} = $self; |
427 |
|
|
Scalar::Util::weaken ($$nc->{parent_node}); |
428 |
|
|
} |
429 |
|
|
|
430 |
|
|
## NOTE: Depends on method: |
431 |
|
|
splice @{$$self->{child_nodes}}, $index, 1, @new_child; |
432 |
|
|
delete ${$_[2]}->{parent_node}; |
433 |
|
|
|
434 |
|
|
## NOTE: Setting |owner_document| in |Document|. |
435 |
|
|
|
436 |
|
|
return $_[2]; |
437 |
|
|
} # replace_child |
438 |
|
|
|
439 |
wakaba |
1.6 |
## |Attr| attributes |
440 |
|
|
|
441 |
|
|
sub manakai_attribute_type ($;$) { |
442 |
|
|
my $self = $_[0]; |
443 |
|
|
if (@_ > 1) { |
444 |
|
|
if (${$$self->{owner_document}}->{strict_error_checking}) { |
445 |
|
|
if ($$self->{manakai_read_only}) { |
446 |
|
|
report Message::DOM::DOMException |
447 |
|
|
-object => $self, |
448 |
|
|
-type => 'NO_MODIFICATION_ALLOWED_ERR', |
449 |
|
|
-subtype => 'READ_ONLY_NODE_ERR'; |
450 |
|
|
} |
451 |
|
|
} |
452 |
|
|
if ($_[1]) { |
453 |
|
|
$$self->{manakai_attribute_type} = 0+$_[1]; |
454 |
|
|
} else { |
455 |
|
|
delete $$self->{manakai_attribute_type}; |
456 |
|
|
} |
457 |
|
|
} |
458 |
|
|
|
459 |
|
|
return $$self->{manakai_attribute_type} || 0; |
460 |
|
|
} # manakai_attribute_type |
461 |
wakaba |
1.1 |
|
462 |
wakaba |
1.10 |
sub is_id ($;$) { |
463 |
|
|
my $self = $_[0]; |
464 |
|
|
|
465 |
|
|
if (@_ > 1) { |
466 |
|
|
## NOTE: The setter is a manakai extension. |
467 |
|
|
## TODO: Document. |
468 |
|
|
|
469 |
|
|
if (${$$self->{owner_document}}->{strict_error_checking}) { |
470 |
|
|
if ($$self->{manakai_read_only}) { |
471 |
|
|
report Message::DOM::DOMException |
472 |
|
|
-object => $self, |
473 |
|
|
-type => 'NO_MODIFICATION_ALLOWED_ERR', |
474 |
|
|
-subtype => 'READ_ONLY_NODE_ERR'; |
475 |
|
|
} |
476 |
|
|
} |
477 |
|
|
|
478 |
|
|
if ($_[1]) { |
479 |
|
|
$$self->{manakai_user_determined_id} = 1; |
480 |
|
|
} else { |
481 |
|
|
delete $$self->{manakai_user_determined_id}; |
482 |
|
|
} |
483 |
|
|
} |
484 |
|
|
return unless defined wantarray; |
485 |
|
|
|
486 |
|
|
## DTD Attribute Type |
487 |
|
|
my $type = $$self->{manakai_attribute_type}; |
488 |
|
|
if (defined $type and $type == 2) { # ID_ATTR |
489 |
|
|
return 1; |
490 |
|
|
} |
491 |
|
|
|
492 |
|
|
## User-determined ID |
493 |
|
|
if ($$self->{manakai_user_determined_id}) { |
494 |
|
|
return 1; |
495 |
|
|
} |
496 |
|
|
|
497 |
|
|
## Application-determined ID |
498 |
|
|
my $nsuri = $self->namespace_uri; |
499 |
|
|
my $ln = $self->manakai_local_name; |
500 |
|
|
if (defined $nsuri) { |
501 |
|
|
if ($ln eq 'id') { |
502 |
|
|
if ($nsuri eq q<http://www.w3.org/XML/1998/namespace>) { |
503 |
|
|
return 1; |
504 |
|
|
} |
505 |
|
|
} |
506 |
|
|
} else { |
507 |
|
|
if ($ln eq 'xml:id') { |
508 |
|
|
return 1; |
509 |
|
|
} |
510 |
|
|
|
511 |
|
|
my $oe = $$self->{owner_element}; |
512 |
|
|
if ($oe) { |
513 |
|
|
my $oe_nsuri = $oe->namespace_uri; |
514 |
|
|
if (defined $oe_nsuri) { |
515 |
|
|
if ($ln eq 'id') { |
516 |
|
|
if ($oe_nsuri eq q<http://www.w3.org/1999/xhtml>) { |
517 |
|
|
return 1; |
518 |
|
|
} |
519 |
|
|
} |
520 |
|
|
} |
521 |
|
|
} |
522 |
|
|
} |
523 |
|
|
|
524 |
|
|
return 0; |
525 |
|
|
} # is_id |
526 |
|
|
|
527 |
wakaba |
1.1 |
## TODO: HTML5 case stuff? |
528 |
|
|
sub name ($) { |
529 |
|
|
my $self = shift; |
530 |
|
|
if (defined $$self->{prefix}) { |
531 |
|
|
return $$self->{prefix} . ':' . $$self->{local_name}; |
532 |
|
|
} else { |
533 |
|
|
return $$self->{local_name}; |
534 |
|
|
} |
535 |
|
|
} # name |
536 |
|
|
|
537 |
wakaba |
1.10 |
## TODO: Documentation |
538 |
|
|
sub manakai_name ($) { |
539 |
|
|
my $self = shift; |
540 |
|
|
if (defined $$self->{prefix}) { |
541 |
|
|
return $$self->{prefix} . ':' . $$self->{local_name}; |
542 |
|
|
} else { |
543 |
|
|
return $$self->{local_name}; |
544 |
|
|
} |
545 |
|
|
} # manakai_name |
546 |
|
|
|
547 |
|
|
sub schema_type_info ($) { |
548 |
|
|
require Message::DOM::TypeInfo; |
549 |
|
|
my $v = ${$_[0]}->{manakai_attribute_type} || 0; |
550 |
|
|
return bless \$v, 'Message::DOM::TypeInfo'; |
551 |
|
|
} # schema_type_info |
552 |
|
|
|
553 |
wakaba |
1.6 |
sub specified ($;$) { |
554 |
wakaba |
1.1 |
if (@_ > 1) { |
555 |
wakaba |
1.6 |
## NOTE: A manakai extension. |
556 |
|
|
if (${${$_[0]}->{owner_document}}->{strict_error_checking} and |
557 |
|
|
${$_[0]}->{manakai_read_only}) { |
558 |
|
|
report Message::DOM::DOMException |
559 |
|
|
-object => $_[0], |
560 |
|
|
-type => 'NO_MODIFICATION_ALLOWED_ERR', |
561 |
|
|
-subtype => 'READ_ONLY_NODE_ERR'; |
562 |
|
|
} |
563 |
|
|
if ($_[1] or not defined ${$_[0]}->{owner_element}) { |
564 |
|
|
${$_[0]}->{specified} = 1; |
565 |
|
|
} else { |
566 |
|
|
delete ${$_[0]}->{specified}; |
567 |
|
|
} |
568 |
wakaba |
1.1 |
} |
569 |
wakaba |
1.6 |
return ${$_[0]}->{specified}; |
570 |
|
|
} # specified |
571 |
|
|
|
572 |
wakaba |
1.9 |
*value = \&node_value; |
573 |
wakaba |
1.1 |
|
574 |
|
|
package Message::IF::Attr; |
575 |
|
|
|
576 |
|
|
package Message::DOM::Document; |
577 |
|
|
|
578 |
|
|
sub create_attribute ($$) { |
579 |
wakaba |
1.7 |
if (${$_[0]}->{strict_error_checking}) { |
580 |
|
|
my $xv = $_[0]->xml_version; |
581 |
|
|
## TODO: HTML Document ?? |
582 |
|
|
if (defined $xv) { |
583 |
|
|
if ($xv eq '1.0' and |
584 |
|
|
$_[1] =~ /\A\p{InXML_NameStartChar10}\p{InXMLNameChar10}*\z/) { |
585 |
|
|
# |
586 |
|
|
} elsif ($xv eq '1.1' and |
587 |
|
|
$_[1] =~ /\A\p{InXMLNameStartChar11}\p{InXMLNameChar11}*\z/) { |
588 |
|
|
# |
589 |
|
|
} else { |
590 |
|
|
report Message::DOM::DOMException |
591 |
|
|
-object => $_[0], |
592 |
|
|
-type => 'INVALID_CHARACTER_ERR', |
593 |
|
|
-subtype => 'MALFORMED_NAME_ERR'; |
594 |
|
|
} |
595 |
|
|
} |
596 |
|
|
} |
597 |
wakaba |
1.1 |
## TODO: HTML5 |
598 |
|
|
return Message::DOM::Attr->____new ($_[0], undef, undef, undef, $_[1]); |
599 |
|
|
} # create_attribute |
600 |
|
|
|
601 |
|
|
sub create_attribute_ns ($$$) { |
602 |
|
|
my ($prefix, $lname); |
603 |
|
|
if (ref $_[2] eq 'ARRAY') { |
604 |
|
|
($prefix, $lname) = @{$_[2]}; |
605 |
|
|
} else { |
606 |
|
|
($prefix, $lname) = split /:/, $_[2], 2; |
607 |
|
|
($prefix, $lname) = (undef, $prefix) unless defined $lname; |
608 |
|
|
} |
609 |
wakaba |
1.10 |
my $nsuri = defined $_[1] ? $_[1] eq '' ? undef : $_[1] : undef; |
610 |
wakaba |
1.7 |
|
611 |
|
|
if (${$_[0]}->{strict_error_checking}) { |
612 |
|
|
my $xv = $_[0]->xml_version; |
613 |
|
|
## TODO: HTML Document ?? (NOT_SUPPORTED_ERR is different from what Web browsers do) |
614 |
|
|
if (defined $xv) { |
615 |
|
|
if ($xv eq '1.0') { |
616 |
|
|
if (ref $_[2] eq 'ARRAY' or |
617 |
|
|
$_[2] =~ /\A\p{InXML_NameStartChar10}\p{InXMLNameChar10}*\z/) { |
618 |
|
|
if (defined $prefix) { |
619 |
|
|
if ($prefix =~ /\A\p{InXML_NCNameStartChar10}\p{InXMLNCNameChar10}*\z/) { |
620 |
|
|
# |
621 |
|
|
} else { |
622 |
|
|
report Message::DOM::DOMException |
623 |
|
|
-object => $_[0], |
624 |
|
|
-type => 'NAMESPACE_ERR', |
625 |
|
|
-subtype => 'MALFORMED_QNAME_ERR'; |
626 |
|
|
} |
627 |
|
|
} |
628 |
|
|
if ($lname =~ /\A\p{InXML_NCNameStartChar10}\p{InXMLNCNameChar10}*\z/) { |
629 |
|
|
# |
630 |
|
|
} else { |
631 |
|
|
report Message::DOM::DOMException |
632 |
|
|
-object => $_[0], |
633 |
|
|
-type => 'NAMESPACE_ERR', |
634 |
|
|
-subtype => 'MALFORMED_QNAME_ERR'; |
635 |
|
|
} |
636 |
|
|
} else { |
637 |
|
|
report Message::DOM::DOMException |
638 |
|
|
-object => $_[0], |
639 |
|
|
-type => 'INVALID_CHARACTER_ERR', |
640 |
|
|
-subtype => 'MALFORMED_NAME_ERR'; |
641 |
|
|
} |
642 |
|
|
} elsif ($xv eq '1.1') { |
643 |
|
|
if (ref $_[2] eq 'ARRAY' or |
644 |
|
|
$_[2] =~ /\A\p{InXML_NameStartChar10}\p{InXMLNameChar10}*\z/) { |
645 |
|
|
if (defined $prefix) { |
646 |
|
|
if ($prefix =~ /\A\p{InXMLNCNameStartChar11}\p{InXMLNCNameChar11}*\z/) { |
647 |
|
|
# |
648 |
|
|
} else { |
649 |
|
|
report Message::DOM::DOMException |
650 |
|
|
-object => $_[0], |
651 |
|
|
-type => 'NAMESPACE_ERR', |
652 |
|
|
-subtype => 'MALFORMED_QNAME_ERR'; |
653 |
|
|
} |
654 |
|
|
} |
655 |
|
|
if ($lname =~ /\A\p{InXMLNCNameStartChar11}\p{InXMLNCNameChar11}*\z/) { |
656 |
|
|
# |
657 |
|
|
} else { |
658 |
|
|
report Message::DOM::DOMException |
659 |
|
|
-object => $_[0], |
660 |
|
|
-type => 'NAMESPACE_ERR', |
661 |
|
|
-subtype => 'MALFORMED_QNAME_ERR'; |
662 |
|
|
} |
663 |
|
|
} else { |
664 |
|
|
report Message::DOM::DOMException |
665 |
|
|
-object => $_[0], |
666 |
|
|
-type => 'INVALID_CHARACTER_ERR', |
667 |
|
|
-subtype => 'MALFORMED_NAME_ERR'; |
668 |
|
|
} |
669 |
|
|
} else { |
670 |
|
|
die "create_attribute_ns: XML version |$xv| is not supported"; |
671 |
|
|
} |
672 |
|
|
} |
673 |
|
|
|
674 |
|
|
if (defined $prefix) { |
675 |
wakaba |
1.10 |
if (not defined $nsuri) { |
676 |
wakaba |
1.7 |
report Message::DOM::DOMException |
677 |
|
|
-object => $_[0], |
678 |
|
|
-type => 'NAMESPACE_ERR', |
679 |
|
|
-subtype => 'PREFIXED_NULLNS_ERR'; |
680 |
|
|
} elsif ($prefix eq 'xml' and |
681 |
wakaba |
1.10 |
$nsuri ne q<http://www.w3.org/XML/1998/namespace>) { |
682 |
wakaba |
1.7 |
report Message::DOM::DOMException |
683 |
|
|
-object => $_[0], |
684 |
|
|
-type => 'NAMESPACE_ERR', |
685 |
|
|
-subtype => 'XMLPREFIX_NONXMLNS_ERR'; |
686 |
|
|
} elsif ($prefix eq 'xmlns' and |
687 |
wakaba |
1.10 |
$nsuri ne q<http://www.w3.org/2000/xmlns/>) { |
688 |
wakaba |
1.7 |
report Message::DOM::DOMException |
689 |
|
|
-object => $_[0], |
690 |
|
|
-type => 'NAMESPACE_ERR', |
691 |
|
|
-subtype => 'XMLNSPREFIX_NONXMLNSNS_ERR'; |
692 |
wakaba |
1.10 |
} elsif ($nsuri eq q<http://www.w3.org/2000/xmlns/> and |
693 |
wakaba |
1.7 |
$prefix ne 'xmlns') { |
694 |
|
|
report Message::DOM::DOMException |
695 |
|
|
-object => $_[0], |
696 |
|
|
-type => 'NAMESPACE_ERR', |
697 |
|
|
-subtype => 'NONXMLNSPREFIX_XMLNSNS_ERR'; |
698 |
|
|
} |
699 |
|
|
} else { # no prefix |
700 |
|
|
if ($lname eq 'xmlns' and |
701 |
wakaba |
1.10 |
(not defined $nsuri or $nsuri ne q<http://www.w3.org/2000/xmlns/>)) { |
702 |
wakaba |
1.7 |
report Message::DOM::DOMException |
703 |
|
|
-object => $_[0], |
704 |
|
|
-type => 'NAMESPACE_ERR', |
705 |
|
|
-subtype => 'XMLNS_NONXMLNSNS_ERR'; |
706 |
wakaba |
1.10 |
} elsif (not defined $nsuri) { |
707 |
wakaba |
1.7 |
# |
708 |
wakaba |
1.10 |
} elsif ($nsuri eq q<http://www.w3.org/2000/xmlns/> and |
709 |
wakaba |
1.7 |
$lname ne 'xmlns') { |
710 |
|
|
report Message::DOM::DOMException |
711 |
|
|
-object => $_[0], |
712 |
|
|
-type => 'NAMESPACE_ERR', |
713 |
|
|
-subtype => 'NONXMLNSPREFIX_XMLNSNS_ERR'; |
714 |
|
|
} |
715 |
|
|
} |
716 |
|
|
} |
717 |
|
|
|
718 |
|
|
## TODO: Older version of manakai set |attribute_type| |
719 |
|
|
## attribute for |xml:id| attribute. Should we support this? |
720 |
|
|
|
721 |
wakaba |
1.10 |
return Message::DOM::Attr->____new ($_[0], undef, $nsuri, $prefix, $lname); |
722 |
wakaba |
1.7 |
} # create_attribute_ns |
723 |
|
|
|
724 |
|
|
=head1 LICENSE |
725 |
|
|
|
726 |
|
|
Copyright 2007 Wakaba <w@suika.fam.cx> |
727 |
|
|
|
728 |
|
|
This program is free software; you can redistribute it and/or |
729 |
|
|
modify it under the same terms as Perl itself. |
730 |
|
|
|
731 |
|
|
=cut |
732 |
wakaba |
1.1 |
|
733 |
|
|
1; |
734 |
wakaba |
1.11 |
## $Date: 2007/07/14 06:12:56 $ |