fix the prototype for Imager::Test::is_imaged

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

diff --git a/lib/Imager/Test.pm b/lib/Imager/Test.pm
index 8d66ecb26b532fb2f21ff6c713df27f16911f22c..fe3391ff3bc64e2f95b02450f95a2ece8e12e525 100644 (file)
--- a/lib/Imager/Test.pm
+++ b/lib/Imager/Test.pm
@@ -2,7 +2,11 @@ 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);
+use Carp qw(croak);
+
+$VERSION = "1.000";
+

 @ISA = qw(Exporter);
 @EXPORT_OK = 
   qw(
 @ISA = qw(Exporter);
 @EXPORT_OK = 
   qw(


@@ -11,10 +15,16 @@ use vars qw(@ISA @EXPORT_OK);
      test_image_16
      test_image
      test_image_double 
      test_image_16
      test_image
      test_image_double 

+     test_image_mono
+     test_image_gray
+     test_image_gray_16
+     test_image_named

      is_color1
      is_color3
      is_color4
      is_color_close3
      is_color1
      is_color3
      is_color4
      is_color_close3

+     is_fcolor1
+     is_fcolor3

      is_fcolor4
      color_cmp
      is_image
      is_fcolor4
      color_cmp
      is_image


@@ -64,7 +74,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


@@ -181,6 +191,80 @@ END_DIAG
   return 1;
 }
 
   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;
+  }
+
+  return 1;
+}
+

 sub is_color1($$$) {
   my ($color, $grey, $comment) = @_;
 
 sub is_color1($$$) {
   my ($color, $grey, $comment) = @_;
 


@@ -242,8 +326,8 @@ sub test_image_16 {
   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 => 16);
   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 => 16);

-  $img->box(filled => 1, color => $green, box => [ 70, 25, 130, 125 ]);
-  $img->box(filled => 1, color => $blue,  box => [ 20, 25, 80, 125 ]);
+  $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->arc(x => 75, y => 75, r => 30, color => $red);
   $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]);
 


@@ -255,14 +339,73 @@ sub test_image_double {
   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');
   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->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;
 }
 
   $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_gray {
+  my $g50 = Imager::Color->new(128, 128, 128);
+  my $g30  = Imager::Color->new(76, 76, 76);
+  my $g70   = Imager::Color->new(178, 178, 178);
+  my $img = Imager->new(xsize => 150, ysize => 150, channels => 1);
+  $img->box(filled => 1, color => $g50, box => [ 70, 24, 130, 124 ]);
+  $img->box(filled => 1, color => $g30,  box => [ 20, 26, 80, 126 ]);
+  $img->arc(x => 75, y => 75, r => 30, color => $g70);
+  $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]);
+
+  return $img;
+}
+
+sub test_image_gray_16 {
+  my $g50 = Imager::Color->new(128, 128, 128);
+  my $g30  = Imager::Color->new(76, 76, 76);
+  my $g70   = Imager::Color->new(178, 178, 178);
+  my $img = Imager->new(xsize => 150, ysize => 150, channels => 1, bits => 16);
+  $img->box(filled => 1, color => $g50, box => [ 70, 24, 130, 124 ]);
+  $img->box(filled => 1, color => $g30,  box => [ 20, 26, 80, 126 ]);
+  $img->arc(x => 75, y => 75, r => 30, color => $g70);
+  $img->filter(type => 'conv', coef => [ 0.1, 0.2, 0.4, 0.2, 0.1 ]);
+
+  return $img;
+}
+
+sub test_image_mono {
+  require Imager::Fill;
+  my $fh = Imager::Fill->new(hatch => 'check1x1');
+  my $img = Imager->new(xsize => 150, ysize => 150, type => "paletted");
+  my $black = Imager::Color->new(0, 0, 0);
+  my $white = Imager::Color->new(255, 255, 255);
+  $img->addcolors(colors => [ $black, $white ]);
+  $img->box(fill => $fh, box => [ 70, 24, 130, 124 ]);
+  $img->box(filled => 1, color => $white,  box => [ 20, 26, 80, 126 ]);
+  $img->arc(x => 75, y => 75, r => 30, color => $black, aa => 0);
+
+  return $img;
+}
+
+my %name_to_sub =
+  (
+   basic => \&test_image,
+   basic16 => \&test_image_16,
+   basic_double => \&test_image_double,
+   gray => \&test_image_gray,
+   gray16 => \&test_image_gray_16,
+   mono => \&test_image_mono,
+  );
+
+sub test_image_named {
+  my $name = shift
+    or croak("No name supplied to test_image_named()");
+  my $sub = $name_to_sub{$name}
+    or croak("Unknown name $name supplied to test_image_named()");
+
+  return $sub->();
+}
+

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


@@ -356,7 +499,12 @@ sub is_image($$$) {
   return is_image_similar($left, $right, 0, $comment);
 }
 
   return is_image_similar($left, $right, 0, $comment);
 }
 

-sub is_imaged($$$) {
+sub is_imaged($$$;$) {
+  my $epsilon = Imager::i_img_epsilonf();
+  if (@_ > 3) {
+    ($epsilon) = splice @_, 2, 1;
+  }
+

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


@@ -368,17 +516,17 @@ sub is_imaged($$$) {
 
   my $builder = Test::Builder->new;
 
 
   my $builder = Test::Builder->new;
 

-  my $diff = Imager::i_img_diffd($left->{IMG}, $right->{IMG});
-  if ($diff > 0) {
+  my $same = Imager::i_img_samef($left->{IMG}, $right->{IMG}, $epsilon, $comment);
+  if (!$same) {

     $builder->ok(0, $comment);
     $builder->ok(0, $comment);

-    $builder->diag("image data difference: $diff");
-   
+    $builder->diag("images different");
+

     # find the first mismatch
   PIXELS:
     for my $y (0 .. $left->getheight()-1) {
       for my $x (0.. $left->getwidth()-1) {
     # 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);
+       my @lsamples = $left->getsamples(x => $x, y => $y, width => 1, type => "float");
+       my @rsamples = $right->getsamples(x => $x, y => $y, width => 1, type => "float");

        if ("@lsamples" ne "@rsamples") {
          $builder->diag("first mismatch at ($x, $y) - @lsamples vs @rsamples");
          last PIXELS;
        if ("@lsamples" ne "@rsamples") {
          $builder->diag("first mismatch at ($x, $y) - @lsamples vs @rsamples");
          last PIXELS;


@@ -604,11 +752,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 is $color matches the given ($red, $blue, $green)
+Tests if $color matches the given ($red, $green, $blue, $alpha)
+
+=item is_fcolor1($fcolor, $grey, $comment)
+
+=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)
 


@@ -620,8 +801,11 @@ not checked.  Equivalent to is_image_similar($im1, $im2, 0, $comment).
 
 =item is_imaged($im, $im2, $comment)
 
 
 =item is_imaged($im, $im2, $comment)
 

+=item is_imaged($im, $im2, $epsilon, $comment)
+

 Tests if the two images have the same content at the double/sample
 Tests if the two images have the same content at the double/sample

-level.
+level.  C<$epsilon> defaults to the platform DBL_EPSILON multiplied by
+four.

 
 =item is_image_similar($im1, $im2, $maxdiff, $comment)
 
 
 =item is_image_similar($im1, $im2, $maxdiff, $comment)
 


@@ -632,58 +816,111 @@ 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)
+
+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)

 
 

-Returns a 150x150x3 double/sample OO test image.
+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. Name: C<basic>.

 
 

-=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. Name: C<basic16>

 
 

-=item mask_tests($im, $epsilon)
+=item test_image_double()
+
+Returns a 150x150x3 double/sample OO test image. Name: C<basic_double>.
+
+=item test_image_gray()
+
+Returns a 150x150 single channel OO test image. Name: C<gray>.
+
+=item test_image_gray_16()
+
+Returns a 150x150 16-bit/sample single channel OO test image. Name:
+C<gray16>.
+
+=item test_image_mono()
+
+Returns a 150x150 bilevel image that passes the is_bilevel() test.
+Name: C<mono>.
+
+=item test_image_named($name)
+
+Return one of the other test images above based on name.
+
+=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