use $Config{path_sep} instead of working it out on our own

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

diff --git a/lib/Imager/Test.pm b/lib/Imager/Test.pm
index a4912945511f3e0c2f1b7d2276f1e2a3fd3bd32b..f1e2b8b7ae313221bcc2a6388f9f753723b5f688 100644 (file)
--- a/lib/Imager/Test.pm
+++ b/lib/Imager/Test.pm
@@ -2,7 +2,10 @@ 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(
@@ -18,7 +21,9 @@ use vars qw(@ISA @EXPORT_OK);
      is_fcolor4
      color_cmp
      is_image
-     is_image_similar 
+     is_imaged
+     is_image_similar
+     isnt_image
      image_bounds_checks
      mask_tests
      test_colorf_gpix
@@ -127,10 +132,10 @@ sub is_color4($$$$$$) {
                       && $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;
   }
@@ -168,10 +173,10 @@ sub is_fcolor4($$$$$$;$) {
                       && 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;
   }
@@ -261,8 +266,8 @@ sub test_image_double {
   $img;
 }
 
-sub is_image_similar($$$$) {
-  my ($left, $right, $limit, $comment) = @_;
+sub _low_image_diff_check {
+  my ($left, $right, $comment) = @_;
 
   my $builder = Test::Builder->new;
 
@@ -304,6 +309,22 @@ sub is_image_similar($$$$) {
                    . $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);
@@ -311,14 +332,14 @@ sub is_image_similar($$$$) {
    
     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");
-            last CHECK;
+            last PIXELS;
           }
        }
       }
@@ -338,6 +359,52 @@ sub is_image($$$) {
   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;
 
@@ -540,6 +607,8 @@ No functions are exported by default.
 
 =head1 FUNCTIONS
 
+=for stopwords OO
+
 =over
 
 =item is_color3($color, $red, $blue, $green, $comment)
@@ -554,6 +623,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).
 
+=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
@@ -582,8 +656,8 @@ 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.