- the image resulting from a crop is now the same type as the

          source image (paletted vs direct, bits/sample)
          Resolves https://rt.cpan.org/Ticket/Display.html?id=7578

diff --git a/Changes b/Changes
index 9f5b868d565c035e76c92bdacd86a4aa8625bc43..dd8af93395f44b9799dd77018ecde6a0c8b439dc 100644 (file)
--- a/Changes
+++ b/Changes
@@ -830,6 +830,9 @@ Revision history for Perl extension Imager.
         - corrected "flood fill" to "flood_fill" in Imager/Draw.pod
         - removed compose() method from Imager/Transformations.pod since
           it isn't implemented yet
+        - the image resulting from a crop is now the same type as the
+          source image (paletted vs direct, bits/sample)
+          Resolves https://rt.cpan.org/Ticket/Display.html?id=7578
 
 =================================================================
 

diff --git a/Imager.pm b/Imager.pm
index 407b5c3cd6ee9cf9edfae6849e71be6c1336efaf..d8df816ab423609ef050f1bee86c7d7c1afae890 100644 (file)
--- a/Imager.pm
+++ b/Imager.pm
@@ -607,12 +607,36 @@ sub crop {
 #    print "l=$l, r=$r, h=$hsh{'width'}\n";
 #    print "t=$t, b=$b, w=$hsh{'height'}\n";
 
-  my $dst=Imager->new(xsize=>$hsh{'width'}, ysize=>$hsh{'height'}, channels=>$self->getchannels());
+  my $dst = $self->_sametype(xsize=>$hsh{width}, ysize=>$hsh{height});
 
   i_copyto($dst->{IMG},$self->{IMG},$l,$t,$r,$b,0,0);
   return $dst;
 }
 
+sub _sametype {
+  my ($self, %opts) = @_;
+
+  $self->{IMG} or return $self->_set_error("Not a valid image");
+
+  my $x = $opts{xsize} || $self->getwidth;
+  my $y = $opts{ysize} || $self->getheight;
+  my $channels = $opts{channels} || $self->getchannels;
+  
+  my $out = Imager->new;
+  if ($channels == $self->getchannels) {
+    $out->{IMG} = i_sametype($self->{IMG}, $x, $y);
+  }
+  else {
+    $out->{IMG} = i_sametype_chans($self->{IMG}, $x, $y, $channels);
+  }
+  unless ($out->{IMG}) {
+    $self->{ERRSTR} = $self->_error_as_msg;
+    return;
+  }
+  
+  return $out;
+}
+
 # Sets an image to a certain size and channel number
 # if there was previously data in the image it is discarded
 

diff --git a/Imager.xs b/Imager.xs
index 8a36fcae2845b22fd1f4e3f4315d66c85114cd40..2fad7b08796c5928ac0805222ce531e68ce64c67 100644 (file)
--- a/Imager.xs
+++ b/Imager.xs
@@ -1178,6 +1178,19 @@ i_img_empty_ch(im,x,y,ch)
               int     y
               int     ch
 
+Imager::ImgRaw
+i_sametype(im, x, y)
+    Imager::ImgRaw im
+               int x
+               int y
+
+Imager::ImgRaw
+i_sametype_chans(im, x, y, channels)
+    Imager::ImgRaw im
+               int x
+               int y
+               int channels
+
 void
 m_init_log(name,level)
              char*    name

diff --git a/t/t65crop.t b/t/t65crop.t
index fe0e91d8a89a9aff7c7e71703abff1741f1ed822..40d32c1a3f842a4fb1935703427c38d36ed561a5 100644 (file)
--- a/t/t65crop.t
+++ b/t/t65crop.t
@@ -1,33 +1,42 @@
-BEGIN { $| = 1; print "1..3\n"; }
-END {print "not ok 1\n" unless $loaded;}
+#!perl -w
+use strict;
+require "t/testtools.pl";
 use Imager;
 
-$loaded = 1;
+print "1..10\n";
 
 #$Imager::DEBUG=1;
 
 Imager::init('log'=>'testout/t65crop.log');
 
-$img=Imager->new() || die "unable to create image object\n";
+my $img=Imager->new() || die "unable to create image object\n";
 
-print "ok 1\n";
+okx($img, "created image ph");
 
-$img->open(file=>'testimg/scale.ppm',type=>'pnm');
-
-sub skip { 
-    print $_[0];
-    print "ok 2 # skip\n";
-    print "ok 3 # skip\n";
-    exit(0);
+if (okx($img->open(file=>'testimg/scale.ppm',type=>'pnm'), "loaded source")) {
+  my $nimg = $img->crop(top=>10, left=>10, bottom=>25, right=>25);
+  okx($nimg, "got an image");
+  okx($nimg->write(file=>"testout/t65.ppm"), "save to file");
+}
+else {
+  skipx(2, "couldn't load source image");
 }
 
-
-$nimg=$img->crop(top=>10, left=>10, bottom=>25, right=>25)
-            or skip ( "\# warning ".$img->{'ERRSTR'}."\n" );
-
-#      xopcodes=>[qw( x y Add)],yopcodes=>[qw( x y Sub)],parm=>[]
-
-print "ok 2\n";
-$nimg->write(type=>'pnm',file=>'testout/t65.ppm') || die "error in write()\n";
-
-print "ok 3\n";
+{ # https://rt.cpan.org/Ticket/Display.html?id=7578
+  # make sure we get the right type of image on crop
+  my $src = Imager->new(xsize=>50, ysize=>50, channels=>2, bits=>16);
+  isx($src->getchannels, 2, "check src channels");
+  isx($src->bits, 16, "check src bits");
+  my $out = $src->crop(left=>10, right=>40, top=>10, bottom=>40);
+  isx($out->getchannels, 2, "check out channels");
+  isx($out->bits, 16, "check out bits");
+}
+{ # https://rt.cpan.org/Ticket/Display.html?id=7578
+  print "# try it for paletted too\n";
+  my $src = Imager->new(xsize=>50, ysize=>50, channels=>3, type=>'paletted');
+  # make sure color index zero is defined so there's something to copy
+  $src->addcolors(colors=>[Imager::Color->new(0,0,0)]);
+  isx($src->type, 'paletted', "check source type");
+  my $out = $src->crop(left=>10, right=>40, top=>10, bottom=>40);
+  isx($out->type, 'paletted', 'check output type');
+}

diff --git a/t/testtools.pl b/t/testtools.pl
index f6125318d753bef8272d494140316e17896bfc86..e3082478a791c4793570f22083c95ce0eca40aca 100644 (file)
--- a/t/testtools.pl
+++ b/t/testtools.pl
@@ -94,5 +94,64 @@ sub matchx($$$) {
   matchn($TESTNUM++, $str, $re, $comment);
 }
 
+sub isn ($$$$) {
+  my ($num, $left, $right, $comment) = @_;
+
+  my $match;
+  if (!defined $left && defined $right
+     || defined $left && !defined $right) {
+    $match = 0;
+  }
+  elsif (!defined $left && !defined $right) {
+    $match = 1;
+  }
+  # the right of the || produces a string of \0 if $left is a PV
+  # which is true
+  elsif (!length $left  || ($left & ~$left) ||
+        !length $right || ($right & ~$right)) {
+    $match = $left eq $right;
+  }
+  else {
+    $match = $left == $right;
+  }
+  okn($num, $match, $comment);
+  unless ($match) {
+    print "# the following two values were not equal:\n";
+    print "# value: ",_sv_str($left),"\n";
+    print "# other: ",_sv_str($right),"\n";
+  }
+
+  $match;
+}
+
+sub isx ($$$) {
+  my ($left, $right, $comment) = @_;
+
+  isn($TESTNUM++, $left, $right, $comment);
+}
+
+sub _sv_str {
+  my ($value) = @_;
+
+  if (defined $value) {
+    if (!length $value || ($value & ~$value)) {
+      $value =~ s/\\/\\\\/g;
+      $value =~ s/\r/\\r/g;
+      $value =~ s/\n/\\n/g;
+      $value =~ s/\t/\\t/g;
+      $value =~ s/\"/\\"/g;
+      $value =~ s/([^ -\x7E])/"\\x".sprintf("%02x", ord($1))/ge;
+
+      return qq!"$value"!;
+    }
+    else {
+      return $value; # a number
+    }
+  }
+  else {
+    return "undef";
+  }
+}
+
 1;