File Coverage

blib/lib/CSS/DOM/Value/Primitive.pm
Criterion Covered Total %
statement 154 166 92.7
branch 98 124 79.0
condition 60 102 58.8
subroutine 32 32 100.0
pod 4 16 25.0
total 348 440 79.0


line stmt bran cond sub pod time code
1             package CSS::DOM::Value::Primitive;
2              
3             $VERSION = '0.16';
4              
5 9     9   65296 use warnings; no warnings qw 'utf8 parenthesis';;
  9     9   21  
  9         336  
  9         46  
  9         18  
  9         342  
6 9     9   48 use strict;
  9         19  
  9         210  
7              
8 9     9   47 use Carp;
  9         16  
  9         774  
9             use CSS::DOM::Constants
10 9     9   1701 <%SuffixToConst NO_MODIFICATION_ALLOWED_ERR INVALID_ACCESS_ERR>;
  9         19  
  9         1513  
11 9         734 use CSS::DOM::Util qw '
12             unescape
13             unescape_url
14             unescape_str escape_str
15 9     9   3017 escape_ident ';
  9         56  
16 9     9   53 use Exporter 5.57 'import';
  9         173  
  9         962  
17              
18             sub DOES {
19 31 50   31 0 10834 return 1 if $_[1] eq 'CSS::DOM::Value';
20 0 0       0 goto &UNIVERSAL'DOES if defined &UNIVERSAL'DOES;
21             }
22              
23 9         1471 use constant 1.03 our $_const = { # Don’t conflict with the superclass!
24             type => 2,
25             valu => 3, # counters
26             csst => 4, name => 0,
27             ownr => 5, sepa => 1,
28             prop => 6, styl => 2,
29             indx => 7,
30             form => 8,
31             sfrm => 9, # serialisation format; used currently only by colours
32 9     9   48 };
  9         140  
33 9     9   48 { no strict; delete @{__PACKAGE__.'::'}{_const => keys %{our $_const}} }
  9         16  
  9         16961  
34              
35             *EXPORT_OK = $CSS::DOM::Constants::EXPORT_TAGS{primitive};
36             our %EXPORT_TAGS = ( all => \our @EXPORT_OK );
37              
38              
39             sub new {
40 250     250 0 26831 my $class = shift;
41 250         1026 my %args = @_;
42 250         544 for('type','value') {
43 0         0 croak "The $_ argument to new ${\__PACKAGE__} is required"
44 500 50       1527 unless exists $args{$_};
45             }
46 250         539 my $self = bless[], $class;
47             @$self[type,valu,csst,ownr,prop,indx,form]
48 250         9977 = @args{< type value css owner property index format >};
49 250         1806 $self;
50             }
51              
52             my @unit_suffixes;
53             $unit_suffixes[CSS_PERCENTAGE ] = '%';
54             $unit_suffixes[CSS_EMS ] = 'em';
55             $unit_suffixes[CSS_EXS ] = 'ex';
56             $unit_suffixes[CSS_PX ] = 'px';
57             $unit_suffixes[CSS_CM ] = 'cm';
58             $unit_suffixes[CSS_MM ] = 'mm';
59             $unit_suffixes[CSS_IN ] = 'in';
60             $unit_suffixes[CSS_PT ] = 'pt';
61             $unit_suffixes[CSS_PC ] = 'pc';
62             $unit_suffixes[CSS_DEG ] = 'deg';
63             $unit_suffixes[CSS_RAD ] = 'rad';
64             $unit_suffixes[CSS_GRAD ] = 'grad';
65             $unit_suffixes[CSS_MS ] = 'ms';
66             $unit_suffixes[CSS_S ] = 's';
67             $unit_suffixes[CSS_HZ ] = 'Hz';
68             $unit_suffixes[CSS_KHZ ] = 'kHz';
69              
70             sub cssText {
71 382     382 1 13437 my $self = shift;
72 382         473 my $old;
73 382 100       1004 if(defined wantarray) {
74 280 100       670 if(defined $self->[csst]) {
75 182         340 $old = $self->[csst]
76             }
77 98         211 else { for($self->[type]) {
78 98         924 my $val = $self->[valu];
79             $old
80             = $_ == CSS_RECT
81             ? 'rect('
82             . join(
83             ', ',
84             map $self->$_->cssText,
85            
86             )
87             .')'
88             : $_ == CSS_RGBCOLOR
89             ? ref $val eq 'ARRAY'
90 98 100       551 ? do {
    100          
    100          
    100          
91 6         156 my(@val_objs,$ret)
92             = map $self->$_, ;
93 6 100 100     52 if(
      66        
94             my $form = $$self[sfrm]
95             and
96             @$val < 4 || $$val[3]->getFloatValue==1
97             ){
98 3 100       15 if($form =~ /^#/) {
99             # Try to preserve original #bed/#c0ffee
100             # format if possible
101 2         6 my $digits = chop $form;
102 2 50       12 if($digits == 1) {
103 0         0 for my $val_obj(@val_objs) {
104 0         0 my $val = $val_obj->getFloatValue;
105 0 0       0 if(
106             $val_obj->primitiveType
107             == CSS_NUMBER
108             ){
109 0 0 0     0 not $val % 17 and $val == int $val
      0        
      0        
110             and $val > 0 and $val < 256
111             # ~~~ Would it be faster simply to use
112             # a regexp?
113             or undef $ret, last;
114 0         0 $ret .= sprintf "%x", $val/17;
115             }
116             else { # percentage
117 0 0 0     0 not $val % 20 and $val == int $val
      0        
      0        
118             and $val > 0 and $val < 101
119             # ~~~ Would it be faster simply to use
120             # a regexp?
121             or undef $ret, last;
122 0         0 $ret .= sprintf "%x", $val * .15;
123             }
124             }
125             }
126 2 50 33     13 if(!$val || $digits == 2) {
127 2         5 for my $val_obj(@val_objs) {
128 4         11 my $val = $val_obj->getFloatValue;
129 4 100       10 if(
    50          
130             $val_obj->primitiveType
131             == CSS_NUMBER
132             ){
133 3 50 33     24 $val == int $val
      33        
134             and $val > 0 and $val < 256
135             or undef $ret, last;
136 3         12 $ret .= sprintf "%02x", $val;
137             }
138             elsif($digits == 2) { # percentage
139 1 0 33     9 not $val % 20 and $val == int $val
      33        
      0        
140             and $val > 0 and $val < 101
141             # ~~~ Would it be faster simply to use
142             # a regexp?
143             or undef $ret, last;
144 0         0 $ret .= sprintf "%02x",$val * 2.55;
145             }
146             }
147             }
148 2 100       15 $ret and substr $ret,0,0, = '#';
149             }
150             else { # named colour
151 1         4 my $rgb = (\our %Colours)->{lc $form};
152 1 50 33     4 $val_objs[0]->getFloatValue
      33        
153             == $$rgb[0]
154             and $val_objs[1]->getFloatValue
155             == $$rgb[1]
156             and $val_objs[2]->getFloatValue
157             == $$rgb[2]
158             and $ret = $form;
159             }
160             }
161            
162 6 100       28 unless($ret) {
163             my @types
164 4         13 = map $_->primitiveType, @val_objs;
165 4 100 66     21 if($types[0] == $types[1]
166             && $types[0] == $types[2]) {
167 2         7 $ret = join ", ",
168             map cssText $_, @val_objs;
169             }
170             else {
171 2 50 33     13 my $type = $types[
172             $types[0] == $types[1]
173             || $types[0] == $types[2]
174             ? 0
175             : 1
176             ];
177 2 100       15 $ret = join ", ", $type == CSS_NUMBER
    0          
    50          
178             ? map
179             $types[$_] == CSS_NUMBER
180             ? $val_objs[$_]->getFloatValue
181             : $val_objs[$_]->getFloatValue
182             * 255/100,
183             0...2
184             : map
185             $types[$_] == CSS_PERCENTAGE
186             ? $val_objs[$_]->getFloatValue
187             : $val_objs[$_]->getFloatValue
188             * 100/255 . '%',
189             0...2;
190             }
191 4         9 my $alpha;
192 4 100 66     43 @$val >= 4 && (
193             $alpha = $self->alpha->cssText
194             ) != 1
195             ? "rgba($ret, $alpha)"
196             : "rgb($ret)"
197             }
198             }
199             : $val =~ /^#/
200             ? $val
201             : escape_ident $val
202             : _serialise($_,$val)
203             }}
204             }
205 382 100       963 if(@_) {
206             require CSS'DOM'Exception,
207 104 100       1213 die new CSS'DOM'Exception
208             NO_MODIFICATION_ALLOWED_ERR,
209             "Unowned value objects cannot be modified"
210             unless my $owner = $self->[ownr];
211 100         171 my $prop = $$self[prop];
212              
213             # deal with formats
214 100 100       573 if(my $format = $$self[form]) {
    50          
    100          
    100          
215 10 100       26 if(!our $parser) {
216 1         6 require CSS'DOM'PropertyParser;
217 1         2 add_property{
218 1         8 $parser = new CSS'DOM'PropertyParser
219             } _=>our $prop_spec = {};
220             }
221 10         20 our $prop_spec->{format} = $format;
222 10 100       15 if(my @args = match { our $parser } _=> shift) {
  10         34  
223 5         26 require CSS'DOM'Value;
224 5         18 CSS'DOM'Value'_apply_args_to_self(
225             $self, $owner, $prop,
226             @args, format => $format,
227             );
228             }
229             }
230              
231             # This is never reached, at least not when CSS::DOM’s mod-
232             # ules call the constructor:
233             elsif(!defined $prop) {
234             require CSS'DOM'Exception,
235 0         0 die new CSS'DOM'Exception
236             NO_MODIFICATION_ALLOWED_ERR,
237             ref($self) . " objects that do not know to which "
238             ."property they belong cannot be modified"
239             }
240              
241             # sub-values of a list
242             elsif(defined(my $index = $$self[indx])) {
243 9         32 my $old_list
244             = $owner->getPropertyCSSValue($prop);
245             # ~~~ What do we do if $old_list is undef?
246             # In what circumstances can
247             # that happen?
248             # ~~~ If we add an API to PropertyParser to allow
249             # for list sub-value formats, we can do away
250             # with this inefficient mess.
251 9         33 my $length = $old_list->length;
252             my @arsg
253             = $owner->property_parser->match(
254             $prop,
255             join $old_list->{s}, # ~~~ we probably need an
256             # API to avoid this encap viol
257 9         32 map(
258             $old_list->item($_)->cssText, 0..$index-1
259             ),
260             $_[0],
261             map(
262             $old_list->item($_)->cssText,
263             $index+1..$length-1
264             ),
265             );
266 9         66 require CSS'DOM'Value;
267 9         33 CSS'DOM'Value'_load_if_necessary($arsg[1]);
268 9         41 my $list = $arsg[1]->new(
269             owner => $owner,
270             property => $prop,
271             @arsg[2..$#arsg]
272             );
273 9 50       36 if($list->length != $length) {
274             # This would mean we were given a
275             # string with commas or a blank
276             # string, which are invalid.
277 0         0 return $old
278             }
279 9         17 @$self = @{ $list->item($index) };
  9         28  
280             }
281              
282             # property-level values
283             elsif(
284             my @arsg
285             = $owner->property_parser->match($prop, $_[0])
286             ) {
287 39         1266 require CSS'DOM'Value;
288 39         136 CSS'DOM'Value'_apply_args_to_self(
289             $self, $owner, $prop, @arsg
290             );
291             }
292              
293 100 100       483 if(my $mh = $owner->modification_handler) {
294 16         37 &$mh();
295             }
296             }
297 378         1802 $old;
298             }
299              
300             sub _serialise {
301 173     173   295 my ($type, $val) = @_;
302 173         373 for($type) {
303 9     9   62 no warnings 'numeric';
  9         17  
  9         3568  
304             return
305             $_ == CSS_ATTR
306             ? 'attr(' . $val . ')'
307             : $_ == CSS_URI
308             ? 'url(' . $val. ')'
309             : $_ == CSS_RECT
310             ? die "_serialise does not support rects"
311             : $_ == CSS_RGBCOLOR
312             ? die "_serialise does not support colours"
313             : $_ == CSS_STRING
314 173 100       1858 ? do {
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
315 10         30 (my $str = $val) =~ s/'/\\'/g;;
316 10         53 return "'$str'";
317             }
318             : $_ == CSS_COUNTER
319             ? 'counter' . 's' x defined($$val[sepa]) . '('
320             . escape_ident($$val[name])
321             . (defined $$val[sepa]
322             ? ", " . escape_str($$val[sepa])
323             : '' )
324             . (defined $$val[styl]
325             ? ", " . escape_ident($$val[styl])
326             : '' )
327             . ")"
328             : $_ == CSS_DIMENSION
329             ? $$val[0].escape_ident$$val[1]
330             : $_ == CSS_NUMBER
331             ? 0+$val
332             : $unit_suffixes[$_]
333             ? 0+$val . $unit_suffixes[$_]
334             : $val;
335             }
336              
337             }
338              
339 67     67 1 321 sub cssValueType { CSS::DOM::Value::CSS_PRIMITIVE_VALUE }
340              
341 49     49 1 8890 sub primitiveType { shift->[type] }
342              
343             sub setFloatValue {
344 96     96 0 17832 my ($self,$type,$val) = @'_;
345              
346             require CSS'DOM'Exception,
347 96 100 100     1249 die new CSS'DOM'Exception INVALID_ACCESS_ERR, "Invalid value type"
      100        
      100        
      100        
348             if $type == CSS_UNKNOWN || $type == CSS_COUNTER
349             || $type == CSS_RECT || $type == CSS_RGBCOLOR || $type == CSS_DIMENSION;
350              
351             # This is not particularly efficient, but I doubt anyone is actually
352             # using this API.
353 9     9   50 no warnings 'numeric';
  9         22  
  9         2093  
354 86         243 $self->cssText(my $css = _serialise($type, $val));
355             require CSS'DOM'Exception,
356 84 100       199 die new CSS'DOM'Exception INVALID_ACCESS_ERR, "Invalid value: $css"
357             if $self->cssText ne $css;
358             _:
359             }
360              
361             sub getFloatValue {
362 44     44 1 76 my $self = shift;
363              
364             # There are more types that are numbers than are not, so we
365             # invert our list.
366 44         75 my $type = $self->[type];
367             require CSS'DOM'Exception,
368 44 100 66     908 die new CSS'DOM'Exception INVALID_ACCESS_ERR, "Not a numeric value"
      100        
      100        
      100        
      100        
      100        
      100        
369             if $type == CSS_UNKNOWN || $type == CSS_STRING || $type == CSS_URI
370             || $type == CSS_IDENT || $type == CSS_ATTR || $type == CSS_COUNTER
371             || $type == CSS_RECT || $type == CSS_RGBCOLOR;
372              
373 9     9   55 no warnings"numeric";
  9         16  
  9         4057  
374 33 100       209 0+($type == CSS_DIMENSION ? $$self[valu][0] : $$self[valu])
375             }
376              
377             *setStringValue = *setFloatValue;
378              
379             sub getStringValue {
380 29     29 0 52 my $self = shift;
381              
382 29         49 my $type = $self->[type];
383             require CSS'DOM'Exception,
384 29 100 100     431 die new CSS'DOM'Exception INVALID_ACCESS_ERR, "Not a string value"
      100        
      100        
385             unless $type == CSS_STRING || $type == CSS_URI
386             || $type == CSS_IDENT || $type == CSS_ATTR;
387              
388 4         21 "$$self[valu]"
389             }
390              
391             # ------------- Rect interface --------------- #
392              
393             sub _autoviv_rect_value {
394 13     13   30 my($self,$index) = @_;
395 13         33 for my $val($$self[valu][$index]) {
396 13 100       45 if(ref $val eq 'ARRAY') {
397 12         36 $val = new
398             __PACKAGE__,
399             owner => $$self[ownr],
400             format => '|auto',
401             @$val;
402 12         33 delete $$self[csst]; # prevent this from being used by cssText; hence-
403             } # forth we must use the subvalues
404 13         66 return $val
405             }
406             }
407              
408 4     4 0 23 sub top { _autoviv_rect_value $_[0], 0 }
409 3     3 0 11 sub right { _autoviv_rect_value $_[0], 1 }
410 3     3 0 13 sub bottom { _autoviv_rect_value $_[0], 2 }
411 3     3 0 11 sub left { _autoviv_rect_value $_[0], 3 }
412              
413             # ------------- RGBColor interface --------------- #
414              
415             sub _autoviv_colour_value {
416 50     50   83 my($self,$index) = @_;
417 50 100       162 if(ref $$self[valu] ne 'ARRAY') {
418 4 100       23 if($$self[valu] =~ /^#(..|.)(..|.)(..|.)/) {
419 3         10 my $x = -length($1) + 3;
420 3         10 $$self[sfrm] = '#' . length $1;
421 9     9   63 no strict 'refs';
  9         22  
  9         3538  
422 3         47 $$self[valu] = [
423             map([type => CSS_NUMBER, value => hex $$_ x$x], 1...3),
424             ];
425             }
426             else {
427 1 50       1179 our %Colours or require "CSS/DOM/Value/Primitive/colours.pl";
428 1         12 my $rgb = $Colours{lc($$self[sfrm] = $$self[valu])};
429 1         7 $$self[valu] = [
430             map
431             [type => CSS_NUMBER, value => $_],
432             @$rgb
433             ];
434             }
435             }
436 50         117 for my $val($$self[valu][$index]) {
437 50 100 66     185 if(ref $val eq 'ARRAY') {
    100          
438 33 100       110 $val = new
439             __PACKAGE__,
440             owner => $$self[ownr],
441             format => $index == 3 ? '' : '|',
442             @$val;
443 33         79 delete $$self[csst];
444             }
445             elsif(!defined $val and $index == 3) { # alpha
446 6         19 $val = new
447             __PACKAGE__,
448             owner => $$self[ownr],
449             format => '',
450             type => CSS_NUMBER,
451             value => 1;
452 6         11 delete $$self[csst];
453             }
454 50         219 return $val
455             }
456             }
457              
458 14     14 0 64 sub red { _autoviv_colour_value $_[0], 0 }
459 13     13 0 38 sub green { _autoviv_colour_value $_[0], 1 }
460 13     13 0 39 sub blue { _autoviv_colour_value $_[0], 2 }
461 10     10 0 30 sub alpha { _autoviv_colour_value $_[0], 3 }
462              
463             !()__END__()!
464              
465             =head1 NAME
466              
467             CSS::DOM::Value::Primitive - CSSPrimitiveValue class for CSS::DOM
468              
469             =head1 VERSION
470              
471             Version 0.16
472              
473             =head1 SYNOPSIS
474              
475             # ...
476              
477             =head1 DESCRIPTION
478              
479             This module implements objects that represent CSS primitive property
480             values (as opposed to lists). It
481             implements the DOM CSSPrimitiveValue, Rect, and RGBColor interfaces.
482              
483             =head1 METHODS
484              
485             If you need the constructor, it's below the object methods. Normally you
486             would get an object via L
487             method|CSS::DOM::Style/getPropertyCSSValue>.
488              
489             =head2 CSSValue Interface
490              
491             =over 4
492              
493             =item cssText
494              
495             Returns a string representation of the attribute. Pass an argument to set
496             it.
497              
498             =item cssValueType
499              
500             Returns C.
501              
502             =back
503              
504             =head2 CSSPrimitiveValue Interface
505              
506             =over
507              
508             =item primitiveType
509              
510             Returns one of the L listed below.
511              
512             =item getFloatValue
513              
514             Returns a number if the value is numeric.
515              
516             =back
517              
518             The rest have still to be implemented.
519              
520             =head2 Rect Interface
521              
522             The four methods C, C, C and C each return
523             another
524             value object representing the individual value.
525              
526             =head2 RGBColor Interface
527              
528             The four methods C, C, C and C each return another
529             value object representing the individual value.
530              
531             =head2 Constructor
532              
533             You probably don't need to call this, but here it is anyway:
534              
535             $val = new CSS::DOM::Value::Primitive:: %args;
536              
537             The hash-style arguments are as follows. Only C and C are
538             required.
539              
540             =over
541              
542             =item type
543              
544             One of the constants listed below under L
545              
546             =item value
547              
548             The data stored inside the value object. The format expected depends on the
549             type. See below.
550              
551             =item css
552              
553             CSS code used for serialisation. This will make reading C faster
554             at least until the value is modified.
555              
556             =item owner
557              
558             The style object that owns this value; if this is omitted, then the value
559             is read-only. The value object holds a weak reference to the owner.
560              
561             =item property
562              
563             The name of the CSS property to which this value belongs. C uses
564             this to determine how to parse text passed to it. This does not
565             apply to the sub-values of colours, counters and rects, but it I
566             apply to individual elements of a list value.
567              
568             =item index
569              
570             The index of this value within a list value (only applies to elements of a
571             list, of course).
572              
573             =item format
574              
575             This is used by sub-values of colours and rects. It determines
576             how assignment to C is handled. This uses the same syntax as the
577             formats in L.
578              
579             =back
580              
581             Here are the formats for the C argument, which depend on the type:
582              
583             =over
584              
585             =item CSS_UNKNOWN
586              
587             A string of CSS code.
588              
589             =item CSS_NUMBER, CSS_PERCENTAGE
590              
591             A simple scalar containing a number.
592              
593             =item Standard Dimensions
594              
595             Also a simple scalar containing a number.
596              
597             This applies to C, C, C, C, C, C, C, C, C, C, C, C, C, C and C.
598              
599             =item CSS_DIMENSION
600              
601             An array ref: C<[$number, $unit_text]>
602              
603             =item CSS_STRING
604              
605             A simple scalar containing a string (not a CSS string literal; i.e., no
606             quotes or escapes).
607              
608             =item CSS_URI
609              
610             The URL (not a CSS literal)
611              
612             =item CSS_IDENT
613              
614             A string (no escapes)
615              
616             =item CSS_ATTR
617              
618             A string containing the name of the attribute.
619              
620             =item CSS_COUNTER
621              
622             An array ref: C<[$name, $separator, $style]>
623              
624             C<$separator> and C<$style> may each be C. If C<$separator> is
625             C, the object represents a C. Otherwise it represents
626             C.
627              
628             =item CSS_RECT
629              
630             An array ref: C<[$top, $right, $bottom, $left]>
631              
632             The four elements are either CSSValue objects or
633             array refs of arguments to be passed to the constructor. E.g.:
634              
635             [
636             [type => CSS_PX, value => 20],
637             [type => CSS_PERCENTAGE, value => 50],
638             [type => CSS_PERCENTAGE, value => 50],
639             [type => CSS_PX, value => 50],
640             ]
641              
642             When these array refs are converted to objects, the C
643             argument is supplied automatically, so you do not need to include it here.
644              
645             =item CSS_RGBCOLOR
646              
647             A string beginning with '#', with no escapes (such as '#fff' or '#c0ffee'),
648             a colour name (like red) or an array ref with three to four elements:
649              
650             [$r, $g, $b]
651             [$r, $g, $b, $alpha]
652              
653             The elements are either CSSValue objects or array refs of
654             argument lists, as with C.
655              
656             =back
657              
658             =head1 CONSTANTS
659              
660             The following constants can be imported with
661             C.
662             They represent the type of primitive value.
663              
664             =over
665              
666             =item CSS_UNKNOWN
667              
668             =item CSS_NUMBER
669              
670             =item CSS_PERCENTAGE
671              
672             =item CSS_EMS
673              
674             =item CSS_EXS
675              
676             =item CSS_PX
677              
678             =item CSS_CM
679              
680             =item CSS_MM
681              
682             =item CSS_IN
683              
684             =item CSS_PT
685              
686             =item CSS_PC
687              
688             =item CSS_DEG
689              
690             =item CSS_RAD
691              
692             =item CSS_GRAD
693              
694             =item CSS_MS
695              
696             =item CSS_S
697              
698             =item CSS_HZ
699              
700             =item CSS_KHZ
701              
702             =item CSS_DIMENSION
703              
704             =item CSS_STRING
705              
706             =item CSS_URI
707              
708             =item CSS_IDENT
709              
710             =item CSS_ATTR
711              
712             =item CSS_COUNTER
713              
714             =item CSS_RECT
715              
716             =item CSS_RGBCOLOR
717              
718             =back
719              
720             =head1 SEE ALSO
721              
722             L
723              
724             L
725              
726             L
727              
728             L