lib/Imager/Color.pm

   1 package Imager::Color;
   2
   3 use Imager;
   4 use strict;
   5 use vars qw($VERSION);
   6
   7 $VERSION = "1.011";
   8
   9 # It's just a front end to the XS creation functions.
  10
  11 # used in converting hsv to rgb
  12 my @hsv_map =
  13   (
  14    'vkm', 'nvm', 'mvk', 'mnv', 'kmv', 'vmn'
  15   );
  16
  17 sub _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;
  41     my %fields = ( 'm'=>$m, 'n'=>$n, 'v'=>$v, 'k'=>$k, );
  42     return @fields{split //, $hsv_map[$i]};
  43   }
  44 }
  45
  46 # cache of loaded gimp files
  47 # each key is a filename, under each key is a hashref with the following
  48 # keys:
  49 #   mod_time => last mod_time of file
  50 #   colors => hashref name to arrayref of colors
  51 my %gimp_cache;
  52
  53 # palette search locations
  54 # this is pretty rude
  55 # $HOME is replaced at runtime
  56 my @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
  66 sub _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
 101 sub _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
 114       $work =~ /\$HOME/ && !defined $ENV{HOME}
 115         and next;
 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
 142 my @x_search =
 143   (
 144    '/usr/share/X11/rgb.txt', # newer Xorg X11 dists use this
 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
 148    '/usr/openwin/lib/rgb.txt',
 149    '/usr/openwin/lib/X11/rgb.txt',
 150   );
 151
 152 # called by the test code to check if we can test this stuff
 153 sub _test_x_palettes {
 154   @x_search;
 155 }
 156
 157 # x rgb.txt cache
 158 # same structure as %gimp_cache
 159 my %x_cache;
 160
 161 sub _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
 190 sub _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 }
 223
 224 # Parse color spec into an a set of 4 colors
 225
 226 sub _pspec {
 227   return (@_,255) if @_ == 3 && !grep /[^\d.+eE-]/, @_;
 228   return (@_    ) if @_ == 4 && !grep /[^\d.+eE-]/, @_;
 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   }
 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};
 267
 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)) {
 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         }
 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   }
 295   elsif ($args{builtin}) {
 296     require Imager::Color::Table;
 297     @result = Imager::Color::Table->get($args{builtin});
 298   }
 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   }
 333   return ();
 334 }
 335
 336 sub new {
 337   shift; # get rid of class name.
 338   my @arg = _pspec(@_);
 339   return @arg ? new_internal($arg[0],$arg[1],$arg[2],$arg[3]) : ();
 340 }
 341
 342 sub set {
 343   my $self = shift;
 344   my @arg = _pspec(@_);
 345   return @arg ? set_internal($self, $arg[0],$arg[1],$arg[2],$arg[3]) : ();
 346 }
 347
 348 sub 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
 366 sub CLONE_SKIP { 1 }
 367
 368 1;
 369
 370 __END__
 371
 372 =head1 NAME
 373
 374 Imager::Color - Color handling for Imager.
 375
 376 =head1 SYNOPSIS
 377
 378   use Imager;
 379
 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
 393   if ($color->equals(other=>$other_color)) {
 394     ...
 395   }
 396
 397
 398 =head1 DESCRIPTION
 399
 400 This module handles creating color objects used by Imager.  The idea
 401 is that in the future this module will be able to handle color space
 402 calculations as well.
 403
 404 An Imager color consists of up to four components, each in the range 0
 405 to 255. Unfortunately the meaning of the components can change
 406 depending on the type of image you're dealing with:
 407
 408 =over
 409
 410 =item *
 411
 412 for 3 or 4 channel images the color components are red, green, blue,
 413 alpha.
 414
 415 =item *
 416
 417 for 1 or 2 channel images the color components are gray, alpha, with
 418 the other two components ignored.
 419
 420 =back
 421
 422 An alpha value of zero is fully transparent, an alpha value of 255 is
 423 fully opaque.
 424
 425 =head1 METHODS
 426
 427 =over 4
 428
 429 =item new
 430
 431 This creates a color object to pass to functions that need a color argument.
 432
 433 =item set
 434
 435 This changes an already defined color.  Note that this does not affect any places
 436 where the color has been used previously.
 437
 438 =item rgba()
 439
 440 This returns the red, green, blue and alpha channels of the color the
 441 object contains.
 442
 443 =item info
 444
 445 Calling info merely dumps the relevant color to the log.
 446
 447 =item equals(other=>$other_color)
 448
 449 =item equals(other=>$other_color, ignore_alpha=>1)
 450
 451 Compares $self and color $other_color returning true if the color
 452 components are the same.
 453
 454 Compares all four channels unless C<ignore_alpha> is set.  If
 455 C<ignore_alpha> is set only the first three channels are compared.
 456
 457 =back
 458
 459 You can specify colors in several different ways, you can just supply
 460 simple values:
 461
 462 =over
 463
 464 =item *
 465
 466 simple numeric parameters - if you supply 3 or 4 numeric arguments, you get a color made up of those RGB (and possibly A) components.
 467
 468 =item *
 469
 470 a six hex digit web color, either C<RRGGBB> or C<#RRGGBB>
 471
 472 =item *
 473
 474 an eight hex digit web color, either C<RRGGBBAA> or C<#RRGGBBAA>.
 475
 476 =item *
 477
 478 a 3 hex digit web color, C<#RGB> - a value of F becomes 255.
 479
 480 =item *
 481
 482 a color name, from whichever of the gimp C<Named_Colors> file or X
 483 C<rgb.txt> is found first.  The same as using the C<name> keyword.
 484
 485 =back
 486
 487 You can supply named parameters:
 488
 489 =over
 490
 491 =item *
 492
 493 'red', 'green' and 'blue', optionally shortened to 'r', 'g' and 'b'.
 494 The color components in the range 0 to 255.
 495
 496  # all of the following are equivalent
 497  my $c1 = Imager::Color->new(red=>100, blue=>255, green=>0);
 498  my $c2 = Imager::Color->new(r=>100, b=>255, g=>0);
 499  my $c3 = Imager::Color->new(r=>100, blue=>255, g=>0);
 500
 501 =item *
 502
 503 C<hue>, C<saturation> and C<value>, optionally shortened to C<h>, C<s> and
 504 C<v>, to specify a HSV color.  0 <= hue < 360, 0 <= s <= 1 and 0 <= v
 505 <= 1.
 506
 507   # the same as RGB(127,255,127)
 508   my $c1 = Imager::Color->new(hue=>120, v=>1, s=>0.5);
 509   my $c1 = Imager::Color->new(hue=>120, value=>1, saturation=>0.5);
 510
 511 =item *
 512
 513 C<web>, which can specify a 6 or 3 hex digit web color, in any of the
 514 forms C<#RRGGBB>, C<#RGB>, C<RRGGBB> or C<RGB>.
 515
 516   my $c1 = Imager::Color->new(web=>'#FFC0C0'); # pale red
 517
 518 =item *
 519
 520 C<gray> or C<grey> which specifies a single channel, from 0 to 255.
 521
 522   # exactly the same
 523   my $c1 = Imager::Color->new(gray=>128);
 524   my $c1 = Imager::Color->new(grey=>128);
 525
 526 =item *
 527
 528 C<rgb> which takes a 3 member arrayref, containing each of the red,
 529 green and blue values.
 530
 531   # the same
 532   my $c1 = Imager::Color->new(rgb=>[255, 100, 0]);
 533   my $c1 = Imager::Color->new(r=>255, g=>100, b=>0);
 534
 535 =item *
 536
 537 C<hsv> which takes a 3 member arrayref, containing each of hue,
 538 saturation and value.
 539
 540   # the same
 541   my $c1 = Imager::Color->new(hsv=>[120, 0.5, 1]);
 542   my $c1 = Imager::Color->new(hue=>120, v=>1, s=>0.5);
 543
 544 =item *
 545
 546 C<gimp> which specifies a color from a GIMP palette file.  You can
 547 specify the file name of the palette file with the 'palette'
 548 parameter, or let Imager::Color look in various places, typically
 549 C<$HOME/gimp-1.x/palettes/Named_Colors> with and without the version
 550 number, and in C</usr/share/gimp/palettes/>.  The palette file must
 551 have color names.
 552
 553   my $c1 = Imager::Color->new(gimp=>'snow');
 554   my $c1 = Imager::Color->new(gimp=>'snow', palette=>'testimg/test_gimp_pal);
 555
 556 =item *
 557
 558 C<xname> which specifies a color from an X11 C<rgb.txt> file.  You can
 559 specify the file name of the C<rgb.txt> file with the C<palette>
 560 parameter, or let Imager::Color look in various places, typically
 561 C</usr/lib/X11/rgb.txt>.
 562
 563   my $c1 = Imager::Color->new(xname=>'blue') # usually RGB(0, 0, 255)
 564
 565 =item *
 566
 567 C<builtin> which specifies a color from the built-in color table in
 568 Imager::Color::Table.  The colors in this module are the same as the
 569 default X11 C<rgb.txt> file.
 570
 571   my $c1 = Imager::Color->new(builtin=>'black') # always RGB(0, 0, 0)
 572
 573 =item *
 574
 575 C<name> which specifies a name from either a GIMP palette, an X
 576 C<rgb.txt> file or the built-in color table, whichever is found first.
 577
 578 =item *
 579
 580 'channel0', 'channel1', etc, each of which specifies a single channel.  These can be abbreviated to 'c0', 'c1' etc.
 581
 582 =item *
 583
 584 'channels' which takes an arrayref of the channel values.
 585
 586 =back
 587
 588 Optionally you can add an alpha channel to a color with the 'alpha' or
 589 'a' parameter.
 590
 591 These color specifications can be used for both constructing new
 592 colors with the new() method and modifying existing colors with the
 593 set() method.
 594
 595 =head1 AUTHOR
 596
 597 Arnar M. Hrafnkelsson, addi@umich.edu
 598 And a great deal of help from others - see the C<README> for a complete
 599 list.
 600
 601 =head1 SEE ALSO
 602
 603 Imager(3), Imager::Color
 604 http://imager.perl.org/
 605
 606 =cut