lib/Imager/Color.pm

   1 package Imager::Color;
   2
   3 use Imager;
   4 use strict;
   5 use vars qw($VERSION);
   6
   7 $VERSION = "1.010";
   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/lib/X11/rgb.txt', # seems fairly standard
 145    '/usr/local/lib/X11/rgb.txt', # seems possible
 146    '/usr/X11R6/lib/X11/rgb.txt', # probably the same as the first
 147    '/usr/openwin/lib/rgb.txt',
 148    '/usr/openwin/lib/X11/rgb.txt',
 149   );
 150
 151 # x rgb.txt cache
 152 # same structure as %gimp_cache
 153 my %x_cache;
 154
 155 sub _load_x_rgb {
 156   my ($filename) = @_;
 157
 158   local *RGB;
 159   if (open RGB, "< $filename") {
 160     my $line;
 161     my %pal;
 162     my $mod_time = (stat RGB)[9];
 163     while (defined($line = <RGB>)) {
 164       # the version of rgb.txt supplied with GNU Emacs uses # for comments
 165       next if $line =~ /^[!#]/ || $line =~ /^\s*$/;
 166       chomp $line;
 167       my ($r,$g, $b, $name) = split ' ', $line, 4;
 168       if ($name) {
 169         $pal{lc $name} = [ $r, $g, $b ];
 170       }
 171     }
 172     close RGB;
 173
 174     $x_cache{$filename} = { mod_time=>$mod_time, colors=>\%pal };
 175
 176     return 1;
 177   }
 178   else {
 179     $Imager::ERRSTR = "Cannot open palette file $filename: $!";
 180     return;
 181   }
 182 }
 183
 184 sub _get_x_color {
 185   my %args = @_;
 186
 187   my $filename;
 188   if ($args{palette}) {
 189     $filename = $args{palette};
 190   }
 191   else {
 192     for my $attempt (@x_search) {
 193       if (-e $attempt) {
 194         $filename = $attempt;
 195         last;
 196       }
 197     }
 198     if (!$filename) {
 199       $Imager::ERRSTR = "No X rgb.txt palette found";
 200       return ();
 201     }
 202   }
 203
 204   if ((!$x_cache{$filename}
 205       || (stat $filename)[9] != $x_cache{$filename})
 206      && !_load_x_rgb($filename)) {
 207     return ();
 208   }
 209
 210   if (!$x_cache{$filename}{colors}{lc $args{name}}) {
 211     $Imager::ERRSTR = "Color '$args{name}' isn't in $filename";
 212     return ();
 213   }
 214
 215   return @{$x_cache{$filename}{colors}{lc $args{name}}};
 216 }
 217
 218 # Parse color spec into an a set of 4 colors
 219
 220 sub _pspec {
 221   return (@_,255) if @_ == 3 && !grep /[^\d.+eE-]/, @_;
 222   return (@_    ) if @_ == 4 && !grep /[^\d.+eE-]/, @_;
 223   if ($_[0] =~
 224       /^\#?([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])/i) {
 225     return (hex($1),hex($2),hex($3),hex($4));
 226   }
 227   if ($_[0] =~ /^\#?([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])/i) {
 228     return (hex($1),hex($2),hex($3),255);
 229   }
 230   if ($_[0] =~ /^\#([\da-f])([\da-f])([\da-f])$/i) {
 231     return (hex($1) * 17, hex($2) * 17, hex($3) * 17, 255);
 232   }
 233   my %args;
 234   if (@_ == 1) {
 235     # a named color
 236     %args = ( name => @_ );
 237   }
 238   else {
 239     %args = @_;
 240   }
 241   my @result;
 242   if (exists $args{gray}) {
 243     @result = $args{gray};
 244   }
 245   elsif (exists $args{grey}) {
 246     @result = $args{grey};
 247   }
 248   elsif ((exists $args{red} || exists $args{r})
 249          && (exists $args{green} || exists $args{g})
 250          && (exists $args{blue} || exists $args{b})) {
 251     @result = ( exists $args{red} ? $args{red} : $args{r},
 252                 exists $args{green} ? $args{green} : $args{g},
 253                 exists $args{blue} ? $args{blue} : $args{b} );
 254   }
 255   elsif ((exists $args{hue} || exists $args{h})
 256          && (exists $args{saturation} || exists $args{'s'})
 257          && (exists $args{value} || exists $args{v})) {
 258     my $hue = exists $args{hue}        ? $args{hue}        : $args{h};
 259     my $sat = exists $args{saturation} ? $args{saturation} : $args{'s'};
 260     my $val = exists $args{value}      ? $args{value}      : $args{v};
 261
 262     @result = _hsv_to_rgb($hue, $sat, $val);
 263   }
 264   elsif (exists $args{web}) {
 265     if ($args{web} =~ /^#?([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])$/i) {
 266       @result = (hex($1),hex($2),hex($3));
 267     }
 268     elsif ($args{web} =~ /^#?([\da-f])([\da-f])([\da-f])$/i) {
 269       @result = (hex($1) * 17, hex($2) * 17, hex($3) * 17);
 270     }
 271   }
 272   elsif ($args{name}) {
 273     unless (@result = _get_gimp_color(%args)) {
 274       unless (@result = _get_x_color(%args)) {
 275         require Imager::Color::Table;
 276         unless (@result = Imager::Color::Table->get($args{name})) {
 277           $Imager::ERRSTR = "No color named $args{name} found";
 278           return ();
 279         }
 280       }
 281     }
 282   }
 283   elsif ($args{gimp}) {
 284     @result = _get_gimp_color(name=>$args{gimp}, %args);
 285   }
 286   elsif ($args{xname}) {
 287     @result = _get_x_color(name=>$args{xname}, %args);
 288   }
 289   elsif ($args{builtin}) {
 290     require Imager::Color::Table;
 291     @result = Imager::Color::Table->get($args{builtin});
 292   }
 293   elsif ($args{rgb}) {
 294     @result = @{$args{rgb}};
 295   }
 296   elsif ($args{rgba}) {
 297     @result = @{$args{rgba}};
 298     return @result if @result == 4;
 299   }
 300   elsif ($args{hsv}) {
 301     @result = _hsv_to_rgb(@{$args{hsv}});
 302   }
 303   elsif ($args{channels}) {
 304     return @{$args{channels}};
 305   }
 306   elsif (exists $args{channel0} || $args{c0}) {
 307     my $i = 0;
 308     while (exists $args{"channel$i"} || exists $args{"c$i"}) {
 309       push(@result,
 310            exists $args{"channel$i"} ? $args{"channel$i"} : $args{"c$i"});
 311       ++$i;
 312     }
 313   }
 314   else {
 315     $Imager::ERRSTR = "No color specification found";
 316     return ();
 317   }
 318   if (@result) {
 319     if (exists $args{alpha} || exists $args{a}) {
 320       push(@result, exists $args{alpha} ? $args{alpha} : $args{a});
 321     }
 322     while (@result < 4) {
 323       push(@result, 255);
 324     }
 325     return @result;
 326   }
 327   return ();
 328 }
 329
 330 sub new {
 331   shift; # get rid of class name.
 332   my @arg = _pspec(@_);
 333   return @arg ? new_internal($arg[0],$arg[1],$arg[2],$arg[3]) : ();
 334 }
 335
 336 sub set {
 337   my $self = shift;
 338   my @arg = _pspec(@_);
 339   return @arg ? set_internal($self, $arg[0],$arg[1],$arg[2],$arg[3]) : ();
 340 }
 341
 342 sub equals {
 343   my ($self, %opts) = @_;
 344
 345   my $other = $opts{other}
 346     or return Imager->_set_error("'other' parameter required");
 347   my $ignore_alpha = $opts{ignore_alpha} || 0;
 348
 349   my @left = $self->rgba;
 350   my @right = $other->rgba;
 351   my $last_chan = $ignore_alpha ? 2 : 3;
 352   for my $ch (0 .. $last_chan) {
 353     $left[$ch] == $right[$ch]
 354       or return;
 355   }
 356
 357   return 1;
 358 }
 359
 360 1;
 361
 362 __END__
 363
 364 =head1 NAME
 365
 366 Imager::Color - Color handling for Imager.
 367
 368 =head1 SYNOPSIS
 369
 370   $color = Imager::Color->new($red, $green, $blue);
 371   $color = Imager::Color->new($red, $green, $blue, $alpha);
 372   $color = Imager::Color->new("#C0C0FF"); # html color specification
 373
 374   $color->set($red, $green, $blue);
 375   $color->set($red, $green, $blue, $alpha);
 376   $color->set("#C0C0FF"); # html color specification
 377
 378   ($red, $green, $blue, $alpha) = $color->rgba();
 379   @hsv = $color->hsv(); # not implemented but proposed
 380
 381   $color->info();
 382
 383   if ($color->equals(other=>$other_color)) {
 384     ...
 385   }
 386
 387
 388 =head1 DESCRIPTION
 389
 390 This module handles creating color objects used by imager.  The idea is
 391 that in the future this module will be able to handle colorspace calculations
 392 as well.
 393
 394 =over 4
 395
 396 =item new
 397
 398 This creates a color object to pass to functions that need a color argument.
 399
 400 =item set
 401
 402 This changes an already defined color.  Note that this does not affect any places
 403 where the color has been used previously.
 404
 405 =item rgba
 406
 407 This returns the rgba code of the color the object contains.
 408
 409 =item info
 410
 411 Calling info merely dumps the relevant colorcode to the log.
 412
 413 =item equals(other=>$other_color)
 414
 415 =item equals(other=>$other_color, ignore_alpha=>1)
 416
 417 Compares $self and color $other_color returning true if the color
 418 components are the same.
 419
 420 Compares all four channels unless C<ignore_alpha> is set.  If
 421 C<ignore_alpha> is set only the first three channels are compared.
 422
 423 =back
 424
 425 You can specify colors in several different ways, you can just supply
 426 simple values:
 427
 428 =over
 429
 430 =item *
 431
 432 simple numeric parameters - if you supply 3 or 4 numeric arguments, you get a color made up of those RGB (and possibly A) components.
 433
 434 =item *
 435
 436 a six hex digit web color, either 'RRGGBB' or '#RRGGBB'
 437
 438 =item *
 439
 440 an eight hex digit web color, either 'RRGGBBAA' or '#RRGGBBAA'.
 441
 442 =item *
 443
 444 a 3 hex digit web color, '#RGB' - a value of F becomes 255.
 445
 446 =item *
 447
 448 a color name, from whichever of the gimp Named_Colors file or X
 449 rgb.txt is found first.  The same as using the name keyword.
 450
 451 =back
 452
 453 You can supply named parameters:
 454
 455 =over
 456
 457 =item *
 458
 459 'red', 'green' and 'blue', optionally shortened to 'r', 'g' and 'b'.
 460 The color components in the range 0 to 255.
 461
 462  # all of the following are equivalent
 463  my $c1 = Imager::Color->new(red=>100, blue=>255, green=>0);
 464  my $c2 = Imager::Color->new(r=>100, b=>255, g=>0);
 465  my $c3 = Imager::Color->new(r=>100, blue=>255, g=>0);
 466
 467 =item *
 468
 469 'hue', 'saturation' and 'value', optionally shortened to 'h', 's' and
 470 'v', to specify a HSV color.  0 <= hue < 360, 0 <= s <= 1 and 0 <= v
 471 <= 1.
 472
 473   # the same as RGB(127,255,127)
 474   my $c1 = Imager::Color->new(hue=>120, v=>1, s=>0.5);
 475   my $c1 = Imager::Color->new(hue=>120, value=>1, saturation=>0.5);
 476
 477 =item *
 478
 479 'web', which can specify a 6 or 3 hex digit web color, in any of the
 480 forms '#RRGGBB', '#RGB', 'RRGGBB' or 'RGB'.
 481
 482   my $c1 = Imager::Color->new(web=>'#FFC0C0'); # pale red
 483
 484 =item *
 485
 486 'gray' or 'grey' which specifies a single channel, from 0 to 255.
 487
 488   # exactly the same
 489   my $c1 = Imager::Color->new(gray=>128);
 490   my $c1 = Imager::Color->new(grey=>128);
 491
 492 =item *
 493
 494 'rgb' which takes a 3 member arrayref, containing each of the red,
 495 green and blue values.
 496
 497   # the same
 498   my $c1 = Imager::Color->new(rgb=>[255, 100, 0]);
 499   my $c1 = Imager::Color->new(r=>255, g=>100, b=>0);
 500
 501 =item *
 502
 503 'hsv' which takes a 3 member arrayref, containting each of hue,
 504 saturation and value.
 505
 506   # the same
 507   my $c1 = Imager::Color->new(hsv=>[120, 0.5, 1]);
 508   my $c1 = Imager::Color->new(hue=>120, v=>1, s=>0.5);
 509
 510 =item *
 511
 512 'gimp' which specifies a color from a GIMP palette file.  You can
 513 specify the filename of the palette file with the 'palette' parameter,
 514 or let Imager::Color look in various places, typically
 515 "$HOME/gimp-1.x/palettes/Named_Colors" with and without the version
 516 number, and in /usr/share/gimp/palettes/.  The palette file must have
 517 color names.
 518
 519   my $c1 = Imager::Color->new(gimp=>'snow');
 520   my $c1 = Imager::Color->new(gimp=>'snow', palette=>'testimg/test_gimp_pal);
 521
 522 =item *
 523
 524 'xname' which specifies a color from an X11 rgb.txt file.  You can
 525 specify the filename of the rgb.txt file with the 'palette' parameter,
 526 or let Imager::Color look in various places, typically
 527 '/usr/lib/X11/rgb.txt'.
 528
 529   my $c1 = Imager::Color->new(xname=>'blue') # usually RGB(0, 0, 255)
 530
 531 =item *
 532
 533 'builtin' which specifies a color from the built-in color table in
 534 Imager::Color::Table.  The colors in this module are the same as the
 535 default X11 rgb.txt file.
 536
 537   my $c1 = Imager::Color->new(builtin=>'black') # always RGB(0, 0, 0)
 538
 539 =item *
 540
 541 'name' which specifies a name from either a GIMP palette, an X rgb.txt
 542 file or the built-in color table, whichever is found first.
 543
 544 =item *
 545
 546 'channel0', 'channel1', etc, each of which specifies a single channel.  These can be abbreviated to 'c0', 'c1' etc.
 547
 548 =item *
 549
 550 'channels' which takes an arrayref of the channel values.
 551
 552 =back
 553
 554 Optionally you can add an alpha channel to a color with the 'alpha' or
 555 'a' parameter.
 556
 557 These color specifications can be used for both constructing new
 558 colors with the new() method and modifying existing colors with the
 559 set() method.
 560
 561 =head1 AUTHOR
 562
 563 Arnar M. Hrafnkelsson, addi@umich.edu
 564 And a great deal of help from others - see the README for a complete
 565 list.
 566
 567 =head1 SEE ALSO
 568
 569 Imager(3)
 570 http://imager.perl.org/
 571
 572 =cut