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