[rt.cpan.org #65386] really fix #62885
[imager.git] / lib / Imager / Color.pm
CommitLineData
02d1d628
AMH
1package Imager::Color;
2
3use Imager;
4use strict;
f17b46d8
TC
5use vars qw($VERSION);
6
5715f7c3 7$VERSION = "1.011";
02d1d628
AMH
8
9# It's just a front end to the XS creation functions.
10
faa9b3e7
TC
11# used in converting hsv to rgb
12my @hsv_map =
13 (
14 'vkm', 'nvm', 'mvk', 'mnv', 'kmv', 'vmn'
15 );
16
17sub _hsv_to_rgb {
18 my ($hue, $sat, $val) = @_;
19
20 # HSV conversions from pages 401-403 "Procedural Elements for Computer
21 # Graphics", 1985, ISBN 0-07-053534-5.
22
23 my @result;
24 if ($sat <= 0) {
25 return ( 255 * $val, 255 * $val, 255 * $val );
26 }
27 else {
28 $val >= 0 or $val = 0;
29 $val <= 1 or $val = 1;
30 $sat <= 1 or $sat = 1;
31 $hue >= 360 and $hue %= 360;
32 $hue < 0 and $hue += 360;
33 $hue /= 60.0;
34 my $i = int($hue);
35 my $f = $hue - $i;
36 $val *= 255;
37 my $m = $val * (1.0 - $sat);
38 my $n = $val * (1.0 - $sat * $f);
39 my $k = $val * (1.0 - $sat * (1 - $f));
40 my $v = $val;
9d540150 41 my %fields = ( 'm'=>$m, 'n'=>$n, 'v'=>$v, 'k'=>$k, );
faa9b3e7
TC
42 return @fields{split //, $hsv_map[$i]};
43 }
44}
45
46# cache of loaded gimp files
08af8ecb 47# each key is a filename, under each key is a hashref with the following
faa9b3e7
TC
48# keys:
49# mod_time => last mod_time of file
50# colors => hashref name to arrayref of colors
51my %gimp_cache;
52
53# palette search locations
54# this is pretty rude
55# $HOME is replaced at runtime
56my @gimp_search =
57 (
58 '$HOME/.gimp-1.2/palettes/Named_Colors',
59 '$HOME/.gimp-1.1/palettes/Named_Colors',
60 '$HOME/.gimp/palettes/Named_Colors',
61 '/usr/share/gimp/1.2/palettes/Named_Colors',
62 '/usr/share/gimp/1.1/palettes/Named_Colors',
63 '/usr/share/gimp/palettes/Named_Colors',
64 );
65
173c91ba
TC
66my $default_gimp_palette;
67
faa9b3e7
TC
68sub _load_gimp_palette {
69 my ($filename) = @_;
70
71 if (open PAL, "< $filename") {
72 my $hdr = <PAL>;
73 chomp $hdr;
74 unless ($hdr =~ /GIMP Palette/) {
75 close PAL;
76 $Imager::ERRSTR = "$filename is not a GIMP palette file";
77 return;
78 }
79 my $line;
80 my %pal;
81 my $mod_time = (stat PAL)[9];
82 while (defined($line = <PAL>)) {
83 next if $line =~ /^#/ || $line =~ /^\s*$/;
84 chomp $line;
85 my ($r,$g, $b, $name) = split ' ', $line, 4;
86 if ($name) {
87 $name =~ s/\s*\([\d\s]+\)\s*$//;
88 $pal{lc $name} = [ $r, $g, $b ];
89 }
90 }
91 close PAL;
92
93 $gimp_cache{$filename} = { mod_time=>$mod_time, colors=>\%pal };
94
95 return 1;
96 }
97 else {
98 $Imager::ERRSTR = "Cannot open palette file $filename: $!";
99 return;
100 }
101}
102
103sub _get_gimp_color {
104 my %args = @_;
105
106 my $filename;
107 if ($args{palette}) {
108 $filename = $args{palette};
109 }
173c91ba
TC
110 elsif (defined $default_gimp_palette) {
111 # don't search again and again and again ...
112 if (!length $default_gimp_palette
113 || !-f $default_gimp_palette) {
114 $Imager::ERRSTR = "No GIMP palette found";
115 $default_gimp_palette = "";
116 return;
117 }
118
119 $filename = $default_gimp_palette;
120 }
faa9b3e7
TC
121 else {
122 # try to make one up - this is intended to die if tainting is
123 # enabled and $ENV{HOME} is tainted. To avoid that untaint $ENV{HOME}
124 # or set the palette parameter
125 for my $attempt (@gimp_search) {
126 my $work = $attempt; # don't modify the source array
3d782fde
TC
127 $work =~ /\$HOME/ && !defined $ENV{HOME}
128 and next;
faa9b3e7
TC
129 $work =~ s/\$HOME/$ENV{HOME}/;
130 if (-e $work) {
131 $filename = $work;
132 last;
133 }
134 }
135 if (!$filename) {
136 $Imager::ERRSTR = "No GIMP palette found";
173c91ba 137 $default_gimp_palette = "";
faa9b3e7
TC
138 return ();
139 }
173c91ba
TC
140
141 $default_gimp_palette = $filename;
faa9b3e7
TC
142 }
143
144 if ((!$gimp_cache{$filename}
145 || (stat $filename)[9] != $gimp_cache{$filename})
146 && !_load_gimp_palette($filename)) {
147 return ();
148 }
149
150 if (!$gimp_cache{$filename}{colors}{lc $args{name}}) {
151 $Imager::ERRSTR = "Color '$args{name}' isn't in $filename";
152 return ();
153 }
154
155 return @{$gimp_cache{$filename}{colors}{lc $args{name}}};
156}
157
158my @x_search =
159 (
d034a178 160 '/usr/share/X11/rgb.txt', # newer Xorg X11 dists use this
faa9b3e7
TC
161 '/usr/lib/X11/rgb.txt', # seems fairly standard
162 '/usr/local/lib/X11/rgb.txt', # seems possible
163 '/usr/X11R6/lib/X11/rgb.txt', # probably the same as the first
08af8ecb
AMH
164 '/usr/openwin/lib/rgb.txt',
165 '/usr/openwin/lib/X11/rgb.txt',
faa9b3e7
TC
166 );
167
173c91ba
TC
168my $default_x_rgb;
169
d034a178
TC
170# called by the test code to check if we can test this stuff
171sub _test_x_palettes {
172 @x_search;
173}
174
faa9b3e7
TC
175# x rgb.txt cache
176# same structure as %gimp_cache
177my %x_cache;
178
179sub _load_x_rgb {
180 my ($filename) = @_;
181
182 local *RGB;
183 if (open RGB, "< $filename") {
184 my $line;
185 my %pal;
186 my $mod_time = (stat RGB)[9];
187 while (defined($line = <RGB>)) {
188 # the version of rgb.txt supplied with GNU Emacs uses # for comments
189 next if $line =~ /^[!#]/ || $line =~ /^\s*$/;
190 chomp $line;
191 my ($r,$g, $b, $name) = split ' ', $line, 4;
192 if ($name) {
193 $pal{lc $name} = [ $r, $g, $b ];
194 }
195 }
196 close RGB;
197
198 $x_cache{$filename} = { mod_time=>$mod_time, colors=>\%pal };
199
200 return 1;
201 }
202 else {
203 $Imager::ERRSTR = "Cannot open palette file $filename: $!";
204 return;
205 }
206}
207
208sub _get_x_color {
209 my %args = @_;
210
211 my $filename;
212 if ($args{palette}) {
213 $filename = $args{palette};
214 }
173c91ba
TC
215 elsif (defined $default_x_rgb) {
216 unless (length $default_x_rgb) {
217 $Imager::ERRSTR = "No X rgb.txt palette found";
218 return ();
219 }
220 $filename = $default_x_rgb;
221 }
faa9b3e7
TC
222 else {
223 for my $attempt (@x_search) {
224 if (-e $attempt) {
225 $filename = $attempt;
226 last;
227 }
228 }
229 if (!$filename) {
230 $Imager::ERRSTR = "No X rgb.txt palette found";
173c91ba 231 $default_x_rgb = "";
faa9b3e7
TC
232 return ();
233 }
234 }
235
236 if ((!$x_cache{$filename}
173c91ba 237 || (stat $filename)[9] != $x_cache{$filename}{mod_time})
faa9b3e7
TC
238 && !_load_x_rgb($filename)) {
239 return ();
240 }
241
173c91ba
TC
242 $default_x_rgb = $filename;
243
faa9b3e7
TC
244 if (!$x_cache{$filename}{colors}{lc $args{name}}) {
245 $Imager::ERRSTR = "Color '$args{name}' isn't in $filename";
246 return ();
247 }
248
249 return @{$x_cache{$filename}{colors}{lc $args{name}}};
250}
02d1d628
AMH
251
252# Parse color spec into an a set of 4 colors
253
d5556805 254sub _pspec {
faa9b3e7
TC
255 return (@_,255) if @_ == 3 && !grep /[^\d.+eE-]/, @_;
256 return (@_ ) if @_ == 4 && !grep /[^\d.+eE-]/, @_;
02d1d628
AMH
257 if ($_[0] =~
258 /^\#?([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])/i) {
259 return (hex($1),hex($2),hex($3),hex($4));
260 }
261 if ($_[0] =~ /^\#?([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])/i) {
262 return (hex($1),hex($2),hex($3),255);
263 }
faa9b3e7
TC
264 if ($_[0] =~ /^\#([\da-f])([\da-f])([\da-f])$/i) {
265 return (hex($1) * 17, hex($2) * 17, hex($3) * 17, 255);
266 }
267 my %args;
268 if (@_ == 1) {
269 # a named color
270 %args = ( name => @_ );
271 }
272 else {
273 %args = @_;
274 }
275 my @result;
276 if (exists $args{gray}) {
277 @result = $args{gray};
278 }
279 elsif (exists $args{grey}) {
280 @result = $args{grey};
281 }
282 elsif ((exists $args{red} || exists $args{r})
283 && (exists $args{green} || exists $args{g})
284 && (exists $args{blue} || exists $args{b})) {
285 @result = ( exists $args{red} ? $args{red} : $args{r},
286 exists $args{green} ? $args{green} : $args{g},
287 exists $args{blue} ? $args{blue} : $args{b} );
288 }
289 elsif ((exists $args{hue} || exists $args{h})
290 && (exists $args{saturation} || exists $args{'s'})
291 && (exists $args{value} || exists $args{v})) {
292 my $hue = exists $args{hue} ? $args{hue} : $args{h};
293 my $sat = exists $args{saturation} ? $args{saturation} : $args{'s'};
294 my $val = exists $args{value} ? $args{value} : $args{v};
08af8ecb 295
faa9b3e7
TC
296 @result = _hsv_to_rgb($hue, $sat, $val);
297 }
298 elsif (exists $args{web}) {
299 if ($args{web} =~ /^#?([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])$/i) {
300 @result = (hex($1),hex($2),hex($3));
301 }
302 elsif ($args{web} =~ /^#?([\da-f])([\da-f])([\da-f])$/i) {
303 @result = (hex($1) * 17, hex($2) * 17, hex($3) * 17);
304 }
305 }
306 elsif ($args{name}) {
307 unless (@result = _get_gimp_color(%args)) {
308 unless (@result = _get_x_color(%args)) {
1c00d65b
TC
309 require Imager::Color::Table;
310 unless (@result = Imager::Color::Table->get($args{name})) {
311 $Imager::ERRSTR = "No color named $args{name} found";
312 return ();
313 }
faa9b3e7
TC
314 }
315 }
316 }
317 elsif ($args{gimp}) {
318 @result = _get_gimp_color(name=>$args{gimp}, %args);
319 }
320 elsif ($args{xname}) {
321 @result = _get_x_color(name=>$args{xname}, %args);
322 }
1c00d65b
TC
323 elsif ($args{builtin}) {
324 require Imager::Color::Table;
325 @result = Imager::Color::Table->get($args{builtin});
326 }
faa9b3e7
TC
327 elsif ($args{rgb}) {
328 @result = @{$args{rgb}};
329 }
330 elsif ($args{rgba}) {
331 @result = @{$args{rgba}};
332 return @result if @result == 4;
333 }
334 elsif ($args{hsv}) {
335 @result = _hsv_to_rgb(@{$args{hsv}});
336 }
337 elsif ($args{channels}) {
338 return @{$args{channels}};
339 }
340 elsif (exists $args{channel0} || $args{c0}) {
341 my $i = 0;
342 while (exists $args{"channel$i"} || exists $args{"c$i"}) {
343 push(@result,
344 exists $args{"channel$i"} ? $args{"channel$i"} : $args{"c$i"});
345 ++$i;
346 }
347 }
348 else {
349 $Imager::ERRSTR = "No color specification found";
350 return ();
351 }
352 if (@result) {
353 if (exists $args{alpha} || exists $args{a}) {
354 push(@result, exists $args{alpha} ? $args{alpha} : $args{a});
355 }
356 while (@result < 4) {
357 push(@result, 255);
358 }
359 return @result;
360 }
02d1d628
AMH
361 return ();
362}
363
02d1d628
AMH
364sub new {
365 shift; # get rid of class name.
d5556805 366 my @arg = _pspec(@_);
02d1d628
AMH
367 return @arg ? new_internal($arg[0],$arg[1],$arg[2],$arg[3]) : ();
368}
369
370sub set {
371 my $self = shift;
d5556805 372 my @arg = _pspec(@_);
02d1d628
AMH
373 return @arg ? set_internal($self, $arg[0],$arg[1],$arg[2],$arg[3]) : ();
374}
375
5f8cbeac
TC
376sub equals {
377 my ($self, %opts) = @_;
378
379 my $other = $opts{other}
380 or return Imager->_set_error("'other' parameter required");
381 my $ignore_alpha = $opts{ignore_alpha} || 0;
382
383 my @left = $self->rgba;
384 my @right = $other->rgba;
385 my $last_chan = $ignore_alpha ? 2 : 3;
386 for my $ch (0 .. $last_chan) {
387 $left[$ch] == $right[$ch]
388 or return;
389 }
390
391 return 1;
392}
393
ffddd407
TC
394sub CLONE_SKIP { 1 }
395
02d1d628
AMH
3961;
397
398__END__
399
400=head1 NAME
401
402Imager::Color - Color handling for Imager.
403
404=head1 SYNOPSIS
405
668c4f62
TC
406 use Imager;
407
02d1d628
AMH
408 $color = Imager::Color->new($red, $green, $blue);
409 $color = Imager::Color->new($red, $green, $blue, $alpha);
410 $color = Imager::Color->new("#C0C0FF"); # html color specification
411
412 $color->set($red, $green, $blue);
413 $color->set($red, $green, $blue, $alpha);
414 $color->set("#C0C0FF"); # html color specification
415
416 ($red, $green, $blue, $alpha) = $color->rgba();
417 @hsv = $color->hsv(); # not implemented but proposed
418
419 $color->info();
420
5f8cbeac
TC
421 if ($color->equals(other=>$other_color)) {
422 ...
423 }
424
02d1d628
AMH
425
426=head1 DESCRIPTION
427
5715f7c3
TC
428This module handles creating color objects used by Imager. The idea
429is that in the future this module will be able to handle color space
430calculations as well.
02d1d628 431
0462442b
TC
432An Imager color consists of up to four components, each in the range 0
433to 255. Unfortunately the meaning of the components can change
434depending on the type of image you're dealing with:
435
436=over
437
438=item *
439
440for 3 or 4 channel images the color components are red, green, blue,
441alpha.
442
443=item *
444
445for 1 or 2 channel images the color components are gray, alpha, with
446the other two components ignored.
447
448=back
449
450An alpha value of zero is fully transparent, an alpha value of 255 is
451fully opaque.
452
42f8a929 453=head1 METHODS
0462442b 454
02d1d628
AMH
455=over 4
456
457=item new
458
459This creates a color object to pass to functions that need a color argument.
460
461=item set
462
463This changes an already defined color. Note that this does not affect any places
464where the color has been used previously.
465
5715f7c3 466=item rgba()
02d1d628 467
5715f7c3
TC
468This returns the red, green, blue and alpha channels of the color the
469object contains.
02d1d628
AMH
470
471=item info
472
5715f7c3 473Calling info merely dumps the relevant color to the log.
02d1d628 474
5f8cbeac
TC
475=item equals(other=>$other_color)
476
477=item equals(other=>$other_color, ignore_alpha=>1)
478
479Compares $self and color $other_color returning true if the color
480components are the same.
481
482Compares all four channels unless C<ignore_alpha> is set. If
483C<ignore_alpha> is set only the first three channels are compared.
484
02d1d628
AMH
485=back
486
faa9b3e7
TC
487You can specify colors in several different ways, you can just supply
488simple values:
489
490=over
491
492=item *
493
494simple numeric parameters - if you supply 3 or 4 numeric arguments, you get a color made up of those RGB (and possibly A) components.
495
496=item *
497
5715f7c3 498a six hex digit web color, either C<RRGGBB> or C<#RRGGBB>
faa9b3e7
TC
499
500=item *
501
5715f7c3 502an eight hex digit web color, either C<RRGGBBAA> or C<#RRGGBBAA>.
faa9b3e7
TC
503
504=item *
505
5715f7c3 506a 3 hex digit web color, C<#RGB> - a value of F becomes 255.
faa9b3e7
TC
507
508=item *
509
5715f7c3
TC
510a color name, from whichever of the gimp C<Named_Colors> file or X
511C<rgb.txt> is found first. The same as using the C<name> keyword.
faa9b3e7
TC
512
513=back
514
515You can supply named parameters:
516
517=over
518
519=item *
520
521'red', 'green' and 'blue', optionally shortened to 'r', 'g' and 'b'.
522The color components in the range 0 to 255.
523
524 # all of the following are equivalent
525 my $c1 = Imager::Color->new(red=>100, blue=>255, green=>0);
526 my $c2 = Imager::Color->new(r=>100, b=>255, g=>0);
527 my $c3 = Imager::Color->new(r=>100, blue=>255, g=>0);
528
529=item *
530
5715f7c3
TC
531C<hue>, C<saturation> and C<value>, optionally shortened to C<h>, C<s> and
532C<v>, to specify a HSV color. 0 <= hue < 360, 0 <= s <= 1 and 0 <= v
faa9b3e7
TC
533<= 1.
534
535 # the same as RGB(127,255,127)
536 my $c1 = Imager::Color->new(hue=>120, v=>1, s=>0.5);
537 my $c1 = Imager::Color->new(hue=>120, value=>1, saturation=>0.5);
538
539=item *
540
5715f7c3
TC
541C<web>, which can specify a 6 or 3 hex digit web color, in any of the
542forms C<#RRGGBB>, C<#RGB>, C<RRGGBB> or C<RGB>.
faa9b3e7
TC
543
544 my $c1 = Imager::Color->new(web=>'#FFC0C0'); # pale red
545
546=item *
547
5715f7c3 548C<gray> or C<grey> which specifies a single channel, from 0 to 255.
faa9b3e7
TC
549
550 # exactly the same
551 my $c1 = Imager::Color->new(gray=>128);
552 my $c1 = Imager::Color->new(grey=>128);
553
554=item *
555
5715f7c3 556C<rgb> which takes a 3 member arrayref, containing each of the red,
faa9b3e7
TC
557green and blue values.
558
559 # the same
560 my $c1 = Imager::Color->new(rgb=>[255, 100, 0]);
561 my $c1 = Imager::Color->new(r=>255, g=>100, b=>0);
562
563=item *
564
5715f7c3 565C<hsv> which takes a 3 member arrayref, containing each of hue,
faa9b3e7
TC
566saturation and value.
567
568 # the same
569 my $c1 = Imager::Color->new(hsv=>[120, 0.5, 1]);
570 my $c1 = Imager::Color->new(hue=>120, v=>1, s=>0.5);
571
572=item *
573
5715f7c3
TC
574C<gimp> which specifies a color from a GIMP palette file. You can
575specify the file name of the palette file with the 'palette'
576parameter, or let Imager::Color look in various places, typically
577C<$HOME/gimp-1.x/palettes/Named_Colors> with and without the version
578number, and in C</usr/share/gimp/palettes/>. The palette file must
579have color names.
faa9b3e7
TC
580
581 my $c1 = Imager::Color->new(gimp=>'snow');
582 my $c1 = Imager::Color->new(gimp=>'snow', palette=>'testimg/test_gimp_pal);
583
584=item *
585
5715f7c3
TC
586C<xname> which specifies a color from an X11 C<rgb.txt> file. You can
587specify the file name of the C<rgb.txt> file with the C<palette>
588parameter, or let Imager::Color look in various places, typically
589C</usr/lib/X11/rgb.txt>.
faa9b3e7
TC
590
591 my $c1 = Imager::Color->new(xname=>'blue') # usually RGB(0, 0, 255)
592
593=item *
594
5715f7c3 595C<builtin> which specifies a color from the built-in color table in
1c00d65b 596Imager::Color::Table. The colors in this module are the same as the
5715f7c3 597default X11 C<rgb.txt> file.
1c00d65b
TC
598
599 my $c1 = Imager::Color->new(builtin=>'black') # always RGB(0, 0, 0)
600
601=item *
602
5715f7c3
TC
603C<name> which specifies a name from either a GIMP palette, an X
604C<rgb.txt> file or the built-in color table, whichever is found first.
faa9b3e7
TC
605
606=item *
607
608'channel0', 'channel1', etc, each of which specifies a single channel. These can be abbreviated to 'c0', 'c1' etc.
609
610=item *
611
612'channels' which takes an arrayref of the channel values.
613
614=back
615
616Optionally you can add an alpha channel to a color with the 'alpha' or
617'a' parameter.
618
619These color specifications can be used for both constructing new
620colors with the new() method and modifying existing colors with the
621set() method.
622
02d1d628
AMH
623=head1 AUTHOR
624
625Arnar M. Hrafnkelsson, addi@umich.edu
5715f7c3 626And a great deal of help from others - see the C<README> for a complete
02d1d628
AMH
627list.
628
629=head1 SEE ALSO
630
0462442b 631Imager(3), Imager::Color
8f22b8d8 632http://imager.perl.org/
02d1d628
AMH
633
634=cut