File Coverage

blib/lib/Number/RGB.pm
Criterion Covered Total %
statement 88 90 97.7
branch 22 24 91.6
condition 9 11 81.8
subroutine 31 33 93.9
pod 7 7 100.0
total 157 165 95.1


line stmt bran cond sub pod time code
1             package Number::RGB;
2              
3 1     1   24613 use strict;
  1         3  
  1         29  
4 1     1   7 use warnings;
  1         2  
  1         116  
5              
6             our $VERSION = '1.41'; # VERSION
7              
8 1     1   5 use vars qw[$CONSTRUCTOR_SPEC];
  1         3  
  1         51  
9 1     1   4 use Scalar::Util qw[looks_like_number];
  1         1  
  1         144  
10 1     1   739 use Params::Validate qw[:all];
  1         9616  
  1         192  
11 1     1   7 use base qw[Class::Accessor::Fast];
  1         2  
  1         703  
12 1     1   3918 use Attribute::Handlers 0.99;
  1         5233  
  1         9  
13 1     1   33 use Carp;
  1         2  
  1         330  
14             our @CARP_NOT = ('Attribute::Handlers', __PACKAGE__);
15             $Carp::Internal{'attributes'}++; # no idea why doesn't work in @CARP_NOT
16              
17             sub import {
18 1     1   8 my $class = shift;
19 1         3 my $caller = (caller)[0];
20 1     1   5 eval qq[
  1     1   1  
  1     20   5  
  1         83  
  1         1  
  1         4  
  20         52290  
  1         80  
21             package $caller;
22             use Attribute::Handlers;
23             sub RGB :ATTR(RAWDATA) { goto &$class\::RGB }
24             package $class;
25             ];
26             }
27              
28             use overload fallback => 1,
29             '""' => \&as_string,
30 2     2   557 '+' => sub { shift->_op_math('+', @_) },
31 4     4   1161 '-' => sub { shift->_op_math('-', @_) },
32 3     3   704 '*' => sub { shift->_op_math('*', @_) },
33 3     3   809 '/' => sub { shift->_op_math('/', @_) },
34 0     0   0 '%' => sub { shift->_op_math('%', @_) },
35 0     0   0 '**' => sub { shift->_op_math('**', @_) },
36 2     2   562 '<<' => sub { shift->_op_math('<<', @_) },
37 2     2   532 '>>' => sub { shift->_op_math('>>', @_) },
38 2     2   533 '&' => sub { shift->_op_math('&', @_) },
39 2     2   570 '^' => sub { shift->_op_math('^', @_) },
40 1     1   1498 '|' => sub { shift->_op_math('|', @_) };
  1     2   1046  
  1         17  
  2         537  
41              
42             sub new {
43 2390     2390 1 7255 my $class = shift;
44 2390         31085 my %params = validate( @_, $CONSTRUCTOR_SPEC );
45 1591 100       6377 croak "$class->new() requires parameters" unless keys %params;
46              
47 1590         1611 my %rgb;
48 1590 100       3895 if ( defined $params{rgb} ) {
    100          
    50          
49 802         762 @rgb{qw[r g b]} = @{$params{rgb}};
  802         2793  
50             } elsif ( defined $params{rgb_number} ) {
51 775         2642 return $class->new(rgb => [($params{rgb_number})x3]);
52             } elsif ( defined $params{hex} ) {
53 13         21 my $hex = $params{hex};
54 13         25 $hex =~ s/^#//;
55 13 100       85 $hex =~ s/(.)/$1$1/g if length($hex) == 3;
56 13         99 @rgb{qw[r g b]} = map hex, $hex =~ /(.{2})/g;
57             }
58              
59 815         2551 $class->SUPER::new(\%rgb);
60             }
61              
62             __PACKAGE__->mk_accessors( qw[r g b] );
63              
64 1     1 1 1875 sub rgb { [ map $_[0]->$_, qw[r g b] ] }
65 2     2 1 499 sub hex { '#' . join '', map { substr sprintf('0%x',$_[0]->$_), -2 } qw[r g b] }
  6         38  
66 1     1 1 324 sub hex_uc { uc shift->hex }
67             sub as_string {
68 808     808 1 9068 join ',', map $_[0]->$_, qw[r g b]
69             }
70              
71             sub _op_math {
72 22     22   40 my ($self,$op, $other, $reversed) = @_;
73             ref($self)->new(rgb => [
74             map {
75 22         39 my $x = $self->$_;
  66         167  
76 66 100 66     376 my $y = ref($other) && overload::Overloaded($other) ? $other->$_ : $other;
77 66 100       5103 my $ans = eval ($reversed ? "$y $op $x" : "$x $op $y");
78 66   100     251 $ans = sprintf '%.0f', $ans||0;
79 66 100       140 $ans = 0 if $ans < 0; $ans = 255 if $ans > 255;
  66 100       119  
80 66         175 $ans;
81             } qw[r g b]
82             ] );
83             }
84              
85             sub new_from_guess {
86 788     788 1 11380 my ($class, $value) = @_;
87 788 100       2013 $value = [ $value =~ /\d+/g ] if $value =~ /,/;
88 788   100     4785 my $is_single_rgb = looks_like_number($value) && $value>=0 && $value<=255;
89              
90 788         829 foreach my $param ( keys %{$CONSTRUCTOR_SPEC} ) {
  788         2014  
91 1583 50 66     3898 next if $param eq 'hex' and $is_single_rgb;
92 1583         1783 my $self = eval { $class->new($param => $value) };
  1583         3167  
93 1583 100       666083 return $self if defined $self;
94             }
95 3         28 croak q{couldn't guess value type};
96             }
97              
98             sub RGB :ATTR(RAWDATA) {
99 20     20 1 59 my ($var, $data) = @_[2,4];
100 20         51 $$var = __PACKAGE__->new_from_guess($data);
101 1     1   935 }
  1         3  
  1         6  
102              
103             $CONSTRUCTOR_SPEC = {
104             rgb => {
105             type => ARRAYREF,
106             optional => 1,
107             callbacks => {
108             'three elements' => sub { 3 == @{$_[0]} },
109             'only digits' => sub { 0 == grep /\D/, @{$_[0]} },
110             'between 0 and 255' => sub { 3 == grep { $_ >= 0 && $_ <= 255 } @{$_[0]} },
111             },
112             },
113             rgb_number => {
114             type => SCALAR,
115             optional => 1,
116             callbacks => {
117             'only digits' => sub { $_[0] !~ /\D/ },
118             'between 0 and 255' => sub {
119             looks_like_number($_[0]) and $_[0] >= 0 && $_[0] <= 255
120             },
121             },
122             },
123             hex => {
124             type => SCALAR,
125             optional => 1,
126             callbacks => {
127             'hex format' => sub { $_[0] =~ /^#?(?:[\da-f]{3}|[\da-f]{6})$/i },
128             },
129             }
130             };
131              
132             1;
133              
134             __END__