File Coverage

blib/lib/CSS/DOM/Style.pm
Criterion Covered Total %
statement 158 162 97.5
branch 80 88 90.9
condition 27 36 75.0
subroutine 23 25 92.0
pod 13 14 92.8
total 301 325 92.6


line stmt bran cond sub pod time code
1             package CSS::DOM::Style;
2              
3             $VERSION = '0.16';
4              
5 22     22   30141 use warnings; no warnings qw' utf8';
  22     22   42  
  22         732  
  22         109  
  22         43  
  22         749  
6 22     22   108 use strict;
  22         42  
  22         502  
7              
8 22     22   3476 use CSS::DOM::Exception 'SYNTAX_ERR';
  22         48  
  22         1189  
9 22     22   11125 use CSS::DOM::Util qw 'escape_ident unescape';
  22         65  
  22         1365  
10 22     22   126 use Scalar::Util 'weaken';
  22         43  
  22         47891  
11              
12             # ~~~ use overload fallback => 1, '@{}' =>
13              
14             # Internal object structure
15             #
16             # Each style object is a hash ref:
17             # {
18             # owner => $owner_rule,
19             # parser => $property_parser,
20             # mod_handler => sub { ... }, # undef initially
21             # names => [...],
22             # props => {...},
23             # pri => {...}, # property priorities
24             # }
25             #
26             # The value of an element in the props hash can be one of three things
27             # 1) a CSSValue object
28             # 2) an array ref that is a blueprint for a CSSValue object:
29             # [ $css_code, $class, @constructor_args]
30             # 3) a string of css code
31             # Item (3) is only used when there is no property parser.
32              
33             sub parse {
34 393     393 1 167619 require CSS::DOM::Parser;
35 393         1591 goto &CSS::DOM::Parser::parse_style_declaration;
36             }
37              
38             sub new {
39 532     532 1 2261 my($class) = shift;
40              
41 532         1219 my $self = bless {}, $class;
42 532 100       1362 if(@_ == 1) {
43 128         397 $self->{owner} = shift;
44             }
45             else {
46 404         787 my %args = @_;
47 404         1194 $self->{owner} = delete $args{owner};
48             $self->{parser}
49 404         946 = delete $args{property_parser};
50             }
51             {
52 532         722 $self->{parser} ||= (
53 532   100     3393 ($self->{owner} || next)->parentStyleSheet || next
      100        
54             )->property_parser;
55             }
56 532         1417 weaken $self->{owner};
57 532         2453 return $self
58             }
59              
60             sub cssText {
61 94     94 1 693 my $self = shift;
62 94         136 my $out;
63 94 100       266 if (defined wantarray) {
64             $out = join "; ", map {
65 88         268 my $pri = $self->getPropertyPriority($_);
66 88         319 "$_: ".$self->getPropertyValue($_)." !"x!!$pri
67             . escape_ident($pri)
68 89         139 } @{$$self{names}};
  89         312  
69             }
70 94 100       335 if(@_) {
71 6         12 my $css = shift;
72             !defined $css || !length $css and
73 6 100 33     38 @$self{'props','names'} = (), return $out;
74              
75 5         792 require CSS::DOM::Parser;
76             my $new =CSS::DOM::Parser::parse_style_declaration(
77             $css, property_parser => $$self{parser}
78 5         25 );
79              
80 5         22 @$self{'props','names'} = @$new{'props','names'};
81 5         218 _m($self);
82             }
83 93         421 return $out;
84             }
85              
86             sub getPropertyValue { # ~~~ Later I plan to make this return lists of
87             # scalars in list context (for list properties).
88 2899     2899 1 6286 my $self = shift;
89 2899   50     8184 my $props = $self->{props} || return '';
90 2899         6016 my $name = lc$_[0];
91              
92 2899 100       8262 if(my $spec = $self->{parser}) { serialise: {
93 1917 100       2481 if(my $p = $spec->get_property($name)) {
  1917         5885  
94 1916 100 66     7069 if(exists $p->{serialise} and my $s = $p->{serialise}) {
95 115         351 my @p = $spec->subproperty_names($name);
96 115         223 my %p;
97 115         261 for(@p) {
98 436         1011 my $v = $self->getPropertyValue($_) ;
99 436 100       1160 length $v or last serialise;
100             $p{$_}
101 403 100       1110 = $spec->get_property($_)->{default} eq $v ?'':$v;
102             }
103 82         285 return $s->(\%p);
104             }
105             }
106             }}
107              
108 2817 100       8728 exists $props->{$name}
109             or return return '';
110 2618         4552 my $val = $props->{$name};
111 2618 100       12925 return ref $val eq 'ARRAY' ? $$val[0]
    100          
112             : !ref $val ? $val
113             : $val->cssText;
114             }
115              
116             sub getPropertyCSSValue {
117 86     86 1 269 my $self = shift;
118 86 100       276 $self->{parser} or return;
119             exists +(my $props = $self->{props} || return)->{
120 85 100 50     457 my $name = lc$_[0]
121             } or return return;
122 81         165 my $valref = \$props->{$name};
123             return ref $$valref eq 'ARRAY'
124             ? scalar (
125             $$$valref[1]->can('new')
126 81 100 66     1014 || do {
127             (my $pack = $$$valref[1]) =~ s e::e/egg;
128             require "$pack.pm";
129             },
130             $$valref =
131             $$$valref[1]->new(
132             owner => $self, property => $name,
133             @$$valref[2..$#$$valref],
134             )
135             ) : $$valref;
136             }
137              
138             sub removeProperty {
139 102     102 1 839 my $self = shift;
140 102         212 my $name = lc shift;
141              
142             # Get the value so we can return it
143 102         156 my $val;
144 102 100       299 $val = $self->getPropertyValue($name)
145             if defined wantarray;
146              
147             # Get names of subprops if we are dealing with a shorthand prop
148 102         147 my @to_delete;
149 102 100       324 if(my $spec = $self->{parser}) {
150 96         292 @to_delete = $spec->subproperty_names($name);
151             }
152 102 100       345 @to_delete or @to_delete = $name;
153              
154             # Delete the properties
155 102         222 for my $name(@to_delete) {
156 175   50     655 delete +($self->{props} || return $val)->{$name};
157 175         1652 @{$$self{names}} = grep $_ ne $name,
158 175 50       248 @{$$self{names} || return $val};
  175         1195  
159             }
160              
161 102         331 $val;
162             }
163              
164             sub getPropertyPriority {
165 92   100 92 1 133 return ${shift->{pri}||return ''}{lc shift} || ''
166             }
167              
168             sub setProperty {
169 1085     1085 1 20682 my ($self, $name, $value, $priority) = @_;
170              
171             # short-circuit for the common case
172 1085 100       2709 length $value or $self->removeProperty($name),return;
173              
174 1054         8175 require CSS'DOM'Parser;
175 1054 100       1789 my @tokens = eval { CSS'DOM'Parser'tokenise_value($value); }
  1054         3140  
176             or die CSS::DOM'Exception->new( SYNTAX_ERR, $@);
177              
178             # check for whitespace/comment assignment
179 1053 100       3445 $tokens[0] =~ /^s+\z/ and $self->removeProperty($name),return;
180              
181 1051   100     3335 my $props = $$self{props} ||= {};
182 1051   100     2932 my $pri = $$self{pri} ||= {};
183              
184 1051         1498 my $val;
185 1051 100       3094 if(my $spec = $self->{parser}) {
186 902 100       3468 my(@args) = $spec->match($name, @tokens)
187             or return;
188 875 100       3120 if(@args == 1) { # shorthand
189 117         183 while(my($k,$v) = each %{ $args[0] }) {
  735         2601  
190 618 100       1896 $self->removeProperty($k), next
191             if $v eq "";
192             exists $$props{$k=lc$k}
193 553 100       1871 or push @{$$self{names}}, $k;
  82         199  
194 553         1056 $$props{$k} = $v;
195 553         1785 $$pri{$k} = $priority;
196             }
197 117         625 return;
198             }
199             else {
200 758         1688 $val = \@args;
201             }
202             }
203              
204 907 100       3487 exists $$props{$name=lc$name} or push @{$$self{names}}, $name;
  135         459  
205 907   66     2753 $$props{$name} = $val || join "", @{ $tokens[1] };
206 907         2373 $$pri{$name} = $priority;
207              
208 907         2037 _m($self);
209             return
210 907         3176 }
211              
212             sub item {
213 4     4 1 13 my $ret = shift->{names}[shift];
214 4 100       24 return defined $ret ? $ret : ''
215             }
216              
217             sub parentRule {
218             shift->{owner}
219 3     3 1 542 }
220              
221             sub _set_property_tokens { # private
222 631     631   1332 my ($self,$name,$types,$tokens) = @_;
223              
224             # Parse out the priority first
225 631         873 my $priority;
226 631 100 66     2063 if($types =~ /(s?(ds?))i\z/ and $tokens->[$-[2]] eq '!') {
227 3         14 $types =~ s///;
228 3         13 $priority = unescape pop @$tokens;
229 3         20 pop @$tokens for 1..length $1;
230             } else {
231 628         1042 $priority = '';
232             }
233              
234             # Get the prop & priority hashes
235 631   100     2955 my $props = $$self{props} ||= {};
236 631   100     2606 my $pri = $$self{pri} ||={};
237              
238             # See if we need to parse the value
239 631         937 my $val;
240 631 100       1527 if(my $spec = $self->{parser}) {
241 13 100       50 my(@args) = $spec->match($name,$types,$tokens)
242             or return;
243 9 100       38 if(@args == 1) {
244 1         3 while(my($k,$v) = each %{ $args[0] }) {
  4         20  
245 3 100       17 $self->removeProperty($k), next
246             if $v eq "";
247             exists $$props{$k=lc$k}
248 2 50       10 or push @{$$self{names}}, $k;
  2         5  
249 2         5 $$props{$k} = $v;
250 2         5 $$pri{$k} = $priority;
251             }
252 1         6 return;
253             }
254             else {
255 8         18 $val = \@args;
256             }
257             }
258 618         1474 else { $val = join "", @$tokens }
259              
260             # Assign the value & priority
261 626 50   1   3561 exists $$props{$name=lc$name} or push @{$$self{names}}, $name;
  626         32660  
  1         8  
  1         2  
  1         14  
262 626         1990 $$props{$name} = $val;
263 626         2813 $$pri{$name} = $priority;
264             }
265              
266              
267             { my $prop_re = qr/[a-z]+(?:[A-Z][a-z]+)*/;
268             sub can {
269 0         0 SUPER::can { shift } @_ or
270 0 0   0 0 0 $_[0] =~ /^$prop_re\z/o ? \&{+shift} : undef;
  0 0       0  
271             }
272             sub AUTOLOAD {
273 2187     2187   445516 my $self = shift;
274 2187 50       14755 if(our $AUTOLOAD =~ /(?<=:)($prop_re)\z/o) {
275 2187         13067 (my $prop = $1) =~ s/([A-Z])/-\l$1/g;
276 2187         3266 my $val;
277             defined wantarray
278 2187 100       7867 and $val = $self->getPropertyValue($prop);
279 2187 100       7635 @_ and $self->setProperty($prop, shift);
280 2187         9526 return $val;
281             } else {
282 0         0 die "Undefined subroutine $AUTOLOAD called at ",
283             join(" line ", (caller)[1,2]), ".\n";
284             }
285             }
286       0     sub DESTROY{}
287             }
288             *cssFloat = \&float;
289              
290             sub modification_handler {
291 110     110 1 257 my $old = (my $self = shift)->{mod_handler};
292 110 100       275 $self->{mod_handler} = shift if @_;
293 110         515 $old;
294             }
295              
296             sub _m#odified
297             {
298 912 100   912   1498 &{$_[0]->{mod_handler} or return}($_[0]);
  912         3094  
299             }
300              
301 97     97 1 420 sub property_parser { shift->{parser} }
302              
303             sub length { # We put this one last to avoid having to say CORE::length
304             # elsewhere.
305 5 100   5 1 17 scalar @{shift->{names}||return 0}
  5         35  
306             }
307              
308              
309              
310             !()__END__()!
311              
312             =head1 NAME
313              
314             CSS::DOM::Style - CSS style declaration class for CSS::DOM
315              
316             =head1 VERSION
317              
318             Version 0.16
319              
320             =head1 SYNOPSIS
321              
322             use CSS::DOM::Style;
323            
324             $style = CSS::DOM::Style::parse(' text-decoration: none ');
325            
326             $style->cssText; # returns 'text-decoration: none'
327             $style->cssText('color: blue'); # replace contents
328            
329             $style->getPropertyValue('color'); # 'blue'
330             $style->color; # same
331             $style->setProperty(color=>'green'); # change it
332             $style->color('green'); # same
333              
334             =head1 DESCRIPTION
335              
336             This module provides the CSS style declaration class for L. (A
337             style declaration is what comes between the braces in C

.)

338             It
339             implements
340             the CSSStyleDeclaration DOM interface.
341              
342             =head1 CONSTRUCTORS
343              
344             =over 4
345              
346             =item CSS::DOM::Style::parse( $string )
347              
348             =item CSS::DOM::Style::parse( $string, property_parser => $parser )
349              
350             This parses the C<$string> and returns a new style declaration
351             object. This is useful if you have text from an HTML C