add simple tests for the Imager::Test test_image functions

diff --git a/Changes b/Changes
index 54c264b1ba2fca85941b61a477ef94d7142240f8..34d53def288c57cb1379acebd5ca4aa5477f82af 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,5 +1,10 @@
 Imager release history.  Older releases can be found in Changes.old
 
+Imager 0.86
+===========
+
+ - add simple tests for the Imager::Test test_image generators
+
 Imager 0.85 - 29 Aug 2011
 ===========
 

diff --git a/lib/Imager/Test.pm b/lib/Imager/Test.pm
index abc797932794cba533f185d9869badb4d7171351..b3ac4450268178b4a509e1b821885ad2bbffb246 100644 (file)
--- a/lib/Imager/Test.pm
+++ b/lib/Imager/Test.pm
@@ -3,6 +3,7 @@ use strict;
 use Test::Builder;
 require Exporter;
 use vars qw(@ISA @EXPORT_OK $VERSION);
+use Carp qw(croak);
 
 $VERSION = "1.000";
 
@@ -14,6 +15,10 @@ $VERSION = "1.000";
      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
@@ -321,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);
-  $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 ]);
 
@@ -334,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');
-  $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;
 }
 
+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) = @_;
 

diff --git a/t/t03test.t b/t/t03test.t
new file mode 100644 (file)
index 0000000..984d212
--- /dev/null
+++ b/t/t03test.t
@@ -0,0 +1,65 @@
+#!perl -w
+use strict;
+use Imager;
+use Imager::Test qw(test_image test_image_16 test_image_mono test_image_gray test_image_gray_16 test_image_double test_image_named);
+use Test::More tests => 60;
+
+# test Imager::Test
+
+for my $named (0, 1) {
+  my $named_desc = $named ? " (by name)" : "";
+  {
+    my $im = $named ? test_image_named("basic") : test_image();
+    ok($im, "got basic test image$named_desc");
+    is($im->type, "direct", "check basic image type");
+    is($im->getchannels, 3, "check basic image channels");
+    is($im->bits, 8, "check basic image bits");
+    ok(!$im->is_bilevel, "check basic isn't mono");
+  }
+  {
+    my $im = $named ? test_image_named("basic16") : test_image_16();
+    ok($im, "got 16-bit basic test image$named_desc");
+    is($im->type, "direct", "check 16-bit basic image type");
+    is($im->getchannels, 3, "check 16-bit basic image channels");
+    is($im->bits, 16, "check 16-bit basic image bits");
+    ok(!$im->is_bilevel, "check 16-bit basic isn't mono");
+  }
+  
+  {
+    my $im = $named ? test_image_named("basic_double") : test_image_double();
+    ok($im, "got double basic test image$named_desc");
+    is($im->type, "direct", "check double basic image type");
+    is($im->getchannels, 3, "check double basic image channels");
+    is($im->bits, "double", "check double basic image bits");
+    ok(!$im->is_bilevel, "check double basic isn't mono");
+  }
+  {
+    my $im = $named ? test_image_named("gray") : test_image_gray();
+    ok($im, "got gray test image$named_desc");
+    is($im->type, "direct", "check gray image type");
+    is($im->getchannels, 1, "check gray image channels");
+    is($im->bits, 8, "check gray image bits");
+    ok(!$im->is_bilevel, "check gray isn't mono");
+    $im->write(file => "testout/t03gray.pgm");
+  }
+  
+  {
+    my $im = $named ? test_image_named("gray16") : test_image_gray_16();
+    ok($im, "got gray test image$named_desc");
+    is($im->type, "direct", "check 16-bit gray image type");
+    is($im->getchannels, 1, "check 16-bit gray image channels");
+    is($im->bits, 16, "check 16-bit gray image bits");
+    ok(!$im->is_bilevel, "check 16-bit isn't mono");
+    $im->write(file => "testout/t03gray16.pgm");
+  }
+  
+  {
+    my $im = $named ? test_image_named("mono") : test_image_mono();
+    ok($im, "got mono image$named_desc");
+    is($im->type, "paletted", "check mono image type");
+    is($im->getchannels, 3, "check mono image channels");
+    is($im->bits, 8, "check mono image bits");
+    ok($im->is_bilevel, "check mono is mono");
+    $im->write(file => "testout/t03mono.pbm");
+  }
+}