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 my $default_gimp_palette;
  67
  68 sub _load_gimp_palette {
  69   my ($filename) = @_;
  70
  71   if (open PAL, "< $filename") {
  72     my $hdr = <PAL>;
  73     chomp $hdr;
  74     unless ($hdr =~ /GIMP Palette/) {
  75       close PAL;
  76       $Imager::ERRSTR = "$filename is not a GIMP palette file";
  77       return;
  78     }
  79     my $line;
  80     my %pal;
  81     my $mod_time = (stat PAL)[9];
  82     while (defined($line = <PAL>)) {
  83       next if $line =~ /^#/ || $line =~ /^\s*$/;
  84       chomp $line;
  85       my ($r,$g, $b, $name) = split ' ', $line, 4;
  86       if ($name) {
  87         $name =~ s/\s*\([\d\s]+\)\s*$//;
  88         $pal{lc $name} = [ $r, $g, $b ];
  89       }
  90     }
  91     close PAL;
  92
  93     $gimp_cache{$filename} = { mod_time=>$mod_time, colors=>\%pal };
  94
  95     return 1;
  96   }
  97   else {
  98     $Imager::ERRSTR = "Cannot open palette file $filename: $!";
  99     return;
 100   }
 101 }
 102
 103 sub _get_gimp_color {
 104   my %args = @_;
 105
 106   my $filename;
 107   if ($args{palette}) {
 108     $filename = $args{palette};
 109   }
 110   elsif (defined $default_gimp_palette) {
 111     # don't search again and again and again ...
 112     if (!length $default_gimp_palette
 113         || !-f $default_gimp_palette) {
 114       $Imager::ERRSTR = "No GIMP palette found";
 115       $default_gimp_palette = "";
 116       return;
 117     }
 118
 119     $filename = $default_gimp_palette;
 120   }
 121   else {
 122     # try to make one up - this is intended to die if tainting is
 123     # enabled and $ENV{HOME} is tainted.  To avoid that untaint $ENV{HOME}
 124     # or set the palette parameter
 125     for my $attempt (@gimp_search) {
 126       my $work = $attempt; # don't modify the source array
 127       $work =~ /\$HOME/ && !defined $ENV{HOME}
 128         and next;
 129       $work =~ s/\$HOME/$ENV{HOME}/;
 130       if (-e $work) {
 131         $filename = $work;
 132         last;
 133       }
 134     }
 135     if (!$filename) {
 136       $Imager::ERRSTR = "No GIMP palette found";
 137       $default_gimp_palette = "";
 138       return ();
 139     }
 140
 141     $default_gimp_palette = $filename;
 142   }
 143
 144   if ((!$gimp_cache{$filename}
 145       || (stat $filename)[9] != $gimp_cache{$filename})
 146      && !_load_gimp_palette($filename)) {
 147     return ();
 148   }
 149
 150   if (!$gimp_cache{$filename}{colors}{lc $args{name}}) {
 151     $Imager::ERRSTR = "Color '$args{name}' isn't in $filename";
 152     return ();
 153   }
 154
 155   return @{$gimp_cache{$filename}{colors}{lc $args{name}}};
 156 }
 157
 158 my @x_search =
 159   (
 160    '/usr/share/X11/rgb.txt', # newer Xorg X11 dists use this
 161    '/usr/lib/X11/rgb.txt', # seems fairly standard
 162    '/usr/local/lib/X11/rgb.txt', # seems possible
 163    '/usr/X11R6/lib/X11/rgb.txt', # probably the same as the first
 164    '/usr/openwin/lib/rgb.txt',
 165    '/usr/openwin/lib/X11/rgb.txt',
 166   );
 167
 168 my $default_x_rgb;
 169
 170 # called by the test code to check if we can test this stuff
 171 sub _test_x_palettes {
 172   @x_search;
 173 }
 174
 175 # x rgb.txt cache
 176 # same structure as %gimp_cache
 177 my %x_cache;
 178
 179 sub _load_x_rgb {
 180   my ($filename) = @_;
 181
 182   local *RGB;
 183   if (open RGB, "< $filename") {
 184     my $line;
 185     my %pal;
 186     my $mod_time = (stat RGB)[9];
 187     while (defined($line = <RGB>)) {
 188       # the version of rgb.txt supplied with GNU Emacs uses # for comments
 189       next if $line =~ /^[!#]/ || $line =~ /^\s*$/;
 190       chomp $line;
 191       my ($r,$g, $b, $name) = split ' ', $line, 4;
 192       if ($name) {
 193         $pal{lc $name} = [ $r, $g, $b ];
 194       }
 195     }
 196     close RGB;
 197
 198     $x_cache{$filename} = { mod_time=>$mod_time, colors=>\%pal };
 199
 200     return 1;
 201   }
 202   else {
 203     $Imager::ERRSTR = "Cannot open palette file $filename: $!";
 204     return;
 205   }
 206 }
 207
 208 sub _get_x_color {
 209   my %args = @_;
 210
 211   my $filename;
 212   if ($args{palette}) {
 213     $filename = $args{palette};
 214   }
 215   elsif (defined $default_x_rgb) {
 216     unless (length $default_x_rgb) {
 217       $Imager::ERRSTR = "No X rgb.txt palette found";
 218       return ();
 219     }
 220     $filename = $default_x_rgb;
 221   }
 222   else {
 223     for my $attempt (@x_search) {
 224       if (-e $attempt) {
 225         $filename = $attempt;
 226         last;
 227       }
 228     }
 229     if (!$filename) {
 230       $Imager::ERRSTR = "No X rgb.txt palette found";
 231       $default_x_rgb = "";
 232       return ();
 233     }
 234   }
 235
 236   if ((!$x_cache{$filename}
 237       || (stat $filename)[9] != $x_cache{$filename}{mod_time})
 238      && !_load_x_rgb($filename)) {
 239     return ();
 240   }
 241
 242   $default_x_rgb = $filename;
 243
 244   if (!$x_cache{$filename}{colors}{lc $args{name}}) {
 245     $Imager::ERRSTR = "Color '$args{name}' isn't in $filename";
 246     return ();
 247   }
 248
 249   return @{$x_cache{$filename}{colors}{lc $args{name}}};
 250 }
 251
 252 # Parse color spec into an a set of 4 colors
 253
 254 sub _pspec {
 255   return (@_,255) if @_ == 3 && !grep /[^\d.+eE-]/, @_;
 256   return (@_    ) if @_ == 4 && !grep /[^\d.+eE-]/, @_;
 257   if ($_[0] =~
 258       /^\#?([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])/i) {
 259     return (hex($1),hex($2),hex($3),hex($4));
 260   }
 261   if ($_[0] =~ /^\#?([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])/i) {
 262     return (hex($1),hex($2),hex($3),255);
 263   }
 264   if ($_[0] =~ /^\#([\da-f])([\da-f])([\da-f])$/i) {
 265     return (hex($1) * 17, hex($2) * 17, hex($3) * 17, 255);
 266   }
 267   my %args;
 268   if (@_ == 1) {
 269     # a named color
 270     %args = ( name => @_ );
 271   }
 272   else {
 273     %args = @_;
 274   }
 275   my @result;
 276   if (exists $args{gray}) {
 277     @result = $args{gray};
 278   }
 279   elsif (exists $args{grey}) {
 280     @result = $args{grey};
 281   }
 282   elsif ((exists $args{red} || exists $args{r})
 283          && (exists $args{green} || exists $args{g})
 284          && (exists $args{blue} || exists $args{b})) {
 285     @result = ( exists $args{red} ? $args{red} : $args{r},
 286                 exists $args{green} ? $args{green} : $args{g},
 287                 exists $args{blue} ? $args{blue} : $args{b} );
 288   }
 289   elsif ((exists $args{hue} || exists $args{h})
 290          && (exists $args{saturation} || exists $args{'s'})
 291          && (exists $args{value} || exists $args{v})) {
 292     my $hue = exists $args{hue}        ? $args{hue}        : $args{h};
 293     my $sat = exists $args{saturation} ? $args{saturation} : $args{'s'};
 294     my $val = exists $args{value}      ? $args{value}      : $args{v};
 295
 296     @result = _hsv_to_rgb($hue, $sat, $val);
 297   }
 298   elsif (exists $args{web}) {
 299     if ($args{web} =~ /^#?([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])$/i) {
 300       @result = (hex($1),hex($2),hex($3));
 301     }
 302     elsif ($args{web} =~ /^#?([\da-f])([\da-f])([\da-f])$/i) {
 303       @result = (hex($1) * 17, hex($2) * 17, hex($3) * 17);
 304     }
 305   }
 306   elsif ($args{name}) {
 307     unless (@result = _get_gimp_color(%args)) {
 308       unless (@result = _get_x_color(%args)) {
 309         require Imager::Color::Table;
 310         unless (@result = Imager::Color::Table->get($args{name})) {
 311           $Imager::ERRSTR = "No color named $args{name} found";
 312           return ();
 313         }
 314       }
 315     }
 316   }
 317   elsif ($args{gimp}) {
 318     @result = _get_gimp_color(name=>$args{gimp}, %args);
 319   }
 320   elsif ($args{xname}) {
 321     @result = _get_x_color(name=>$args{xname}, %args);
 322   }
 323   elsif ($args{builtin}) {
 324     require Imager::Color::Table;
 325     @result = Imager::Color::Table->get($args{builtin});
 326   }
 327   elsif ($args{rgb}) {
 328     @result = @{$args{rgb}};
 329   }
 330   elsif ($args{rgba}) {
 331     @result = @{$args{rgba}};
 332     return @result if @result == 4;
 333   }
 334   elsif ($args{hsv}) {
 335     @result = _hsv_to_rgb(@{$args{hsv}});
 336   }
 337   elsif ($args{channels}) {
 338     return @{$args{channels}};
 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 =back
 687
 688 =head1 AUTHOR
 689
 690 Arnar M. Hrafnkelsson, addi@umich.edu
 691 And a great deal of help from others - see the C<README> for a complete
 692 list.
 693
 694 =head1 SEE ALSO
 695
 696 Imager(3), Imager::Color
 697 http://imager.perl.org/
 698
 699 =cut