/[suikacvs]/messaging/manakai/lib/Message/DOM/Element.pm
Suika

Contents of /messaging/manakai/lib/Message/DOM/Element.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.28 - (hide annotations) (download)
Mon Jan 14 13:56:35 2008 UTC (16 years, 10 months ago) by wakaba
Branch: MAIN
Changes since 1.27: +8 -2 lines
++ manakai/lib/Message/DOM/ChangeLog	14 Jan 2008 13:56:26 -0000
	* CSSStyleDeclaration.pm (AUTOLOAD): DOM attributes reflecting
	shorthand properties did croak (fixed but still they does not
	return correct result - they need to be fixed later).

	* Element.pm (query_selector, query_selector_all): Prototypes
	were missing.

2008-01-14  Wakaba  <wakaba@suika.fam.cx>

1 wakaba 1.22 ## NOTE: This module will be renamed as Element.pm.
2    
3     package Message::DOM::Element;
4 wakaba 1.1 use strict;
5 wakaba 1.28 our $VERSION=do{my @r=(q$Revision: 1.27 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
6 wakaba 1.24 push our @ISA, 'Message::DOM::Node', 'Message::IF::Element',
7 wakaba 1.26 'Message::IF::ElementSelector', # MUST in Selectors API spec.
8     'Message::IF::ElementCSSInlineStyle';
9 wakaba 1.9 require Message::DOM::Document;
10 wakaba 1.22
11     sub ____new ($$$$$) {
12     my $self = shift->SUPER::____new (shift);
13     ($$self->{namespace_uri},
14     $$self->{prefix},
15     $$self->{local_name}) = @_;
16     $$self->{attributes} = {};
17     $$self->{child_nodes} = [];
18     return $self;
19     } # ____new
20    
21 wakaba 1.10 sub AUTOLOAD {
22 wakaba 1.22 my $method_name = our $AUTOLOAD;
23     $method_name =~ s/.*:://;
24     return if $method_name eq 'DESTROY';
25 wakaba 1.10
26 wakaba 1.22 if ({
27     ## Read-only attributes (trivial accessors)
28     namespace_uri => 1,
29     }->{$method_name}) {
30     no strict 'refs';
31     eval qq{
32     sub $method_name (\$) {
33     return \${\$_[0]}->{$method_name};
34     }
35     };
36     goto &{ $AUTOLOAD };
37     } elsif ({
38     ## Read-write attributes (DOMString, trivial accessors)
39     manakai_base_uri => 1,
40     }->{$method_name}) {
41     no strict 'refs';
42     eval qq{
43     sub $method_name (\$;\$) {
44     if (\@_ > 1) {
45     if (\${\${\$_[0]}->{owner_document}}->{strict_error_checking} and
46     \${\$_[0]}->{manakai_read_only}) {
47     report Message::DOM::DOMException
48     -object => \$_[0],
49     -type => 'NO_MODIFICATION_ALLOWED_ERR',
50     -subtype => 'READ_ONLY_NODE_ERR';
51     }
52     if (defined \$_[1]) {
53     \${\$_[0]}->{$method_name} = ''.\$_[1];
54     } else {
55     delete \${\$_[0]}->{$method_name};
56     }
57 wakaba 1.10 }
58 wakaba 1.22 return \${\$_[0]}->{$method_name};
59     }
60     };
61     goto &{ $AUTOLOAD };
62 wakaba 1.24 } elsif (my $module_name = {
63     query_selector => 'Message::DOM::SelectorsAPI',
64     query_selector_all => 'Message::DOM::SelectorsAPI',
65     }->{$method_name}) {
66     eval qq{ require $module_name } or die $@;
67     goto &{ $AUTOLOAD };
68 wakaba 1.22 } else {
69     require Carp;
70     Carp::croak (qq<Can't locate method "$AUTOLOAD">);
71     }
72     } # AUTOLOAD
73 wakaba 1.10
74 wakaba 1.22 ## TODO: Test for create_element_ns ('', ...)
75 wakaba 1.10
76 wakaba 1.22 ## |Node| attributes
77 wakaba 1.9
78 wakaba 1.22 sub attributes ($) {
79     require Message::DOM::NamedNodeMap;
80     return bless \\($_[0]), 'Message::DOM::NamedNodeMap::AttrMap';
81     } # attributes
82 wakaba 1.9
83 wakaba 1.22 sub base_uri ($) {
84     my $self = $_[0];
85     return $$self->{manakai_base_uri} if defined $$self->{manakai_base_uri};
86 wakaba 1.9
87 wakaba 1.22 local $Error::Depth = $Error::Depth + 1;
88     my $xb = $self->get_attribute_node_ns
89     ('http://www.w3.org/XML/1998/namespace', 'base');
90     unless (defined $xb) {
91     $xb = $self->get_attribute_node_ns (undef, 'xml:base');
92     }
93 wakaba 1.9
94 wakaba 1.22 if ($xb) {
95     my $v = $self->owner_document->implementation->create_uri_reference
96     ($xb->value);
97     if (not defined $v->uri_scheme) { # Relative reference
98     my $xbbase = $xb->base_uri;
99     if (defined $xbbase) {
100     return $v->get_absolute_reference ($xbbase)->uri_reference;
101     }
102     }
103     return $v->uri_reference;
104     }
105 wakaba 1.9
106 wakaba 1.22 my $pe = $$self->{parent_node};
107     while (defined $pe) {
108     my $nt = $pe->node_type;
109     if ($nt == 1 or $nt == 6 or $nt == 9 or $nt == 11) {
110     ## Element, Entity, Document, or DocumentFragment
111     return $pe->base_uri;
112     } elsif ($nt == 5) {
113     ## EntityReference
114     if ($pe->manakai_external) {
115     return $pe->manakai_entity_base_uri;
116     }
117 wakaba 1.9 }
118 wakaba 1.22 $pe = $$pe->{parent_node};
119     }
120     return $pe->base_uri if $pe;
121     return $$self->{owner_document}->base_uri;
122     } # base_uri
123 wakaba 1.9
124 wakaba 1.22 sub local_name ($) { # TODO: HTML5 case
125     return ${$_[0]}->{local_name};
126     } # local_name
127 wakaba 1.9
128 wakaba 1.22 sub manakai_local_name ($) {
129     return ${$_[0]}->{local_name};
130     } # manakai_local_name
131 wakaba 1.9
132 wakaba 1.22 sub namespace_uri ($);
133 wakaba 1.9
134 wakaba 1.22 ## The tag name of the element [DOM1, DOM2].
135     ## Same as |Element.tagName| [DOM3].
136 wakaba 1.9
137 wakaba 1.22 *node_name = \&tag_name;
138 wakaba 1.9
139 wakaba 1.22 sub node_type () { 1 } # ELEMENT_NODE
140 wakaba 1.9
141 wakaba 1.22 sub prefix ($;$) {
142     ## NOTE: No check for new value as Firefox doesn't do.
143     ## See <http://suika.fam.cx/gate/2005/sw/prefix>.
144 wakaba 1.9
145 wakaba 1.22 ## NOTE: Same as trivial setter except "" -> undef
146 wakaba 1.9
147 wakaba 1.22 ## NOTE: Same as |Attr|'s |prefix|.
148    
149     if (@_ > 1) {
150     if (${$_[0]}->{manakai_read_only}) {
151     report Message::DOM::DOMException
152     -object => $_[0],
153     -type => 'NO_MODIFICATION_ALLOWED_ERR',
154     -subtype => 'READ_ONLY_NODE_ERR';
155     }
156     if (defined $_[1] and $_[1] ne '') {
157     ${$_[0]}->{prefix} = ''.$_[1];
158     } else {
159     delete ${$_[0]}->{prefix};
160     }
161     }
162     return ${$_[0]}->{prefix};
163     } # prefix
164 wakaba 1.9
165 wakaba 1.22 ## |Element| attributes
166 wakaba 1.9
167 wakaba 1.22 sub manakai_base_uri ($;$);
168 wakaba 1.9
169 wakaba 1.22 ## Defined in |HTMLElement| interface of HTML5
170     sub inner_html ($;$) {
171     my $self = $_[0];
172 wakaba 1.9
173 wakaba 1.22 ## TODO: Setter
174 wakaba 1.9
175 wakaba 1.22 if (${$$self->{owner_document}}->{manakai_is_html}) {
176 wakaba 1.25 require Whatpm::HTML::Serializer;
177     return ${ Whatpm::HTML::Serializer->get_inner_html ($self) };
178 wakaba 1.22 } else {
179     ## TODO: This serializer is not currenly conformant to HTML5.
180     require Whatpm::XMLSerializer;
181     my $r = '';
182     for (@{$self->child_nodes}) {
183     $r .= ${ Whatpm::XMLSerializer->get_outer_xml ($_) };
184     }
185     return $r;
186     }
187     } # inner_html
188 wakaba 1.9
189 wakaba 1.22 sub schema_type_info ($) {
190     require Message::DOM::TypeInfo;
191     my $v = 0;
192     return bless \$v, 'Message::DOM::TypeInfo';
193     ## NOTE: Currently manakai does not support XML Schema, so it is
194     ## always a no-type |TypeInfo|. It is expected that
195     ## a future version of the implementation will return an
196     ## element type definition node that also implement the
197     ## |TypeInfo| interface when the schema language is XML DTD.
198     } # schema_type_info
199 wakaba 1.9
200 wakaba 1.22 ## TODO: HTML5 capitalization
201     sub tag_name ($) {
202     my $self = shift;
203     if (defined $$self->{prefix}) {
204     return $$self->{prefix} . ':' . $$self->{local_name};
205     } else {
206     return $$self->{local_name};
207     }
208     } # tag_name
209 wakaba 1.9
210 wakaba 1.22 ## TODO: Documentation
211     sub manakai_tag_name ($) {
212     my $self = shift;
213     if (defined $$self->{prefix}) {
214     return $$self->{prefix} . ':' . $$self->{local_name};
215     } else {
216     return $$self->{local_name};
217     }
218     } # manakai_tag_name
219 wakaba 1.9
220 wakaba 1.22 ## The |Element| interface - methods
221 wakaba 1.9
222 wakaba 1.22 sub manakai_element_type_match ($$$) {
223     my ($self, $nsuri, $ln) = @_;
224     if (defined $nsuri) {
225     if (defined $$self->{namespace_uri} and $nsuri eq $$self->{namespace_uri}) {
226     return ($ln eq $$self->{local_name});
227     } else {
228     return 0;
229 wakaba 1.9 }
230     } else {
231 wakaba 1.22 if (not defined $$self->{namespace_uri}) {
232     return ($ln eq $$self->{local_name});
233     } else {
234     return 0;
235 wakaba 1.9 }
236     }
237 wakaba 1.22 } # manakai_element_type_match
238 wakaba 1.9
239 wakaba 1.22 sub get_attribute ($$) {
240     my $attr = ${$_[0]}->{attributes};
241     my $name = ''.$_[1];
242 wakaba 1.9
243 wakaba 1.22 ## NOTE: |sort|ing is required so that every |getAttribute|, |setAttribute|,
244     ## |hasAttribute|, |removeAttribute|, or any other namespace unaware
245     ## methods operates on the same node even if there is
246     ## multiple nodes with the same qualified name.
247 wakaba 1.9
248 wakaba 1.22 ## NOTE: Same as |get_attribute_node|, except what is returned.
249 wakaba 1.9
250 wakaba 1.22 for my $ns (sort {$a cmp $b} keys %$attr) {
251     for my $ln (sort {$a cmp $b} keys %{$attr->{$ns}}) {
252     my $node = $attr->{$ns}->{$ln};
253     if ($node->manakai_name eq $name) {
254     return $node->value;
255     }
256     }
257 wakaba 1.9 }
258    
259 wakaba 1.22 return undef;
260     } # get_attribute
261 wakaba 1.9
262 wakaba 1.22 sub get_attribute_node ($$) {
263     my $attr = ${$_[0]}->{attributes};
264     my $name = ''.$_[1];
265 wakaba 1.9
266 wakaba 1.22 ## NOTE: Same as |get_attribute|, except what is returned.
267 wakaba 1.9
268 wakaba 1.22 for my $ns (sort {$a cmp $b} keys %$attr) {
269     for my $ln (sort {$a cmp $b} keys %{$attr->{$ns}}) {
270     my $node = $attr->{$ns}->{$ln};
271     if ($node->manakai_name eq $name) {
272     return $node;
273     }
274 wakaba 1.13 }
275 wakaba 1.18 }
276 wakaba 1.9
277 wakaba 1.22 return undef;
278     } # get_attribute_node
279 wakaba 1.9
280 wakaba 1.22 sub get_attribute_ns ($$$) {
281     my $nsuri = defined $_[1] ? ''.$_[1] : '';
282     my $ln = ''.$_[2];
283     if (my $attr = ${$_[0]}->{attributes}->{$nsuri}->{$ln}) {
284     return $attr->value;
285 wakaba 1.9 } else {
286 wakaba 1.22 return undef;
287 wakaba 1.9 }
288 wakaba 1.22 } # get_attribute_ns
289 wakaba 1.9
290 wakaba 1.22 sub get_attribute_node_ns ($$$) {
291     return ${$_[0]}->{attributes}->{defined $_[1] ? ''.$_[1] : ''}->{''.$_[2]};
292     } # get_attribute_node_ns
293 wakaba 1.9
294 wakaba 1.22 *get_elements_by_tag_name = \&Message::DOM::Document::get_elements_by_tag_name;
295 wakaba 1.9
296 wakaba 1.22 *get_elements_by_tag_name_ns
297     = \&Message::DOM::Document::get_elements_by_tag_name_ns;
298 wakaba 1.13
299 wakaba 1.22 sub has_attribute ($$) {
300     my $attr = ${$_[0]}->{attributes};
301     my $name = ''.$_[1];
302 wakaba 1.13
303 wakaba 1.22 for my $ns (keys %$attr) {
304     for my $ln (keys %{$attr->{$ns}}) {
305     my $node = $attr->{$ns}->{$ln};
306     if ($node->manakai_name eq $name) {
307     return 1;
308     }
309     }
310     }
311 wakaba 1.13
312 wakaba 1.22 return 0;
313     } # has_attribute
314 wakaba 1.9
315 wakaba 1.22 sub has_attribute_ns ($$$) {
316     return ${$_[0]}->{attributes}->{defined $_[1] ? ''.$_[1] : ''}->{''.$_[2]}?1:0;
317     } # has_attribute_ns
318 wakaba 1.9
319 wakaba 1.22 sub remove_attribute ($$) {
320     my $attr = ${$_[0]}->{attributes};
321     my $name = ''.$_[1];
322 wakaba 1.9
323 wakaba 1.22 my $list;
324     my $key;
325     my $attr_node;
326     ATTR: {
327     for my $ns (keys %$attr) {
328     $list = $attr->{$ns};
329     for my $ln (keys %$list) {
330     $attr_node = $list->{$ln};
331     if ($attr_node->manakai_name eq $name) {
332     $key = $ln;
333     last ATTR;
334     }
335     }
336     }
337    
338     return undef; # not found
339     } # ATTR
340 wakaba 1.9
341 wakaba 1.22 my $od = ${$_[0]}->{owner_document};
342     if ($$od->{strict_error_checking} and ${$_[0]}->{manakai_read_only}) {
343     report Message::DOM::DOMException
344     -object => $_[0],
345     -type => 'NO_MODIFICATION_ALLOWED_ERR',
346     -subtype => 'READ_ONLY_NODE_ERR';
347     }
348 wakaba 1.9
349 wakaba 1.22 delete $list->{$key};
350     delete $$attr_node->{owner_element};
351     $$attr_node->{specified} = 1;
352     delete ${$_[0]}->{manakai_content_attribute_list};
353 wakaba 1.9
354 wakaba 1.22 ## Default attribute
355     local $Error::Depth = $Error::Depth + 1;
356     my $cfg = $od->dom_config;
357     if ($cfg->get_parameter
358     (q<http://suika.fam.cx/www/2006/dom-config/dtd-default-attribute>)) {
359     my $doctype = $od->doctype;
360     if ($doctype) {
361     my $et = $doctype->get_element_type_definition_node
362     ($_[0]->manakai_tag_name);
363     if ($et) {
364     my $at = $et->get_attribute_definition_node ($name);
365     if ($at) {
366     local $$od->{strict_error_checking} = 0;
367     my $copy_asis = $cfg->get_parameter
368     (q<http://suika.fam.cx/www/2006/dom-config/clone-entity-reference-subtree>);
369     $cfg->set_parameter
370     (q<http://suika.fam.cx/www/2006/dom-config/clone-entity-reference-subtree> => 1);
371     ADD: {
372     my $def_attr_node;
373     my $def_prefix = $attr_node->prefix;
374     my $def_nsuri = '';
375     my $def_ln;
376     if (defined $def_prefix) {
377     $def_nsuri =
378     $def_prefix eq 'xml' ? q<http://www.w3.org/XML/1998/namespace>:
379     $def_prefix eq 'xmlns' ? q<http://www.w3.org/2000/xmlns/>:
380     $_[0]->lookup_namespace_uri ($def_prefix);
381     unless (defined $def_nsuri) {
382     ## TODO: Namespace well-formedness error...
383 wakaba 1.9 }
384 wakaba 1.22 $def_ln = $attr_node->manakai_local_name;
385 wakaba 1.9 } else {
386 wakaba 1.22 $def_nsuri = $name eq 'xmlns'
387     ? q<http://www.w3.org/2000/xmlns/> : undef;
388     $def_ln = $name;
389 wakaba 1.9 }
390 wakaba 1.22 if ($attr->{defined $def_nsuri ? $def_nsuri : ''}->{$def_ln}) {
391     ## TODO: Namespace well-formedness warning?
392     last ADD;
393 wakaba 1.9 }
394 wakaba 1.22 $def_attr_node = $od->create_attribute_ns
395     ($def_nsuri, [$def_prefix, $def_ln]);
396    
397     for my $child (@{$at->child_nodes}) {
398     $def_attr_node->append_child ($child->clone_node (1));
399 wakaba 1.9 }
400 wakaba 1.22 $def_attr_node->manakai_attribute_type ($at->declared_type);
401     $attr->{defined $def_nsuri ? $def_nsuri : ''}->{$def_ln}
402     = $def_attr_node;
403     $$def_attr_node->{owner_element} = $_[0];
404     Scalar::Util::weaken ($$def_attr_node->{owner_element});
405     delete $$def_attr_node->{specified};
406     } # ADD
407     $cfg->set_parameter
408     (q<http://suika.fam.cx/www/2006/dom-config/clone-entity-reference-subtree> => $copy_asis);
409 wakaba 1.9 }
410 wakaba 1.22 }
411 wakaba 1.9 }
412 wakaba 1.22 }
413 wakaba 1.9
414 wakaba 1.22 return undef;
415     } # remove_attribute
416 wakaba 1.9
417 wakaba 1.22 sub remove_attribute_node ($$) {
418     my $od = ${$_[0]}->{owner_document};
419     if ($$od->{strict_error_checking} and ${$_[0]}->{manakai_read_only}) {
420     report Message::DOM::DOMException
421     -object => $_[0],
422     -type => 'NO_MODIFICATION_ALLOWED_ERR',
423     -subtype => 'READ_ONLY_NODE_ERR';
424     }
425    
426     my $attr_node = $_[1];
427     my $ln = $attr_node->manakai_local_name;
428     my $attr = ${$_[0]}->{attributes};
429     FIND: {
430     my $nsuri = $attr_node->namespace_uri;
431     my $list = $attr->{defined $nsuri ? $nsuri : ''};
432     my $list_node = $list->{$ln};
433     if (defined $list_node and $list_node eq $attr_node) {
434     delete $list->{$ln};
435     last FIND;
436     }
437    
438     report Message::DOM::DOMException
439     -object => $_[0],
440     -type => 'NOT_FOUND_ERR',
441     -subtype => 'NOT_CHILD_ERR';
442     } # FIND
443    
444     delete ${$_[0]}->{manakai_content_attribute_list};
445     delete $$attr_node->{owner_element};
446     $$attr_node->{specified} = 1;
447 wakaba 1.9
448 wakaba 1.22 ## Default attribute
449     ## Same as |remove_attribute|'s, except where marked as "***".
450     local $Error::Depth = $Error::Depth + 1;
451     my $cfg = $od->dom_config;
452     if ($cfg->get_parameter
453     (q<http://suika.fam.cx/www/2006/dom-config/dtd-default-attribute>)) {
454     my $doctype = $od->doctype;
455     if ($doctype) {
456     my $et = $doctype->get_element_type_definition_node
457     ($_[0]->manakai_tag_name);
458     if ($et) {
459     my $at = $et->get_attribute_definition_node ($_[1]->manakai_name); # ***
460     if ($at) {
461     local $$od->{strict_error_checking} = 0;
462     my $copy_asis = $cfg->get_parameter
463     (q<http://suika.fam.cx/www/2006/dom-config/clone-entity-reference-subtree>);
464     $cfg->set_parameter
465     (q<http://suika.fam.cx/www/2006/dom-config/clone-entity-reference-subtree> => 1);
466     ADD: {
467     my $def_attr_node;
468     my $def_prefix = $attr_node->prefix;
469     my $def_nsuri = '';
470     my $def_ln;
471     if (defined $def_prefix) {
472     $def_nsuri =
473     $def_prefix eq 'xml' ? q<http://www.w3.org/XML/1998/namespace>:
474     $def_prefix eq 'xmlns' ? q<http://www.w3.org/2000/xmlns/>:
475     $_[0]->lookup_namespace_uri ($def_prefix);
476     unless (defined $def_nsuri) {
477     ## TODO: Namespace well-formedness error...
478     }
479     $def_ln = $attr_node->manakai_local_name;
480     } else {
481     $def_nsuri = $attr_node->manakai_name eq 'xmlns'
482     ? q<http://www.w3.org/2000/xmlns/> : undef;
483     $def_ln = $attr_node->manakai_local_name; ## ***
484     }
485     if ($attr->{defined $def_nsuri ? $def_nsuri : ''}->{$def_ln}) {
486     ## TODO: Namespace well-formedness warning?
487     last ADD;
488     }
489     $def_attr_node = $od->create_attribute_ns
490     ($def_nsuri, [$def_prefix, $def_ln]);
491    
492     for my $child (@{$at->child_nodes}) {
493     $def_attr_node->append_child ($child->clone_node (1));
494     }
495     $def_attr_node->manakai_attribute_type ($at->declared_type);
496     $attr->{defined $def_nsuri ? $def_nsuri : ''}->{$def_ln}
497     = $def_attr_node;
498     $$def_attr_node->{owner_element} = $_[0];
499     Scalar::Util::weaken ($$def_attr_node->{owner_element});
500     delete $$def_attr_node->{specified};
501     } # ADD
502     $cfg->set_parameter
503     (q<http://suika.fam.cx/www/2006/dom-config/clone-entity-reference-subtree> => $copy_asis);
504     }
505     }
506 wakaba 1.9 }
507 wakaba 1.22 }
508 wakaba 1.9
509 wakaba 1.22 return $_[1];
510     } # remove_attribute_node
511 wakaba 1.9
512 wakaba 1.22 sub remove_attribute_ns ($$$) {
513     my $attr = ${$_[0]}->{attributes};
514 wakaba 1.9
515 wakaba 1.22 my $list = $attr->{defined $_[1] ? $_[1] : ''};
516     my $key = ''.$_[2];
517     my $attr_node = $list->{$key};
518     return undef unless defined $attr_node;
519    
520     ## NOTE: Anything below is same as |remove_attribute|'s except "***"
521    
522     my $od = ${$_[0]}->{owner_document};
523     if ($$od->{strict_error_checking} and ${$_[0]}->{manakai_read_only}) {
524     report Message::DOM::DOMException
525     -object => $_[0],
526     -type => 'NO_MODIFICATION_ALLOWED_ERR',
527     -subtype => 'READ_ONLY_NODE_ERR';
528     }
529    
530     delete $list->{$key};
531     delete $$attr_node->{owner_element};
532     $$attr_node->{specified} = 1;
533     delete ${$_[0]}->{manakai_content_attribute_list};
534 wakaba 1.9
535 wakaba 1.22 ## Default attribute
536     local $Error::Depth = $Error::Depth + 1;
537     my $cfg = $od->dom_config;
538     if ($cfg->get_parameter
539     (q<http://suika.fam.cx/www/2006/dom-config/dtd-default-attribute>)) {
540     my $doctype = $od->doctype;
541     if ($doctype) {
542     my $et = $doctype->get_element_type_definition_node
543     ($_[0]->manakai_tag_name);
544     if ($et) {
545     my $at = $et->get_attribute_definition_node
546     ($attr_node->manakai_name); # ***
547     if ($at) {
548     local $$od->{strict_error_checking} = 0;
549     my $copy_asis = $cfg->get_parameter
550     (q<http://suika.fam.cx/www/2006/dom-config/clone-entity-reference-subtree>);
551     $cfg->set_parameter
552     (q<http://suika.fam.cx/www/2006/dom-config/clone-entity-reference-subtree> => 1);
553     ADD: {
554     my $def_attr_node;
555     my $def_prefix = $attr_node->prefix;
556     my $def_nsuri = '';
557     my $def_ln;
558     if (defined $def_prefix) {
559     $def_nsuri =
560     $def_prefix eq 'xml' ? q<http://www.w3.org/XML/1998/namespace>:
561     $def_prefix eq 'xmlns' ? q<http://www.w3.org/2000/xmlns/>:
562     $_[0]->lookup_namespace_uri ($def_prefix);
563     unless (defined $def_nsuri) {
564     ## TODO: Namespace well-formedness error...
565     }
566     } else {
567     $def_nsuri = $attr_node->manakai_name eq 'xmlns'
568     ? q<http://www.w3.org/2000/xmlns/> : undef;
569     }
570     $def_ln = $attr_node->manakai_local_name; # ***
571     if ($attr->{defined $def_nsuri ? $def_nsuri : ''}->{$def_ln}) {
572     ## TODO: Namespace well-formedness warning?
573     last ADD;
574     }
575     $def_attr_node = $od->create_attribute_ns
576     ($def_nsuri, [$def_prefix, $def_ln]);
577    
578     for my $child (@{$at->child_nodes}) {
579     $def_attr_node->append_child ($child->clone_node (1));
580     }
581     $def_attr_node->manakai_attribute_type ($at->declared_type);
582     $attr->{defined $def_nsuri ? $def_nsuri : ''}->{$def_ln}
583     = $def_attr_node;
584     $$def_attr_node->{owner_element} = $_[0];
585     Scalar::Util::weaken ($$def_attr_node->{owner_element});
586     delete $$def_attr_node->{specified};
587     } # ADD
588     $cfg->set_parameter
589     (q<http://suika.fam.cx/www/2006/dom-config/clone-entity-reference-subtree> => $copy_asis);
590     }
591     }
592 wakaba 1.9 }
593 wakaba 1.22 }
594 wakaba 1.9
595 wakaba 1.22 return undef;
596     } # remove_attribute_ns
597 wakaba 1.9
598 wakaba 1.22 sub set_attribute ($$$) {
599     my $od = ${$_[0]}->{owner_document};
600     if ($$od->{strict_error_checking}) {
601     if (${$_[0]}->{manakai_read_only}) {
602     report Message::DOM::DOMException
603     -object => $_[0],
604     -type => 'NO_MODIFICATION_ALLOWED_ERR',
605     -subtype => 'READ_ONLY_NODE_ERR';
606 wakaba 1.9 }
607 wakaba 1.22 }
608 wakaba 1.9
609 wakaba 1.22 my $name = ''.$_[1];
610     my $attr = ${$_[0]}->{attributes};
611     my $attr_node;
612     NS: for my $ns (keys %$attr) {
613     for my $ln (keys %{$attr->{$ns}}) {
614     my $node = $attr->{$ns}->{$ln};
615     if ($node->manakai_name eq $name) {
616     $attr_node = $node;
617     last NS;
618     }
619 wakaba 1.9 }
620     }
621    
622 wakaba 1.22 local $Error::Depth = $Error::Depth + 1;
623     if (defined $attr_node) {
624     if ($$od->{strict_error_checking}) {
625     $od->create_attribute ($name); # or exception
626     }
627     } else {
628     $attr_node = $od->create_attribute ($name); # return or exception
629     delete ${$_[0]}->{manakai_content_attribute_list};
630     $attr->{''}->{$name} = $attr_node;
631     $$attr_node->{owner_element} = $_[0];
632     Scalar::Util::weaken ($$attr_node->{owner_element});
633    
634     if ($od->dom_config->get_parameter
635     (q<http://suika.fam.cx/www/2006/dom-config/dtd-attribute-type>)) {
636     my $doctype = $od->doctype;
637     if (defined $doctype) {
638     my $et = $doctype->get_element_type_definition_node
639     ($_[0]->manakai_tag_name);
640     if (defined $et) {
641     my $at = $et->get_attribute_definition_node ($attr_node->manakai_name);
642     if (defined $at) {
643     $attr_node->manakai_attribute_type ($at->declared_type);
644     }
645     }
646     }
647     }
648     }
649 wakaba 1.9
650 wakaba 1.22 $attr_node->value ($_[2]); # set or exception
651     $attr_node->specified (1);
652     return undef;
653     } # set_attribute
654 wakaba 1.9
655 wakaba 1.22 sub set_attribute_node ($$) {
656     my ($self, $new_attr) = @_;
657     local $Error::Depth = $Error::Depth + 1;
658     my $check = ${$$self->{owner_document}}->{strict_error_checking};
659     if ($check and $$self->{owner_document} ne $new_attr->owner_document) {
660     local $Error::Depth = $Error::Depth - 1;
661     report Message::DOM::DOMException
662     -object => $self,
663     -type => 'WRONG_DOCUMENT_ERR';
664     }
665    
666     my $nsuri = $$new_attr->{namespace_uri};
667     $nsuri = '' unless defined $nsuri;
668     my $ln = $$new_attr->{local_name};
669    
670     delete $$self->{manakai_content_attribute_list};
671     my $attrs = $$self->{attributes};
672     my $current = $attrs->{$nsuri}->{$ln};
673    
674     if (defined $$new_attr->{owner_element}) {
675     if (defined $current and $current eq $new_attr) {
676     ## No effect
677     return undef; # no return value
678     } else {
679     local $Error::Depth = $Error::Depth - 1;
680     report Message::DOM::DOMException
681     -object => $self,
682     -type => 'INUSE_ATTRIBUTE_ERR';
683     }
684     } elsif ($check and $$self->{manakai_read_only}) {
685     report Message::DOM::DOMException
686     -object => $self,
687     -type => 'NO_MODIFICATION_ALLOWED_ERR',
688     -subtype => 'READ_ONLY_NODE_ERR';
689     }
690    
691     $attrs->{$nsuri}->{$ln} = $new_attr;
692     $$new_attr->{owner_element} = $self;
693     Scalar::Util::weaken ($$new_attr->{owner_element});
694     $$new_attr->{specified} = 1;
695 wakaba 1.9
696 wakaba 1.22 if (defined $current) {
697     delete $$current->{owner_element};
698     $$current->{specified} = 1;
699     }
700     return $current;
701     } # set_attribute_node
702 wakaba 1.9
703 wakaba 1.22 *set_attribute_node_ns = \&set_attribute_node;
704 wakaba 1.9
705 wakaba 1.22 ## The second parameter only supports manakai extended way
706     ## to specify qualified name - "[$prefix, $local_name]" ## TODO: Document
707     sub set_attribute_ns ($$$$) {
708     my $prefix;
709     my $lname;
710     if (ref $_[2] eq 'ARRAY') {
711     ($prefix, $lname) = @{$_[2]};
712     } else {
713     ($prefix, $lname) = split /:/, $_[2], 2;
714     ($prefix, $lname) = (undef, $prefix) unless defined $lname;
715     }
716    
717     my $od = ${$_[0]}->{owner_document};
718     if ($$od->{strict_error_checking}) {
719     if (${$_[0]}->{manakai_read_only}) {
720     report Message::DOM::DOMException
721     -object => $_[0],
722     -type => 'NO_MODIFICATION_ALLOWED_ERR',
723     -subtype => 'READ_ONLY_NODE_ERR';
724     }
725 wakaba 1.9 }
726    
727 wakaba 1.22 my $attr = ${$_[0]}->{attributes};
728     my $attr_node = $attr->{defined $_[1] ? ''.$_[1] : ''}->{$lname};
729    
730     local $Error::Depth = $Error::Depth + 1;
731     if (defined $attr_node) {
732     if ($$od->{strict_error_checking}) {
733     $od->create_attribute_ns ($_[1], [$prefix, $lname]); # name exception
734     }
735     } else {
736     $attr_node = $od->create_attribute_ns
737     ($_[1], [$prefix, $lname]); # or exception
738     delete ${$_[0]}->{manakai_content_attribute_list};
739     $attr->{defined $_[1] ? ''.$_[1] : ''}->{$lname} = $attr_node;
740     $$attr_node->{owner_element} = $_[0];
741     Scalar::Util::weaken ($$attr_node->{owner_element});
742    
743     if ($od->dom_config->get_parameter
744     (q<http://suika.fam.cx/www/2006/dom-config/dtd-attribute-type>)) {
745     my $doctype = $od->doctype;
746     if (defined $doctype) {
747     my $et = $doctype->get_element_type_definition_node
748     ($_[0]->manakai_tag_name);
749     if (defined $et) {
750     my $at = $et->get_attribute_definition_node ($attr_node->manakai_name);
751     if (defined $at) {
752     $attr_node->manakai_attribute_type ($at->declared_type);
753     }
754     }
755     }
756     }
757 wakaba 1.9 }
758    
759 wakaba 1.22 $attr_node->value ($_[3]); # set or exception
760     $attr_node->prefix ($prefix);
761     $attr_node->specified (1);
762     return undef;
763     } # set_attribute_ns
764    
765     sub set_id_attribute ($$$) {
766     if (${${$_[0]}->{owner_document}}->{strict_error_checking} and
767     ${$_[0]}->{manakai_read_only}) {
768     report Message::DOM::DOMException
769     -object => $_[0],
770     -type => 'NO_MODIFICATION_ALLOWED_ERR',
771     -subtype => 'READ_ONLY_NODE_ERR';
772     }
773    
774     my $attr = $_[0]->get_attribute_node ($_[1]);
775     if (not defined $attr) {
776     report Message::DOM::DOMException
777     -object => $_[0],
778     -type => 'NOT_FOUND_ERR',
779     -subtype => 'NOT_CHILD_ERR';
780     } else {
781     local $Error::Depth = $Error::Depth + 1;
782     $attr->is_id ($_[2]); # or exception
783     }
784     return;
785     } # set_id_attribute
786    
787     sub set_id_attribute_ns ($$$$) {
788     if (${${$_[0]}->{owner_document}}->{strict_error_checking} and
789     ${$_[0]}->{manakai_read_only}) {
790     report Message::DOM::DOMException
791     -object => $_[0],
792     -type => 'NO_MODIFICATION_ALLOWED_ERR',
793     -subtype => 'READ_ONLY_NODE_ERR';
794     }
795    
796     my $attr = $_[0]->get_attribute_node_ns ($_[1], $_[2]);
797     if (not defined $attr) {
798     report Message::DOM::DOMException
799     -object => $_[0],
800     -type => 'NOT_FOUND_ERR',
801     -subtype => 'NOT_CHILD_ERR';
802     } else {
803     local $Error::Depth = $Error::Depth + 1;
804     $attr->is_id ($_[2]);
805     }
806     return;
807     } # set_id_attribute_ns
808    
809     sub set_id_attribute_node ($$$$) {
810     if (${${$_[0]}->{owner_document}}->{strict_error_checking} and
811     ${$_[0]}->{manakai_read_only}) {
812     report Message::DOM::DOMException
813     -object => $_[0],
814     -type => 'NO_MODIFICATION_ALLOWED_ERR',
815     -subtype => 'READ_ONLY_NODE_ERR';
816     }
817    
818     my $oe = $_[1]->owner_element;
819     if ($oe ne $_[0]) {
820     report Message::DOM::DOMException
821     -object => $_[0],
822     -type => 'NOT_FOUND_ERR',
823     -subtype => 'NOT_CHILD_ERR';
824     } else {
825     local $Error::Depth = $Error::Depth + 1;
826     $_[1]->is_id ($_[2]);
827 wakaba 1.9 }
828 wakaba 1.22 return;
829     } # set_id_attribute_node
830 wakaba 1.9
831 wakaba 1.28 ## |ElementSelector| methods
832    
833     sub query_selector ($$;$);
834    
835     sub query_selector_all ($$;$);
836    
837 wakaba 1.26 ## |ElementCSSInlineStyle| attributes
838    
839     sub current_style ($) {
840     ## TODO: If not part of document tree
841    
842     ## ISSUE: Neither |getComputedStyle| nor |currentStyle| represent
843     ## the set of computed values in the real world (in fact what is
844     ## represented by them disagree in browsers and even |getComputedStyle|
845     ## and |currentStyle| are different in the same Opera browser).
846    
847 wakaba 1.27 local $Error::Depth = $Error::Depth + 1;
848 wakaba 1.26 my $self = shift;
849     my $view = $self->owner_document->default_view;
850     return undef unless defined $view; ## ISSUE: Not defined in the spec yet.
851    
852     return $view->get_computed_style ($self);
853     } # current_style
854    
855     ## TODO: |style|, |runtimeStyle|
856    
857 wakaba 1.22 package Message::IF::Element;
858 wakaba 1.24 package Message::IF::ElementSelector;
859 wakaba 1.26 package Message::IF::ElementCSSInlineStyle;
860 wakaba 1.9
861 wakaba 1.22 package Message::DOM::Document;
862 wakaba 1.9
863 wakaba 1.22 sub create_element ($$) {
864     my $self = $_[0];
865     if ($$self->{strict_error_checking}) {
866     my $xv = $self->xml_version;
867     ## TODO: HTML Document ??
868     if (defined $xv) {
869     if ($xv eq '1.0' and
870     $_[1] =~ /\A\p{InXML_NameStartChar10}\p{InXMLNameChar10}*\z/) {
871     #
872     } elsif ($xv eq '1.1' and
873     $_[1] =~ /\A\p{InXMLNameStartChar11}\p{InXMLNameChar11}*\z/) {
874     #
875     } else {
876     report Message::DOM::DOMException
877     -object => $self,
878     -type => 'INVALID_CHARACTER_ERR',
879     -subtype => 'MALFORMED_NAME_ERR';
880     }
881     }
882 wakaba 1.13 }
883 wakaba 1.22 ## TODO: HTML5
884    
885     my $r = Message::DOM::Element->____new ($self, undef, undef, $_[1]);
886    
887     ## -- Default attributes
888     {
889     local $Error::Depth = $Error::Depth + 1;
890     my $cfg = $self->dom_config;
891     return $r
892     unless $cfg->get_parameter
893     (q<http://suika.fam.cx/www/2006/dom-config/dtd-default-attribute>);
894    
895     my $doctype = $self->doctype;
896     return $r unless defined $doctype;
897    
898     my $et = $doctype->get_element_type_definition_node ($_[1]);
899     return $r unless defined $et;
900    
901     my $orig_strict = $self->strict_error_checking;
902     $self->strict_error_checking (0);
903    
904     my %gattr;
905     my %has_attr;
906     my %pfx_to_uri;
907     my $copy_asis = $cfg->get_parameter
908     (q<http://suika.fam.cx/www/2006/dom-config/clone-entity-reference-subtree>);
909     $cfg->set_parameter
910     (q<http://suika.fam.cx/www/2006/dom-config/clone-entity-reference-subtree> => 1);
911    
912     for my $at (@{$et->attribute_definitions}) {
913     my $at_default = $at->default_type;
914     if ($at_default == 4 or $at_default == 1) {
915     # EXPLICIT_DEFAULT, FIXED_DEFAULT
916     my ($nn1, $nn2) = split /:/, $at->node_name;
917     if (defined $nn2) { # prefixed
918     if ($nn1 eq 'xmlns') {
919     ## TODO: NCName check, prefix check and NSURI check
920     my $attr = $self->create_attribute_ns
921     (q<http://www.w3.org/2000/xmlns/>, [$nn1, $nn2]);
922     for my $at_child (@{$at->child_nodes}) {
923     $attr->append_child ($at_child->clone_node (1));
924     }
925     $attr->manakai_attribute_type ($at->declared_type);
926     my $nsuri = $attr->value;
927     ## TODO: Namespace well-formedness check (NSURI), v1.1 chk
928     $pfx_to_uri{$nn2} = $nsuri;
929     $r->set_attribute_node_ns ($attr);
930     ## NOTE: This method changes |specified| flag
931     $attr->specified (0);
932     $has_attr{q<http://www.w3.org/2000/xmlns/>}->{$nn2} = 1;
933     } else {
934     ## TODO: NCName check
935     $gattr{$nn1}->{$nn2} = $at;
936     }
937     } else { # no prefixed
938     my $attr;
939     if ($nn1 eq 'xmlns') {
940     $attr = $self->create_attribute_ns
941     (q<http://www.w3.org/2000/xmlns/>, 'xmlns');
942     $has_attr{q<http://www.w3.org/2000/xmlns/>}->{xmlns} = 1;
943     } else {
944     $attr = $self->create_attribute_ns (undef, $nn1);
945     ## TODO: NCName check
946     }
947     for my $at_child (@{$at->child_nodes}) {
948     $attr->append_child ($at_child->clone_node (1));
949     }
950     $attr->manakai_attribute_type ($at->declared_type);
951     ## TODO: Namespace well-formedness check (NSURI)
952     $r->set_attribute_node_ns ($attr);
953     ## NOTE: This method changes |specified| flag
954     $attr->specified (0);
955     }
956     }
957     } # attrdefs
958     for my $pfx (keys %gattr) {
959     my $nsuri = $pfx_to_uri{$pfx};
960     unless (defined $nsuri) {
961     ## TODO: Namespace well-formedness error
962     }
963     LN: for my $ln (keys %{$gattr{$pfx}}) {
964     if ($has_attr{defined $nsuri ? $nsuri : ''}->{$ln}) {
965     ## TODO: Namespace well-formedness error
966     next LN;
967     }
968     ## TODO: NCName check, prefix check and NSURI check
969     my $at = $gattr{$pfx}->{$ln};
970     my $attr = $self->create_attribute_ns ($nsuri, [$pfx, $ln]);
971     for my $at_child (@{$at->child_nodes}) {
972     $attr->append_child ($at_child->clone_node (1));
973     }
974     $attr->manakai_attribute_type ($at->declared_type);
975     $r->set_attribute_node_ns ($attr);
976     ## NOTE: This method changes |specified| flag
977     $attr->specified (0);
978     $has_attr{defined $nsuri ? $nsuri : ''}->{$ln} = 1;
979     } # LN
980     } # pfx
981     $cfg->set_parameter
982     (q<http://suika.fam.cx/www/2006/dom-config/clone-entity-reference-subtree> => $copy_asis);
983     $self->strict_error_checking ($orig_strict);
984 wakaba 1.13 }
985 wakaba 1.9
986 wakaba 1.22 return $r;
987     } # create_element
988 wakaba 1.9
989 wakaba 1.22 sub create_element_ns ($$$) {
990     my $self = $_[0];
991     my ($prefix, $lname);
992     if (ref $_[2] eq 'ARRAY') {
993     ($prefix, $lname) = @{$_[2]};
994     } else {
995     ($prefix, $lname) = split /:/, $_[2], 2;
996     ($prefix, $lname) = (undef, $prefix) unless defined $lname;
997     }
998     my $nsuri = defined $_[1] ? $_[1] eq '' ? undef : $_[1] : undef;
999    
1000     if ($$self->{strict_error_checking}) {
1001     my $xv = $self->xml_version;
1002     ## TODO: HTML Document ?? (NOT_SUPPORTED_ERR is different from what Web browsers do)
1003     if (defined $xv) {
1004     if ($xv eq '1.0') {
1005     if (ref $_[2] eq 'ARRAY' or
1006     $_[2] =~ /\A\p{InXML_NameStartChar10}\p{InXMLNameChar10}*\z/) {
1007     if (defined $prefix) {
1008     if ($prefix =~ /\A\p{InXML_NCNameStartChar10}\p{InXMLNCNameChar10}*\z/) {
1009     #
1010     } else {
1011     report Message::DOM::DOMException
1012     -object => $self,
1013     -type => 'NAMESPACE_ERR',
1014     -subtype => 'MALFORMED_QNAME_ERR';
1015     }
1016 wakaba 1.1 }
1017 wakaba 1.22 if ($lname =~ /\A\p{InXML_NCNameStartChar10}\p{InXMLNCNameChar10}*\z/) {
1018     #
1019     } else {
1020     report Message::DOM::DOMException
1021     -object => $self,
1022     -type => 'NAMESPACE_ERR',
1023     -subtype => 'MALFORMED_QNAME_ERR';
1024 wakaba 1.1 }
1025 wakaba 1.22 } else {
1026     report Message::DOM::DOMException
1027     -object => $self,
1028     -type => 'INVALID_CHARACTER_ERR',
1029     -subtype => 'MALFORMED_NAME_ERR';
1030 wakaba 1.1 }
1031 wakaba 1.22 } elsif ($xv eq '1.1') {
1032     if (ref $_[2] eq 'ARRAY' or
1033     $_[2] =~ /\A\p{InXML_NameStartChar10}\p{InXMLNameChar10}*\z/) {
1034     if (defined $prefix) {
1035     if ($prefix =~ /\A\p{InXMLNCNameStartChar11}\p{InXMLNCNameChar11}*\z/) {
1036     #
1037     } else {
1038     report Message::DOM::DOMException
1039     -object => $self,
1040     -type => 'NAMESPACE_ERR',
1041     -subtype => 'MALFORMED_QNAME_ERR';
1042     }
1043     }
1044     if ($lname =~ /\A\p{InXMLNCNameStartChar11}\p{InXMLNCNameChar11}*\z/) {
1045     #
1046     } else {
1047     report Message::DOM::DOMException
1048     -object => $self,
1049     -type => 'NAMESPACE_ERR',
1050     -subtype => 'MALFORMED_QNAME_ERR';
1051 wakaba 1.1 }
1052 wakaba 1.22 } else {
1053     report Message::DOM::DOMException
1054     -object => $self,
1055     -type => 'INVALID_CHARACTER_ERR',
1056     -subtype => 'MALFORMED_NAME_ERR';
1057 wakaba 1.1 }
1058 wakaba 1.9 } else {
1059 wakaba 1.22 die "create_attribute_ns: XML version |$xv| is not supported";
1060 wakaba 1.9 }
1061     }
1062 wakaba 1.1
1063 wakaba 1.22 if (defined $prefix) {
1064     if (not defined $nsuri) {
1065     report Message::DOM::DOMException
1066     -object => $self,
1067     -type => 'NAMESPACE_ERR',
1068     -subtype => 'PREFIXED_NULLNS_ERR';
1069     } elsif ($prefix eq 'xml' and
1070     $nsuri ne q<http://www.w3.org/XML/1998/namespace>) {
1071     report Message::DOM::DOMException
1072     -object => $self,
1073     -type => 'NAMESPACE_ERR',
1074     -subtype => 'XMLPREFIX_NONXMLNS_ERR';
1075     } elsif ($prefix eq 'xmlns' and
1076     $nsuri ne q<http://www.w3.org/2000/xmlns/>) {
1077     report Message::DOM::DOMException
1078     -object => $self,
1079     -type => 'NAMESPACE_ERR',
1080     -subtype => 'XMLNSPREFIX_NONXMLNSNS_ERR';
1081     } elsif ($nsuri eq q<http://www.w3.org/2000/xmlns/> and
1082     $prefix ne 'xmlns') {
1083     report Message::DOM::DOMException
1084     -object => $self,
1085     -type => 'NAMESPACE_ERR',
1086     -subtype => 'NONXMLNSPREFIX_XMLNSNS_ERR';
1087     }
1088     } else { # no prefix
1089     if ($lname eq 'xmlns' and
1090     (not defined $nsuri or $nsuri ne q<http://www.w3.org/2000/xmlns/>)) {
1091     report Message::DOM::DOMException
1092     -object => $self,
1093     -type => 'NAMESPACE_ERR',
1094     -subtype => 'XMLNS_NONXMLNSNS_ERR';
1095     } elsif (not defined $nsuri) {
1096     #
1097     } elsif ($nsuri eq q<http://www.w3.org/2000/xmlns/> and
1098     $lname ne 'xmlns') {
1099     report Message::DOM::DOMException
1100     -object => $self,
1101     -type => 'NAMESPACE_ERR',
1102     -subtype => 'NONXMLNSPREFIX_XMLNSNS_ERR';
1103     }
1104     }
1105     }
1106    
1107     ## -- Choose the most apppropriate class for the element
1108     my $class = 'Message::DOM::Element';
1109     if (defined $nsuri) {
1110 wakaba 1.23 if ($nsuri eq q<http://www.w3.org/1999/xhtml>) {
1111     require Message::DOM::HTML::HTMLElement;
1112     $class = {
1113     a => 'Message::DOM::HTML::HTMLAnchorElement',
1114     area => 'Message::DOM::HTML::HTMLAreaElement',
1115     audio => 'Message::DOM::HTML::HTMLAudioElement',
1116     base => 'Message::DOM::HTML::HTMLBaseElement',
1117     body => 'Message::DOM::HTML::HTMLBodyElement',
1118     canvas => 'Message::DOM::HTML::HTMLCanvasElement',
1119     command => 'Message::DOM::HTML::HTMLCommandElement',
1120     datagrid => 'Message::DOM::HTML::HTMLDataGridElement',
1121     details => 'Message::DOM::HTML::HTMLDetailsElement',
1122     embed => 'Message::DOM::HTML::HTMLEmbedElement',
1123     'event-source' => 'Message::DOM::HTML::HTMLEventSourceElement',
1124     font => 'Message::DOM::HTML::HTMLFontElement',
1125     head => 'Message::DOM::HTML::HTMLHeadElement',
1126     html => 'Message::DOM::HTML::HTMLHtmlElement',
1127     iframe => 'Message::DOM::HTML::HTMLIFrameElement',
1128     img => 'Message::DOM::HTML::HTMLImageElement',
1129     li => 'Message::DOM::HTML::HTMLLIElement',
1130     link => 'Message::DOM::HTML::HTMLLinkElement',
1131     map => 'Message::DOM::HTML::HTMLMapElement',
1132     menu => 'Message::DOM::HTML::HTMLMenuElement',
1133     meta => 'Message::DOM::HTML::HTMLMetaElement',
1134     meter => 'Message::DOM::HTML::HTMLMeterElement',
1135     del => 'Message::DOM::HTML::HTMLModElement',
1136     ins => 'Message::DOM::HTML::HTMLModElement',
1137     object => 'Message::DOM::HTML::HTMLObjectElement',
1138     ol => 'Message::DOM::HTML::HTMLOListElement',
1139     param => 'Message::DOM::HTML::HTMLParamElement',
1140     progress => 'Message::DOM::HTML::HTMLProgressElement',
1141     blockquote => 'Message::DOM::HTML::HTMLQuoteElement',
1142     q => 'Message::DOM::HTML::HTMLQuoteElement',
1143     script => 'Message::DOM::HTML::HTMLScriptElement',
1144     source => 'Message::DOM::HTML::HTMLSourceElement',
1145     style => 'Message::DOM::HTML::HTMLStyleElement',
1146     table => 'Message::DOM::HTML::HTMLTableElement',
1147     td => 'Message::DOM::HTML::HTMLTableCellElement',
1148     col => 'Message::DOM::HTML::HTMLTableColElement',
1149     colgroup => 'Message::DOM::HTML::HTMLTableColElement',
1150     th => 'Message::DOM::HTML::HTMLTableHeaderCellElement',
1151     tr => 'Message::DOM::HTML::HTMLTableRowElement',
1152     tbody => 'Message::DOM::HTML::HTMLTableSectionElement',
1153     tfoot => 'Message::DOM::HTML::HTMLTableSectionElement',
1154     thead => 'Message::DOM::HTML::HTMLTableSectionElement',
1155     time => 'Message::DOM::HTML::HTMLTimeElement',
1156     video => 'Message::DOM::HTML::HTMLVideoElement',
1157     }->{$lname} || 'Message::DOM::HTML::HTMLElement';
1158     } elsif ($nsuri eq q<http://www.w3.org/2005/Atom>) {
1159 wakaba 1.22 require Message::DOM::Atom::AtomElement;
1160     $class = {
1161     author => 'Message::DOM::Atom::AtomElement::AtomPersonConstruct',
1162     category => 'Message::DOM::Atom::AtomElement::AtomCategoryElement',
1163     content => 'Message::DOM::Atom::AtomElement::AtomContentElement',
1164     contributor => 'Message::DOM::Atom::AtomElement::AtomPersonConstruct',
1165     entry => 'Message::DOM::Atom::AtomElement::AtomEntryElement',
1166     feed => 'Message::DOM::Atom::AtomElement::AtomFeedElement',
1167     generator => 'Message::DOM::Atom::AtomElement::AtomGeneratorElement',
1168     link => 'Message::DOM::Atom::AtomElement::AtomLinkElement',
1169     published => 'Message::DOM::Atom::AtomElement::AtomDateConstruct',
1170     rights => 'Message::DOM::Atom::AtomElement::AtomTextConstruct',
1171     source => 'Message::DOM::Atom::AtomElement::AtomSourceElement',
1172     subtitle => 'Message::DOM::Atom::AtomElement::AtomTextConstruct',
1173     summary => 'Message::DOM::Atom::AtomElement::AtomTextConstruct',
1174     title => 'Message::DOM::Atom::AtomElement::AtomTextConstruct',
1175     updated => 'Message::DOM::Atom::AtomElement::AtomDateConstruct',
1176     }->{$lname} || 'Message::DOM::Atom::AtomElement';
1177     }
1178     }
1179    
1180     my $r = $class->____new ($self, $nsuri, $prefix, $lname);
1181    
1182     ## -- Default attributes
1183     {
1184     local $Error::Depth = $Error::Depth + 1;
1185     my $cfg = $self->dom_config;
1186     return $r
1187     unless $cfg->get_parameter
1188     (q<http://suika.fam.cx/www/2006/dom-config/dtd-default-attribute>);
1189    
1190     my $doctype = $self->doctype;
1191     return $r unless defined $doctype;
1192    
1193     my $et = $doctype->get_element_type_definition_node
1194     (defined $prefix ? $prefix . ':' . $lname : $lname);
1195     return $r unless defined $et;
1196    
1197     my $orig_strict = $self->strict_error_checking;
1198     $self->strict_error_checking (0);
1199    
1200     my %gattr;
1201     my %has_attr;
1202     my %pfx_to_uri;
1203     my $copy_asis = $cfg->get_parameter
1204     (q<http://suika.fam.cx/www/2006/dom-config/clone-entity-reference-subtree>);
1205     $cfg->set_parameter
1206     (q<http://suika.fam.cx/www/2006/dom-config/clone-entity-reference-subtree> => 1);
1207    
1208     for my $at (@{$et->attribute_definitions}) {
1209     my $at_default = $at->default_type;
1210     if ($at_default == 4 or $at_default == 1) {
1211     # EXPLICIT_DEFAULT, FIXED_DEFAULT
1212     my ($nn1, $nn2) = split /:/, $at->node_name;
1213     if (defined $nn2) { # prefixed
1214     if ($nn1 eq 'xmlns') {
1215     ## TODO: NCName check, prefix check and NSURI check
1216     my $attr = $self->create_attribute_ns
1217     (q<http://www.w3.org/2000/xmlns/>, [$nn1, $nn2]);
1218     for my $at_child (@{$at->child_nodes}) {
1219     $attr->append_child ($at_child->clone_node (1));
1220     }
1221     $attr->manakai_attribute_type ($at->declared_type);
1222     my $nsuri = $attr->value;
1223     ## TODO: Namespace well-formedness check (NSURI), v1.1 chk
1224     $pfx_to_uri{$nn2} = $nsuri;
1225     $r->set_attribute_node_ns ($attr);
1226     ## NOTE: This method changes |specified| flag
1227     $attr->specified (0);
1228     $has_attr{q<http://www.w3.org/2000/xmlns/>}->{$nn2} = 1;
1229     } else {
1230     ## TODO: NCName check
1231     $gattr{$nn1}->{$nn2} = $at;
1232     }
1233     } else { # no prefixed
1234     my $attr;
1235     if ($nn1 eq 'xmlns') {
1236     $attr = $self->create_attribute_ns
1237     (q<http://www.w3.org/2000/xmlns/>, 'xmlns');
1238     $has_attr{q<http://www.w3.org/2000/xmlns/>}->{xmlns} = 1;
1239     } else {
1240     $attr = $self->create_attribute_ns (undef, $nn1);
1241     ## TODO: NCName check
1242     }
1243     for my $at_child (@{$at->child_nodes}) {
1244     $attr->append_child ($at_child->clone_node (1));
1245     }
1246     $attr->manakai_attribute_type ($at->declared_type);
1247     ## TODO: Namespace well-formedness check (NSURI)
1248     $r->set_attribute_node_ns ($attr);
1249     ## NOTE: This method changes |specified| flag
1250     $attr->specified (0);
1251     }
1252     }
1253     } # attrdefs
1254     for my $pfx (keys %gattr) {
1255     my $nsuri = $pfx_to_uri{$pfx};
1256     unless (defined $nsuri) {
1257     ## TODO: Namespace well-formedness error
1258 wakaba 1.10 }
1259 wakaba 1.22 LN: for my $ln (keys %{$gattr{$pfx}}) {
1260     if ($has_attr{defined $nsuri ? $nsuri : ''}->{$ln}) {
1261     ## TODO: Namespace well-formedness error
1262     next LN;
1263     }
1264     ## TODO: NCName check, prefix check and NSURI check
1265     my $at = $gattr{$pfx}->{$ln};
1266     my $attr = $self->create_attribute_ns ($nsuri, [$pfx, $ln]);
1267     for my $at_child (@{$at->child_nodes}) {
1268     $attr->append_child ($at_child->clone_node (1));
1269     }
1270     $attr->manakai_attribute_type ($at->declared_type);
1271     $r->set_attribute_node_ns ($attr);
1272     ## NOTE: This method changes |specified| flag
1273     $attr->specified (0);
1274     $has_attr{defined $nsuri ? $nsuri : ''}->{$ln} = 1;
1275     } # LN
1276     } # pfx
1277     $cfg->set_parameter
1278     (q<http://suika.fam.cx/www/2006/dom-config/clone-entity-reference-subtree> => $copy_asis);
1279     $self->strict_error_checking ($orig_strict);
1280 wakaba 1.10 }
1281    
1282 wakaba 1.22 return $r;
1283     } # create_element_ns
1284 wakaba 1.10
1285 wakaba 1.22 =head1 LICENSE
1286 wakaba 1.10
1287 wakaba 1.22 Copyright 2007 Wakaba <w@suika.fam.cx>
1288 wakaba 1.10
1289 wakaba 1.22 This program is free software; you can redistribute it and/or
1290     modify it under the same terms as Perl itself.
1291 wakaba 1.10
1292 wakaba 1.22 =cut
1293 wakaba 1.10
1294 wakaba 1.1 1;
1295 wakaba 1.28 ## $Date: 2008/01/14 11:33:48 $

admin@suikawiki.org
ViewVC Help
Powered by ViewVC 1.1.24