File Coverage

/root/.cpan/build/Imager-1.019-0/blib/lib/Imager/Color.pm

Criterion	Covered	Total	%
statement	201	251	80.0
branch	138	180	76.6
condition	45	74	60.8
subroutine	18	21	85.7
pod	6	6	100.0
total	408	532	76.6

package Imager::Color;
use 5.006;
use Imager;
use strict;
use Scalar::Util ();
use POSIX ();

our $VERSION = "1.015";

# 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',
  );

my $default_gimp_palette;

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

  if (open PAL, "< $filename") {
    my $hdr = ;
    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 = )) {
      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};
  }
  elsif (defined $default_gimp_palette) {
    # don't search again and again and again ...
    if (!length $default_gimp_palette
	|| !-f $default_gimp_palette) {
      $Imager::ERRSTR = "No GIMP palette found";
      $default_gimp_palette = "";
      return;
    }

    $filename = $default_gimp_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";
      $default_gimp_palette = "";
      return ();
    }

    $default_gimp_palette = $filename;
  }

  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',
  );

my $default_x_rgb;

# 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 = )) {
      # 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};
  }
  elsif (defined $default_x_rgb) {
    unless (length $default_x_rgb) {
      $Imager::ERRSTR = "No X rgb.txt palette found";
      return ();
    }
    $filename = $default_x_rgb;
  }
  else {
    for my $attempt (@x_search) {
      if (-e $attempt) {
        $filename = $attempt;
        last;
      }
    }
    if (!$filename) {
      $Imager::ERRSTR = "No X rgb.txt palette found";
      $default_x_rgb = "";
      return ();
    }
  }

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

  $default_x_rgb = $filename;

  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}}};
}

sub _pc_to_byte {
  POSIX::ceil($_[0] * 255 / 100);
}

sub _rgb_alpha {
  my ($alpha) = @_;
  if ($alpha =~ /^(.*)%\z/) {
    return POSIX::ceil($1 * 255 / 100);
  }
  else {
    return POSIX::ceil($alpha * 255);
  }
}

my $rgb_key = qr/rgba?/;
my $rgb_samp = qr/(\d+(?:\.\d*)?)/;
my $rgb_pc = qr/(\d+(?:\.\d*)?)%/;
my $rgb_sep = qr/ *[, ] */;
my $rgb_rgb = qr/$rgb_samp $rgb_sep $rgb_samp $rgb_sep $rgb_samp/x;
my $rgb_rgb_pc = qr/$rgb_pc $rgb_sep $rgb_pc $rgb_sep $rgb_pc/x;
my $rgb_alpha_sep = qr/ *[\/,] */;
my $rgb_alpha = qr/((?:\.\d+|\d+(?:\.\d*)?)%?)/;

# Parse color spec into an a set of 4 colors

sub _pspec {
  if (@_ == 1 && Scalar::Util::blessed($_[0])) {
    if ($_[0]->isa("Imager::Color")) {
      return $_[0]->rgba;
    } elsif ($_[0]->isa("Imager::Color::Float")) {
      return $_[0]->as_8bit->rgba;
    }
  }
  if (@_ == 1) {
    # CSS Color 4 says that color values are rounded to +Inf
    if ($_[0] =~ /\A$rgb_key\( *$rgb_rgb *\)\z/) {
      return ( POSIX::ceil($1), POSIX::ceil($2), POSIX::ceil($3), 255 );
    }
    elsif ($_[0] =~ /\A$rgb_key\( *$rgb_rgb_pc *\)\z/) {
      return ( _pc_to_byte($1), _pc_to_byte($2), _pc_to_byte($3), 255 );
    }
    elsif ($_[0] =~ /\A$rgb_key\( *$rgb_rgb$rgb_alpha_sep$rgb_alpha *\)\z/) {
      return ( POSIX::ceil($1), POSIX::ceil($2), POSIX::ceil($3), _rgb_alpha($4) );
    }
    elsif ($_[0] =~ /\A$rgb_key\( *$rgb_rgb_pc$rgb_alpha_sep$rgb_alpha *\)\z/) {
      return ( _pc_to_byte($1), _pc_to_byte($2), _pc_to_byte($3), _rgb_alpha($4) );
    }
  }

  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}) {
    my @ch = @{$args{channels}};
    return ( @ch, (0) x (4 - @ch) );
  }
  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 }

# Lifted from Graphics::Color::RGB
# Thank you very much
sub hsv {
    my( $self ) = @_;

    my( $red, $green, $blue, $alpha ) = $self->rgba;
    my $max = $red;
    my $maxc = 'r';
    my $min = $red;

    if($green > $max) {
        $max = $green;
        $maxc = 'g';
    }
    if($blue > $max) {
        $max = $blue;
        $maxc = 'b';
    }

    if($green < $min) {
        $min = $green;
    }
    if($blue < $min) {
        $min = $blue;
    }

    my ($h, $s, $v);

    if($max == $min) {
        $h = 0;
    }
    elsif($maxc eq 'r') {
        $h = 60 * (($green - $blue) / ($max - $min)) % 360;
    }
    elsif($maxc eq 'g') {
        $h = (60 * (($blue - $red) / ($max - $min)) + 120);
    }
    elsif($maxc eq 'b') {
        $h = (60 * (($red - $green) / ($max - $min)) + 240);
    }

    $v = $max/255;
    if($max == 0) {
        $s = 0;
    }
    else {
        $s = 1 - ($min / $max);
    }

    return int($h), $s, $v, $alpha;
}

sub as_float {
  my ($self) = @_;

  return Imager::Color::Float->new(map { $_ / 255 } $self->rgba);
}

sub as_css_rgb {
  my ($self) = @_;

  my ($r, $g, $b, $alpha) = $self->rgba;

  if ($alpha == 255) {
    return "rgb($r, $g, $b)";
  }
  else {
    my $ac = POSIX::floor($alpha * 1000 / 255) / 10;
    if (POSIX::ceil(POSIX::floor($ac/10) * 10 * 255 / 100) == $alpha) {
      # simple one decimal fraction
      $ac = POSIX::floor($ac/10)/10;
    }
    elsif (POSIX::ceil(POSIX::floor($ac) * 255 / 100) == $alpha) {
      $ac = POSIX::floor($ac) . "%";
    }
    else {
      $ac = "$ac%";
    }
    return "rgba($r, $g, $b, $ac)";
  }
}

1;

__END__