- added the C<builtin> color specifier and the
[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)) {
1c00d65b
TC
271 require Imager::Color::Table;
272 unless (@result = Imager::Color::Table->get($args{name})) {
273 $Imager::ERRSTR = "No color named $args{name} found";
274 return ();
275 }
faa9b3e7
TC
276 }
277 }
278 }
279 elsif ($args{gimp}) {
280 @result = _get_gimp_color(name=>$args{gimp}, %args);
281 }
282 elsif ($args{xname}) {
283 @result = _get_x_color(name=>$args{xname}, %args);
284 }
1c00d65b
TC
285 elsif ($args{builtin}) {
286 require Imager::Color::Table;
287 @result = Imager::Color::Table->get($args{builtin});
288 }
faa9b3e7
TC
289 elsif ($args{rgb}) {
290 @result = @{$args{rgb}};
291 }
292 elsif ($args{rgba}) {
293 @result = @{$args{rgba}};
294 return @result if @result == 4;
295 }
296 elsif ($args{hsv}) {
297 @result = _hsv_to_rgb(@{$args{hsv}});
298 }
299 elsif ($args{channels}) {
300 return @{$args{channels}};
301 }
302 elsif (exists $args{channel0} || $args{c0}) {
303 my $i = 0;
304 while (exists $args{"channel$i"} || exists $args{"c$i"}) {
305 push(@result,
306 exists $args{"channel$i"} ? $args{"channel$i"} : $args{"c$i"});
307 ++$i;
308 }
309 }
310 else {
311 $Imager::ERRSTR = "No color specification found";
312 return ();
313 }
314 if (@result) {
315 if (exists $args{alpha} || exists $args{a}) {
316 push(@result, exists $args{alpha} ? $args{alpha} : $args{a});
317 }
318 while (@result < 4) {
319 push(@result, 255);
320 }
321 return @result;
322 }
02d1d628
AMH
323 return ();
324}
325
02d1d628
AMH
326sub new {
327 shift; # get rid of class name.
328 my @arg = pspec(@_);
329 return @arg ? new_internal($arg[0],$arg[1],$arg[2],$arg[3]) : ();
330}
331
332sub set {
333 my $self = shift;
02d1d628
AMH
334 my @arg = pspec(@_);
335 return @arg ? set_internal($self, $arg[0],$arg[1],$arg[2],$arg[3]) : ();
336}
337
02d1d628
AMH
3381;
339
340__END__
341
342=head1 NAME
343
344Imager::Color - Color handling for Imager.
345
346=head1 SYNOPSIS
347
348 $color = Imager::Color->new($red, $green, $blue);
349 $color = Imager::Color->new($red, $green, $blue, $alpha);
350 $color = Imager::Color->new("#C0C0FF"); # html color specification
351
352 $color->set($red, $green, $blue);
353 $color->set($red, $green, $blue, $alpha);
354 $color->set("#C0C0FF"); # html color specification
355
356 ($red, $green, $blue, $alpha) = $color->rgba();
357 @hsv = $color->hsv(); # not implemented but proposed
358
359 $color->info();
360
361
362=head1 DESCRIPTION
363
364This module handles creating color objects used by imager. The idea is
365that in the future this module will be able to handle colorspace calculations
366as well.
367
368=over 4
369
370=item new
371
372This creates a color object to pass to functions that need a color argument.
373
374=item set
375
376This changes an already defined color. Note that this does not affect any places
377where the color has been used previously.
378
379=item rgba
380
381This returns the rgba code of the color the object contains.
382
383=item info
384
385Calling info merely dumps the relevant colorcode to the log.
386
387=back
388
faa9b3e7
TC
389You can specify colors in several different ways, you can just supply
390simple values:
391
392=over
393
394=item *
395
396simple numeric parameters - if you supply 3 or 4 numeric arguments, you get a color made up of those RGB (and possibly A) components.
397
398=item *
399
400a six hex digit web color, either 'RRGGBB' or '#RRGGBB'
401
402=item *
403
404an eight hex digit web color, either 'RRGGBBAA' or '#RRGGBBAA'.
405
406=item *
407
408a 3 hex digit web color, '#RGB' - a value of F becomes 255.
409
410=item *
411
412a color name, from whichever of the gimp Named_Colors file or X
413rgb.txt is found first. The same as using the name keyword.
414
415=back
416
417You can supply named parameters:
418
419=over
420
421=item *
422
423'red', 'green' and 'blue', optionally shortened to 'r', 'g' and 'b'.
424The color components in the range 0 to 255.
425
426 # all of the following are equivalent
427 my $c1 = Imager::Color->new(red=>100, blue=>255, green=>0);
428 my $c2 = Imager::Color->new(r=>100, b=>255, g=>0);
429 my $c3 = Imager::Color->new(r=>100, blue=>255, g=>0);
430
431=item *
432
433'hue', 'saturation' and 'value', optionally shortened to 'h', 's' and
434'v', to specify a HSV color. 0 <= hue < 360, 0 <= s <= 1 and 0 <= v
435<= 1.
436
437 # the same as RGB(127,255,127)
438 my $c1 = Imager::Color->new(hue=>120, v=>1, s=>0.5);
439 my $c1 = Imager::Color->new(hue=>120, value=>1, saturation=>0.5);
440
441=item *
442
443'web', which can specify a 6 or 3 hex digit web color, in any of the
444forms '#RRGGBB', '#RGB', 'RRGGBB' or 'RGB'.
445
446 my $c1 = Imager::Color->new(web=>'#FFC0C0'); # pale red
447
448=item *
449
450'gray' or 'grey' which specifies a single channel, from 0 to 255.
451
452 # exactly the same
453 my $c1 = Imager::Color->new(gray=>128);
454 my $c1 = Imager::Color->new(grey=>128);
455
456=item *
457
458'rgb' which takes a 3 member arrayref, containing each of the red,
459green and blue values.
460
461 # the same
462 my $c1 = Imager::Color->new(rgb=>[255, 100, 0]);
463 my $c1 = Imager::Color->new(r=>255, g=>100, b=>0);
464
465=item *
466
467'hsv' which takes a 3 member arrayref, containting each of hue,
468saturation and value.
469
470 # the same
471 my $c1 = Imager::Color->new(hsv=>[120, 0.5, 1]);
472 my $c1 = Imager::Color->new(hue=>120, v=>1, s=>0.5);
473
474=item *
475
476'gimp' which specifies a color from a GIMP palette file. You can
477specify the filename of the palette file with the 'palette' parameter,
478or let Imager::Color look in various places, typically
479"$HOME/gimp-1.x/palettes/Named_Colors" with and without the version
480number, and in /usr/share/gimp/palettes/. The palette file must have
481color names.
482
483 my $c1 = Imager::Color->new(gimp=>'snow');
484 my $c1 = Imager::Color->new(gimp=>'snow', palette=>'testimg/test_gimp_pal);
485
486=item *
487
488'xname' which specifies a color from an X11 rgb.txt file. You can
489specify the filename of the rgb.txt file with the 'palette' parameter,
490or let Imager::Color look in various places, typically
491'/usr/lib/X11/rgb.txt'.
492
493 my $c1 = Imager::Color->new(xname=>'blue') # usually RGB(0, 0, 255)
494
495=item *
496
1c00d65b
TC
497'builtin' which specifies a color from the built-in color table in
498Imager::Color::Table. The colors in this module are the same as the
499default X11 rgb.txt file.
500
501 my $c1 = Imager::Color->new(builtin=>'black') # always RGB(0, 0, 0)
502
503=item *
504
505'name' which specifies a name from either a GIMP palette, an X rgb.txt
506file or the built-in color table, whichever is found first.
faa9b3e7
TC
507
508=item *
509
510'channel0', 'channel1', etc, each of which specifies a single channel. These can be abbreviated to 'c0', 'c1' etc.
511
512=item *
513
514'channels' which takes an arrayref of the channel values.
515
516=back
517
518Optionally you can add an alpha channel to a color with the 'alpha' or
519'a' parameter.
520
521These color specifications can be used for both constructing new
522colors with the new() method and modifying existing colors with the
523set() method.
524
02d1d628
AMH
525=head1 AUTHOR
526
527Arnar M. Hrafnkelsson, addi@umich.edu
528And a great deal of help from others - see the README for a complete
529list.
530
531=head1 SEE ALSO
532
533Imager(3)
534http://www.eecs.umich.edu/~addi/perl/Imager/
535
536=cut