File Coverage

blib/lib/HTML/DOM/Attr.pm
Criterion Covered Total %
statement 120 123 97.5
branch 54 60 90.0
condition 21 28 75.0
subroutine 33 33 100.0
pod 12 15 80.0
total 240 259 92.6


line stmt bran cond sub pod time code
1             package HTML::DOM::Attr;
2              
3 25     25   95 use warnings;
  25         25  
  25         1188  
4              
5             # attribute constants (array elems)
6             BEGIN{
7 25     25   27 my $x;
8 25         630 %constants
9             = map +($_=>$x++), qw[
10             _doc _elem _name _val _list _styl
11             ]
12             }
13 25     25   147 use constant 1.03 \%constants;
  25         465  
  25         2305  
14             # after compilation:
15             delete @{__PACKAGE__."::"}{ keys %constants, 'constants' };
16              
17 25     25   90 use strict;
  25         29  
  25         1019  
18              
19             # The internal fields are:
20             # _doc # owner document
21             # _elem # owner element
22             # _name
23             # _val # actually contains an array with one element, so
24             # _list # node list # that nodelists can work efficiently
25             # _styl # style obj
26              
27              
28             use overload fallback => 1,
29 77     77   208 '""' => sub { shift->value },
30 25     25   82 'bool' => sub{1};
  25     1164   23  
  25         185  
  1164         1882  
31              
32 25         1050 use HTML::DOM::Exception qw'NOT_FOUND_ERR NO_MODIFICATION_ALLOWED_ERR
33 25     25   1463 HIERARCHY_REQUEST_ERR ';
  25         23  
34 25     25   82 use HTML::DOM::Node 'ATTRIBUTE_NODE';
  25         25  
  25         772  
35 25     25   81 use Scalar::Util qw'weaken blessed refaddr';
  25         21  
  25         27342  
36              
37             require HTML::DOM::EventTarget;
38             require HTML::DOM::NodeList;
39              
40             our @ISA = 'HTML::DOM::EventTarget';
41              
42             our $VERSION = '0.056';
43              
44             # -------- NON-DOM AND PRIVATE METHODS -------- #
45              
46             sub new { # @_[1..2] contains the nayme & vallew
47             # ~~~ INVALID_CHARACTER_ERR is meant to be raised if the specified name contains an invalid character.
48 348     348 0 253 my @self;
49 348 100       1049 @self[_name,_val] = ($_[1],[defined$_[2]?$_[2]:'']);
50             # value should be an empty
51 348         792 bless \@self, shift; # string, not undef
52             }
53              
54              
55              
56             sub _set_ownerDocument {
57 369     369   1203 weaken ($_[0][_doc] = $_[1]);
58             }
59              
60             sub _element { # This is like ownerElement, except that it lets you set it.
61 394 100   394   635 if(@_ > 1) {
62 369         328 my $old = $_[0][_elem];
63 369         587 weaken ($_[0][_elem] = $_[1]);
64 369         431 return $old
65             }
66 25         95 $_[0][_elem];
67             }
68              
69             sub DOES {
70 1 50   1 0 224 return !0 if $_[1] eq 'HTML::DOM::Node';
71 0 0       0 eval { shift->SUPER::DOES(@_) } || !1
  0         0  
72             }
73              
74             sub _value { # returns the value as it is, whether it is a node or scalar
75 24     24   51 $_[0][_val][0];
76             }
77              
78             sub _val_as_node { # turns the attribute's value into a text node if it is
79             # not one already and returns it
80 26     26   692 my $val = $_[0][_val][0];
81             defined blessed $val && $val->isa('HTML::DOM::Text')
82             ? $val
83 26 100 66     176 : do {
84 13 100       23 my $val = $_[0][_val][0] =
85             $_[0]->ownerDocument->createTextNode(
86             $_[0][_styl] ? $_[0][_styl]->cssText : $val
87             );
88 13         36 weaken($val->{_parent}=($_[0]));
89 13         65 $val
90             }
91             }
92              
93             # ~~~ Should I make this public? This actually allows a style object to be
94             # attached to any attr node, not just a style attr. Is this useful?
95             # (Actually, it would be problematic for event attributes, unless some-
96             # one really wants to run css code :-)
97             sub style {
98 39     39 0 40 my $self = shift;
99 39   66     132 $self->[_styl] ||= do{
100             require CSS::DOM::Style,
101 27         861 my $ret = CSS::DOM::Style::parse(my $val = $self->value);
102             $ret->modification_handler(my $cref = sub {
103 13 100   13   1345 if(ref(my $text = $self->_value)) {
104             # We can’t use ->data here because it will
105             # trigger chardatamodified (see sub new),
106             # which sets cssText, which calls this.
107 1         3 $text->attr('text', shift->cssText)
108             }
109 13         20 $self->_modified;
110 27         17190 });
111 27         130 weaken $self;
112 27         49 my $css_code = $ret->cssText;
113 27 100       417 if($val ne $css_code) { &$cref($ret) }
  5         8  
114 27         159 $ret;
115             };
116             }
117              
118             sub _modified {
119 276     276   248 my $self = shift;
120 276         255 my ($old_val,$new) = @_;
121 276   100     473 my $element = $self->[_elem] || return;
122 264 100       385 defined $new or $new = value $self;
123 264 100 100     958 if ($self->[_name] =~ /^on(.*)/is
124             and my $listener_maker = $self->ownerDocument
125             ->event_attr_handler
126             ) {
127 2         7 my $eavesdropper = &$listener_maker(
128             $element, my $evt_name = lc $1, $new
129             );
130 2 50       14 defined $eavesdropper
131             and $element->event_handler(
132             $evt_name, $eavesdropper
133             );
134             }
135              
136             $element->trigger_event(
137 264 100       739 DOMAttrModified =>
138             attr_name => $self->[_name],
139             attr_change_type => 1,
140             prev_value => defined $old_val?$old_val:$new,
141             new_value => $new,
142             rel_node => $self,
143             )
144             }
145              
146             sub _text_node_modified {
147 6     6   6 my $self = shift;
148 6 100       17 if($$self[_styl]) {
149 1         12 $$self[_styl]->cssText(shift->newValue)
150             }
151             else {
152 5         17 $self->_modified($_[0]->prevValue,$_[0]->newValue);
153             }
154             }
155              
156              
157             # ----------- ATTR-ONLY METHODS ---------- #
158              
159             sub name {
160 568     568 1 1772 $_[0][_name];
161             }
162              
163             sub value {
164 944 100   944 1 7355 if(my $style = $_[0][_styl]) {
165 22         17 shift;
166 22         88 return $style->cssText(@_);
167             }
168 922 100       1319 if(@_ > 1){
169 255         253 my $old = $_[0][_val][0];
170 255 100       685 if(ref $old) {
    100          
171 1         3 $old = $old->data;
172 1         4 $_[0][_val][0]->data($_[1]);
173             # ~~~ Can we combine these two statements by using data’s retval?
174             }
175             elsif((my $new_val = $_[0][_val][0] = "$_[1]") ne $old) {
176 252 100       524 if($_[0]->get_event_listeners(
177             'DOMCharacterDataModified'
178             )) {
179 1         4 $_[0]->firstChild->trigger_event(
180             'DOMCharacterDataModified',
181             prev_value => $old,
182             new_value => $new_val
183             )
184             }
185             else {
186 251         377 $_[0]->_modified($old,$new_val);
187             }
188             }
189 255         1179 return $old;
190             }
191 667         661 my $val = $_[0][_val][0];
192 667 100       2047 ref $val ? $val->data : $val;
193             }
194              
195             sub specified {
196 24     24 1 44 my $attr=shift;
197 24   100     96 ($$attr[_elem]||return 1)->_attr_specified($$attr[_name]);
198             }
199              
200             sub ownerElement { # ~~~ If the attr is detached, is _element currently
201             # erased as it should be?
202             shift->_element || ()
203 6 100   6 1 17 }
204              
205             # ------------------ NODE METHODS ------------ #
206              
207             *nodeName = \&name;
208             *nodeValue = \&value;
209             *nodeType =\&ATTRIBUTE_NODE;
210              
211             # These all return null
212             *previousSibling = *nextSibling = *attributes = *parentNode = *prefix =
213             *namespaceURI = *localName = *normalize
214       41     = sub {};
215              
216             sub childNodes {
217 12 100 66 12 1 592 wantarray ? $_[0]->_val_as_node :(
218             $_[0]->_val_as_node,
219             $_[0][_list] ||= HTML::DOM::NodeList->new($_[0][_val])
220             );
221             }
222              
223             *firstChild = *lastChild = \&_val_as_node;
224              
225 34     34 1 817 sub ownerDocument { $_[0][_doc] }
226              
227             sub insertBefore {
228 3     3 1 398 die HTML::DOM::Exception->new(NO_MODIFICATION_ALLOWED_ERR,
229             'The list of child nodes of an attribute cannot be modified');
230             }
231              
232             sub replaceChild {
233 11     11 1 27 my($self,$new_node,$old_node) = @_;
234 11         20 my $val = $self->_value;
235 11 100 66     53 die HTML::DOM::Exception->new(NOT_FOUND_ERR,
236             'The node passed to replaceChild is not a child of this attribute')
237             if !ref $val || $old_node != $val;
238 10 100 66     76 if(defined blessed $new_node and
239             isa $new_node 'HTML::DOM::DocumentFragment') {
240 3 100       8 (($new_node) = $new_node->childNodes) != 1 and
241             die HTML::DOM::Exception->new(HIERARCHY_REQUEST_ERR,
242             'The document fragment passed to replaceChild ' .
243             'does not have exactly one child node');
244             }
245 9 100 33     47 die HTML::DOM::Exception->new(HIERARCHY_REQUEST_ERR,
246             'The node passed to replaceChild is not a text node')
247             if !defined blessed $new_node ||
248             !$new_node->isa('HTML::DOM::Text');
249              
250 7         20 $old_node->trigger_event('DOMNodeRemoved',
251             rel_node => $self);
252 7   100     49 my $in_doc = $self->[_elem] && $self->[_elem]->is_inside(
253             $self->[_doc]
254             );
255 7 100       17 if($in_doc) {
256 1         3 $old_node->trigger_event('DOMNodeRemovedFromDocument')
257             }
258 7         15 my $old_parent = $new_node->parent;
259 7 100       18 $old_parent and $new_node->trigger_event('DOMNodeRemoved',
260             rel_node => $old_parent);
261 7 50       24 if($new_node->is_inside($self->[_doc])){
262 0         0 $new_node->trigger_event('DOMNodeRemovedFromDocument')
263             }
264             else {
265             # Even if it’s already the same document, it’s actually
266             # quicker just to set it than to check first.
267 7         15 $new_node->_set_ownerDocument( $self->[_doc] );
268             }
269              
270 7         18 ($_[0][_val][0] = $new_node)->detach;
271 7         15 weaken($new_node->{_parent}=($self));
272 7         17 $old_node->parent(undef);
273              
274 7         17 $new_node->trigger_event('DOMNodeInserted', rel_node => $self);
275 7 100       24 if($in_doc) {
276 1         3 $new_node->trigger_event('DOMNodeInsertedIntoDocument')
277             }
278             $_->trigger_event('DOMSubtreeModified')
279 7         34 for grep defined, $old_parent, $self;
280 7         19 $self->_modified($old_node->data, $new_node->data);
281              
282 7         31 $old_node;
283             }
284              
285              
286             *removeChild = *appendChild = \&insertBefore;
287              
288 1     1 1 185 sub hasChildNodes { 1 }
289              
290             sub cloneNode {
291             # ~~~ The spec. is not clear as to what should be done with an
292             # Attr’s child node when it is cloned shallowly. I’m here fol-
293             # lowing the behaviour of Safari and Firefox, which both ignore
294             # the ‘deep’ option.
295 4     4 1 6 my($self,$deep) = @_;
296 4         13 my $clone = bless [@$self], ref $self;
297 4         11 weaken $$clone[_doc];
298 4         9 delete $$clone[$_] for _elem, _list;
299 4         9 $$clone[_val] = ["$$clone[_val][0]"]; # copy the single-elem array
300             # that ->[_val] contains,
301             # flattening it in order effec-
302             # tively to clone it.
303 4         8 $clone;
304             }
305              
306 1     1 1 246 sub hasAttributes { !1 }
307              
308             sub isSupported {
309 2     2 1 166 my $self = shift;
310 2 50       4 return !1 if $_[0] =~ /events\z/i;
311 2         8 $HTML::DOM::Implementation::it->hasFeature(@_)
312             }
313              
314              
315             1
316              
317             __END__