lib/Imager/Color.pm

   1 package Imager::Color;
   2
   3 use Imager;
   4 use strict;
   5 use vars qw($VERSION);
   6
   7 $VERSION = "1.012";
   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     my @ch = @{$args{channels}};
 339     return ( @ch, (0) x (4 - @ch) );
 340   }
 341   elsif (exists $args{channel0} || $args{c0}) {
 342     my $i = 0;
 343     while (exists $args{"channel$i"} || exists $args{"c$i"}) {
 344       push(@result,
 345            exists $args{"channel$i"} ? $args{"channel$i"} : $args{"c$i"});
 346       ++$i;
 347     }
 348   }
 349   else {
 350     $Imager::ERRSTR = "No color specification found";
 351     return ();
 352   }
 353   if (@result) {
 354     if (exists $args{alpha} || exists $args{a}) {
 355       push(@result, exists $args{alpha} ? $args{alpha} : $args{a});
 356     }
 357     while (@result < 4) {
 358       push(@result, 255);
 359     }
 360     return @result;
 361   }
 362   return ();
 363 }
 364
 365 sub new {
 366   shift; # get rid of class name.
 367   my @arg = _pspec(@_);
 368   return @arg ? new_internal($arg[0],$arg[1],$arg[2],$arg[3]) : ();
 369 }
 370
 371 sub set {
 372   my $self = shift;
 373   my @arg = _pspec(@_);
 374   return @arg ? set_internal($self, $arg[0],$arg[1],$arg[2],$arg[3]) : ();
 375 }
 376
 377 sub equals {
 378   my ($self, %opts) = @_;
 379
 380   my $other = $opts{other}
 381     or return Imager->_set_error("'other' parameter required");
 382   my $ignore_alpha = $opts{ignore_alpha} || 0;
 383
 384   my @left = $self->rgba;
 385   my @right = $other->rgba;
 386   my $last_chan = $ignore_alpha ? 2 : 3;
 387   for my $ch (0 .. $last_chan) {
 388     $left[$ch] == $right[$ch]
 389       or return;
 390   }
 391
 392   return 1;
 393 }
 394
 395 sub CLONE_SKIP { 1 }
 396
 397 # Lifted from Graphics::Color::RGB
 398 # Thank you very much
 399 sub hsv {
 400     my( $self ) = @_;
 401
 402     my( $red, $green, $blue, $alpha ) = $self->rgba;
 403     my $max = $red;
 404     my $maxc = 'r';
 405     my $min = $red;
 406
 407     if($green > $max) {
 408         $max = $green;
 409         $maxc = 'g';
 410     }
 411     if($blue > $max) {
 412         $max = $blue;
 413         $maxc = 'b';
 414     }
 415
 416     if($green < $min) {
 417         $min = $green;
 418     }
 419     if($blue < $min) {
 420         $min = $blue;
 421     }
 422
 423     my ($h, $s, $v);
 424
 425     if($max == $min) {
 426         $h = 0;
 427     }
 428     elsif($maxc eq 'r') {
 429         $h = 60 * (($green - $blue) / ($max - $min)) % 360;
 430     }
 431     elsif($maxc eq 'g') {
 432         $h = (60 * (($blue - $red) / ($max - $min)) + 120);
 433     }
 434     elsif($maxc eq 'b') {
 435         $h = (60 * (($red - $green) / ($max - $min)) + 240);
 436     }
 437
 438     $v = $max/255;
 439     if($max == 0) {
 440         $s = 0;
 441     }
 442     else {
 443         $s = 1 - ($min / $max);
 444     }
 445
 446     return int($h), $s, $v, $alpha;
 447
 448 }
 449
 450 1;
 451
 452 __END__
 453
 454 =head1 NAME
 455
 456 Imager::Color - Color handling for Imager.
 457
 458 =head1 SYNOPSIS
 459
 460   use Imager;
 461
 462   $color = Imager::Color->new($red, $green, $blue);
 463   $color = Imager::Color->new($red, $green, $blue, $alpha);
 464   $color = Imager::Color->new("#C0C0FF"); # html color specification
 465
 466   $color->set($red, $green, $blue);
 467   $color->set($red, $green, $blue, $alpha);
 468   $color->set("#C0C0FF"); # html color specification
 469
 470   ($red, $green, $blue, $alpha) = $color->rgba();
 471   @hsv = $color->hsv();
 472
 473   $color->info();
 474
 475   if ($color->equals(other=>$other_color)) {
 476     ...
 477   }
 478
 479
 480 =head1 DESCRIPTION
 481
 482 This module handles creating color objects used by Imager.  The idea
 483 is that in the future this module will be able to handle color space
 484 calculations as well.
 485
 486 An Imager color consists of up to four components, each in the range 0
 487 to 255. Unfortunately the meaning of the components can change
 488 depending on the type of image you're dealing with:
 489
 490 =over
 491
 492 =item *
 493
 494 for 3 or 4 channel images the color components are red, green, blue,
 495 alpha.
 496
 497 =item *
 498
 499 for 1 or 2 channel images the color components are gray, alpha, with
 500 the other two components ignored.
 501
 502 =back
 503
 504 An alpha value of zero is fully transparent, an alpha value of 255 is
 505 fully opaque.
 506
 507 =head1 METHODS
 508
 509 =over 4
 510
 511 =item new
 512
 513 This creates a color object to pass to functions that need a color argument.
 514
 515 =item set
 516
 517 This changes an already defined color.  Note that this does not affect any places
 518 where the color has been used previously.
 519
 520 =item rgba()
 521
 522 This returns the red, green, blue and alpha channels of the color the
 523 object contains.
 524
 525 =item info
 526
 527 Calling info merely dumps the relevant color to the log.
 528
 529 =item equals(other=>$other_color)
 530
 531 =item equals(other=>$other_color, ignore_alpha=>1)
 532
 533 Compares $self and color $other_color returning true if the color
 534 components are the same.
 535
 536 Compares all four channels unless C<ignore_alpha> is set.  If
 537 C<ignore_alpha> is set only the first three channels are compared.
 538
 539 =back
 540
 541 You can specify colors in several different ways, you can just supply
 542 simple values:
 543
 544 =over
 545
 546 =item *
 547
 548 simple numeric parameters - if you supply 3 or 4 numeric arguments, you get a color made up of those RGB (and possibly A) components.
 549
 550 =item *
 551
 552 a six hex digit web color, either C<RRGGBB> or C<#RRGGBB>
 553
 554 =item *
 555
 556 an eight hex digit web color, either C<RRGGBBAA> or C<#RRGGBBAA>.
 557
 558 =item *
 559
 560 a 3 hex digit web color, C<#RGB> - a value of F becomes 255.
 561
 562 =item *
 563
 564 a color name, from whichever of the gimp C<Named_Colors> file or X
 565 C<rgb.txt> is found first.  The same as using the C<name> keyword.
 566
 567 =back
 568
 569 You can supply named parameters:
 570
 571 =over
 572
 573 =item *
 574
 575 'red', 'green' and 'blue', optionally shortened to 'r', 'g' and 'b'.
 576 The color components in the range 0 to 255.
 577
 578  # all of the following are equivalent
 579  my $c1 = Imager::Color->new(red=>100, blue=>255, green=>0);
 580  my $c2 = Imager::Color->new(r=>100, b=>255, g=>0);
 581  my $c3 = Imager::Color->new(r=>100, blue=>255, g=>0);
 582
 583 =item *
 584
 585 C<hue>, C<saturation> and C<value>, optionally shortened to C<h>, C<s> and
 586 C<v>, to specify a HSV color.  0 <= hue < 360, 0 <= s <= 1 and 0 <= v
 587 <= 1.
 588
 589   # the same as RGB(127,255,127)
 590   my $c1 = Imager::Color->new(hue=>120, v=>1, s=>0.5);
 591   my $c1 = Imager::Color->new(hue=>120, value=>1, saturation=>0.5);
 592
 593 =item *
 594
 595 C<web>, which can specify a 6 or 3 hex digit web color, in any of the
 596 forms C<#RRGGBB>, C<#RGB>, C<RRGGBB> or C<RGB>.
 597
 598   my $c1 = Imager::Color->new(web=>'#FFC0C0'); # pale red
 599
 600 =item *
 601
 602 C<gray> or C<grey> which specifies a single channel, from 0 to 255.
 603
 604   # exactly the same
 605   my $c1 = Imager::Color->new(gray=>128);
 606   my $c1 = Imager::Color->new(grey=>128);
 607
 608 =item *
 609
 610 C<rgb> which takes a 3 member arrayref, containing each of the red,
 611 green and blue values.
 612
 613   # the same
 614   my $c1 = Imager::Color->new(rgb=>[255, 100, 0]);
 615   my $c1 = Imager::Color->new(r=>255, g=>100, b=>0);
 616
 617 =item *
 618
 619 C<hsv> which takes a 3 member arrayref, containing each of hue,
 620 saturation and value.
 621
 622   # the same
 623   my $c1 = Imager::Color->new(hsv=>[120, 0.5, 1]);
 624   my $c1 = Imager::Color->new(hue=>120, v=>1, s=>0.5);
 625
 626 =item *
 627
 628 C<gimp> which specifies a color from a GIMP palette file.  You can
 629 specify the file name of the palette file with the 'palette'
 630 parameter, or let Imager::Color look in various places, typically
 631 C<$HOME/gimp-1.x/palettes/Named_Colors> with and without the version
 632 number, and in C</usr/share/gimp/palettes/>.  The palette file must
 633 have color names.
 634
 635   my $c1 = Imager::Color->new(gimp=>'snow');
 636   my $c1 = Imager::Color->new(gimp=>'snow', palette=>'testimg/test_gimp_pal);
 637
 638 =item *
 639
 640 C<xname> which specifies a color from an X11 C<rgb.txt> file.  You can
 641 specify the file name of the C<rgb.txt> file with the C<palette>
 642 parameter, or let Imager::Color look in various places, typically
 643 C</usr/lib/X11/rgb.txt>.
 644
 645   my $c1 = Imager::Color->new(xname=>'blue') # usually RGB(0, 0, 255)
 646
 647 =item *
 648
 649 C<builtin> which specifies a color from the built-in color table in
 650 Imager::Color::Table.  The colors in this module are the same as the
 651 default X11 C<rgb.txt> file.
 652
 653   my $c1 = Imager::Color->new(builtin=>'black') # always RGB(0, 0, 0)
 654
 655 =item *
 656
 657 C<name> which specifies a name from either a GIMP palette, an X
 658 C<rgb.txt> file or the built-in color table, whichever is found first.
 659
 660 =item *
 661
 662 'channel0', 'channel1', etc, each of which specifies a single channel.  These can be abbreviated to 'c0', 'c1' etc.
 663
 664 =item *
 665
 666 'channels' which takes an arrayref of the channel values.
 667
 668 =back
 669
 670 Optionally you can add an alpha channel to a color with the 'alpha' or
 671 'a' parameter.
 672
 673 These color specifications can be used for both constructing new
 674 colors with the new() method and modifying existing colors with the
 675 set() method.
 676
 677 =head1 METHODS
 678
 679 =over
 680
 681 =item hsv()
 682
 683     my($h, $s, $v, $alpha) = $color->hsv();
 684
 685 Returns the color as a Hue/Saturation/Value/Alpha tuple.
 686
 687 =back
 688
 689 =head1 AUTHOR
 690
 691 Arnar M. Hrafnkelsson, addi@umich.edu
 692 And a great deal of help from others - see the C<README> for a complete
 693 list.
 694
 695 =head1 SEE ALSO
 696
 697 Imager(3), Imager::Color
 698 http://imager.perl.org/
 699
 700 =cut