f2bd30d61c21b6d45cc68a4815375f998b5cbf2b
[imager.git] / lib / Imager / Color.pm
1 package Imager::Color;
2
3 use Imager;
4 use strict;
5 use vars qw($VERSION);
6
7 $VERSION = "1.012";
8
9 # It's just a front end to the XS creation functions.
10
11 # used in converting hsv to rgb
12 my @hsv_map =
13   (
14    'vkm', 'nvm', 'mvk', 'mnv', 'kmv', 'vmn'
15   );
16
17 sub _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;
41     my %fields = ( 'm'=>$m, 'n'=>$n, 'v'=>$v, 'k'=>$k, );
42     return @fields{split //, $hsv_map[$i]};
43   }
44 }
45
46 # cache of loaded gimp files
47 # each key is a filename, under each key is a hashref with the following
48 # keys:
49 #   mod_time => last mod_time of file
50 #   colors => hashref name to arrayref of colors
51 my %gimp_cache;
52
53 # palette search locations
54 # this is pretty rude
55 # $HOME is replaced at runtime
56 my @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
66 my $default_gimp_palette;
67
68 sub _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
103 sub _get_gimp_color {
104   my %args = @_;
105
106   my $filename;
107   if ($args{palette}) {
108     $filename = $args{palette};
109   }
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   }
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
127       $work =~ /\$HOME/ && !defined $ENV{HOME}
128         and next;
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";
137       $default_gimp_palette = "";
138       return ();
139     }
140
141     $default_gimp_palette = $filename;
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
158 my @x_search =
159   (
160    '/usr/share/X11/rgb.txt', # newer Xorg X11 dists use this
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
164    '/usr/openwin/lib/rgb.txt',
165    '/usr/openwin/lib/X11/rgb.txt',
166   );
167
168 my $default_x_rgb;
169
170 # called by the test code to check if we can test this stuff
171 sub _test_x_palettes {
172   @x_search;
173 }
174
175 # x rgb.txt cache
176 # same structure as %gimp_cache
177 my %x_cache;
178
179 sub _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
208 sub _get_x_color {
209   my %args = @_;
210
211   my $filename;
212   if ($args{palette}) {
213     $filename = $args{palette};
214   }
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   }
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";
231       $default_x_rgb = "";
232       return ();
233     }
234   }
235
236   if ((!$x_cache{$filename}
237       || (stat $filename)[9] != $x_cache{$filename}{mod_time})
238      && !_load_x_rgb($filename)) {
239     return ();
240   }
241
242   $default_x_rgb = $filename;
243
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 }
251
252 # Parse color spec into an a set of 4 colors
253
254 sub _pspec {
255   return (@_,255) if @_ == 3 && !grep /[^\d.+eE-]/, @_;
256   return (@_    ) if @_ == 4 && !grep /[^\d.+eE-]/, @_;
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   }
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};
295
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)) {
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         }
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   }
323   elsif ($args{builtin}) {
324     require Imager::Color::Table;
325     @result = Imager::Color::Table->get($args{builtin});
326   }
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     my @ch = @{$args{channels}};
339     return ( @ch, (0) x (4 - @ch) );
340   }
341   elsif (exists $args{channel0} || $args{c0}) {
342     my $i = 0;
343     while (exists $args{"channel$i"} || exists $args{"c$i"}) {
344       push(@result,
345            exists $args{"channel$i"} ? $args{"channel$i"} : $args{"c$i"});
346       ++$i;
347     }
348   }
349   else {
350     $Imager::ERRSTR = "No color specification found";
351     return ();
352   }
353   if (@result) {
354     if (exists $args{alpha} || exists $args{a}) {
355       push(@result, exists $args{alpha} ? $args{alpha} : $args{a});
356     }
357     while (@result < 4) {
358       push(@result, 255);
359     }
360     return @result;
361   }
362   return ();
363 }
364
365 sub new {
366   shift; # get rid of class name.
367   my @arg = _pspec(@_);
368   return @arg ? new_internal($arg[0],$arg[1],$arg[2],$arg[3]) : ();
369 }
370
371 sub set {
372   my $self = shift;
373   my @arg = _pspec(@_);
374   return @arg ? set_internal($self, $arg[0],$arg[1],$arg[2],$arg[3]) : ();
375 }
376
377 sub equals {
378   my ($self, %opts) = @_;
379
380   my $other = $opts{other}
381     or return Imager->_set_error("'other' parameter required");
382   my $ignore_alpha = $opts{ignore_alpha} || 0;
383
384   my @left = $self->rgba;
385   my @right = $other->rgba;
386   my $last_chan = $ignore_alpha ? 2 : 3;
387   for my $ch (0 .. $last_chan) {
388     $left[$ch] == $right[$ch]
389       or return;
390   }
391
392   return 1;
393 }
394
395 sub CLONE_SKIP { 1 }
396
397 # Lifted from Graphics::Color::RGB
398 # Thank you very much
399 sub hsv {
400     my( $self ) = @_;
401
402     my( $red, $green, $blue, $alpha ) = $self->rgba;
403     my $max = $red;
404     my $maxc = 'r';
405     my $min = $red;
406
407     if($green > $max) {
408         $max = $green;
409         $maxc = 'g';
410     }
411     if($blue > $max) {
412         $max = $blue;
413         $maxc = 'b';
414     }
415
416     if($green < $min) {
417         $min = $green;
418     }
419     if($blue < $min) {
420         $min = $blue;
421     }
422
423     my ($h, $s, $v);
424
425     if($max == $min) {
426         $h = 0;
427     }
428     elsif($maxc eq 'r') {
429         $h = 60 * (($green - $blue) / ($max - $min)) % 360;
430     }
431     elsif($maxc eq 'g') {
432         $h = (60 * (($blue - $red) / ($max - $min)) + 120);
433     }
434     elsif($maxc eq 'b') {
435         $h = (60 * (($red - $green) / ($max - $min)) + 240);
436     }
437
438     $v = $max/255;
439     if($max == 0) {
440         $s = 0;
441     }
442     else {
443         $s = 1 - ($min / $max);
444     }
445
446     return int($h), $s, $v, $alpha;
447
448 }
449
450 1;
451
452 __END__
453
454 =head1 NAME
455
456 Imager::Color - Color handling for Imager.
457
458 =head1 SYNOPSIS
459
460   use Imager;
461
462   $color = Imager::Color->new($red, $green, $blue);
463   $color = Imager::Color->new($red, $green, $blue, $alpha);
464   $color = Imager::Color->new("#C0C0FF"); # html color specification
465
466   $color->set($red, $green, $blue);
467   $color->set($red, $green, $blue, $alpha);
468   $color->set("#C0C0FF"); # html color specification
469
470   ($red, $green, $blue, $alpha) = $color->rgba();
471   @hsv = $color->hsv();
472
473   $color->info();
474
475   if ($color->equals(other=>$other_color)) {
476     ...
477   }
478
479
480 =head1 DESCRIPTION
481
482 This module handles creating color objects used by Imager.  The idea
483 is that in the future this module will be able to handle color space
484 calculations as well.
485
486 An Imager color consists of up to four components, each in the range 0
487 to 255. Unfortunately the meaning of the components can change
488 depending on the type of image you're dealing with:
489
490 =over
491
492 =item *
493
494 for 3 or 4 channel images the color components are red, green, blue,
495 alpha.
496
497 =item *
498
499 for 1 or 2 channel images the color components are gray, alpha, with
500 the other two components ignored.
501
502 =back
503
504 An alpha value of zero is fully transparent, an alpha value of 255 is
505 fully opaque.
506
507 =head1 METHODS
508
509 =over 4
510
511 =item new
512
513 This creates a color object to pass to functions that need a color argument.
514
515 =item set
516
517 This changes an already defined color.  Note that this does not affect any places
518 where the color has been used previously.
519
520 =item rgba()
521
522 This returns the red, green, blue and alpha channels of the color the
523 object contains.
524
525 =item info
526
527 Calling info merely dumps the relevant color to the log.
528
529 =item equals(other=>$other_color)
530
531 =item equals(other=>$other_color, ignore_alpha=>1)
532
533 Compares $self and color $other_color returning true if the color
534 components are the same.
535
536 Compares all four channels unless C<ignore_alpha> is set.  If
537 C<ignore_alpha> is set only the first three channels are compared.
538
539 =back
540
541 You can specify colors in several different ways, you can just supply
542 simple values:
543
544 =over
545
546 =item *
547
548 simple numeric parameters - if you supply 3 or 4 numeric arguments, you get a color made up of those RGB (and possibly A) components.
549
550 =item *
551
552 a six hex digit web color, either C<RRGGBB> or C<#RRGGBB>
553
554 =item *
555
556 an eight hex digit web color, either C<RRGGBBAA> or C<#RRGGBBAA>.
557
558 =item *
559
560 a 3 hex digit web color, C<#RGB> - a value of F becomes 255.
561
562 =item *
563
564 a color name, from whichever of the gimp C<Named_Colors> file or X
565 C<rgb.txt> is found first.  The same as using the C<name> keyword.
566
567 =back
568
569 You can supply named parameters:
570
571 =over
572
573 =item *
574
575 'red', 'green' and 'blue', optionally shortened to 'r', 'g' and 'b'.
576 The color components in the range 0 to 255.
577
578  # all of the following are equivalent
579  my $c1 = Imager::Color->new(red=>100, blue=>255, green=>0);
580  my $c2 = Imager::Color->new(r=>100, b=>255, g=>0);
581  my $c3 = Imager::Color->new(r=>100, blue=>255, g=>0);
582
583 =item *
584
585 C<hue>, C<saturation> and C<value>, optionally shortened to C<h>, C<s> and
586 C<v>, to specify a HSV color.  0 <= hue < 360, 0 <= s <= 1 and 0 <= v
587 <= 1.
588
589   # the same as RGB(127,255,127)
590   my $c1 = Imager::Color->new(hue=>120, v=>1, s=>0.5);
591   my $c1 = Imager::Color->new(hue=>120, value=>1, saturation=>0.5);
592
593 =item *
594
595 C<web>, which can specify a 6 or 3 hex digit web color, in any of the
596 forms C<#RRGGBB>, C<#RGB>, C<RRGGBB> or C<RGB>.
597
598   my $c1 = Imager::Color->new(web=>'#FFC0C0'); # pale red
599
600 =item *
601
602 C<gray> or C<grey> which specifies a single channel, from 0 to 255.
603
604   # exactly the same
605   my $c1 = Imager::Color->new(gray=>128);
606   my $c1 = Imager::Color->new(grey=>128);
607
608 =item *
609
610 C<rgb> which takes a 3 member arrayref, containing each of the red,
611 green and blue values.
612
613   # the same
614   my $c1 = Imager::Color->new(rgb=>[255, 100, 0]);
615   my $c1 = Imager::Color->new(r=>255, g=>100, b=>0);
616
617 =item *
618
619 C<hsv> which takes a 3 member arrayref, containing each of hue,
620 saturation and value.
621
622   # the same
623   my $c1 = Imager::Color->new(hsv=>[120, 0.5, 1]);
624   my $c1 = Imager::Color->new(hue=>120, v=>1, s=>0.5);
625
626 =item *
627
628 C<gimp> which specifies a color from a GIMP palette file.  You can
629 specify the file name of the palette file with the 'palette'
630 parameter, or let Imager::Color look in various places, typically
631 C<$HOME/gimp-1.x/palettes/Named_Colors> with and without the version
632 number, and in C</usr/share/gimp/palettes/>.  The palette file must
633 have color names.
634
635   my $c1 = Imager::Color->new(gimp=>'snow');
636   my $c1 = Imager::Color->new(gimp=>'snow', palette=>'testimg/test_gimp_pal);
637
638 =item *
639
640 C<xname> which specifies a color from an X11 C<rgb.txt> file.  You can
641 specify the file name of the C<rgb.txt> file with the C<palette>
642 parameter, or let Imager::Color look in various places, typically
643 C</usr/lib/X11/rgb.txt>.
644
645   my $c1 = Imager::Color->new(xname=>'blue') # usually RGB(0, 0, 255)
646
647 =item *
648
649 C<builtin> which specifies a color from the built-in color table in
650 Imager::Color::Table.  The colors in this module are the same as the
651 default X11 C<rgb.txt> file.
652
653   my $c1 = Imager::Color->new(builtin=>'black') # always RGB(0, 0, 0)
654
655 =item *
656
657 C<name> which specifies a name from either a GIMP palette, an X
658 C<rgb.txt> file or the built-in color table, whichever is found first.
659
660 =item *
661
662 'channel0', 'channel1', etc, each of which specifies a single channel.  These can be abbreviated to 'c0', 'c1' etc.
663
664 =item *
665
666 'channels' which takes an arrayref of the channel values.
667
668 =back
669
670 Optionally you can add an alpha channel to a color with the 'alpha' or
671 'a' parameter.
672
673 These color specifications can be used for both constructing new
674 colors with the new() method and modifying existing colors with the
675 set() method.
676
677 =head1 METHODS
678
679 =over
680
681 =item hsv()
682
683     my($h, $s, $v, $alpha) = $color->hsv();
684
685 Returns the color as a Hue/Saturation/Value/Alpha tuple.
686
687 =back
688
689 =head1 AUTHOR
690
691 Arnar M. Hrafnkelsson, addi@umich.edu
692 And a great deal of help from others - see the C<README> for a complete
693 list.
694
695 =head1 SEE ALSO
696
697 Imager(3), Imager::Color
698 http://imager.perl.org/
699
700 =cut