[rt.cpan.org #65385] Patch for Imager::Color->hsv
[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
d5fb1fdf
PG
396# Lifted from Graphics::Color::RGB
397# Thank you very much
398sub hsv {
399 my( $self ) = @_;
400
401 my( $red, $green, $blue, $alpha ) = $self->rgba;
402 my $max = $red;
403 my $maxc = 'r';
404 my $min = $red;
405
406 if($green > $max) {
407 $max = $green;
408 $maxc = 'g';
409 }
410 if($blue > $max) {
411 $max = $blue;
412 $maxc = 'b';
413 }
414
415 if($green < $min) {
416 $min = $green;
417 }
418 if($blue < $min) {
419 $min = $blue;
420 }
421
422 my ($h, $s, $v);
423
424 if($max == $min) {
425 $h = 0;
426 }
427 elsif($maxc eq 'r') {
428 $h = 60 * (($green - $blue) / ($max - $min)) % 360;
429 }
430 elsif($maxc eq 'g') {
431 $h = (60 * (($blue - $red) / ($max - $min)) + 120);
432 }
433 elsif($maxc eq 'b') {
434 $h = (60 * (($red - $green) / ($max - $min)) + 240);
435 }
436
437 $v = $max/255;
438 if($max == 0) {
439 $s = 0;
440 }
441 else {
442 $s = 1 - ($min / $max);
443 }
444
445 return int($h), $s, $v, $alpha;
446
447}
448
02d1d628
AMH
4491;
450
451__END__
452
453=head1 NAME
454
455Imager::Color - Color handling for Imager.
456
457=head1 SYNOPSIS
458
668c4f62
TC
459 use Imager;
460
02d1d628
AMH
461 $color = Imager::Color->new($red, $green, $blue);
462 $color = Imager::Color->new($red, $green, $blue, $alpha);
463 $color = Imager::Color->new("#C0C0FF"); # html color specification
464
465 $color->set($red, $green, $blue);
466 $color->set($red, $green, $blue, $alpha);
467 $color->set("#C0C0FF"); # html color specification
468
469 ($red, $green, $blue, $alpha) = $color->rgba();
d5fb1fdf 470 @hsv = $color->hsv();
02d1d628
AMH
471
472 $color->info();
473
5f8cbeac
TC
474 if ($color->equals(other=>$other_color)) {
475 ...
476 }
477
02d1d628
AMH
478
479=head1 DESCRIPTION
480
5715f7c3
TC
481This module handles creating color objects used by Imager. The idea
482is that in the future this module will be able to handle color space
483calculations as well.
02d1d628 484
0462442b
TC
485An Imager color consists of up to four components, each in the range 0
486to 255. Unfortunately the meaning of the components can change
487depending on the type of image you're dealing with:
488
489=over
490
491=item *
492
493for 3 or 4 channel images the color components are red, green, blue,
494alpha.
495
496=item *
497
498for 1 or 2 channel images the color components are gray, alpha, with
499the other two components ignored.
500
501=back
502
503An alpha value of zero is fully transparent, an alpha value of 255 is
504fully opaque.
505
42f8a929 506=head1 METHODS
0462442b 507
02d1d628
AMH
508=over 4
509
510=item new
511
512This creates a color object to pass to functions that need a color argument.
513
514=item set
515
516This changes an already defined color. Note that this does not affect any places
517where the color has been used previously.
518
5715f7c3 519=item rgba()
02d1d628 520
5715f7c3
TC
521This returns the red, green, blue and alpha channels of the color the
522object contains.
02d1d628
AMH
523
524=item info
525
5715f7c3 526Calling info merely dumps the relevant color to the log.
02d1d628 527
5f8cbeac
TC
528=item equals(other=>$other_color)
529
530=item equals(other=>$other_color, ignore_alpha=>1)
531
532Compares $self and color $other_color returning true if the color
533components are the same.
534
535Compares all four channels unless C<ignore_alpha> is set. If
536C<ignore_alpha> is set only the first three channels are compared.
537
02d1d628
AMH
538=back
539
faa9b3e7
TC
540You can specify colors in several different ways, you can just supply
541simple values:
542
543=over
544
545=item *
546
547simple numeric parameters - if you supply 3 or 4 numeric arguments, you get a color made up of those RGB (and possibly A) components.
548
549=item *
550
5715f7c3 551a six hex digit web color, either C<RRGGBB> or C<#RRGGBB>
faa9b3e7
TC
552
553=item *
554
5715f7c3 555an eight hex digit web color, either C<RRGGBBAA> or C<#RRGGBBAA>.
faa9b3e7
TC
556
557=item *
558
5715f7c3 559a 3 hex digit web color, C<#RGB> - a value of F becomes 255.
faa9b3e7
TC
560
561=item *
562
5715f7c3
TC
563a color name, from whichever of the gimp C<Named_Colors> file or X
564C<rgb.txt> is found first. The same as using the C<name> keyword.
faa9b3e7
TC
565
566=back
567
568You can supply named parameters:
569
570=over
571
572=item *
573
574'red', 'green' and 'blue', optionally shortened to 'r', 'g' and 'b'.
575The color components in the range 0 to 255.
576
577 # all of the following are equivalent
578 my $c1 = Imager::Color->new(red=>100, blue=>255, green=>0);
579 my $c2 = Imager::Color->new(r=>100, b=>255, g=>0);
580 my $c3 = Imager::Color->new(r=>100, blue=>255, g=>0);
581
582=item *
583
5715f7c3
TC
584C<hue>, C<saturation> and C<value>, optionally shortened to C<h>, C<s> and
585C<v>, to specify a HSV color. 0 <= hue < 360, 0 <= s <= 1 and 0 <= v
faa9b3e7
TC
586<= 1.
587
588 # the same as RGB(127,255,127)
589 my $c1 = Imager::Color->new(hue=>120, v=>1, s=>0.5);
590 my $c1 = Imager::Color->new(hue=>120, value=>1, saturation=>0.5);
591
592=item *
593
5715f7c3
TC
594C<web>, which can specify a 6 or 3 hex digit web color, in any of the
595forms C<#RRGGBB>, C<#RGB>, C<RRGGBB> or C<RGB>.
faa9b3e7
TC
596
597 my $c1 = Imager::Color->new(web=>'#FFC0C0'); # pale red
598
599=item *
600
5715f7c3 601C<gray> or C<grey> which specifies a single channel, from 0 to 255.
faa9b3e7
TC
602
603 # exactly the same
604 my $c1 = Imager::Color->new(gray=>128);
605 my $c1 = Imager::Color->new(grey=>128);
606
607=item *
608
5715f7c3 609C<rgb> which takes a 3 member arrayref, containing each of the red,
faa9b3e7
TC
610green and blue values.
611
612 # the same
613 my $c1 = Imager::Color->new(rgb=>[255, 100, 0]);
614 my $c1 = Imager::Color->new(r=>255, g=>100, b=>0);
615
616=item *
617
5715f7c3 618C<hsv> which takes a 3 member arrayref, containing each of hue,
faa9b3e7
TC
619saturation and value.
620
621 # the same
622 my $c1 = Imager::Color->new(hsv=>[120, 0.5, 1]);
623 my $c1 = Imager::Color->new(hue=>120, v=>1, s=>0.5);
624
625=item *
626
5715f7c3
TC
627C<gimp> which specifies a color from a GIMP palette file. You can
628specify the file name of the palette file with the 'palette'
629parameter, or let Imager::Color look in various places, typically
630C<$HOME/gimp-1.x/palettes/Named_Colors> with and without the version
631number, and in C</usr/share/gimp/palettes/>. The palette file must
632have color names.
faa9b3e7
TC
633
634 my $c1 = Imager::Color->new(gimp=>'snow');
635 my $c1 = Imager::Color->new(gimp=>'snow', palette=>'testimg/test_gimp_pal);
636
637=item *
638
5715f7c3
TC
639C<xname> which specifies a color from an X11 C<rgb.txt> file. You can
640specify the file name of the C<rgb.txt> file with the C<palette>
641parameter, or let Imager::Color look in various places, typically
642C</usr/lib/X11/rgb.txt>.
faa9b3e7
TC
643
644 my $c1 = Imager::Color->new(xname=>'blue') # usually RGB(0, 0, 255)
645
646=item *
647
5715f7c3 648C<builtin> which specifies a color from the built-in color table in
1c00d65b 649Imager::Color::Table. The colors in this module are the same as the
5715f7c3 650default X11 C<rgb.txt> file.
1c00d65b
TC
651
652 my $c1 = Imager::Color->new(builtin=>'black') # always RGB(0, 0, 0)
653
654=item *
655
5715f7c3
TC
656C<name> which specifies a name from either a GIMP palette, an X
657C<rgb.txt> file or the built-in color table, whichever is found first.
faa9b3e7
TC
658
659=item *
660
661'channel0', 'channel1', etc, each of which specifies a single channel. These can be abbreviated to 'c0', 'c1' etc.
662
663=item *
664
665'channels' which takes an arrayref of the channel values.
666
667=back
668
669Optionally you can add an alpha channel to a color with the 'alpha' or
670'a' parameter.
671
672These color specifications can be used for both constructing new
673colors with the new() method and modifying existing colors with the
674set() method.
675
d5fb1fdf
PG
676=head1 METHODS
677
678=head2 hsv
679
680 my($h, $s, $v, $alpha) = $colour->hsv();
681
682Returns the colour as a Hue/Saturation/Value/Alpha tuple.
683
02d1d628
AMH
684=head1 AUTHOR
685
686Arnar M. Hrafnkelsson, addi@umich.edu
5715f7c3 687And a great deal of help from others - see the C<README> for a complete
02d1d628
AMH
688list.
689
690=head1 SEE ALSO
691
0462442b 692Imager(3), Imager::Color
8f22b8d8 693http://imager.perl.org/
02d1d628
AMH
694
695=cut