lib/Imager/Color.pm

   1 package Imager::Color;
   2 use 5.006;
   3 use Imager;
   4 use strict;
   5
   6 our $VERSION = "1.013";
   7
   8 # It's just a front end to the XS creation functions.
   9
  10 # used in converting hsv to rgb
  11 my @hsv_map =
  12   (
  13    'vkm', 'nvm', 'mvk', 'mnv', 'kmv', 'vmn'
  14   );
  15
  16 sub _hsv_to_rgb {
  17   my ($hue, $sat, $val) = @_;
  18
  19   # HSV conversions from pages 401-403 "Procedural Elements for Computer
  20   # Graphics", 1985, ISBN 0-07-053534-5.
  21
  22   my @result;
  23   if ($sat <= 0) {
  24     return ( 255 * $val, 255 * $val, 255 * $val );
  25   }
  26   else {
  27     $val >= 0 or $val = 0;
  28     $val <= 1 or $val = 1;
  29     $sat <= 1 or $sat = 1;
  30     $hue >= 360 and $hue %= 360;
  31     $hue < 0 and $hue += 360;
  32     $hue /= 60.0;
  33     my $i = int($hue);
  34     my $f = $hue - $i;
  35     $val *= 255;
  36     my $m = $val * (1.0 - $sat);
  37     my $n = $val * (1.0 - $sat * $f);
  38     my $k = $val * (1.0 - $sat * (1 - $f));
  39     my $v = $val;
  40     my %fields = ( 'm'=>$m, 'n'=>$n, 'v'=>$v, 'k'=>$k, );
  41     return @fields{split //, $hsv_map[$i]};
  42   }
  43 }
  44
  45 # cache of loaded gimp files
  46 # each key is a filename, under each key is a hashref with the following
  47 # keys:
  48 #   mod_time => last mod_time of file
  49 #   colors => hashref name to arrayref of colors
  50 my %gimp_cache;
  51
  52 # palette search locations
  53 # this is pretty rude
  54 # $HOME is replaced at runtime
  55 my @gimp_search =
  56   (
  57    '$HOME/.gimp-1.2/palettes/Named_Colors',
  58    '$HOME/.gimp-1.1/palettes/Named_Colors',
  59    '$HOME/.gimp/palettes/Named_Colors',
  60    '/usr/share/gimp/1.2/palettes/Named_Colors',
  61    '/usr/share/gimp/1.1/palettes/Named_Colors',
  62    '/usr/share/gimp/palettes/Named_Colors',
  63   );
  64
  65 my $default_gimp_palette;
  66
  67 sub _load_gimp_palette {
  68   my ($filename) = @_;
  69
  70   if (open PAL, "< $filename") {
  71     my $hdr = <PAL>;
  72     chomp $hdr;
  73     unless ($hdr =~ /GIMP Palette/) {
  74       close PAL;
  75       $Imager::ERRSTR = "$filename is not a GIMP palette file";
  76       return;
  77     }
  78     my $line;
  79     my %pal;
  80     my $mod_time = (stat PAL)[9];
  81     while (defined($line = <PAL>)) {
  82       next if $line =~ /^#/ || $line =~ /^\s*$/;
  83       chomp $line;
  84       my ($r,$g, $b, $name) = split ' ', $line, 4;
  85       if ($name) {
  86         $name =~ s/\s*\([\d\s]+\)\s*$//;
  87         $pal{lc $name} = [ $r, $g, $b ];
  88       }
  89     }
  90     close PAL;
  91
  92     $gimp_cache{$filename} = { mod_time=>$mod_time, colors=>\%pal };
  93
  94     return 1;
  95   }
  96   else {
  97     $Imager::ERRSTR = "Cannot open palette file $filename: $!";
  98     return;
  99   }
 100 }
 101
 102 sub _get_gimp_color {
 103   my %args = @_;
 104
 105   my $filename;
 106   if ($args{palette}) {
 107     $filename = $args{palette};
 108   }
 109   elsif (defined $default_gimp_palette) {
 110     # don't search again and again and again ...
 111     if (!length $default_gimp_palette
 112         || !-f $default_gimp_palette) {
 113       $Imager::ERRSTR = "No GIMP palette found";
 114       $default_gimp_palette = "";
 115       return;
 116     }
 117
 118     $filename = $default_gimp_palette;
 119   }
 120   else {
 121     # try to make one up - this is intended to die if tainting is
 122     # enabled and $ENV{HOME} is tainted.  To avoid that untaint $ENV{HOME}
 123     # or set the palette parameter
 124     for my $attempt (@gimp_search) {
 125       my $work = $attempt; # don't modify the source array
 126       $work =~ /\$HOME/ && !defined $ENV{HOME}
 127         and next;
 128       $work =~ s/\$HOME/$ENV{HOME}/;
 129       if (-e $work) {
 130         $filename = $work;
 131         last;
 132       }
 133     }
 134     if (!$filename) {
 135       $Imager::ERRSTR = "No GIMP palette found";
 136       $default_gimp_palette = "";
 137       return ();
 138     }
 139
 140     $default_gimp_palette = $filename;
 141   }
 142
 143   if ((!$gimp_cache{$filename}
 144       || (stat $filename)[9] != $gimp_cache{$filename})
 145      && !_load_gimp_palette($filename)) {
 146     return ();
 147   }
 148
 149   if (!$gimp_cache{$filename}{colors}{lc $args{name}}) {
 150     $Imager::ERRSTR = "Color '$args{name}' isn't in $filename";
 151     return ();
 152   }
 153
 154   return @{$gimp_cache{$filename}{colors}{lc $args{name}}};
 155 }
 156
 157 my @x_search =
 158   (
 159    '/usr/share/X11/rgb.txt', # newer Xorg X11 dists use this
 160    '/usr/lib/X11/rgb.txt', # seems fairly standard
 161    '/usr/local/lib/X11/rgb.txt', # seems possible
 162    '/usr/X11R6/lib/X11/rgb.txt', # probably the same as the first
 163    '/usr/openwin/lib/rgb.txt',
 164    '/usr/openwin/lib/X11/rgb.txt',
 165   );
 166
 167 my $default_x_rgb;
 168
 169 # called by the test code to check if we can test this stuff
 170 sub _test_x_palettes {
 171   @x_search;
 172 }
 173
 174 # x rgb.txt cache
 175 # same structure as %gimp_cache
 176 my %x_cache;
 177
 178 sub _load_x_rgb {
 179   my ($filename) = @_;
 180
 181   local *RGB;
 182   if (open RGB, "< $filename") {
 183     my $line;
 184     my %pal;
 185     my $mod_time = (stat RGB)[9];
 186     while (defined($line = <RGB>)) {
 187       # the version of rgb.txt supplied with GNU Emacs uses # for comments
 188       next if $line =~ /^[!#]/ || $line =~ /^\s*$/;
 189       chomp $line;
 190       my ($r,$g, $b, $name) = split ' ', $line, 4;
 191       if ($name) {
 192         $pal{lc $name} = [ $r, $g, $b ];
 193       }
 194     }
 195     close RGB;
 196
 197     $x_cache{$filename} = { mod_time=>$mod_time, colors=>\%pal };
 198
 199     return 1;
 200   }
 201   else {
 202     $Imager::ERRSTR = "Cannot open palette file $filename: $!";
 203     return;
 204   }
 205 }
 206
 207 sub _get_x_color {
 208   my %args = @_;
 209
 210   my $filename;
 211   if ($args{palette}) {
 212     $filename = $args{palette};
 213   }
 214   elsif (defined $default_x_rgb) {
 215     unless (length $default_x_rgb) {
 216       $Imager::ERRSTR = "No X rgb.txt palette found";
 217       return ();
 218     }
 219     $filename = $default_x_rgb;
 220   }
 221   else {
 222     for my $attempt (@x_search) {
 223       if (-e $attempt) {
 224         $filename = $attempt;
 225         last;
 226       }
 227     }
 228     if (!$filename) {
 229       $Imager::ERRSTR = "No X rgb.txt palette found";
 230       $default_x_rgb = "";
 231       return ();
 232     }
 233   }
 234
 235   if ((!$x_cache{$filename}
 236       || (stat $filename)[9] != $x_cache{$filename}{mod_time})
 237      && !_load_x_rgb($filename)) {
 238     return ();
 239   }
 240
 241   $default_x_rgb = $filename;
 242
 243   if (!$x_cache{$filename}{colors}{lc $args{name}}) {
 244     $Imager::ERRSTR = "Color '$args{name}' isn't in $filename";
 245     return ();
 246   }
 247
 248   return @{$x_cache{$filename}{colors}{lc $args{name}}};
 249 }
 250
 251 # Parse color spec into an a set of 4 colors
 252
 253 sub _pspec {
 254   return (@_,255) if @_ == 3 && !grep /[^\d.+eE-]/, @_;
 255   return (@_    ) if @_ == 4 && !grep /[^\d.+eE-]/, @_;
 256   if ($_[0] =~
 257       /^\#?([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])/i) {
 258     return (hex($1),hex($2),hex($3),hex($4));
 259   }
 260   if ($_[0] =~ /^\#?([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])/i) {
 261     return (hex($1),hex($2),hex($3),255);
 262   }
 263   if ($_[0] =~ /^\#([\da-f])([\da-f])([\da-f])$/i) {
 264     return (hex($1) * 17, hex($2) * 17, hex($3) * 17, 255);
 265   }
 266   my %args;
 267   if (@_ == 1) {
 268     # a named color
 269     %args = ( name => @_ );
 270   }
 271   else {
 272     %args = @_;
 273   }
 274   my @result;
 275   if (exists $args{gray}) {
 276     @result = $args{gray};
 277   }
 278   elsif (exists $args{grey}) {
 279     @result = $args{grey};
 280   }
 281   elsif ((exists $args{red} || exists $args{r})
 282          && (exists $args{green} || exists $args{g})
 283          && (exists $args{blue} || exists $args{b})) {
 284     @result = ( exists $args{red} ? $args{red} : $args{r},
 285                 exists $args{green} ? $args{green} : $args{g},
 286                 exists $args{blue} ? $args{blue} : $args{b} );
 287   }
 288   elsif ((exists $args{hue} || exists $args{h})
 289          && (exists $args{saturation} || exists $args{'s'})
 290          && (exists $args{value} || exists $args{v})) {
 291     my $hue = exists $args{hue}        ? $args{hue}        : $args{h};
 292     my $sat = exists $args{saturation} ? $args{saturation} : $args{'s'};
 293     my $val = exists $args{value}      ? $args{value}      : $args{v};
 294
 295     @result = _hsv_to_rgb($hue, $sat, $val);
 296   }
 297   elsif (exists $args{web}) {
 298     if ($args{web} =~ /^#?([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])$/i) {
 299       @result = (hex($1),hex($2),hex($3));
 300     }
 301     elsif ($args{web} =~ /^#?([\da-f])([\da-f])([\da-f])$/i) {
 302       @result = (hex($1) * 17, hex($2) * 17, hex($3) * 17);
 303     }
 304   }
 305   elsif ($args{name}) {
 306     unless (@result = _get_gimp_color(%args)) {
 307       unless (@result = _get_x_color(%args)) {
 308         require Imager::Color::Table;
 309         unless (@result = Imager::Color::Table->get($args{name})) {
 310           $Imager::ERRSTR = "No color named $args{name} found";
 311           return ();
 312         }
 313       }
 314     }
 315   }
 316   elsif ($args{gimp}) {
 317     @result = _get_gimp_color(name=>$args{gimp}, %args);
 318   }
 319   elsif ($args{xname}) {
 320     @result = _get_x_color(name=>$args{xname}, %args);
 321   }
 322   elsif ($args{builtin}) {
 323     require Imager::Color::Table;
 324     @result = Imager::Color::Table->get($args{builtin});
 325   }
 326   elsif ($args{rgb}) {
 327     @result = @{$args{rgb}};
 328   }
 329   elsif ($args{rgba}) {
 330     @result = @{$args{rgba}};
 331     return @result if @result == 4;
 332   }
 333   elsif ($args{hsv}) {
 334     @result = _hsv_to_rgb(@{$args{hsv}});
 335   }
 336   elsif ($args{channels}) {
 337     my @ch = @{$args{channels}};
 338     return ( @ch, (0) x (4 - @ch) );
 339   }
 340   elsif (exists $args{channel0} || $args{c0}) {
 341     my $i = 0;
 342     while (exists $args{"channel$i"} || exists $args{"c$i"}) {
 343       push(@result,
 344            exists $args{"channel$i"} ? $args{"channel$i"} : $args{"c$i"});
 345       ++$i;
 346     }
 347   }
 348   else {
 349     $Imager::ERRSTR = "No color specification found";
 350     return ();
 351   }
 352   if (@result) {
 353     if (exists $args{alpha} || exists $args{a}) {
 354       push(@result, exists $args{alpha} ? $args{alpha} : $args{a});
 355     }
 356     while (@result < 4) {
 357       push(@result, 255);
 358     }
 359     return @result;
 360   }
 361   return ();
 362 }
 363
 364 sub new {
 365   shift; # get rid of class name.
 366   my @arg = _pspec(@_);
 367   return @arg ? new_internal($arg[0],$arg[1],$arg[2],$arg[3]) : ();
 368 }
 369
 370 sub set {
 371   my $self = shift;
 372   my @arg = _pspec(@_);
 373   return @arg ? set_internal($self, $arg[0],$arg[1],$arg[2],$arg[3]) : ();
 374 }
 375
 376 sub equals {
 377   my ($self, %opts) = @_;
 378
 379   my $other = $opts{other}
 380     or return Imager->_set_error("'other' parameter required");
 381   my $ignore_alpha = $opts{ignore_alpha} || 0;
 382
 383   my @left = $self->rgba;
 384   my @right = $other->rgba;
 385   my $last_chan = $ignore_alpha ? 2 : 3;
 386   for my $ch (0 .. $last_chan) {
 387     $left[$ch] == $right[$ch]
 388       or return;
 389   }
 390
 391   return 1;
 392 }
 393
 394 sub CLONE_SKIP { 1 }
 395
 396 # Lifted from Graphics::Color::RGB
 397 # Thank you very much
 398 sub hsv {
 399     my( $self ) = @_;
 400
 401     my( $red, $green, $blue, $alpha ) = $self->rgba;
 402     my $max = $red;
 403     my $maxc = 'r';
 404     my $min = $red;
 405
 406     if($green > $max) {
 407         $max = $green;
 408         $maxc = 'g';
 409     }
 410     if($blue > $max) {
 411         $max = $blue;
 412         $maxc = 'b';
 413     }
 414
 415     if($green < $min) {
 416         $min = $green;
 417     }
 418     if($blue < $min) {
 419         $min = $blue;
 420     }
 421
 422     my ($h, $s, $v);
 423
 424     if($max == $min) {
 425         $h = 0;
 426     }
 427     elsif($maxc eq 'r') {
 428         $h = 60 * (($green - $blue) / ($max - $min)) % 360;
 429     }
 430     elsif($maxc eq 'g') {
 431         $h = (60 * (($blue - $red) / ($max - $min)) + 120);
 432     }
 433     elsif($maxc eq 'b') {
 434         $h = (60 * (($red - $green) / ($max - $min)) + 240);
 435     }
 436
 437     $v = $max/255;
 438     if($max == 0) {
 439         $s = 0;
 440     }
 441     else {
 442         $s = 1 - ($min / $max);
 443     }
 444
 445     return int($h), $s, $v, $alpha;
 446
 447 }
 448
 449 1;
 450
 451 __END__
 452
 453 =head1 NAME
 454
 455 Imager::Color - Color handling for Imager.
 456
 457 =head1 SYNOPSIS
 458
 459   use Imager;
 460
 461   $color = Imager::Color->new($red, $green, $blue);
 462   $color = Imager::Color->new($red, $green, $blue, $alpha);
 463   $color = Imager::Color->new("#C0C0FF"); # html color specification
 464
 465   $color->set($red, $green, $blue);
 466   $color->set($red, $green, $blue, $alpha);
 467   $color->set("#C0C0FF"); # html color specification
 468
 469   ($red, $green, $blue, $alpha) = $color->rgba();
 470   @hsv = $color->hsv();
 471
 472   $color->info();
 473
 474   if ($color->equals(other=>$other_color)) {
 475     ...
 476   }
 477
 478
 479 =head1 DESCRIPTION
 480
 481 This module handles creating color objects used by Imager.  The idea
 482 is that in the future this module will be able to handle color space
 483 calculations as well.
 484
 485 An Imager color consists of up to four components, each in the range 0
 486 to 255. Unfortunately the meaning of the components can change
 487 depending on the type of image you're dealing with:
 488
 489 =over
 490
 491 =item *
 492
 493 for 3 or 4 channel images the color components are red, green, blue,
 494 alpha.
 495
 496 =item *
 497
 498 for 1 or 2 channel images the color components are gray, alpha, with
 499 the other two components ignored.
 500
 501 =back
 502
 503 An alpha value of zero is fully transparent, an alpha value of 255 is
 504 fully opaque.
 505
 506 =head1 METHODS
 507
 508 =over 4
 509
 510 =item new
 511
 512 This creates a color object to pass to functions that need a color argument.
 513
 514 =item set
 515
 516 This changes an already defined color.  Note that this does not affect any places
 517 where the color has been used previously.
 518
 519 =item rgba()
 520
 521 This returns the red, green, blue and alpha channels of the color the
 522 object contains.
 523
 524 =item info
 525
 526 Calling info merely dumps the relevant color to the log.
 527
 528 =item equals(other=>$other_color)
 529
 530 =item equals(other=>$other_color, ignore_alpha=>1)
 531
 532 Compares $self and color $other_color returning true if the color
 533 components are the same.
 534
 535 Compares all four channels unless C<ignore_alpha> is set.  If
 536 C<ignore_alpha> is set only the first three channels are compared.
 537
 538 =back
 539
 540 You can specify colors in several different ways, you can just supply
 541 simple values:
 542
 543 =over
 544
 545 =item *
 546
 547 simple numeric parameters - if you supply 3 or 4 numeric arguments, you get a color made up of those RGB (and possibly A) components.
 548
 549 =item *
 550
 551 a six hex digit web color, either C<RRGGBB> or C<#RRGGBB>
 552
 553 =item *
 554
 555 an eight hex digit web color, either C<RRGGBBAA> or C<#RRGGBBAA>.
 556
 557 =item *
 558
 559 a 3 hex digit web color, C<#RGB> - a value of F becomes 255.
 560
 561 =item *
 562
 563 a color name, from whichever of the gimp C<Named_Colors> file or X
 564 C<rgb.txt> is found first.  The same as using the C<name> keyword.
 565
 566 =back
 567
 568 You can supply named parameters:
 569
 570 =over
 571
 572 =item *
 573
 574 'red', 'green' and 'blue', optionally shortened to 'r', 'g' and 'b'.
 575 The color components in the range 0 to 255.
 576
 577  # all of the following are equivalent
 578  my $c1 = Imager::Color->new(red=>100, blue=>255, green=>0);
 579  my $c2 = Imager::Color->new(r=>100, b=>255, g=>0);
 580  my $c3 = Imager::Color->new(r=>100, blue=>255, g=>0);
 581
 582 =item *
 583
 584 C<hue>, C<saturation> and C<value>, optionally shortened to C<h>, C<s> and
 585 C<v>, to specify a HSV color.  0 <= hue < 360, 0 <= s <= 1 and 0 <= v
 586 <= 1.
 587
 588   # the same as RGB(127,255,127)
 589   my $c1 = Imager::Color->new(hue=>120, v=>1, s=>0.5);
 590   my $c1 = Imager::Color->new(hue=>120, value=>1, saturation=>0.5);
 591
 592 =item *
 593
 594 C<web>, which can specify a 6 or 3 hex digit web color, in any of the
 595 forms C<#RRGGBB>, C<#RGB>, C<RRGGBB> or C<RGB>.
 596
 597   my $c1 = Imager::Color->new(web=>'#FFC0C0'); # pale red
 598
 599 =item *
 600
 601 C<gray> or C<grey> which specifies a single channel, from 0 to 255.
 602
 603   # exactly the same
 604   my $c1 = Imager::Color->new(gray=>128);
 605   my $c1 = Imager::Color->new(grey=>128);
 606
 607 =item *
 608
 609 C<rgb> which takes a 3 member arrayref, containing each of the red,
 610 green and blue values.
 611
 612   # the same
 613   my $c1 = Imager::Color->new(rgb=>[255, 100, 0]);
 614   my $c1 = Imager::Color->new(r=>255, g=>100, b=>0);
 615
 616 =item *
 617
 618 C<hsv> which takes a 3 member arrayref, containing each of hue,
 619 saturation and value.
 620
 621   # the same
 622   my $c1 = Imager::Color->new(hsv=>[120, 0.5, 1]);
 623   my $c1 = Imager::Color->new(hue=>120, v=>1, s=>0.5);
 624
 625 =item *
 626
 627 C<gimp> which specifies a color from a GIMP palette file.  You can
 628 specify the file name of the palette file with the 'palette'
 629 parameter, or let Imager::Color look in various places, typically
 630 C<$HOME/gimp-1.x/palettes/Named_Colors> with and without the version
 631 number, and in C</usr/share/gimp/palettes/>.  The palette file must
 632 have color names.
 633
 634   my $c1 = Imager::Color->new(gimp=>'snow');
 635   my $c1 = Imager::Color->new(gimp=>'snow', palette=>'testimg/test_gimp_pal);
 636
 637 =item *
 638
 639 C<xname> which specifies a color from an X11 C<rgb.txt> file.  You can
 640 specify the file name of the C<rgb.txt> file with the C<palette>
 641 parameter, or let Imager::Color look in various places, typically
 642 C</usr/lib/X11/rgb.txt>.
 643
 644   my $c1 = Imager::Color->new(xname=>'blue') # usually RGB(0, 0, 255)
 645
 646 =item *
 647
 648 C<builtin> which specifies a color from the built-in color table in
 649 Imager::Color::Table.  The colors in this module are the same as the
 650 default X11 C<rgb.txt> file.
 651
 652   my $c1 = Imager::Color->new(builtin=>'black') # always RGB(0, 0, 0)
 653
 654 =item *
 655
 656 C<name> which specifies a name from either a GIMP palette, an X
 657 C<rgb.txt> file or the built-in color table, whichever is found first.
 658
 659 =item *
 660
 661 'channel0', 'channel1', etc, each of which specifies a single channel.  These can be abbreviated to 'c0', 'c1' etc.
 662
 663 =item *
 664
 665 'channels' which takes an arrayref of the channel values.
 666
 667 =back
 668
 669 Optionally you can add an alpha channel to a color with the 'alpha' or
 670 'a' parameter.
 671
 672 These color specifications can be used for both constructing new
 673 colors with the new() method and modifying existing colors with the
 674 set() method.
 675
 676 =head1 METHODS
 677
 678 =over
 679
 680 =item hsv()
 681
 682     my($h, $s, $v, $alpha) = $color->hsv();
 683
 684 Returns the color as a Hue/Saturation/Value/Alpha tuple.
 685
 686 =item red
 687
 688 =item green
 689
 690 =item blue
 691
 692 =item alpha
 693
 694 Returns the respective component as an integer from 0 to 255.
 695
 696 =back
 697
 698 =head1 AUTHOR
 699
 700 Arnar M. Hrafnkelsson, addi@umich.edu
 701 And a great deal of help from others - see the C<README> for a complete
 702 list.
 703
 704 =head1 SEE ALSO
 705
 706 Imager(3), Imager::Color
 707 http://imager.perl.org/
 708
 709 =cut