[rt.cpan.org #65385] Patch for Imager::Color->hsv

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

diff --git a/lib/Imager/Test.pm b/lib/Imager/Test.pm
index a83007093fff1b13b495f43f4e2b6ed25670efd2..c9d7f5070810528da1921e23af4fa522c1ca95aa 100644 (file)
--- a/lib/Imager/Test.pm
+++ b/lib/Imager/Test.pm
@@ -2,15 +2,35 @@ package Imager::Test;
 use strict;
 use Test::Builder;
 require Exporter;
 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);
 @ISA = qw(Exporter);

-@EXPORT_OK = qw(diff_text_with_nul 
-                test_image_raw test_image_16 test_image test_image_double 
-                is_color3 is_color1 is_color4 is_color_close3
-                is_fcolor4
-                is_image is_image_similar 
-                image_bounds_checks mask_tests
-                test_colorf_gpix test_color_gpix test_colorf_glin);
+@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_fcolor1
+     is_fcolor3
+     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) = @_;
 
 sub diff_text_with_nul {
   my ($desc, $text1, $text2, @params) = @_;


@@ -49,7 +69,7 @@ sub is_color3($$$$$) {
 
   my ($cr, $cg, $cb) = $color->rgba;
   unless ($builder->ok($cr == $red && $cg == $green && $cb == $blue, $comment)) {
 
   my ($cr, $cg, $cb) = $color->rgba;
   unless ($builder->ok($cr == $red && $cg == $green && $cb == $blue, $comment)) {

-    $builder->diag(<<END_DIAG);
+    print <<END_DIAG;

 Color mismatch:
   Red: $red vs $cr
 Green: $green vs $cg
 Color mismatch:
   Red: $red vs $cr
 Green: $green vs $cg


@@ -114,10 +134,10 @@ sub is_color4($$$$$$) {
                       && $ca == $alpha, $comment)) {
     $builder->diag(<<END_DIAG);
 Color mismatch:
                       && $ca == $alpha, $comment)) {
     $builder->diag(<<END_DIAG);
 Color mismatch:

-  Red: $red vs $cr
-Green: $green vs $cg
- Blue: $blue vs $cb
-Alpha: $alpha vs $ca
+  Red: $cr vs $red
+Green: $cg vs $green
+ Blue: $cb vs $blue
+Alpha: $ca vs $alpha

 END_DIAG
     return;
   }
 END_DIAG
     return;
   }


@@ -155,10 +175,84 @@ sub is_fcolor4($$$$$$;$) {
                       && abs($ca - $alpha) <= $mindiff, $comment)) {
     $builder->diag(<<END_DIAG);
 Color mismatch:
                       && abs($ca - $alpha) <= $mindiff, $comment)) {
     $builder->diag(<<END_DIAG);
 Color mismatch:

-  Red: $red vs $cr
-Green: $green vs $cg
- Blue: $blue vs $cb
-Alpha: $alpha vs $ca
+  Red: $cr vs $red
+Green: $cg vs $green
+ Blue: $cb vs $blue
+Alpha: $ca vs $alpha
+END_DIAG
+    return;
+  }
+
+  return 1;
+}
+
+sub is_fcolor1($$$;$) {
+  my ($color, $grey, $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 ($cgrey) = $color->rgba;
+  unless ($builder->ok(abs($cgrey - $grey) <= $mindiff, $comment)) {
+    print <<END_DIAG;
+Color mismatch:
+  Gray: $cgrey vs $grey
+END_DIAG
+    return;
+  }
+
+  return 1;
+}
+
+sub is_fcolor3($$$$$;$) {
+  my ($color, $red, $green, $blue, $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) = $color->rgba;
+  unless ($builder->ok(abs($cr - $red) <= $mindiff
+                      && abs($cg - $green) <= $mindiff
+                      && abs($cb - $blue) <= $mindiff, $comment)) {
+    $builder->diag(<<END_DIAG);
+Color mismatch:
+  Red: $cr vs $red
+Green: $cg vs $green
+ Blue: $cb vs $blue

 END_DIAG
     return;
   }
 END_DIAG
     return;
   }


@@ -248,8 +342,8 @@ sub test_image_double {
   $img;
 }
 
   $img;
 }
 

-sub is_image_similar($$$$) {
-  my ($left, $right, $limit, $comment) = @_;
+sub _low_image_diff_check {
+  my ($left, $right, $comment) = @_;

 
   my $builder = Test::Builder->new;
 
 
   my $builder = Test::Builder->new;
 


@@ -291,6 +385,22 @@ sub is_image_similar($$$$) {
                    . $right->getchannels);
     return;
   }
                    . $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});
   if ($diff > $limit) {
     $builder->ok(0, $comment);
   my $diff = Imager::i_img_diff($left->{IMG}, $right->{IMG});
   if ($diff > $limit) {
     $builder->ok(0, $comment);


@@ -298,14 +408,14 @@ sub is_image_similar($$$$) {
    
     if ($limit == 0) {
       # find the first mismatch
    
     if ($limit == 0) {
       # find the first mismatch

-      CHECK:
+      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");
       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 CHECK;
+            last PIXELS;

           }
        }
       }
           }
        }
       }


@@ -325,6 +435,52 @@ sub is_image($$$) {
   return is_image_similar($left, $right, 0, $comment);
 }
 
   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 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;
 
 sub image_bounds_checks {
   my $im = shift;
 


@@ -363,11 +519,14 @@ sub test_colorf_gpix {
     $builder->ok(0, "$comment - retrieve color at ($x,$y)");
     return;
   }
     $builder->ok(0, "$comment - retrieve color at ($x,$y)");
     return;
   }

-  unless ($builder->ok(_colorf_cmp($c, $expected, $epsilon) == 0,
+  unless ($builder->ok(colorf_cmp($c, $expected, $epsilon) == 0,

             "$comment - got right color ($x, $y)")) {
             "$comment - got right color ($x, $y)")) {

-    print "# got: (", join(",", ($c->rgba)[0,1,2]), ")\n";
-    print "# expected: (", join(",", ($expected->rgba)[0,1,2]), ")\n";
-    return;
+    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;
 }
   }
   1;
 }


@@ -383,10 +542,14 @@ sub test_color_gpix {
     $builder->ok(0, "$comment - retrieve color at ($x,$y)");
     return;
   }
     $builder->ok(0, "$comment - retrieve color at ($x,$y)");
     return;
   }

-  unless ($builder->ok(_color_cmp($c, $expected) == 0,
+  unless ($builder->ok(color_cmp($c, $expected) == 0,

      "got right color ($x, $y)")) {
      "got right color ($x, $y)")) {

-    print "# got: (", join(",", ($c->rgba)[0,1,2]), ")\n";
-    print "# expected: (", join(",", ($expected->rgba)[0,1,2]), ")\n";
+    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;
   }
 


@@ -402,11 +565,11 @@ sub test_colorf_glin {
   @got == @$pels
     or return $builder->is_num(scalar(@got), scalar(@$pels), "$comment - pixels retrieved");
   
   @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),
+  return $builder->ok(!grep(colorf_cmp($pels->[$_], $got[$_], 0.005), 0..$#got),

      "$comment - check colors ($x, $y)");
 }
 
      "$comment - check colors ($x, $y)");
 }
 

-sub _colorf_cmp {
+sub colorf_cmp {

   my ($c1, $c2, $epsilon) = @_;
 
   defined $epsilon or $epsilon = 0;
   my ($c1, $c2, $epsilon) = @_;
 
   defined $epsilon or $epsilon = 0;


@@ -420,7 +583,7 @@ sub _colorf_cmp {
       || abs($s1[2]-$s2[2]) >= $epsilon && $s1[2] <=> $s2[2];
 }
 
       || abs($s1[2]-$s2[2]) >= $epsilon && $s1[2] <=> $s2[2];
 }
 

-sub _color_cmp {
+sub color_cmp {

   my ($c1, $c2) = @_;
 
   my @s1 = $c1->rgba;
   my ($c1, $c2) = @_;
 
   my @s1 = $c1->rgba;


@@ -520,11 +683,44 @@ No functions are exported by default.
 
 =head1 FUNCTIONS
 
 
 =head1 FUNCTIONS
 

+=head2 Test functions
+
+=for stopwords OO
+

 =over
 
 =over
 

-=item is_color3($color, $red, $blue, $green, $comment)
+=item is_color1($color, $grey, $comment)
+
+Tests if the first channel of $color matches $grey.
+
+=item is_color3($color, $red, $green, $blue, $comment)
+
+Tests if $color matches the given ($red, $green, $blue)
+
+=item is_color4($color, $red, $green, $blue, $alpha, $comment)
+
+Tests if $color matches the given ($red, $green, $blue, $alpha)
+
+=item is_fcolor1($fcolor, $grey, $comment)

 
 

-Tests is $color matches the given ($red, $blue, $green)
+=item is_fcolor1($fcolor, $grey, $epsilon, $comment)
+
+Tests if $fcolor's first channel is within $epsilon of ($grey).  For
+the first form $epsilon is taken as 0.001.
+
+=item is_fcolor3($fcolor, $red, $green, $blue, $comment)
+
+=item is_fcolor3($fcolor, $red, $green, $blue, $epsilon, $comment)
+
+Tests if $fcolor's channels are within $epsilon of ($red, $green,
+$blue).  For the first form $epsilon is taken as 0.001.
+
+=item is_fcolor4($fcolor, $red, $green, $blue, $alpha, $comment)
+
+=item is_fcolor4($fcolor, $red, $green, $blue, $alpha, $epsilon, $comment)
+
+Tests if $fcolor's channels are within $epsilon of ($red, $green,
+$blue, $alpha).  For the first form $epsilon is taken as 0.001.

 
 =item is_image($im1, $im2, $comment)
 
 
 =item is_image($im1, $im2, $comment)
 


@@ -534,6 +730,11 @@ 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.  Equivalent to is_image_similar($im1, $im2, 0, $comment).
 
 color representation such as direct vs paletted, bits per sample are
 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
 =item is_image_similar($im1, $im2, $maxdiff, $comment)
 
 Tests if the 2 images have similar content.  Both images must be


@@ -543,58 +744,93 @@ 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.
 
 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()
+=item isnt_image($im1, $im2, $comment)

 
 

-Returns a 150x150x3 Imager::ImgRaw test image.
+Tests that the two images are different.  For regressions tests where
+something (like text output of "0") produced no change, but should
+have produced a change.

 
 

-=item test_image()
+=item test_colorf_gpix($im, $x, $y, $expected, $epsilon, $comment)

 
 

-Returns a 150x150x3 8-bit/sample OO test image.
+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_image_16()
+=item test_color_gpix($im, $x, $y, $expected, $comment)

 
 

-Returns a 150x150x3 16-bit/sample OO test image.
+Retrieves the pixel ($x,$y) from the low-level image $im and compares
+it to the floating point color $expected.

 
 

-=item test_image_double()
+=item test_colorf_glin($im, $x, $y, $pels, $comment)

 
 

-Returns a 150x150x3 double/sample OO test image.
+Retrieves the floating point pixels ($x, $y)-[$x+@$pels, $y] from the
+low level image $im and compares them against @$pels.
+
+=item is_color_close3($color, $red, $green, $blue, $tolerance, $comment)
+
+Tests if $color's first three channels are within $tolerance of ($red,
+$green, $blue).
+
+=back
+
+=head2 Test suite functions
+
+Functions that perform one or more tests, typically used to test
+various parts of Imager's implementation.
+
+=over
+
+=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 mask_tests($im, $epsilon)
+
+Perform a standard set of mask tests on the OO image $im.  Does 24
+separate tests.

 
 =item diff_text_with_nul($test_name, $text1, $text2, @options)
 
 Creates 2 test images and writes $text1 to the first image and $text2
 
 =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.
 
 
 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)
+=back

 
 

-Attempts to write to various pixel positions outside the edge of the
-image to ensure that it fails in those locations.
+=head2 Helper functions

 
 

-Any new image type should pass these tests.  Does 16 separate tests.
+=over

 
 

-=item test_colorf_gpix($im, $x, $y, $expected, $epsilon, $comment)
+=item test_image_raw()

 
 

-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.
+Returns a 150x150x3 Imager::ImgRaw test image.

 
 

-=item test_color_gpix($im, $x, $y, $expected, $comment)
+=item test_image()

 
 

-Retrieves the pixel ($x,$y) from the low-level image $im and compares
-it to the floating point color $expected.
+Returns a 150x150x3 8-bit/sample OO test image.

 
 

-=item test_colorf_glin($im, $x, $y, $pels, $comment)
+=item test_image_16()

 
 

-Retrieves the floating point pixels ($x, $y)-[$x+@$pels, $y] from the
-low level image $im and compares them against @$pels.
+Returns a 150x150x3 16-bit/sample OO test image.

 
 

-=item mask_tests($im, $epsilon)
+=item test_image_double()
+
+Returns a 150x150x3 double/sample OO test image.
+
+=item color_cmp($c1, $c2)
+
+Performs an ordering of 3-channel colors (like <=>).
+
+=item colorf_cmp($c1, $c2)

 
 

-Perform a standard set of mask tests on the OO image $im.
+Performs an ordering of 3-channel floating point colors (like <=>).

 
 =back
 
 
 =back