split out the calculations of the final scale factors/sizes so you can
[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
02d1d628
AMH
3661;
367
368__END__
369
370=head1 NAME
371
372Imager::Color - Color handling for Imager.
373
374=head1 SYNOPSIS
375
376 $color = Imager::Color->new($red, $green, $blue);
377 $color = Imager::Color->new($red, $green, $blue, $alpha);
378 $color = Imager::Color->new("#C0C0FF"); # html color specification
379
380 $color->set($red, $green, $blue);
381 $color->set($red, $green, $blue, $alpha);
382 $color->set("#C0C0FF"); # html color specification
383
384 ($red, $green, $blue, $alpha) = $color->rgba();
385 @hsv = $color->hsv(); # not implemented but proposed
386
387 $color->info();
388
5f8cbeac
TC
389 if ($color->equals(other=>$other_color)) {
390 ...
391 }
392
02d1d628
AMH
393
394=head1 DESCRIPTION
395
396This module handles creating color objects used by imager. The idea is
397that in the future this module will be able to handle colorspace calculations
398as well.
399
400=over 4
401
402=item new
403
404This creates a color object to pass to functions that need a color argument.
405
406=item set
407
408This changes an already defined color. Note that this does not affect any places
409where the color has been used previously.
410
411=item rgba
412
413This returns the rgba code of the color the object contains.
414
415=item info
416
417Calling info merely dumps the relevant colorcode to the log.
418
5f8cbeac
TC
419=item equals(other=>$other_color)
420
421=item equals(other=>$other_color, ignore_alpha=>1)
422
423Compares $self and color $other_color returning true if the color
424components are the same.
425
426Compares all four channels unless C<ignore_alpha> is set. If
427C<ignore_alpha> is set only the first three channels are compared.
428
02d1d628
AMH
429=back
430
faa9b3e7
TC
431You can specify colors in several different ways, you can just supply
432simple values:
433
434=over
435
436=item *
437
438simple numeric parameters - if you supply 3 or 4 numeric arguments, you get a color made up of those RGB (and possibly A) components.
439
440=item *
441
442a six hex digit web color, either 'RRGGBB' or '#RRGGBB'
443
444=item *
445
446an eight hex digit web color, either 'RRGGBBAA' or '#RRGGBBAA'.
447
448=item *
449
450a 3 hex digit web color, '#RGB' - a value of F becomes 255.
451
452=item *
453
454a color name, from whichever of the gimp Named_Colors file or X
455rgb.txt is found first. The same as using the name keyword.
456
457=back
458
459You can supply named parameters:
460
461=over
462
463=item *
464
465'red', 'green' and 'blue', optionally shortened to 'r', 'g' and 'b'.
466The color components in the range 0 to 255.
467
468 # all of the following are equivalent
469 my $c1 = Imager::Color->new(red=>100, blue=>255, green=>0);
470 my $c2 = Imager::Color->new(r=>100, b=>255, g=>0);
471 my $c3 = Imager::Color->new(r=>100, blue=>255, g=>0);
472
473=item *
474
475'hue', 'saturation' and 'value', optionally shortened to 'h', 's' and
476'v', to specify a HSV color. 0 <= hue < 360, 0 <= s <= 1 and 0 <= v
477<= 1.
478
479 # the same as RGB(127,255,127)
480 my $c1 = Imager::Color->new(hue=>120, v=>1, s=>0.5);
481 my $c1 = Imager::Color->new(hue=>120, value=>1, saturation=>0.5);
482
483=item *
484
485'web', which can specify a 6 or 3 hex digit web color, in any of the
486forms '#RRGGBB', '#RGB', 'RRGGBB' or 'RGB'.
487
488 my $c1 = Imager::Color->new(web=>'#FFC0C0'); # pale red
489
490=item *
491
492'gray' or 'grey' which specifies a single channel, from 0 to 255.
493
494 # exactly the same
495 my $c1 = Imager::Color->new(gray=>128);
496 my $c1 = Imager::Color->new(grey=>128);
497
498=item *
499
500'rgb' which takes a 3 member arrayref, containing each of the red,
501green and blue values.
502
503 # the same
504 my $c1 = Imager::Color->new(rgb=>[255, 100, 0]);
505 my $c1 = Imager::Color->new(r=>255, g=>100, b=>0);
506
507=item *
508
509'hsv' which takes a 3 member arrayref, containting each of hue,
510saturation and value.
511
512 # the same
513 my $c1 = Imager::Color->new(hsv=>[120, 0.5, 1]);
514 my $c1 = Imager::Color->new(hue=>120, v=>1, s=>0.5);
515
516=item *
517
518'gimp' which specifies a color from a GIMP palette file. You can
519specify the filename of the palette file with the 'palette' parameter,
520or let Imager::Color look in various places, typically
521"$HOME/gimp-1.x/palettes/Named_Colors" with and without the version
522number, and in /usr/share/gimp/palettes/. The palette file must have
523color names.
524
525 my $c1 = Imager::Color->new(gimp=>'snow');
526 my $c1 = Imager::Color->new(gimp=>'snow', palette=>'testimg/test_gimp_pal);
527
528=item *
529
530'xname' which specifies a color from an X11 rgb.txt file. You can
531specify the filename of the rgb.txt file with the 'palette' parameter,
532or let Imager::Color look in various places, typically
533'/usr/lib/X11/rgb.txt'.
534
535 my $c1 = Imager::Color->new(xname=>'blue') # usually RGB(0, 0, 255)
536
537=item *
538
1c00d65b
TC
539'builtin' which specifies a color from the built-in color table in
540Imager::Color::Table. The colors in this module are the same as the
541default X11 rgb.txt file.
542
543 my $c1 = Imager::Color->new(builtin=>'black') # always RGB(0, 0, 0)
544
545=item *
546
547'name' which specifies a name from either a GIMP palette, an X rgb.txt
548file or the built-in color table, whichever is found first.
faa9b3e7
TC
549
550=item *
551
552'channel0', 'channel1', etc, each of which specifies a single channel. These can be abbreviated to 'c0', 'c1' etc.
553
554=item *
555
556'channels' which takes an arrayref of the channel values.
557
558=back
559
560Optionally you can add an alpha channel to a color with the 'alpha' or
561'a' parameter.
562
563These color specifications can be used for both constructing new
564colors with the new() method and modifying existing colors with the
565set() method.
566
02d1d628
AMH
567=head1 AUTHOR
568
569Arnar M. Hrafnkelsson, addi@umich.edu
570And a great deal of help from others - see the README for a complete
571list.
572
573=head1 SEE ALSO
574
575Imager(3)
8f22b8d8 576http://imager.perl.org/
02d1d628
AMH
577
578=cut