File Coverage

blib/lib/Convert/Color.pm
Criterion Covered Total %
statement 102 125 81.6
branch 22 42 52.3
condition 2 11 18.1
subroutine 35 37 94.5
pod 5 16 31.2
total 166 231 71.8


line stmt bran cond sub pod time code
1             # You may distribute under the terms of either the GNU General Public License
2             # or the Artistic License (the same terms as Perl itself)
3             #
4             # (C) Paul Evans, 2009-2023 -- leonerd@leonerd.org.uk
5              
6             package Convert::Color 0.14;
7              
8 18     18   67438 use v5.14;
  18         73  
9 18     18   90 use warnings;
  18         34  
  18         434  
10              
11 18     18   99 use Carp;
  18         33  
  18         1148  
12              
13 18     18   11062 use List::UtilsBy qw( min_by );
  18         35866  
  18         1318  
14 18     18   8203 use Sub::Util 1.40 qw( set_subname );
  18         6008  
  18         1124  
15              
16             # Maximum number of entries in a ->closest_to cache
17 18     18   134 use constant MAX_CACHE_SIZE => 1000;
  18         38  
  18         1880  
18              
19 18         131 use Module::Pluggable require => 0,
20 18     18   8863 search_path => [ 'Convert::Color' ];
  18         211158  
21             my @plugins = Convert::Color->plugins;
22              
23             =head1 NAME
24              
25             C - color space conversions and named lookups
26              
27             =head1 SYNOPSIS
28              
29             use Convert::Color;
30              
31             my $color = Convert::Color->new( 'hsv:76,0.43,0.89' );
32              
33             my ( $red, $green, $blue ) = $color->rgb;
34              
35             # GTK uses 16-bit values
36             my $gtk_col = Gtk2::Gdk::Color->new( $color->as_rgb16->rgb16 );
37              
38             # HTML uses #rrggbb in hex
39             my $html = '';
40              
41             =head1 DESCRIPTION
42              
43             This module provides conversions between commonly used ways to express colors.
44             It provides conversions between color spaces such as RGB and HSV, and it
45             provides ways to look up colors by a name.
46              
47             This class provides a base for subclasses which represent particular color
48             values in particular spaces. The base class provides methods to represent the
49             color in a few convenient forms, though subclasses may provide more specific
50             details for the space in question.
51              
52             For more detail, read the documentation on these classes; namely:
53              
54             =over 4
55              
56             =item *
57              
58             L - red/green/blue as floats between 0 and 1
59              
60             =item *
61              
62             L - red/green/blue as 8-bit integers
63              
64             =item *
65              
66             L - red/green/blue as 16-bit integers
67              
68             =item *
69              
70             L - hue/saturation/value
71              
72             =item *
73              
74             L - hue/saturation/lightness
75              
76             =item *
77              
78             L - cyan/magenta/yellow
79              
80             =item *
81              
82             L - cyan/magenta/yellow/key (blackness)
83              
84             =back
85              
86             The following classes are subclasses of one of the above, which provide a way
87             to access predefined colors by names:
88              
89             =over 4
90              
91             =item *
92              
93             L - named lookup for the basic VGA colors
94              
95             =item *
96              
97             L - named lookup of colors from X11's F
98              
99             =back
100              
101             =cut
102              
103             =head1 CONSTRUCTOR
104              
105             =cut
106              
107             my $_space2class_cache_initialised;
108             my %_space2class_cache; # {$space} = $class
109             my %_class2space_cache; # {$class} = $space
110              
111             # doc'ed later for readability...
112             sub register_color_space
113             {
114 105     105 1 413 my $class = shift;
115 105         290 my ( $space ) = @_;
116              
117 105 50       378 exists $_space2class_cache{$space} and croak "Color space $space is already defined";
118 105 50       322 exists $_class2space_cache{$class} and croak "Class $class already declared a color space";
119              
120 105         218 $_space2class_cache{$space} = $class;
121 105         209 $_class2space_cache{$class} = $space;
122              
123 18     18   3326 no strict 'refs';
  18         45  
  18         16316  
124 105         1152 *{"as_$space"} = set_subname "as_$space" => sub {
125 83     83 0 319 shift->convert_to( $space )
        83 0    
        83 0    
        83 0    
        83 0    
        83 0    
        83 0    
        83 0    
        92 0    
        84      
126 105         1018 };
127             }
128              
129             sub _space2class
130             {
131 129     129   240 my ( $space ) = @_;
132              
133 129 100       321 unless( $_space2class_cache_initialised ) {
134 10         21 $_space2class_cache_initialised++;
135             # Initialise the space name to class cache
136 10         30 foreach my $class ( @plugins ) {
137 100         584 ( my $file = "$class.pm" ) =~ s{::}{/}g;
138 100 50       33169 require $file or next;
139              
140 100 50       527 $class->can( 'COLOR_SPACE' ) or next;
141 0 0       0 my $thisspace = $class->COLOR_SPACE or next;
142              
143 0         0 warnings::warn( deprecated => "Discovered $class by deprecated COLOR_SPACE method" );
144              
145 0         0 $class->register_color_space( $thisspace );
146             }
147             }
148              
149 129         412 return $_space2class_cache{$space};
150             }
151              
152             =head2 new
153              
154             $color = Convert::Color->new( STRING )
155              
156             Return a new value to represent the color specified by the string. This string
157             should be prefixed by the name of the color space to which it applies. For
158             example
159              
160             rgb:RED,GREEN,BLUE
161             rgb8:RRGGBB
162             rgb16:RRRRGGGGBBBB
163             hsv:HUE,SAT,VAL
164             hsl:HUE,SAT,LUM
165             cmy:CYAN,MAGENTA,YELLOW
166             cmyk:CYAN,MAGENTA,YELLOW,KEY
167              
168             vga:NAME
169             vga:INDEX
170              
171             x11:NAME
172              
173             For more detail, see the constructor of the color space subclass in question.
174              
175             =cut
176              
177             sub new
178             {
179 8     8 1 98 shift;
180 8         31 my ( $str ) = @_;
181              
182 8 50       58 $str =~ m/^(\w+):(.*)$/ or croak "Unable to parse color name $str";
183 8         30 ( my $space, $str ) = ( $1, $2 );
184              
185 8 50       26 my $class = _space2class( $space ) or croak "Unrecognised color space name '$space'";
186              
187 8         42 return $class->new( $str );
188             }
189              
190             =head1 METHODS
191              
192             =cut
193              
194             =head2 rgb
195              
196             ( $red, $green, $blue ) = $color->rgb
197              
198             Returns the individual red, green and blue color components of the color
199             value. For RGB values, this is done directly. For values in other spaces, this
200             is done by first converting them to an RGB value using their C
201             method.
202              
203             =cut
204              
205             sub rgb
206             {
207 0     0 1 0 my $self = shift;
208 0         0 croak "Abstract method - should be overloaded by ".ref($self);
209             }
210              
211             =head1 COLOR SPACE CONVERSIONS
212              
213             Cross-conversion between color spaces is provided by the C
214             method, assisted by helper methods in the two color space classes involved.
215              
216             When converting C<$color> from color space SRC to color space DEST, the
217             following operations are attemped, in this order. SRC and DEST refer to the
218             names of the color spaces, e.g. C.
219              
220             =over 4
221              
222             =item 1.
223              
224             If SRC and DEST are equal, return C<$color> as it stands.
225              
226             =item 2.
227              
228             If the SRC space's class provides a C method, use it.
229              
230             =item 3.
231              
232             If the DEST space's class provides a C constructor, call it and
233             pass C<$color>.
234              
235             =item 4.
236              
237             If the DEST space's class provides a C constructor, convert C<$color>
238             to red/green/blue components then call it.
239              
240             =item 5.
241              
242             If none of these operations worked, then throw an exception.
243              
244             =back
245              
246             These functions may be called in the following ways:
247              
248             $other = $color->convert_to_DEST()
249             $other = Dest::Class->new_from_SRC( $color )
250             $other = Dest::Class->new_rgb( $color->rgb )
251              
252             =cut
253              
254             =head2 convert_to
255              
256             $other = $color->convert_to( $space )
257              
258             Attempt to convert the color into its representation in the given space. See
259             above for the various ways this may be achieved.
260              
261             If the relevant subclass has already been loaded (either explicitly, or
262             implicitly by either the C or C methods), then a specific
263             conversion method will be installed in the class.
264              
265             $other = $color->as_$space
266              
267             Methods of this form are currently Ced if they do not yet exist, but
268             this feature should not be relied upon - see below.
269              
270             =cut
271              
272             sub convert_to
273             {
274 121     121 1 288 my $self = shift;
275 121         229 my ( $to_space ) = @_;
276              
277 121 50       236 my $to_class = _space2class( $to_space ) or croak "Unrecognised color space name '$to_space'";
278              
279 121         297 my $from_space = $_class2space_cache{ref $self};
280              
281 121 100       279 if( $from_space eq $to_space ) {
282             # Identity conversion
283 42         132 return $self;
284             }
285              
286 79         115 my $code;
287 79 100       231 if( $code = $self->can( "convert_to_$to_space" ) ) {
    100          
    50          
288 30         80 return $code->( $self );
289             }
290             elsif( $code = $to_class->can( "new_from_$from_space" ) ) {
291 3         12 return $code->( $to_class, $self );
292             }
293             elsif( $code = $to_class->can( "new_rgb" ) ) {
294             # TODO: check that $self->rgb is overloaded
295 46         145 return $code->( $to_class, $self->rgb );
296             }
297             else {
298 0         0 croak "Cannot convert from space '$from_space' to space '$to_space'";
299             }
300             }
301              
302             # Fallback implementations in case subclasses don't provide anything better
303              
304             sub convert_to_rgb
305             {
306 28     28 0 72 my $self = shift;
307 28         147 require Convert::Color::RGB;
308 28         83 return Convert::Color::RGB->new( $self->rgb );
309             }
310              
311             =head1 AUTOLOADED CONVERSION METHODS
312              
313             This class provides C and C behaviour which automatically
314             constructs conversion methods. The following method calls are identical:
315              
316             $color->convert_to('rgb')
317             $color->as_rgb
318              
319             The generated method will be stored in the package, so that future calls will
320             not have the AUTOLOAD overhead.
321              
322             This feature is deprecated and should not be relied upon, due to the delicate
323             nature of C.
324              
325             =cut
326              
327             # Since this is AUTOLOADed, we can dynamically provide new methods for classes
328             # discovered at runtime.
329              
330             sub can
331             {
332 274     274 0 494 my $self = shift;
333 274         445 my ( $method ) = @_;
334              
335 274 50       656 if( $method =~ m/^as_(.*)$/ ) {
336 0         0 my $to_space = $1;
337 0 0       0 _space2class( $to_space ) or return undef;
338              
339             return sub {
340 0     0   0 my $self = shift;
341 0         0 return $self->convert_to( $to_space );
342 0         0 };
343             }
344              
345 274         1747 return $self->SUPER::can( $method );
346             }
347              
348             sub AUTOLOAD
349             {
350 197     197   14012 my ( $method ) = our $AUTOLOAD =~ m/::([^:]+)$/;
351              
352 197 50       3219 return if $method eq "DESTROY";
353              
354 0 0 0     0 if( ref $_[0] and my $code = $_[0]->can( $method ) ) {
355             # It's possible that the lazy loading by ->can has just created this method
356 0         0 warnings::warn( deprecated => "Relying on AUTOLOAD to provide $method" );
357 18     18   145 no strict 'refs';
  18         60  
  18         4629  
358 0 0       0 unless( defined &{$method} ) {
  0         0  
359 0         0 *{$method} = $code;
  0         0  
360             }
361 0         0 goto &$code;
362             }
363              
364 0   0     0 my $class = ref $_[0] || $_[0];
365 0         0 croak qq(Cannot locate object method "$method" via package "$class");
366             }
367              
368             =head1 OTHER METHODS
369              
370             As well as the above, it is likely the subclass will provide accessors to
371             directly obtain the components of its representation in the specific space.
372             For more detail, see the documentation for the specific subclass in question.
373              
374             =cut
375              
376             =head1 SUBCLASS METHODS
377              
378             This base class is intended to be subclassed to provide more color spaces.
379              
380             =cut
381              
382             =head2 register_color_space
383              
384             $class->register_color_space( $space )
385              
386             A subclass should call this method to register itself as a named color space.
387              
388             =cut
389              
390             =head2 register_palette
391              
392             $class->register_palette( %args )
393              
394             A subclass that provides a fixed set of color values should call this method,
395             to set up automatic conversions that look for the closest match within the
396             set. This conversion process is controlled by the C<%args>:
397              
398             =over 8
399              
400             =item enumerate => STRING or CODE
401              
402             A method name or anonymous CODE reference which will be used to generate the
403             list of color values.
404              
405             =item enumerate_once => STRING or CODE
406              
407             As per C, but will be called only once and the results cached.
408              
409             =back
410              
411             This method creates a new class method on the calling package, called
412             C.
413              
414             =head2 closest_to
415              
416             $color = $pkg->closest_to( $orig, $space )
417              
418             Returns the color in the space closest to the given value. The distance is
419             measured in the named space; defaulting to C if this is not provided.
420              
421             In the case of a tie, where two or more colors have the same distance from the
422             target, the first one will be chosen.
423              
424             =cut
425              
426             sub register_palette
427             {
428 21     21 1 49 my $pkg = shift;
429 21         63 my %args = @_;
430              
431 21         38 my $enumerate;
432              
433 21 100       85 if( $args{enumerate} ) {
    50          
434 11         28 $enumerate = $args{enumerate};
435             }
436             elsif( my $enumerate_once = $args{enumerate_once} ) {
437 10         23 my @colors;
438             $enumerate = sub {
439 1     1   3 my $class = shift;
440 1 50       19 @colors = $class->$enumerate_once unless @colors;
441 1         25 return @colors;
442             }
443 10         48 }
444             else {
445 0         0 croak "Require 'enumerate' or 'enumerate_once'";
446             }
447              
448 18     18   137 no strict 'refs';
  18         39  
  18         6972  
449              
450 21         41 my %cache;
451 21         127 *{"${pkg}::closest_to"} = set_subname "${pkg}::closest_to" => sub {
452 1     1   3 my $class = shift;
        1      
        1      
453 1         2 my ( $orig, $space ) = @_;
454              
455 1   50     4 $space ||= "rgb";
456              
457             # Prevent the cache getting -too- big
458 1         5 delete $cache{ each %cache } while keys %cache > MAX_CACHE_SIZE;
459              
460 1         6 $orig = $orig->convert_to( $space );
461 1         3 my $dst = "dst_${space}_cheap";
462              
463 1         5 my $key = join ",", $space, $orig->$space;
464              
465             return $cache{$key} //=
466 1   33 1   12 min_by { $orig->$dst( $_->convert_to( $space ) ) } $class->$enumerate;
  8         85  
467 21         199 };
468              
469 21         70 foreach my $space (qw( rgb hsv hsl )) {
470 63         275 *{"${pkg}::new_from_${space}"} = set_subname "${pkg}::new_from_${space}" => sub {
471 1     2   2 my $class = shift;
472 1         3 my ( $rgb ) = @_;
473 1         3 return $pkg->closest_to( $rgb, $space );
474 63         407 };
475             }
476              
477 21         120 *{"${pkg}::new_rgb"} = set_subname "${pkg}::new_rgb" => sub {
478 0     2     my $class = shift;
479 0           return $class->closest_to( Convert::Color::RGB->new( @_ ), "rgb" );
480 21         146 };
481             }
482              
483             =head1 AUTHOR
484              
485             Paul Evans
486              
487             =cut
488              
489             0x55AA;