File Coverage

blib/lib/HTML/DOM/Node.pm
Criterion Covered Total %
statement 198 201 98.5
branch 74 80 92.5
condition 31 42 73.8
subroutine 38 38 100.0
pod 21 26 80.7
total 362 387 93.5


line stmt bran cond sub pod time code
1             package HTML::DOM::Node;
2              
3             our $VERSION = '0.056';
4              
5              
6 28     28   89 use strict;
  28         26  
  28         605  
7 28     28   94 use warnings;
  28         27  
  28         921  
8              
9             use constant {
10 28         4039 ELEMENT_NODE => 1,
11             ATTRIBUTE_NODE => 2,
12             TEXT_NODE => 3,
13             CDATA_SECTION_NODE => 4,
14             ENTITY_REFERENCE_NODE => 5,
15             ENTITY_NODE => 6,
16             PROCESSING_INSTRUCTION_NODE => 7,
17             COMMENT_NODE => 8,
18             DOCUMENT_NODE => 9,
19             DOCUMENT_TYPE_NODE => 10,
20             DOCUMENT_FRAGMENT_NODE => 11,
21             NOTATION_NODE => 12,
22 28     28   80 };
  28         26  
23              
24 28     28   95 use Exporter 5.57 'import';
  28         571  
  28         619  
25 28     28   9770 use HTML::DOM::Event;
  28         38  
  28         1128  
26 28         1186 use HTML::DOM::Exception qw'NO_MODIFICATION_ALLOWED_ERR NOT_FOUND_ERR
27             HIERARCHY_REQUEST_ERR
28 28     28   129 UNSPECIFIED_EVENT_TYPE_ERR';
  28         26  
29 28     28   92 use Scalar::Util qw'refaddr weaken blessed';
  28         23  
  28         17990  
30              
31             require HTML::DOM::EventTarget;
32             require HTML::DOM::Implementation;
33             require HTML::DOM::NodeList;
34             require HTML::DOM::_Element;
35              
36             our @ISA =('HTML::DOM::_Element', # No, a node isn't an HTML element,
37             'HTML::DOM::EventTarget'); # but HTML::DOM::_Element (forked from
38             # HTML::Element) has some nice tree-handling
39             # methods (and, after all, TreeBuilder's
40             # pseudo-elements aren't elements either).
41              
42             our @EXPORT_OK = qw'
43             ELEMENT_NODE
44             ATTRIBUTE_NODE
45             TEXT_NODE
46             CDATA_SECTION_NODE
47             ENTITY_REFERENCE_NODE
48             ENTITY_NODE
49             PROCESSING_INSTRUCTION_NODE
50             COMMENT_NODE
51             DOCUMENT_NODE
52             DOCUMENT_TYPE_NODE
53             DOCUMENT_FRAGMENT_NODE
54             NOTATION_NODE
55             ';
56             our %EXPORT_TAGS = (all => \@EXPORT_OK);
57              
58              
59              
60             =head1 NAME
61              
62             HTML::DOM::Node - A Perl class for representing the nodes of an HTML DOM tree
63              
64             =head1 VERSION
65              
66             Version 0.056
67              
68             =head1 SYNOPSIS
69              
70             use HTML::DOM::Node ':all'; # constants
71             use HTML::DOM;
72             $doc = HTML::DOM->new;
73             $doc->isa('HTML::DOM::Node'); # true
74             $doc->nodeType == DOCUMENT_NODE; # true
75              
76             $doc->firstChild;
77             $doc->childNodes;
78             # etc
79              
80             =head1 DESCRIPTION
81              
82             This is the base class for all nodes in an HTML::DOM tree. (See
83             L.) It implements the Node
84             interface, and, indirectly, the EventTarget interface (see
85             L.
86              
87             =head1 METHODS
88              
89             =head2 Attributes
90              
91             The following DOM attributes are supported:
92              
93             =over 4
94              
95             =item nodeName
96              
97             =item nodeType
98              
99             These two are implemented not by HTML::DOM::Node itself, but by its
100             subclasses.
101              
102             =item nodeValue
103              
104             =item parentNode
105              
106             =item childNodes
107              
108             =item firstChild
109              
110             =item lastChild
111              
112             =item previousSibling
113              
114             =item nextSibling
115              
116             =item attributes
117              
118             =item ownerDocument
119              
120             =item namespaceURI
121              
122             =item prefix
123              
124             =item localName
125              
126             Those last three always return nothing.
127              
128             =back
129              
130             There is also a C<_set_ownerDocument> method, which you probably do not
131             need to know about.
132              
133             =cut
134              
135             # ----------- ATTRIBUTE METHODS ------------- #
136              
137             # sub nodeName {} # every subclass overrides this
138             # sub nodeType {} # likewise
139              
140             sub nodeValue {
141 3 50   3 1 13 if(@_ > 1) {
142 0         0 die new HTML::DOM::Exception
143             NO_MODIFICATION_ALLOWED_ERR,
144             'Read-only node';# ~~~ only when the node is
145             # readonly
146             }
147 3         10 return; # empty list
148             }
149              
150             sub parentNode {
151 4911     4911 1 9315 my $p = $_[0]->parent;
152 4911 100       13693 defined $p ? $p :()
153             }
154              
155             sub childNodes {
156 75 100   75 1 1494 wantarray ? $_[0]->content_list :
157             new HTML::DOM::NodeList $_[0]->content_array_ref;
158             }
159              
160             sub firstChild {
161 104     104 1 296 ($_[0]->content_list)[0];
162             }
163              
164             sub lastChild {
165 7     7 1 21 ($_[0]->content_list)[-1];
166             }
167              
168             sub previousSibling {
169 2     2 1 9 my $sib = scalar $_[0]->left;
170 2 100       7 defined $sib ? $sib : ();
171             }
172              
173             sub nextSibling {
174 14     14 1 27 my $sib = scalar $_[0]->right;
175 14 100       36 defined $sib ? $sib : ();
176             }
177              
178       17 1   sub attributes {} # null for most nodes; overridden by Element
179              
180             sub ownerDocument {
181 9271     9271 1 9190 my $self = shift;
182 9271 100       31948 $$self{_HTML_DOM_Node_owner} || do {
183 477         1065 my $root = $self->root;
184             # ~~~ I’m not sure this logic is right. I need to revisit
185             # this. Do we ever have a case in which ->root returns
186             # the wrong value? If so, can we guarantee that the
187             # ‘root’ has its _HTML_DOM_Node_owner attribute set?
188             $$self{_HTML_DOM_Node_owner} =
189 477   66     615 $$root{_HTML_DOM_Node_owner} || $root;
190 477         890 weaken $$self{_HTML_DOM_Node_owner};
191             $$self{_HTML_DOM_Node_owner}
192 477         1358 };
193             }
194              
195             sub _set_ownerDocument {
196 1207     1207   2477 $_[0]{_HTML_DOM_Node_owner} = $_[1];
197 1207         2392 weaken $_[0]{_HTML_DOM_Node_owner};
198             }
199              
200             *prefix = *localName = *namespaceURI = *attributes;
201              
202              
203             =head2 Other Methods
204              
205             See the DOM spec. for descriptions of most of these. The first four
206             automatically trigger mutation events. (See L.)
207              
208             =over 4
209              
210             =item insertBefore
211              
212             =item replaceChild
213              
214             =item removeChild
215              
216             =item appendChild
217              
218             =item hasChildNodes
219              
220             =item cloneNode
221              
222             =item normalize
223              
224             =item hasAttributes
225              
226             =item isSupported
227              
228             =cut
229              
230             # ----------- METHOD METHODS ------------- #
231              
232             sub insertBefore {
233             # ~~~ NO_MODIFICATION_ALLOWED_ERR is meant to be raised if the
234             # node is read-only.
235             # ~~~ HIERARCHY_REQUEST_ERR is also supposed to be raised if the
236             # node type does not allow children of $new_node's type.
237              
238 15     15 1 21 my($self,$new_node,$before) = @_;
239              
240 15 100       39 $self->is_inside($new_node) and
241             die new HTML::DOM::Exception HIERARCHY_REQUEST_ERR,
242             'A node cannot be inserted into one of its descendants';
243              
244 14   66     24 my $doc = $self->ownerDocument || $self;
245              
246 14         13 my $index;
247 14         28 my @kids = $self->content_list;
248 14 100       22 if($before) { FIND_INDEX: {
249 7         7 for (0..$#kids) {
  7         15  
250 9 100       26 $kids[$_] == $before
251             and $index = $_, last FIND_INDEX;
252             }
253 1         3 die new HTML::DOM::Exception NOT_FOUND_ERR,
254             'insertBefore\'s 2nd argument is not a child of this node';
255             }}
256             else {
257 7         10 $index = @kids;
258             }
259              
260             #$new_node->can('parent') or warn JE::Code::add_line_number("cant parent");
261 13         35 my $old_parent = $new_node->parent;
262 13 100       42 $old_parent and $new_node->trigger_event('DOMNodeRemoved',
263             rel_node => $old_parent);
264 13         43 my $was_inside_doc = $new_node->is_inside($doc);
265 13 100       20 if($was_inside_doc) {
266             $_->trigger_event('DOMNodeRemovedFromDocument')
267 4         8 for $new_node, $new_node->descendants;
268             }
269              
270 13 100       82 $self->splice_content($index, 0, my @nodes =
271             $new_node->isa('HTML::DOM::DocumentFragment')
272             ? $new_node->childNodes
273             : $new_node
274             );
275 13         26 $_->_set_ownerDocument($doc) for @nodes;
276              
277 13         28 $new_node->trigger_event('DOMNodeInserted', rel_node => $self);
278 13 100       60 if($self->is_inside($doc)) {
279 6         14 for($new_node, $new_node->descendants) {
280 31 50 66     79 if(
281             !$was_inside_doc
282             and my $sub = $doc->elem_handler(lc $_->tag)
283             ) {
284 0         0 &$sub($doc,$_)
285             }
286 31         65 $_->trigger_event('DOMNodeInsertedIntoDocument')
287             }
288             }
289             $_->trigger_event('DOMSubtreeModified')
290 13         25 for _nearest_common_parent($old_parent, $self);
291              
292 13         29 $doc->_modified;
293              
294 13         29 $new_node;
295             }
296              
297             sub replaceChild {
298             # ~~~ NO_MODIFICATION_ALLOWED_ERR is meant to be raised if the
299             # node is read-only.
300             # ~~~ HIERARCHY_REQUEST_ERR is also supposed to be raised if the
301             # node type does not allow children of $new_node's type.
302              
303 18     18 1 23 my($self,$new_node,$old_node) = @_;
304              
305 18 100       42 $self->is_inside($new_node) and
306             die new HTML::DOM::Exception HIERARCHY_REQUEST_ERR,
307             'A node cannot be inserted into one of its descendants';
308              
309 17   66     27 my $doc = $self->ownerDocument || $self;
310              
311 28     28   134 no warnings 'uninitialized';
  28         29  
  28         6441  
312 17 100       41 $self == $old_node->parent or
313             die new HTML::DOM::Exception NOT_FOUND_ERR,
314             'replaceChild\'s 2nd argument is not a child of this node';
315              
316 16         40 $old_node->trigger_event('DOMNodeRemoved',
317             rel_node => $self);
318 16         99 my $in_doc = $self->is_inside($doc);
319 16 100       30 if($in_doc) {
320             $_->trigger_event('DOMNodeRemovedFromDocument')
321 9         18 for $old_node, $old_node->descendants;
322             }
323 16         35 my $old_parent = $new_node->parent;
324 16 100       37 $old_parent and $new_node->trigger_event('DOMNodeRemoved',
325             rel_node => $old_parent);
326 16 100 100     51 if($new_node->is_inside($doc) && !$new_node->is_inside($old_node)){
327             $_->trigger_event('DOMNodeRemovedFromDocument')
328 3         7 for $new_node, $new_node->descendants;
329             }
330              
331             # If the owner is not set explicitly inside the node, it will lose
332             # its owner. The ownerDocument method sets it if it is not
333             # already set.
334 16         28 $old_node->ownerDocument;
335              
336 16 100       129 my $ret = $old_node->replace_with(
337             my @nodes
338             = $new_node->isa('HTML::DOM::DocumentFragment')
339             ? $new_node->childNodes
340             : $new_node
341             );
342 16         33 $_->_set_ownerDocument($doc) for @nodes;
343              
344 16         42 $new_node->trigger_event('DOMNodeInserted', rel_node => $self);
345 16 100       65 if($in_doc) {
346 9         21 for($new_node, $new_node->descendants) {
347 65 50       137 if(my $sub = $doc->elem_handler(lc $_->tag)) {
348 0         0 &$sub($doc,$_)
349             }
350 65         144 $_->trigger_event('DOMNodeInsertedIntoDocument')
351             }
352             }
353             $_->trigger_event('DOMSubtreeModified')
354 16         29 for _nearest_common_parent($old_parent, $self);
355              
356 16         39 $doc->_modified;
357              
358 16         45 $ret;
359             }
360              
361             sub removeChild {
362             # ~~~ NO_MODIFICATION_ALLOWED_ERR is meant to be raised if the
363             # node is read-only.
364              
365 30     30 1 75 my($self,$child) = @_;
366              
367 28     28   108 no warnings 'uninitialized';
  28         24  
  28         25037  
368 30 100       87 $self == $child->parent or
369             die new HTML::DOM::Exception NOT_FOUND_ERR,
370             'removeChild\'s argument is not a child of this node';
371              
372             # If the owner is not set explicitly inside the node, it will lose
373             # its owner. The ownerDocument method sets it if it is not
374             # already set.
375 29         64 my $doc = $child->ownerDocument;
376              
377 29         82 $child->trigger_event('DOMNodeRemoved',
378             rel_node => $self);
379 29 100       159 if($child->is_inside($doc)) {
380             $_->trigger_event('DOMNodeRemovedFromDocument')
381 24         50 for $child, $child->descendants;
382             }
383              
384 29         112 $child->detach;
385              
386 29         64 $self->trigger_event('DOMSubtreeModified');
387              
388 29   100     86 {($self->ownerDocument||next)->_modified;}
  29         52  
389              
390 29         85 $child;
391             }
392              
393             sub appendChild {
394             # ~~~ NO_MODIFICATION_ALLOWED_ERR is meant to be raised if the
395             # node is read-only.
396             # ~~~ HIERARCHY_REQUEST_ERR is also supposed to be raised if the
397             # node type does not allow children of $new_node's type.
398              
399 138     138 1 165 my($self,$new_node) = @_;
400              
401 138 100       333 $self->is_inside($new_node) and
402             die new HTML::DOM::Exception HIERARCHY_REQUEST_ERR,
403             'A node cannot be inserted into one of its descendants';
404              
405 137   66     228 my $doc = $self->ownerDocument || $self;
406              
407 137         337 my $old_parent = $new_node->parent;
408 137 100       205 $old_parent and $new_node->trigger_event('DOMNodeRemoved',
409             rel_node => $old_parent);
410 137         313 my $was_inside_doc = $new_node->is_inside($doc);
411 137 100       196 if($was_inside_doc) {
412             $_->trigger_event('DOMNodeRemovedFromDocument')
413 5         10 for $new_node, $new_node->descendants;
414             }
415              
416             $self->push_content(
417 137 100       835 my @nodes = $new_node->isa('HTML::DOM::DocumentFragment')
418             ? $new_node->childNodes
419             : $new_node
420             );
421 137         263 $_->_set_ownerDocument($doc) for @nodes;
422              
423 137         356 $new_node->trigger_event('DOMNodeInserted', rel_node => $self);
424 137 100       625 if($self->is_inside($doc)) {
425 30         92 for($new_node, $new_node->descendants) {
426 60 100 100     187 if(
427             !$was_inside_doc
428             and my $sub = $doc->elem_handler(lc $_->tag)
429             ) {
430 1         2 &$sub($doc,$_)
431             }
432 60         150 $_->trigger_event('DOMNodeInsertedIntoDocument')
433             }
434             }
435             $_->trigger_event('DOMSubtreeModified')
436 137         224 for _nearest_common_parent($old_parent, $self);
437              
438 137         300 $doc->_modified;
439              
440 137         284 $new_node;
441             }
442              
443             # This is used to determine who gets a DOMSubtreeModified event. Despite
444             # its name, it may choose one of the two nodes passed to it if one is the
445             # parent of the other. If neither of the nodes is in the same tree, they
446             # are both returned. The first arg may be undef, in which case the 2nd
447             # is returned.
448             sub _nearest_common_parent {
449 166     166   165 my ($node1,$node2)=@_;
450 166 100       591 !defined $node1 and return $node2;
451 19 100       40 $node1->root != $node2->root and return $node1, $node2;
452 11         28 my $addr1 = $node1->address;
453 11         24 my $addr2 = $node2->address;
454 11   100     43 while(substr $addr1, 0, length $addr2, ne $addr2 and
455             substr $addr2, 0, length $addr1, ne $addr1) {
456 3         26 s/\.[^.]*\z// for $addr1, $addr2;
457             }
458             $node2->address(
459 11 100       44 length $addr1 < length $addr2 ? $addr1 : $addr2
460             )
461             }
462              
463             sub hasChildNodes {
464 23     23 1 68 !!$_[0]->content_list
465             }
466              
467             sub cloneNode {
468 13     13 1 14 my($self,$deep) = @_;
469 13 100       22 if($deep) {
470 7         30 (my $clown = $self->clone)
471             ->_set_ownerDocument($self->ownerDocument);
472 7         14 $clown;
473             }
474             else {
475             # ~~~ Do I need to reweaken any attributes?
476 6         37 bless +(my $clone = { %$self }), ref $self;
477 6         17 $clone->_set_ownerDocument($self->ownerDocument);
478 6         18 delete $clone->{$_} for qw/ _parent _content /;
479 6         10 $clone
480             }
481             }
482              
483             sub normalize {
484 2     2 1 3 my @pile = my $self = shift;
485 2         5 while(@pile) {
486 11 100       15 if($pile[0]{_tag} eq '~text') {
487 9 100       11 if($pile[0]{text} eq '') {
488 3         10 shift(@pile)->detach, next
489             }
490 6   100     5 _:{while((my $next = $pile[0]->nextSibling||next _)
  6         9  
491             ->{_tag} eq '~text') {
492 6         7 $pile[0]{text}.=$next->{text};
493 6         13 $next->detach;
494             }}
495 6         14 shift @pile;
496             }
497             else {
498 2 50       2 unshift @pile, @{(shift@pile)->{'_content'}||[]};
  2         7  
499             }
500             }
501             return
502 2         5 }
503              
504             sub hasAttributes {
505 3   100 3 1 256 (shift->attributes||return 0)->length
506             }
507              
508             sub isSupported {
509 2     2 1 181 my $self = shift;
510 2         7 $HTML::DOM::Implementation::it->hasFeature(@_)
511             }
512              
513             # ----------- EVENT STUFF ------------- #
514              
515             =item trigger_event
516              
517             This overrides L's (non-DOM) method of the same
518             name, so that
519             the document's default event handler is called.
520              
521             =cut
522              
523             sub trigger_event { # non-DOM method
524 1872     1872 1 2290 my ($n,$evnt) = (shift,shift);
525 1872   66     2279 my $doc = $n->ownerDocument||$n;
526 1872         3353 $n->SUPER::trigger_event(
527             $evnt,
528             default => $doc->default_event_handler,
529             view => scalar $doc->defaultView,
530             @_,
531             );
532             }
533              
534             =item as_text
535              
536             =item as_HTML
537              
538             These two (non-DOM) methods of L are overridden, so that
539             they work correctly with comment and text nodes.
540              
541             =cut
542              
543             sub as_text{
544 16     16 1 45 (my $clone = shift->clone)->deobjectify_text;
545 16         60 $clone->SUPER::as_text(@_);
546             }
547              
548             sub as_HTML{
549 52     52 1 107 (my $clone = shift->clone)->deobjectify_text;
550 52         116 $clone->SUPER::as_HTML(@_);
551             }
552              
553             sub push_content {
554 1700     1700 0 1527 my $self = shift;
555 1700 100       2326 @_ or return $self;
556 1694         3068 my $count = ()=$self->content_list;
557 1694         3556 $self->SUPER::push_content(@_);
558 1694         1655 my $ary = $self->{_content};
559 1694   66     6255 ref and weaken $_->{_parent} for @$ary[$count-@$ary..-1];
560 1694         2233 $self
561             }
562              
563             sub unshift_content {
564 8     8 0 9 my $self = shift;
565 8         17 my $count = ()=$self->content_list;
566 8         30 $self->SUPER::unshift_content(@_);
567 8         9 my $ary = $self->{_content};
568 8   33     43 ref and weaken $_->{_parent} for @$ary[0..$#$ary-$count];
569 8         12 $self
570             }
571              
572             sub splice_content {
573 561     561 0 768 my($self,$start,$deleted) = (shift,@_);
574 561         983 my $orig_count = ()=$self->content_list;
575 561         1235 $self->SUPER::splice_content(@_);
576 561         543 my $ary = $self->{_content};
577              
578             # orig_length - deleted_items + x = final_length,
579             # where x is the number of items added (to be weakened), so
580             # x = final_length - orig_length + deleted_items.
581             # x needs to be adjusted so it is an ending offset, so we use
582             # $#$ary instead of the final length (@$ary) and add $start
583             ref and weaken $_->{_parent}
584 561   33     2260 for @$ary[$start..$#$ary-$orig_count+$deleted+$start];
585              
586 561         777 $self
587             }
588              
589             sub clone {
590 322     322 0 230 my $self = shift;
591 322         498 my $clone = $self->SUPER::clone;
592 322         549 for ($clone->content_list) {
593 247 50       311 ref or next;
594 247         386 weaken $_->{_parent};
595             }
596 322         521 $clone;
597             }
598              
599             sub replace_with {
600 41     41 0 31 my $self = shift;
601 41         101 $self->SUPER::replace_with(@_);
602 41         53 for(@_) {
603 28     28   144 no warnings;
  28         32  
  28         1685  
604 65 50       172 ref and weaken $_->{_parent};
605             }
606 41         102 $self;
607             }
608              
609              
610             =back
611              
612             =cut
613              
614             1;
615             __END__