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