[imager.git] / lib / Imager / Color.pm

package Imager::Color;

use Imager;
use strict;
use vars qw($VERSION);

$VERSION = "1.010";

# It's just a front end to the XS creation functions.

# used in converting hsv to rgb
my @hsv_map = 
  (
   'vkm', 'nvm', 'mvk', 'mnv', 'kmv', 'vmn'
  );

sub _hsv_to_rgb {
  my ($hue, $sat, $val) = @_;

  # HSV conversions from pages 401-403 "Procedural Elements for Computer 
  # Graphics", 1985, ISBN 0-07-053534-5.

  my @result;
  if ($sat <= 0) {
    return ( 255 * $val, 255 * $val, 255 * $val );
  }
  else {
    $val >= 0 or $val = 0;
    $val <= 1 or $val = 1;
    $sat <= 1 or $sat = 1;
    $hue >= 360 and $hue %= 360;
    $hue < 0 and $hue += 360;
    $hue /= 60.0;
    my $i = int($hue);
    my $f = $hue - $i;
    $val *= 255;
    my $m = $val * (1.0 - $sat);
    my $n = $val * (1.0 - $sat * $f);
    my $k = $val * (1.0 - $sat * (1 - $f));
    my $v = $val;
    my %fields = ( 'm'=>$m, 'n'=>$n, 'v'=>$v, 'k'=>$k, );
    return @fields{split //, $hsv_map[$i]};
  }
}

# cache of loaded gimp files
# each key is a filename, under each key is a hashref with the following
# keys:
#   mod_time => last mod_time of file
#   colors => hashref name to arrayref of colors
my %gimp_cache;

# palette search locations
# this is pretty rude
# $HOME is replaced at runtime
my @gimp_search =
  (
   '$HOME/.gimp-1.2/palettes/Named_Colors',
   '$HOME/.gimp-1.1/palettes/Named_Colors',
   '$HOME/.gimp/palettes/Named_Colors',
   '/usr/share/gimp/1.2/palettes/Named_Colors',
   '/usr/share/gimp/1.1/palettes/Named_Colors',
   '/usr/share/gimp/palettes/Named_Colors',
  );

sub _load_gimp_palette {
  my ($filename) = @_;

  if (open PAL, "< $filename") {
    my $hdr = <PAL>;
    chomp $hdr;
    unless ($hdr =~ /GIMP Palette/) {
      close PAL;
      $Imager::ERRSTR = "$filename is not a GIMP palette file";
      return;
    }
    my $line;
    my %pal;
    my $mod_time = (stat PAL)[9];
    while (defined($line = <PAL>)) {
      next if $line =~ /^#/ || $line =~ /^\s*$/;
      chomp $line;
      my ($r,$g, $b, $name) = split ' ', $line, 4;
      if ($name) {
        $name =~ s/\s*\([\d\s]+\)\s*$//;
        $pal{lc $name} = [ $r, $g, $b ];
      }
    }
    close PAL;

    $gimp_cache{$filename} = { mod_time=>$mod_time, colors=>\%pal };

    return 1;
  }
  else {
    $Imager::ERRSTR = "Cannot open palette file $filename: $!";
    return;
  }
}

sub _get_gimp_color {
  my %args = @_;

  my $filename;
  if ($args{palette}) {
    $filename = $args{palette};
  }
  else {
    # try to make one up - this is intended to die if tainting is
    # enabled and $ENV{HOME} is tainted.  To avoid that untaint $ENV{HOME}
    # or set the palette parameter
    for my $attempt (@gimp_search) {
      my $work = $attempt; # don't modify the source array
      $work =~ /\$HOME/ && !defined $ENV{HOME}
	and next;
      $work =~ s/\$HOME/$ENV{HOME}/;
      if (-e $work) {
        $filename = $work;
        last;
      }
    }
    if (!$filename) {
      $Imager::ERRSTR = "No GIMP palette found";
      return ();
    }
  }

  if ((!$gimp_cache{$filename} 
      || (stat $filename)[9] != $gimp_cache{$filename})
     && !_load_gimp_palette($filename)) {
    return ();
  }

  if (!$gimp_cache{$filename}{colors}{lc $args{name}}) {
    $Imager::ERRSTR = "Color '$args{name}' isn't in $filename";
    return ();
  }

  return @{$gimp_cache{$filename}{colors}{lc $args{name}}};
}

my @x_search = 
  (
   '/usr/share/X11/rgb.txt', # newer Xorg X11 dists use this
   '/usr/lib/X11/rgb.txt', # seems fairly standard
   '/usr/local/lib/X11/rgb.txt', # seems possible
   '/usr/X11R6/lib/X11/rgb.txt', # probably the same as the first
   '/usr/openwin/lib/rgb.txt',
   '/usr/openwin/lib/X11/rgb.txt',
  );

# called by the test code to check if we can test this stuff
sub _test_x_palettes {
  @x_search;
}

# x rgb.txt cache
# same structure as %gimp_cache
my %x_cache;

sub _load_x_rgb {
  my ($filename) = @_;

  local *RGB;
  if (open RGB, "< $filename") {
    my $line;
    my %pal;
    my $mod_time = (stat RGB)[9];
    while (defined($line = <RGB>)) {
      # the version of rgb.txt supplied with GNU Emacs uses # for comments
      next if $line =~ /^[!#]/ || $line =~ /^\s*$/;
      chomp $line;
      my ($r,$g, $b, $name) = split ' ', $line, 4;
      if ($name) {
        $pal{lc $name} = [ $r, $g, $b ];
      }
    }
    close RGB;

    $x_cache{$filename} = { mod_time=>$mod_time, colors=>\%pal };

    return 1;
  }
  else {
    $Imager::ERRSTR = "Cannot open palette file $filename: $!";
    return;
  }
}

sub _get_x_color {
  my %args = @_;

  my $filename;
  if ($args{palette}) {
    $filename = $args{palette};
  }
  else {
    for my $attempt (@x_search) {
      if (-e $attempt) {
        $filename = $attempt;
        last;
      }
    }
    if (!$filename) {
      $Imager::ERRSTR = "No X rgb.txt palette found";
      return ();
    }
  }

  if ((!$x_cache{$filename} 
      || (stat $filename)[9] != $x_cache{$filename})
     && !_load_x_rgb($filename)) {
    return ();
  }

  if (!$x_cache{$filename}{colors}{lc $args{name}}) {
    $Imager::ERRSTR = "Color '$args{name}' isn't in $filename";
    return ();
  }

  return @{$x_cache{$filename}{colors}{lc $args{name}}};
}

# Parse color spec into an a set of 4 colors

sub _pspec {
  return (@_,255) if @_ == 3 && !grep /[^\d.+eE-]/, @_;
  return (@_    ) if @_ == 4 && !grep /[^\d.+eE-]/, @_;
  if ($_[0] =~ 
      /^\#?([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])/i) {
    return (hex($1),hex($2),hex($3),hex($4));
  }
  if ($_[0] =~ /^\#?([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])/i) {
    return (hex($1),hex($2),hex($3),255);
  }
  if ($_[0] =~ /^\#([\da-f])([\da-f])([\da-f])$/i) {
    return (hex($1) * 17, hex($2) * 17, hex($3) * 17, 255);
  }
  my %args;
  if (@_ == 1) {
    # a named color
    %args = ( name => @_ );
  }
  else {
    %args = @_;
  }
  my @result;
  if (exists $args{gray}) {
    @result = $args{gray};
  }
  elsif (exists $args{grey}) {
    @result = $args{grey};
  }
  elsif ((exists $args{red} || exists $args{r}) 
         && (exists $args{green} || exists $args{g})
         && (exists $args{blue} || exists $args{b})) {
    @result = ( exists $args{red} ? $args{red} : $args{r},
                exists $args{green} ? $args{green} : $args{g},
                exists $args{blue} ? $args{blue} : $args{b} );
  }
  elsif ((exists $args{hue} || exists $args{h}) 
         && (exists $args{saturation} || exists $args{'s'})
         && (exists $args{value} || exists $args{v})) {
    my $hue = exists $args{hue}        ? $args{hue}        : $args{h};
    my $sat = exists $args{saturation} ? $args{saturation} : $args{'s'};
    my $val = exists $args{value}      ? $args{value}      : $args{v};

    @result = _hsv_to_rgb($hue, $sat, $val);
  }
  elsif (exists $args{web}) {
    if ($args{web} =~ /^#?([\da-f][\da-f])([\da-f][\da-f])([\da-f][\da-f])$/i) {
      @result = (hex($1),hex($2),hex($3));
    }
    elsif ($args{web} =~ /^#?([\da-f])([\da-f])([\da-f])$/i) {
      @result = (hex($1) * 17, hex($2) * 17, hex($3) * 17);
    }
  }
  elsif ($args{name}) {
    unless (@result = _get_gimp_color(%args)) {
      unless (@result = _get_x_color(%args)) {
        require Imager::Color::Table;
        unless (@result = Imager::Color::Table->get($args{name})) {
          $Imager::ERRSTR = "No color named $args{name} found";
          return ();
        }
      }
    }
  }
  elsif ($args{gimp}) {
    @result = _get_gimp_color(name=>$args{gimp}, %args);
  }
  elsif ($args{xname}) {
    @result = _get_x_color(name=>$args{xname}, %args);
  }
  elsif ($args{builtin}) {
    require Imager::Color::Table;
    @result = Imager::Color::Table->get($args{builtin});
  }
  elsif ($args{rgb}) {
    @result = @{$args{rgb}};
  }
  elsif ($args{rgba}) {
    @result = @{$args{rgba}};
    return @result if @result == 4;
  }
  elsif ($args{hsv}) {
    @result = _hsv_to_rgb(@{$args{hsv}});
  }
  elsif ($args{channels}) {
    return @{$args{channels}};
  }
  elsif (exists $args{channel0} || $args{c0}) {
    my $i = 0;
    while (exists $args{"channel$i"} || exists $args{"c$i"}) {
      push(@result, 
           exists $args{"channel$i"} ? $args{"channel$i"} : $args{"c$i"});
      ++$i;
    }
  }
  else {
    $Imager::ERRSTR = "No color specification found";
    return ();
  }
  if (@result) {
    if (exists $args{alpha} || exists $args{a}) {
      push(@result, exists $args{alpha} ? $args{alpha} : $args{a});
    }
    while (@result < 4) {
      push(@result, 255);
    }
    return @result;
  }
  return ();
}

sub new {
  shift; # get rid of class name.
  my @arg = _pspec(@_);
  return @arg ? new_internal($arg[0],$arg[1],$arg[2],$arg[3]) : ();
}

sub set {
  my $self = shift;
  my @arg = _pspec(@_);
  return @arg ? set_internal($self, $arg[0],$arg[1],$arg[2],$arg[3]) : ();
}

sub equals {
  my ($self, %opts) = @_;

  my $other = $opts{other}
    or return Imager->_set_error("'other' parameter required");
  my $ignore_alpha = $opts{ignore_alpha} || 0;

  my @left = $self->rgba;
  my @right = $other->rgba;
  my $last_chan = $ignore_alpha ? 2 : 3;
  for my $ch (0 .. $last_chan) {
    $left[$ch] == $right[$ch]
      or return;
  }
  
  return 1;
}

sub CLONE_SKIP { 1 }

1;

__END__

=head1 NAME

Imager::Color - Color handling for Imager.

=head1 SYNOPSIS

  use Imager;

  $color = Imager::Color->new($red, $green, $blue);
  $color = Imager::Color->new($red, $green, $blue, $alpha);
  $color = Imager::Color->new("#C0C0FF"); # html color specification

  $color->set($red, $green, $blue);
  $color->set($red, $green, $blue, $alpha);
  $color->set("#C0C0FF"); # html color specification

  ($red, $green, $blue, $alpha) = $color->rgba();
  @hsv = $color->hsv(); # not implemented but proposed

  $color->info();

  if ($color->equals(other=>$other_color)) { 
    ...
  }


=head1 DESCRIPTION

This module handles creating color objects used by imager.  The idea is
that in the future this module will be able to handle colorspace calculations
as well.

An Imager color consists of up to four components, each in the range 0
to 255. Unfortunately the meaning of the components can change
depending on the type of image you're dealing with:

=over

=item *

for 3 or 4 channel images the color components are red, green, blue,
alpha.

=item *

for 1 or 2 channel images the color components are gray, alpha, with
the other two components ignored.

=back

An alpha value of zero is fully transparent, an alpha value of 255 is
fully opaque.

=head1 METHODS

=over 4

=item new

This creates a color object to pass to functions that need a color argument.

=item set

This changes an already defined color.  Note that this does not affect any places
where the color has been used previously.

=item rgba

This returns the rgba code of the color the object contains.

=item info

Calling info merely dumps the relevant colorcode to the log.

=item equals(other=>$other_color)

=item equals(other=>$other_color, ignore_alpha=>1)

Compares $self and color $other_color returning true if the color
components are the same.

Compares all four channels unless C<ignore_alpha> is set.  If
C<ignore_alpha> is set only the first three channels are compared.

=back

You can specify colors in several different ways, you can just supply
simple values:

=over

=item *

simple numeric parameters - if you supply 3 or 4 numeric arguments, you get a color made up of those RGB (and possibly A) components.

=item *

a six hex digit web color, either 'RRGGBB' or '#RRGGBB'

=item *

an eight hex digit web color, either 'RRGGBBAA' or '#RRGGBBAA'.

=item *

a 3 hex digit web color, '#RGB' - a value of F becomes 255.

=item *

a color name, from whichever of the gimp Named_Colors file or X
rgb.txt is found first.  The same as using the name keyword.

=back

You can supply named parameters:

=over

=item *

'red', 'green' and 'blue', optionally shortened to 'r', 'g' and 'b'.
The color components in the range 0 to 255.

 # all of the following are equivalent
 my $c1 = Imager::Color->new(red=>100, blue=>255, green=>0);
 my $c2 = Imager::Color->new(r=>100, b=>255, g=>0);
 my $c3 = Imager::Color->new(r=>100, blue=>255, g=>0);

=item *

'hue', 'saturation' and 'value', optionally shortened to 'h', 's' and
'v', to specify a HSV color.  0 <= hue < 360, 0 <= s <= 1 and 0 <= v
<= 1.

  # the same as RGB(127,255,127)
  my $c1 = Imager::Color->new(hue=>120, v=>1, s=>0.5);
  my $c1 = Imager::Color->new(hue=>120, value=>1, saturation=>0.5);

=item *

'web', which can specify a 6 or 3 hex digit web color, in any of the
forms '#RRGGBB', '#RGB', 'RRGGBB' or 'RGB'.

  my $c1 = Imager::Color->new(web=>'#FFC0C0'); # pale red

=item *

'gray' or 'grey' which specifies a single channel, from 0 to 255.

  # exactly the same
  my $c1 = Imager::Color->new(gray=>128);
  my $c1 = Imager::Color->new(grey=>128);

=item *

'rgb' which takes a 3 member arrayref, containing each of the red,
green and blue values.

  # the same
  my $c1 = Imager::Color->new(rgb=>[255, 100, 0]);
  my $c1 = Imager::Color->new(r=>255, g=>100, b=>0);

=item *

'hsv' which takes a 3 member arrayref, containting each of hue,
saturation and value.

  # the same
  my $c1 = Imager::Color->new(hsv=>[120, 0.5, 1]);
  my $c1 = Imager::Color->new(hue=>120, v=>1, s=>0.5);

=item *

'gimp' which specifies a color from a GIMP palette file.  You can
specify the filename of the palette file with the 'palette' parameter,
or let Imager::Color look in various places, typically
"$HOME/gimp-1.x/palettes/Named_Colors" with and without the version
number, and in /usr/share/gimp/palettes/.  The palette file must have
color names.

  my $c1 = Imager::Color->new(gimp=>'snow');
  my $c1 = Imager::Color->new(gimp=>'snow', palette=>'testimg/test_gimp_pal);

=item *

'xname' which specifies a color from an X11 rgb.txt file.  You can
specify the filename of the rgb.txt file with the 'palette' parameter,
or let Imager::Color look in various places, typically
'/usr/lib/X11/rgb.txt'.

  my $c1 = Imager::Color->new(xname=>'blue') # usually RGB(0, 0, 255)

=item *

'builtin' which specifies a color from the built-in color table in
Imager::Color::Table.  The colors in this module are the same as the
default X11 rgb.txt file.

  my $c1 = Imager::Color->new(builtin=>'black') # always RGB(0, 0, 0)

=item *

'name' which specifies a name from either a GIMP palette, an X rgb.txt
file or the built-in color table, whichever is found first.

=item *

'channel0', 'channel1', etc, each of which specifies a single channel.  These can be abbreviated to 'c0', 'c1' etc.

=item * 

'channels' which takes an arrayref of the channel values.

=back

Optionally you can add an alpha channel to a color with the 'alpha' or
'a' parameter.

These color specifications can be used for both constructing new
colors with the new() method and modifying existing colors with the
set() method.

=head1 AUTHOR

Arnar M. Hrafnkelsson, addi@umich.edu
And a great deal of help from others - see the README for a complete
list.

=head1 SEE ALSO

Imager(3), Imager::Color
http://imager.perl.org/

=cut
Commit	Line	Data
02d1d628 AMH	1	package Imager::Color;
	2
	3	use Imager;
	4	use strict;
f17b46d8 TC	5	use vars qw($VERSION);
f17b46d8 TC	6
4e33b785	7	$VERSION = "1.010";
02d1d628 AMH	8
	9	# It's just a front end to the XS creation functions.
	10
faa9b3e7 TC	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;
9d540150	41	my %fields = ( 'm'=>$m, 'n'=>$n, 'v'=>$v, 'k'=>$k, );
faa9b3e7 TC	42	return @fields{split //, $hsv_map[$i]};
	43	}
	44	}
	45
	46	# cache of loaded gimp files
08af8ecb	47	# each key is a filename, under each key is a hashref with the following
faa9b3e7 TC	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
3d782fde TC	114	$work =~ /\$HOME/ && !defined $ENV{HOME}
3d782fde TC	115	and next;
faa9b3e7 TC	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	(
d034a178	144	'/usr/share/X11/rgb.txt', # newer Xorg X11 dists use this
faa9b3e7 TC	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
08af8ecb AMH	148	'/usr/openwin/lib/rgb.txt',
08af8ecb AMH	149	'/usr/openwin/lib/X11/rgb.txt',
faa9b3e7 TC	150	);
faa9b3e7 TC	151
d034a178 TC	152	# called by the test code to check if we can test this stuff
	153	sub _test_x_palettes {
	154	@x_search;
	155	}
	156
faa9b3e7 TC	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	}
02d1d628 AMH	223
	224	# Parse color spec into an a set of 4 colors
	225
d5556805	226	sub _pspec {
faa9b3e7 TC	227	return (@_,255) if @_ == 3 && !grep /[^\d.+eE-]/, @_;
faa9b3e7 TC	228	return (@_ ) if @_ == 4 && !grep /[^\d.+eE-]/, @_;
02d1d628 AMH	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	}
faa9b3e7 TC	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};
08af8ecb	267
faa9b3e7 TC	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)) {
1c00d65b TC	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	}
faa9b3e7 TC	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	}
1c00d65b TC	295	elsif ($args{builtin}) {
	296	require Imager::Color::Table;
	297	@result = Imager::Color::Table->get($args{builtin});
	298	}
faa9b3e7 TC	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	}
02d1d628 AMH	333	return ();
	334	}
	335
02d1d628 AMH	336	sub new {
02d1d628 AMH	337	shift; # get rid of class name.
d5556805	338	my @arg = _pspec(@_);
02d1d628 AMH	339	return @arg ? new_internal($arg[0],$arg[1],$arg[2],$arg[3]) : ();
	340	}
	341
	342	sub set {
	343	my $self = shift;
d5556805	344	my @arg = _pspec(@_);
02d1d628 AMH	345	return @arg ? set_internal($self, $arg[0],$arg[1],$arg[2],$arg[3]) : ();
	346	}
	347
5f8cbeac TC	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
ffddd407 TC	366	sub CLONE_SKIP { 1 }
ffddd407 TC	367
02d1d628 AMH	368	1;
	369
	370	__END__
	371
	372	=head1 NAME
	373
	374	Imager::Color - Color handling for Imager.
	375
	376	=head1 SYNOPSIS
	377
668c4f62 TC	378	use Imager;
668c4f62 TC	379
02d1d628 AMH	380	$color = Imager::Color->new($red, $green, $blue);
	381	$color = Imager::Color->new($red, $green, $blue, $alpha);
	382	$color = Imager::Color->new("#C0C0FF"); # html color specification
	383
	384	$color->set($red, $green, $blue);
	385	$color->set($red, $green, $blue, $alpha);
	386	$color->set("#C0C0FF"); # html color specification
	387
	388	($red, $green, $blue, $alpha) = $color->rgba();
	389	@hsv = $color->hsv(); # not implemented but proposed
	390
	391	$color->info();
	392
5f8cbeac TC	393	if ($color->equals(other=>$other_color)) {
	394	...
	395	}
	396
02d1d628 AMH	397
	398	=head1 DESCRIPTION
	399
	400	This module handles creating color objects used by imager. The idea is
	401	that in the future this module will be able to handle colorspace calculations
	402	as well.
	403
0462442b TC	404	An Imager color consists of up to four components, each in the range 0
	405	to 255. Unfortunately the meaning of the components can change
	406	depending on the type of image you're dealing with:
	407
	408	=over
	409
	410	=item *
	411
	412	for 3 or 4 channel images the color components are red, green, blue,
	413	alpha.
	414
	415	=item *
	416
	417	for 1 or 2 channel images the color components are gray, alpha, with
	418	the other two components ignored.
	419
	420	=back
	421
	422	An alpha value of zero is fully transparent, an alpha value of 255 is
	423	fully opaque.
	424
42f8a929	425	=head1 METHODS
0462442b	426
02d1d628 AMH	427	=over 4
	428
	429	=item new
	430
	431	This creates a color object to pass to functions that need a color argument.
	432
	433	=item set
	434
	435	This changes an already defined color. Note that this does not affect any places
	436	where the color has been used previously.
	437
	438	=item rgba
	439
	440	This returns the rgba code of the color the object contains.
	441
	442	=item info
	443
	444	Calling info merely dumps the relevant colorcode to the log.
	445
5f8cbeac TC	446	=item equals(other=>$other_color)
	447
	448	=item equals(other=>$other_color, ignore_alpha=>1)
	449
	450	Compares $self and color $other_color returning true if the color
	451	components are the same.
	452
	453	Compares all four channels unless C<ignore_alpha> is set. If
	454	C<ignore_alpha> is set only the first three channels are compared.
	455
02d1d628 AMH	456	=back
02d1d628 AMH	457
faa9b3e7 TC	458	You can specify colors in several different ways, you can just supply
	459	simple values:
	460
	461	=over
	462
	463	=item *
	464
	465	simple numeric parameters - if you supply 3 or 4 numeric arguments, you get a color made up of those RGB (and possibly A) components.
	466
	467	=item *
	468
	469	a six hex digit web color, either 'RRGGBB' or '#RRGGBB'
	470
	471	=item *
	472
	473	an eight hex digit web color, either 'RRGGBBAA' or '#RRGGBBAA'.
	474
	475	=item *
	476
	477	a 3 hex digit web color, '#RGB' - a value of F becomes 255.
	478
	479	=item *
	480
	481	a color name, from whichever of the gimp Named_Colors file or X
	482	rgb.txt is found first. The same as using the name keyword.
	483
	484	=back
	485
	486	You can supply named parameters:
	487
	488	=over
	489
	490	=item *
	491
	492	'red', 'green' and 'blue', optionally shortened to 'r', 'g' and 'b'.
	493	The color components in the range 0 to 255.
	494
	495	# all of the following are equivalent
	496	my $c1 = Imager::Color->new(red=>100, blue=>255, green=>0);
	497	my $c2 = Imager::Color->new(r=>100, b=>255, g=>0);
	498	my $c3 = Imager::Color->new(r=>100, blue=>255, g=>0);
	499
	500	=item *
	501
	502	'hue', 'saturation' and 'value', optionally shortened to 'h', 's' and
	503	'v', to specify a HSV color. 0 <= hue < 360, 0 <= s <= 1 and 0 <= v
	504	<= 1.
	505
	506	# the same as RGB(127,255,127)
	507	my $c1 = Imager::Color->new(hue=>120, v=>1, s=>0.5);
	508	my $c1 = Imager::Color->new(hue=>120, value=>1, saturation=>0.5);
	509
	510	=item *
	511
	512	'web', which can specify a 6 or 3 hex digit web color, in any of the
	513	forms '#RRGGBB', '#RGB', 'RRGGBB' or 'RGB'.
	514
	515	my $c1 = Imager::Color->new(web=>'#FFC0C0'); # pale red
	516
	517	=item *
	518
	519	'gray' or 'grey' which specifies a single channel, from 0 to 255.
	520
	521	# exactly the same
522	my $c1 = Imager::Color->new(gray=>128);
523	my $c1 = Imager::Color->new(grey=>128);
524
525	=item *
526
527	'rgb' which takes a 3 member arrayref, containing each of the red,
528	green and blue values.
529
530	# the same
531	my $c1 = Imager::Color->new(rgb=>[255, 100, 0]);
532	my $c1 = Imager::Color->new(r=>255, g=>100, b=>0);
533
534	=item *
535
536	'hsv' which takes a 3 member arrayref, containting each of hue,
537	saturation and value.
538
539	# the same
540	my $c1 = Imager::Color->new(hsv=>[120, 0.5, 1]);
541	my $c1 = Imager::Color->new(hue=>120, v=>1, s=>0.5);
542
543	=item *
544
545	'gimp' which specifies a color from a GIMP palette file. You can
546	specify the filename of the palette file with the 'palette' parameter,
547	or let Imager::Color look in various places, typically
548	"$HOME/gimp-1.x/palettes/Named_Colors" with and without the version
549	number, and in /usr/share/gimp/palettes/. The palette file must have
550	color names.
551
552	my $c1 = Imager::Color->new(gimp=>'snow');
553	my $c1 = Imager::Color->new(gimp=>'snow', palette=>'testimg/test_gimp_pal);
554
555	=item *
556
557	'xname' which specifies a color from an X11 rgb.txt file. You can
558	specify the filename of the rgb.txt file with the 'palette' parameter,
559	or let Imager::Color look in various places, typically
560	'/usr/lib/X11/rgb.txt'.
561
562	my $c1 = Imager::Color->new(xname=>'blue') # usually RGB(0, 0, 255)
563
564	=item *
565
1c00d65b TC	566	'builtin' which specifies a color from the built-in color table in
	567	Imager::Color::Table. The colors in this module are the same as the
	568	default X11 rgb.txt file.
	569
	570	my $c1 = Imager::Color->new(builtin=>'black') # always RGB(0, 0, 0)
	571
	572	=item *
	573
	574	'name' which specifies a name from either a GIMP palette, an X rgb.txt
	575	file or the built-in color table, whichever is found first.
faa9b3e7 TC	576
	577	=item *
	578
	579	'channel0', 'channel1', etc, each of which specifies a single channel. These can be abbreviated to 'c0', 'c1' etc.
	580
	581	=item *
	582
	583	'channels' which takes an arrayref of the channel values.
	584
	585	=back
	586
	587	Optionally you can add an alpha channel to a color with the 'alpha' or
	588	'a' parameter.
	589
	590	These color specifications can be used for both constructing new
	591	colors with the new() method and modifying existing colors with the
	592	set() method.
	593
02d1d628 AMH	594	=head1 AUTHOR
	595
	596	Arnar M. Hrafnkelsson, addi@umich.edu
	597	And a great deal of help from others - see the README for a complete
	598	list.
	599
	600	=head1 SEE ALSO
	601
0462442b	602	Imager(3), Imager::Color
8f22b8d8	603	http://imager.perl.org/
02d1d628 AMH	604
02d1d628 AMH	605	=cut