File Coverage

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


line stmt bran cond sub pod time code
1             package CSS::DOM::Style;
2              
3             $VERSION = '0.17';
4              
5 22     22   59416 use warnings; no warnings qw' utf8';
  22     22   45  
  22         645  
  22         89  
  22         33  
  22         570  
6 22     22   88 use strict;
  22         30  
  22         459  
7              
8 22     22   2097 use CSS::DOM::Exception 'SYNTAX_ERR';
  22         31  
  22         928  
9 22     22   6999 use CSS::DOM::Util qw 'escape_ident unescape';
  22         51  
  22         997  
10 22     22   122 use Scalar::Util 'weaken';
  22         25  
  22         36374  
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 168566 require CSS::DOM::Parser;
35 393         1350 goto &CSS::DOM::Parser::parse_style_declaration;
36             }
37              
38             sub new {
39 532     532 1 2041 my($class) = shift;
40              
41 532         921 my $self = bless {}, $class;
42 532 100       1029 if(@_ == 1) {
43 128         248 $self->{owner} = shift;
44             }
45             else {
46 404         545 my %args = @_;
47 404         799 $self->{owner} = delete $args{owner};
48             $self->{parser}
49 404         702 = delete $args{property_parser};
50             }
51             {
52 532         606 $self->{parser} ||= (
53 532   100     1828 ($self->{owner} || next)->parentStyleSheet || next
      100        
54             )->property_parser;
55             }
56 532         1291 weaken $self->{owner};
57 532         1486 return $self
58             }
59              
60             sub cssText {
61 94     94 1 412 my $self = shift;
62 94         109 my $out;
63 94 100       166 if (defined wantarray) {
64             $out = join "; ", map {
65 88         158 my $pri = $self->getPropertyPriority($_);
66 88         187 "$_: ".$self->getPropertyValue($_)." !"x!!$pri
67             . escape_ident($pri)
68 89         111 } @{$$self{names}};
  89         166  
69             }
70 94 100       207 if(@_) {
71 6         10 my $css = shift;
72             !defined $css || !length $css and
73 6 100 66     28 @$self{'props','names'} = (), return $out;
74              
75 5         443 require CSS::DOM::Parser;
76             my $new =CSS::DOM::Parser::parse_style_declaration(
77             $css, property_parser => $$self{parser}
78 5         15 );
79              
80 5         33 @$self{'props','names'} = @$new{'props','names'};
81 5         149 _m($self);
82             }
83 93         263 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 2901     2901 1 4489 my $self = shift;
89 2901   50     5138 my $props = $self->{props} || return '';
90 2901         4446 my $name = lc$_[0];
91              
92 2901 100       4614 if(my $spec = $self->{parser}) { serialise: {
93 1919 100       1911 if(my $p = $spec->get_property($name)) {
  1919         3317  
94 1918 100 66     3729 if(exists $p->{serialise} and my $s = $p->{serialise}) {
95 115         217 my @p = $spec->subproperty_names($name);
96 115         161 my %p;
97 115         179 for(@p) {
98 438         609 my $v = $self->getPropertyValue($_) ;
99 438 100       693 length $v or last serialise;
100             $p{$_}
101 405 100       629 = $spec->get_property($_)->{default} eq $v ?'':$v;
102             }
103 82         177 return $s->(\%p);
104             }
105             }
106             }}
107              
108 2819 100       4992 exists $props->{$name}
109             or return return '';
110 2620         3715 my $val = $props->{$name};
111 2620 100       7367 return ref $val eq 'ARRAY' ? $$val[0]
    100          
112             : !ref $val ? $val
113             : $val->cssText;
114             }
115              
116             sub getPropertyCSSValue {
117 86     86 1 208 my $self = shift;
118 86 100       192 $self->{parser} or return;
119             exists +(my $props = $self->{props} || return)->{
120 85 100 50     273 my $name = lc$_[0]
121             } or return return;
122 81         116 my $valref = \$props->{$name};
123             return ref $$valref eq 'ARRAY'
124             ? scalar (
125             $$$valref[1]->can('new')
126 81 100 66     647 || 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 677 my $self = shift;
140 102         157 my $name = lc shift;
141              
142             # Get the value so we can return it
143 102         108 my $val;
144 102 100       162 $val = $self->getPropertyValue($name)
145             if defined wantarray;
146              
147             # Get names of subprops if we are dealing with a shorthand prop
148 102         116 my @to_delete;
149 102 100       198 if(my $spec = $self->{parser}) {
150 96         196 @to_delete = $spec->subproperty_names($name);
151             }
152 102 100       202 @to_delete or @to_delete = $name;
153              
154             # Delete the properties
155 102         148 for my $name(@to_delete) {
156 175   50     398 delete +($self->{props} || return $val)->{$name};
157 175         671 @{$$self{names}} = grep $_ ne $name,
158 175 50       176 @{$$self{names} || return $val};
  175         656  
159             }
160              
161 102         197 $val;
162             }
163              
164             sub getPropertyPriority {
165 92   100 92 1 106 return ${shift->{pri}||return ''}{lc shift} || ''
166             }
167              
168             sub setProperty {
169 1085     1085 1 23117 my ($self, $name, $value, $priority) = @_;
170              
171             # short-circuit for the common case
172 1085 100       1872 length $value or $self->removeProperty($name),return;
173              
174 1054         6415 require CSS'DOM'Parser;
175 1054 100       1380 my @tokens = eval { CSS'DOM'Parser'tokenise_value($value); }
  1054         2137  
176             or die CSS::DOM'Exception->new( SYNTAX_ERR, $@);
177              
178             # check for whitespace/comment assignment
179 1053 100       2347 $tokens[0] =~ /^s+\z/ and $self->removeProperty($name),return;
180              
181 1051   100     2366 my $props = $$self{props} ||= {};
182 1051   100     1839 my $pri = $$self{pri} ||= {};
183              
184 1051         1090 my $val;
185 1051 100       2026 if(my $spec = $self->{parser}) {
186 902 100       2429 my(@args) = $spec->match($name, @tokens)
187             or return;
188 875 100       1644 if(@args == 1) { # shorthand
189 117         132 while(my($k,$v) = each %{ $args[0] }) {
  735         1536  
190 618 100       1006 $self->removeProperty($k), next
191             if $v eq "";
192             exists $$props{$k=lc$k}
193 553 100       1036 or push @{$$self{names}}, $k;
  82         117  
194 553         734 $$props{$k} = $v;
195 553         923 $$pri{$k} = $priority;
196             }
197 117         356 return;
198             }
199             else {
200 758         1143 $val = \@args;
201             }
202             }
203              
204 907 100       2371 exists $$props{$name=lc$name} or push @{$$self{names}}, $name;
  135         309  
205 907   66     2371 $$props{$name} = $val || join "", @{ $tokens[1] };
206 907         1280 $$pri{$name} = $priority;
207              
208 907         1756 _m($self);
209             return
210 907         1801 }
211              
212             sub item {
213 4     4 1 8 my $ret = shift->{names}[shift];
214 4 100       80 return defined $ret ? $ret : ''
215             }
216              
217             sub parentRule {
218             shift->{owner}
219 3     3 1 497 }
220              
221             sub _set_property_tokens { # private
222 631     631   1168 my ($self,$name,$types,$tokens) = @_;
223              
224             # Parse out the priority first
225 631         654 my $priority;
226 631 100 66     1226 if($types =~ /(s?(ds?))i\z/ and $tokens->[$-[2]] eq '!') {
227 3         10 $types =~ s///;
228 3         8 $priority = unescape pop @$tokens;
229 3         11 pop @$tokens for 1..length $1;
230             } else {
231 628         720 $priority = '';
232             }
233              
234             # Get the prop & priority hashes
235 631   100     1982 my $props = $$self{props} ||= {};
236 631   100     1487 my $pri = $$self{pri} ||={};
237              
238             # See if we need to parse the value
239 631         709 my $val;
240 631 100       962 if(my $spec = $self->{parser}) {
241 13 100       48 my(@args) = $spec->match($name,$types,$tokens)
242             or return;
243 9 100       16 if(@args == 1) {
244 1         3 while(my($k,$v) = each %{ $args[0] }) {
  4         14  
245 3 100       12 $self->removeProperty($k), next
246             if $v eq "";
247             exists $$props{$k=lc$k}
248 2 50       7 or push @{$$self{names}}, $k;
  2         3  
249 2         3 $$props{$k} = $v;
250 2         3 $$pri{$k} = $priority;
251             }
252 1         4 return;
253             }
254             else {
255 8         22 $val = \@args;
256             }
257             }
258 618         1722 else { $val = join "", @$tokens }
259              
260             # Assign the value & priority
261 626 50   1   2432 exists $$props{$name=lc$name} or push @{$$self{names}}, $name;
  626         20579  
  1         5  
  1         2  
  1         8  
262 626         1331 $$props{$name} = $val;
263 626         1746 $$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   374940 my $self = shift;
274 2187 50       12559 if(our $AUTOLOAD =~ /(?<=:)($prop_re)\z/o) {
275 2187         10908 (my $prop = $1) =~ s/([A-Z])/-\l$1/g;
276 2187         3206 my $val;
277             defined wantarray
278 2187 100       5195 and $val = $self->getPropertyValue($prop);
279 2187 100       5242 @_ and $self->setProperty($prop, shift);
280 2187         6458 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 196 my $old = (my $self = shift)->{mod_handler};
292 110 100       185 $self->{mod_handler} = shift if @_;
293 110         292 $old;
294             }
295              
296             sub _m#odified
297             {
298 912 100   912   1179 &{$_[0]->{mod_handler} or return}($_[0]);
  912         1719  
299             }
300              
301 97     97 1 329 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 10 scalar @{shift->{names}||return 0}
  5         22  
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.17
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