File Coverage

lib/Graphics/Toolkit/Color/Name.pm
Criterion Covered Total %
statement 95 100 95.0
branch 72 88 81.8
condition 11 18 61.1
subroutine 17 17 100.0
pod 9 9 100.0
total 204 232 87.9


line stmt bran cond sub pod time code
1 5     5   718 use v5.12;
  5         16  
2              
3             # named colors from X11, HTML (SVG) standard and Pantone report
4              
5             package Graphics::Toolkit::Color::Name;
6 5     5   2077 use Graphics::Toolkit::Color::Values;
  5         14  
  5         163  
7 5     5   29 use Carp;
  5         9  
  5         7715  
8              
9             my $RGB = Graphics::Toolkit::Color::Space::Hub::get_space('RGB');
10             my $HSL = Graphics::Toolkit::Color::Space::Hub::get_space('HSL');
11             my $constants = require Graphics::Toolkit::Color::Name::Constant;
12             our (@name_from_rgb, @name_from_hsl); # search caches
13             _add_color_to_reverse_search( $_, @{$constants->{$_}} ) for all();
14              
15 6     6 1 3672 sub all { sort keys %$constants }
16 45     45 1 1095 sub taken { exists $constants->{ _clean($_[0]) } }
17              
18             sub rgb_from_name {
19 18     18 1 11685 my $name = _clean(shift);
20 18 100       57 @{$constants->{$name}}[0..2] if taken( $name );
  17         104  
21             }
22              
23             sub hsl_from_name {
24 20     20 1 44 my $name = _clean(shift);
25 20 50       40 @{$constants->{$name}}[3..5] if taken( $name );
  20         93  
26             }
27              
28             sub name_from_rgb {
29 130     130 1 230 my (@rgb) = @_;
30 130 100       257 @rgb = @{$rgb[0]} if (ref $rgb[0] eq 'ARRAY');
  1         5  
31 130 50       343 $RGB->check( [@rgb] ) and return; # return if sub did carp
32 130         307 my @names = _names_from_rgb( @rgb );
33 130 50       919 wantarray ? @names : $names[0];
34             }
35              
36             sub name_from_hsl {
37 2     2 1 7 my (@hsl) = @_;
38 2 50       8 @hsl = @{$hsl[0]} if (ref $hsl[0] eq 'ARRAY');
  0         0  
39 2 50       10 $HSL->check( [ @hsl ] ) and return;
40 2         6 my @names = _names_from_hsl( @hsl );
41 2 50       57 wantarray ? @names : $names[0];
42             }
43              
44             sub names_in_hsl_range { # @center, (@d | $d) --> @names
45 17     17 1 16776 my $help = 'need two arguments: 1. array with h s l values '.
46             '2. radius (real number) or array with tolerances in h s l direction';
47 17 100       74 return carp $help if @_ != 2;
48 15         29 my ($hsl_center, $radius) = @_;
49 15 100       53 $HSL->check( $hsl_center ) and return;
50 8 100       24 my $hsl_delta = (ref $radius eq 'ARRAY') ? $radius : [$radius, $radius, $radius];
51 8 100       18 $HSL->check( $hsl_delta ) and return;
52              
53 7 50       18 $hsl_delta->[0] = 180 if $hsl_delta->[0] > 180; # enough to search complete HSL space (prevent double results)
54 7         14 my (@min, @max, @names, $minhrange, $maxhrange);
55 7         29 $min[$_] = $hsl_center->[$_] - $hsl_delta->[$_] for 0..2;
56 7         22 $max[$_] = $hsl_center->[$_] + $hsl_delta->[$_] for 0..2;
57 7 100       15 $min[1] = 0 if $min[1] < 0;
58 7 50       16 $min[2] = 0 if $min[2] < 0;
59 7 100       13 $max[1] = 100 if $max[1] > 100;
60 7 100       16 $max[2] = 100 if $max[2] > 100;
61 7 100       46 my @hrange = ($min[0] < 0) ? ( 0 .. $max[0] , $min[0]+360 .. 359)
    100          
62             : ($max[0] > 360) ? ( 0 .. $max[0]-360, $min[0] .. 359)
63             : ($min[0] .. $max[0]);
64 7         18 for my $h (@hrange){
65 657 100       952 next unless defined $name_from_hsl[ $h ];
66 323         366 for my $s ($min[1] .. $max[1]){
67 2088 100       3169 next unless defined $name_from_hsl[ $h ][ $s ];
68 166         191 for my $l ($min[2] .. $max[2]){
69 2001         2173 my $name = $name_from_hsl[ $h ][ $s ][ $l ];
70 2001 100       2917 next unless defined $name;
71 87 100       176 push @names, (ref $name ? $name->[0] : $name);
72             }
73             }
74             }
75 7 100       50 @names = grep {Graphics::Toolkit::Color::Values->new(['HSL',@$hsl_center])->distance(
  18         73  
76             Graphics::Toolkit::Color::Values->new(['HSL',hsl_from_name($_)]) ) <= $radius} @names if not ref $radius;
77 7         150 @names;
78             }
79              
80             sub add_rgb {
81 6     6 1 4834 my ($name, @rgb) = @_;
82 6 50       19 @rgb = @{$rgb[0]} if (ref $rgb[0] eq 'ARRAY');
  0         0  
83 6 100 66     47 return carp "missing first argument: color name" unless defined $name and $name;
84 5 100       21 $RGB->check( [@rgb] ) and return;
85 2         10 my @hsl = $HSL->deconvert( [$RGB->normalize( \@rgb )], 'RGB');
86 2         10 _add_color( $name, @rgb, $HSL->denormalize(\@hsl) );
87             }
88              
89             sub add_hsl {
90 2     2 1 6 my ($name, @hsl) = @_;
91 2 50       8 @hsl = @{$hsl[0]} if (ref $hsl[0] eq 'ARRAY');
  0         0  
92 2 50 33     12 return carp "missing first argument: color name" unless defined $name and $name;
93 2 50       9 $HSL->check( \@hsl ) and return;
94 2         9 my @rgb = $HSL->convert( [$HSL->normalize( \@hsl )], 'RGB');
95 2         8 _add_color( $name, $RGB->denormalize( \@rgb ), @hsl );
96             }
97              
98             sub _add_color {
99 4     4   11 my ($name, @rgb, @hsl) = @_;
100 4         8 $name = _clean( $name );
101 4 100       10 return carp "there is already a color named '$name' in store of ".__PACKAGE__ if taken( $name );
102 3         10 _add_color_to_reverse_search( $name, @rgb, @hsl);
103 3         11 my $ret = $constants->{$name} = [@rgb, @hsl]; # add to foreward search
104 3 50       24 (ref $ret) ? [@$ret] : ''; # make returned ref not transparent
105             }
106              
107             sub _clean {
108 88     88   127 my $name = shift;
109 88         135 $name =~ tr/_//d;
110 88         304 lc $name;
111             }
112              
113             sub _names_from_rgb { # each of AoAoA cells (if exists) contains name or array with names (shortes first)
114 130 100 100 130   717 return '' unless exists $name_from_rgb[ $_[0] ]
      100        
115             and exists $name_from_rgb[ $_[0] ][ $_[1] ] and exists $name_from_rgb[ $_[0] ][ $_[1] ][ $_[2] ];
116 64         144 my $cell = $name_from_rgb[ $_[0] ][ $_[1] ][ $_[2] ];
117 64 100       211 ref $cell ? @$cell : $cell;
118             }
119              
120             sub _names_from_hsl {
121 2 50 33 2   17 return '' unless exists $name_from_hsl[ $_[0] ]
      33        
122             and exists $name_from_hsl[ $_[0] ][ $_[1] ] and exists $name_from_hsl[ $_[0] ][ $_[1] ][ $_[2] ];
123 2         5 my $cell = $name_from_hsl[ $_[0] ][ $_[1] ][ $_[2] ];
124 2 100       9 ref $cell ? @$cell : $cell;
125             }
126              
127             sub _add_color_to_reverse_search { # my ($name, @rgb, @hsl) = @_;
128 3583     3583   3718 my $name = $_[0];
129 3583         8571 my $cell = $name_from_rgb[ $_[1] ][ $_[2] ][ $_[3] ];
130 3583 100       4698 if (defined $cell) {
131 286 100       386 if (ref $cell) {
132 21 50       50 if (length $name < length $cell->[0] ) { unshift @$cell, $name }
  0         0  
133 21         41 else { push @$cell, $name }
134             } else {
135 265 100       611 $name_from_rgb[ $_[1] ][ $_[2] ][ $_[3] ] =
136             (length $name < length $cell) ? [ $name, $cell ]
137             : [ $cell, $name ] ;
138             }
139 3297         9976 } else { $name_from_rgb[ $_[1] ][ $_[2] ][ $_[3] ] = $name }
140              
141 3583         6839 $cell = $name_from_hsl[ $_[4] ][ $_[5] ][ $_[6] ];
142 3583 100       4470 if (defined $cell) {
143 331 100       437 if (ref $cell) {
144 21 50       43 if (length $name < length $cell->[0] ) { unshift @$cell, $name }
  0         0  
145 21         43 else { push @$cell, $name }
146             } else {
147 310 100       759 $name_from_hsl[ $_[4] ][ $_[5] ][ $_[6] ] =
148             (length $name < length $cell) ? [ $name, $cell ]
149             : [ $cell, $name ] ;
150             }
151 3252         7915 } else { $name_from_hsl[ $_[4] ][ $_[5] ][ $_[6] ] = $name }
152             }
153              
154             1;
155              
156             __END__