setcolors() and addcolors() can now accept non-object colors like most

other methods

diff --git a/Imager.pm b/Imager.pm
index 4b8081f0dd4c57e65b3aa63f63429985db45e93a..f6e0ab844476b1a9ff5d1f83fe15c2fc81aa3795 100644 (file)
--- a/Imager.pm
+++ b/Imager.pm
@@ -892,17 +892,46 @@ sub addcolors {
   my $self = shift;
   my %opts = (colors=>[], @_);
 
   my $self = shift;
   my %opts = (colors=>[], @_);
 

-  @{$opts{colors}} or return undef;
+  unless ($self->{IMG}) {
+    $self->_set_error("empty input image");
+    return;
+  }
+
+  my @colors = @{$opts{colors}}
+    or return undef;

 
 

-  $self->{IMG} and i_addcolors($self->{IMG}, @{$opts{colors}});
+  for my $color (@colors) {
+    $color = _color($color);
+    unless ($color) {
+      $self->_set_error($Imager::ERRSTR);
+      return;
+    }  
+  }
+
+  return i_addcolors($self->{IMG}, @colors);

 }
 
 sub setcolors {
   my $self = shift;
   my %opts = (start=>0, colors=>[], @_);
 }
 
 sub setcolors {
   my $self = shift;
   my %opts = (start=>0, colors=>[], @_);

-  @{$opts{colors}} or return undef;

 
 

-  $self->{IMG} and i_setcolors($self->{IMG}, $opts{start}, @{$opts{colors}});
+  unless ($self->{IMG}) {
+    $self->_set_error("empty input image");
+    return;
+  }
+
+  my @colors = @{$opts{colors}}
+    or return undef;
+
+  for my $color (@colors) {
+    $color = _color($color);
+    unless ($color) {
+      $self->_set_error($Imager::ERRSTR);
+      return;
+    }  
+  }
+
+  return i_setcolors($self->{IMG}, $opts{start}, @colors);

 }
 
 sub getcolors {
 }
 
 sub getcolors {

diff --git a/t/t023palette.t b/t/t023palette.t
index 6b081962bf20f53529093b11cef2465995c5f73b..a8e9610d940fa86ff995f69dfbd561b241f6ba39 100644 (file)
--- a/t/t023palette.t
+++ b/t/t023palette.t
@@ -2,7 +2,7 @@
 # some of this is tested in t01introvert.t too
 use strict;
 use lib 't';
 # some of this is tested in t01introvert.t too
 use strict;
 use lib 't';

-use Test::More tests => 64;
+use Test::More tests => 70;

 BEGIN { use_ok("Imager"); }
 
 my $img = Imager->new(xsize=>50, ysize=>50, type=>'paletted');
 BEGIN { use_ok("Imager"); }
 
 my $img = Imager->new(xsize=>50, ysize=>50, type=>'paletted');


@@ -211,6 +211,36 @@ cmp_ok(Imager->errstr, '=~', qr/Channels must be positive and <= 4/,
      "set after the last color");
 }
 
      "set after the last color");
 }
 

+{ # https://rt.cpan.org/Ticket/Display.html?id=20056
+  # added named color support to addcolor/setcolor
+  my $img = Imager->new(xsize => 10, ysize => 10, type => 'paletted');
+  is($img->addcolors(colors => [ qw/000000 FF0000/ ]), "0 but true",
+     "add colors as strings instead of objects");
+  my @colors = $img->getcolors;
+  iscolor($colors[0], $black, "check first color");
+  iscolor($colors[1], $red, "check second color");
+  ok($img->setcolors(colors => [ qw/00FF00 0000FF/ ]),
+     "setcolors as strings instead of objects");
+  @colors = $img->getcolors;
+  iscolor($colors[0], $green, "check first color");
+  iscolor($colors[1], $blue, "check second color");
+}
+
+sub iscolor {
+  my ($c1, $c2, $msg) = @_;
+
+  my $builder = Test::Builder->new;
+  my @c1 = $c1->rgba;
+  my @c2 = $c2->rgba;
+  if (!$builder->ok($c1[0] == $c2[0] && $c1[1] == $c2[1] && $c1[2] == $c2[2],
+                    $msg)) {
+    $builder->diag(<<DIAG);
+      got color: [ @c1 ]
+ expected color: [ @c2 ]
+DIAG
+  }
+}
+

 sub coloreq {
   my ($left, $right, $comment) = @_;
 
 sub coloreq {
   my ($left, $right, $comment) = @_;