- to avoid confusion, channels not present in the image are returned as

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

diff --git a/lib/Imager/Test.pm b/lib/Imager/Test.pm
index e8f77f78f30f4500e6462a91a5017699fb61cc94..3b7d561edb86aab075c7a46a48099c4d1d838679 100644 (file)
--- a/lib/Imager/Test.pm
+++ b/lib/Imager/Test.pm
@@ -4,7 +4,11 @@ use Test::Builder;
 require Exporter;
 use vars qw(@ISA @EXPORT_OK);
 @ISA = qw(Exporter);
-@EXPORT_OK = qw(diff_text_with_nul test_image_raw test_image_16 test_image is_color3 is_color1 is_image is_image_similar image_bounds_checks);
+@EXPORT_OK = qw(diff_text_with_nul test_image_raw test_image_16 test_image 
+                is_color3 is_color1 is_color4 
+                is_fcolor4
+                is_image is_image_similar 
+                image_bounds_checks);
 
 sub diff_text_with_nul {
   my ($desc, $text1, $text2, @params) = @_;
@@ -55,6 +59,79 @@ END_DIAG
   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: $red vs $cr
+Green: $green vs $cg
+ Blue: $blue vs $cb
+Alpha: $alpha vs $ca
+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: $red vs $cr
+Green: $green vs $cg
+ Blue: $blue vs $cb
+Alpha: $alpha vs $ca
+END_DIAG
+    return;
+  }
+
+  return 1;
+}
+
 sub is_color1($$$) {
   my ($color, $grey, $comment) = @_;