X-Git-Url: http://git.imager.perl.org/imager.git/blobdiff_plain/ae12796a26e9881d7b0dd8382e95c1befe06fb1b..e17b7029eb8e9c20f30e5208de1f49d243fa514c:/lib/Imager/Test.pm

diff --git a/lib/Imager/Test.pm b/lib/Imager/Test.pm
index f914f2ca..f1e2b8b7 100644
--- a/lib/Imager/Test.pm
+++ b/lib/Imager/Test.pm
@@ -2,9 +2,33 @@ package Imager::Test;
 use strict;
 use Test::Builder;
 require Exporter;
-use vars qw(@ISA @EXPORT_OK);
+use vars qw(@ISA @EXPORT_OK $VERSION);
+
+$VERSION = "1.000";
+
 @ISA = qw(Exporter);
-@EXPORT_OK = qw(diff_text_with_nul test_image_raw test_image_16 is_color3 is_color1 is_image);
+@EXPORT_OK = 
+  qw(
+     diff_text_with_nul 
+     test_image_raw
+     test_image_16
+     test_image
+     test_image_double 
+     is_color1
+     is_color3
+     is_color4
+     is_color_close3
+     is_fcolor4
+     color_cmp
+     is_image
+     is_imaged
+     is_image_similar
+     isnt_image
+     image_bounds_checks
+     mask_tests
+     test_colorf_gpix
+     test_color_gpix
+     test_colorf_glin);
 
 sub diff_text_with_nul {
   my ($desc, $text1, $text2, @params) = @_;
@@ -55,6 +79,111 @@ END_DIAG
   return 1;
 }
 
+sub is_color_close3($$$$$$) {
+  my ($color, $red, $green, $blue, $tolerance, $comment) = @_;
+
+  my $builder = Test::Builder->new;
+
+  unless (defined $color) {
+    $builder->ok(0, $comment);
+    $builder->diag("color is undef");
+    return;
+  }
+  unless ($color->can('rgba')) {
+    $builder->ok(0, $comment);
+    $builder->diag("color is not a color object");
+    return;
+  }
+
+  my ($cr, $cg, $cb) = $color->rgba;
+  unless ($builder->ok(abs($cr - $red) <= $tolerance
+		       && abs($cg - $green) <= $tolerance
+		       && abs($cb - $blue) <= $tolerance, $comment)) {
+    $builder->diag(<<END_DIAG);
+Color out of tolerance ($tolerance):
+  Red: expected $red vs received $cr
+Green: expected $green vs received $cg
+ Blue: expected $blue vs received $cb
+END_DIAG
+    return;
+  }
+
+  return 1;
+}
+
+sub is_color4($$$$$$) {
+  my ($color, $red, $green, $blue, $alpha, $comment) = @_;
+
+  my $builder = Test::Builder->new;
+
+  unless (defined $color) {
+    $builder->ok(0, $comment);
+    $builder->diag("color is undef");
+    return;
+  }
+  unless ($color->can('rgba')) {
+    $builder->ok(0, $comment);
+    $builder->diag("color is not a color object");
+    return;
+  }
+
+  my ($cr, $cg, $cb, $ca) = $color->rgba;
+  unless ($builder->ok($cr == $red && $cg == $green && $cb == $blue 
+		       && $ca == $alpha, $comment)) {
+    $builder->diag(<<END_DIAG);
+Color mismatch:
+  Red: $cr vs $red
+Green: $cg vs $green
+ Blue: $cb vs $blue
+Alpha: $ca vs $alpha
+END_DIAG
+    return;
+  }
+
+  return 1;
+}
+
+sub is_fcolor4($$$$$$;$) {
+  my ($color, $red, $green, $blue, $alpha, $comment_or_diff, $comment_or_undef) = @_;
+  my ($comment, $mindiff);
+  if (defined $comment_or_undef) {
+    ( $mindiff, $comment ) = ( $comment_or_diff, $comment_or_undef )
+  }
+  else {
+    ( $mindiff, $comment ) = ( 0.001, $comment_or_diff )
+  }
+
+  my $builder = Test::Builder->new;
+
+  unless (defined $color) {
+    $builder->ok(0, $comment);
+    $builder->diag("color is undef");
+    return;
+  }
+  unless ($color->can('rgba')) {
+    $builder->ok(0, $comment);
+    $builder->diag("color is not a color object");
+    return;
+  }
+
+  my ($cr, $cg, $cb, $ca) = $color->rgba;
+  unless ($builder->ok(abs($cr - $red) <= $mindiff
+		       && abs($cg - $green) <= $mindiff
+		       && abs($cb - $blue) <= $mindiff
+		       && abs($ca - $alpha) <= $mindiff, $comment)) {
+    $builder->diag(<<END_DIAG);
+Color mismatch:
+  Red: $cr vs $red
+Green: $cg vs $green
+ Blue: $cb vs $blue
+Alpha: $ca vs $alpha
+END_DIAG
+    return;
+  }
+
+  return 1;
+}
+
 sub is_color1($$$) {
   my ($color, $grey, $comment) = @_;
 
@@ -98,6 +227,19 @@ sub test_image_raw {
   $img;
 }
 
+sub test_image {
+  my $green = Imager::Color->new(0, 255, 0, 255);
+  my $blue  = Imager::Color->new(0, 0, 255, 255);
+  my $red   = Imager::Color->new(255, 0, 0, 255);
+  my $img = Imager->new(xsize => 150, ysize => 150);
+  $img->box(filled => 1, color => $green, box => [ 70, 24, 130, 124 ]);
+  $img->box(filled => 1, color => $blue,  box => [ 20, 26, 80, 126 ]);
+  $img->arc(x => 75, y => 75, r => 30, color => $red);
+  $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]);
+
+  $img;
+}
+
 sub test_image_16 {
   my $green = Imager::Color->new(0, 255, 0, 255);
   my $blue  = Imager::Color->new(0, 0, 255, 255);
@@ -111,7 +253,20 @@ sub test_image_16 {
   $img;
 }
 
-sub is_image($$$) {
+sub test_image_double {
+  my $green = Imager::Color->new(0, 255, 0, 255);
+  my $blue  = Imager::Color->new(0, 0, 255, 255);
+  my $red   = Imager::Color->new(255, 0, 0, 255);
+  my $img = Imager->new(xsize => 150, ysize => 150, bits => 'double');
+  $img->box(filled => 1, color => $green, box => [ 70, 25, 130, 125 ]);
+  $img->box(filled => 1, color => $blue,  box => [ 20, 25, 80, 125 ]);
+  $img->arc(x => 75, y => 75, r => 30, color => $red);
+  $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]);
+
+  $img;
+}
+
+sub _low_image_diff_check {
   my ($left, $right, $comment) = @_;
 
   my $builder = Test::Builder->new;
@@ -154,16 +309,280 @@ sub is_image($$$) {
                    . $right->getchannels);
     return;
   }
+
+  return 1;
+}
+
+sub is_image_similar($$$$) {
+  my ($left, $right, $limit, $comment) = @_;
+
+  {
+    local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+    _low_image_diff_check($left, $right, $comment)
+      or return;
+  }
+
+  my $builder = Test::Builder->new;
+
   my $diff = Imager::i_img_diff($left->{IMG}, $right->{IMG});
-  unless ($diff == 0) {
+  if ($diff > $limit) {
+    $builder->ok(0, $comment);
+    $builder->diag("image data difference > $limit - $diff");
+   
+    if ($limit == 0) {
+      # find the first mismatch
+      PIXELS:
+      for my $y (0 .. $left->getheight()-1) {
+	for my $x (0.. $left->getwidth()-1) {
+	  my @lsamples = $left->getsamples(x => $x, y => $y, width => 1);
+	  my @rsamples = $right->getsamples(x => $x, y => $y, width => 1);
+          if ("@lsamples" ne "@rsamples") {
+            $builder->diag("first mismatch at ($x, $y) - @lsamples vs @rsamples");
+            last PIXELS;
+          }
+	}
+      }
+    }
+
+    return;
+  }
+  
+  return $builder->ok(1, $comment);
+}
+
+sub is_image($$$) {
+  my ($left, $right, $comment) = @_;
+
+  local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+  return is_image_similar($left, $right, 0, $comment);
+}
+
+sub is_imaged($$$) {
+  my ($left, $right, $comment) = @_;
+
+  {
+    local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+    _low_image_diff_check($left, $right, $comment)
+      or return;
+  }
+
+  my $builder = Test::Builder->new;
+
+  my $diff = Imager::i_img_diffd($left->{IMG}, $right->{IMG});
+  if ($diff > 0) {
     $builder->ok(0, $comment);
-    $builder->diag("image data different - $diff");
+    $builder->diag("image data difference: $diff");
+   
+    # find the first mismatch
+  PIXELS:
+    for my $y (0 .. $left->getheight()-1) {
+      for my $x (0.. $left->getwidth()-1) {
+	my @lsamples = $left->getsamples(x => $x, y => $y, width => 1);
+	my @rsamples = $right->getsamples(x => $x, y => $y, width => 1);
+	if ("@lsamples" ne "@rsamples") {
+	  $builder->diag("first mismatch at ($x, $y) - @lsamples vs @rsamples");
+	  last PIXELS;
+	}
+      }
+    }
+
     return;
   }
   
   return $builder->ok(1, $comment);
 }
 
+sub isnt_image {
+  my ($left, $right, $comment) = @_;
+
+  my $builder = Test::Builder->new;
+
+  my $diff = Imager::i_img_diff($left->{IMG}, $right->{IMG});
+
+  return $builder->ok($diff, "$comment");
+}
+
+sub image_bounds_checks {
+  my $im = shift;
+
+  my $builder = Test::Builder->new;
+
+  $builder->ok(!$im->getpixel(x => -1, y => 0), 'bounds check get (-1, 0)');
+  $builder->ok(!$im->getpixel(x => 10, y => 0), 'bounds check get (10, 0)');
+  $builder->ok(!$im->getpixel(x => 0, y => -1), 'bounds check get (0, -1)');
+  $builder->ok(!$im->getpixel(x => 0, y => 10), 'bounds check get (0, 10)');
+  $builder->ok(!$im->getpixel(x => -1, y => 0), 'bounds check get (-1, 0) float');
+  $builder->ok(!$im->getpixel(x => 10, y => 0), 'bounds check get (10, 0) float');
+  $builder->ok(!$im->getpixel(x => 0, y => -1), 'bounds check get (0, -1) float');
+  $builder->ok(!$im->getpixel(x => 0, y => 10), 'bounds check get (0, 10) float');
+  my $black = Imager::Color->new(0, 0, 0);
+  require Imager::Color::Float;
+  my $blackf = Imager::Color::Float->new(0, 0, 0);
+  $builder->ok(!$im->setpixel(x => -1, y => 0, color => $black), 'bounds check set (-1, 0)');
+  $builder->ok(!$im->setpixel(x => 10, y => 0, color => $black), 'bounds check set (10, 0)');
+  $builder->ok(!$im->setpixel(x => 0, y => -1, color => $black), 'bounds check set (0, -1)');
+  $builder->ok(!$im->setpixel(x => 0, y => 10, color => $black), 'bounds check set (0, 10)');
+  $builder->ok(!$im->setpixel(x => -1, y => 0, color => $blackf), 'bounds check set (-1, 0) float');
+  $builder->ok(!$im->setpixel(x => 10, y => 0, color => $blackf), 'bounds check set (10, 0) float');
+  $builder->ok(!$im->setpixel(x => 0, y => -1, color => $blackf), 'bounds check set (0, -1) float');
+  $builder->ok(!$im->setpixel(x => 0, y => 10, color => $blackf), 'bounds check set (0, 10) float');
+}
+
+sub test_colorf_gpix {
+  my ($im, $x, $y, $expected, $epsilon, $comment) = @_;
+
+  my $builder = Test::Builder->new;
+  
+  defined $comment or $comment = '';
+
+  my $c = Imager::i_gpixf($im, $x, $y);
+  unless ($c) {
+    $builder->ok(0, "$comment - retrieve color at ($x,$y)");
+    return;
+  }
+  unless ($builder->ok(colorf_cmp($c, $expected, $epsilon) == 0,
+	     "$comment - got right color ($x, $y)")) {
+    my @c = $c->rgba;
+    my @exp = $expected->rgba;
+    $builder->diag(<<EOS);
+# got: ($c[0], $c[1], $c[2])
+# expected: ($exp[0], $exp[1], $exp[2])
+EOS
+  }
+  1;
+}
+
+sub test_color_gpix {
+  my ($im, $x, $y, $expected, $comment) = @_;
+
+  my $builder = Test::Builder->new;
+  
+  defined $comment or $comment = '';
+  my $c = Imager::i_get_pixel($im, $x, $y);
+  unless ($c) {
+    $builder->ok(0, "$comment - retrieve color at ($x,$y)");
+    return;
+  }
+  unless ($builder->ok(color_cmp($c, $expected) == 0,
+     "got right color ($x, $y)")) {
+    my @c = $c->rgba;
+    my @exp = $expected->rgba;
+    $builder->diag(<<EOS);
+# got: ($c[0], $c[1], $c[2])
+# expected: ($exp[0], $exp[1], $exp[2])
+EOS
+    return;
+  }
+
+  return 1;
+}
+
+sub test_colorf_glin {
+  my ($im, $x, $y, $pels, $comment) = @_;
+
+  my $builder = Test::Builder->new;
+  
+  my @got = Imager::i_glinf($im, $x, $x+@$pels, $y);
+  @got == @$pels
+    or return $builder->is_num(scalar(@got), scalar(@$pels), "$comment - pixels retrieved");
+  
+  return $builder->ok(!grep(colorf_cmp($pels->[$_], $got[$_], 0.005), 0..$#got),
+     "$comment - check colors ($x, $y)");
+}
+
+sub colorf_cmp {
+  my ($c1, $c2, $epsilon) = @_;
+
+  defined $epsilon or $epsilon = 0;
+
+  my @s1 = $c1->rgba;
+  my @s2 = $c2->rgba;
+
+  # print "# (",join(",", @s1[0..2]),") <=> (",join(",", @s2[0..2]),")\n";
+  return abs($s1[0]-$s2[0]) >= $epsilon && $s1[0] <=> $s2[0] 
+    || abs($s1[1]-$s2[1]) >= $epsilon && $s1[1] <=> $s2[1]
+      || abs($s1[2]-$s2[2]) >= $epsilon && $s1[2] <=> $s2[2];
+}
+
+sub color_cmp {
+  my ($c1, $c2) = @_;
+
+  my @s1 = $c1->rgba;
+  my @s2 = $c2->rgba;
+
+  return $s1[0] <=> $s2[0] 
+    || $s1[1] <=> $s2[1]
+      || $s1[2] <=> $s2[2];
+}
+
+# these test the action of the channel mask on the image supplied
+# which should be an OO image.
+sub mask_tests {
+  my ($im, $epsilon) = @_;
+
+  my $builder = Test::Builder->new;
+
+  defined $epsilon or $epsilon = 0;
+
+  # we want to check all four of ppix() and plin(), ppix() and plinf()
+  # basic test procedure:
+  #   first using default/all 1s mask, set to white
+  #   make sure we got white
+  #   set mask to skip a channel, set to grey
+  #   make sure only the right channels set
+
+  print "# channel mask tests\n";
+  # 8-bit color tests
+  my $white = Imager::NC(255, 255, 255);
+  my $grey = Imager::NC(128, 128, 128);
+  my $white_grey = Imager::NC(128, 255, 128);
+
+  print "# with ppix\n";
+  $builder->ok($im->setmask(mask=>~0), "set to default mask");
+  $builder->ok($im->setpixel(x=>0, 'y'=>0, color=>$white), "set to white all channels");
+  test_color_gpix($im->{IMG}, 0, 0, $white, "ppix");
+  $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
+  $builder->ok($im->setpixel(x=>0, 'y'=>0, color=>$grey), "set to grey, no channel 2");
+  test_color_gpix($im->{IMG}, 0, 0, $white_grey, "ppix masked");
+
+  print "# with plin\n";
+  $builder->ok($im->setmask(mask=>~0), "set to default mask");
+  $builder->ok($im->setscanline(x=>0, 'y'=>1, pixels => [$white]), 
+     "set to white all channels");
+  test_color_gpix($im->{IMG}, 0, 1, $white, "plin");
+  $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
+  $builder->ok($im->setscanline(x=>0, 'y'=>1, pixels=>[$grey]), 
+     "set to grey, no channel 2");
+  test_color_gpix($im->{IMG}, 0, 1, $white_grey, "plin masked");
+
+  # float color tests
+  my $whitef = Imager::NCF(1.0, 1.0, 1.0);
+  my $greyf = Imager::NCF(0.5, 0.5, 0.5);
+  my $white_greyf = Imager::NCF(0.5, 1.0, 0.5);
+
+  print "# with ppixf\n";
+  $builder->ok($im->setmask(mask=>~0), "set to default mask");
+  $builder->ok($im->setpixel(x=>0, 'y'=>2, color=>$whitef), "set to white all channels");
+  test_colorf_gpix($im->{IMG}, 0, 2, $whitef, $epsilon, "ppixf");
+  $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
+  $builder->ok($im->setpixel(x=>0, 'y'=>2, color=>$greyf), "set to grey, no channel 2");
+  test_colorf_gpix($im->{IMG}, 0, 2, $white_greyf, $epsilon, "ppixf masked");
+
+  print "# with plinf\n";
+  $builder->ok($im->setmask(mask=>~0), "set to default mask");
+  $builder->ok($im->setscanline(x=>0, 'y'=>3, pixels => [$whitef]), 
+     "set to white all channels");
+  test_colorf_gpix($im->{IMG}, 0, 3, $whitef, $epsilon, "plinf");
+  $builder->ok($im->setmask(mask=>0xF-0x2), "set channel to exclude channel1");
+  $builder->ok($im->setscanline(x=>0, 'y'=>3, pixels=>[$greyf]), 
+     "set to grey, no channel 2");
+  test_colorf_gpix($im->{IMG}, 0, 3, $white_greyf, $epsilon, "plinf masked");
+
+}
+
 1;
 
 __END__
@@ -188,6 +607,8 @@ No functions are exported by default.
 
 =head1 FUNCTIONS
 
+=for stopwords OO
+
 =over
 
 =item is_color3($color, $red, $blue, $green, $comment)
@@ -200,27 +621,75 @@ Tests if the 2 images have the same content.  Both images must be
 defined, have the same width, height, channels and the same color in
 each pixel.  The color comparison is done at 8-bits per pixel.  The
 color representation such as direct vs paletted, bits per sample are
-not checked.
+not checked.  Equivalent to is_image_similar($im1, $im2, 0, $comment).
+
+=item is_imaged($im, $im2, $comment)
+
+Tests if the two images have the same content at the double/sample
+level.
+
+=item is_image_similar($im1, $im2, $maxdiff, $comment)
+
+Tests if the 2 images have similar content.  Both images must be
+defined, have the same width, height and channels.  The cum of the
+squares of the differences of each sample are calculated and must be
+less than or equal to I<$maxdiff> for the test to pass.  The color
+comparison is done at 8-bits per pixel.  The color representation such
+as direct vs paletted, bits per sample are not checked.
 
 =item test_image_raw()
 
 Returns a 150x150x3 Imager::ImgRaw test image.
 
+=item test_image()
+
+Returns a 150x150x3 8-bit/sample OO test image.
+
 =item test_image_16()
 
 Returns a 150x150x3 16-bit/sample OO test image.
 
+=item test_image_double()
+
+Returns a 150x150x3 double/sample OO test image.
+
 =item diff_text_with_nul($test_name, $text1, $text2, @options)
 
 Creates 2 test images and writes $text1 to the first image and $text2
-to the second image with the string() method.  Each call adds 3 ok/not
-ok to the output of the test script.
+to the second image with the string() method.  Each call adds 3
+C<ok>/C<not ok> to the output of the test script.
 
 Extra options that should be supplied include the font and either a
 color or channel parameter.
 
 This was explicitly created for regression tests on #21770.
 
+=item image_bounds_checks($im)
+
+Attempts to write to various pixel positions outside the edge of the
+image to ensure that it fails in those locations.
+
+Any new image type should pass these tests.  Does 16 separate tests.
+
+=item test_colorf_gpix($im, $x, $y, $expected, $epsilon, $comment)
+
+Retrieves the pixel ($x,$y) from the low-level image $im and compares
+it to the floating point color $expected, with a tolerance of epsilon.
+
+=item test_color_gpix($im, $x, $y, $expected, $comment)
+
+Retrieves the pixel ($x,$y) from the low-level image $im and compares
+it to the floating point color $expected.
+
+=item test_colorf_glin($im, $x, $y, $pels, $comment)
+
+Retrieves the floating point pixels ($x, $y)-[$x+@$pels, $y] from the
+low level image $im and compares them against @$pels.
+
+=item mask_tests($im, $epsilon)
+
+Perform a standard set of mask tests on the OO image $im.
+
 =back
 
 =head1 AUTHOR