eliminate use vars
[imager.git] / lib / Imager / Color.pm
1 package Imager::Color;
2 use 5.006;
3 use Imager;
4 use strict;
5
6 our $VERSION = "1.013";
7
8 # It's just a front end to the XS creation functions.
9
10 # used in converting hsv to rgb
11 my @hsv_map =
12   (
13    'vkm', 'nvm', 'mvk', 'mnv', 'kmv', 'vmn'
14   );
15
16 sub _hsv_to_rgb {
17   my ($hue, $sat, $val) = @_;
18
19   # HSV conversions from pages 401-403 "Procedural Elements for Computer
20   # Graphics", 1985, ISBN 0-07-053534-5.
21
22   my @result;
23   if ($sat <= 0) {
24     return ( 255 * $val, 255 * $val, 255 * $val );
25   }
26   else {
27     $val >= 0 or $val = 0;
28     $val <= 1 or $val = 1;
29     $sat <= 1 or $sat = 1;
30     $hue >= 360 and $hue %= 360;
31     $hue < 0 and $hue += 360;
32     $hue /= 60.0;
33     my $i = int($hue);
34     my $f = $hue - $i;
35     $val *= 255;
36     my $m = $val * (1.0 - $sat);
37     my $n = $val * (1.0 - $sat * $f);
38     my $k = $val * (1.0 - $sat * (1 - $f));
39     my $v = $val;
40     my %fields = ( 'm'=>$m, 'n'=>$n, 'v'=>$v, 'k'=>$k, );
41     return @fields{split //, $hsv_map[$i]};
42   }
43 }
44
45 # cache of loaded gimp files
46 # each key is a filename, under each key is a hashref with the following
47 # keys:
48 #   mod_time => last mod_time of file
49 #   colors => hashref name to arrayref of colors
50 my %gimp_cache;
51
52 # palette search locations
53 # this is pretty rude
54 # $HOME is replaced at runtime
55 my @gimp_search =
56   (
57    '$HOME/.gimp-1.2/palettes/Named_Colors',
58    '$HOME/.gimp-1.1/palettes/Named_Colors',
59    '$HOME/.gimp/palettes/Named_Colors',
60    '/usr/share/gimp/1.2/palettes/Named_Colors',
61    '/usr/share/gimp/1.1/palettes/Named_Colors',
62    '/usr/share/gimp/palettes/Named_Colors',
63   );
64
65 my $default_gimp_palette;
66
67 sub _load_gimp_palette {
68   my ($filename) = @_;
69
70   if (open PAL, "< $filename") {
71     my $hdr = <PAL>;
72     chomp $hdr;
73     unless ($hdr =~ /GIMP Palette/) {
74       close PAL;
75       $Imager::ERRSTR = "$filename is not a GIMP palette file";
76       return;
77     }
78     my $line;
79     my %pal;
80     my $mod_time = (stat PAL)[9];
81     while (defined($line = <PAL>)) {
82       next if $line =~ /^#/ || $line =~ /^\s*$/;
83       chomp $line;
84       my ($r,$g, $b, $name) = split ' ', $line, 4;
85       if ($name) {
86         $name =~ s/\s*\([\d\s]+\)\s*$//;
87         $pal{lc $name} = [ $r, $g, $b ];
88       }
89     }
90     close PAL;
91
92     $gimp_cache{$filename} = { mod_time=>$mod_time, colors=>\%pal };
93
94     return 1;
95   }
96   else {
97     $Imager::ERRSTR = "Cannot open palette file $filename: $!";
98     return;
99   }
100 }
101
102 sub _get_gimp_color {
103   my %args = @_;
104
105   my $filename;
106   if ($args{palette}) {
107     $filename = $args{palette};
108   }
109   elsif (defined $default_gimp_palette) {
110     # don't search again and again and again ...
111     if (!length $default_gimp_palette
112         || !-f $default_gimp_palette) {
113       $Imager::ERRSTR = "No GIMP palette found";
114       $default_gimp_palette = "";
115       return;
116     }
117
118     $filename = $default_gimp_palette;
119   }
120   else {
121     # try to make one up - this is intended to die if tainting is
122     # enabled and $ENV{HOME} is tainted.  To avoid that untaint $ENV{HOME}
123     # or set the palette parameter
124     for my $attempt (@gimp_search) {
125       my $work = $attempt; # don't modify the source array
126       $work =~ /\$HOME/ && !defined $ENV{HOME}
127         and next;
128       $work =~ s/\$HOME/$ENV{HOME}/;
129       if (-e $work) {
130         $filename = $work;
131         last;
132       }
133     }
134     if (!$filename) {
135       $Imager::ERRSTR = "No GIMP palette found";
136       $default_gimp_palette = "";
137       return ();
138     }
139
140     $default_gimp_palette = $filename;
141   }
142
143   if ((!$gimp_cache{$filename}
144       || (stat $filename)[9] != $gimp_cache{$filename})
145      && !_load_gimp_palette($filename)) {
146     return ();
147   }
148
149   if (!$gimp_cache{$filename}{colors}{lc $args{name}}) {
150     $Imager::ERRSTR = "Color '$args{name}' isn't in $filename";
151     return ();
152   }
153
154   return @{$gimp_cache{$filename}{colors}{lc $args{name}}};
155 }
156
157 my @x_search =
158   (
159    '/usr/share/X11/rgb.txt', # newer Xorg X11 dists use this
160    '/usr/lib/X11/rgb.txt', # seems fairly standard
161    '/usr/local/lib/X11/rgb.txt', # seems possible
162    '/usr/X11R6/lib/X11/rgb.txt', # probably the same as the first
163    '/usr/openwin/lib/rgb.txt',
164    '/usr/openwin/lib/X11/rgb.txt',
165   );
166
167 my $default_x_rgb;
168
169 # called by the test code to check if we can test this stuff
170 sub _test_x_palettes {
171   @x_search;
172 }
173
174 # x rgb.txt cache
175 # same structure as %gimp_cache
176 my %x_cache;
177
178 sub _load_x_rgb {
179   my ($filename) = @_;
180
181   local *RGB;
182   if (open RGB, "< $filename") {
183     my $line;
184     my %pal;
185     my $mod_time = (stat RGB)[9];
186     while (defined($line = <RGB>)) {
187       # the version of rgb.txt supplied with GNU Emacs uses # for comments
188       next if $line =~ /^[!#]/ || $line =~ /^\s*$/;
189       chomp $line;
190       my ($r,$g, $b, $name) = split ' ', $line, 4;
191       if ($name) {
192         $pal{lc $name} = [ $r, $g, $b ];
193       }
194     }
195     close RGB;
196
197     $x_cache{$filename} = { mod_time=>$mod_time, colors=>\%pal };
198
199     return 1;
200   }
201   else {
202     $Imager::ERRSTR = "Cannot open palette file $filename: $!";
203     return;
204   }
205 }
206
207 sub _get_x_color {
208   my %args = @_;
209
210   my $filename;
211   if ($args{palette}) {
212     $filename = $args{palette};
213   }
214   elsif (defined $default_x_rgb) {
215     unless (length $default_x_rgb) {
216       $Imager::ERRSTR = "No X rgb.txt palette found";
217       return ();
218     }
219     $filename = $default_x_rgb;
220   }
221   else {
222     for my $attempt (@x_search) {
223       if (-e $attempt) {
224         $filename = $attempt;
225         last;
226       }
227     }
228     if (!$filename) {
229       $Imager::ERRSTR = "No X rgb.txt palette found";
230       $default_x_rgb = "";
231       return ();
232     }
233   }
234
235   if ((!$x_cache{$filename}
236       || (stat $filename)[9] != $x_cache{$filename}{mod_time})
237      && !_load_x_rgb($filename)) {
238     return ();
239   }
240
241   $default_x_rgb = $filename;
242
243   if (!$x_cache{$filename}{colors}{lc $args{name}}) {
244     $Imager::ERRSTR = "Color '$args{name}' isn't in $filename";
245     return ();
246   }
247
248   return @{$x_cache{$filename}{colors}{lc $args{name}}};
249 }
250
251 # Parse color spec into an a set of 4 colors
252
253 sub _pspec {
254   return (@_,255) if @_ == 3 && !grep /[^\d.+eE-]/, @_;
255   return (@_    ) if @_ == 4 && !grep /[^\d.+eE-]/, @_;
256   if ($_[0] =~
257       /^\#?([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])/i) {
258     return (hex($1),hex($2),hex($3),hex($4));
259   }
260   if ($_[0] =~ /^\#?([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])/i) {
261     return (hex($1),hex($2),hex($3),255);
262   }
263   if ($_[0] =~ /^\#([\da-f])([\da-f])([\da-f])$/i) {
264     return (hex($1) * 17, hex($2) * 17, hex($3) * 17, 255);
265   }
266   my %args;
267   if (@_ == 1) {
268     # a named color
269     %args = ( name => @_ );
270   }
271   else {
272     %args = @_;
273   }
274   my @result;
275   if (exists $args{gray}) {
276     @result = $args{gray};
277   }
278   elsif (exists $args{grey}) {
279     @result = $args{grey};
280   }
281   elsif ((exists $args{red} || exists $args{r})
282          && (exists $args{green} || exists $args{g})
283          && (exists $args{blue} || exists $args{b})) {
284     @result = ( exists $args{red} ? $args{red} : $args{r},
285                 exists $args{green} ? $args{green} : $args{g},
286                 exists $args{blue} ? $args{blue} : $args{b} );
287   }
288   elsif ((exists $args{hue} || exists $args{h})
289          && (exists $args{saturation} || exists $args{'s'})
290          && (exists $args{value} || exists $args{v})) {
291     my $hue = exists $args{hue}        ? $args{hue}        : $args{h};
292     my $sat = exists $args{saturation} ? $args{saturation} : $args{'s'};
293     my $val = exists $args{value}      ? $args{value}      : $args{v};
294
295     @result = _hsv_to_rgb($hue, $sat, $val);
296   }
297   elsif (exists $args{web}) {
298     if ($args{web} =~ /^#?([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])$/i) {
299       @result = (hex($1),hex($2),hex($3));
300     }
301     elsif ($args{web} =~ /^#?([\da-f])([\da-f])([\da-f])$/i) {
302       @result = (hex($1) * 17, hex($2) * 17, hex($3) * 17);
303     }
304   }
305   elsif ($args{name}) {
306     unless (@result = _get_gimp_color(%args)) {
307       unless (@result = _get_x_color(%args)) {
308         require Imager::Color::Table;
309         unless (@result = Imager::Color::Table->get($args{name})) {
310           $Imager::ERRSTR = "No color named $args{name} found";
311           return ();
312         }
313       }
314     }
315   }
316   elsif ($args{gimp}) {
317     @result = _get_gimp_color(name=>$args{gimp}, %args);
318   }
319   elsif ($args{xname}) {
320     @result = _get_x_color(name=>$args{xname}, %args);
321   }
322   elsif ($args{builtin}) {
323     require Imager::Color::Table;
324     @result = Imager::Color::Table->get($args{builtin});
325   }
326   elsif ($args{rgb}) {
327     @result = @{$args{rgb}};
328   }
329   elsif ($args{rgba}) {
330     @result = @{$args{rgba}};
331     return @result if @result == 4;
332   }
333   elsif ($args{hsv}) {
334     @result = _hsv_to_rgb(@{$args{hsv}});
335   }
336   elsif ($args{channels}) {
337     my @ch = @{$args{channels}};
338     return ( @ch, (0) x (4 - @ch) );
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   }
361   return ();
362 }
363
364 sub new {
365   shift; # get rid of class name.
366   my @arg = _pspec(@_);
367   return @arg ? new_internal($arg[0],$arg[1],$arg[2],$arg[3]) : ();
368 }
369
370 sub set {
371   my $self = shift;
372   my @arg = _pspec(@_);
373   return @arg ? set_internal($self, $arg[0],$arg[1],$arg[2],$arg[3]) : ();
374 }
375
376 sub 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
394 sub CLONE_SKIP { 1 }
395
396 # Lifted from Graphics::Color::RGB
397 # Thank you very much
398 sub 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
449 1;
450
451 __END__
452
453 =head1 NAME
454
455 Imager::Color - Color handling for Imager.
456
457 =head1 SYNOPSIS
458
459   use Imager;
460
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();
470   @hsv = $color->hsv();
471
472   $color->info();
473
474   if ($color->equals(other=>$other_color)) {
475     ...
476   }
477
478
479 =head1 DESCRIPTION
480
481 This module handles creating color objects used by Imager.  The idea
482 is that in the future this module will be able to handle color space
483 calculations as well.
484
485 An Imager color consists of up to four components, each in the range 0
486 to 255. Unfortunately the meaning of the components can change
487 depending on the type of image you're dealing with:
488
489 =over
490
491 =item *
492
493 for 3 or 4 channel images the color components are red, green, blue,
494 alpha.
495
496 =item *
497
498 for 1 or 2 channel images the color components are gray, alpha, with
499 the other two components ignored.
500
501 =back
502
503 An alpha value of zero is fully transparent, an alpha value of 255 is
504 fully opaque.
505
506 =head1 METHODS
507
508 =over 4
509
510 =item new
511
512 This creates a color object to pass to functions that need a color argument.
513
514 =item set
515
516 This changes an already defined color.  Note that this does not affect any places
517 where the color has been used previously.
518
519 =item rgba()
520
521 This returns the red, green, blue and alpha channels of the color the
522 object contains.
523
524 =item info
525
526 Calling info merely dumps the relevant color to the log.
527
528 =item equals(other=>$other_color)
529
530 =item equals(other=>$other_color, ignore_alpha=>1)
531
532 Compares $self and color $other_color returning true if the color
533 components are the same.
534
535 Compares all four channels unless C<ignore_alpha> is set.  If
536 C<ignore_alpha> is set only the first three channels are compared.
537
538 =back
539
540 You can specify colors in several different ways, you can just supply
541 simple values:
542
543 =over
544
545 =item *
546
547 simple 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
551 a six hex digit web color, either C<RRGGBB> or C<#RRGGBB>
552
553 =item *
554
555 an eight hex digit web color, either C<RRGGBBAA> or C<#RRGGBBAA>.
556
557 =item *
558
559 a 3 hex digit web color, C<#RGB> - a value of F becomes 255.
560
561 =item *
562
563 a color name, from whichever of the gimp C<Named_Colors> file or X
564 C<rgb.txt> is found first.  The same as using the C<name> keyword.
565
566 =back
567
568 You can supply named parameters:
569
570 =over
571
572 =item *
573
574 'red', 'green' and 'blue', optionally shortened to 'r', 'g' and 'b'.
575 The 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
584 C<hue>, C<saturation> and C<value>, optionally shortened to C<h>, C<s> and
585 C<v>, to specify a HSV color.  0 <= hue < 360, 0 <= s <= 1 and 0 <= v
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
594 C<web>, which can specify a 6 or 3 hex digit web color, in any of the
595 forms C<#RRGGBB>, C<#RGB>, C<RRGGBB> or C<RGB>.
596
597   my $c1 = Imager::Color->new(web=>'#FFC0C0'); # pale red
598
599 =item *
600
601 C<gray> or C<grey> which specifies a single channel, from 0 to 255.
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
609 C<rgb> which takes a 3 member arrayref, containing each of the red,
610 green 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
618 C<hsv> which takes a 3 member arrayref, containing each of hue,
619 saturation 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
627 C<gimp> which specifies a color from a GIMP palette file.  You can
628 specify the file name of the palette file with the 'palette'
629 parameter, or let Imager::Color look in various places, typically
630 C<$HOME/gimp-1.x/palettes/Named_Colors> with and without the version
631 number, and in C</usr/share/gimp/palettes/>.  The palette file must
632 have color names.
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
639 C<xname> which specifies a color from an X11 C<rgb.txt> file.  You can
640 specify the file name of the C<rgb.txt> file with the C<palette>
641 parameter, or let Imager::Color look in various places, typically
642 C</usr/lib/X11/rgb.txt>.
643
644   my $c1 = Imager::Color->new(xname=>'blue') # usually RGB(0, 0, 255)
645
646 =item *
647
648 C<builtin> which specifies a color from the built-in color table in
649 Imager::Color::Table.  The colors in this module are the same as the
650 default X11 C<rgb.txt> file.
651
652   my $c1 = Imager::Color->new(builtin=>'black') # always RGB(0, 0, 0)
653
654 =item *
655
656 C<name> which specifies a name from either a GIMP palette, an X
657 C<rgb.txt> file or the built-in color table, whichever is found first.
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
669 Optionally you can add an alpha channel to a color with the 'alpha' or
670 'a' parameter.
671
672 These color specifications can be used for both constructing new
673 colors with the new() method and modifying existing colors with the
674 set() method.
675
676 =head1 METHODS
677
678 =over
679
680 =item hsv()
681
682     my($h, $s, $v, $alpha) = $color->hsv();
683
684 Returns the color as a Hue/Saturation/Value/Alpha tuple.
685
686 =item red
687
688 =item green
689
690 =item blue
691
692 =item alpha
693
694 Returns the respective component as an integer from 0 to 255.
695
696 =back
697
698 =head1 AUTHOR
699
700 Arnar M. Hrafnkelsson, addi@umich.edu
701 And a great deal of help from others - see the C<README> for a complete
702 list.
703
704 =head1 SEE ALSO
705
706 Imager(3), Imager::Color
707 http://imager.perl.org/
708
709 =cut