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/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 1;
 367
 368 __END__
 369
 370 =head1 NAME
 371
 372 Imager::Color - Color handling for Imager.
 373
 374 =head1 SYNOPSIS
 375
 376   $color = Imager::Color->new($red, $green, $blue);
 377   $color = Imager::Color->new($red, $green, $blue, $alpha);
 378   $color = Imager::Color->new("#C0C0FF"); # html color specification
 379
 380   $color->set($red, $green, $blue);
 381   $color->set($red, $green, $blue, $alpha);
 382   $color->set("#C0C0FF"); # html color specification
 383
 384   ($red, $green, $blue, $alpha) = $color->rgba();
 385   @hsv = $color->hsv(); # not implemented but proposed
 386
 387   $color->info();
 388
 389   if ($color->equals(other=>$other_color)) {
 390     ...
 391   }
 392
 393
 394 =head1 DESCRIPTION
 395
 396 This module handles creating color objects used by imager.  The idea is
 397 that in the future this module will be able to handle colorspace calculations
 398 as well.
 399
 400 =over 4
 401
 402 =item new
 403
 404 This creates a color object to pass to functions that need a color argument.
 405
 406 =item set
 407
 408 This changes an already defined color.  Note that this does not affect any places
 409 where the color has been used previously.
 410
 411 =item rgba
 412
 413 This returns the rgba code of the color the object contains.
 414
 415 =item info
 416
 417 Calling info merely dumps the relevant colorcode to the log.
 418
 419 =item equals(other=>$other_color)
 420
 421 =item equals(other=>$other_color, ignore_alpha=>1)
 422
 423 Compares $self and color $other_color returning true if the color
 424 components are the same.
 425
 426 Compares all four channels unless C<ignore_alpha> is set.  If
 427 C<ignore_alpha> is set only the first three channels are compared.
 428
 429 =back
 430
 431 You can specify colors in several different ways, you can just supply
 432 simple values:
 433
 434 =over
 435
 436 =item *
 437
 438 simple numeric parameters - if you supply 3 or 4 numeric arguments, you get a color made up of those RGB (and possibly A) components.
 439
 440 =item *
 441
 442 a six hex digit web color, either 'RRGGBB' or '#RRGGBB'
 443
 444 =item *
 445
 446 an eight hex digit web color, either 'RRGGBBAA' or '#RRGGBBAA'.
 447
 448 =item *
 449
 450 a 3 hex digit web color, '#RGB' - a value of F becomes 255.
 451
 452 =item *
 453
 454 a color name, from whichever of the gimp Named_Colors file or X
 455 rgb.txt is found first.  The same as using the name keyword.
 456
 457 =back
 458
 459 You can supply named parameters:
 460
 461 =over
 462
 463 =item *
 464
 465 'red', 'green' and 'blue', optionally shortened to 'r', 'g' and 'b'.
 466 The color components in the range 0 to 255.
 467
 468  # all of the following are equivalent
 469  my $c1 = Imager::Color->new(red=>100, blue=>255, green=>0);
 470  my $c2 = Imager::Color->new(r=>100, b=>255, g=>0);
 471  my $c3 = Imager::Color->new(r=>100, blue=>255, g=>0);
 472
 473 =item *
 474
 475 'hue', 'saturation' and 'value', optionally shortened to 'h', 's' and
 476 'v', to specify a HSV color.  0 <= hue < 360, 0 <= s <= 1 and 0 <= v
 477 <= 1.
 478
 479   # the same as RGB(127,255,127)
 480   my $c1 = Imager::Color->new(hue=>120, v=>1, s=>0.5);
 481   my $c1 = Imager::Color->new(hue=>120, value=>1, saturation=>0.5);
 482
 483 =item *
 484
 485 'web', which can specify a 6 or 3 hex digit web color, in any of the
 486 forms '#RRGGBB', '#RGB', 'RRGGBB' or 'RGB'.
 487
 488   my $c1 = Imager::Color->new(web=>'#FFC0C0'); # pale red
 489
 490 =item *
 491
 492 'gray' or 'grey' which specifies a single channel, from 0 to 255.
 493
 494   # exactly the same
 495   my $c1 = Imager::Color->new(gray=>128);
 496   my $c1 = Imager::Color->new(grey=>128);
 497
 498 =item *
 499
 500 'rgb' which takes a 3 member arrayref, containing each of the red,
 501 green and blue values.
 502
 503   # the same
 504   my $c1 = Imager::Color->new(rgb=>[255, 100, 0]);
 505   my $c1 = Imager::Color->new(r=>255, g=>100, b=>0);
 506
 507 =item *
 508
 509 'hsv' which takes a 3 member arrayref, containting each of hue,
 510 saturation and value.
 511
 512   # the same
 513   my $c1 = Imager::Color->new(hsv=>[120, 0.5, 1]);
 514   my $c1 = Imager::Color->new(hue=>120, v=>1, s=>0.5);
 515
 516 =item *
 517
 518 'gimp' which specifies a color from a GIMP palette file.  You can
 519 specify the filename of the palette file with the 'palette' parameter,
 520 or let Imager::Color look in various places, typically
 521 "$HOME/gimp-1.x/palettes/Named_Colors" with and without the version
 522 number, and in /usr/share/gimp/palettes/.  The palette file must have
 523 color names.
 524
 525   my $c1 = Imager::Color->new(gimp=>'snow');
 526   my $c1 = Imager::Color->new(gimp=>'snow', palette=>'testimg/test_gimp_pal);
 527
 528 =item *
 529
 530 'xname' which specifies a color from an X11 rgb.txt file.  You can
 531 specify the filename of the rgb.txt file with the 'palette' parameter,
 532 or let Imager::Color look in various places, typically
 533 '/usr/lib/X11/rgb.txt'.
 534
 535   my $c1 = Imager::Color->new(xname=>'blue') # usually RGB(0, 0, 255)
 536
 537 =item *
 538
 539 'builtin' which specifies a color from the built-in color table in
 540 Imager::Color::Table.  The colors in this module are the same as the
 541 default X11 rgb.txt file.
 542
 543   my $c1 = Imager::Color->new(builtin=>'black') # always RGB(0, 0, 0)
 544
 545 =item *
 546
 547 'name' which specifies a name from either a GIMP palette, an X rgb.txt
 548 file or the built-in color table, whichever is found first.
 549
 550 =item *
 551
 552 'channel0', 'channel1', etc, each of which specifies a single channel.  These can be abbreviated to 'c0', 'c1' etc.
 553
 554 =item *
 555
 556 'channels' which takes an arrayref of the channel values.
 557
 558 =back
 559
 560 Optionally you can add an alpha channel to a color with the 'alpha' or
 561 'a' parameter.
 562
 563 These color specifications can be used for both constructing new
 564 colors with the new() method and modifying existing colors with the
 565 set() method.
 566
 567 =head1 AUTHOR
 568
 569 Arnar M. Hrafnkelsson, addi@umich.edu
 570 And a great deal of help from others - see the README for a complete
 571 list.
 572
 573 =head1 SEE ALSO
 574
 575 Imager(3)
 576 http://imager.perl.org/
 577
 578 =cut