[rt #84596] rearrange Imager's test files
authorTony Cook <tony@develop-help.com>
Thu, 2 May 2013 23:56:50 +0000 (09:56 +1000)
committerTony Cook <tony@develop-help.com>
Thu, 2 May 2013 23:56:50 +0000 (09:56 +1000)
The old one-level, 2 digit test file arrangement made it difficult to
add new test files, with the effect that I have some test files that
test things that should be separate (eg. the filters test).

This is mostly a simple rename pass so far,

141 files changed:
MANIFEST
MANIFEST.SKIP
Makefile.PL
t/000-load.t [new file with mode: 0644]
t/100-base/010-introvert.t [new file with mode: 0644]
t/100-base/020-color.t [new file with mode: 0644]
t/100-base/030-countc.t [new file with mode: 0644]
t/100-base/800-tr18561.t [new file with mode: 0644]
t/100-base/801-tr18561b.t [new file with mode: 0644]
t/150-type/020-sixteen.t [new file with mode: 0644]
t/150-type/030-double.t [new file with mode: 0644]
t/150-type/040-palette.t [new file with mode: 0644]
t/150-type/100-masked.t [new file with mode: 0644]
t/200-file/010-iolayer.t [new file with mode: 0644]
t/200-file/100-files.t [new file with mode: 0644]
t/200-file/200-nojpeg.t [new file with mode: 0644]
t/200-file/210-nopng.t [new file with mode: 0644]
t/200-file/220-nogif.t [new file with mode: 0644]
t/200-file/230-notiff.t [new file with mode: 0644]
t/200-file/300-raw.t [new file with mode: 0644]
t/200-file/310-pnm.t [new file with mode: 0644]
t/200-file/320-bmp.t [new file with mode: 0644]
t/200-file/330-tga.t [new file with mode: 0644]
t/200-file/400-basic.t [new file with mode: 0644]
t/250-draw/010-draw.t [new file with mode: 0644]
t/250-draw/020-flood.t [new file with mode: 0644]
t/250-draw/030-paste.t [new file with mode: 0644]
t/250-draw/040-rubthru.t [new file with mode: 0644]
t/250-draw/050-polyaa.t [new file with mode: 0644]
t/250-draw/100-fill.t [new file with mode: 0644]
t/250-draw/200-compose.t [new file with mode: 0644]
t/300-transform/010-scale.t [new file with mode: 0644]
t/300-transform/020-combine.t [new file with mode: 0644]
t/300-transform/030-copyflip.t [new file with mode: 0644]
t/300-transform/040-crop.t [new file with mode: 0644]
t/300-transform/050-convert.t [new file with mode: 0644]
t/300-transform/060-map.t [new file with mode: 0644]
t/300-transform/500-trans.t [new file with mode: 0644]
t/300-transform/600-trans2.t [new file with mode: 0644]
t/300-transform/610-postfix.t [new file with mode: 0644]
t/300-transform/620-infix.t [new file with mode: 0644]
t/300-transform/630-assem.t [new file with mode: 0644]
t/350-font/010-font.t [new file with mode: 0644]
t/350-font/020-tt.t [new file with mode: 0644]
t/350-font/030-ttoo.t [new file with mode: 0644]
t/350-font/040-ttstd.t [new file with mode: 0644]
t/350-font/100-texttools.t [new file with mode: 0644]
t/400-filter/010-filters.t [new file with mode: 0644]
t/450-api/100-inline.t [new file with mode: 0644]
t/450-api/110-inlinectx.t [new file with mode: 0644]
t/850-thread/010-base.t [new file with mode: 0644]
t/850-thread/100-error.t [new file with mode: 0644]
t/850-thread/110-log.t [new file with mode: 0644]
t/900-util/010-test.t [new file with mode: 0644]
t/900-util/020-error.t [new file with mode: 0644]
t/900-util/030-log.t [new file with mode: 0644]
t/900-util/040-limit.t [new file with mode: 0644]
t/900-util/050-matrix.t [new file with mode: 0644]
t/900-util/060-extutil.t [new file with mode: 0644]
t/900-util/060-hlines.t [new file with mode: 0644]
t/950-kwalitee/010-pod.t [new file with mode: 0644]
t/950-kwalitee/020-samples.t [new file with mode: 0644]
t/950-kwalitee/030-podcover.t [new file with mode: 0644]
t/950-kwalitee/040-strict.t [new file with mode: 0644]
t/950-kwalitee/050-meta.t [new file with mode: 0644]
t/t00basic.t [deleted file]
t/t01introvert.t [deleted file]
t/t020masked.t [deleted file]
t/t021sixteen.t [deleted file]
t/t022double.t [deleted file]
t/t023palette.t [deleted file]
t/t03test.t [deleted file]
t/t05error.t [deleted file]
t/t07iolayer.t [deleted file]
t/t080log.t [deleted file]
t/t081error.t [deleted file]
t/t082limit.t [deleted file]
t/t1000files.t [deleted file]
t/t101nojpeg.t [deleted file]
t/t102nopng.t [deleted file]
t/t103raw.t [deleted file]
t/t104ppm.t [deleted file]
t/t105nogif.t [deleted file]
t/t106notiff.t [deleted file]
t/t107bmp.t [deleted file]
t/t108tga.t [deleted file]
t/t15color.t [deleted file]
t/t16matrix.t [deleted file]
t/t20fill.t [deleted file]
t/t21draw.t [deleted file]
t/t22flood.t [deleted file]
t/t31font.t [deleted file]
t/t35ttfont.t [deleted file]
t/t36oofont.t [deleted file]
t/t37std.t [deleted file]
t/t40scale.t [deleted file]
t/t50basicoo.t [deleted file]
t/t55trans.t [deleted file]
t/t56postfix.t [deleted file]
t/t57infix.t [deleted file]
t/t58trans2.t [deleted file]
t/t59assem.t [deleted file]
t/t61filters.t [deleted file]
t/t62compose.t [deleted file]
t/t63combine.t [deleted file]
t/t64copyflip.t [deleted file]
t/t65crop.t [deleted file]
t/t66paste.t [deleted file]
t/t67convert.t [deleted file]
t/t68map.t [deleted file]
t/t69rubthru.t [deleted file]
t/t75polyaa.t [deleted file]
t/t80texttools.t [deleted file]
t/t81hlines.t [deleted file]
t/t82inline.t [deleted file]
t/t83extutil.t [deleted file]
t/t84inlinectx.t [deleted file]
t/t90cc.t [deleted file]
t/t91pod.t [deleted file]
t/t92samples.t [deleted file]
t/t93podcover.t [deleted file]
t/t94kwalitee.t [deleted file]
t/t95log.t [deleted file]
t/t98meta.t [deleted file]
t/t99thread.t [deleted file]
t/tr18561.t [deleted file]
t/tr18561b.t [deleted file]
t/x107bmp.t [deleted file]
t/x11rubthru.t [deleted file]
t/x20spell.t [deleted file]
t/x30podlinkcheck.t [deleted file]
t/x40checklib.t [deleted file]
t/x90cmpversion.t [deleted file]
t/x91manifest.t [deleted file]
xt/x107bmp.t [new file with mode: 0644]
xt/x11rubthru.t [new file with mode: 0644]
xt/x20spell.t [new file with mode: 0644]
xt/x30podlinkcheck.t [new file with mode: 0644]
xt/x40checklib.t [new file with mode: 0644]
xt/x90cmpversion.t [new file with mode: 0644]
xt/x91manifest.t [new file with mode: 0644]

index 55a9466..25d87ea 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -311,71 +311,71 @@ SGI/testimg/verb6.rgb
 spot.perl                      For making an ordered dither matrix from a spot function
 stackmach.c
 stackmach.h
+t/000-load.t                   Test Imager modules can be loaded
+t/100-base/010-introvert.t     Test image inspection
+t/100-base/020-color.t         Test Imager::Color
+t/100-base/030-countc.t                Test getcolorcount() etc
+t/100-base/800-tr18561.t       Regression test for RT #18561
+t/100-base/801-tr18561b.t      Regression test for RT #18561
+t/150-type/020-sixteen.t       Test 16-bit/sample images
+t/150-type/030-double.t                Test double/sample images
+t/150-type/040-palette.t       Test paletted images
+t/150-type/100-masked.t                Test masked images
+t/200-file/010-iolayer.t       Test Imager I/O layer objects
+t/200-file/100-files.t         Format independent file tests
+t/200-file/200-nojpeg.t                Test handling when jpeg not available
+t/200-file/210-nopng.t         Test handling when png not available
+t/200-file/220-nogif.t         Test handling when gif not available
+t/200-file/230-notiff.t                Test handling when tiff not available
+t/200-file/300-raw.t           Test raw file handling
+t/200-file/310-pnm.t           Test PNM file handling
+t/200-file/320-bmp.t           Test BMP file handling
+t/200-file/330-tga.t           Test TGA file handling
+t/200-file/400-basic.t         Test basic operations across file formats
+t/250-draw/010-draw.t          Basic drawing tests
+t/250-draw/020-flood.t         Flood fill tests
+t/250-draw/030-paste.t         Test the paste() method
+t/250-draw/040-rubthru.t       Test the rubthrough() method
+t/250-draw/050-polyaa.t                polygon()
+t/250-draw/100-fill.t          fills
+t/250-draw/200-compose.t       compose()
+t/300-transform/010-scale.t    scale(), scaleX() and scaleY()
+t/300-transform/020-combine.t  Test combine() method
+t/300-transform/030-copyflip.t Test copy, flip, rotate, matrix_transform
+t/300-transform/040-crop.t
+t/300-transform/050-convert.t
+t/300-transform/060-map.t
+t/300-transform/500-trans.t    transform()
+t/300-transform/600-trans2.t   transform2() using RPN
+t/300-transform/610-postfix.t  more transform2() using RPN
+t/300-transform/620-infix.t    transform2() using infix
+t/300-transform/630-assem.t    transform2() using assembler
+t/350-font/010-font.t          General font interface tests
+t/350-font/020-tt.t            low level FT1 tests
+t/350-font/030-ttoo.t          OO level FT1 tests
+t/350-font/040-ttstd.t         Standard font tests for TT
+t/350-font/100-texttools.t     Test text wrapping
+t/400-filter/010-filters.t     Consolidated filter tests (needs to split)
+t/450-api/100-inline.t         Inline::C integration and API
+t/450-api/110-inlinectx.t      context APIs
+t/850-thread/010-base.t                Test wrt to perl threads
+t/850-thread/100-error.t       error stack handling with threads
+t/850-thread/110-log.t         log handling with threads
+t/900-util/010-test.t          Test Imager::Test
+t/900-util/020-error.t         Error stack
+t/900-util/030-log.t           log
+t/900-util/040-limit.t         file size limits
+t/900-util/050-matrix.t                Imager::Matrix2d
+t/900-util/060-extutil.t       Imager::ExtUtils
+t/900-util/060-hlines.t                hlines.c internal API
+t/950-kwalitee/010-pod.t       Test POD with Test::Pod
+t/950-kwalitee/020-samples.t   Check samples are in samples/README
+t/950-kwalitee/030-podcover.t  POD Coverage tests
+t/950-kwalitee/040-strict.t    Check use strict is usede
+t/950-kwalitee/050-meta.t      Check META.yml is valid
 t/GoodTestFont.pm              A dummy (hardly implemented) font driver.
 t/Pod/Coverage/Imager.pm
-t/t00basic.t
-t/t01introvert.t
-t/t020masked.t
-t/t021sixteen.t
-t/t022double.t                 Test double/sample images
-t/t023palette.t                        Test paletted images
-t/t03test.t                    Test Imager::Test
-t/t05error.t
-t/t07iolayer.t
-t/t080log.t
-t/t081error.t
-t/t082limit.t
-t/t1000files.t                 Format independent file tests
 t/t1000lib/Imager/File/BAD.pm  Test failing to load a file handler
-t/t101nojpeg.t                 Test handling when jpeg not available
-t/t102nopng.t                  Test handling when png not available
-t/t103raw.t
-t/t104ppm.t
-t/t105nogif.t                  Test handling when gif not available
-t/t106notiff.t                 Test handling when tiff not available
-t/t107bmp.t
-t/t108tga.t
-t/t15color.t
-t/t16matrix.t                  Tests Imager::Matrix2d
-t/t20fill.t                    Tests fills
-t/t21draw.t                    Basic drawing tests
-t/t22flood.t                   Flood fill tests
-t/t31font.t                    General font interface tests
-t/t35ttfont.t
-t/t36oofont.t
-t/t37std.t                     Standard font tests for TT
-t/t40scale.t
-t/t50basicoo.t
-t/t55trans.t
-t/t56postfix.t
-t/t57infix.t
-t/t58trans2.t
-t/t59assem.t
-t/t61filters.t
-t/t62compose.t
-t/t63combine.t                 Test combine() method
-t/t64copyflip.t                        Test copy, flip, rotate, matrix_transform
-t/t65crop.t
-t/t66paste.t
-t/t67convert.t
-t/t68map.t
-t/t69rubthru.t
-t/t75polyaa.t
-t/t80texttools.t               Test text wrapping
-t/t81hlines.t                  Test hlines.c
-t/t82inline.t                  Test Inline::C integration
-t/t83extutil.t                 Test Imager::ExtUtils
-t/t84inlinectx.t
-t/t90cc.t
-t/t91pod.t                     Test POD with Test::Pod
-t/t92samples.t
-t/t93podcover.t                        POD Coverage tests
-t/t94kwalitee.t                        Various "kwalitee" tests
-t/t95log.t
-t/t98meta.t
-t/t99thread.t                  Test wrt to perl threads
-t/tr18561.t                    Regression tests
-t/tr18561b.t
 T1/fontfiles/dcr10.afm
 T1/fontfiles/dcr10.pfb
 T1/fontfiles/ExistenceTest.afm please edit ExistenceTest.sfd in CVS
@@ -514,7 +514,7 @@ W32/lib/Imager/Font/Win32.pm
 W32/Makefile.PL
 W32/README
 W32/t/t10win32.t               Tests Win32 GDI font support
-W32/t/t90std.t                         Standard font tests for W32
+W32/t/t90std.t                 Standard font tests for W32
 W32/W32.pm
 W32/W32.xs
 W32/win32.c                    Implements font support through Win32 GDI
index b1d5a89..96d847e 100644 (file)
@@ -10,6 +10,9 @@
 # unshipped test images
 ^xtestimg/
 
+# unshipped tests
+^xt/
+
 # base for some other images
 ^testimg/pbm_base\.pgm$
 
@@ -37,7 +40,6 @@
 ^fileformatdocs/
 ^extraimages/
 ^fontfiles/.*\.sfd$
-^t/x.*\.t$
 ^imcover.perl$
 
 # might distribute one day
@@ -99,6 +101,9 @@ Makefile\.old$
 # generated if we build them in their own directory
 ^(PNG|TIFF|FT2|W32|GIF)/blib/
 
+# not shipped with Imager itself
+^(PNG|TIFF|FT2|W32|GIF)/MANIFEST
+
 # generated from .im files
 ^combine\.c$
 ^compose\.c$
@@ -134,4 +139,7 @@ Makefile\.old$
 
 # sub-module build junk
 \.bak$
-MYMETA.json
\ No newline at end of file
+MYMETA.json
+
+# dist dir
+^Imager-[01]\.[0-9]+/
\ No newline at end of file
index 39a0278..35d80ba 100644 (file)
@@ -201,6 +201,11 @@ if ($trace_context) {
   $CFLAGS .= " -DIMAGER_TRACE_CONTEXT";
 }
 
+my $tests = 't/*.t t/*/*.t';
+if (-d "xt" && scalar(() = glob("xt/*.t"))) {
+  $tests .= " xt/*.t";
+}
+
 my %opts=
   (
    'NAME'         => 'Imager',
@@ -218,6 +223,7 @@ my %opts=
     'XSLoader'    => 0,
    },
    TYPEMAPS       => \@typemaps,
+   test =>        { TESTS => $tests },
   );
 
 if ($coverage) {
diff --git a/t/000-load.t b/t/000-load.t
new file mode 100644 (file)
index 0000000..883af43
--- /dev/null
@@ -0,0 +1,19 @@
+#!perl -w
+use strict;
+use Test::More tests => 15;
+
+use_ok('Imager');
+use_ok('Imager::Font');
+use_ok('Imager::Color');
+use_ok('Imager::Color::Float');
+use_ok('Imager::Color::Table');
+use_ok('Imager::Matrix2d');
+use_ok('Imager::ExtUtils');
+use_ok('Imager::Expr');
+use_ok('Imager::Expr::Assem');
+use_ok('Imager::Font::BBox');
+use_ok('Imager::Font::Wrap');
+use_ok('Imager::Fountain');
+use_ok('Imager::Regops');
+use_ok('Imager::Test');
+use_ok('Imager::Transform');
diff --git a/t/100-base/010-introvert.t b/t/100-base/010-introvert.t
new file mode 100644 (file)
index 0000000..d040eaf
--- /dev/null
@@ -0,0 +1,1160 @@
+#!perl -w
+# t/t01introvert.t - tests internals of image formats
+# to make sure we get expected values
+
+use strict;
+use Test::More tests => 466;
+
+BEGIN { use_ok(Imager => qw(:handy :all)) }
+
+use Imager::Test qw(image_bounds_checks is_color3 is_color4 is_fcolor4 color_cmp mask_tests is_fcolor3);
+
+-d "testout" or mkdir "testout";
+
+Imager->open_log(log => "testout/t01introvert.log");
+
+my $im_g = Imager::ImgRaw::new(100, 101, 1);
+
+my $red = NC(255, 0, 0);
+my $green = NC(0, 255, 0);
+my $blue = NC(0, 0, 255);
+
+use Imager::Color::Float;
+my $f_black = Imager::Color::Float->new(0, 0, 0);
+my $f_red = Imager::Color::Float->new(1.0, 0, 0);
+my $f_green = Imager::Color::Float->new(0, 1.0, 0);
+my $f_blue = Imager::Color::Float->new(0, 0, 1.0);
+
+is(Imager::i_img_getchannels($im_g), 1, "1 channel image channel count");
+ok(Imager::i_img_getmask($im_g) & 1, "1 channel image mask");
+ok(!Imager::i_img_virtual($im_g), "1 channel image not virtual");
+is(Imager::i_img_bits($im_g), 8, "1 channel image has 8 bits/sample");
+is(Imager::i_img_type($im_g), 0, "1 channel image is direct");
+is(Imager::i_img_get_width($im_g), 100, "100 pixels wide");
+is(Imager::i_img_get_height($im_g), 101, "101 pixels high");
+
+my @ginfo = Imager::i_img_info($im_g);
+is($ginfo[0], 100, "1 channel image width");
+is($ginfo[1], 101, "1 channel image height");
+
+undef $im_g; # can we check for release after this somehow?
+
+my $im_rgb = Imager::ImgRaw::new(100, 101, 3);
+
+is(Imager::i_img_getchannels($im_rgb), 3, "3 channel image channel count");
+is((Imager::i_img_getmask($im_rgb) & 7), 7, "3 channel image mask");
+is(Imager::i_img_bits($im_rgb), 8, "3 channel image has 8 bits/sample");
+is(Imager::i_img_type($im_rgb), 0, "3 channel image is direct");
+
+undef $im_rgb;
+
+my $im_pal = Imager::i_img_pal_new(100, 101, 3, 256);
+
+ok($im_pal, "make paletted image");
+is(Imager::i_img_getchannels($im_pal), 3, "pal img channel count");
+is(Imager::i_img_bits($im_pal), 8, "pal img bits");
+is(Imager::i_img_type($im_pal), 1, "pal img is paletted");
+
+my $red_idx = check_add($im_pal, $red, 0);
+my $green_idx = check_add($im_pal, $green, 1);
+my $blue_idx = check_add($im_pal, $blue, 2);
+
+# basic writing of palette indicies
+# fill with red
+is(Imager::i_ppal($im_pal, 0, 0, ($red_idx) x 100), 100, 
+   "write red 100 times");
+# and blue
+is(Imager::i_ppal($im_pal, 50, 0, ($blue_idx) x 50), 50,
+   "write blue 50 times");
+
+# make sure we get it back
+my @pals = Imager::i_gpal($im_pal, 0, 100, 0);
+ok(!grep($_ != $red_idx, @pals[0..49]), "check for red");
+ok(!grep($_ != $blue_idx, @pals[50..99]), "check for blue");
+is(Imager::i_gpal($im_pal, 0, 100, 0), "\0" x 50 . "\2" x 50, 
+   "gpal in scalar context");
+my @samp = Imager::i_gsamp($im_pal, 0, 100, 0, [ 0, 1, 2 ]);
+is(@samp, 300, "gsamp count in list context");
+my @samp_exp = ((255, 0, 0) x 50, (0, 0, 255) x 50);
+is_deeply(\@samp, \@samp_exp, "gsamp list deep compare");
+my $samp = Imager::i_gsamp($im_pal, 0, 100, 0, [ 0, 1, 2 ]);
+is(length($samp), 300, "gsamp scalar length");
+is($samp, "\xFF\0\0" x 50 . "\0\0\xFF" x 50, "gsamp scalar bytes");
+
+# reading indicies as colors
+my $c_red = Imager::i_get_pixel($im_pal, 0, 0);
+ok($c_red, "got the red pixel");
+is_color3($c_red, 255, 0, 0, "and it's red");
+my $c_blue = Imager::i_get_pixel($im_pal, 50, 0);
+ok($c_blue, "got the blue pixel");
+is_color3($c_blue, 0, 0, 255, "and it's blue");
+
+# drawing with colors
+ok(Imager::i_ppix($im_pal, 0, 0, $green) == 0, "draw with color in palette");
+# that was in the palette, should still be paletted
+is(Imager::i_img_type($im_pal), 1, "image still paletted");
+
+my $c_green = Imager::i_get_pixel($im_pal, 0, 0);
+ok($c_green, "got green pixel");
+is_color3($c_green, 0, 255, 0, "and it's green");
+
+is(Imager::i_colorcount($im_pal), 3, "still 3 colors in palette");
+is(Imager::i_findcolor($im_pal, $green), 1, "and green is the second");
+
+my $black = NC(0, 0, 0);
+# this should convert the image to RGB
+ok(Imager::i_ppix($im_pal, 1, 0, $black) == 0, "draw with black (not in palette)");
+is(Imager::i_img_type($im_pal), 0, "pal img shouldn't be paletted now");
+
+{
+  my %quant =
+    (
+     colors => [$red, $green, $blue, $black],
+     make_colors => 'none',
+    );
+  my $im_pal2 = Imager::i_img_to_pal($im_pal, \%quant);
+  ok($im_pal2, "got an image from quantizing");
+  is(@{$quant{colors}}, 4, "quant has the right number of colours");
+  is(Imager::i_colorcount($im_pal2), 4, "and so does the image");
+  my @colors = Imager::i_getcolors($im_pal2, 0, 4);
+  my ($first) = Imager::i_getcolors($im_pal2, 0);
+  my @first = $colors[0]->rgba;
+  is_color3($first, $first[0], $first[1], $first[2],
+          "check first color is first for multiple or single fetch");
+  is_color3($colors[0], 255, 0, 0, "still red");
+  is_color3($colors[1], 0, 255, 0, "still green");
+  is_color3($colors[2], 0, 0, 255, "still blue");
+  is_color3($colors[3], 0, 0, 0, "still black");
+  my @samples = Imager::i_gsamp($im_pal2, 0, 100, 0, [ 0, 1, 2 ]);
+  my @expect = unpack("C*", "\0\xFF\0\0\0\0"."\xFF\0\0" x 48 . "\0\0\xFF" x 50);
+  my $match_list = is_deeply(\@samples, \@expect, "colors are still correct");
+  my $samples = Imager::i_gsamp($im_pal2, 0, 100, 0, [ 0, 1, 2 ]);
+  my $match_scalar = is_deeply([ unpack("C*", $samples) ],
+                              \@expect, "colors are still correct (scalar)");
+  unless ($match_list && $match_scalar) {
+    # this has been failing on a particular smoker, provide more
+    # diagnostic information
+    print STDERR "Pallete:\n";
+    print STDERR "  $_: ", join(",", $colors[$_]->rgba), "\n" for 0..$#colors;
+    print STDERR "Samples (list): ", join(",", @samples), "\n";
+    print STDERR "Samples (scalar): ", join(",", unpack("C*", $samples)), "\n";
+    print STDERR "Indexes: ", join(",", Imager::i_gpal($im_pal2, 0, 100, 0)), "\n";
+  }
+}
+
+# test the OO interfaces
+my $impal2 = Imager->new(type=>'pseudo', xsize=>200, ysize=>201);
+ok($impal2, "make paletted via OO")
+  or diag(Imager->errstr);
+is($impal2->getchannels, 3, "check channels");
+is($impal2->bits, 8, "check bits");
+is($impal2->type, 'paletted', "check type");
+is($impal2->getwidth, 200, "check width");
+is($impal2->getheight, 201, "check height");
+
+{
+  my $red_idx = $impal2->addcolors(colors=>[$red]);
+  ok($red_idx, "add red to OO");
+  is(0+$red_idx, 0, "and it's expected index for red");
+  my $blue_idx = $impal2->addcolors(colors=>[$blue, $green]);
+  ok($blue_idx, "add blue/green via OO");
+  is($blue_idx, 1, "and it's expected index for blue");
+  my $green_idx = $blue_idx + 1;
+  my $c = $impal2->getcolors(start=>$green_idx);
+  is_color3($c, 0, 255, 0, "found green where expected");
+  my @cols = $impal2->getcolors;
+  is(@cols, 3, "got 3 colors");
+  my @exp = ( $red, $blue, $green );
+  my $good = 1;
+  for my $i (0..2) {
+    if (color_cmp($cols[$i], $exp[$i])) {
+      $good = 0;
+      last;
+    }
+  }
+  ok($good, "all colors in palette as expected");
+  is($impal2->colorcount, 3, "and colorcount returns 3");
+  is($impal2->maxcolors, 256, "maxcolors as expected");
+  is($impal2->findcolor(color=>$blue), 1, "findcolors found blue");
+  ok($impal2->setcolors(start=>0, colors=>[ $blue, $red ]),
+     "we can setcolors");
+
+  # make an rgb version
+  my $imrgb2 = $impal2->to_rgb8()
+    or diag($impal2->errstr);
+  is($imrgb2->type, 'direct', "converted is direct");
+
+  # and back again, specifying the palette
+  my @colors = ( $red, $blue, $green );
+  my $impal3 = $imrgb2->to_paletted(colors=>\@colors,
+                                    make_colors=>'none',
+                                    translate=>'closest');
+  ok($impal3, "got a paletted image from conversion");
+  dump_colors(@colors);
+  print "# in image\n";
+  dump_colors($impal3->getcolors);
+  is($impal3->colorcount, 3, "new image has expected color table size");
+  is($impal3->type, 'paletted', "and is paletted");
+}
+
+{
+  my $im = Imager->new;
+  ok($im, "make empty image");
+  ok(!$im->to_rgb8, "convert to rgb8");
+  is($im->errstr, "to_rgb8: empty input image", "check message");
+  is($im->bits, undef, "can't call bits on an empty image");
+  is($im->errstr, "bits: empty input image", "check message");
+  is($im->type, undef, "can't call type on an empty image");
+  is($im->errstr, "type: empty input image", "check message");
+  is($im->virtual, undef, "can't call virtual on an empty image");
+  is($im->errstr, "virtual: empty input image", "check message");
+  is($im->is_bilevel, undef, "can't call virtual on an empty image");
+  is($im->errstr, "is_bilevel: empty input image", "check message");
+  ok(!$im->getscanline(y => 0), "can't call getscanline on an empty image");
+  is($im->errstr, "getscanline: empty input image", "check message");
+  ok(!$im->setscanline(y => 0, pixels => [ $red, $blue ]),
+     "can't call setscanline on an empty image");
+  is($im->errstr, "setscanline: empty input image", "check message");
+  ok(!$im->getsamples(y => 0), "can't call getsamples on an empty image");
+  is($im->errstr, "getsamples: empty input image", "check message");
+  is($im->getwidth, undef, "can't get width of empty image");
+  is($im->errstr, "getwidth: empty input image", "check message");
+  is($im->getheight, undef, "can't get height of empty image");
+  is($im->errstr, "getheight: empty input image", "check message");
+  is($im->getchannels, undef, "can't get channels of empty image");
+  is($im->errstr, "getchannels: empty input image", "check message");
+  is($im->getmask, undef, "can't get mask of empty image");
+  is($im->errstr, "getmask: empty input image", "check message");
+  is($im->setmask, undef, "can't set mask of empty image");
+  is($im->errstr, "setmask: empty input image", "check message");
+}
+
+{ # basic checks, 8-bit direct images
+  my $im = Imager->new(xsize => 2, ysize => 3);
+  ok($im, 'create 8-bit direct image');
+  is($im->bits, 8, '8 bits');
+  ok(!$im->virtual, 'not virtual');
+  is($im->type, 'direct', 'direct image');
+  ok(!$im->is_bilevel, 'not mono');
+}
+
+ok(!Imager->new(xsize=>0, ysize=>1), "fail to create 0 height image");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
+       "0 height error message check");
+ok(!Imager->new(xsize=>1, ysize=>0), "fail to create 0 width image");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
+       "0 width error message check");
+ok(!Imager->new(xsize=>-1, ysize=>1), "fail to create -ve height image");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
+       "-ve width error message check");
+ok(!Imager->new(xsize=>1, ysize=>-1), "fail to create -ve width image");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
+       "-ve height error message check");
+ok(!Imager->new(xsize=>-1, ysize=>-1), "fail to create -ve width/height image");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
+       "-ve width/height error message check");
+
+ok(!Imager->new(xsize=>1, ysize=>1, channels=>0),
+   "fail to create a zero channel image");
+cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
+       "out of range channel message check");
+ok(!Imager->new(xsize=>1, ysize=>1, channels=>5),
+   "fail to create a five channel image");
+cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
+       "out of range channel message check");
+
+{
+  # https://rt.cpan.org/Ticket/Display.html?id=8213
+  # check for handling of memory allocation of very large images
+  # only test this on 32-bit machines - on a 64-bit machine it may
+  # result in trying to allocate 4Gb of memory, which is unfriendly at
+  # least and may result in running out of memory, causing a different
+  # type of exit
+ SKIP:
+  {
+    use Config;
+    skip("don't want to allocate 4Gb", 8) unless $Config{ptrsize} == 4;
+
+    my $uint_range = 256 ** $Config{intsize};
+    print "# range $uint_range\n";
+    my $dim1 = int(sqrt($uint_range))+1;
+    
+    my $im_b = Imager->new(xsize=>$dim1, ysize=>$dim1, channels=>1);
+    is($im_b, undef, "integer overflow check - 1 channel");
+    
+    $im_b = Imager->new(xisze=>$dim1, ysize=>1, channels=>1);
+    ok($im_b, "but same width ok");
+    $im_b = Imager->new(xisze=>1, ysize=>$dim1, channels=>1);
+    ok($im_b, "but same height ok");
+    cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
+           "check the error message");
+
+    # do a similar test with a 3 channel image, so we're sure we catch
+    # the same case where the third dimension causes the overflow
+    my $dim3 = int(sqrt($uint_range / 3))+1;
+    
+    $im_b = Imager->new(xsize=>$dim3, ysize=>$dim3, channels=>3);
+    is($im_b, undef, "integer overflow check - 3 channel");
+    
+    $im_b = Imager->new(xisze=>$dim3, ysize=>1, channels=>3);
+    ok($im_b, "but same width ok");
+    $im_b = Imager->new(xisze=>1, ysize=>$dim3, channels=>3);
+    ok($im_b, "but same height ok");
+
+    cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
+           "check the error message");
+  }
+}
+
+{ # http://rt.cpan.org/NoAuth/Bug.html?id=9672
+  my $warning;
+  local $SIG{__WARN__} = 
+    sub { 
+      $warning = "@_";
+      my $printed = $warning;
+      $printed =~ s/\n$//;
+      $printed =~ s/\n/\n\#/g; 
+      print "# ",$printed, "\n";
+    };
+  my $img = Imager->new(xsize=>10, ysize=>10);
+  $img->to_rgb8(); # doesn't really matter what the source is
+  cmp_ok($warning, '=~', 'void', "correct warning");
+  cmp_ok($warning, '=~', 'introvert\\.t', "correct file");
+}
+
+{ # http://rt.cpan.org/NoAuth/Bug.html?id=11860
+  my $im = Imager->new(xsize=>2, ysize=>2);
+  $im->setpixel(x=>0, 'y'=>0, color=>$red);
+  $im->setpixel(x=>1, 'y'=>0, color=>$blue);
+
+  my @row = Imager::i_glin($im->{IMG}, 0, 2, 0);
+  is(@row, 2, "got 2 pixels from i_glin");
+  is_color3($row[0], 255, 0, 0, "red first");
+  is_color3($row[1], 0, 0, 255, "then blue");
+}
+
+{ # general tag tests
+  
+  # we don't care much about the image itself
+  my $im = Imager::ImgRaw::new(10, 10, 1);
+
+  ok(Imager::i_tags_addn($im, 'alpha', 0, 101), "i_tags_addn(...alpha, 0, 101)");
+  ok(Imager::i_tags_addn($im, undef, 99, 102), "i_tags_addn(...undef, 99, 102)");
+  is(Imager::i_tags_count($im), 2, "should have 2 tags");
+  ok(Imager::i_tags_addn($im, undef, 99, 103), "i_tags_addn(...undef, 99, 103)");
+  is(Imager::i_tags_count($im), 3, "should have 3 tags, despite the dupe");
+  is(Imager::i_tags_find($im, 'alpha', 0), '0 but true', "find alpha");
+  is(Imager::i_tags_findn($im, 99, 0), 1, "find 99");
+  is(Imager::i_tags_findn($im, 99, 2), 2, "find 99 again");
+  is(Imager::i_tags_get($im, 0), 101, "check first");
+  is(Imager::i_tags_get($im, 1), 102, "check second");
+  is(Imager::i_tags_get($im, 2), 103, "check third");
+
+  ok(Imager::i_tags_add($im, 'beta', 0, "hello", 0), 
+     "add string with string key");
+  ok(Imager::i_tags_add($im, 'gamma', 0, "goodbye", 0),
+     "add another one");
+  ok(Imager::i_tags_add($im, undef, 199, "aloha", 0),
+     "add one keyed by number");
+  is(Imager::i_tags_find($im, 'beta', 0), 3, "find beta");
+  is(Imager::i_tags_find($im, 'gamma', 0), 4, "find gamma");
+  is(Imager::i_tags_findn($im, 199, 0), 5, "find 199");
+  ok(Imager::i_tags_delete($im, 2), "delete");
+  is(Imager::i_tags_find($im, 'beta', 0), 2, 'find beta after deletion');
+  ok(Imager::i_tags_delbyname($im, 'beta'), 'delete beta by name');
+  is(Imager::i_tags_find($im, 'beta', 0), undef, 'beta not there now');
+  is(Imager::i_tags_get_string($im, "gamma"), "goodbye", 
+     'i_tags_get_string() on a string');
+  is(Imager::i_tags_get_string($im, 99), 102, 
+     'i_tags_get_string() on a number entry');
+  ok(Imager::i_tags_delbycode($im, 99), 'delete by code');
+  is(Imager::i_tags_findn($im, 99, 0), undef, '99 not there now');
+  is(Imager::i_tags_count($im), 3, 'final count of 3');
+}
+
+{ 
+  print "# low-level scan line function tests\n";
+  my $im = Imager::ImgRaw::new(10, 10, 4);
+  Imager::i_ppix($im, 5, 0, $red);
+
+  # i_glin/i_glinf
+  my @colors = Imager::i_glin($im, 0, 10, 0);
+  is_deeply([ (0) x 20, (255, 0, 0, 255), (0) x 16 ], 
+           [ map $_->rgba, @colors ],
+           "i_glin - list context");
+  my $colors = Imager::i_glin($im, 0, 10, 0);
+  is("00" x 20 . "FF0000FF" . "00" x 16, 
+     uc unpack("H*", $colors), "i_glin - scalar context");
+  my @fcolors = Imager::i_glinf($im, 0, 10, 0);
+  is_deeply([ (0.0) x 20, (1.0, 0, 0, 1.0) , (0) x 16 ],
+           [ map $_->rgba, @fcolors ],
+           "i_glinf - list context");
+  my $fcolors = Imager::i_glinf($im, 0, 10, 0);
+  is_deeply([ (0.0) x 20, (1.0, 0, 0, 1.0) , (0) x 16 ],
+           [ unpack "d*", $fcolors ],
+           "i_glinf - scalar context");
+
+  # i_plin/i_plinf
+  my @plin_colors = (($black) x 4, $red, $blue, ($black) x 4);
+  is(Imager::i_plin($im, 0, 1, @plin_colors),
+     10, "i_plin - pass in a list");
+  # make sure we get it back
+  is_deeply([ map [ $_->rgba ], @plin_colors ],
+           [ map [ $_->rgba ], Imager::i_glin($im, 0, 10, 1) ],
+           "check i_plin wrote to the image");
+  my @scalar_plin = 
+    (
+     (0,0,0,0) x 4, 
+     (0, 255, 0, 255),
+     (0, 0, 255, 255), 
+     (0, 0, 0, 0) x 4,
+    );
+  is(Imager::i_plin($im, 0, 2, pack("C*", @scalar_plin)),
+     10, "i_plin - pass in a scalar");
+  is_deeply(\@scalar_plin,
+           [ map $_->rgba , Imager::i_glin($im, 0, 10, 2) ],
+           "check i_plin scalar wrote to the image");
+
+  my @plinf_colors = # Note: only 9 pixels
+    ( 
+     ($f_blue) x 4, 
+     $f_red, 
+     ($f_black) x 3, 
+     $f_black
+    );
+  is(Imager::i_plinf($im, 0, 3, @plinf_colors), 9,
+     "i_plinf - list");
+  is_deeply([ map $_->rgba, Imager::i_glinf($im, 0, 9, 3) ],
+           [ map $_->rgba, @plinf_colors ],
+           "check colors were written");
+  my @scalar_plinf =
+    (
+     ( 1.0, 1.0,   0, 1.0 ) x 3,
+     (   0, 1.0, 1.0, 1.0 ) x 2,
+     (   0,   0,   0,   0 ),
+     ( 1.0,   0, 1.0, 1.0 ),
+    );
+  is(Imager::i_plinf($im, 2, 4, pack("d*", @scalar_plinf)),
+     7, "i_plinf - scalar");
+  is_deeply(\@scalar_plinf,
+           [ map $_->rgba, Imager::i_glinf($im, 2, 9, 4) ],
+           "check colors were written");
+
+  is_deeply([ Imager::i_gsamp($im, 0, 10, 0, [ 0, 3 ]) ],
+           [ (0, 0) x 5, (255, 255), (0, 0) x 4 ],
+           "i_gsamp list context");
+  is("0000" x 5 . "FFFF" . "0000" x 4,
+     uc unpack("H*", Imager::i_gsamp($im, 0, 10, 0, [ 0, 3 ])),
+     "i_gsamp scalar context");
+  is_deeply([ Imager::i_gsampf($im, 2, 9, 4, [ 0, 2, 3 ]) ],
+           [ (1.0, 0, 1.0) x 3, (0, 1.0, 1.0) x 2, (0, 0, 0),
+             (1.0, 1.0, 1.0) ], "i_gsampf - list context");
+  is_deeply([ unpack("d*", Imager::i_gsampf($im, 2, 9, 4, [ 0, 2, 3 ])) ],
+           [ (1.0, 0, 1.0) x 3, (0, 1.0, 1.0) x 2, (0, 0, 0),
+              (1.0, 1.0, 1.0) ], "i_gsampf - scalar context");
+  print "# end low-level scan-line function tests\n";
+}
+
+my $psamp_outside_error = "Image position outside of image";
+{ # psamp
+  print "# psamp\n";
+  my $imraw = Imager::ImgRaw::new(10, 20, 3);
+  {
+    is(Imager::i_psamp($imraw, 0, 2, undef, [ 255, 128, 64 ]), 3,
+       "i_psamp def channels, 3 samples");
+    is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
+             "check color written");
+    Imager::i_img_setmask($imraw, 5);
+    is(Imager::i_psamp($imraw, 1, 3, undef, [ 64, 128, 192 ]), 3,
+       "i_psamp def channels, 3 samples, masked");
+    is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 192,
+             "check color written");
+    is(Imager::i_psamp($imraw, 1, 7, [ 0, 1, 2 ], [ 64, 128, 192 ]), 3,
+       "i_psamp channels listed, 3 samples, masked");
+    is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 192,
+             "check color written");
+    Imager::i_img_setmask($imraw, ~0);
+    is(Imager::i_psamp($imraw, 2, 4, [ 0, 1 ], [ 255, 128, 64, 32 ]), 4,
+       "i_psamp channels [0, 1], 4 samples");
+    is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
+             "check first color written");
+    is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
+             "check second color written");
+    is(Imager::i_psamp($imraw, 0, 5, [ 0, 1, 2 ], [ (128, 63, 32) x 10 ]), 30,
+       "write a full row");
+    is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
+             [ (128, 63, 32) x 10 ],
+             "check full row");
+    is(Imager::i_psamp($imraw, 8, 8, [ 0, 1, 2 ],
+                      [ 255, 128, 32, 64, 32, 16, 32, 16, 8 ]),
+       6, "i_psamp channels [0, 1, 2], 9 samples, but room for 6");
+    is(Imager::i_psamp($imraw, 4, 6, undef, [ 0 .. 18 ], 1), 18,
+       "psamp with offset");
+    is_deeply([ Imager::i_gsamp($imraw, 0, 10, 6, undef) ],
+             [ (0) x 12, 1 .. 18 ],
+             "check result");
+    is(Imager::i_psamp($imraw, 4, 11, undef, [ 0 .. 18 ], 1, 3), 9,
+       "psamp with offset and width");
+    is_deeply([ Imager::i_gsamp($imraw, 0, 10, 11, undef) ],
+             [ (0) x 12, 1 .. 9, (0) x 9 ],
+             "check result");
+  }
+  { # errors we catch
+    is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, 3 ], [ 255, 128, 32 ]),
+       undef, "i_psamp channels [0, 1, 3], 3 samples (invalid channel number)");
+    is(_get_error(), "No channel 3 in this image",
+       "check error message");
+    is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, -1 ], [ 255, 128, 32 ]),
+       undef, "i_psamp channels [0, 1, -1], 3 samples (invalid channel number)");
+    is(_get_error(), "No channel -1 in this image",
+       "check error message");
+    is(Imager::i_psamp($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
+       "negative y");
+    is(_get_error(), $psamp_outside_error,
+       "check error message");
+    is(Imager::i_psamp($imraw, 0, 20, undef, [ 0, 0, 0 ]), undef,
+       "y overflow");
+    is(_get_error(), $psamp_outside_error,
+       "check error message");
+    is(Imager::i_psamp($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
+       "negative x");
+    is(_get_error(), $psamp_outside_error,
+       "check error message");
+    is(Imager::i_psamp($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
+       "x overflow");
+    is(_get_error(), $psamp_outside_error,
+       "check error message");
+  }
+  { # test the im_sample_list typemap
+    ok(!eval { Imager::i_psamp($imraw, 9, 9, [ 0 ], undef); 1 },
+       "pass undef as the sample list");
+    like($@, qr/data must be a scalar or an arrayref/,
+        "check message");
+    ok(!eval { Imager::i_psamp($imraw, 9, 9, [ 0 ], { a => 1 }); 1 },
+       "hashref as the sample list");
+    like($@, qr/data must be a scalar or an arrayref/,
+        "check message");
+    ok(!eval { Imager::i_psamp($imraw, 9, 9, [ 0 ], []); 1 },
+       "empty sample list");
+    like($@, qr/i_psamp: no samples provided in data/,
+        "check message");
+    ok(!eval { Imager::i_psamp($imraw, 9, 9, [ 0 ], ""); 1 },
+       "empty scalar sample list");
+    like($@, qr/i_psamp: no samples provided in data/,
+        "check message");
+
+    # not the typemap
+    is(Imager::i_psamp($imraw, 0, 8, undef, [ (0) x 3 ], -1), undef,
+       "negative offset");
+    is(_get_error(), "offset must be non-negative",
+       "check message");
+
+    is(Imager::i_psamp($imraw, 0, 8, undef, [ (0) x 3 ], 4), undef,
+       "too high offset");
+    is(_get_error(), "offset greater than number of samples supplied",
+       "check message");
+  }
+  print "# end psamp tests\n";
+}
+
+{ # psampf
+  print "# psampf\n";
+  my $imraw = Imager::ImgRaw::new(10, 20, 3);
+  {
+    is(Imager::i_psampf($imraw, 0, 2, undef, [ 1, 0.5, 0.25 ]), 3,
+       "i_psampf def channels, 3 samples");
+    is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
+             "check color written");
+    Imager::i_img_setmask($imraw, 5);
+    is(Imager::i_psampf($imraw, 1, 3, undef, [ 0.25, 0.5, 0.75 ]), 3,
+       "i_psampf def channels, 3 samples, masked");
+    is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 191,
+             "check color written");
+    is(Imager::i_psampf($imraw, 1, 7, [ 0, 1, 2 ], [ 0.25, 0.5, 0.75 ]), 3,
+       "i_psampf channels listed, 3 samples, masked");
+    is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 191,
+             "check color written");
+    Imager::i_img_setmask($imraw, ~0);
+    is(Imager::i_psampf($imraw, 2, 4, [ 0, 1 ], [ 1, 0.5, 0.25, 0.125 ]), 4,
+       "i_psampf channels [0, 1], 4 samples");
+    is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
+             "check first color written");
+    is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
+             "check second color written");
+    is(Imager::i_psampf($imraw, 0, 5, [ 0, 1, 2 ], [ (0.5, 0.25, 0.125) x 10 ]), 30,
+       "write a full row");
+    is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
+             [ (128, 64, 32) x 10 ],
+             "check full row");
+    is(Imager::i_psampf($imraw, 8, 8, [ 0, 1, 2 ],
+                       [ 1.0, 0.5, 0.125, 0.25, 0.125, 0.0625, 0.125, 0, 1 ]),
+       6, "i_psampf channels [0, 1, 2], 9 samples, but room for 6");
+    is(Imager::i_psampf($imraw, 4, 6, undef, [ map $_/254.9, 0 .. 18 ], 1), 18,
+       "psampf with offset");
+    is_deeply([ Imager::i_gsamp($imraw, 0, 10, 6, undef) ],
+             [ (0) x 12, 1 .. 18 ],
+             "check result");
+    is(Imager::i_psampf($imraw, 4, 11, undef, [ map $_/254.9, 0 .. 18 ], 1, 3), 9,
+       "psampf with offset and width");
+    is_deeply([ Imager::i_gsamp($imraw, 0, 10, 11, undef) ],
+             [ (0) x 12, 1 .. 9, (0) x 9 ],
+             "check result");
+  }
+  { # errors we catch
+    is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, 3 ], [ 1, 0.5, 0.125 ]),
+       undef, "i_psampf channels [0, 1, 3], 3 samples (invalid channel number)");
+    is(_get_error(), "No channel 3 in this image",
+       "check error message");
+    is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, -1 ], [ 1, 0.5, 0.125 ]),
+       undef, "i_psampf channels [0, 1, -1], 3 samples (invalid channel number)");
+    is(_get_error(), "No channel -1 in this image",
+       "check error message");
+    is(Imager::i_psampf($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
+       "negative y");
+    is(_get_error(), $psamp_outside_error,
+       "check error message");
+    is(Imager::i_psampf($imraw, 0, 20, undef, [ 0, 0, 0 ]), undef,
+       "y overflow");
+    is(_get_error(), $psamp_outside_error,
+       "check error message");
+    is(Imager::i_psampf($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
+       "negative x");
+    is(_get_error(), $psamp_outside_error,
+       "check error message");
+    is(Imager::i_psampf($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
+       "x overflow");
+    is(_get_error(), $psamp_outside_error,
+       "check error message");
+  }
+  { # test the im_fsample_list typemap
+    ok(!eval { Imager::i_psampf($imraw, 9, 9, [ 0 ], undef); 1 },
+       "pass undef as the sample list");
+    like($@, qr/data must be a scalar or an arrayref/,
+        "check message");
+    ok(!eval { Imager::i_psampf($imraw, 9, 9, [ 0 ], { a => 1 }); 1 },
+       "hashref as the sample list");
+    like($@, qr/data must be a scalar or an arrayref/,
+        "check message");
+    ok(!eval { Imager::i_psampf($imraw, 9, 9, [ 0 ], []); 1 },
+       "empty sample list");
+    like($@, qr/i_psampf: no samples provided in data/,
+        "check message");
+    ok(!eval { Imager::i_psampf($imraw, 9, 9, [ 0 ], ""); 1 },
+       "empty scalar sample list");
+    like($@, qr/i_psampf: no samples provided in data/,
+        "check message");
+
+    # not the typemap
+    is(Imager::i_psampf($imraw, 0, 8, undef, [ (0) x 3 ], -1), undef,
+       "negative offset");
+    is(_get_error(), "offset must be non-negative",
+       "check message");
+
+    is(Imager::i_psampf($imraw, 0, 8, undef, [ (0) x 3 ], 4), undef,
+       "too high offset");
+    is(_get_error(), "offset greater than number of samples supplied",
+       "check message");
+  }
+  print "# end psampf tests\n";
+}
+
+{
+  print "# OO level scanline function tests\n";
+  my $im = Imager->new(xsize=>10, ysize=>10, channels=>4);
+  $im->setpixel(color=>$red, 'x'=>5, 'y'=>0);
+  ok(!$im->getscanline(), "getscanline() - supply nothing, get nothing");
+  is($im->errstr, "missing y parameter", "check message");
+  is_deeply([ map [ $_->rgba ], $im->getscanline('y'=>0) ],
+           [ ([ 0,0,0,0]) x 5, [ 255, 0, 0, 255 ], ([ 0,0,0,0]) x 4 ],
+           "getscanline, list context, default x, width");
+  is_deeply([ map [ $_->rgba ], $im->getscanline('y'=>0, 'x'=>3) ],
+           [ ([0,0,0,0]) x 2, [ 255, 0, 0, 255 ], ([0,0,0,0]) x 4 ],
+           "getscanline, list context, default width");
+  is_deeply([ map [ $_->rgba ], $im->getscanline('y'=>0, 'x'=>4, width=>4) ],
+           [ [0,0,0,0], [ 255, 0, 0, 255 ], ([0,0,0,0]) x 2 ],
+           "getscanline, list context, no defaults");
+  is(uc unpack("H*",  $im->getscanline('y'=>0)),
+     "00000000" x 5 .  "FF0000FF" . "00000000" x 4,
+     "getscanline, scalar context, default x, width");
+  is_deeply([ map [ $_->rgba ], 
+             $im->getscanline('y'=>0, 'x'=>4, width=>4, type=>'float') ],
+           [ [0,0,0,0], [ 1.0, 0, 0, 1.0 ], ([0,0,0,0]) x 2 ],
+           "getscanline float, list context, no defaults");
+  is_deeply([ unpack "d*",
+             $im->getscanline('y'=>0, 'x'=>4, width=>4, type=>'float') ],
+           [ (0,0,0,0), ( 1.0, 0, 0, 1.0 ), (0,0,0,0) x 2 ],
+           "getscanline float, scalar context, no defaults");
+
+  ok(!$im->getscanline('y'=>0, type=>'invalid'),
+     "check invalid type checking");
+  like($im->errstr, qr/invalid type parameter/, 
+       "check message for invalid type");
+
+  my @plin_colors = (($black) x 4, $red, $blue, ($green) x 4);
+  is($im->setscanline('y'=>1, pixels=>\@plin_colors), 10,
+     "setscanline - arrayref, default x");
+  is_deeply([ map [ $_->rgba ], @plin_colors ],
+           [ map [ $_->rgba ], $im->getscanline('y'=>1) ],
+           "check colors were written");
+
+  my @plin_colors2 = ( $green, $red, $blue, $red );
+  is($im->setscanline('y'=>2, 'x'=>3, pixels=>\@plin_colors2), 4,
+     "setscanline - arrayref");
+
+  # using map instead of x here due to a bug in some versions of Test::More
+  # fixed in the latest Test::More
+  is_deeply([ ( map [ 0,0,0,0 ], 1..3), (map [ $_->rgba ], @plin_colors2),
+             ( map [ 0,0,0,0 ], 1..3) ],
+           [ map [ $_->rgba ], $im->getscanline('y'=>2) ],
+           "check write to middle of line");
+  
+  my $raw_colors = pack "H*", "FF00FFFF"."FF0000FF"."FFFFFFFF";
+  is($im->setscanline('y'=>3, 'x'=>2, pixels=>$raw_colors), 3,
+     "setscanline - scalar, default raw type")
+    or print "# ",$im->errstr,"\n";
+  is(uc unpack("H*", $im->getscanline('y'=>3, 'x'=>1, 'width'=>5)),
+     "00000000".uc(unpack "H*", $raw_colors)."00000000",
+     "check write");
+
+  # float colors
+  my @fcolors = ( $f_red, $f_blue, $f_black, $f_green );
+  is($im->setscanline('y'=>4, 'x'=>3, pixels=>\@fcolors), 4,
+     "setscanline - float arrayref");
+  is_deeply([ map [ $_->rgba ], @fcolors ],
+           [ map [ $_->rgba ], $im->getscanline('y'=>4, 'x'=>3, width=>4, type=>'float') ],
+           "check write");
+  # packed
+  my $packed_fcolors = pack "d*", map $_->rgba, @fcolors;
+  is($im->setscanline('y'=>5, 'x'=>4, pixels=>$packed_fcolors, type=>'float'), 4,
+     "setscanline - float scalar");
+  is_deeply([ map [ $_->rgba ], @fcolors ],
+           [ map [ $_->rgba ], $im->getscanline('y'=>5, 'x'=>4, width=>4, type=>'float') ],
+           "check write");
+
+  # get samples
+  is_deeply([ $im->getsamples('y'=>1, channels=>[ 0 ]) ],
+           [ map +($_->rgba)[0], @plin_colors ],
+           "get channel 0, list context, default x, width");
+  is_deeply([ unpack "C*", $im->getsamples('y'=>1, channels=>[0, 2]) ],
+           [ map { ($_->rgba)[0, 2] } @plin_colors ],
+           "get channel 0, 1, scalar context");
+  is_deeply([ $im->getsamples('y'=>4, 'x'=>3, width=>4, type=>'float',
+                             channels=>[1,3]) ],
+           [ map { ($_->rgba)[1,3] } @fcolors ],
+           "get channels 1,3, list context, float samples");
+  is_deeply([ unpack "d*", 
+             $im->getsamples('y'=>4, 'x'=>3, width=>4,
+                             type=>'float', channels=>[3,2,1,0]) ],
+           [ map { ($_->rgba)[3,2,1,0] } @fcolors ],
+           "get channels 3..0 as scalar, float samples");
+  
+  print "# end OO level scanline function tests\n";
+}
+
+{ # RT 74882
+  # for the non-gsamp_bits case with a target parameter it was
+  # treating the target parameter as a hashref
+  {
+    my $im = Imager->new(xsize => 10, ysize => 10);
+    my $c1 = NC(0, 63, 255);
+    my $c2 = NC(255, 128, 255);
+    is($im->setscanline(y => 1, pixels => [ ( $c1, $c2 ) x 5 ]),
+       10, "set some test data")
+      or diag "setscanline: ", $im->errstr;
+    my @target;
+    is($im->getsamples(y => 1, x => 1, target => \@target, width => 3),
+       9, "getsamples to target");
+    is_deeply(\@target, [ 255, 128, 255, 0, 63, 255, 255, 128, 255 ],
+             "check result");
+  }
+  {
+    my $im = Imager->new(xsize => 10, ysize => 10, bits => "double");
+    my $c1 = NCF(0, 0.25, 1.0);
+    my $c2 = NCF(1.0, 0.5, 1.0);
+    is($im->setscanline(y => 1, pixels => [ ( $c1, $c2 ) x 5 ]),
+       10, "set some test data")
+      or diag "setscanline: ", $im->errstr;
+    my @target;
+    is($im->getsamples(y => 1, x => 1, target => \@target, width => 3, type => "float"),
+       9, "getsamples to target");
+    is_deeply(\@target, [ 1.0, 0.5, 1.0, 0, 0.25, 1.0, 1.0, 0.5, 1.0 ],
+             "check result");
+  }
+}
+
+{ # to avoid confusion, i_glin/i_glinf modified to return 0 in unused
+  # channels at the perl level
+  my $im = Imager->new(xsize => 4, ysize => 4, channels => 2);
+  my $fill = Imager::Color->new(128, 255, 0, 0);
+  ok($im->box(filled => 1, color => $fill), 'fill it up');
+  my $data = $im->getscanline('y' => 0);
+  is(unpack("H*", $data), "80ff000080ff000080ff000080ff0000",
+     "check we get zeros");
+  my @colors = $im->getscanline('y' => 0);
+  is_color4($colors[0], 128, 255, 0, 0, "check object interface[0]");
+  is_color4($colors[1], 128, 255, 0, 0, "check object interface[1]");
+  is_color4($colors[2], 128, 255, 0, 0, "check object interface[2]");
+  is_color4($colors[3], 128, 255, 0, 0, "check object interface[3]");
+  
+  my $dataf = $im->getscanline('y' => 0, type => 'float');
+  # the extra pack/unpack is to force double precision rather than long
+  # double, otherwise the test fails
+  is_deeply([ unpack("d*", $dataf) ],
+           [ unpack("d*", pack("d*", ( 128.0 / 255.0, 1.0, 0, 0, ) x 4)) ],
+           "check we get zeroes (double)");
+  my @fcolors = $im->getscanline('y' => 0, type => 'float');
+  is_fcolor4($fcolors[0], 128.0/255.0, 1.0, 0, 0, "check object interface[0]");
+  is_fcolor4($fcolors[1], 128.0/255.0, 1.0, 0, 0, "check object interface[1]");
+  is_fcolor4($fcolors[2], 128.0/255.0, 1.0, 0, 0, "check object interface[2]");
+  is_fcolor4($fcolors[3], 128.0/255.0, 1.0, 0, 0, "check object interface[3]");
+}
+
+{ # check the channel mask function
+  
+  my $im = Imager->new(xsize => 10, ysize=>10, bits=>8);
+
+  mask_tests($im, 0.005);
+}
+
+{ # check bounds checking
+  my $im = Imager->new(xsize => 10, ysize => 10);
+
+  image_bounds_checks($im);
+}
+
+{ # setsamples() interface to psamp()
+  my $im = Imager->new(xsize => 10, ysize => 10);
+  is($im->setsamples(y => 1, x => 2, data => [ 1 .. 6 ]), 6,
+     "simple put (array), default channels");
+  is_deeply([ $im->getsamples(y => 1, x => 0) ],
+           [ (0) x 6, 1 .. 6, (0) x 18 ], "check they were stored");
+  is($im->setsamples(y => 3, x => 3, data => pack("C*", 2 .. 10 )), 9,
+     "simple put (scalar), default channels")
+    or diag $im->errstr;
+  is_deeply([ $im->getsamples(y => 3, x => 0) ],
+           [ (0) x 9, 2 .. 10, (0) x 12 ], "check they were stored");
+  is($im->setsamples(y => 4, x => 4, data => [ map $_ / 254.5, 1 .. 6 ], type => 'float'),
+     6, "simple put (float array), default channels");
+  is_deeply([ $im->getsamples(y => 4, x => 0) ],
+           [ (0) x 12, 1 .. 6, (0) x 12 ], "check they were stored");
+
+  is($im->setsamples(y => 5, x => 3, data => pack("d*", map $_ / 254.5, 1 .. 6), type => 'float'),
+     6, "simple put (float scalar), default channels");
+  is_deeply([ $im->getsamples(y => 5, x => 0) ],
+           [ (0) x 9, 1 .. 6, (0) x 15 ], "check they were stored");
+
+  is($im->setsamples(y => 7, x => 3, data => [ 0 .. 18 ], offset => 1), 18,
+     "setsamples offset");
+  is_deeply([ $im->getsamples(y => 7) ],
+           [ (0) x 9, 1 .. 18, (0) x 3 ],
+           "check result");
+
+  is($im->setsamples(y => 8, x => 3, data => [ map $_ / 254.9, 0 .. 18 ],
+                    offset => 1, type => 'float'),
+     18, "setsamples offset (float)");
+  is_deeply([ $im->getsamples(y => 8) ],
+           [ (0) x 9, 1 .. 18, (0) x 3 ],
+           "check result");
+
+  is_deeply([ $im->setsamples(y => 6, x => 10, data => [ (0) x 3 ]) ],
+           [], "check out of range result (8bit)");
+  is($im->errstr, $psamp_outside_error, "check error message");
+
+  is_deeply([ $im->setsamples(y => 6, x => 10, data => [ (0) x 3 ], type => "float") ],
+           [], "check out of range result (float)");
+  is($im->errstr, $psamp_outside_error, "check error message");
+
+  is_deeply([ $im->setsamples(y => 6, x => 2, channels => [0, 1, 3 ],
+                             data => [ (0) x 3 ]) ],
+           [], "check bad channels (8bit)");
+  is($im->errstr, "No channel 3 in this image",
+     "check error message");
+  
+  is_deeply([ $im->setsamples(y => 6, x => 2, channels => [0, 1, 3 ], 
+                             data => [ (0) x 3 ], type => "float") ],
+           [], "check bad channels (float)");
+  is($im->errstr, "No channel 3 in this image",
+     "check error message");
+
+  is($im->setsamples(y => 5, data => [ (0) x 3 ], type => "bad"),
+     undef, "setsamples with bad type");
+  is($im->errstr, "setsamples: type parameter invalid",
+     "check error message");
+  is($im->setsamples(y => 5),
+     undef, "setsamples with no data");
+  is($im->errstr, "setsamples: data parameter missing",
+     "check error message");
+
+  is($im->setsamples(y => 5, data => undef),
+     undef, "setsamples with undef data");
+  is($im->errstr, "setsamples: data parameter not defined",
+     "check error message");
+
+  my $imempty = Imager->new;
+  is($imempty->setsamples(y => 0, data => [ (0) x 3 ]), undef,
+     "setsamples to empty image");
+  is($imempty->errstr, "setsamples: empty input image",
+     "check error message");
+}
+
+{ # getpixel parameters
+  my $im = Imager->new(xsize => 10, ysize => 10);
+  $im->box(filled => 1, xmax => 4, color => NC(255, 0, 0));
+  $im->box(filled => 1, xmin => 5, ymax => 4, color => NC(0, 255, 255));
+  $im->box(filled => 1, xmin => 5, ymin => 5, color => NC(255, 0, 255));
+  { # error handling
+    my $empty = Imager->new;
+    ok(!$empty->getpixel(x => 0, y => 0), "getpixel empty image");
+    is($empty->errstr, "getpixel: empty input image", "check message");
+
+    ok(!$im->getpixel(y => 0), "missing x");
+    is($im->errstr, "getpixel: missing x or y parameter", "check message");
+
+    $im->_set_error("something different");
+    ok(!$im->getpixel(x => 0), "missing y");
+    is($im->errstr, "getpixel: missing x or y parameter", "check message");
+
+    ok(!$im->getpixel(x => [], y => 0), "empty x array ref");
+    is($im->errstr, "getpixel: x is a reference to an empty array",
+       "check message");
+
+    ok(!$im->getpixel(x => 0, y => []), "empty y array ref");
+    is($im->errstr, "getpixel: y is a reference to an empty array",
+       "check message");
+
+    ok(!$im->getpixel(x => 0, y => 0, type => "bad"), "bad type (scalar path)");
+    is($im->errstr, "getpixel: type must be '8bit' or 'float'",
+      "check message");
+
+    $im->_set_error("something different");
+    ok(!$im->getpixel(x => [ 0 ], y => [ 0 ], type => "bad"),
+       "bad type (array path)");
+    is($im->errstr, "getpixel: type must be '8bit' or 'float'",
+      "check message");
+  }
+
+  # simple calls
+  is_color3($im->getpixel(x => 1, y => 0), 255, 0, 0,
+           "getpixel(1, 0)");
+  is_color3($im->getpixel(x => 8, y => 1), 0, 255, 255,
+           "getpixel(8, 1)");
+  is_color3($im->getpixel(x => 8, y => 7), 255, 0, 255,
+           "getpixel(8, 7)");
+
+  {
+    # simple arrayrefs
+    my @colors = $im->getpixel(x => [ 0, 8, 7 ], y => [ 0, 7, 3 ]);
+    is(@colors, 3, "getpixel 2 3 element array refs");
+    is_color3($colors[0], 255, 0, 0, "check first color");
+    is_color3($colors[1], 255, 0, 255, "check second color");
+    is_color3($colors[2], 0, 255, 255, "check third color");
+  }
+  
+  # array and scalar
+  {
+    my @colors = $im->getpixel(x => 5, y => [ 4, 5, 9 ]);
+    is(@colors, 3, "getpixel x scalar, y arrayref of 3");
+    is_color3($colors[0], 0, 255, 255, "check first color");
+    is_color3($colors[1], 255, 0, 255, "check second color");
+    is_color3($colors[2], 255, 0, 255, "check third color");
+  }
+
+  {
+    my @colors = $im->getpixel(x => [ 0, 4, 5 ], y => 2);
+    is(@colors, 3, "getpixel y scalar, x arrayref of 3");
+    is_color3($colors[0], 255, 0, 0, "check first color");
+    is_color3($colors[1], 255, 0, 0, "check second color");
+    is_color3($colors[2], 0, 255, 255, "check third color");
+  }
+
+  { # float
+    is_fcolor3($im->getpixel(x => 1, y => 0, type => 'float'),
+              1.0, 0, 0, "getpixel(1,0) float");
+    is_fcolor3($im->getpixel(x => 8, y => 1, type => 'float'),
+              0, 1.0, 1.0, "getpixel(8,1) float");
+    is_fcolor3($im->getpixel(x => 8, y => 7, type => 'float'),
+              1.0, 0, 1.0, "getpixel(8,7) float");
+
+    my @colors = $im->getpixel(x => [ 0, 8, 7 ], y => [ 0, 7, 3 ], type => 'float');
+    is(@colors, 3, "getpixel 2 3 element array refs (float)");
+    is_fcolor3($colors[0], 1, 0, 0, "check first color");
+    is_fcolor3($colors[1], 1, 0, 1, "check second color");
+    is_fcolor3($colors[2], 0, 1, 1, "check third color");
+  }
+
+  { # out of bounds
+    my @colors = $im->getpixel(x => [ 0, -1, 5, 10 ], y => 0);
+    is(@colors, 4, "should be 4 entries")
+      or diag $im->errstr;
+    is_color3($colors[0], 255, 0, 0, "first red");
+    is($colors[1], undef, "second undef");
+    is_color3($colors[2], 0, 255, 255, "third cyan");
+    is($colors[3], undef, "fourth undef");
+  }
+
+  { # out of bounds
+    my @colors = $im->getpixel(x => [ 0, -1, 5, 10 ], y => 0, type => "float");
+    is(@colors, 4, "should be 4 entries")
+      or diag $im->errstr;
+    is_fcolor3($colors[0], 1.0, 0, 0, "first red");
+    is($colors[1], undef, "second undef");
+    is_fcolor3($colors[2], 0, 1.0, 1.0, "third cyan");
+    is($colors[3], undef, "fourth undef");
+  }
+}
+
+{ # setpixel
+  my $im = Imager->new(xsize => 10, ysize => 10);
+  { # errors
+    my $empty = Imager->new;
+    ok(!$empty->setpixel(x => 0, y => 0, color => $red),
+       "setpixel on empty image");
+    is($empty->errstr, "setpixel: empty input image", "check message");
+
+    ok(!$im->setpixel(y => 0, color => $red), "missing x");
+    is($im->errstr, "setpixel: missing x or y parameter", "check message");
+
+    $im->_set_error("something different");
+    ok(!$im->setpixel(x => 0, color => $red), "missing y");
+    is($im->errstr, "setpixel: missing x or y parameter", "check message");
+
+    ok(!$im->setpixel(x => [], y => 0, color => $red), "empty x array ref");
+    is($im->errstr, "setpixel: x is a reference to an empty array",
+       "check message");
+
+    ok(!$im->setpixel(x => 0, y => [], color => $red), "empty y array ref");
+    is($im->errstr, "setpixel: y is a reference to an empty array",
+       "check message");
+
+    ok(!$im->setpixel(x => 0, y => 0, color => "not really a color"),
+       "color not a color");
+    is($im->errstr, "setpixel: No color named not really a color found",
+       "check message");
+  }
+
+  # simple set
+  is($im->setpixel(x => 0, y => 0, color => $red), $im,
+     "simple setpixel")
+    or diag "simple set float: ", $im->errstr;
+  is_color3($im->getpixel(x => 0, y => 0), 255, 0, 0, "check stored pixel");
+
+  is($im->setpixel(x => 1, y => 2, color => $f_red), $im,
+     "simple setpixel (float)")
+    or diag "simple set float: ", $im->errstr;
+  is_color3($im->getpixel(x => 1, y => 2), 255, 0, 0, "check stored pixel");
+
+  is($im->setpixel(x => -1, y => 0, color => $red), undef,
+     "simple setpixel outside of image");
+  is($im->setpixel(x => 0, y => -1, color => $f_red), undef,
+     "simple setpixel (float) outside of image");
+
+  # simple arrayrefs
+  is($im->setpixel( x => [ 0, 8, 7 ], y => [ 0, 7, 3 ], color => $blue),
+     3, "setpixel with 3 element array refs");
+  my @colors = $im->getpixel(x => [ 8, 7, 0 ], y => [ 7, 3, 0 ]);
+  is_color3($colors[0], 0, 0, 255, "check first color");
+  is_color3($colors[1], 0, 0, 255, "check second color");
+  is_color3($colors[2], 0, 0, 255, "check third color");
+
+  # array and scalar
+  {
+    is($im->setpixel(x => 5, y => [ 4, 5, 9 ], color => $green), 3,
+       "setpixel with x scalar, y arrayref of 3");
+    my @colors = $im->getpixel(x => [ 5, 5, 5 ], y => [ 4, 5, 9 ]);
+    is_color3($colors[0], 0, 255, 0, "check first color");
+    is_color3($colors[1], 0, 255, 0, "check second color");
+    is_color3($colors[2], 0, 255, 0, "check third color");
+  }
+
+  {
+    is($im->setpixel(x => [ 0, 4, 5 ], y => 2, color => $blue), 3,
+       "setpixel with y scalar, x arrayref of 3");
+    my @colors = $im->getpixel(x => [ 0, 4, 5 ], y => [ 2, 2, 2 ]);
+    is_color3($colors[0], 0, 0, 255, "check first color");
+    is_color3($colors[1], 0, 0, 255, "check second color");
+    is_color3($colors[2], 0, 0, 255, "check third color");
+  }
+
+  {
+    is($im->setpixel(x => [ 0, -1, 10, 5, 0 ], y => [ 0, 1, 2, 3, 1 ], color => $blue), 3,
+       "set array with two bad locations")
+      or diag "set array bad locations: ", $im->errstr;
+    my @colors = $im->getpixel(x => [ 0, 5, 0 ], y => [ 0, 3, 1 ]);
+    is_color3($colors[0], 0, 0, 255, "check first color");
+    is_color3($colors[1], 0, 0, 255, "check second color");
+    is_color3($colors[2], 0, 0, 255, "check third color");
+  }
+  {
+    is($im->setpixel(x => [ 0, -1, 10, 5, 0 ], y => [ 0, 1, 2, 3, 1 ], color => $f_green), 3,
+       "set array with two bad locations (float)")
+      or diag "set array bad locations (float): ", $im->errstr;
+    my @colors = $im->getpixel(x => [ 0, 5, 0 ], y => [ 0, 3, 1 ]);
+    is_color3($colors[0], 0, 255, 0, "check first color");
+    is_color3($colors[1], 0, 255, 0, "check second color");
+    is_color3($colors[2], 0, 255, 0, "check third color");
+  }
+  { # default color
+    is($im->setpixel(x => 0, y => 9), $im, "setpixel() default color")
+      or diag "setpixel default color: ", $im->errstr;
+    is_color3($im->getpixel(x => 0, y => 9), 255, 255, 255,
+             "check color set");
+  }
+}
+
+{
+  my $empty = Imager->new;
+  ok(!$empty->addtag(name => "foo", value => 1),
+     "can't addtag on an empty image");
+  is($empty->errstr, "addtag: empty input image",
+    "check error message");
+  ok(!$empty->settag(name => "foo", value => 1),
+     "can't settag on an empty image");
+  is($empty->errstr, "settag: empty input image",
+    "check error message");
+  ok(!$empty->deltag(name => "foo"), "can't deltag on an empty image");
+  is($empty->errstr, "deltag: empty input image",
+     "check error message");
+  ok(!$empty->tags(name => "foo"), "can't tags on an empty image");
+  is($empty->errstr, "tags: empty input image",
+     "check error message");
+}
+
+Imager->close_log();
+
+unless ($ENV{IMAGER_KEEP_FILES}) {
+  unlink "testout/t01introvert.log";
+}
+
+sub check_add {
+  my ($im, $color, $expected) = @_;
+  my $index = Imager::i_addcolors($im, $color);
+  ok($index, "got index");
+  print "# $index\n";
+  is(0+$index, $expected, "index matched expected");
+  my ($new) = Imager::i_getcolors($im, $index);
+  ok($new, "got the color");
+  ok(color_cmp($new, $color) == 0, "color matched what was added");
+
+  $index;
+}
+
+# sub array_ncmp {
+#   my ($a1, $a2) = @_;
+#   my $len = @$a1 < @$a2 ? @$a1 : @$a2;
+#   for my $i (0..$len-1) {
+#     my $diff = $a1->[$i] <=> $a2->[$i] 
+#       and return $diff;
+#   }
+#   return @$a1 <=> @$a2;
+# }
+
+sub dump_colors {
+  for my $col (@_) {
+    print "# ", map(sprintf("%02X", $_), ($col->rgba)[0..2]),"\n";
+  }
+}
+
+sub _get_error {
+  my @errors = Imager::i_errors();
+  return join(": ", map $_->[0], @errors);
+}
diff --git a/t/100-base/020-color.t b/t/100-base/020-color.t
new file mode 100644 (file)
index 0000000..edcb923
--- /dev/null
@@ -0,0 +1,241 @@
+#!perl -w
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl test.pl'
+
+######################### We start with some black magic to print on failure.
+
+# Change 1..1 below to 1..last_test_to_print .
+# (It may become useful if the test is moved to ./t subdirectory.)
+
+use Test::More tests => 70;
+
+use Imager;
+use Imager::Test qw(is_fcolor4);
+
+-d "testout" or mkdir "testout";
+
+Imager->open_log(log => "testout/t15color.log");
+
+my $c1 = Imager::Color->new(100, 150, 200, 250);
+ok(test_col($c1, 100, 150, 200, 250), 'simple 4-arg');
+my $c2 = Imager::Color->new(100, 150, 200);
+ok(test_col($c2, 100, 150, 200, 255), 'simple 3-arg');
+my $c3 = Imager::Color->new("#6496C8");
+ok(test_col($c3, 100, 150, 200, 255), 'web color');
+# crashes in Imager-0.38pre8 and earlier
+my @foo;
+for (1..1000) {
+  push(@foo, Imager::Color->new("#FFFFFF"));
+}
+my $fail;
+for (@foo) {
+  Imager::Color::set_internal($_, 128, 128, 128, 128) == $_ or ++$fail;
+  Imager::Color::set_internal($_, 128, 128, 128, 128) == $_ or ++$fail;
+  test_col($_, 128, 128, 128, 128) or ++$fail;
+}
+ok(!$fail, 'consitency check');
+
+# test the new OO methods
+color_ok('r g b',, 100, 150, 200, 255, Imager::Color->new(r=>100, g=>150, b=>200));
+color_ok('red green blue', 101, 151, 201, 255, 
+         Imager::Color->new(red=>101, green=>151, blue=>201));
+color_ok('grey', 102, 255, 255, 255, Imager::Color->new(grey=>102));
+color_ok('gray', 103, 255, 255, 255, Imager::Color->new(gray=>103));
+SKIP:
+{
+  skip "no X rgb.txt found", 1 
+    unless grep -r, Imager::Color::_test_x_palettes();
+  color_ok('xname', 0, 0, 255, 255, Imager::Color->new(xname=>'blue'));
+}
+color_ok('gimp', 255, 250, 250, 255, 
+         Imager::Color->new(gimp=>'snow', palette=>'testimg/test_gimp_pal'));
+color_ok('h s v', 255, 255, 255, 255, Imager::Color->new(h=>0, 's'=>0, 'v'=>1.0));
+color_ok('h s v again', 255, 0, 0, 255, Imager::Color->new(h=>0, 's'=>1, v=>1));
+color_ok('web 6 digit', 128, 129, 130, 255, Imager::Color->new(web=>'#808182'));
+color_ok('web 3 digit', 0x11, 0x22, 0x33, 255, Imager::Color->new(web=>'#123'));
+color_ok('rgb arrayref', 255, 150, 121, 255, Imager::Color->new(rgb=>[ 255, 150, 121 ]));
+color_ok('rgba arrayref', 255, 150, 121, 128, 
+         Imager::Color->new(rgba=>[ 255, 150, 121, 128 ]));
+color_ok('hsv arrayref', 255, 0, 0, 255, Imager::Color->new(hsv=>[ 0, 1, 1 ]));
+color_ok('channel0-3', 129, 130, 131, 134, 
+         Imager::Color->new(channel0=>129, channel1=>130, channel2=>131,
+                            channel3=>134));
+color_ok('c0-3', 129, 130, 131, 134, 
+         Imager::Color->new(c0=>129, c1=>130, c2=>131, c3=>134));
+color_ok('channels arrayref', 200, 201, 203, 204, 
+         Imager::Color->new(channels=>[ 200, 201, 203, 204 ]));
+color_ok('name', 255, 250, 250, 255, 
+         Imager::Color->new(name=>'snow', palette=>'testimg/test_gimp_pal'));
+
+# test the internal HSV <=> RGB conversions
+# these values were generated using the GIMP
+# all but hue is 0..360, saturation and value from 0 to 1
+# rgb from 0 to 255
+my @hsv_vs_rgb =
+  (
+   { hsv => [ 0, 0.2, 0.1 ], rgb=> [ 25, 20, 20 ] },
+   { hsv => [ 0, 0.5, 1.0 ], rgb => [ 255, 127, 127 ] },
+   { hsv => [ 100, 0.5, 1.0 ], rgb => [ 170, 255, 127 ] },
+   { hsv => [ 100, 1.0, 1.0 ], rgb=> [ 85, 255, 0 ] },
+   { hsv => [ 335, 0.5, 0.5 ], rgb=> [127, 63, 90 ] },
+  );
+
+use Imager::Color::Float;
+my $test_num = 23;
+my $index = 0;
+for my $entry (@hsv_vs_rgb) {
+  print "# color index $index\n";
+  my $hsv = $entry->{hsv};
+  my $rgb = $entry->{rgb};
+  my $fhsvo = Imager::Color::Float->new($hsv->[0]/360.0, $hsv->[1], $hsv->[2]);
+  my $fc = Imager::Color::Float::i_hsv_to_rgb($fhsvo);
+  fcolor_close_enough("i_hsv_to_rgbf $index", $rgb->[0]/255, $rgb->[1]/255, 
+                      $rgb->[2]/255, $fc);
+  my $fc2 = Imager::Color::Float::i_rgb_to_hsv($fc);
+  fcolor_close_enough("i_rgbf_to_hsv $index", $hsv->[0]/360.0, $hsv->[1], $hsv->[2], 
+                      $fc2);
+
+  my $hsvo = Imager::Color->new($hsv->[0]*255/360.0, $hsv->[1] * 255, 
+                                $hsv->[2] * 255);
+  my $c = Imager::Color::i_hsv_to_rgb($hsvo);
+  color_close_enough("i_hsv_to_rgb $index", @$rgb, $c);
+  my $c2 = Imager::Color::i_rgb_to_hsv($c);
+  color_close_enough_hsv("i_rgb_to_hsv $index", $hsv->[0]*255/360.0, $hsv->[1] * 255, 
+                     $hsv->[2] * 255, $c2);
+  ++$index;
+}
+
+# check the built-ins table
+color_ok('builtin black', 0, 0, 0, 255, 
+       Imager::Color->new(builtin=>'black'));
+
+{
+  my $c1 = Imager::Color->new(255, 255, 255, 0);
+  my $c2 = Imager::Color->new(255, 255, 255, 255);
+  ok(!$c1->equals(other=>$c2), "not equal no ignore alpha");
+  ok(scalar($c1->equals(other=>$c2, ignore_alpha=>1)), 
+      "equal with ignore alpha");
+  ok($c1->equals(other=>$c1), "equal to itself");
+}
+
+{ # http://rt.cpan.org/NoAuth/Bug.html?id=13143
+  # Imager::Color->new(color_name) warning if HOME environment variable not set
+  local $ENV{HOME};
+  my @warnings;
+  local $SIG{__WARN__} = sub { push @warnings, "@_" };
+
+  # presumably no-one will name a color like this.
+  my $c1 = Imager::Color->new(gimp=>"ABCDEFGHIJKLMNOP");
+  is(@warnings, 0, "Should be no warnings")
+    or do { print "# $_" for @warnings };
+}
+
+{
+  # float color from hex triple
+  my $f3white = Imager::Color::Float->new("#FFFFFF");
+  is_fcolor4($f3white, 1.0, 1.0, 1.0, 1.0, "check color #FFFFFF");
+  my $f3black = Imager::Color::Float->new("#000000");
+  is_fcolor4($f3black, 0, 0, 0, 1.0, "check color #000000");
+  my $f3grey = Imager::Color::Float->new("#808080");
+  is_fcolor4($f3grey, 0x80/0xff, 0x80/0xff, 0x80/0xff, 1.0, "check color #808080");
+
+  my $f4white = Imager::Color::Float->new("#FFFFFF80");
+  is_fcolor4($f4white, 1.0, 1.0, 1.0, 0x80/0xff, "check color #FFFFFF80");
+}
+
+{
+  # fail to make a color
+  ok(!Imager::Color::Float->new("-unknown-"), "try to make float color -unknown-");
+}
+
+{
+  # set after creation
+  my $c = Imager::Color::Float->new(0, 0, 0);
+  is_fcolor4($c, 0, 0, 0, 1.0, "check simple init of float color");
+  ok($c->set(1.0, 0.5, 0.25, 1.0), "set() the color");
+  is_fcolor4($c, 1.0, 0.5, 0.25, 1.0, "check after set");
+
+  ok(!$c->set("-unknown-"), "set to unknown");
+}
+
+{
+  # test ->hsv
+  my $c = Imager::Color->new(255, 0, 0);
+  my($h,$s,$v) = $c->hsv;
+  is($h,0,'red hue');
+  is($s,1,'red saturation');
+  is($v,1,'red value');
+
+  $c = Imager::Color->new(0, 255, 0);
+  ($h,$s,$v) = $c->hsv;
+  is($h,120,'green hue');
+  is($s,1,'green saturation');
+  is($v,1,'green value');
+
+  $c = Imager::Color->new(0, 0, 255);
+  ($h,$s,$v) = $c->hsv;
+  is($h,240,'blue hue');
+  is($s,1,'blue saturation');
+  is($v,1,'blue value');
+
+  $c = Imager::Color->new(255, 255, 255);
+  ($h,$s,$v) = $c->hsv;
+  is($h,0,'white hue');
+  is($s,0,'white saturation');
+  is($v,1,'white value');
+
+  $c = Imager::Color->new(0, 0, 0);
+  ($h,$s,$v) = $c->hsv;
+  is($h,0,'black hue');
+  is($s,0,'black saturation');
+  is($v,0,'black value');
+}
+
+sub test_col {
+  my ($c, $r, $g, $b, $a) = @_;
+  unless ($c) {
+    print "# $Imager::ERRSTR\n";
+    return 0;
+  }
+  my ($cr, $cg, $cb, $ca) = $c->rgba;
+  return $r == $cr && $g == $cg && $b == $cb && $a == $ca;
+}
+
+sub color_close_enough {
+  my ($name, $r, $g, $b, $c) = @_;
+
+  my ($cr, $cg, $cb) = $c->rgba;
+  ok(abs($cr-$r) <= 5 && abs($cg-$g) <= 5 && abs($cb-$b) <= 5,
+    "$name - ($cr, $cg, $cb) <=> ($r, $g, $b)");
+}
+
+sub color_close_enough_hsv {
+  my ($name, $h, $s, $v, $c) = @_;
+
+  my ($ch, $cs, $cv) = $c->rgba;
+  if ($ch < 5 && $h > 250) {
+    $ch += 255;
+  }
+  elsif ($ch > 250 && $h < 5) {
+    $h += 255;
+  }
+  ok(abs($ch-$h) <= 5 && abs($cs-$s) <= 5 && abs($cv-$v) <= 5,
+    "$name - ($ch, $cs, $cv) <=> ($h, $s, $v)");
+}
+
+sub fcolor_close_enough {
+  my ($name, $r, $g, $b, $c) = @_;
+
+  my ($cr, $cg, $cb) = $c->rgba;
+  ok(abs($cr-$r) <= 0.01 && abs($cg-$g) <= 0.01 && abs($cb-$b) <= 0.01,
+    "$name - ($cr, $cg, $cb) <=> ($r, $g, $b)");
+}
+
+sub color_ok {
+  my ($name, $r, $g, $b, $a, $c) = @_;
+
+  unless (ok(test_col($c, $r, $g, $b, $a), $name)) {
+    print "# ($r,$g,$b,$a) != (".join(",", $c ? $c->rgba: ()).")\n";
+  }
+}
+
diff --git a/t/100-base/030-countc.t b/t/100-base/030-countc.t
new file mode 100644 (file)
index 0000000..c38453e
--- /dev/null
@@ -0,0 +1,84 @@
+#!perl -w
+use strict;
+use Test::More tests => 22;
+
+use Imager;
+
+-d "testout" or mkdir "testout";
+
+Imager::init('log'=>'testout/t90cc.log');
+
+{
+  my $img=Imager->new();
+  ok($img->open(file=>'testimg/scale.ppm'), 'load test image')
+    or print "failed: ",$img->{ERRSTR},"\n";
+  
+  ok(defined($img->getcolorcount(maxcolors=>10000)), 'check color count is small enough');
+  print "# color count: ".$img->getcolorcount()."\n";
+  is($img->getcolorcount(), 86, 'expected number of colors');
+  is($img->getcolorcount(maxcolors => 50), undef, 'check overflow handling');
+}
+
+{
+  my $black = Imager::Color->new(0, 0, 0);
+  my $blue  = Imager::Color->new(0, 0, 255);
+  my $red   = Imager::Color->new(255, 0, 0);
+  
+  my $im    = Imager->new(xsize=>50, ysize=>50);
+  
+  my $count = $im->getcolorcount();
+  is ($count, 1, "getcolorcount is 1");
+  my @colour_usage = $im->getcolorusage();
+  is_deeply (\@colour_usage, [2500], "2500 are in black");
+  
+  $im->box(filled=>1, color=>$blue, xmin=>25);
+  
+  $count = $im->getcolorcount();
+  is ($count, 2, "getcolorcount is 2");
+  @colour_usage = $im->getcolorusage();
+  is_deeply(\@colour_usage, [1250, 1250] , "1250, 1250: Black and blue");
+  
+  $im->box(filled=>1, color=>$red, ymin=>25);
+  
+  $count = $im->getcolorcount();
+  is ($count, 3, "getcolorcount is 3");
+  @colour_usage = $im->getcolorusage();
+  is_deeply(\@colour_usage, [625, 625, 1250] , 
+           "625, 625, 1250: Black blue and red");
+  @colour_usage = $im->getcolorusage(maxcolors => 2);
+  is(@colour_usage, 0, 'test overflow check');
+  
+  my $colour_usage = $im->getcolorusagehash();
+  my $red_pack = pack("CCC", 255, 0, 0);
+  my $blue_pack = pack("CCC", 0, 0, 255);
+  my $black_pack = pack("CCC", 0, 0, 0);
+  is_deeply( $colour_usage, 
+            { $black_pack => 625, $blue_pack => 625, $red_pack => 1250 },
+            "625, 625, 1250: Black blue and red (hash)");
+  is($im->getcolorusagehash(maxcolors => 2), undef,
+     'test overflow check');
+
+  # test with a greyscale image
+  my $im_g = $im->convert(preset => 'grey');
+  # since the grey preset scales each source channel differently
+  # each of the original colors will be converted to different colors
+  is($im_g->getcolorcount, 3, '3 colors (grey)');
+  is_deeply([ $im_g->getcolorusage ], [ 625, 625, 1250 ], 
+           'color counts (grey)');
+  is_deeply({ "\x00" => 625, "\x12" => 625, "\x38" => 1250 },
+           $im_g->getcolorusagehash,
+           'color usage hash (grey)');
+}
+
+{
+  my $empty = Imager->new;
+  is($empty->getcolorcount, undef, "can't getcolorcount an empty image");
+  is($empty->errstr, "getcolorcount: empty input image",
+     "check error message");
+  is($empty->getcolorusagehash, undef, "can't getcolorusagehash an empty image");
+  is($empty->errstr, "getcolorusagehash: empty input image",
+     "check error message");
+  is($empty->getcolorusage, undef, "can't getcolorusage an empty image");
+  is($empty->errstr, "getcolorusage: empty input image",
+     "check error message");
+}
diff --git a/t/100-base/800-tr18561.t b/t/100-base/800-tr18561.t
new file mode 100644 (file)
index 0000000..fb7264f
--- /dev/null
@@ -0,0 +1,21 @@
+#!perl -w
+# regression test for RT issue 18561
+# 
+use strict;
+use Test::More tests => 1;
+eval {
+  use Imager;
+  
+  my $i = Imager->new(
+          xsize => 50,
+         ysize => 50,
+  );
+  
+  $i->setpixel(
+       x => 10,
+       y => 10,
+       color => [0, 0, 0],
+  );
+};
+ok(!$@, "shouldn't crash")
+  or print "# $@\n";
diff --git a/t/100-base/801-tr18561b.t b/t/100-base/801-tr18561b.t
new file mode 100644 (file)
index 0000000..6b93389
--- /dev/null
@@ -0,0 +1,17 @@
+#!perl -w
+# variant on the code that produces 18561
+# the old _color() code could return floating colors in some cases
+# but in most cases the caller couldn't handle it
+use strict;
+use Test::More tests => 1;
+eval {
+  use Imager;
+  use Imager::Color::Float; # prevent the actual 18561 crash
+  my $i = Imager->new(
+         xsize => 50,
+         ysize => 50,
+  );
+  $i->line(x1 => 0, y1 => 0, x2 => 99, y2=>99, color => [ 0, 0, 0 ]);
+};
+ok(!$@, "shouldn't crash")
+  or print "# $@\n";
diff --git a/t/150-type/020-sixteen.t b/t/150-type/020-sixteen.t
new file mode 100644 (file)
index 0000000..a1054e5
--- /dev/null
@@ -0,0 +1,369 @@
+#!perl -w
+use strict;
+use Test::More tests => 155;
+
+BEGIN { use_ok(Imager=>qw(:all :handy)) }
+
+-d "testout" or mkdir "testout";
+
+Imager->open_log(log => "testout/t021sixteen.log");
+
+use Imager::Color::Float;
+use Imager::Test qw(test_image is_image image_bounds_checks test_colorf_gpix
+                    test_colorf_glin mask_tests is_color3);
+
+my $im_g = Imager::i_img_16_new(100, 101, 1);
+
+is(Imager::i_img_getchannels($im_g), 1, "1 channel image channel count");
+ok(Imager::i_img_getmask($im_g) & 1, "1 channel image mask");
+ok(!Imager::i_img_virtual($im_g), "shouldn't be marked virtual");
+is(Imager::i_img_bits($im_g), 16, "1 channel image has bits == 16");
+is(Imager::i_img_type($im_g), 0, "1 channel image isn't direct");
+
+my @ginfo = i_img_info($im_g);
+is($ginfo[0], 100, "1 channel image width");
+is($ginfo[1], 101, "1 channel image height");
+
+undef $im_g;
+
+my $im_rgb = Imager::i_img_16_new(100, 101, 3);
+
+is(Imager::i_img_getchannels($im_rgb), 3, "3 channel image channel count");
+ok((Imager::i_img_getmask($im_rgb) & 7) == 7, "3 channel image mask");
+is(Imager::i_img_bits($im_rgb), 16, "3 channel image bits");
+is(Imager::i_img_type($im_rgb), 0, "3 channel image type");
+
+my $redf = NCF(1, 0, 0);
+my $greenf = NCF(0, 1, 0);
+my $bluef = NCF(0, 0, 1);
+
+# fill with red
+for my $y (0..101) {
+  Imager::i_plinf($im_rgb, 0, $y, ($redf) x 100);
+}
+pass("fill with red");
+# basic sanity
+test_colorf_gpix($im_rgb, 0,  0,   $redf, 0, "top-left");
+test_colorf_gpix($im_rgb, 99, 0,   $redf, 0, "top-right");
+test_colorf_gpix($im_rgb, 0,  100, $redf, 0, "bottom left");
+test_colorf_gpix($im_rgb, 99, 100, $redf, 0, "bottom right");
+test_colorf_glin($im_rgb, 0,  0,   [ ($redf) x 100 ], "first line");
+test_colorf_glin($im_rgb, 0,  100, [ ($redf) x 100 ], "last line");
+
+Imager::i_plinf($im_rgb, 20, 1, ($greenf) x 60);
+test_colorf_glin($im_rgb, 0, 1, 
+                 [ ($redf) x 20, ($greenf) x 60, ($redf) x 20 ],
+               "added some green in the middle");
+{
+  my @samples;
+  is(Imager::i_gsamp_bits($im_rgb, 18, 22, 1, 16, \@samples, 0, [ 0 .. 2 ]), 12, 
+     "i_gsamp_bits all channels - count")
+    or print "# ", Imager->_error_as_msg(), "\n";
+  is_deeply(\@samples, [ 65535, 0, 0,   65535, 0, 0,
+                        0, 65535, 0,   0, 65535, 0 ],
+           "check samples retrieved");
+  @samples = ();
+  is(Imager::i_gsamp_bits($im_rgb, 18, 22, 1, 16, \@samples, 0, [ 0, 2 ]), 8, 
+     "i_gsamp_bits some channels - count")
+    or print "# ", Imager->_error_as_msg(), "\n";
+  is_deeply(\@samples, [ 65535, 0,   65535, 0,
+                        0, 0,       0, 0     ],
+           "check samples retrieved");
+  # fail gsamp
+  is(Imager::i_gsamp_bits($im_rgb, 18, 22, 1, 16, \@samples, 0, [ 0, 3 ]), undef,
+     "i_gsamp_bits fail bad channel");
+  is(Imager->_error_as_msg(), 'No channel 3 in this image', 'check message');
+
+  is(Imager::i_gsamp_bits($im_rgb, 18, 22, 1, 17, \@samples, 0, [ 0, 2 ]), 8, 
+     "i_gsamp_bits succeed high bits");
+  is($samples[0], 131071, "check correct with high bits");
+
+  # write some samples back
+  my @wr_samples = 
+    ( 
+     0, 0, 65535,
+     65535, 0, 0,  
+     0, 65535, 0,  
+     65535, 65535, 0 
+    );
+  is(Imager::i_psamp_bits($im_rgb, 18, 2, 16, [ 0 .. 2 ], \@wr_samples),
+     12, "write 16-bit samples")
+    or print "# ", Imager->_error_as_msg(), "\n";
+  @samples = ();
+  is(Imager::i_gsamp_bits($im_rgb, 18, 22, 2, 16, \@samples, 0, [ 0 .. 2 ]), 12, 
+     "read them back")
+    or print "# ", Imager->_error_as_msg(), "\n";
+  is_deeply(\@samples, \@wr_samples, "check they match");
+  my $c = Imager::i_get_pixel($im_rgb, 18, 2);
+  is_color3($c, 0, 0, 255, "check it write to the right places");
+}
+
+# basic OO tests
+my $oo16img = Imager->new(xsize=>200, ysize=>201, bits=>16);
+ok($oo16img, "make a 16-bit oo image");
+is($oo16img->bits,  16, "test bits");
+isnt($oo16img->is_bilevel, "should not be considered mono");
+# make sure of error handling
+ok(!Imager->new(xsize=>0, ysize=>1, bits=>16),
+    "fail to create a 0 pixel wide image");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
+       "and correct error message");
+
+ok(!Imager->new(xsize=>1, ysize=>0, bits=>16),
+    "fail to create a 0 pixel high image");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
+       "and correct error message");
+
+ok(!Imager->new(xsize=>-1, ysize=>1, bits=>16),
+    "fail to create a negative width image");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
+       "and correct error message");
+
+ok(!Imager->new(xsize=>1, ysize=>-1, bits=>16),
+    "fail to create a negative height image");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
+       "and correct error message");
+
+ok(!Imager->new(xsize=>-1, ysize=>-1, bits=>16),
+    "fail to create a negative width/height image");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
+       "and correct error message");
+
+ok(!Imager->new(xsize=>1, ysize=>1, bits=>16, channels=>0),
+    "fail to create a zero channel image");
+cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
+       "and correct error message");
+ok(!Imager->new(xsize=>1, ysize=>1, bits=>16, channels=>5),
+    "fail to create a five channel image");
+cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
+       "and correct error message");
+
+{
+  # https://rt.cpan.org/Ticket/Display.html?id=8213
+  # check for handling of memory allocation of very large images
+  # only test this on 32-bit machines - on a 64-bit machine it may
+  # result in trying to allocate 4Gb of memory, which is unfriendly at
+  # least and may result in running out of memory, causing a different
+  # type of exit
+ SKIP: {
+    use Config;
+    $Config{ptrsize} == 4
+      or skip("don't want to allocate 4Gb", 10);
+    my $uint_range = 256 ** $Config{intsize};
+    print "# range $uint_range\n";
+    my $dim1 = int(sqrt($uint_range/2))+1;
+    
+    my $im_b = Imager->new(xsize=>$dim1, ysize=>$dim1, channels=>1, bits=>16);
+    is($im_b, undef, "integer overflow check - 1 channel");
+    
+    $im_b = Imager->new(xisze=>$dim1, ysize=>1, channels=>1, bits=>16);
+    ok($im_b, "but same width ok");
+    $im_b = Imager->new(xisze=>1, ysize=>$dim1, channels=>1, bits=>16);
+    ok($im_b, "but same height ok");
+    cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
+           "check the error message");
+
+    # do a similar test with a 3 channel image, so we're sure we catch
+    # the same case where the third dimension causes the overflow
+    my $dim3 = int(sqrt($uint_range / 3 / 2))+1;
+    
+    $im_b = Imager->new(xsize=>$dim3, ysize=>$dim3, channels=>3, bits=>16);
+    is($im_b, undef, "integer overflow check - 3 channel");
+    
+    $im_b = Imager->new(xisze=>$dim3, ysize=>1, channels=>3, bits=>16);
+    ok($im_b, "but same width ok");
+    $im_b = Imager->new(xisze=>1, ysize=>$dim3, channels=>3, bits=>16);
+    ok($im_b, "but same height ok");
+
+    cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
+           "check the error message");
+
+    # check we can allocate a scanline, unlike double images the scanline
+    # in the image itself is smaller than a line of i_fcolor
+    # divide by 2 to get to int range, by 2 for 2 bytes/pixel, by 3 to 
+    # fit the image allocation in, but for the floats to overflow
+    my $dim4 = $uint_range / 2 / 2 / 3;
+    my $im_o = Imager->new(xsize=>$dim4, ysize=>1, channels=>1, bits=>16);
+    is($im_o, undef, "integer overflow check - scanline");
+    cmp_ok(Imager->errstr, '=~',
+           qr/integer overflow calculating scanline allocation/,
+           "check error message");
+  }
+}
+
+{ # check the channel mask function
+  
+  my $im = Imager->new(xsize => 10, ysize=>10, bits=>16);
+
+  mask_tests($im, 1.0/65535);
+}
+
+{ # convert to rgb16
+  my $im = test_image();
+  my $im16 = $im->to_rgb16;
+  print "# check conversion to 16 bit\n";
+  is($im16->bits, 16, "check bits");
+  is_image($im, $im16, "check image data matches");
+}
+
+{ # empty image handling
+  my $im = Imager->new;
+  ok($im, "make empty image");
+  ok(!$im->to_rgb16, "convert empty image to 16-bit");
+  is($im->errstr, "to_rgb16: empty input image", "check message");
+}
+
+{ # bounds checks
+  my $im = Imager->new(xsize => 10, ysize => 10, bits => 16);
+  image_bounds_checks($im);
+}
+
+{
+  my $im = Imager->new(xsize => 10, ysize => 10, bits => 16, channels => 3);
+  my @wr_samples = map int(rand 65536), 1..30;
+  is($im->setsamples('y' => 1, data => \@wr_samples, type => '16bit'),
+     30, "write 16-bit to OO image")
+    or print "# ", $im->errstr, "\n";
+  my @samples;
+  is($im->getsamples(y => 1, target => \@samples, type => '16bit'),
+     30, "read 16-bit from OO image")
+    or print "# ", $im->errstr, "\n";
+  is_deeply(\@wr_samples, \@samples, "check it matches");
+}
+
+my $psamp_outside_error = "Image position outside of image";
+{ # psamp
+  print "# psamp\n";
+  my $imraw = Imager::i_img_16_new(10, 10, 3);
+  {
+    is(Imager::i_psamp($imraw, 0, 2, undef, [ 255, 128, 64 ]), 3,
+       "i_psamp def channels, 3 samples");
+    is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
+             "check color written");
+    Imager::i_img_setmask($imraw, 5);
+    is(Imager::i_psamp($imraw, 1, 3, undef, [ 64, 128, 192 ]), 3,
+       "i_psamp def channels, 3 samples, masked");
+    is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 192,
+             "check color written");
+    is(Imager::i_psamp($imraw, 1, 7, [ 0, 1, 2 ], [ 64, 128, 192 ]), 3,
+       "i_psamp channels listed, 3 samples, masked");
+    is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 192,
+             "check color written");
+    Imager::i_img_setmask($imraw, ~0);
+    is(Imager::i_psamp($imraw, 2, 4, [ 0, 1 ], [ 255, 128, 64, 32 ]), 4,
+       "i_psamp channels [0, 1], 4 samples");
+    is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
+             "check first color written");
+    is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
+             "check second color written");
+    is(Imager::i_psamp($imraw, 0, 5, [ 0, 1, 2 ], [ (128, 63, 32) x 10 ]), 30,
+       "write a full row");
+    is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
+             [ (128, 63, 32) x 10 ],
+             "check full row");
+    is(Imager::i_psamp($imraw, 8, 8, [ 0, 1, 2 ],
+                      [ 255, 128, 32, 64, 32, 16, 32, 16, 8 ]),
+       6, "i_psamp channels [0, 1, 2], 9 samples, but room for 6");
+  }
+  { # errors we catch
+    is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, 3 ], [ 255, 128, 32 ]),
+       undef, "i_psamp channels [0, 1, 3], 3 samples (invalid channel number)");
+    is(_get_error(), "No channel 3 in this image",
+       "check error message");
+    is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, -1 ], [ 255, 128, 32 ]),
+       undef, "i_psamp channels [0, 1, -1], 3 samples (invalid channel number)");
+    is(_get_error(), "No channel -1 in this image",
+       "check error message");
+    is(Imager::i_psamp($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
+       "negative y");
+    is(_get_error(), $psamp_outside_error,
+       "check error message");
+    is(Imager::i_psamp($imraw, 0, 10, undef, [ 0, 0, 0 ]), undef,
+       "y overflow");
+    is(_get_error(), $psamp_outside_error,
+       "check error message");
+    is(Imager::i_psamp($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
+       "negative x");
+    is(_get_error(), $psamp_outside_error,
+       "check error message");
+    is(Imager::i_psamp($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
+       "x overflow");
+    is(_get_error(), $psamp_outside_error,
+       "check error message");
+  }
+  print "# end psamp tests\n";
+}
+
+{ # psampf
+  print "# psampf\n";
+  my $imraw = Imager::i_img_16_new(10, 10, 3);
+  {
+    is(Imager::i_psampf($imraw, 0, 2, undef, [ 1, 0.5, 0.25 ]), 3,
+       "i_psampf def channels, 3 samples");
+    is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 127, 64,
+             "check color written");
+    Imager::i_img_setmask($imraw, 5);
+    is(Imager::i_psampf($imraw, 1, 3, undef, [ 0.25, 0.5, 0.75 ]), 3,
+       "i_psampf def channels, 3 samples, masked");
+    is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 191,
+             "check color written");
+    is(Imager::i_psampf($imraw, 1, 7, [ 0, 1, 2 ], [ 0.25, 0.5, 0.75 ]), 3,
+       "i_psampf channels listed, 3 samples, masked");
+    is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 191,
+             "check color written");
+    Imager::i_img_setmask($imraw, ~0);
+    is(Imager::i_psampf($imraw, 2, 4, [ 0, 1 ], [ 1, 0.5, 0.25, 0.125 ]), 4,
+       "i_psampf channels [0, 1], 4 samples");
+    is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 127, 0,
+             "check first color written");
+    is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
+             "check second color written");
+    is(Imager::i_psampf($imraw, 0, 5, [ 0, 1, 2 ], [ (0.5, 0.25, 0.125) x 10 ]), 30,
+       "write a full row");
+    is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
+             [ (127, 64, 32) x 10 ],
+             "check full row");
+    is(Imager::i_psampf($imraw, 8, 8, [ 0, 1, 2 ],
+                       [ 1.0, 0.5, 0.125, 0.25, 0.125, 0.0625, 0.125, 0, 1 ]),
+       6, "i_psampf channels [0, 1, 2], 9 samples, but room for 6");
+  }
+  { # errors we catch
+    is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, 3 ], [ 1, 0.5, 0.125 ]),
+       undef, "i_psampf channels [0, 1, 3], 3 samples (invalid channel number)");
+    is(_get_error(), "No channel 3 in this image",
+       "check error message");
+    is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, -1 ], [ 1, 0.5, 0.125 ]),
+       undef, "i_psampf channels [0, 1, -1], 3 samples (invalid channel number)");
+    is(_get_error(), "No channel -1 in this image",
+       "check error message");
+    is(Imager::i_psampf($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
+       "negative y");
+    is(_get_error(), $psamp_outside_error,
+       "check error message");
+    is(Imager::i_psampf($imraw, 0, 10, undef, [ 0, 0, 0 ]), undef,
+       "y overflow");
+    is(_get_error(), $psamp_outside_error,
+       "check error message");
+    is(Imager::i_psampf($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
+       "negative x");
+    is(_get_error(), $psamp_outside_error,
+       "check error message");
+    is(Imager::i_psampf($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
+       "x overflow");
+    is(_get_error(), $psamp_outside_error,
+       "check error message");
+  }
+  print "# end psampf tests\n";
+}
+
+Imager->close_log;
+
+unless ($ENV{IMAGER_KEEP_FILES}) {
+  unlink "testout/t021sixteen.log";
+}
+
+sub _get_error {
+  my @errors = Imager::i_errors();
+  return join(": ", map $_->[0], @errors);
+}
+
diff --git a/t/150-type/030-double.t b/t/150-type/030-double.t
new file mode 100644 (file)
index 0000000..6a2f757
--- /dev/null
@@ -0,0 +1,298 @@
+#!perl -w
+use strict;
+use Test::More tests => 136;
+BEGIN { use_ok(Imager => qw(:all :handy)) }
+
+use Imager::Test qw(test_image is_image is_color3);
+
+-d "testout" or mkdir "testout";
+
+Imager->open_log(log => "testout/t022double.log");
+
+use Imager::Test qw(image_bounds_checks test_colorf_gpix test_colorf_glin mask_tests);
+
+use Imager::Color::Float;
+
+my $im_g = Imager::i_img_double_new(100, 101, 1);
+
+ok(Imager::i_img_getchannels($im_g) == 1, 
+   "1 channel image channel count mismatch");
+ok(Imager::i_img_getmask($im_g) & 1, "1 channel image bad mask");
+ok(Imager::i_img_virtual($im_g) == 0, 
+  "1 channel image thinks it is virtual");
+my $double_bits = length(pack("d", 1)) * 8;
+print "# $double_bits double bits\n";
+ok(Imager::i_img_bits($im_g) == $double_bits, 
+   "1 channel image has bits != $double_bits");
+ok(Imager::i_img_type($im_g) == 0, "1 channel image isn't direct");
+
+my @ginfo = i_img_info($im_g);
+ok($ginfo[0] == 100, "1 channel image width incorrect");
+ok($ginfo[1] == 101, "1 channel image height incorrect");
+
+undef $im_g;
+
+my $im_rgb = Imager::i_img_double_new(100, 101, 3);
+
+ok(Imager::i_img_getchannels($im_rgb) == 3,
+   "3 channel image channel count mismatch");
+ok((Imager::i_img_getmask($im_rgb) & 7) == 7, "3 channel image bad mask");
+ok(Imager::i_img_bits($im_rgb) == $double_bits,
+  "3 channel image has bits != $double_bits");
+ok(Imager::i_img_type($im_rgb) == 0, "3 channel image isn't direct");
+
+my $redf = NCF(1, 0, 0);
+my $greenf = NCF(0, 1, 0);
+my $bluef = NCF(0, 0, 1);
+
+# fill with red
+for my $y (0..101) {
+  Imager::i_plinf($im_rgb, 0, $y, ($redf) x 100);
+}
+
+# basic sanity
+test_colorf_gpix($im_rgb, 0,  0,   $redf);
+test_colorf_gpix($im_rgb, 99, 0,   $redf);
+test_colorf_gpix($im_rgb, 0,  100, $redf);
+test_colorf_gpix($im_rgb, 99, 100, $redf);
+test_colorf_glin($im_rgb, 0,  0,   [ ($redf) x 100 ], 'sanity glin @0');
+test_colorf_glin($im_rgb, 0,  100, [ ($redf) x 100 ], 'sanity glin @100');
+
+Imager::i_plinf($im_rgb, 20, 1, ($greenf) x 60);
+test_colorf_glin($im_rgb, 0, 1, 
+                 [ ($redf) x 20, ($greenf) x 60, ($redf) x 20 ],
+                'check after write');
+
+# basic OO tests
+my $ooimg = Imager->new(xsize=>200, ysize=>201, bits=>'double');
+ok($ooimg, "couldn't make double image");
+is($ooimg->bits, 'double', "oo didn't give double image");
+ok(!$ooimg->is_bilevel, 'not monochrome');
+
+# check that the image is copied correctly
+my $oocopy = $ooimg->copy;
+is($oocopy->bits, 'double', "oo copy didn't give double image");
+
+ok(!Imager->new(xsize=>0, ysize=>1, bits=>'double'),
+    "fail making 0 width image");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
+       "and correct message");
+ok(!Imager->new(xsize=>1, ysize=>0, bits=>'double'),
+    "fail making 0 height image");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
+       "and correct message");
+ok(!Imager->new(xsize=>-1, ysize=>1, bits=>'double'),
+    "fail making -ve width image");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
+       "and correct message");
+ok(!Imager->new(xsize=>1, ysize=>-1, bits=>'double'),
+    "fail making -ve height image");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
+       "and correct message");
+ok(!Imager->new(xsize=>1, ysize=>1, bits=>'double', channels=>0),
+    "fail making 0 channel image");
+cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
+       "and correct message");
+ok(!Imager->new(xsize=>1, ysize=>1, bits=>'double', channels=>5),
+    "fail making 5 channel image");
+cmp_ok(Imager->errstr, '=~', qr/channels must be between 1 and 4/,
+       "and correct message");
+
+{
+  # https://rt.cpan.org/Ticket/Display.html?id=8213
+  # check for handling of memory allocation of very large images
+  # only test this on 32-bit machines - on a 64-bit machine it may
+  # result in trying to allocate 4Gb of memory, which is unfriendly at
+  # least and may result in running out of memory, causing a different
+  # type of exit
+  use Config;
+  SKIP: 
+  {
+    $Config{ptrsize} == 4
+      or skip "don't want to allocate 4Gb", 8;
+    my $uint_range = 256 ** $Config{intsize};
+    my $dbl_size = $Config{doublesize} || 8;
+    my $dim1 = int(sqrt($uint_range/$dbl_size))+1;
+    
+    my $im_b = Imager->new(xsize=>$dim1, ysize=>$dim1, channels=>1, bits=>'double');
+    is($im_b, undef, "integer overflow check - 1 channel");
+    
+    $im_b = Imager->new(xisze=>$dim1, ysize=>1, channels=>1, bits=>'double');
+    ok($im_b, "but same width ok");
+    $im_b = Imager->new(xisze=>1, ysize=>$dim1, channels=>1, bits=>'double');
+    ok($im_b, "but same height ok");
+    cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
+           "check the error message");
+
+    # do a similar test with a 3 channel image, so we're sure we catch
+    # the same case where the third dimension causes the overflow
+    my $dim3 = int(sqrt($uint_range / 3 / $dbl_size))+1;
+    
+    $im_b = Imager->new(xsize=>$dim3, ysize=>$dim3, channels=>3, bits=>'double');
+    is($im_b, undef, "integer overflow check - 3 channel");
+    
+    $im_b = Imager->new(xsize=>$dim3, ysize=>1, channels=>3, bits=>'double');
+    ok($im_b, "but same width ok");
+    $im_b = Imager->new(xsize=>1, ysize=>$dim3, channels=>3, bits=>'double');
+    ok($im_b, "but same height ok");
+
+    cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
+           "check the error message");
+  }
+}
+
+{ # check the channel mask function
+  
+  my $im = Imager->new(xsize => 10, ysize=>10, bits=>'double');
+
+  mask_tests($im);
+}
+
+{ # bounds checking
+  my $im = Imager->new(xsize => 10, ysize=>10, bits=>'double');
+  image_bounds_checks($im);
+}
+
+
+{ # convert to rgb double
+  my $im = test_image();
+  my $imdb = $im->to_rgb_double;
+  print "# check conversion to double\n";
+  is($imdb->bits, "double", "check bits");
+  is_image($im, $imdb, "check image data matches");
+}
+
+{ # empty image handling
+  my $im = Imager->new;
+  ok($im, "make empty image");
+  ok(!$im->to_rgb_double, "convert empty image to double");
+  is($im->errstr, "to_rgb_double: empty input image", "check message");
+}
+
+my $psamp_outside_error = "Image position outside of image";
+{ # psamp
+  print "# psamp\n";
+  my $imraw = Imager::i_img_double_new(10, 10, 3);
+  {
+    is(Imager::i_psamp($imraw, 0, 2, undef, [ 255, 128, 64 ]), 3,
+       "i_psamp def channels, 3 samples");
+    is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
+             "check color written");
+    Imager::i_img_setmask($imraw, 5);
+    is(Imager::i_psamp($imraw, 1, 3, undef, [ 64, 128, 192 ]), 3,
+       "i_psamp def channels, 3 samples, masked");
+    is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 192,
+             "check color written");
+    is(Imager::i_psamp($imraw, 1, 7, [ 0, 1, 2 ], [ 64, 128, 192 ]), 3,
+       "i_psamp channels listed, 3 samples, masked");
+    is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 192,
+             "check color written");
+    Imager::i_img_setmask($imraw, ~0);
+    is(Imager::i_psamp($imraw, 2, 4, [ 0, 1 ], [ 255, 128, 64, 32 ]), 4,
+       "i_psamp channels [0, 1], 4 samples");
+    is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
+             "check first color written");
+    is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
+             "check second color written");
+    is(Imager::i_psamp($imraw, 0, 5, [ 0, 1, 2 ], [ (128, 63, 32) x 10 ]), 30,
+       "write a full row");
+    is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
+             [ (128, 63, 32) x 10 ],
+             "check full row");
+    is(Imager::i_psamp($imraw, 8, 8, [ 0, 1, 2 ],
+                      [ 255, 128, 32, 64, 32, 16, 32, 16, 8 ]),
+       6, "i_psamp channels [0, 1, 2], 9 samples, but room for 6");
+  }
+  { # errors we catch
+    is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, 3 ], [ 255, 128, 32 ]),
+       undef, "i_psamp channels [0, 1, 3], 3 samples (invalid channel number)");
+    is(_get_error(), "No channel 3 in this image",
+       "check error message");
+    is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, -1 ], [ 255, 128, 32 ]),
+       undef, "i_psamp channels [0, 1, -1], 3 samples (invalid channel number)");
+    is(_get_error(), "No channel -1 in this image",
+       "check error message");
+    is(Imager::i_psamp($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
+       "negative y");
+    is(_get_error(), $psamp_outside_error, "check error message");
+    is(Imager::i_psamp($imraw, 0, 10, undef, [ 0, 0, 0 ]), undef,
+       "y overflow");
+    is(_get_error(), $psamp_outside_error, "check error message");
+    is(Imager::i_psamp($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
+       "negative x");
+    is(_get_error(), $psamp_outside_error, "check error message");
+    is(Imager::i_psamp($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
+       "x overflow");
+    is(_get_error(), $psamp_outside_error, "check error message");
+  }
+  print "# end psamp tests\n";
+}
+
+{ # psampf
+  print "# psampf\n";
+  my $imraw = Imager::i_img_double_new(10, 10, 3);
+  {
+    is(Imager::i_psampf($imraw, 0, 2, undef, [ 1, 0.5, 0.25 ]), 3,
+       "i_psampf def channels, 3 samples");
+    is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
+             "check color written");
+    Imager::i_img_setmask($imraw, 5);
+    is(Imager::i_psampf($imraw, 1, 3, undef, [ 0.25, 0.5, 0.75 ]), 3,
+       "i_psampf def channels, 3 samples, masked");
+    is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 191,
+             "check color written");
+    is(Imager::i_psampf($imraw, 1, 7, [ 0, 1, 2 ], [ 0.25, 0.5, 0.75 ]), 3,
+       "i_psampf channels listed, 3 samples, masked");
+    is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 191,
+             "check color written");
+    Imager::i_img_setmask($imraw, ~0);
+    is(Imager::i_psampf($imraw, 2, 4, [ 0, 1 ], [ 1, 0.5, 0.25, 0.125 ]), 4,
+       "i_psampf channels [0, 1], 4 samples");
+    is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
+             "check first color written");
+    is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
+             "check second color written");
+    is(Imager::i_psampf($imraw, 0, 5, [ 0, 1, 2 ], [ (0.5, 0.25, 0.125) x 10 ]), 30,
+       "write a full row");
+    is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
+             [ (128, 64, 32) x 10 ],
+             "check full row");
+    is(Imager::i_psampf($imraw, 8, 8, [ 0, 1, 2 ],
+                       [ 1.0, 0.5, 0.125, 0.25, 0.125, 0.0625, 0.125, 0, 1 ]),
+       6, "i_psampf channels [0, 1, 2], 9 samples, but room for 6");
+  }
+  { # errors we catch
+    is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, 3 ], [ 1, 0.5, 0.125 ]),
+       undef, "i_psampf channels [0, 1, 3], 3 samples (invalid channel number)");
+    is(_get_error(), "No channel 3 in this image",
+       "check error message");
+    is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, -1 ], [ 1, 0.5, 0.125 ]),
+       undef, "i_psampf channels [0, 1, -1], 3 samples (invalid channel number)");
+    is(_get_error(), "No channel -1 in this image",
+       "check error message");
+    is(Imager::i_psampf($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
+       "negative y");
+    is(_get_error(), $psamp_outside_error, "check error message");
+    is(Imager::i_psampf($imraw, 0, 10, undef, [ 0, 0, 0 ]), undef,
+       "y overflow");
+    is(_get_error(), $psamp_outside_error, "check error message");
+    is(Imager::i_psampf($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
+       "negative x");
+    is(_get_error(), $psamp_outside_error, "check error message");
+    is(Imager::i_psampf($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
+       "x overflow");
+    is(_get_error(), $psamp_outside_error, "check error message");
+  }
+  print "# end psampf tests\n";
+}
+
+Imager->close_log;
+
+unless ($ENV{IMAGER_KEEP_FILES}) {
+  unlink "testout/t022double.log";
+}
+
+sub _get_error {
+  my @errors = Imager::i_errors();
+  return join(": ", map $_->[0], @errors);
+}
diff --git a/t/150-type/040-palette.t b/t/150-type/040-palette.t
new file mode 100644 (file)
index 0000000..a5976b7
--- /dev/null
@@ -0,0 +1,679 @@
+#!perl -w
+# some of this is tested in t01introvert.t too
+use strict;
+use Test::More tests => 226;
+BEGIN { use_ok("Imager", ':handy'); }
+
+use Imager::Test qw(image_bounds_checks test_image is_color3 isnt_image is_color4 is_fcolor3);
+
+Imager->open_log(log => "testout/t023palette.log");
+
+sub isbin($$$);
+
+my $img = Imager->new(xsize=>50, ysize=>50, type=>'paletted');
+
+ok($img, "paletted image created");
+
+is($img->type, 'paletted', "got a paletted image");
+
+my $black = Imager::Color->new(0,0,0);
+my $red = Imager::Color->new(255,0,0);
+my $green = Imager::Color->new(0,255,0);
+my $blue = Imager::Color->new(0,0,255);
+
+my $white = Imager::Color->new(255,255,255);
+
+# add some color
+my $blacki = $img->addcolors(colors=>[ $black, $red, $green, $blue ]);
+
+print "# blacki $blacki\n";
+ok(defined $blacki && $blacki == 0, "we got the first color");
+
+is($img->colorcount(), 4, "should have 4 colors");
+is($img->maxcolors, 256, "maxcolors always 256");
+
+my ($redi, $greeni, $bluei) = 1..3;
+
+my @all = $img->getcolors;
+ok(@all == 4, "all colors is 4");
+coloreq($all[0], $black, "first black");
+coloreq($all[1], $red, "then red");
+coloreq($all[2], $green, "then green");
+coloreq($all[3], $blue, "and finally blue");
+
+# keep this as an assignment, checking for scalar context
+# we don't want the last color, otherwise if the behaviour changes to
+# get all up to the last (count defaulting to size-index) we'd get a
+# false positive
+my $one_color = $img->getcolors(start=>$redi);
+ok($one_color->isa('Imager::Color'), "check scalar context");
+coloreq($one_color, $red, "and that it's what we want");
+
+# make sure we can find colors
+ok(!defined($img->findcolor(color=>$white)), 
+    "shouldn't be able to find white");
+ok($img->findcolor(color=>$black) == $blacki, "find black");
+ok($img->findcolor(color=>$red) == $redi, "find red");
+ok($img->findcolor(color=>$green) == $greeni, "find green");
+ok($img->findcolor(color=>$blue) == $bluei, "find blue");
+
+# various failure tests for setcolors
+ok(!defined($img->setcolors(start=>-1, colors=>[$white])),
+    "expect failure: low index");
+ok(!defined($img->setcolors(start=>1, colors=>[])),
+    "expect failure: no colors");
+ok(!defined($img->setcolors(start=>5, colors=>[$white])),
+    "expect failure: high index");
+
+# set the green index to white
+ok($img->setcolors(start => $greeni, colors => [$white]),
+    "set a color");
+# and check it
+coloreq(scalar($img->getcolors(start=>$greeni)), $white,
+       "make sure it was set");
+ok($img->findcolor(color=>$white) == $greeni, "and that we can find it");
+ok(!defined($img->findcolor(color=>$green)), "and can't find the old color");
+
+# write a few colors
+ok(scalar($img->setcolors(start=>$redi, colors=>[ $green, $red])),
+          "save multiple");
+coloreq(scalar($img->getcolors(start=>$redi)), $green, "first of multiple");
+coloreq(scalar($img->getcolors(start=>$greeni)), $red, "second of multiple");
+
+# put it back
+$img->setcolors(start=>$red, colors=>[$red, $green]);
+
+# draw on the image, make sure it stays paletted when it should
+ok($img->box(color=>$red, filled=>1), "fill with red");
+is($img->type, 'paletted', "paletted after fill");
+ok($img->box(color=>$green, filled=>1, xmin=>10, ymin=>10,
+             xmax=>40, ymax=>40), "green box");
+is($img->type, 'paletted', 'still paletted after box');
+# an AA line will almost certainly convert the image to RGB, don't use
+# an AA line here
+ok($img->line(color=>$blue, x1=>10, y1=>10, x2=>40, y2=>40),
+    "draw a line");
+is($img->type, 'paletted', 'still paletted after line');
+
+# draw with white - should convert to direct
+ok($img->box(color=>$white, filled=>1, xmin=>20, ymin=>20, 
+             xmax=>30, ymax=>30), "white box");
+is($img->type, 'direct', "now it should be direct");
+
+# various attempted to make a paletted image from our now direct image
+my $palimg = $img->to_paletted;
+ok($palimg, "we got an image");
+# they should be the same pixel for pixel
+ok(Imager::i_img_diff($img->{IMG}, $palimg->{IMG}) == 0, "same pixels");
+
+# strange case: no color picking, and no colors
+# this was causing a segmentation fault
+$palimg = $img->to_paletted(colors=>[ ], make_colors=>'none');
+ok(!defined $palimg, "to paletted with an empty palette is an error");
+print "# ",$img->errstr,"\n";
+ok(scalar($img->errstr =~ /no colors available for translation/),
+    "and got the correct msg");
+
+ok(!Imager->new(xsize=>1, ysize=>-1, type=>'paletted'), 
+    "fail on -ve height");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
+       "and correct error message");
+ok(!Imager->new(xsize=>-1, ysize=>1, type=>'paletted'), 
+    "fail on -ve width");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
+       "and correct error message");
+ok(!Imager->new(xsize=>-1, ysize=>-1, type=>'paletted'), 
+    "fail on -ve width/height");
+cmp_ok(Imager->errstr, '=~', qr/Image sizes must be positive/,
+       "and correct error message");
+
+ok(!Imager->new(xsize=>1, ysize=>1, type=>'paletted', channels=>0),
+    "fail on 0 channels");
+cmp_ok(Imager->errstr, '=~', qr/Channels must be positive and <= 4/,
+       "and correct error message");
+ok(!Imager->new(xsize=>1, ysize=>1, type=>'paletted', channels=>5),
+    "fail on 5 channels");
+cmp_ok(Imager->errstr, '=~', qr/Channels must be positive and <= 4/,
+       "and correct error message");
+
+{
+  # https://rt.cpan.org/Ticket/Display.html?id=8213
+  # check for handling of memory allocation of very large images
+  # only test this on 32-bit machines - on a 64-bit machine it may
+  # result in trying to allocate 4Gb of memory, which is unfriendly at
+  # least and may result in running out of memory, causing a different
+  # type of exit
+  use Config;
+ SKIP:
+  {
+    skip("don't want to allocate 4Gb", 10)
+      unless $Config{ptrsize} == 4;
+
+    my $uint_range = 256 ** $Config{intsize};
+    my $dim1 = int(sqrt($uint_range))+1;
+    
+    my $im_b = Imager->new(xsize=>$dim1, ysize=>$dim1, channels=>1, type=>'paletted');
+    is($im_b, undef, "integer overflow check - 1 channel");
+    
+    $im_b = Imager->new(xisze=>$dim1, ysize=>1, channels=>1, type=>'paletted');
+    ok($im_b, "but same width ok");
+    $im_b = Imager->new(xisze=>1, ysize=>$dim1, channels=>1, type=>'paletted');
+    ok($im_b, "but same height ok");
+    cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
+           "check the error message");
+
+    # do a similar test with a 3 channel image, so we're sure we catch
+    # the same case where the third dimension causes the overflow
+    # for paletted images the third dimension can't cause an overflow
+    # but make sure we didn't anything too dumb in the checks
+    my $dim3 = $dim1;
+    
+    $im_b = Imager->new(xsize=>$dim3, ysize=>$dim3, channels=>3, type=>'paletted');
+    is($im_b, undef, "integer overflow check - 3 channel");
+    
+    $im_b = Imager->new(xsize=>$dim3, ysize=>1, channels=>3, type=>'paletted');
+    ok($im_b, "but same width ok");
+    $im_b = Imager->new(xsize=>1, ysize=>$dim3, channels=>3, type=>'paletted');
+    ok($im_b, "but same height ok");
+
+    cmp_ok(Imager->errstr, '=~', qr/integer overflow/,
+           "check the error message");
+
+    # test the scanline allocation check
+    # divide by 2 to get int range, by 3 so that the image (one byte/pixel)
+    # doesn't integer overflow, but the scanline of i_color (4/pixel) does
+    my $dim4 = $uint_range / 3;
+    my $im_o = Imager->new(xsize=>$dim4, ysize=>1, channels=>3, type=>'paletted');
+    is($im_o, undef, "integer overflow check - scanline size");
+    cmp_ok(Imager->errstr, '=~', 
+           qr/integer overflow calculating scanline allocation/,
+           "check error message");
+  }
+}
+
+{ # http://rt.cpan.org/NoAuth/Bug.html?id=9672
+  my $warning;
+  local $SIG{__WARN__} = 
+    sub { 
+      $warning = "@_";
+      my $printed = $warning;
+      $printed =~ s/\n$//;
+      $printed =~ s/\n/\n\#/g; 
+      print "# ",$printed, "\n";
+    };
+  my $img = Imager->new(xsize=>10, ysize=>10);
+  $img->to_paletted();
+  cmp_ok($warning, '=~', 'void', "correct warning");
+  cmp_ok($warning, '=~', 'palette\\.t', "correct file");
+}
+
+{ # http://rt.cpan.org/NoAuth/Bug.html?id=12676
+  # setcolors() has a fencepost error
+  my $img = Imager->new(xsize=>10, ysize=>10, type=>'paletted');
+
+  is($img->addcolors(colors=>[ $black, $red ]), "0 but true",
+     "add test colors");
+  ok($img->setcolors(start=>1, colors=>[ $green ]), "set the last color");
+  ok(!$img->setcolors(start=>2, colors=>[ $black ]), 
+     "set after the last color");
+}
+
+{ # https://rt.cpan.org/Ticket/Display.html?id=20056
+  # added named color support to addcolor/setcolor
+  my $img = Imager->new(xsize => 10, ysize => 10, type => 'paletted');
+  is($img->addcolors(colors => [ qw/000000 FF0000/ ]), "0 but true",
+     "add colors as strings instead of objects");
+  my @colors = $img->getcolors;
+  iscolor($colors[0], $black, "check first color");
+  iscolor($colors[1], $red, "check second color");
+  ok($img->setcolors(colors => [ qw/00FF00 0000FF/ ]),
+     "setcolors as strings instead of objects");
+  @colors = $img->getcolors;
+  iscolor($colors[0], $green, "check first color");
+  iscolor($colors[1], $blue, "check second color");
+
+  # make sure we handle bad colors correctly
+  is($img->colorcount, 2, "start from a known state");
+  is($img->addcolors(colors => [ 'XXFGXFXGXFX' ]), undef,
+     "fail to add unknown color");
+  is($img->errstr, 'No color named XXFGXFXGXFX found', 'check error message');
+  is($img->setcolors(colors => [ 'XXFGXFXGXFXZ' ]), undef,
+     "fail to set to unknown color");
+  is($img->errstr, 'No color named XXFGXFXGXFXZ found', 'check error message');
+}
+
+{ # https://rt.cpan.org/Ticket/Display.html?id=20338
+  # OO interface to i_glin/i_plin
+  my $im = Imager->new(xsize => 10, ysize => 10, type => 'paletted');
+  is($im->addcolors(colors => [ "#000", "#F00", "#0F0", "#00F" ]), "0 but true",
+     "add some test colors")
+    or print "# ", $im->errstr, "\n";
+  # set a pixel to check
+  $im->setpixel(x => 1, 'y' => 0, color => "#0F0");
+  is_deeply([ $im->getscanline('y' => 0, type=>'index') ],
+            [ 0, 2, (0) x 8 ], "getscanline index in list context");
+  isbin($im->getscanline('y' => 0, type=>'index'),
+        "\x00\x02" . "\x00" x 8,
+        "getscanline index in scalar context");
+  is($im->setscanline('y' => 0, pixels => [ 1, 2, 0, 3 ], type => 'index'),
+     4, "setscanline with list");
+  is($im->setscanline('y' => 0, x => 4, pixels => pack("C*", 3, 2, 1, 0, 3),
+                      type => 'index'),
+     5, "setscanline with pv");
+  is_deeply([ $im->getscanline(type => 'index', 'y' => 0) ],
+            [ 1, 2, 0, 3, 3, 2, 1, 0, 3, 0 ],
+            "check values set");
+  eval { # should croak on OOR index
+    $im->setscanline('y' => 1, pixels => [ 255 ], type=>'index');
+  };
+  ok($@, "croak on setscanline() to invalid index");
+  eval { # same again with pv
+    $im->setscanline('y' => 1, pixels => "\xFF", type => 'index');
+  };
+  ok($@, "croak on setscanline() with pv to invalid index");
+}
+
+{
+  print "# make_colors => mono\n";
+  # test mono make_colors
+  my $imrgb = Imager->new(xsize => 10, ysize => 10);
+  $imrgb->setpixel(x => 0, 'y' => 0, color => '#FFF');
+  $imrgb->setpixel(x => 1, 'y' => 0, color => '#FF0');
+  $imrgb->setpixel(x => 2, 'y' => 0, color => '#000');
+  my $mono = $imrgb->to_paletted(make_colors => 'mono',
+                                  translate => 'closest');
+  is($mono->type, 'paletted', "check we get right image type");
+  is($mono->colorcount, 2, "only 2 colors");
+  my ($is_mono, $ziw) = $mono->is_bilevel;
+  ok($is_mono, "check monochrome check true");
+  is($ziw, 0, "check ziw false");
+  my @colors = $mono->getcolors;
+  iscolor($colors[0], $black, "check first entry");
+  iscolor($colors[1], $white, "check second entry");
+  my @pixels = $mono->getscanline(x => 0, 'y' => 0, width => 3, type=>'index');
+  is($pixels[0], 1, "check white pixel");
+  is($pixels[1], 1, "check yellow pixel");
+  is($pixels[2], 0, "check black pixel");
+}
+
+{ # check for the various mono images we accept
+  my $mono_8_bw_3 = Imager->new(xsize => 2, ysize => 2, channels => 3, 
+                             type => 'paletted');
+  ok($mono_8_bw_3->addcolors(colors => [ qw/000000 FFFFFF/ ]), 
+     "mono8bw3 - add colors");
+  ok($mono_8_bw_3->is_bilevel, "it's mono");
+  is(($mono_8_bw_3->is_bilevel)[1], 0, 'zero not white');
+  
+  my $mono_8_wb_3 = Imager->new(xsize => 2, ysize => 2, channels => 3, 
+                             type => 'paletted');
+  ok($mono_8_wb_3->addcolors(colors => [ qw/FFFFFF 000000/ ]), 
+     "mono8wb3 - add colors");
+  ok($mono_8_wb_3->is_bilevel, "it's mono");
+  is(($mono_8_wb_3->is_bilevel)[1], 1, 'zero is white');
+  
+  my $mono_8_bw_1 = Imager->new(xsize => 2, ysize => 2, channels => 1, 
+                             type => 'paletted');
+  ok($mono_8_bw_1->addcolors(colors => [ qw/000000 FFFFFF/ ]), 
+     "mono8bw - add colors");
+  ok($mono_8_bw_1->is_bilevel, "it's mono");
+  is(($mono_8_bw_1->is_bilevel)[1], 0, 'zero not white');
+  
+  my $mono_8_wb_1 = Imager->new(xsize => 2, ysize => 2, channels => 1, 
+                             type => 'paletted');
+  ok($mono_8_wb_1->addcolors(colors => [ qw/FFFFFF 000000/ ]), 
+     "mono8wb - add colors");
+  ok($mono_8_wb_1->is_bilevel, "it's mono");
+  is(($mono_8_wb_1->is_bilevel)[1], 1, 'zero is white');
+}
+
+{ # check bounds checking
+  my $im = Imager->new(xsize => 10, ysize => 10, type=>'paletted');
+  ok($im->addcolors(colors => [ $black ]), "add color of pixel bounds check writes");
+
+  image_bounds_checks($im);
+}
+
+{ # test colors array returns colors
+  my $data;
+  my $im = test_image();
+  my @colors;
+  my $imp = $im->to_paletted(colors => \@colors, 
+                            make_colors => 'webmap', 
+                            translate => 'closest');
+  ok($imp, "made paletted");
+  is(@colors, 216, "should be 216 colors in the webmap");
+  is_color3($colors[0], 0, 0, 0, "first should be 000000");
+  is_color3($colors[1], 0, 0, 0x33, "second should be 000033");
+  is_color3($colors[8], 0, 0x33, 0x66, "9th should be 003366");
+}
+
+{ # RT 68508
+  my $im = Imager->new(xsize => 10, ysize => 10);
+  $im->box(filled => 1, color => Imager::Color->new(255, 0, 0));
+  my $palim = $im->to_paletted(make_colors => "mono", translate => "errdiff");
+  ok($palim, "convert to mono with error diffusion");
+  my $blank = Imager->new(xsize => 10, ysize => 10);
+  isnt_image($palim, $blank, "make sure paletted isn't all black");
+}
+
+{ # check validation of palette entries
+  my $im = Imager->new(xsize => 10, ysize => 10, type => 'paletted');
+  $im->addcolors(colors => [ $black, $red ]);
+  {
+    my $no_croak = eval {
+      $im->setscanline(y => 0, type => 'index', pixels => [ 0, 1 ]);
+      1;
+    };
+    ok($no_croak, "valid values don't croak");
+  }
+  {
+    my $no_croak = eval {
+      $im->setscanline(y => 0, type => 'index', pixels => pack("C*", 0, 1));
+      1;
+    };
+    ok($no_croak, "valid values don't croak (packed)");
+  }
+  {
+    my $no_croak = eval {
+      $im->setscanline(y => 0, type => 'index', pixels => [ 2, 255 ]);
+      1;
+    };
+    ok(!$no_croak, "invalid values do croak");
+  }
+  {
+    my $no_croak = eval {
+      $im->setscanline(y => 0, type => 'index', pixels => pack("C*", 2, 255));
+      1;
+    };
+    ok(!$no_croak, "invalid values do croak (packed)");
+  }
+}
+
+{
+  my $im = Imager->new(xsize => 1, ysize => 1);
+  my $im_bad = Imager->new;
+  {
+    my @map = Imager->make_palette({});
+    ok(!@map, "make_palette should fail with no images");
+    is(Imager->errstr, "make_palette: supply at least one image",
+       "check error message");
+  }
+  {
+    my @map = Imager->make_palette({}, $im, $im_bad, $im);
+    ok(!@map, "make_palette should fail with an empty image");
+    is(Imager->errstr, "make_palette: image 2 is empty",
+       "check error message");
+  }
+  {
+    my @map = Imager->make_palette({ make_colors => "mono" }, $im);
+    is(@map, 2, "mono should make 2 color palette")
+      or skip("unexpected color count", 2);
+    is_color4($map[0], 0, 0, 0, 255, "check map[0]");
+    is_color4($map[1], 255, 255, 255, 255, "check map[1]");
+  }
+  {
+    my @map = Imager->make_palette({ make_colors => "gray4" }, $im);
+    is(@map, 4, "gray4 should make 4 color palette")
+      or skip("unexpected color count", 4);
+    is_color4($map[0], 0, 0, 0, 255, "check map[0]");
+    is_color4($map[1], 85, 85, 85, 255, "check map[1]");
+    is_color4($map[2], 170, 170, 170, 255, "check map[2]");
+    is_color4($map[3], 255, 255, 255, 255, "check map[3]");
+  }
+  {
+    my @map = Imager->make_palette({ make_colors => "gray16" }, $im);
+    is(@map, 16, "gray16 should make 16 color palette")
+      or skip("unexpected color count", 4);
+    is_color4($map[0], 0, 0, 0, 255, "check map[0]");
+    is_color4($map[1], 17, 17, 17, 255, "check map[1]");
+    is_color4($map[2], 34, 34, 34, 255, "check map[2]");
+    is_color4($map[15], 255, 255, 255, 255, "check map[15]");
+  }
+  {
+    my @map = Imager->make_palette({ make_colors => "gray" }, $im);
+    is(@map, 256, "gray16 should make 256 color palette")
+      or skip("unexpected color count", 4);
+    is_color4($map[0], 0, 0, 0, 255, "check map[0]");
+    is_color4($map[1], 1, 1, 1, 255, "check map[1]");
+    is_color4($map[33], 33, 33, 33, 255, "check map[2]");
+    is_color4($map[255], 255, 255, 255, 255, "check map[15]");
+  }
+}
+
+my $psamp_outside_error = "Image position outside of image";
+{ # psamp
+  print "# psamp\n";
+  my $imraw = Imager::i_img_pal_new(10, 10, 3, 255);
+  my @colors =
+    (
+     NC(0, 0, 0), NC(255, 128, 64), NC(64, 128, 192),
+     NC(64, 0, 192), NC(255, 128, 0), NC(64, 32, 0),
+     NC(128, 63, 32), NC(255, 128, 32), NC(64, 32, 16),
+    );
+  is(Imager::i_addcolors($imraw, @colors), "0 but true",
+     "add colors needed for testing");
+  {
+    is(Imager::i_psamp($imraw, 0, 2, undef, [ 255, 128, 64 ]), 3,
+       "i_psamp def channels, 3 samples");
+    is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
+             "check color written");
+    Imager::i_img_setmask($imraw, 5);
+    is(Imager::i_psamp($imraw, 1, 3, undef, [ 64, 128, 192 ]), 3,
+       "i_psamp def channels, 3 samples, masked");
+    is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 192,
+             "check color written");
+    is(Imager::i_psamp($imraw, 1, 7, [ 0, 1, 2 ], [ 64, 128, 192 ]), 3,
+       "i_psamp channels listed, 3 samples, masked");
+    is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 192,
+             "check color written");
+    Imager::i_img_setmask($imraw, ~0);
+    is(Imager::i_psamp($imraw, 2, 4, [ 0, 1 ], [ 255, 128, 64, 32 ]), 4,
+       "i_psamp channels [0, 1], 4 samples");
+    is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
+             "check first color written");
+    is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
+             "check second color written");
+    is(Imager::i_psamp($imraw, 0, 5, [ 0, 1, 2 ], [ (128, 63, 32) x 10 ]), 30,
+       "write a full row");
+    is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
+             [ (128, 63, 32) x 10 ],
+             "check full row");
+    is(Imager::i_psamp($imraw, 8, 8, [ 0, 1, 2 ],
+                      [ 255, 128, 32, 64, 32, 16, 32, 16, 8 ]),
+       6, "i_psamp channels [0, 1, 2], 9 samples, but room for 6");
+  }
+  { # errors we catch
+    is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, 3 ], [ 255, 128, 32 ]),
+       undef, "i_psamp channels [0, 1, 3], 3 samples (invalid channel number)");
+    is(_get_error(), "No channel 3 in this image",
+       "check error message");
+    is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, -1 ], [ 255, 128, 32 ]),
+       undef, "i_psamp channels [0, 1, -1], 3 samples (invalid channel number)");
+    is(_get_error(), "No channel -1 in this image",
+       "check error message");
+    is(Imager::i_psamp($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
+       "negative y");
+    is(_get_error(), $psamp_outside_error, "check message");
+    is(Imager::i_psamp($imraw, 0, 10, undef, [ 0, 0, 0 ]), undef,
+       "y overflow");
+    is(_get_error(), $psamp_outside_error, "check message");
+    is(Imager::i_psamp($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
+       "negative x");
+    is(_get_error(), $psamp_outside_error, "check message");
+    is(Imager::i_psamp($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
+       "x overflow");
+    is(_get_error(), $psamp_outside_error, "check message");
+  }
+  ok(Imager::i_img_type($imraw), "still paletted");
+  print "# end psamp tests\n";
+}
+
+{ # psampf
+  print "# psampf\n";
+  my $imraw = Imager::i_img_pal_new(10, 10, 3, 255);
+  my @colors =
+    (
+     NC(0, 0, 0), NC(255, 128, 64), NC(64, 128, 192),
+     NC(64, 0, 191), NC(255, 128, 0), NC(64, 32, 0),
+     NC(128, 64, 32), NC(255, 128, 32), NC(64, 32, 16),
+    );
+  is(Imager::i_addcolors($imraw, @colors), "0 but true",
+     "add colors needed for testing");
+  {
+    is(Imager::i_psampf($imraw, 0, 2, undef, [ 1, 0.5, 0.25 ]), 3,
+       "i_psampf def channels, 3 samples");
+    is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
+             "check color written");
+    Imager::i_img_setmask($imraw, 5);
+    is(Imager::i_psampf($imraw, 1, 3, undef, [ 0.25, 0.5, 0.75 ]), 3,
+       "i_psampf def channels, 3 samples, masked");
+    is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 191,
+             "check color written");
+    is(Imager::i_psampf($imraw, 1, 7, [ 0, 1, 2 ], [ 0.25, 0.5, 0.75 ]), 3,
+       "i_psampf channels listed, 3 samples, masked");
+    is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 191,
+             "check color written");
+    Imager::i_img_setmask($imraw, ~0);
+    is(Imager::i_psampf($imraw, 2, 4, [ 0, 1 ], [ 1, 0.5, 0.25, 0.125 ]), 4,
+       "i_psampf channels [0, 1], 4 samples");
+    is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
+             "check first color written");
+    is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
+             "check second color written");
+    is(Imager::i_psampf($imraw, 0, 5, [ 0, 1, 2 ], [ (0.5, 0.25, 0.125) x 10 ]), 30,
+       "write a full row");
+    is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
+             [ (128, 64, 32) x 10 ],
+             "check full row");
+    is(Imager::i_psampf($imraw, 8, 8, [ 0, 1, 2 ],
+                       [ 1.0, 0.5, 0.125, 0.25, 0.125, 0.0625, 0.125, 0, 1 ]),
+       6, "i_psampf channels [0, 1, 2], 9 samples, but room for 6");
+  }
+  { # errors we catch
+    is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, 3 ], [ 1, 0.5, 0.125 ]),
+       undef, "i_psampf channels [0, 1, 3], 3 samples (invalid channel number)");
+    is(_get_error(), "No channel 3 in this image",
+       "check error message");
+    is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, -1 ], [ 1, 0.5, 0.125 ]),
+       undef, "i_psampf channels [0, 1, -1], 3 samples (invalid channel number)");
+    is(_get_error(), "No channel -1 in this image",
+       "check error message");
+    is(Imager::i_psampf($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
+       "negative y");
+    is(_get_error(), $psamp_outside_error, "check message");
+    is(Imager::i_psampf($imraw, 0, 10, undef, [ 0, 0, 0 ]), undef,
+       "y overflow");
+    is(_get_error(), $psamp_outside_error, "check message");
+    is(Imager::i_psampf($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
+       "negative x");
+    is(_get_error(), $psamp_outside_error, "check message");
+    is(Imager::i_psampf($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
+       "x overflow");
+    is(_get_error(), $psamp_outside_error, "check message");
+  }
+  ok(Imager::i_img_type($imraw), "still paletted");
+  print "# end psampf tests\n";
+}
+
+{ # 75258 - gpixf() broken for paletted images
+  my $im = Imager->new(xsize => 10, ysize => 10, type => "paletted");
+  ok($im, "make a test image");
+  my @colors = ( $black, $red, $green, $blue );
+  is($im->addcolors(colors => \@colors), "0 but true",
+     "add some colors");
+  $im->setpixel(x => 0, y => 0, color => $red);
+  $im->setpixel(x => 1, y => 0, color => $green);
+  $im->setpixel(x => 2, y => 0, color => $blue);
+  is_fcolor3($im->getpixel(x => 0, y => 0, type => "float"),
+            1.0, 0, 0, "get a pixel in float form, make sure it's red");
+  is_fcolor3($im->getpixel(x => 1, y => 0, type => "float"),
+            0, 1.0, 0, "get a pixel in float form, make sure it's green");
+  is_fcolor3($im->getpixel(x => 2, y => 0, type => "float"),
+            0, 0, 1.0, "get a pixel in float form, make sure it's blue");
+}
+
+{
+  my $empty = Imager->new;
+  ok(!$empty->to_paletted, "can't convert an empty image");
+  is($empty->errstr, "to_paletted: empty input image",
+    "check error message");
+
+  is($empty->addcolors(colors => [ $black ]), -1,
+     "can't addcolors() to an empty image");
+  is($empty->errstr, "addcolors: empty input image",
+     "check error message");
+
+  ok(!$empty->setcolors(colors => [ $black ]),
+     "can't setcolors() to an empty image");
+  is($empty->errstr, "setcolors: empty input image",
+     "check error message");
+
+  ok(!$empty->getcolors(),
+     "can't getcolors() from an empty image");
+  is($empty->errstr, "getcolors: empty input image",
+     "check error message");
+
+  is($empty->colorcount, -1, "can't colorcount() an empty image");
+  is($empty->errstr, "colorcount: empty input image",
+     "check error message");
+
+  is($empty->maxcolors, -1, "can't maxcolors() an empty image");
+  is($empty->errstr, "maxcolors: empty input image",
+     "check error message");
+
+  is($empty->findcolor(color => $blue), undef,
+     "can't findcolor an empty image");
+  is($empty->errstr, "findcolor: empty input image",
+     "check error message");
+}
+
+Imager->close_log;
+
+unless ($ENV{IMAGER_KEEP_FILES}) {
+  unlink "testout/t023palette.log"
+}
+
+sub iscolor {
+  my ($c1, $c2, $msg) = @_;
+
+  my $builder = Test::Builder->new;
+  my @c1 = $c1->rgba;
+  my @c2 = $c2->rgba;
+  if (!$builder->ok($c1[0] == $c2[0] && $c1[1] == $c2[1] && $c1[2] == $c2[2],
+                    $msg)) {
+    $builder->diag(<<DIAG);
+      got color: [ @c1 ]
+ expected color: [ @c2 ]
+DIAG
+  }
+}
+
+sub isbin ($$$) {
+  my ($got, $expected, $msg) = @_;
+
+  my $builder = Test::Builder->new;
+  if (!$builder->ok($got eq $expected, $msg)) {
+    (my $got_dec = $got) =~ s/([^ -~])/sprintf("\\x%02x", ord $1)/ge;
+    (my $exp_dec = $expected)  =~ s/([^ -~])/sprintf("\\x%02x", ord $1)/ge;
+    $builder->diag(<<DIAG);
+      got: "$got_dec"
+ expected: "$exp_dec"
+DIAG
+  }
+}
+
+sub coloreq {
+  my ($left, $right, $comment) = @_;
+
+  my ($rl, $gl, $bl, $al) = $left->rgba;
+  my ($rr, $gr, $br, $ar) = $right->rgba;
+
+  print "# comparing color($rl,$gl,$bl,$al) with ($rr,$gr,$br,$ar)\n";
+  ok($rl == $rr && $gl == $gr && $bl == $br && $al == $ar,
+      $comment);
+}
+
+sub _get_error {
+  my @errors = Imager::i_errors();
+  return join(": ", map $_->[0], @errors);
+}
diff --git a/t/150-type/100-masked.t b/t/150-type/100-masked.t
new file mode 100644 (file)
index 0000000..95d5f1a
--- /dev/null
@@ -0,0 +1,706 @@
+#!perl -w
+use strict;
+use Test::More tests => 244;
+use Imager qw(:all :handy);
+use Imager::Test qw(is_color3 is_fcolor3);
+
+-d "testout" or mkdir "testout";
+
+Imager->open_log(log => "testout/t020masked.log");
+
+my $base_rgb = Imager::ImgRaw::new(100, 100, 3);
+# put something in there
+my $black = NC(0, 0, 0);
+my $red = NC(255, 0, 0);
+my $green = NC(0, 255, 0);
+my $blue = NC(0, 0, 255);
+my $white = NC(255, 255, 255);
+my $grey = NC(128, 128, 128);
+use Imager::Color::Float;
+my $redf = Imager::Color::Float->new(1, 0, 0);
+my $greenf = Imager::Color::Float->new(0, 1, 0);
+my $bluef = Imager::Color::Float->new(0, 0, 1);
+my $greyf = Imager::Color::Float->new(0.5, 0.5, 0.5);
+my @cols = ($red, $green, $blue);
+for my $y (0..99) {
+  Imager::i_plin($base_rgb, 0, $y, ($cols[$y % 3] ) x 100);
+}
+
+# first a simple subset image
+my $s_rgb = Imager::i_img_masked_new($base_rgb, undef, 25, 25, 50, 50);
+
+is(Imager::i_img_getchannels($s_rgb), 3,
+   "1 channel image channel count match");
+ok(Imager::i_img_getmask($s_rgb) & 1,
+   "1 channel image mask");
+ok(Imager::i_img_virtual($s_rgb),
+   "1 channel image thinks it isn't virtual");
+is(Imager::i_img_bits($s_rgb), 8,
+   "1 channel image has bits == 8");
+is(Imager::i_img_type($s_rgb), 0, # direct
+   "1 channel image is direct");
+
+my @ginfo = i_img_info($s_rgb);
+is($ginfo[0], 50, "check width");
+is($ginfo[1], 50, "check height");
+
+# sample some pixels through the subset
+my $c = Imager::i_get_pixel($s_rgb, 0, 0);
+is_color3($c, 0, 255, 0, "check (0,0)");
+$c = Imager::i_get_pixel($s_rgb, 49, 49);
+# (25+49)%3 = 2
+is_color3($c, 0, 0, 255, "check (49,49)");
+
+# try writing to it
+for my $y (0..49) {
+  Imager::i_plin($s_rgb, 0, $y, ($cols[$y % 3]) x 50);
+}
+pass("managed to write to it");
+# and checking the target image
+$c = Imager::i_get_pixel($base_rgb, 25, 25);
+is_color3($c, 255, 0, 0, "check (25,25)");
+$c = Imager::i_get_pixel($base_rgb, 29, 29);
+is_color3($c, 0, 255, 0, "check (29,29)");
+
+undef $s_rgb;
+
+# a basic background
+for my $y (0..99) {
+  Imager::i_plin($base_rgb, 0, $y, ($red ) x 100);
+}
+my $mask = Imager::ImgRaw::new(50, 50, 1);
+# some venetian blinds
+for my $y (4..20) {
+  Imager::i_plin($mask, 5, $y*2, ($white) x 40);
+}
+# with a strip down the middle
+for my $y (0..49) {
+  Imager::i_plin($mask, 20, $y, ($white) x 8);
+}
+my $m_rgb = Imager::i_img_masked_new($base_rgb, $mask, 25, 25, 50, 50);
+ok($m_rgb, "make masked with mask");
+for my $y (0..49) {
+  Imager::i_plin($m_rgb, 0, $y, ($green) x 50);
+}
+my @color_tests =
+  (
+   [ 25+0,  25+0,  $red ],
+   [ 25+19, 25+0,  $red ],
+   [ 25+20, 25+0,  $green ],
+   [ 25+27, 25+0,  $green ],
+   [ 25+28, 25+0,  $red ],
+   [ 25+49, 25+0,  $red ],
+   [ 25+19, 25+7,  $red ],
+   [ 25+19, 25+8,  $green ],
+   [ 25+19, 25+9,  $red ],
+   [ 25+0,  25+8,  $red ],
+   [ 25+4,  25+8,  $red ],
+   [ 25+5,  25+8,  $green ],
+   [ 25+44, 25+8,  $green ],
+   [ 25+45, 25+8,  $red ],
+   [ 25+49, 25+49, $red ],
+  );
+my $test_num = 15;
+for my $test (@color_tests) {
+  my ($x, $y, $testc) = @$test;
+  my ($r, $g, $b) = $testc->rgba;
+  my $c = Imager::i_get_pixel($base_rgb, $x, $y);
+  is_color3($c, $r, $g, $b, "at ($x, $y)");
+}
+
+{
+  # tests for the OO versions, fairly simple, since the basic functionality
+  # is covered by the low-level interface tests
+   
+  my $base = Imager->new(xsize=>100, ysize=>100);
+  ok($base, "make base OO image");
+  $base->box(color=>$blue, filled=>1); # fill it all
+  my $mask = Imager->new(xsize=>80, ysize=>80, channels=>1);
+  $mask->box(color=>$white, filled=>1, xmin=>5, xmax=>75, ymin=>5, ymax=>75);
+  my $m_img = $base->masked(mask=>$mask, left=>5, top=>5);
+  ok($m_img, "make masked OO image");
+  is($m_img->getwidth, 80, "check width");
+  $m_img->box(color=>$green, filled=>1);
+  my $c = $m_img->getpixel(x=>0, y=>0);
+  is_color3($c, 0, 0, 255, "check (0,0)");
+  $c = $m_img->getpixel(x => 5, y => 5);
+  is_color3($c, 0, 255, 0, "check (5,5)");
+
+  # older versions destroyed the Imager::ImgRaw object manually in 
+  # Imager::DESTROY rather than letting Imager::ImgRaw::DESTROY 
+  # destroy the object
+  # so we test here by destroying the base and mask objects and trying 
+  # to draw to the masked wrapper
+  # you may need to test with ElectricFence to trigger the problem
+  undef $mask;
+  undef $base;
+  $m_img->box(color=>$blue, filled=>1);
+  pass("didn't crash unreffing base or mask for masked image");
+}
+
+# 35.7% cover on maskimg.c up to here
+
+{ # error handling:
+  my $base = Imager->new(xsize => 100, ysize => 100);
+  ok($base, "make base");
+  { #  make masked image subset outside of the base image
+    my $masked = $base->masked(left => 100);
+    ok (!$masked, "fail to make empty masked");
+    is($base->errstr, "subset outside of target image", "check message");
+  }
+}
+
+{ # size limiting
+  my $base = Imager->new(xsize => 10, ysize => 10);
+  ok($base, "make base for size limit tests");
+  {
+    my $masked = $base->masked(left => 5, right => 15);
+    ok($masked, "make masked");
+    is($masked->getwidth, 5, "check width truncated");
+  }
+  {
+    my $masked = $base->masked(top => 5, bottom => 15);
+    ok($masked, "make masked");
+    is($masked->getheight, 5, "check height truncated");
+  }
+}
+# 36.7% up to here
+
+$mask = Imager->new(xsize => 80, ysize => 80, channels => 1);
+$mask->box(filled => 1, color => $white, xmax => 39, ymax => 39);
+$mask->box(fill => { hatch => "check1x1" }, ymin => 40, xmax => 39);
+
+{
+  my $base = Imager->new(xsize => 100, ysize => 100, bits => "double");
+  ok($base, "base for single pixel tests");
+  is($base->type, "direct", "check type");
+  my $masked = $base->masked(mask => $mask, left => 1, top => 2);
+  my $limited = $base->masked(left => 1, top => 2);
+
+  is($masked->type, "direct", "check masked is same type as base");
+  is($limited->type, "direct", "check limited is same type as base");
+
+  {
+    # single pixel writes, masked
+    {
+      ok($masked->setpixel(x => 1, y => 3, color => $green),
+        "set (1,3) in masked (2, 5) in based");
+      my $c = $base->getpixel(x => 2, y => 5);
+      is_color3($c, 0, 255, 0, "check it wrote through");
+      ok($masked->setpixel(x => 45, y => 2, color => $red),
+        "set (45,2) in masked (46,4) in base (no mask)");
+    $c = $base->getpixel(x => 46, y => 4);
+      is_color3($c, 0, 0, 0, "shouldn't have written through");
+    }
+    {
+      ok($masked->setpixel(x => 2, y => 3, color => $redf),
+        "write float red to (2,3) base(3,5)");
+      my $c = $base->getpixel(x => 3, y => 5);
+      is_color3($c, 255, 0, 0, "check it wrote through");
+      ok($masked->setpixel(x => 45, y => 3, color => $greenf),
+        "set float (45,3) in masked (46,5) in base (no mask)");
+      $c = $base->getpixel(x => 46, y => 5);
+      is_color3($c, 0, 0, 0, "check it didn't write");
+    }
+    {
+      # write out of range should fail
+      ok(!$masked->setpixel(x => 80, y => 0, color => $green),
+        "write 8-bit color out of range");
+      ok(!$masked->setpixel(x => 0, y => 80, color => $greenf),
+        "write float color out of range");
+    }
+  }
+
+  # 46.9
+
+  {
+    print "# plin coverage\n";
+    {
+      $base->box(filled => 1, color => $black);
+      # plin masked
+      # simple path
+      is($masked->setscanline(x => 76, y => 1, pixels => [ ($red, $green) x 3 ]),
+        4, "try to write 6 pixels, but only write 4");
+      is_deeply([ $base->getsamples(x => 77, y => 3, width => 4) ],
+               [ ( 0 ) x 12 ],
+               "check not written through");
+      # !simple path
+      is($masked->setscanline(x => 4, y => 2, pixels => [ ($red, $green, $blue, $grey) x (72/4) ]),
+        72, "write many pixels (masked)");
+      is_deeply([ $base->getsamples(x => 5, y => 4, width => 72) ],
+               [ ( (255, 0, 0), (0, 255, 0), (0, 0, 255), (128, 128, 128)) x 9,
+                 ( 0, 0, 0 ) x 36 ],
+               "check written through to base");
+      
+      # simple path, due to number of transitions
+      is($masked->setscanline(x => 0, y => 40, pixels => [ ($red, $green, $blue, $grey) x 5 ]),
+        20, "try to write 20 pixels, with alternating write through");
+      is_deeply([ $base->getsamples(x => 1, y => 42, width => 20) ],
+               [ ( (0, 0, 0), (0,255,0), (0,0,0), (128,128,128) ) x 5 ],
+               "check correct pixels written through");
+    }
+    
+    {
+      $base->box(filled => 1, color => $black);
+      # plin, non-masked path
+      is($limited->setscanline(x => 4, y => 2, pixels => [ ($red, $green, $blue, $grey) x (72/4) ]),
+        72, "write many pixels (limited)");
+      is_deeply([ $base->getsamples(x => 5, y => 4, width => 72) ],
+               [ ( (255, 0, 0), (0, 255, 0), (0, 0, 255), (128, 128, 128)) x 18 ],
+               "check written through to based");
+    }
+    
+    {
+      # draw outside fails
+      is($masked->setscanline(x => 80, y => 2, pixels => [ $red, $green ]),
+        0, "check writing no pixels");
+    }
+  }
+
+  {
+    print "# plinf coverage\n";
+    {
+      $base->box(filled => 1, color => $black);
+      # plinf masked
+      # simple path
+      is($masked->setscanline(x => 76, y => 1, pixels => [ ($redf, $greenf) x 3 ]),
+        4, "try to write 6 pixels, but only write 4");
+      is_deeply([ $base->getsamples(x => 77, y => 3, width => 4, type => "float") ],
+               [ ( 0 ) x 12 ],
+               "check not written through");
+      # !simple path
+      is($masked->setscanline(x => 4, y => 2, pixels => [ ($redf, $greenf, $bluef, $greyf) x (72/4) ]),
+        72, "write many pixels (masked)");
+      is_deeply([ $base->getsamples(x => 5, y => 4, width => 72, type => "float") ],
+               [ ( (1, 0, 0), (0, 1, 0), (0, 0, 1), (0.5, 0.5, 0.5)) x 9,
+                 ( 0, 0, 0 ) x 36 ],
+               "check written through to base");
+      
+      # simple path, due to number of transitions
+      is($masked->setscanline(x => 0, y => 40, pixels => [ ($redf, $greenf, $bluef, $greyf) x 5 ]),
+        20, "try to write 20 pixels, with alternating write through");
+      is_deeply([ $base->getsamples(x => 1, y => 42, width => 20, type => "float") ],
+               [ ( (0, 0, 0), (0,1,0), (0,0,0), (0.5,0.5,0.5) ) x 5 ],
+               "check correct pixels written through");
+    }
+    
+    {
+      $base->box(filled => 1, color => $black);
+      # plinf, non-masked path
+      is($limited->setscanline(x => 4, y => 2, pixels => [ ($redf, $greenf, $bluef, $greyf) x (72/4) ]),
+        72, "write many pixels (limited)");
+      is_deeply([ $base->getsamples(x => 5, y => 4, width => 72, type => "float") ],
+               [ ( (1, 0, 0), (0, 1, 0), (0, 0, 1), (0.5, 0.5, 0.5)) x 18 ],
+               "check written through to based");
+    }
+    
+    {
+      # draw outside fails
+      is($masked->setscanline(x => 80, y => 2, pixels => [ $redf, $greenf ]),
+        0, "check writing no pixels");
+    }
+  }
+  # 71.4%
+  {
+    {
+      print "# gpix\n";
+      # gpix
+      $base->box(filled => 1, color => $black);
+      ok($base->setpixel(x => 4, y => 10, color => $red),
+        "set base(4,10) to red");
+      is_fcolor3($masked->getpixel(x => 3, y => 8),
+                255, 0, 0, "check pixel written");
+
+      # out of range
+      is($masked->getpixel(x => -1, y => 1),
+        undef, "check failure to left");
+      is($masked->getpixel(x => 0, y => -1),
+        undef, "check failure to top");
+      is($masked->getpixel(x => 80, y => 1),
+        undef, "check failure to right");
+      is($masked->getpixel(x => 0, y => 80),
+        undef, "check failure to bottom");
+    }
+    {
+      print "# gpixf\n";
+      # gpixf
+      $base->box(filled => 1, color => $black);
+      ok($base->setpixel(x => 4, y => 10, color => $redf),
+        "set base(4,10) to red");
+      is_fcolor3($masked->getpixel(x => 3, y => 8, type => "float"),
+                1.0, 0, 0, 0, "check pixel written");
+
+      # out of range
+      is($masked->getpixel(x => -1, y => 1, type => "float"),
+        undef, "check failure to left");
+      is($masked->getpixel(x => 0, y => -1, type => "float"),
+        undef, "check failure to top");
+      is($masked->getpixel(x => 80, y => 1, type => "float"),
+        undef, "check failure to right");
+      is($masked->getpixel(x => 0, y => 80, type => "float"),
+        undef, "check failure to bottom");
+    }
+  }
+  # 74.5
+  {
+    {
+      print "# glin\n";
+      $base->box(filled => 1, color => $black);
+      is($base->setscanline(x => 31, y => 3, 
+                           pixels => [ ( $red, $green) x 10 ]),
+        20, "write 20 pixels to base image");
+      my @colors = $masked->
+       getscanline(x => 30, y => 1, width => 20);
+      is(@colors, 20, "check we got right number of colors");
+      is_color3($colors[0], 255, 0, 0, "check first pixel");
+      is_color3($colors[19], 0, 255, 0, "check last pixel");
+
+      @colors = $masked->getscanline(x => 76, y => 2, width => 10);
+      is(@colors, 4, "read line from right edge");
+      is_color3($colors[0], 0, 0, 0, "check pixel");
+
+      is_deeply([ $masked->getscanline(x => -1, y => 0, width => 1) ],
+        [], "fail read left of image");
+      is_deeply([ $masked->getscanline(x => 0, y => -1, width => 1) ],
+        [], "fail read top of image");
+      is_deeply([$masked->getscanline(x => 80, y => 0, width => 1)],
+        [], "fail read right of image");
+      is_deeply([$masked->getscanline(x => 0, y => 80, width => 1)],
+        [], "fail read bottom of image");
+    }
+    {
+      print "# glinf\n";
+      $base->box(filled => 1, color => $black);
+      is($base->setscanline(x => 31, y => 3, 
+                           pixels => [ ( $redf, $greenf) x 10 ]),
+        20, "write 20 pixels to base image");
+      my @colors = $masked->
+       getscanline(x => 30, y => 1, width => 20, type => "float");
+      is(@colors, 20, "check we got right number of colors");
+      is_fcolor3($colors[0], 1.0, 0, 0, 0, "check first pixel");
+      is_fcolor3($colors[19], 0, 1.0, 0, 0, "check last pixel");
+
+      @colors = $masked->
+       getscanline(x => 76, y => 2, width => 10, type => "float");
+      is(@colors, 4, "read line from right edge");
+      is_fcolor3($colors[0], 0, 0, 0, 0, "check pixel");
+
+      is_deeply([ $masked->getscanline(x => -1, y => 0, width => 1, type => "float") ],
+        [], "fail read left of image");
+      is_deeply([ $masked->getscanline(x => 0, y => -1, width => 1, type => "float") ],
+        [], "fail read top of image");
+      is_deeply([$masked->getscanline(x => 80, y => 0, width => 1, type => "float")],
+        [], "fail read right of image");
+      is_deeply([$masked->getscanline(x => 0, y => 80, width => 1, type => "float")],
+        [], "fail read bottom of image");
+    }
+  }
+  # 81.6%
+  {
+    {
+      print "# gsamp\n";
+      $base->box(filled => 1, color => $black);
+      is($base->setscanline(x => 31, y => 3, 
+                           pixels => [ ( $red, $green) x 10 ]),
+        20, "write 20 pixels to base image");
+      my @samps = $masked->
+       getsamples(x => 30, y => 1, width => 20);
+      is(@samps, 60, "check we got right number of samples");
+      is_deeply(\@samps,
+               [ (255, 0, 0, 0, 255, 0) x 10 ],
+               "check it");
+
+      @samps = $masked->
+       getsamples(x => 76, y => 2, width => 10);
+      is(@samps, 12, "read line from right edge");
+      is_deeply(\@samps, [ (0, 0, 0) x 4], "check result");
+
+      is_deeply([ $masked->getsamples(x => -1, y => 0, width => 1) ],
+        [], "fail read left of image");
+      is_deeply([ $masked->getsamples(x => 0, y => -1, width => 1) ],
+        [], "fail read top of image");
+      is_deeply([$masked->getsamples(x => 80, y => 0, width => 1)],
+        [], "fail read right of image");
+      is_deeply([$masked->getsamples(x => 0, y => 80, width => 1)],
+        [], "fail read bottom of image");
+    }
+    {
+      print "# gsampf\n";
+      $base->box(filled => 1, color => $black);
+      is($base->setscanline(x => 31, y => 3, 
+                           pixels => [ ( $redf, $greenf) x 10 ]),
+        20, "write 20 pixels to base image");
+      my @samps = $masked->
+       getsamples(x => 30, y => 1, width => 20, type => "float");
+      is(@samps, 60, "check we got right number of samples");
+      is_deeply(\@samps,
+               [ (1.0, 0, 0, 0, 1.0, 0) x 10 ],
+               "check it");
+
+      @samps = $masked->
+       getsamples(x => 76, y => 2, width => 10, type => "float");
+      is(@samps, 12, "read line from right edge");
+      is_deeply(\@samps, [ (0, 0, 0) x 4], "check result");
+
+      is_deeply([ $masked->getsamples(x => -1, y => 0, width => 1, type => "float") ],
+        [], "fail read left of image");
+      is_deeply([ $masked->getsamples(x => 0, y => -1, width => 1, type => "float") ],
+        [], "fail read top of image");
+      is_deeply([$masked->getsamples(x => 80, y => 0, width => 1, type => "float")],
+        [], "fail read right of image");
+      is_deeply([$masked->getsamples(x => 0, y => 80, width => 1, type => "float")],
+        [], "fail read bottom of image");
+    }
+  }
+  # 86.2%
+}
+
+{
+  my $base = Imager->new(xsize => 100, ysize => 100, type => "paletted");
+  ok($base, "make paletted base");
+  is($base->type, "paletted", "check we got paletted");
+  is($base->addcolors(colors => [ $black, $red, $green, $blue ]),
+     "0 but true",
+     "add some colors to base");
+  my $masked = $base->masked(mask => $mask, left => 1, top => 2);
+  my $limited = $base->masked(left => 1, top => 2);
+
+  is($masked->type, "paletted", "check masked is same type as base");
+  is($limited->type, "paletted", "check limited is same type as base");
+
+  {
+    # make sure addcolors forwarded
+    is($masked->addcolors(colors => [ $grey ]), 4,
+       "test addcolors forwarded");
+    my @colors = $masked->getcolors();
+    is(@colors, 5, "check getcolors forwarded");
+    is_color3($colors[1], 255, 0, 0, "check color from palette");
+  }
+
+  my ($blacki, $redi, $greeni, $bluei, $greyi) = 0 .. 4;
+
+  { # gpal
+    print "# gpal\n";
+    $base->box(filled => 1, color => $black);
+    is($base->setscanline(x => 0, y => 5, type => "index",
+                         pixels => [ ( $redi, $greeni, $bluei, $greyi) x 25 ]),
+       100, "write some pixels to base");
+    my @indexes = $masked->getscanline(y => 3, type => "index", width => "81");
+    is(@indexes, 80, "got 80 indexes");
+    is_deeply(\@indexes,
+             [ ( $greeni, $bluei, $greyi, $redi) x 20 ],
+             "check values");
+
+    is_deeply([ $masked->getscanline(x => -1, y => 3, type => "index") ],
+             [], "fail read left of image");
+  }
+  # 89.8%
+
+  { # ppal, unmasked
+    print "# ppal\n";
+    $base->box(filled => 1, color => $black);
+    is($limited->setscanline(x => 1, y => 1, type => "index",
+                            pixels => [ ( $redi, $greeni, $bluei) x 3 ]),
+       9, "ppal limited");
+    is_deeply([ $base->getscanline(x => 2, y => 3, type => "index", 
+                                  width => 9) ],
+             [ ( $redi, $greeni, $bluei) x 3 ],
+             "check set in base");
+  }
+  { # ppal, masked
+    $base->box(filled => 1, color => $black);
+    is($masked->setscanline(x => 1, y => 2, type => "index",
+                           pixels => [ ( $redi, $greeni, $bluei, $greyi) x 12 ]),
+       48, "ppal masked");
+    is_deeply([ $base->getscanline(x => 0, y => 4, type => "index") ],
+             [ 0, 0,
+               ( $redi, $greeni, $bluei, $greyi ) x 9,
+               $redi, $greeni, $bluei, ( 0 ) x 59 ],
+             "check written");
+  }
+  {
+    # ppal, errors
+    is($masked->setscanline(x => -1, y => 0, type => "index",
+                           pixels => [ $redi, $bluei ]),
+       0, "fail to write ppal");
+
+    is($masked->setscanline(x => 78, y => 0, type => "index",
+                          pixels => [ $redi, $bluei, $greeni, $greyi ]),
+       2, "write over right side");
+  }
+}
+
+my $full_mask = Imager->new(xsize => 10, ysize => 10, channels => 1);
+$full_mask->box(filled => 1, color => NC(255, 0, 0));
+
+# no mask and mask with full coverage should behave the same
+my $psamp_outside_error = "Image position outside of image";
+for my $masked (0, 1){ # psamp
+  print "# psamp masked: $masked\n";
+  my $imback = Imager::ImgRaw::new(20, 20, 3);
+  my $mask;
+  if ($masked) {
+    $mask = $full_mask->{IMG};
+  }
+  my $imraw = Imager::i_img_masked_new($imback, $mask, 3, 4, 10, 10);
+  {
+    is(Imager::i_psamp($imraw, 0, 2, undef, [ 255, 128, 64 ]), 3,
+       "i_psamp def channels, 3 samples");
+    is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
+             "check color written");
+    Imager::i_img_setmask($imraw, 5);
+    is(Imager::i_psamp($imraw, 1, 3, undef, [ 64, 128, 192 ]), 3,
+       "i_psamp def channels, 3 samples, masked");
+    is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 192,
+             "check color written");
+    is(Imager::i_psamp($imraw, 1, 7, [ 0, 1, 2 ], [ 64, 128, 192 ]), 3,
+       "i_psamp channels listed, 3 samples, masked");
+    is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 192,
+             "check color written");
+    Imager::i_img_setmask($imraw, ~0);
+    is(Imager::i_psamp($imraw, 2, 4, [ 0, 1 ], [ 255, 128, 64, 32 ]), 4,
+       "i_psamp channels [0, 1], 4 samples");
+    is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
+             "check first color written");
+    is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
+             "check second color written");
+    is(Imager::i_psamp($imraw, 0, 5, [ 0, 1, 2 ], [ (128, 63, 32) x 10 ]), 30,
+       "write a full row");
+    is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
+             [ (128, 63, 32) x 10 ],
+             "check full row");
+    is(Imager::i_psamp($imraw, 8, 8, [ 0, 1, 2 ],
+                      [ 255, 128, 32, 64, 32, 16, 32, 16, 8 ]),
+       6, "i_psamp channels [0, 1, 2], 9 samples, but room for 6");
+  }
+  { # errors we catch
+    is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, 3 ], [ 255, 128, 32 ]),
+       undef, "i_psamp channels [0, 1, 3], 3 samples (invalid channel number)");
+    is(_get_error(), "No channel 3 in this image",
+       "check error message");
+    is(Imager::i_psamp($imraw, 6, 8, [ 0, 1, -1 ], [ 255, 128, 32 ]),
+       undef, "i_psamp channels [0, 1, -1], 3 samples (invalid channel number)");
+    is(_get_error(), "No channel -1 in this image",
+       "check error message");
+    is(Imager::i_psamp($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
+       "negative y");
+    is(_get_error(), $psamp_outside_error, "check error message");
+    is(Imager::i_psamp($imraw, 0, 10, undef, [ 0, 0, 0 ]), undef,
+       "y overflow");
+    is(_get_error(), $psamp_outside_error, "check error message");
+    is(Imager::i_psamp($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
+       "negative x");
+    is(_get_error(), $psamp_outside_error, "check error message");
+    is(Imager::i_psamp($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
+       "x overflow");
+    is(_get_error(), $psamp_outside_error, "check error message");
+  }
+  print "# end psamp tests\n";
+}
+
+for my $masked (0, 1) { # psampf
+  print "# psampf\n";
+  my $imback = Imager::ImgRaw::new(20, 20, 3);
+  my $mask;
+  if ($masked) {
+    $mask = $full_mask->{IMG};
+  }
+  my $imraw = Imager::i_img_masked_new($imback, $mask, 3, 4, 10, 10);
+  {
+    is(Imager::i_psampf($imraw, 0, 2, undef, [ 1, 0.5, 0.25 ]), 3,
+       "i_psampf def channels, 3 samples");
+    is_color3(Imager::i_get_pixel($imraw, 0, 2), 255, 128, 64,
+             "check color written");
+    Imager::i_img_setmask($imraw, 5);
+    is(Imager::i_psampf($imraw, 1, 3, undef, [ 0.25, 0.5, 0.75 ]), 3,
+       "i_psampf def channels, 3 samples, masked");
+    is_color3(Imager::i_get_pixel($imraw, 1, 3), 64, 0, 191,
+             "check color written");
+    is(Imager::i_psampf($imraw, 1, 7, [ 0, 1, 2 ], [ 0.25, 0.5, 0.75 ]), 3,
+       "i_psampf channels listed, 3 samples, masked");
+    is_color3(Imager::i_get_pixel($imraw, 1, 7), 64, 0, 191,
+             "check color written");
+    Imager::i_img_setmask($imraw, ~0);
+    is(Imager::i_psampf($imraw, 2, 4, [ 0, 1 ], [ 1, 0.5, 0.25, 0.125 ]), 4,
+       "i_psampf channels [0, 1], 4 samples");
+    is_color3(Imager::i_get_pixel($imraw, 2, 4), 255, 128, 0,
+             "check first color written");
+    is_color3(Imager::i_get_pixel($imraw, 3, 4), 64, 32, 0,
+             "check second color written");
+    is(Imager::i_psampf($imraw, 0, 5, [ 0, 1, 2 ], [ (0.5, 0.25, 0.125) x 10 ]), 30,
+       "write a full row");
+    is_deeply([ Imager::i_gsamp($imraw, 0, 10, 5, [ 0, 1, 2 ]) ],
+             [ (128, 64, 32) x 10 ],
+             "check full row");
+    is(Imager::i_psampf($imraw, 8, 8, [ 0, 1, 2 ],
+                       [ 1.0, 0.5, 0.125, 0.25, 0.125, 0.0625, 0.125, 0, 1 ]),
+       6, "i_psampf channels [0, 1, 2], 9 samples, but room for 6");
+  }
+  { # errors we catch
+    is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, 3 ], [ 1, 0.5, 0.125 ]),
+       undef, "i_psampf channels [0, 1, 3], 3 samples (invalid channel number)");
+    is(_get_error(), "No channel 3 in this image",
+       "check error message");
+    is(Imager::i_psampf($imraw, 6, 8, [ 0, 1, -1 ], [ 1, 0.5, 0.125 ]),
+       undef, "i_psampf channels [0, 1, -1], 3 samples (invalid channel number)");
+    is(_get_error(), "No channel -1 in this image",
+       "check error message");
+    is(Imager::i_psampf($imraw, 0, -1, undef, [ 0, 0, 0 ]), undef,
+       "negative y");
+    is(_get_error(), $psamp_outside_error, "check error message");
+    is(Imager::i_psampf($imraw, 0, 10, undef, [ 0, 0, 0 ]), undef,
+       "y overflow");
+    is(_get_error(), $psamp_outside_error, "check error message");
+    is(Imager::i_psampf($imraw, -1, 0, undef, [ 0, 0, 0 ]), undef,
+       "negative x");
+    is(_get_error(), $psamp_outside_error, "check error message");
+    is(Imager::i_psampf($imraw, 10, 0, undef, [ 0, 0, 0 ]), undef,
+       "x overflow");
+    is(_get_error(), $psamp_outside_error, "check error message");
+  }
+  print "# end psampf tests\n";
+}
+
+{
+  my $sub_mask = $full_mask->copy;
+  $sub_mask->box(filled => 1, color => NC(0,0,0), xmin => 4, xmax => 6);
+  my $base = Imager::ImgRaw::new(20, 20, 3);
+  my $masked = Imager::i_img_masked_new($base, $sub_mask->{IMG}, 3, 4, 10, 10);
+
+  is(Imager::i_psamp($masked, 0, 2, undef, [ ( 0, 127, 255) x 10 ]), 30,
+     "psamp() to masked image");
+  is_deeply([ Imager::i_gsamp($base, 0, 20, 6, undef) ],
+           [ ( 0, 0, 0 ) x 3, # left of mask
+             ( 0, 127, 255 ) x 4, # masked area
+             ( 0, 0, 0 ) x 3, # unmasked area
+             ( 0, 127, 255 ) x 3, # masked area
+             ( 0, 0, 0 ) x 7 ], # right of mask
+           "check values written");
+  is(Imager::i_psampf($masked, 0, 2, undef, [ ( 0, 0.5, 1.0) x 10 ]), 30,
+     "psampf() to masked image");
+  is_deeply([ Imager::i_gsamp($base, 0, 20, 6, undef) ],
+           [ ( 0, 0, 0 ) x 3, # left of mask
+             ( 0, 128, 255 ) x 4, # masked area
+             ( 0, 0, 0 ) x 3, # unmasked area
+             ( 0, 128, 255 ) x 3, # masked area
+             ( 0, 0, 0 ) x 7 ], # right of mask
+           "check values written");
+}
+
+{
+  my $empty = Imager->new;
+  ok(!$empty->masked, "fail to make a masked image from an empty");
+  is($empty->errstr, "masked: empty input image",
+    "check error message");
+}
+
+Imager->close_log();
+
+unless ($ENV{IMAGER_KEEP_FILES}) {
+  unlink "testout/t020masked.log";
+}
+
+sub _get_error {
+  my @errors = Imager::i_errors();
+  return join(": ", map $_->[0], @errors);
+}
diff --git a/t/200-file/010-iolayer.t b/t/200-file/010-iolayer.t
new file mode 100644 (file)
index 0000000..76388a9
--- /dev/null
@@ -0,0 +1,987 @@
+#!perl -w
+use strict;
+use Test::More tests => 274;
+use Imager::Test qw(is_image);
+# for SEEK_SET etc, Fcntl doesn't provide these in 5.005_03
+use IO::Seekable;
+use Config;
+
+BEGIN { use_ok(Imager => ':all') };
+
+-d "testout" or mkdir "testout";
+
+$| = 1;
+
+Imager->open_log(log => "testout/t07iolayer.log");
+
+undef($/);
+# start by testing io buffer
+
+my $data="P2\n2 2\n255\n 255 0\n0 255\n";
+my $IO = Imager::io_new_buffer($data);
+my $im = Imager::i_readpnm_wiol($IO, -1);
+
+ok($im, "read from data io");
+
+open(FH, ">testout/t07.ppm") or die $!;
+binmode(FH);
+my $fd = fileno(FH);
+my $IO2 = Imager::io_new_fd( $fd );
+Imager::i_writeppm_wiol($im, $IO2);
+close(FH);
+undef($im);
+
+open(FH, "<testimg/penguin-base.ppm");
+binmode(FH);
+$data = <FH>;
+close(FH);
+my $IO3 = Imager::IO->new_buffer($data);
+#undef($data);
+$im = Imager::i_readpnm_wiol($IO3, -1);
+
+ok($im, "read from buffer, for compare");
+undef $IO3;
+
+open(FH, "<testimg/penguin-base.ppm") or die $!;
+binmode(FH);
+$fd = fileno(FH);
+my $IO4 = Imager::IO->new_fd( $fd );
+my $im2 = Imager::i_readpnm_wiol($IO4, -1);
+close(FH);
+undef($IO4);
+
+ok($im2, "read from file, for compare");
+
+is(i_img_diff($im, $im2), 0, "compare images");
+undef($im2);
+
+my $IO5 = Imager::io_new_bufchain();
+Imager::i_writeppm_wiol($im, $IO5);
+my $data2 = Imager::io_slurp($IO5);
+undef($IO5);
+
+ok($data2, "check we got data from bufchain");
+
+my $IO6 = Imager::io_new_buffer($data2);
+my $im3 = Imager::i_readpnm_wiol($IO6, -1);
+
+is(Imager::i_img_diff($im, $im3), 0, "read from buffer");
+
+my $work = $data;
+my $pos = 0;
+sub io_reader {
+  my ($size, $maxread) = @_;
+  my $out = substr($work, $pos, $maxread);
+  $pos += length $out;
+  $out;
+}
+sub io_reader2 {
+  my ($size, $maxread) = @_;
+  my $out = substr($work, $pos, $maxread);
+  $pos += length $out;
+  $out;
+}
+my $IO7 = Imager::IO->new_cb(undef, \&io_reader, undef, undef);
+ok($IO7, "making readcb object");
+my $im4 = Imager::i_readpnm_wiol($IO7, -1);
+ok($im4, "read from cb");
+ok(Imager::i_img_diff($im, $im4) == 0, "read from cb image match");
+
+$pos = 0;
+$IO7 = Imager::io_new_cb(undef, \&io_reader2, undef, undef);
+ok($IO7, "making short readcb object");
+my $im5 = Imager::i_readpnm_wiol($IO7, -1);
+ok($im4, "read from cb2");
+is(Imager::i_img_diff($im, $im5), 0, "read from cb2 image match");
+
+sub io_writer {
+  my ($what) = @_;
+  substr($work, $pos, $pos+length $what) = $what;
+  $pos += length $what;
+
+  1;
+}
+
+my $did_close;
+sub io_close {
+  ++$did_close;
+}
+
+my $IO8 = Imager::io_new_cb(\&io_writer, undef, undef, \&io_close);
+ok($IO8, "making writecb object");
+$pos = 0;
+$work = '';
+ok(Imager::i_writeppm_wiol($im, $IO8), "write to cb");
+# I originally compared this to $data, but that doesn't include the
+# Imager header
+is($work, $data2, "write image match");
+ok($did_close, "did close");
+
+# with a short buffer, no closer
+my $IO9 = Imager::io_new_cb(\&io_writer, undef, undef, undef, 1);
+ok($IO9, "making short writecb object");
+$pos = 0;
+$work = '';
+ok(Imager::i_writeppm_wiol($im, $IO9), "write to short cb");
+is($work, $data2, "short write image match");
+
+{
+  my $buf_data = "Test data";
+  my $io9 = Imager::io_new_buffer($buf_data);
+  is(ref $io9, "Imager::IO", "check class");
+  my $work;
+  is($io9->raw_read($work, 4), 4, "read 4 from buffer object");
+  is($work, "Test", "check data read");
+  is($io9->raw_read($work, 5), 5, "read the rest");
+  is($work, " data", "check data read");
+  is($io9->raw_seek(5, SEEK_SET), 5, "seek");
+  is($io9->raw_read($work, 5), 4, "short read");
+  is($work, "data", "check data read");
+  is($io9->raw_seek(-1, SEEK_CUR), 8, "seek relative");
+  is($io9->raw_seek(-5, SEEK_END), 4, "seek relative to end");
+  is($io9->raw_seek(-10, SEEK_CUR), -1, "seek failure");
+  undef $io9;
+}
+{
+  my $io = Imager::IO->new_bufchain();
+  is(ref $io, "Imager::IO", "check class");
+  is($io->raw_write("testdata"), 8, "check write");
+  is($io->raw_seek(-8, SEEK_CUR), 0, "seek relative");
+  my $work;
+  is($io->raw_read($work, 8), 8, "check read");
+  is($work, "testdata", "check data read");
+  is($io->raw_seek(-3, SEEK_END), 5, "seek end relative");
+  is($io->raw_read($work, 5), 3, "short read");
+  is($work, "ata", "check read data");
+  is($io->raw_seek(4, SEEK_SET), 4, "absolute seek to write some");
+  is($io->raw_write("testdata"), 8, "write");
+  is($io->raw_seek(0, SEEK_CUR), 12, "check size");
+  $io->raw_close();
+  
+  # grab the data
+  my $data = Imager::io_slurp($io);
+  is($data, "testtestdata", "check we have the right data");
+}
+
+{ # callback failure checks
+  my $fail_io = Imager::io_new_cb(\&fail_write, \&fail_read, \&fail_seek, undef, 1);
+  # scalar context
+  my $buffer;
+  my $read_result = $fail_io->raw_read($buffer, 10);
+  is($read_result, undef, "read failure undef in scalar context");
+  my @read_result = $fail_io->raw_read($buffer, 10);
+  is(@read_result, 0, "empty list in list context");
+  $read_result = $fail_io->raw_read2(10);
+  is($read_result, undef, "raw_read2 failure (scalar)");
+  @read_result = $fail_io->raw_read2(10);
+  is(@read_result, 0, "raw_read2 failure (list)");
+
+  my $write_result = $fail_io->raw_write("test");
+  is($write_result, -1, "failed write");
+
+  my $seek_result = $fail_io->raw_seek(-1, SEEK_SET);
+  is($seek_result, -1, "failed seek");
+}
+
+{ # callback success checks
+  my $good_io = Imager::io_new_cb(\&good_write, \&good_read, \&good_seek, undef, 1);
+  # scalar context
+  my $buffer;
+  my $read_result = $good_io->raw_read($buffer, 10);
+  is($read_result, 8, "read success (scalar)");
+  is($buffer, "testdata", "check data");
+  my @read_result = $good_io->raw_read($buffer, 10);
+  is_deeply(\@read_result, [ 8 ], "read success (list)");
+  is($buffer, "testdata", "check data");
+  $read_result = $good_io->raw_read2(10);
+  is($read_result, "testdata", "read2 success (scalar)");
+  @read_result = $good_io->raw_read2(10);
+  is_deeply(\@read_result, [ "testdata" ], "read2 success (list)");
+}
+
+{ # end of file
+  my $eof_io = Imager::io_new_cb(undef, \&eof_read, undef, undef, 1);
+  my $buffer;
+  my $read_result = $eof_io->raw_read($buffer, 10);
+  is($read_result, 0, "read eof (scalar)");
+  is($buffer, '', "check data");
+  my @read_result = $eof_io->raw_read($buffer, 10);
+  is_deeply(\@read_result, [ 0 ], "read eof (list)");
+  is($buffer, '', "check data");
+}
+
+{ # no callbacks
+  my $none_io = Imager::io_new_cb(undef, undef, undef, undef, 0);
+  is($none_io->raw_write("test"), -1, "write with no writecb should fail");
+  my $buffer;
+  is($none_io->raw_read($buffer, 10), undef, "read with no readcb should fail");
+  is($none_io->raw_seek(0, SEEK_SET), -1, "seek with no seekcb should fail");
+}
+
+SKIP:
+{ # make sure we croak when trying to write a string with characters over 0xff
+  # the write callback shouldn't get called
+  skip("no native UTF8 support in this version of perl", 2)
+    unless $] >= 5.006;
+  my $io = Imager::io_new_cb(\&good_write, undef, undef, 1);
+  my $data = chr(0x100);
+  is(ord $data, 0x100, "make sure we got what we expected");
+  my $result = 
+    eval {
+      $io->raw_write($data);
+      1;
+    };
+  ok(!$result, "should have croaked")
+    and print "# $@\n";
+}
+
+{ # 0.52 left some debug code in a path that wasn't tested, make sure
+  # that path is tested
+  # http://rt.cpan.org/Ticket/Display.html?id=20705
+  my $io = Imager::io_new_cb
+    (
+     sub { 
+       print "# write $_[0]\n";
+       1 
+     }, 
+     sub { 
+       print "# read $_[0], $_[1]\n";
+       "x" x $_[1]
+     }, 
+     sub { print "# seek\n"; 0 }, 
+     sub { print "# close\n"; 1 });
+  my $buffer;
+  is($io->raw_read($buffer, 10), 10, "read 10");
+  is($buffer, "xxxxxxxxxx", "read value");
+  ok($io->raw_write("foo"), "write");
+  is($io->raw_close, 0, "close");
+}
+
+SKIP:
+{ # fd_seek write failure
+  -c "/dev/full"
+    or skip("No /dev/full", 3);
+  open my $fh, "> /dev/full"
+    or skip("Can't open /dev/full: $!", 3);
+  my $io = Imager::io_new_fd(fileno($fh));
+  ok($io, "make fd io for /dev/full");
+  Imager::i_clear_error();
+  is($io->raw_write("test"), -1, "fail to write");
+  my $msg = Imager->_error_as_msg;
+  like($msg, qr/^write\(\) failure: /, "check error message");
+  print "# $msg\n";
+
+  # /dev/full succeeds on seek on Linux
+
+  undef $io;
+}
+
+SKIP:
+{ # fd_seek seek failure
+  my $seekfail = "testout/t07seekfail.dat";
+  open my $fh, "> $seekfail"
+    or skip("Can't open $seekfail: $!", 3);
+  my $io = Imager::io_new_fd(fileno($fh));
+  ok($io, "make fd io for $seekfail");
+
+  Imager::i_clear_error();
+  is($io->raw_seek(-1, SEEK_SET), -1, "shouldn't be able to seek to -1");
+  my $msg = Imager->_error_as_msg;
+  like($msg, qr/^lseek\(\) failure: /, "check error message");
+  print "# $msg\n";
+
+  undef $io;
+  close $fh;
+  unlink $seekfail;
+}
+
+SKIP:
+{ # fd_seek read failure
+  open my $fh, "> testout/t07writeonly.txt"
+    or skip("Can't open testout/t07writeonly.txt: $!", 3);
+  my $io = Imager::io_new_fd(fileno($fh));
+  ok($io, "make fd io for write-only");
+
+  Imager::i_clear_error();
+  my $buf;
+  is($io->raw_read($buf, 10), undef,
+     "file open for write shouldn't be readable");
+  my $msg = Imager->_error_as_msg;
+  like($msg, qr/^read\(\) failure: /, "check error message");
+  print "# $msg\n";
+
+  undef $io;
+}
+
+SKIP:
+{ # fd_seek eof
+  open my $fh, "> testout/t07readeof.txt"
+    or skip("Can't open testout/t07readeof.txt: $!", 5);
+  binmode $fh;
+  print $fh "test";
+  close $fh;
+  open my $fhr, "< testout/t07readeof.txt",
+    or skip("Can't open testout/t07readeof.txt: $!", 5);
+  my $io = Imager::io_new_fd(fileno($fhr));
+  ok($io, "make fd io for read eof");
+
+  Imager::i_clear_error();
+  my $buf;
+  is($io->raw_read($buf, 10), 4,
+     "10 byte read on 4 byte file should return 4");
+  my $msg = Imager->_error_as_msg;
+  is($msg, "", "should be no error message")
+    or print STDERR "# read(4) message is: $msg\n";
+
+  Imager::i_clear_error();
+  $buf = '';
+  is($io->raw_read($buf, 10), 0,
+     "10 byte read at end of 4 byte file should return 0 (eof)");
+
+  $msg = Imager->_error_as_msg;
+  is($msg, "", "should be no error message")
+    or print STDERR "# read(4), eof message is: $msg\n";
+
+  undef $io;
+}
+
+{ # buffered I/O
+  my $data="P2\n2 2\n255\n 255 0\n0 255\n";
+  my $io = Imager::io_new_buffer($data);
+
+  my $c = $io->getc();
+
+  is($c, ord "P", "getc");
+  my $peekc = $io->peekc();
+
+  is($peekc, ord "2", "peekc");
+
+  my $peekn = $io->peekn(2);
+  is($peekn, "2\n", "peekn");
+
+  $c = $io->getc();
+  is($c, ord "2", "getc after peekc/peekn");
+
+  is($io->seek(0, SEEK_SET), "0", "seek");
+  is($io->getc, ord "P", "check we got back to the start");
+}
+
+{ # test closecb result is propagated
+  my $success_cb = sub { 1 };
+  my $failure_cb = sub { 0 };
+
+  {
+    my $io = Imager::io_new_cb(undef, $success_cb, undef, $success_cb);
+    is($io->close(), 0, "test successful close");
+  }
+  {
+    my $io = Imager::io_new_cb(undef, $success_cb, undef, $failure_cb);
+    is($io->close(), -1, "test failed close");
+  }
+}
+
+{ # buffered coverage/function tests
+  # some data to play with
+  my $base = pack "C*", map rand(26) + ord("a"), 0 .. 20_001;
+
+  { # buffered accessors
+    my $io = Imager::io_new_buffer($base);
+    ok($io->set_buffered(0), "set unbuffered");
+    ok(!$io->is_buffered, "verify unbuffered");
+    ok($io->set_buffered(1), "set buffered");
+    ok($io->is_buffered, "verify buffered");
+  }
+
+  { # initial i_io_read(), buffered
+    my $pos = 0;
+    my $ops = "";
+    my $work = $base;
+    my $read = sub {
+      my ($size) = @_;
+
+      my $req_size = $size;
+
+      if ($pos + $size > length $work) {
+       $size = length($work) - $pos;
+      }
+
+      my $result = substr($work, $pos, $size);
+      $pos += $size;
+      $ops .= "R$req_size>$size;";
+
+      print "# read $req_size>$size\n";
+
+      return $result;
+    };
+    my $write = sub {
+      my ($data) = @_;
+
+      substr($work, $pos, length($data), $data);
+
+      return 1;
+    };
+    {
+      my $io = Imager::io_new_cb(undef, $read, undef, undef);
+      my $buf;
+      is($io->read($buf, 1000), 1000, "read initial 1000");
+      is($buf, substr($base, 0, 1000), "check data read");
+      is($ops, "R8192>8192;", "check read op happened to buffer size");
+
+      undef $buf;
+      is($io->read($buf, 1001), 1001, "read another 1001");
+      is($buf, substr($base, 1000, 1001), "check data read");
+      is($ops, "R8192>8192;", "should be no further reads");
+
+      undef $buf;
+      is($io->read($buf, 40_000), length($base) - 2001,
+        "read the rest in one chunk");
+      is($buf, substr($base, 2001), "check the data read");
+      my $buffer_left = 8192 - 2001;
+      my $after_buffer = length($base) - 8192;
+      is($ops, "R8192>8192;R".(40_000 - $buffer_left).">$after_buffer;R21999>0;",
+        "check we tried to read the remainder");
+    }
+    {
+      # read after write errors
+      my $io = Imager::io_new_cb($write, $read, undef, undef);
+      is($io->write("test"), 4, "write 4 bytes, io in write mode");
+      is($io->read2(10), undef, "read should fail");
+      is($io->peekn(10), undef, "peekn should fail");
+      is($io->getc(), -1, "getc should fail");
+      is($io->peekc(), -1, "peekc should fail");
+    }
+  }
+
+  {
+    my $io = Imager::io_new_buffer($base);
+    print "# buffer fill check\n";
+    ok($io, "make memory io");
+    my $buf;
+    is($io->read($buf, 4096), 4096, "read 4k");
+    is($buf, substr($base, 0, 4096), "check data is correct");
+
+    # peek a bit
+    undef $buf;
+    is($io->peekn(5120), substr($base, 4096, 5120),
+       "peekn() 5120, which should exceed the buffer, and only read the left overs");
+  }
+
+  { # initial peekn
+    my $io = Imager::io_new_buffer($base);
+    is($io->peekn(10), substr($base, 0, 10),
+       "make sure initial peekn() is sane");
+    is($io->read2(10), substr($base, 0, 10),
+       "and that reading 10 gets the expected data");
+  }
+
+  { # oversize peekn
+    my $io = Imager::io_new_buffer($base);
+    is($io->peekn(10_000), substr($base, 0, 8192),
+       "peekn() larger than buffer should return buffer-size bytes");
+  }
+
+  { # small peekn then large peekn with a small I/O back end
+    # this might happen when reading from a socket
+    my $work = $base;
+    my $pos = 0;
+    my $ops = '';
+    my $reader = sub {
+      my ($size) = @_;
+
+      my $req_size = $size;
+      # do small reads, to trigger a possible bug
+      if ($size > 10) {
+       $size = 10;
+      }
+
+      if ($pos + $size > length $work) {
+       $size = length($work) - $pos;
+      }
+
+      my $result = substr($work, $pos, $size);
+      $pos += $size;
+      $ops .= "R$req_size>$size;";
+
+      print "# read $req_size>$size\n";
+
+      return $result;
+    };
+    my $io = Imager::io_new_cb(undef, $reader, undef, undef);
+    ok($io, "small reader io");
+    is($io->peekn(25), substr($base, 0, 25), "peek 25");
+    is($ops, "R8192>10;R8182>10;R8172>10;",
+       "check we got the raw calls expected");
+    is($io->peekn(65), substr($base, 0, 65), "peek 65");
+    is($ops, "R8192>10;R8182>10;R8172>10;R8162>10;R8152>10;R8142>10;R8132>10;",
+       "check we got the raw calls expected");
+  }
+  for my $buffered (1, 0) { # peekn followed by errors
+    my $buffered_desc = $buffered ? "buffered" : "unbuffered";
+    my $read = 0;
+    my $base = "abcdef";
+    my $pos = 0;
+    my $reader = sub {
+      my $size = shift;
+      my $req_size = $size;
+      if ($pos + $size > length $base) {
+       $size = length($base) - $pos;
+      }
+      # error instead of eof
+      if ($size == 0) {
+       print "# read $req_size>error\n";
+       return;
+      }
+      my $result = substr($base, $pos, $size);
+      $pos += $size;
+
+      print "# read $req_size>$size\n";
+
+      return $result;
+    };
+    my $io = Imager::io_new_cb(undef, $reader, undef, undef);
+    ok($io, "make $buffered_desc cb with error after 6 bytes");
+    is($io->peekn(5), "abcde",
+       "peekn until just before error ($buffered_desc)");
+    is($io->peekn(6), "abcdef", "peekn until error ($buffered_desc)");
+    is($io->peekn(7), "abcdef", "peekn past error ($buffered_desc)");
+    ok(!$io->error,
+       "should be no error indicator, since data buffered ($buffered_desc)");
+    ok(!$io->eof,
+       "should be no eof indicator, since data buffered ($buffered_desc)");
+
+    # consume it
+    is($io->read2(6), "abcdef", "consume the buffer ($buffered_desc)");
+    is($io->peekn(10), undef,
+       "peekn should get an error indicator ($buffered_desc)");
+    ok($io->error, "should be an error state ($buffered_desc)");
+    ok(!$io->eof, "but not eof ($buffered_desc)");
+  }
+  { # peekn on an empty file
+    my $io = Imager::io_new_buffer("");
+    is($io->peekn(10), "", "peekn on empty source");
+    ok($io->eof, "should be in eof state");
+    ok(!$io->error, "but not error");
+  }
+  { # peekn on error source
+    my $io = Imager::io_new_cb(undef, sub { return; }, undef, undef);
+    is($io->peekn(10), undef, "peekn on empty source");
+    ok($io->error, "should be in error state");
+    ok(!$io->eof, "but not eof");
+  }
+  { # peekn on short source
+    my $io = Imager::io_new_buffer("abcdef");
+    is($io->peekn(4), "abcd", "peekn 4 on 6 byte source");
+    is($io->peekn(10), "abcdef", "followed by peekn 10 on 6 byte source");
+    is($io->peekn(10), "abcdef", "and again, now eof is set");
+  }
+  { # peekn(0)
+    Imager::i_clear_error();
+    my $io = Imager::io_new_buffer("abcdef");
+    is($io->peekn(0), undef, "peekn 0 on 6 byte source");
+    my $msg = Imager->_error_as_msg;
+    is($msg, "peekn size must be positive");
+  }
+  { # getc through a whole file (buffered)
+    my $io = Imager::io_new_buffer($base);
+    my $out = '';
+    while ((my $c = $io->getc()) != -1) {
+      $out .= chr($c);
+    }
+    is($out, $base, "getc should return the file byte by byte (buffered)");
+    is($io->getc, -1, "another getc after eof should fail too");
+    ok($io->eof, "should be marked eof");
+    ok(!$io->error, "shouldn't be marked in error");
+  }
+  { # getc through a whole file (unbuffered)
+    my $io = Imager::io_new_buffer($base);
+    $io->set_buffered(0);
+    my $out = '';
+    while ((my $c = $io->getc()) != -1) {
+      $out .= chr($c);
+    }
+    is($out, $base, "getc should return the file byte by byte (unbuffered)");
+    is($io->getc, -1, "another getc after eof should fail too");
+    ok($io->eof, "should be marked eof");
+    ok(!$io->error, "shouldn't be marked in error");
+  }
+  { # buffered getc with an error
+    my $io = Imager::io_new_cb(undef, sub { return; }, undef, undef);
+    is($io->getc, -1, "buffered getc error");
+    ok($io->error, "io marked in error");
+    ok(!$io->eof, "but not eof");
+  }
+  { # unbuffered getc with an error
+    my $io = Imager::io_new_cb(undef, sub { return; }, undef, undef);
+    $io->set_buffered(0);
+    is($io->getc, -1, "unbuffered getc error");
+    ok($io->error, "io marked in error");
+    ok(!$io->eof, "but not eof");
+  }
+  { # initial peekc - buffered
+    my $io = Imager::io_new_buffer($base);
+    my $c = $io->peekc;
+    is($c, ord($base), "buffered peekc matches");
+    is($io->peekc, $c, "duplicate peekc matchess");
+  }
+  { # initial peekc - unbuffered
+    my $io = Imager::io_new_buffer($base);
+    $io->set_buffered(0);
+    my $c = $io->peekc;
+    is($c, ord($base), "unbuffered peekc matches");
+    is($io->peekc, $c, "duplicate peekc matchess");
+  }
+  { # initial peekc eof - buffered
+    my $io = Imager::io_new_cb(undef, sub { "" }, undef, undef);
+    my $c = $io->peekc;
+    is($c, -1, "buffered eof peekc is -1");
+    is($io->peekc, $c, "duplicate matches");
+    ok($io->eof, "io marked eof");
+    ok(!$io->error, "but not error");
+  }
+  { # initial peekc eof - unbuffered
+    my $io = Imager::io_new_cb(undef, sub { "" }, undef, undef);
+    $io->set_buffered(0);
+    my $c = $io->peekc;
+    is($c, -1, "buffered eof peekc is -1");
+    is($io->peekc, $c, "duplicate matches");
+    ok($io->eof, "io marked eof");
+    ok(!$io->error, "but not error");
+  }
+  { # initial peekc error - buffered
+    my $io = Imager::io_new_cb(undef, sub { return; }, undef, undef);
+    my $c = $io->peekc;
+    is($c, -1, "buffered error peekc is -1");
+    is($io->peekc, $c, "duplicate matches");
+    ok($io->error, "io marked error");
+    ok(!$io->eof, "but not eof");
+  }
+  { # initial peekc error - unbuffered
+    my $io = Imager::io_new_cb(undef, sub { return; }, undef, undef);
+    $io->set_buffered(0);
+    my $c = $io->peekc;
+    is($c, -1, "unbuffered error peekc is -1");
+    is($io->peekc, $c, "duplicate matches");
+    ok($io->error, "io marked error");
+    ok(!$io->eof, "but not eof");
+  }
+  { # initial putc
+    my $io = Imager::io_new_bufchain();
+    is($io->putc(ord "A"), ord "A", "initial putc buffered");
+    is($io->close, 0, "close it");
+    is(Imager::io_slurp($io), "A", "check it was written");
+  }
+  { # initial putc - unbuffered
+    my $io = Imager::io_new_bufchain();
+    $io->set_buffered(0);
+    is($io->putc(ord "A"), ord "A", "initial putc unbuffered");
+    is($io->close, 0, "close it");
+    is(Imager::io_slurp($io), "A", "check it was written");
+  }
+  { # putc unbuffered with error
+    my $io = Imager::io_new_cb(undef, undef, undef, undef);
+    $io->set_buffered(0);
+    is($io->putc(ord "A"), -1, "initial putc unbuffered error");
+    ok($io->error, "io in error");
+    is($io->putc(ord "B"), -1, "still in error");
+  }
+  { # writes while in read state
+    my $io = Imager::io_new_cb(sub { 1 }, sub { return "AA" }, undef, undef);
+    is($io->getc, ord "A", "read to setup read buffer");
+    is($io->putc(ord "B"), -1, "putc should fail");
+    is($io->write("test"), -1, "write should fail");
+  }
+  { # buffered putc error handling
+    # tests the check for error state in the buffered putc code
+    my $io = Imager::io_new_cb(undef, undef, undef, undef);
+    $io->putc(ord "A");
+    ok(!$io->flush, "flush should fail");
+    ok($io->error, "should be in error state");
+    is($io->putc(ord "B"), -1, "check for error");
+  }
+  { # buffered putc flush error handling
+    # test handling of flush failure and of the error state resulting
+    # from that
+    my $io = Imager::io_new_cb(undef, undef, undef, undef);
+    my $i = 0;
+    while (++$i < 100_000 && $io->putc(ord "A") == ord "A") {
+      # until we have to flush and fail doing do
+    }
+    is($i, 8193, "should have failed on 8193rd byte");
+    ok($io->error, "should be in error state");
+    is($io->putc(ord "B"), -1, "next putc should fail");
+  }
+  { # buffered write flush error handling
+    # test handling of flush failure and of the error state resulting
+    # from that
+    my $io = Imager::io_new_cb(undef, undef, undef, undef);
+    my $i = 0;
+    while (++$i < 100_000 && $io->write("A") == 1) {
+      # until we have to flush and fail doing do
+    }
+    is($i, 8193, "should have failed on 8193rd byte");
+    ok($io->error, "should be in error state");
+    is($io->write("B"), -1, "next write should fail");
+  }
+  { # buffered read error
+    my $io = Imager::io_new_cb(undef, undef, undef, undef);
+    is($io->read2(10), undef, "initial read returning error");
+    ok($io->error, "should be in error state");
+  }
+  { # unbuffered read error
+    my $io = Imager::io_new_cb(undef, undef, undef, undef);
+    $io->set_buffered(0);
+    is($io->read2(10), undef, "initial read returning error");
+    ok($io->error, "should be in error state");
+  }
+  { # unbuffered write error
+    my $count = 0;
+    my $io = Imager::io_new_cb(sub { return $count++; }, undef, undef, undef);
+    $io->set_buffered(0);
+    is($io->write("A"), -1, "unbuffered write failure");
+    ok($io->error, "should be in error state");
+    is($io->write("BC"), -1, "should still fail");
+  }
+  { # buffered write + large write
+    my $io = Imager::io_new_bufchain();
+    is($io->write(substr($base, 0, 4096)), 4096,
+       "should be buffered");
+    is($io->write(substr($base, 4096)), length($base) - 4096,
+       "large write, should fill buffer and fall back to direct write");
+    is($io->close, 0, "close it");
+    is(Imager::io_slurp($io), $base, "make sure the data is correct");
+  }
+  { # initial large write with failure
+    # tests error handling for the case where we bypass the buffer
+    # when the write is too large to fit
+    my $io = Imager::io_new_cb(undef, undef, undef, undef);
+    ok($io->flush, "flush with nothing buffered should succeed");
+    is($io->write($base), -1, "large write failure");
+    ok($io->error, "should be in error state");
+    is($io->close, -1, "should fail to close");
+  }
+  { # write that causes a flush then fills the buffer a bit
+    my $io = Imager::io_new_bufchain();
+    is($io->write(substr($base, 0, 6000)), 6000, "fill the buffer a bit");
+    is($io->write(substr($base, 6000, 4000)), 4000,
+       "cause it to flush and then fill some more");
+    is($io->write(substr($base, 10000)), length($base)-10000,
+       "write out the rest of our test data");
+    is($io->close, 0, "close the stream");
+    is(Imager::io_slurp($io), $base, "make sure the data is right");
+  }
+  { # failure on flush on close
+    my $io = Imager::io_new_cb(undef, undef, undef, undef);
+    is($io->putc(ord "A"), ord "A", "something in the buffer");
+    ok(!$io->error, "should be no error yet");
+    is($io->close, -1, "close should failure due to flush error");
+  }
+  { # seek failure
+    my $io = Imager::io_new_cb(undef, undef, undef, undef);
+    is($io->seek(0, SEEK_SET), -1, "seek failure");
+  }
+  { # read a little and seek
+    my $io = Imager::io_new_buffer($base);
+    is($io->getc, ord $base, "read one");
+    is($io->getc, ord substr($base, 1, 1), "read another");
+    is($io->seek(-1, SEEK_CUR), 1, "seek relative back to origin+1");
+    is($io->getc, ord substr($base, 1, 1), "read another again");
+  }
+  { # seek with failing flush
+    my $io = Imager::io_new_cb(undef, undef, undef, undef);
+    is($io->putc(ord "A"), ord "A", "write one");
+    ok(!$io->error, "not in error mode (yet)");
+    is($io->seek(0, SEEK_SET), -1, "seek failure due to flush");
+    ok($io->error, "in error mode");
+  }
+  { # gets()
+    my $data = "test1\ntest2\ntest3";
+    my $io = Imager::io_new_buffer($data);
+    is($io->gets(6), "test1\n", "gets(6)");
+    is($io->gets(5), "test2", "gets(5) (short for the line)");
+    is($io->gets(10), "\n", "gets(10) the rest of the line (the newline)");
+    is($io->gets(), "test3", "gets(default) unterminated line");
+  }
+  { # more gets()
+    my $data = "test1\ntest2\ntest3";
+    my $io = Imager::io_new_buffer($data);
+    is($io->gets(6, ord("1")), "test1", "gets(6) (line terminator 1)");
+    is($io->gets(6, ord("2")), "\ntest2", "gets(6) (line terminator 2)");
+    is($io->gets(6, ord("3")), "\ntest3", "gets(6) (line terminator 3)");
+    is($io->getc, -1, "should be eof");
+  }
+}
+
+{ # based on discussion on IRC, user was attempting to write a TIFF
+  # image file with only a write callback, but TIFF requires seek and
+  # read callbacks when writing.
+  # https://rt.cpan.org/Ticket/Display.html?id=76782
+  my $cb = Imager::io_new_cb(undef, undef, undef, undef);
+  {
+    Imager::i_clear_error();
+    my $data;
+    is($cb->read($data, 10), undef, "default read callback should fail");
+    is(Imager->_error_as_msg(), "read callback called but no readcb supplied",
+       "check error message");
+  }
+  {
+    Imager::i_clear_error();
+    is($cb->raw_write("abc"), -1, "default write callback should fail");
+    is(Imager->_error_as_msg(), "write callback called but no writecb supplied",
+       "check error message");
+  }
+  {
+    Imager::i_clear_error();
+    is($cb->seek(0, 0), -1, "default seek callback should fail");
+    is(Imager->_error_as_msg(), "seek callback called but no seekcb supplied",
+       "check error message");
+  }
+}
+
+SKIP:
+{
+  $Config{useperlio}
+    or skip "PerlIO::scalar requires perlio", 13;
+
+  my $foo;
+  open my $fh, "+<", \$foo;
+  my $io = Imager::IO->_new_perlio($fh);
+  ok($io, "perlio: make a I/O object for a perl scalar fh");
+  is($io->write("test"), 4, "perlio: check we can write");
+  is($io->seek(2, SEEK_SET), 2, "perlio: check we can seek");
+  is($io->write("more"), 4, "perlio: write some more");
+  is($io->seek(0, SEEK_SET), 0, "perlio: seek back to start");
+  my $data;
+  is($io->read($data, 10), 6, "perlio: read everything back");
+  is($data, "temore", "perlio: check we read back what we wrote");
+  is($io->close, 0, "perlio: close it");
+  is($foo, "temore", "perlio: check it got to the scalar properly");
+
+  my $io2 = Imager::IO->new_fh($fh);
+  ok($io2, "new_fh() can make an I/O layer object from a scalar fh");
+  close $fh;
+
+  my $im = Imager->new(xsize => 10, ysize => 10);
+  $foo = "";
+  open my $fh2, ">", \$foo;
+  ok($im->write(fh => $fh2, type => "pnm"), "can write image to scalar fh")
+    or print "# ", $im->errstr, "\n";
+
+  close $fh2;
+  open my $fh3, "<", \$foo;
+  my $im2 = Imager->new(fh => $fh3);
+  ok($im2, "read image from a scalar fh");
+  is_image($im, $im2, "check they match");
+}
+
+{
+  tie *FOO, "IO::Tied";
+  my $io = Imager::IO->new_fh(\*FOO);
+  ok($io, "tied: make a I/O object for a tied fh");
+  is($io->write("test"), 4, "tied: check we can write");
+  is($io->seek(2, SEEK_SET), 2, "tied: check we can seek");
+  is($io->write("more"), 4, "tied: write some more");
+  is($io->seek(0, SEEK_SET), 0, "tied: seek back to start");
+  my $data;
+  is($io->read($data, 10), 6, "tied: read everything back");
+  is($data, "temore", "tied: check we read back what we wrote");
+  is($io->close, 0, "tied: close it");
+  is(tied(*FOO)->[0], "temore", "tied: check it got to the output properly");
+}
+
+Imager->close_log;
+
+unless ($ENV{IMAGER_KEEP_FILES}) {
+  unlink "testout/t07.ppm", "testout/t07iolayer.log";
+}
+
+sub eof_read {
+  my ($max_len) = @_;
+
+  return '';
+}
+
+sub good_read {
+  my ($max_len) = @_;
+
+  my $data = "testdata";
+  length $data <= $max_len or substr($data, $max_len) = '';
+
+  print "# good_read ($max_len) => $data\n";
+
+  return $data;
+}
+
+sub fail_write {
+  return;
+}
+
+sub fail_read {
+  return;
+}
+
+sub fail_seek {
+  return -1;
+}
+
+package IO::Tied;
+use base 'Tie::Handle';
+use IO::Seekable;
+
+sub TIEHANDLE {
+  return bless [ "", 0 ];
+}
+
+sub PRINT {
+  for my $entry (@_[1 .. $#_]) {
+    substr($_[0][0], $_[0][1], length $entry, $entry);
+    $_[0][1] += length $entry;
+  }
+
+  return 1;
+}
+
+sub SEEK {
+  my ($self, $offset, $whence) = @_;
+
+  my $newpos;
+  if ($whence == SEEK_SET) {
+    $newpos = $offset;
+  }
+  elsif ($whence == SEEK_CUR) {
+    $newpos = $self->[1] + $offset;
+  }
+  elsif ($whence == SEEK_END) {
+    $newpos = length($self->[0]) + $newpos;
+  }
+  else {
+    return -1;
+  }
+
+  if ($newpos < 0) {
+    return 0;
+  }
+
+  $self->[1] = $newpos;
+
+  return 1;
+}
+
+sub TELL {
+  return $_[0][1];
+}
+
+sub READ {
+  my $self = shift;
+  my $outlen = $_[1];
+  my $offset = @_ > 2 ? $_[2] : 0;
+  if ($self->[1] + $outlen > length $self->[0]) {
+    $outlen = length($self->[0]) - $self->[1];
+    $outlen <= 0
+      and return "";
+  }
+  defined $_[0] or $_[0] = "";
+  substr($_[0], $offset, $outlen) = substr($self->[0], $self->[1], $outlen);
+  $self->[1] += $outlen;
+
+  return $outlen;
+}
diff --git a/t/200-file/100-files.t b/t/200-file/100-files.t
new file mode 100644 (file)
index 0000000..f937019
--- /dev/null
@@ -0,0 +1,354 @@
+#!perl -w
+
+# This file is for testing file functionality that is independent of
+# the file format
+
+use strict;
+use Test::More tests => 89;
+use Imager;
+
+-d "testout" or mkdir "testout";
+
+Imager->open_log(log => "testout/t1000files.log");
+
+SKIP:
+{
+  # Test that i_test_format_probe() doesn't pollute stdout
+
+  # Initally I tried to write this test using open to redirect files,
+  # but there was a buffering problem that made it so the data wasn't
+  # being written to the output file.  This external perl call avoids
+  # that problem
+
+  my $test_script = 'testout/t1000files_probe.pl';
+
+  # build a temp test script to use
+  ok(open(SCRIPT, "> $test_script"), "open test script")
+    or skip("no test script $test_script: $!", 2);
+  print SCRIPT <<'PERL';
+#!perl
+use Imager;
+use strict;
+my $file = shift or die "No file supplied";
+open FH, "< $file" or die "Cannot open file: $!";
+binmode FH;
+my $io = Imager::io_new_fd(fileno(FH));
+Imager::i_test_format_probe($io, -1);
+PERL
+  close SCRIPT;
+  my $perl = $^X;
+  $perl = qq/"$perl"/ if $perl =~ / /;
+  
+  print "# script: $test_script\n";
+  my $cmd = "$perl -Mblib $test_script t/200-file/100-files.t";
+  print "# command: $cmd\n";
+
+  my $out = `$cmd`;
+  is($?, 0, "command successful");
+  is($out, '', "output should be empty");
+}
+
+# test the file limit functions
+# by default the limits are zero (unlimited)
+print "# image file limits\n";
+is_deeply([ Imager->get_file_limits() ], [0, 0, 0x40000000 ],
+         "check defaults");
+ok(Imager->set_file_limits(width=>100), "set only width");
+is_deeply([ Imager->get_file_limits() ], [100, 0, 0x40000000 ],
+         "check width set");
+ok(Imager->set_file_limits(height=>150, bytes=>10000),
+   "set height and bytes");
+is_deeply([ Imager->get_file_limits() ], [ 100, 150, 10000 ],
+         "check all values now set");
+ok(Imager->check_file_limits(width => 100, height => 30),
+   "check 100 x 30 (def channels, sample_size) ok")
+  or diag(Imager->errstr);
+ok(Imager->check_file_limits(width => 100, height => 100, channels => 1),
+   "check 100 x 100 x 1 (def sample_size) ok")
+  or diag(Imager->errstr);
+ok(Imager->check_file_limits(width => 100, height => 100, channels => 1),
+   "check 100 x 100 x 1 (def sample_size) ok")
+  or diag(Imager->errstr);
+ok(!Imager->check_file_limits(width => 100, height => 100, channels => 1, sample_size => "float"),
+   "check 100 x 100 x 1 x float should fail");
+ok(!Imager->check_file_limits(width => 100, height => 100, channels => 0),
+   "0 channels should fail");
+is(Imager->errstr, "file size limit - channels 0 out of range",
+   "check error message");
+ok(!Imager->check_file_limits(width => 0, height => 100),
+   "0 width should fail");
+is(Imager->errstr, "file size limit - image width of 0 is not positive",
+   "check error message");
+ok(!Imager->check_file_limits(width => 100, height => 0),
+   "0 height should fail");
+is(Imager->errstr, "file size limit - image height of 0 is not positive",
+   "check error message");
+ok(!Imager->check_file_limits(width => 10, height => 10, sample_size => 0),
+   "0 sample_size should fail");
+is(Imager->errstr, "file size limit - sample_size 0 out of range",
+   "check error message");
+ok(!Imager->check_file_limits(width => 10, height => 10, sample_size => 1000),
+   "1000 sample_size should fail");
+is(Imager->errstr, "file size limit - sample_size 1000 out of range",
+   "check error message");
+ok(Imager->set_file_limits(reset=>1, height => 99),
+   "set height and reset");
+is_deeply([ Imager->get_file_limits() ], [ 0, 99, 0x40000000 ],
+         "check only height is set");
+ok(Imager->set_file_limits(reset=>1),
+   "just reset");
+is_deeply([ Imager->get_file_limits() ], [ 0, 0, 0x40000000 ],
+         "check all are reset");
+
+# bad parameters
+is_deeply([ Imager->check_file_limits() ], [],
+         "missing size paramaters");
+is(Imager->errstr, "check_file_limits: width must be defined",
+   "check message");
+is_deeply([ Imager->check_file_limits(width => 100.5) ], [],
+         "non-integer parameter");
+is(Imager->errstr, "check_file_limits: width must be a positive integer",
+   "check message");
+
+# test error handling for loading file handers
+{
+  # first, no module at all
+  {
+    my $data = "abc";
+    ok(!Imager->new(data => $data, filetype => "unknown"),
+       "try to read an unknown file type");
+   like(Imager->errstr, qr(^format 'unknown' not supported - formats .* - Can't locate Imager/File/UNKNOWN.pm or Imager/File/UNKNOWNReader.pm$),
+       "check error message");
+  }
+  {
+    my $data;
+    my $im = Imager->new(xsize => 10, ysize => 10);
+    ok(!$im->write(data => \$data, type => "unknown"),
+       "try to write an unknown file type");
+   like($im->errstr, qr(^format 'unknown' not supported - formats .* - Can't locate Imager/File/UNKNOWN.pm or Imager/File/UNKNOWNWriter.pm$),
+       "check error message");
+  }
+  push @INC, "t/t1000lib";
+  {
+    my $data = "abc";
+    ok(!Imager->new(data => $data, filetype => "bad"),
+       "try to read an bad (other load failure) file type");
+   like(Imager->errstr, qr(^format 'bad' not supported - formats .* available for reading - This module fails to load loading Imager/File/BAD.pm$),
+       "check error message");
+  }
+  {
+    my $data;
+    my $im = Imager->new(xsize => 10, ysize => 10);
+    ok(!$im->write(data => \$data, type => "bad"),
+       "try to write an bad file type");
+   like($im->errstr, qr(^format 'bad' not supported - formats .* available for writing - This module fails to load loading Imager/File/BAD.pm$),
+       "check error message");
+  }
+}
+
+{ # test empty image handling for write()/write_multi()
+  my $empty = Imager->new;
+  my $data;
+  ok(!$empty->write(data => \$data, type => "pnm"),
+     "fail to write an empty image");
+  is($empty->errstr, "write: empty input image", "check error message");
+  my $good = Imager->new(xsize => 1, ysize => 1);
+  ok(!Imager->write_multi({ data => \$data, type => "pnm" }, $good, $empty),
+     "fail to write_multi an empty image");
+  is(Imager->errstr, "write_multi: empty input image (image 2)");
+}
+
+# check file type probe
+probe_ok("49492A41", undef, "not quite tiff");
+probe_ok("4D4D0041", undef, "not quite tiff");
+probe_ok("49492A00", "tiff", "tiff intel");
+probe_ok("4D4D002A", "tiff", "tiff motorola");
+probe_ok("474946383961", "gif", "gif 89");
+probe_ok("474946383761", "gif", "gif 87");
+probe_ok(<<TGA, "tga", "TGA");
+00 00 0A 00 00 00 00 00 00 00 00 00 96 00 96 00
+18 20 FF 00 00 00 95 00 00 00 FF 00 00 00 95 00
+00 00 FF 00 00 00 95 00 00 00 FF 00 00 00 95 00
+00 00 FF 00 00 00 95 00 00 00 FF 00 00 00 95 00
+TGA
+
+probe_ok(<<TGA, "tga", "TGA 32-bit");
+00 00 0A 00 00 00 00 00 00 00 00 00 0A 00 0A 00
+20 08 84 00 00 00 00 84 FF FF FF FF 84 00 00 00
+00 84 FF FF FF FF 84 00 00 00 00 84 FF FF FF FF
+TGA
+
+probe_ok(<<ICO, "ico", "Windows Icon");
+00 00 01 00 02 00 20 20 10 00 00 00 00 00 E8 02
+00 00 26 00 00 00 20 20 00 00 00 00 00 00 A8 08
+00 00 0E 03 00 00 28 00 00 00 20 00 00 00 40 00
+ICO
+
+probe_ok(<<ICO, "cur", "Windows Cursor");
+00 00 02 00 02 00 20 20 10 00 00 00 00 00 E8 02
+00 00 26 00 00 00 20 20 00 00 00 00 00 00 A8 08
+00 00 0E 03 00 00 28 00 00 00 20 00 00 00 40 00
+ICO
+
+probe_ok(<<SGI, "sgi", "SGI RGB");
+01 DA 01 01 00 03 00 96 00 96 00 03 00 00 00 00 
+00 00 00 FF 00 00 00 00 6E 6F 20 6E 61 6D 65 00
+00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
+SGI
+
+probe_ok(<<ILBM, "ilbm", "ILBM");
+46 4F 52 4D 00 00 60 7A 49 4C 42 4D 42 4D 48 44
+00 00 00 14 00 96 00 96 00 00 00 00 18 00 01 80
+00 00 0A 0A 00 96 00 96 42 4F 44 59 00 00 60 51
+ILBM
+
+probe_ok(<<XPM, "xpm", "XPM");
+2F 2A 20 58 50 4D 20 2A 2F 0A 73 74 61 74 69 63
+20 63 68 61 72 20 2A 6E 6F 6E 61 6D 65 5B 5D 20
+3D 20 7B 0A 2F 2A 20 77 69 64 74 68 20 68 65 69
+XPM
+
+probe_ok(<<PCX, "pcx", 'PCX');
+0A 05 01 08 00 00 00 00 95 00 95 00 96 00 96 00
+00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
+00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
+PCX
+
+probe_ok(<<FITS, "fits", "FITS");
+53 49 4D 50 4C 45 20 20 3D 20 20 20 20 20 20 20 
+20 20 20 20 20 20 20 20 20 20 20 20 20 54 20 20 
+20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 
+FITS
+
+probe_ok(<<PSD, "psd", "Photoshop");
+38 42 50 53 00 01 00 00 00 00 00 00 00 06 00 00
+00 3C 00 00 00 96 00 08 00 03 00 00 00 00 00 00
+0B E6 38 42 49 4D 03 ED 00 00 00 00 00 10 00 90
+PSD
+
+probe_ok(<<EPS, "eps", "Encapsulated Postscript");
+25 21 50 53 2D 41 64 6F 62 65 2D 32 2E 30 20 45
+50 53 46 2D 32 2E 30 0A 25 25 43 72 65 61 74 6F
+72 3A 20 70 6E 6D 74 6F 70 73 0A 25 25 54 69 74
+EPS
+
+probe_ok(<<UTAH, "utah", "Utah RLE");
+52 CC 00 00 00 00 0A 00 0A 00 0A 03 08 00 08 00 
+2F 00 48 49 53 54 4F 52 59 3D 70 6E 6D 74 6F 72 
+6C 65 20 6F 6E 20 54 68 75 20 4D 61 79 20 31 31 
+20 31 36 3A 33 35 3A 34 33 20 32 30 30 36 0A 09 
+UTAH
+
+probe_ok(<<XWD, "xwd", "X Window Dump");
+00 00 00 69 00 00 00 07 00 00 00 02 00 00 00 18
+00 00 01 E4 00 00 01 3C 00 00 00 00 00 00 00 00
+00 00 00 20 00 00 00 00 00 00 00 20 00 00 00 20
+00 00 07 90 00 00 00 04 00 FF 00 00 00 00 FF 00
+XWD
+
+probe_ok(<<GZIP, "gzip", "gzip compressed");
+1F 8B 08 08 C2 81 BD 44 02 03 49 6D 61 67 65 72
+2D 30 2E 35 31 5F 30 33 2E 74 61 72 00 EC 5B 09
+40 53 C7 BA 9E 24 AC 01 D9 44 04 44 08 8B B2 8A
+C9 C9 42 92 56 41 50 20 A0 02 41 41 01 17 48 80
+GZIP
+
+probe_ok(<<BZIP2, "bzip2", "bzip2 compressed");
+42 5A 68 39 31 41 59 26 53 59 0F D8 8C 09 00 03
+28 FF FF FF FF FB 7F FB 77 FF EF BF 6B 7F BE FF
+FF DF EE C8 0F FF F3 FF FF FF FC FF FB B1 FF FB
+F4 07 DF D0 03 B8 03 60 31 82 05 2A 6A 06 83 20
+BZIP2
+
+probe_ok(<<WEBP, "webp", "Google WEBP");
+52 49 46 46 2C 99 00 00 57 45 42 50 56 50 38 20
+20 99 00 00 70 7A 02 9D 01 2A E0 01 80 02 00 87
+08 85 85 88 85 84 88 88 83 AF E2 F7 64 1F 98 55
+1B 6A 70 F5 8A 45 09 95 0C 09 7E 25 D9 2E 46 44
+07 84 FB 01 FD 2C 8A 2F 97 CC ED DB 50 0F 11 3B
+WEBP
+
+probe_ok(<<JPEG2K, "jp2", "JPEG 2000");
+00 00 00 0C 6A 50 20 20 0D 0A 87 0A 00 00 00 14
+66 74 79 70 6A 70 32 20 00 00 00 00 6A 70 32 20
+00 00 00 2D 6A 70 32 68 00 00 00 16 69 68 64 72
+00 00 02 80 00 00 01 E0 00 03 07 07 00 00 00 00
+00 0F 63 6F 6C 72 01 00 00 00 00 00 10 00 00 00
+00 6A 70 32 63 FF 4F FF 51 00 2F 00 00 00 00 01
+JPEG2K
+
+{ # RT 72475
+  # check error messages from read/read_multi
+  my $data = "nothing useful";
+  my @mult_data = Imager->read_multi(data => $data);
+  is(@mult_data, 0, "read_multi with non-image input data should fail");
+  is(Imager->errstr,
+     "type parameter missing and it couldn't be determined from the file contents",
+     "check the error message");
+
+  my @mult_file = Imager->read_multi(file => "t/200-file/100-files.t");
+  is(@mult_file, 0, "read_multi with non-image filename should fail");
+  is(Imager->errstr,
+     "type parameter missing and it couldn't be determined from the file contents or file name",
+     "check the error message");
+
+  my $im = Imager->new;
+  ok(!$im->read(data => $data), "read from non-image data should fail");
+  is($im->errstr,
+     "type parameter missing and it couldn't be determined from the file contents",
+     "check the error message");
+
+  ok(!$im->read(file => "t/200-file/100-files.t"),
+     "read from non-image file should fail");
+  is($im->errstr,
+     "type parameter missing and it couldn't be determined from the file contents or file name",
+     "check the error message");
+}
+
+{
+  # test def_guess_type
+  my @tests =
+    (
+     pnm => "pnm",
+     GIF => "gif",
+     tif => "tiff",
+     TIFF => "tiff",
+     JPG => "jpeg",
+     rle => "utah",
+     bmp => "bmp",
+     dib => "bmp",
+     rgb => "sgi",
+     BW => "sgi",
+     TGA => "tga",
+     CUR => "cur",
+     ico => "ico",
+     ILBM => "ilbm",
+     pcx => "pcx",
+     psd => "psd",
+    );
+
+  while (my ($ext, $expect) = splice(@tests, 0, 2)) {
+    my $filename = "foo.$ext";
+    is(Imager::def_guess_type($filename), $expect,
+       "type for $filename should be $expect");
+  }
+}
+
+Imager->close_log;
+
+unless ($ENV{IMAGER_KEEP_FILES}) {
+  unlink "testout/t1000files.log";
+}
+
+sub probe_ok {
+  my ($packed, $exp_type, $name) = @_;
+
+  my $builder = Test::Builder->new;
+  $packed =~ tr/ \r\n//d; # remove whitespace used for layout
+  my $data = pack("H*", $packed);
+
+  my $io = Imager::io_new_buffer($data);
+  my $result = Imager::i_test_format_probe($io, -1);
+
+  return $builder->is_eq($result, $exp_type, $name)
+}
diff --git a/t/200-file/200-nojpeg.t b/t/200-file/200-nojpeg.t
new file mode 100644 (file)
index 0000000..582d5bf
--- /dev/null
@@ -0,0 +1,28 @@
+#!perl -w
+use strict;
+use Test::More;
+use Imager qw(:all);
+
+-d "testout" or mkdir "testout";
+
+Imager->open_log(log => "testout/t101jpeg.log");
+
+$Imager::formats{"jpeg"}
+  and plan skip_all => "have jpeg support - this tests the lack of it";
+
+plan tests => 6;
+
+my $im = Imager->new;
+ok(!$im->read(file=>"testimg/base.jpg"), "should fail to read jpeg");
+cmp_ok($im->errstr, '=~', qr/format 'jpeg' not supported/, "check no jpeg message");
+$im = Imager->new(xsize=>2, ysize=>2);
+ok(!$im->write(file=>"testout/nojpeg.jpg"), "should fail to write jpeg");
+cmp_ok($im->errstr, '=~', qr/format 'jpeg' not supported/, "check no jpeg message");
+ok(!grep($_ eq 'jpeg', Imager->read_types), "check jpeg not in read types");
+ok(!grep($_ eq 'jpeg', Imager->write_types), "check jpeg not in write types");
+
+Imager->close_log;
+
+unless ($ENV{IMAGER_KEEP_FILES}) {
+  unlink "testout/t101jpeg.log";
+}
diff --git a/t/200-file/210-nopng.t b/t/200-file/210-nopng.t
new file mode 100644 (file)
index 0000000..3509582
--- /dev/null
@@ -0,0 +1,19 @@
+#!perl -w
+use strict;
+use Imager qw(:all);
+use Test::More;
+
+$Imager::formats{"png"}
+  and plan skip_all => "png available, and this tests the lack of it";
+
+plan tests => 6;
+
+my $im = Imager->new;
+ok(!$im->read(file=>"testimg/test.png"), "should fail to read png");
+cmp_ok($im->errstr, '=~', "format 'png' not supported", "check no png message");
+$im = Imager->new(xsize=>2, ysize=>2);
+ok(!$im->write(file=>"testout/nopng.png"), "should fail to write png");
+cmp_ok($im->errstr, '=~', "format 'png' not supported", "check no png message");
+ok(!grep($_ eq 'png', Imager->read_types), "check png not in read types");
+ok(!grep($_ eq 'png', Imager->write_types), "check png not in write types");
+
diff --git a/t/200-file/220-nogif.t b/t/200-file/220-nogif.t
new file mode 100644 (file)
index 0000000..bf053e8
--- /dev/null
@@ -0,0 +1,35 @@
+#!perl -w
+use strict;
+$|=1;
+use Test::More;
+use Imager qw(:all);
+
+$Imager::formats{"gif"}
+  and plan skip_all => "gif support available and this tests the lack of it";
+
+plan tests => 12;
+
+my $im = Imager->new;
+ok(!$im->read(file=>"GIF/testimg/scale.gif"), "should fail to read gif");
+cmp_ok($im->errstr, '=~', "format 'gif' not supported",
+       "check no gif message");
+ok(!Imager->read_multi(file=>"GIF/testimg/scale.gif"), 
+   "should fail to read multi gif");
+cmp_ok($im->errstr, '=~', "format 'gif' not supported",
+       "check no gif message");
+
+$im = Imager->new(xsize=>2, ysize=>2);
+
+ok(!$im->write(file=>"testout/nogif.gif"), "should fail to write gif");
+ok(!-e "testout/nogif.gif", "shouldn't create the file");
+cmp_ok($im->errstr, '=~', "format 'gif' not supported",
+       "check no gif message");
+
+ok(!Imager->write_multi({file => "testout/nogif.gif"}, $im, $im),
+   "should fail to write multi gif");
+ok(!-e "testout/nogif.gif", "shouldn't create the file");
+cmp_ok($im->errstr, '=~', "format 'gif' not supported",
+       "check no gif message");
+
+ok(!grep($_ eq 'gif', Imager->read_types), "check gif not in read types");
+ok(!grep($_ eq 'gif', Imager->write_types), "check gif not in write types");
diff --git a/t/200-file/230-notiff.t b/t/200-file/230-notiff.t
new file mode 100644 (file)
index 0000000..0854640
--- /dev/null
@@ -0,0 +1,36 @@
+#!perl -w
+use strict;
+use Test::More;
+use Imager qw(:all);
+
+$Imager::formats{"tiff"}
+  and plan skip_all => "tiff support available - this tests the lack of it";
+
+plan tests => 12;
+
+my $im = Imager->new;
+
+ok(!$im->read(file=>"TIFF/testimg/comp4.tif"), "should fail to read tif");
+cmp_ok($im->errstr, '=~', "format 'tiff' not supported",
+       "check no tiff message");
+
+ok(!$im->read_multi(file => "TIFF/testimg/comp4.tif"),
+   "should fail to read multi tiff");
+cmp_ok($im->errstr, '=~', "format 'tiff' not supported",
+       "check no tiff message");
+
+$im = Imager->new(xsize=>2, ysize=>2);
+
+ok(!$im->write(file=>"testout/notiff.tif"), "should fail to write tiff");
+cmp_ok($im->errstr, '=~', "format 'tiff' not supported",
+       "check no tiff message");
+ok(!-e "testout/notiff.tif", "file shouldn't be created");
+
+ok(!Imager->write_multi({file=>"testout/notiff.tif"}, $im, $im),
+   "should fail to write multi tiff");
+cmp_ok($im->errstr, '=~', "format 'tiff' not supported",
+       "check no tiff message");
+ok(!-e "testout/notiff.tif", "file shouldn't be created");
+
+ok(!grep($_ eq 'tiff', Imager->read_types), "check tiff not in read types");
+ok(!grep($_ eq 'tiff', Imager->write_types), "check tiff not in write types");
diff --git a/t/200-file/300-raw.t b/t/200-file/300-raw.t
new file mode 100644 (file)
index 0000000..52ab850
--- /dev/null
@@ -0,0 +1,407 @@
+#!perl -w
+use strict;
+use Test::More tests => 53;
+use Imager qw(:all);
+use Imager::Test qw/is_color3 is_color4 test_image test_image_mono/;
+
+-d "testout" or mkdir "testout";
+
+Imager->open_log(log => "testout/t103raw.log");
+
+$| = 1;
+
+my $green=i_color_new(0,255,0,255);
+my $blue=i_color_new(0,0,255,255);
+my $red=i_color_new(255,0,0,255);
+
+my $img=Imager::ImgRaw::new(150,150,3);
+my $cmpimg=Imager::ImgRaw::new(150,150,3);
+
+i_box_filled($img,70,25,130,125,$green);
+i_box_filled($img,20,25,80,125,$blue);
+i_arc($img,75,75,30,0,361,$red);
+i_conv($img,[0.1, 0.2, 0.4, 0.2, 0.1]);
+
+my $timg = Imager::ImgRaw::new(20, 20, 4);
+my $trans = i_color_new(255, 0, 0, 127);
+i_box_filled($timg, 0, 0, 20, 20, $green);
+i_box_filled($timg, 2, 2, 18, 18, $trans);
+
+open(FH,">testout/t103.raw") || die "Cannot open testout/t103.raw for writing\n";
+binmode(FH);
+my $IO = Imager::io_new_fd( fileno(FH) );
+ok(i_writeraw_wiol($img, $IO), "write raw low") or
+  print "# Cannot write testout/t103.raw\n";
+close(FH);
+
+open(FH,"testout/t103.raw") || die "Cannot open testout/t103.raw\n";
+binmode(FH);
+$IO = Imager::io_new_fd( fileno(FH) );
+$cmpimg = i_readraw_wiol($IO, 150, 150, 3, 3, 0);
+ok($cmpimg, "read raw low")
+  or print "# Cannot read testout/t103.raw\n";
+close(FH);
+
+print "# raw average mean square pixel difference: ",sqrt(i_img_diff($img,$cmpimg))/150*150,"\n";
+
+# I could have kept the raw images for these tests in binary files in
+# testimg/, but I think keeping them as hex encoded data in here makes
+# it simpler to add more if necessary
+# Later we may change this to read from a scalar instead
+save_data('testout/t103_base.raw');
+save_data('testout/t103_3to4.raw');
+save_data('testout/t103_line_int.raw');
+save_data('testout/t103_img_int.raw');
+
+# load the base image
+open FH, "testout/t103_base.raw" 
+  or die "Cannot open testout/t103_base.raw: $!";
+binmode FH;
+$IO = Imager::io_new_fd( fileno(FH) );
+
+my $baseimg = i_readraw_wiol( $IO, 4, 4, 3, 3, 0);
+ok($baseimg, "read base raw image")
+  or die "Cannot read base raw image";
+close FH;
+
+# the actual read tests
+# each read_test() call does 2 tests:
+#  - check if the read succeeds
+#  - check if it matches $baseimg
+read_test('testout/t103_3to4.raw', 4, 4, 4, 3, 0, $baseimg);
+read_test('testout/t103_line_int.raw', 4, 4, 3, 3, 1, $baseimg);
+# intrl==2 is documented in raw.c but doesn't seem to be implemented
+#read_test('testout/t103_img_int.raw', 4, 4, 3, 3, 2, $baseimg, 7);
+
+# paletted images
+SKIP:
+{
+  my $palim = Imager::i_img_pal_new(20, 20, 3, 256);
+  ok($palim, "make paletted image")
+    or skip("couldn't make paletted image", 2);
+  my $redindex = Imager::i_addcolors($palim, $red);
+  my $blueindex = Imager::i_addcolors($palim, $blue);
+  for my $y (0..9) {
+    Imager::i_ppal($palim, 0, $y, ($redindex) x 20);
+  }
+  for my $y (10..19) {
+    Imager::i_ppal($palim, 0, $y, ($blueindex) x 20);
+  }
+  open FH, "> testout/t103_pal.raw"
+    or die "Cannot create testout/t103_pal.raw: $!";
+  binmode FH;
+  $IO = Imager::io_new_fd(fileno(FH));
+  ok(i_writeraw_wiol($palim, $IO), "write low paletted");
+  close FH;
+  
+  open FH, "testout/t103_pal.raw"
+    or die "Cannot open testout/t103_pal.raw: $!";
+  binmode FH;
+  my $data = do { local $/; <FH> };
+  is($data, "\x0" x 200 . "\x1" x 200, "compare paletted data written");
+  close FH;
+}
+
+# 16-bit image
+# we don't have 16-bit reads yet
+SKIP:
+{
+  my $img16 = Imager::i_img_16_new(150, 150, 3);
+  ok($img16, "make 16-bit/sample image")
+    or skip("couldn't make 16 bit/sample image", 1);
+  i_box_filled($img16,70,25,130,125,$green);
+  i_box_filled($img16,20,25,80,125,$blue);
+  i_arc($img16,75,75,30,0,361,$red);
+  i_conv($img16,[0.1, 0.2, 0.4, 0.2, 0.1]);
+  
+  open FH, "> testout/t103_16.raw" 
+    or die "Cannot create testout/t103_16.raw: $!";
+  binmode FH;
+  $IO = Imager::io_new_fd(fileno(FH));
+  ok(i_writeraw_wiol($img16, $IO), "write low 16 bit image");
+  close FH;
+}
+
+# try a simple virtual image
+SKIP:
+{
+  my $maskimg = Imager::i_img_masked_new($img, undef, 0, 0, 150, 150);
+  ok($maskimg, "make masked image")
+    or skip("couldn't make masked image", 3);
+
+  open FH, "> testout/t103_virt.raw" 
+    or die "Cannot create testout/t103_virt.raw: $!";
+  binmode FH;
+  $IO = Imager::io_new_fd(fileno(FH));
+  ok(i_writeraw_wiol($maskimg, $IO), "write virtual raw");
+  close FH;
+
+  open FH, "testout/t103_virt.raw"
+    or die "Cannot open testout/t103_virt.raw: $!";
+  binmode FH;
+  $IO = Imager::io_new_fd(fileno(FH));
+  my $cmpimgmask = i_readraw_wiol($IO, 150, 150, 3, 3, 0);
+  ok($cmpimgmask, "read result of masked write");
+  my $diff = i_img_diff($maskimg, $cmpimgmask);
+  print "# difference for virtual image $diff\n";
+  is($diff, 0, "compare masked to read");
+
+  # check that i_format is set correctly
+  my $index = Imager::i_tags_find($cmpimgmask, 'i_format', 0);
+  if ($index) {
+    my $value = Imager::i_tags_get($cmpimgmask, $index);
+    is($value, 'raw', "check i_format value");
+  }
+  else {
+    fail("couldn't find i_format tag");
+  }
+}
+
+{ # error handling checks
+  # should get an error writing to a open for read file
+  # make a empty file
+  open RAW, "> testout/t103_empty.raw"
+    or die "Cannot create testout/t103_empty.raw: $!";
+  close RAW;
+  open RAW, "< testout/t103_empty.raw"
+    or die "Cannot open testout/t103_empty.raw: $!";
+  my $im = Imager->new(xsize => 50, ysize=>50);
+  ok(!$im->write(fh => \*RAW, type => 'raw', buffered => 0),
+     "write to open for read handle");
+  cmp_ok($im->errstr, '=~', '^Could not write to file: write\(\) failure', 
+        "check error message");
+  close RAW;
+
+  # should get an error reading an empty file
+  ok(!$im->read(file => 'testout/t103_empty.raw', xsize => 50, ysize=>50, type=>'raw', interleave => 1),
+     'read an empty file');
+  is($im->errstr, 'premature end of file', "check message");
+ SKIP:
+  {
+    # see 862083f7e40bc2a9e3b94aedce56c1336e7bdb25 in perl5 git
+    $] >= 5.010
+      or skip "5.8.x and earlier don't treat a read on a WRONLY file as an error", 2;
+    open RAW, "> testout/t103_empty.raw"
+      or die "Cannot create testout/t103_empty.raw: $!";
+    ok(!$im->read(fh => \*RAW, , xsize => 50, ysize=>50, type=>'raw', interleave => 1),
+       'read a file open for write');
+    cmp_ok($im->errstr, '=~', '^error reading file: read\(\) failure', "check message");
+  }
+}
+
+
+{
+  ok(grep($_ eq 'raw', Imager->read_types), "check raw in read types");
+  ok(grep($_ eq 'raw', Imager->write_types), "check raw in write types");
+}
+
+
+{ # OO no interleave warning
+  my $im = Imager->new;
+  my $msg;
+  local $SIG{__WARN__} = sub { $msg = "@_" };
+  ok($im->read(file => "testout/t103_line_int.raw", xsize => 4, ysize => 4,
+              type => "raw"),
+     "read without interleave parameter")
+    or print "# ", $im->errstr, "\n";
+  ok($msg, "should have warned");
+  like($msg, qr/interleave/, "check warning is ok");
+  # check we got the right value
+  is_color3($im->getpixel(x => 0, y => 0), 0x00, 0x11, 0x22,
+           "check the image was read correctly");
+
+  # check no warning if either is supplied
+  $im = Imager->new;
+  undef $msg;
+  ok($im->read(file => "testout/t103_base.raw", xsize => 4, ysize => 4, type => "raw", interleave => 0), 
+     "read with interleave 0");
+  is($msg, undef, "no warning");
+  is_color3($im->getpixel(x => 0, y => 0), 0x00, 0x11, 0x22,
+           "check read non-interleave");
+
+  $im = Imager->new;
+  undef $msg;
+  ok($im->read(file => "testout/t103_base.raw", xsize => 4, ysize => 4, type => "raw", raw_interleave => 0), 
+     "read with raw_interleave 0");
+  is($msg, undef, "no warning");
+  is_color3($im->getpixel(x => 1, y => 0), 0x01, 0x12, 0x23,
+           "check read non-interleave");
+
+  # make sure set to 1 is sane
+  $im = Imager->new;
+  undef $msg;
+  ok($im->read(file => "testout/t103_line_int.raw", xsize => 4, ysize => 4, type => "raw", raw_interleave => 1), 
+     "read with raw_interleave 1");
+  is($msg, undef, "no warning");
+  is_color3($im->getpixel(x => 2, y => 0), 0x02, 0x13, 0x24,
+           "check read interleave = 1");
+}
+
+{ # invalid interleave error handling
+  my $im = Imager->new;
+  ok(!$im->read(file => "testout/t103_base.raw", raw_interleave => 2, type => "raw", xsize => 4, ysize => 4),
+     "invalid interleave");
+  is($im->errstr, "raw_interleave must be 0 or 1", "check message");
+}
+
+{ # store/data channel behaviour
+  my $im = Imager->new;
+  ok($im->read(file => "testout/t103_3to4.raw", xsize => 4, ysize => 4, 
+              raw_datachannels => 4, raw_interleave => 0, type => "raw"),
+     "read 4 channel file as 3 channels")
+    or print "# ", $im->errstr, "\n";
+  is_color3($im->getpixel(x => 2, y => 1), 0x12, 0x23, 0x34,
+           "check read correctly");
+}
+
+{ # should fail to read with storechannels > 4
+  my $im = Imager->new;
+  ok(!$im->read(file => "testout/t103_line_int.raw", type => "raw",
+               raw_interleave => 1, xsize => 4, ysize => 4,
+               raw_storechannels => 5),
+     "read with large storechannels");
+  is($im->errstr, "raw_storechannels must be between 1 and 4", 
+     "check error message");
+}
+
+{ # should zero spare channels if storechannels > datachannels
+  my $im = Imager->new;
+  ok($im->read(file => "testout/t103_base.raw", type => "raw",
+               raw_interleave => 0, xsize => 4, ysize => 4,
+               raw_storechannels => 4),
+     "read with storechannels > datachannels");
+  is($im->getchannels, 4, "should have 4 channels");
+  is_color4($im->getpixel(x => 2, y => 1), 0x12, 0x23, 0x34, 0x00,
+           "check last channel zeroed");
+}
+
+{
+  my @ims = ( basic => test_image(), mono => test_image_mono() );
+  push @ims, masked => test_image()->masked();
+
+  my $fail_close = sub {
+    Imager::i_push_error(0, "synthetic close failure");
+    return 0;
+  };
+
+  while (my ($type, $im) = splice(@ims, 0, 2)) {
+    my $io = Imager::io_new_cb(sub { 1 }, undef, undef, $fail_close);
+    ok(!$im->write(io => $io, type => "raw"),
+       "write $type image with a failing close handler");
+    like($im->errstr, qr/synthetic close failure/,
+        "check error message");
+  }
+}
+
+Imager->close_log;
+
+unless ($ENV{IMAGER_KEEP_FILES}) {
+  unlink "testout/t103raw.log";
+  unlink(qw(testout/t103_base.raw testout/t103_3to4.raw
+           testout/t103_line_int.raw testout/t103_img_int.raw))
+}
+
+sub read_test {
+  my ($in, $xsize, $ysize, $data, $store, $intrl, $base) = @_;
+  open FH, $in or die "Cannot open $in: $!";
+  binmode FH;
+  my $IO = Imager::io_new_fd( fileno(FH) );
+
+  my $img = i_readraw_wiol($IO, $xsize, $ysize, $data, $store, $intrl);
+ SKIP:
+  {
+    ok($img, "read_test $in read")
+      or skip("couldn't read $in", 1);
+    is(i_img_diff($img, $baseimg), 0, "read_test $in compare");
+  }
+}
+
+sub save_data {
+  my $outname = shift;
+  my $data = load_data();
+  open FH, "> $outname" or die "Cannot create $outname: $!";
+  binmode FH;
+  print FH $data;
+  close FH;
+}
+
+sub load_data {
+  my $hex = '';
+  while (<DATA>) {
+    next if /^#/;
+    last if /^EOF/;
+    chomp;
+    $hex .= $_;
+  }
+  $hex =~ tr/ //d;
+  my $result = pack("H*", $hex);
+  #print unpack("H*", $result),"\n";
+  return $result;
+}
+
+# FIXME: may need tests for 1,2,4 channel images
+
+__DATA__
+# we keep some packed raw images here
+# we decode this in the code, ignoring lines starting with #, a subfile
+# ends with EOF, data is HEX encoded (spaces ignored)
+
+# basic 3 channel version of the image
+001122 011223 021324 031425
+102132 112233 122334 132435
+203142 213243 223344 233445
+304152 314253 324354 334455
+EOF
+
+# test image for reading a 4 channel image into a 3 channel image
+# 4 x 4 pixels
+00112233 01122334 02132435 03142536
+10213243 11223344 12233445 13243546
+20314253 21324354 22334455 23344556
+30415263 31425364 32435465 33445566
+EOF
+
+# test image for line based interlacing
+# 4 x 4 pixels
+# first line
+00 01 02 03
+11 12 13 14
+22 23 24 25
+
+# second line
+10 11 12 13
+21 22 23 24
+32 33 34 35
+
+# third line
+20 21 22 23
+31 32 33 34
+42 43 44 45
+
+# fourth line
+30 31 32 33
+41 42 43 44
+52 53 54 55
+
+EOF
+
+# test image for image based interlacing
+# first channel
+00 01 02 03
+10 11 12 13
+20 21 22 23
+30 31 32 33
+
+# second channel
+11 12 13 14
+21 22 23 24
+31 32 33 34
+41 42 43 44
+
+# third channel
+22 23 24 25
+32 33 34 35
+42 43 44 45
+52 53 54 55
+
+EOF
diff --git a/t/200-file/310-pnm.t b/t/200-file/310-pnm.t
new file mode 100644 (file)
index 0000000..d299b3a
--- /dev/null
@@ -0,0 +1,661 @@
+#!perl -w
+use Imager ':all';
+use Test::More tests => 205;
+use strict;
+use Imager::Test qw(test_image_raw test_image_16 is_color3 is_color1 is_image test_image_named);
+
+$| = 1;
+
+-d "testout" or mkdir "testout";
+
+Imager->open_log(log => "testout/t104ppm.log");
+
+my $green = i_color_new(0,255,0,255);
+my $blue  = i_color_new(0,0,255,255);
+my $red   = i_color_new(255,0,0,255);
+
+my @files;
+
+my $img    = test_image_raw();
+
+my $fh = openimage(">testout/t104.ppm");
+push @files, "t104.ppm";
+my $IO = Imager::io_new_fd(fileno($fh));
+ok(i_writeppm_wiol($img, $IO), "write pnm low")
+  or die "Cannot write testout/t104.ppm\n";
+close($fh);
+
+$IO = Imager::io_new_bufchain();
+ok(i_writeppm_wiol($img, $IO), "write to bufchain")
+  or die "Cannot write to bufchain";
+my $data = Imager::io_slurp($IO);
+
+$fh = openimage("testout/t104.ppm");
+$IO = Imager::io_new_fd( fileno($fh) );
+my $cmpimg = i_readpnm_wiol($IO,-1);
+ok($cmpimg, "read image we wrote")
+  or die "Cannot read testout/t104.ppm\n";
+close($fh);
+
+is(i_img_diff($img, $cmpimg), 0, "compare written and read images");
+
+my $rdata = slurp("testout/t104.ppm");
+is($data, $rdata, "check data read from file and bufchain data");
+
+# build a grayscale image
+my $gimg = Imager::ImgRaw::new(150, 150, 1);
+my $gray = i_color_new(128, 0, 0, 255);
+my $dgray = i_color_new(64, 0, 0, 255);
+my $white = i_color_new(255, 0, 0, 255);
+i_box_filled($gimg, 20, 20, 130, 130, $gray);
+i_box_filled($gimg, 40, 40, 110, 110, $dgray);
+i_arc($gimg, 75, 75, 30, 0, 361, $white);
+
+push @files, "t104_gray.pgm";
+open FH, "> testout/t104_gray.pgm" or die "Cannot create testout/t104_gray.pgm: $!\n";
+binmode FH;
+$IO = Imager::io_new_fd(fileno(FH));
+ok(i_writeppm_wiol($gimg, $IO), "write grayscale");
+close FH;
+
+open FH, "< testout/t104_gray.pgm" or die "Cannot open testout/t104_gray.pgm: $!\n";
+binmode FH;
+$IO = Imager::io_new_fd(fileno(FH));
+my $gcmpimg = i_readpnm_wiol($IO, -1);
+ok($gcmpimg, "read grayscale");
+is(i_img_diff($gimg, $gcmpimg), 0, 
+   "compare written and read greyscale images");
+
+my $ooim = Imager->new;
+ok($ooim->read(file=>"testimg/simple.pbm"), "read simple pbm, via OO")
+  or print "# ", $ooim->errstr, "\n";
+
+check_gray(Imager::i_get_pixel($ooim->{IMG}, 0, 0), 0);
+check_gray(Imager::i_get_pixel($ooim->{IMG}, 0, 1), 255);
+check_gray(Imager::i_get_pixel($ooim->{IMG}, 1, 0), 255);
+check_gray(Imager::i_get_pixel($ooim->{IMG}, 1, 1), 0);
+is($ooim->type, 'paletted', "check pbm read as paletted");
+is($ooim->tags(name=>'pnm_type'), 1, "check pnm_type tag");
+
+{
+  # https://rt.cpan.org/Ticket/Display.html?id=7465
+  # the pnm reader ignores the maxval that it reads from the pnm file
+  my $maxval = Imager->new;
+  ok($maxval->read(file=>"testimg/maxval.ppm"),
+     "read testimg/maxval.ppm");
+  
+  # this image contains three pixels, with each sample from 0 to 63
+  # the pixels are (63, 63, 63), (32, 32, 32) and (31, 31, 0)
+  
+  # check basic parameters
+  is($maxval->getchannels, 3, "channel count");
+  is($maxval->getwidth, 3, "width");
+  is($maxval->getheight, 1, "height");
+  
+  # check the pixels
+  ok(my ($white, $grey, $green) = $maxval->getpixel('x'=>[0,1,2], 'y'=>[0,0,0]), "fetch pixels");
+  is_color3($white, 255, 255, 255, "white pixel");
+  is_color3($grey,  130, 130, 130, "grey  pixel");
+  is_color3($green, 125, 125, 0,   "green pixel");
+  is($maxval->tags(name=>'pnm_type'), 6, "check pnm_type tag on maxval");
+
+  # and do the same for ASCII images
+  my $maxval_asc = Imager->new;
+  ok($maxval_asc->read(file=>"testimg/maxval_asc.ppm"),
+     "read testimg/maxval_asc.ppm");
+  
+  # this image contains three pixels, with each sample from 0 to 63
+  # the pixels are (63, 63, 63), (32, 32, 32) and (31, 31, 0)
+  
+  # check basic parameters
+  is($maxval_asc->getchannels, 3, "channel count");
+  is($maxval_asc->getwidth, 3, "width");
+  is($maxval_asc->getheight, 1, "height");
+
+  is($maxval->tags(name=>'pnm_type'), 6, "check pnm_type tag on maxval");
+  
+  # check the pixels
+  ok(my ($white_asc, $grey_asc, $green_asc) = $maxval_asc->getpixel('x'=>[0,1,2], 'y'=>[0,0,0]), "fetch pixels");
+  is_color3($white_asc, 255, 255, 255, "white asc pixel");
+  is_color3($grey_asc,  130, 130, 130, "grey  asc pixel");
+  is_color3($green_asc, 125, 125, 0,   "green asc pixel");
+}
+
+{ # previously we didn't validate maxval at all, make sure it's
+  # validated now
+  my $maxval0 = Imager->new;
+  ok(!$maxval0->read(file=>'testimg/maxval_0.ppm'),
+     "should fail to read maxval 0 image");
+  print "# ", $maxval0->errstr, "\n";
+  like($maxval0->errstr, qr/maxval is zero - invalid pnm file/,
+       "error expected from reading maxval_0.ppm");
+
+  my $maxval65536 = Imager->new;
+  ok(!$maxval65536->read(file=>'testimg/maxval_65536.ppm'),
+     "should fail reading maxval 65536 image");
+  print "# ",$maxval65536->errstr, "\n";
+  like($maxval65536->errstr, qr/maxval of 65536 is over 65535 - invalid pnm file/,
+       "error expected from reading maxval_65536.ppm");
+
+  # maxval of 256 is valid, and handled as of 0.56
+  my $maxval256 = Imager->new;
+  ok($maxval256->read(file=>'testimg/maxval_256.ppm'),
+     "should succeed reading maxval 256 image");
+  is_color3($maxval256->getpixel(x => 0, 'y' => 0),
+            0, 0, 0, "check black in maxval_256");
+  is_color3($maxval256->getpixel(x => 0, 'y' => 1),
+            255, 255, 255, "check white in maxval_256");
+  is($maxval256->bits, 16, "check bits/sample on maxval 256");
+
+  # make sure we handle maxval > 255 for ascii
+  my $maxval4095asc = Imager->new;
+  ok($maxval4095asc->read(file=>'testimg/maxval_4095_asc.ppm'),
+     "read maxval_4095_asc.ppm");
+  is($maxval4095asc->getchannels, 3, "channels");
+  is($maxval4095asc->getwidth, 3, "width");
+  is($maxval4095asc->getheight, 1, "height");
+  is($maxval4095asc->bits, 16, "check bits/sample on maxval 4095");
+
+  ok(my ($white, $grey, $green) = $maxval4095asc->getpixel('x'=>[0,1,2], 'y'=>[0,0,0]), "fetch pixels");
+  is_color3($white, 255, 255, 255, "white 4095 pixel");
+  is_color3($grey,  128, 128, 128, "grey  4095 pixel");
+  is_color3($green, 127, 127, 0,   "green 4095 pixel");
+}
+
+{ # check i_format is set when reading a pnm file
+  # doesn't really matter which file.
+  my $maxval = Imager->new;
+  ok($maxval->read(file=>"testimg/maxval.ppm"),
+      "read test file");
+  my ($type) = $maxval->tags(name=>'i_format');
+  is($type, 'pnm', "check i_format");
+}
+
+{ # check file limits are checked
+  my $limit_file = "testout/t104.ppm";
+  ok(Imager->set_file_limits(reset=>1, width=>149), "set width limit 149");
+  my $im = Imager->new;
+  ok(!$im->read(file=>$limit_file),
+     "should fail read due to size limits");
+  print "# ",$im->errstr,"\n";
+  like($im->errstr, qr/image width/, "check message");
+
+  ok(Imager->set_file_limits(reset=>1, height=>149), "set height limit 149");
+  ok(!$im->read(file=>$limit_file),
+     "should fail read due to size limits");
+  print "# ",$im->errstr,"\n";
+  like($im->errstr, qr/image height/, "check message");
+
+  ok(Imager->set_file_limits(reset=>1, width=>150), "set width limit 150");
+  ok($im->read(file=>$limit_file),
+     "should succeed - just inside width limit");
+  ok(Imager->set_file_limits(reset=>1, height=>150), "set height limit 150");
+  ok($im->read(file=>$limit_file),
+     "should succeed - just inside height limit");
+  
+  # 150 x 150 x 3 channel image uses 67500 bytes
+  ok(Imager->set_file_limits(reset=>1, bytes=>67499),
+     "set bytes limit 67499");
+  ok(!$im->read(file=>$limit_file),
+     "should fail - too many bytes");
+  print "# ",$im->errstr,"\n";
+  like($im->errstr, qr/storage size/, "check error message");
+  ok(Imager->set_file_limits(reset=>1, bytes=>67500),
+     "set bytes limit 67500");
+  ok($im->read(file=>$limit_file),
+     "should succeed - just inside bytes limit");
+  Imager->set_file_limits(reset=>1);
+}
+
+{
+  # check we correctly sync with the data stream
+  my $im = Imager->new;
+  ok($im->read(file => 'testimg/pgm.pgm', type => 'pnm'),
+     "read pgm.pgm")
+    or print "# cannot read pgm.pgm: ", $im->errstr, "\n";
+  print "# ", $im->getsamples('y' => 0), "\n";
+  is_color1($im->getpixel(x=>0, 'y' => 0), 254, "check top left");
+}
+
+{ # check error messages set correctly
+  my $im = Imager->new;
+  ok(!$im->read(file=>'t/200-file/310-pnm.t', type=>'pnm'),
+     'should fail to read script as an image file');
+  is($im->errstr, 'unable to read pnm image: bad header magic, not a PNM file',
+     "check error message");
+}
+
+{
+  # RT #30074
+  # give 4/2 channel images a background color when saving to pnm
+  my $im = Imager->new(xsize=>16, ysize=>16, channels=>4);
+  $im->box(filled => 1, xmin => 8, color => '#FFE0C0');
+  $im->box(filled => 1, color => NC(0, 192, 192, 128),
+          ymin => 8, xmax => 7);
+  push @files, "t104_alpha.ppm";
+  ok($im->write(file=>"testout/t104_alpha.ppm", type=>'pnm'),
+     "should succeed writing 4 channel image");
+  my $imread = Imager->new;
+  ok($imread->read(file => 'testout/t104_alpha.ppm'), "read it back")
+    or print "# ", $imread->errstr, "\n";
+  is_color3($imread->getpixel('x' => 0, 'y' => 0), 0, 0, 0, 
+           "check transparent became black");
+  is_color3($imread->getpixel('x' => 8, 'y' => 0), 255, 224, 192,
+           "check color came through");
+  is_color3($imread->getpixel('x' => 0, 'y' => 15), 0, 96, 96,
+           "check translucent came through");
+  my $data;
+  ok($im->write(data => \$data, type => 'pnm', i_background => '#FF0000'),
+     "write with red background");
+  ok($imread->read(data => $data, type => 'pnm'),
+     "read it back");
+  is_color3($imread->getpixel('x' => 0, 'y' => 0), 255, 0, 0, 
+           "check transparent became red");
+  is_color3($imread->getpixel('x' => 8, 'y' => 0), 255, 224, 192,
+           "check color came through");
+  is_color3($imread->getpixel('x' => 0, 'y' => 15), 127, 96, 96,
+           "check translucent came through");
+}
+
+{
+  # more RT #30074 - 16 bit images
+  my $im = Imager->new(xsize=>16, ysize=>16, channels=>4, bits => 16);
+  $im->box(filled => 1, xmin => 8, color => '#FFE0C0');
+  $im->box(filled => 1, color => NC(0, 192, 192, 128),
+          ymin => 8, xmax => 7);
+  push @files, "t104_alp16.ppm";
+  ok($im->write(file=>"testout/t104_alp16.ppm", type=>'pnm', 
+               pnm_write_wide_data => 1),
+     "should succeed writing 4 channel image");
+  my $imread = Imager->new;
+  ok($imread->read(file => 'testout/t104_alp16.ppm'), "read it back");
+  is($imread->bits, 16, "check we did produce a 16 bit image");
+  is_color3($imread->getpixel('x' => 0, 'y' => 0), 0, 0, 0, 
+           "check transparent became black");
+  is_color3($imread->getpixel('x' => 8, 'y' => 0), 255, 224, 192,
+           "check color came through");
+  is_color3($imread->getpixel('x' => 0, 'y' => 15), 0, 96, 96,
+           "check translucent came through");
+  my $data;
+  ok($im->write(data => \$data, type => 'pnm', i_background => '#FF0000',
+               pnm_write_wide_data => 1),
+     "write with red background");
+  ok($imread->read(data => $data, type => 'pnm'),
+     "read it back");
+  is($imread->bits, 16, "check it's 16-bit");
+  is_color3($imread->getpixel('x' => 0, 'y' => 0), 255, 0, 0, 
+           "check transparent became red");
+  is_color3($imread->getpixel('x' => 8, 'y' => 0), 255, 224, 192,
+           "check color came through");
+  is_color3($imread->getpixel('x' => 0, 'y' => 15), 127, 96, 96,
+           "check translucent came through");
+}
+
+# various bad input files
+print "# check error handling\n";
+{
+  my $im = Imager->new;
+  ok(!$im->read(file => 'testimg/short_bin.ppm', type=>'pnm'),
+     "fail to read short bin ppm");
+  cmp_ok($im->errstr, '=~', 'short read - file truncated', 
+         "check error message");
+}
+
+{
+  my $im = Imager->new;
+  ok(!$im->read(file => 'testimg/short_bin16.ppm', type=>'pnm'),
+     "fail to read short bin ppm (maxval 65535)");
+  cmp_ok($im->errstr, '=~', 'short read - file truncated', 
+         "check error message");
+}
+
+{
+  my $im = Imager->new;
+  ok(!$im->read(file => 'testimg/short_bin.pgm', type=>'pnm'),
+     "fail to read short bin pgm");
+  cmp_ok($im->errstr, '=~', 'short read - file truncated', 
+         "check error message");
+}
+
+{
+  my $im = Imager->new;
+  ok(!$im->read(file => 'testimg/short_bin16.pgm', type=>'pnm'),
+     "fail to read short bin pgm (maxval 65535)");
+  cmp_ok($im->errstr, '=~', 'short read - file truncated', 
+         "check error message");
+}
+
+{
+  my $im = Imager->new;
+  ok(!$im->read(file => 'testimg/short_bin.pbm', type => 'pnm'),
+     "fail to read a short bin pbm");
+  cmp_ok($im->errstr, '=~', 'short read - file truncated', 
+         "check error message");
+}
+
+{
+  my $im = Imager->new;
+  ok(!$im->read(file => 'testimg/short_asc.ppm', type => 'pnm'),
+     "fail to read a short asc ppm");
+  cmp_ok($im->errstr, '=~', 'short read - file truncated', 
+         "check error message");
+}
+
+{
+  my $im = Imager->new;
+  ok(!$im->read(file => 'testimg/short_asc.pgm', type => 'pnm'),
+     "fail to read a short asc pgm");
+  cmp_ok($im->errstr, '=~', 'short read - file truncated', 
+         "check error message");
+}
+
+{
+  my $im = Imager->new;
+  ok(!$im->read(file => 'testimg/short_asc.pbm', type => 'pnm'),
+     "fail to read a short asc pbm");
+  cmp_ok($im->errstr, '=~', 'short read - file truncated', 
+         "check error message");
+}
+
+{
+  my $im = Imager->new;
+  ok(!$im->read(file => 'testimg/bad_asc.ppm', type => 'pnm'),
+     "fail to read a bad asc ppm");
+  cmp_ok($im->errstr, '=~', 'invalid data for ascii pnm', 
+         "check error message");
+}
+
+{
+  my $im = Imager->new;
+  ok(!$im->read(file => 'testimg/bad_asc.pgm', type => 'pnm'),
+     "fail to read a bad asc pgm");
+  cmp_ok($im->errstr, '=~', 'invalid data for ascii pnm', 
+         "check error message");
+}
+
+{
+  my $im = Imager->new;
+  ok(!$im->read(file => 'testimg/bad_asc.pbm', type => 'pnm'),
+     "fail to read a bad asc pbm");
+  cmp_ok($im->errstr, '=~', 'invalid data for ascii pnm', 
+         "check error message");
+}
+
+{
+  my $im = Imager->new;
+  ok($im->read(file => 'testimg/short_bin.ppm', type => 'pnm',
+                allow_incomplete => 1),
+     "partial read bin ppm");
+  is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
+  is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
+}
+
+{
+  my $im = Imager->new;
+  ok($im->read(file => 'testimg/short_bin16.ppm', type => 'pnm',
+                allow_incomplete => 1),
+     "partial read bin16 ppm");
+  is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
+  is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
+  is($im->bits, 16, "check correct bits");
+}
+
+{
+  my $im = Imager->new;
+  ok($im->read(file => 'testimg/short_bin.pgm', type => 'pnm',
+                allow_incomplete => 1),
+     "partial read bin pgm");
+  is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
+  is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
+}
+
+{
+  my $im = Imager->new;
+  ok($im->read(file => 'testimg/short_bin16.pgm', type => 'pnm',
+                allow_incomplete => 1),
+     "partial read bin16 pgm");
+  is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
+  is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
+}
+
+{
+  my $im = Imager->new;
+  ok($im->read(file => 'testimg/short_bin.pbm', type => 'pnm',
+                allow_incomplete => 1),
+     "partial read bin pbm");
+  is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
+  is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
+}
+
+{
+  my $im = Imager->new;
+  ok($im->read(file => 'testimg/short_asc.ppm', type => 'pnm',
+                allow_incomplete => 1),
+     "partial read asc ppm");
+  is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
+  is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
+}
+
+{
+  my $im = Imager->new;
+  ok($im->read(file => 'testimg/short_asc.pgm', type => 'pnm',
+                allow_incomplete => 1),
+     "partial read asc pgm");
+  is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
+  is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
+}
+
+{
+  my $im = Imager->new;
+  ok($im->read(file => 'testimg/short_asc.pbm', type => 'pnm',
+                allow_incomplete => 1),
+     "partial read asc pbm");
+  is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
+  is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
+}
+
+{
+  my @imgs = Imager->read_multi(file => 'testimg/multiple.ppm');
+  is( 0+@imgs, 3, "Read 3 images");
+  is( $imgs[0]->tags( name => 'pnm_type' ), 1, "Image 1 is type 1" );
+  is( $imgs[0]->getwidth, 2, " ... width=2" );
+  is( $imgs[0]->getheight, 2, " ... width=2" );
+  is( $imgs[1]->tags( name => 'pnm_type' ), 6, "Image 2 is type 6" );
+  is( $imgs[1]->getwidth, 164, " ... width=164" );
+  is( $imgs[1]->getheight, 180, " ... width=180" );
+  is( $imgs[2]->tags( name => 'pnm_type' ), 5, "Image 3 is type 5" );
+  is( $imgs[2]->getwidth, 2, " ... width=2" );
+  is( $imgs[2]->getheight, 2, " ... width=2" );
+}
+
+{
+  my $im = Imager->new;
+  ok($im->read(file => 'testimg/bad_asc.ppm', type => 'pnm',
+                allow_incomplete => 1),
+     "partial read bad asc ppm");
+  is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
+  is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
+}
+
+{
+  my $im = Imager->new;
+  ok($im->read(file => 'testimg/bad_asc.pgm', type => 'pnm',
+                allow_incomplete => 1),
+     "partial read bad asc pgm");
+  is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
+  is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
+}
+
+{
+  my $im = Imager->new;
+  ok($im->read(file => 'testimg/bad_asc.pbm', type => 'pnm',
+                allow_incomplete => 1),
+     "partial read bad asc pbm");
+  is($im->tags(name => 'i_incomplete'), 1, "partial flag set");
+  is($im->tags(name => 'i_lines_read'), 1, "lines_read set");
+}
+
+{
+  print "# monochrome output\n";
+  my $im = Imager->new(xsize => 10, ysize => 10, channels => 1, type => 'paletted');
+  ok($im->addcolors(colors => [ '#000000', '#FFFFFF' ]),
+     "add black and white");
+  $im->box(filled => 1, xmax => 4, color => '#000000');
+  $im->box(filled => 1, xmin => 5, color => '#FFFFFF');
+  is($im->type, 'paletted', 'mono still paletted');
+  push @files, "t104_mono.pbm";
+  ok($im->write(file => 'testout/t104_mono.pbm', type => 'pnm'),
+     "save as pbm");
+
+  # check it
+  my $imread = Imager->new;
+  ok($imread->read(file => 'testout/t104_mono.pbm', type=>'pnm'),
+     "read it back in")
+    or print "# ", $imread->errstr, "\n";
+  is($imread->type, 'paletted', "check result is paletted");
+  is($imread->tags(name => 'pnm_type'), 4, "check type");
+  is_image($im, $imread, "check image matches");
+}
+
+{
+  print "# monochrome output - reversed palette\n";
+  my $im = Imager->new(xsize => 10, ysize => 10, channels => 1, type => 'paletted');
+  ok($im->addcolors(colors => [ '#FFFFFF', '#000000' ]),
+     "add white and black");
+  $im->box(filled => 1, xmax => 4, color => '#000000');
+  $im->box(filled => 1, xmin => 5, color => '#FFFFFF');
+  is($im->type, 'paletted', 'mono still paletted');
+  push @files, "t104_mono2.pbm";
+  ok($im->write(file => 'testout/t104_mono2.pbm', type => 'pnm'),
+     "save as pbm");
+
+  # check it
+  my $imread = Imager->new;
+  ok($imread->read(file => 'testout/t104_mono2.pbm', type=>'pnm'),
+     "read it back in")
+    or print "# ", $imread->errstr, "\n";
+  is($imread->type, 'paletted', "check result is paletted");
+  is($imread->tags(name => 'pnm_type'), 4, "check type");
+  is_image($im, $imread, "check image matches");
+}
+
+{
+  print "# 16-bit output\n";
+  my $data;
+  my $im = test_image_16();
+  
+  # without tag, it should do 8-bit output
+  ok($im->write(data => \$data, type => 'pnm'),
+     "write 16-bit image as 8-bit/sample ppm");
+  my $im8 = Imager->new;
+  ok($im8->read(data => $data), "read it back");
+  is($im8->tags(name => 'pnm_maxval'), 255, "check maxval");
+  is_image($im, $im8, "check image matches");
+
+  # try 16-bit output
+  $im->settag(name => 'pnm_write_wide_data', value => 1);
+  $data = '';
+  ok($im->write(data => \$data, type => 'pnm'),
+     "write 16-bit image as 16-bit/sample ppm");
+  push @files, "t104_16.ppm";
+  $im->write(file=>'testout/t104_16.ppm');
+  my $im16 = Imager->new;
+  ok($im16->read(data => $data), "read it back");
+  is($im16->tags(name => 'pnm_maxval'), 65535, "check maxval");
+  push @files, "t104_16b.ppm";
+  $im16->write(file=>'testout/t104_16b.ppm');
+  is_image($im, $im16, "check image matches");
+}
+
+{
+  ok(grep($_ eq 'pnm', Imager->read_types), "check pnm in read types");
+  ok(grep($_ eq 'pnm', Imager->write_types), "check pnm in write types");
+}
+
+{ # test new() loading an image
+  my $im = Imager->new(file => "testimg/penguin-base.ppm");
+  ok($im, "received an image");
+  is($im->getwidth, 164, "check width matches image");
+
+  # fail to load an image
+  my $im2 = Imager->new(file => "Imager.pm", filetype => "pnm");
+  ok(!$im2, "no image when file failed to load");
+  cmp_ok(Imager->errstr, '=~', "bad header magic, not a PNM file",
+        "check error message transferred");
+
+  # load from data
+ SKIP:
+  {
+    ok(open(FH, "< testimg/penguin-base.ppm"), "open test file")
+      or skip("couldn't open data source", 4);
+    binmode FH;
+    my $imdata = do { local $/; <FH> };
+    close FH;
+    ok(length $imdata, "we got the data");
+    my $im3 = Imager->new(data => $imdata);
+    ok($im3, "read the file data");
+    is($im3->getwidth, 164, "check width matches image");
+  }
+}
+
+{ # image too large handling
+  {
+    ok(!Imager->new(file => "testimg/toowide.ppm", filetype => "pnm"),
+       "fail to read a too wide image");
+    is(Imager->errstr, "unable to read pnm image: could not read image width: integer overflow",
+       "check error message");
+  }
+  {
+    ok(!Imager->new(file => "testimg/tootall.ppm", filetype => "pnm"),
+       "fail to read a too wide image");
+    is(Imager->errstr, "unable to read pnm image: could not read image height: integer overflow",
+       "check error message");
+  }
+}
+
+{ # make sure close is checked for each image type
+  my $fail_close = sub {
+    Imager::i_push_error(0, "synthetic close failure");
+    return 0;
+  };
+
+  for my $type (qw(basic basic16 gray gray16 mono)) {
+    my $im = test_image_named($type);
+    my $io = Imager::io_new_cb(sub { 1 }, undef, undef, $fail_close);
+    ok(!$im->write(io => $io, type => "pnm"),
+       "write $type image with a failing close handler");
+    like($im->errstr, qr/synthetic close failure/,
+        "check error message");
+  }
+}
+
+Imager->close_log;
+
+unless ($ENV{IMAGER_KEEP_FILES}) {
+  unlink "testout/t104ppm.log";
+  unlink map "testout/$_", @files;
+}
+
+sub openimage {
+  my $fname = shift;
+  local(*FH);
+  open(FH, $fname) or die "Cannot open $fname: $!\n";
+  binmode(FH);
+  return *FH;
+}
+
+sub slurp {
+  my $fh = openimage(shift);
+  local $/;
+  my $data = <$fh>;
+  close($fh);
+  return $data;
+}
+
+sub check_gray {
+  my ($c, $gray) = @_;
+
+  my ($g) = $c->rgba;
+  is($g, $gray, "compare gray");
+}
+
diff --git a/t/200-file/320-bmp.t b/t/200-file/320-bmp.t
new file mode 100644 (file)
index 0000000..356d776
--- /dev/null
@@ -0,0 +1,798 @@
+#!perl -w
+use strict;
+use Test::More tests => 215;
+use Imager qw(:all);
+use Imager::Test qw(test_image_raw is_image is_color3 test_image);
+
+-d "testout" or mkdir "testout";
+
+Imager->open_log(log => "testout/t107bmp.log");
+
+my @files;
+my $debug_writes = 0;
+
+my $base_diff = 0;
+# if you change this make sure you generate new compressed versions
+my $green=i_color_new(0,255,0,255);
+my $blue=i_color_new(0,0,255,255);
+my $red=i_color_new(255,0,0,255);
+
+my $img = test_image_raw();
+
+Imager::i_tags_add($img, 'i_xres', 0, '300', 0);
+Imager::i_tags_add($img, 'i_yres', 0, undef, 300);
+write_test($img, "testout/t107_24bit.bmp");
+push @files, "t107_24bit.bmp";
+# 'webmap' is noticably faster than the default
+my $im8 = Imager::i_img_to_pal($img, { make_colors=>'webmap', 
+                                      translate=>'errdiff'});
+write_test($im8, "testout/t107_8bit.bmp");
+push @files, "t107_8bit.bmp";
+# use a fixed palette so we get reproducible results for the compressed
+# version
+my @pal16 = map { NC($_) } 
+  qw(605844 966600 0148b2 00f800 bf0a33 5e009e
+     2ead1b 0000f8 004b01 fd0000 0e1695 000002);
+my $im4 = Imager::i_img_to_pal($img, { colors=>\@pal16, make_colors=>'none' });
+write_test($im4, "testout/t107_4bit.bmp");
+push @files, "t107_4bit.bmp";
+my $im1 = Imager::i_img_to_pal($img, { colors=>[ NC(0, 0, 0), NC(176, 160, 144) ],
+                              make_colors=>'none', translate=>'errdiff' });
+write_test($im1, "testout/t107_1bit.bmp");
+push @files, "t107_1bit.bmp";
+my $bi_rgb = 0;
+my $bi_rle8 = 1;
+my $bi_rle4 = 2;
+my $bi_bitfields = 3;
+read_test("testout/t107_24bit.bmp", $img, 
+          bmp_compression=>0, bmp_bit_count => 24);
+read_test("testout/t107_8bit.bmp", $im8, 
+          bmp_compression=>0, bmp_bit_count => 8);
+read_test("testout/t107_4bit.bmp", $im4, 
+          bmp_compression=>0, bmp_bit_count => 4);
+read_test("testout/t107_1bit.bmp", $im1, bmp_compression=>0, 
+          bmp_bit_count=>1);
+# the following might have slight differences
+$base_diff = i_img_diff($img, $im8) * 2;
+print "# base difference $base_diff\n";
+read_test("testimg/comp4.bmp", $im4, 
+          bmp_compression=>$bi_rle4, bmp_bit_count => 4);
+read_test("testimg/comp8.bmp", $im8, 
+          bmp_compression=>$bi_rle8, bmp_bit_count => 8);
+
+my $imoo = Imager->new;
+# read via OO
+ok($imoo->read(file=>'testout/t107_24bit.bmp'), "read via OO")
+  or print "# ",$imoo->errstr,"\n";
+
+ok($imoo->write(file=>'testout/t107_oo.bmp'), "write via OO")
+  or print "# ",$imoo->errstr,"\n";
+push @files, "t107_oo.bmp";
+
+# various invalid format tests
+# we have so many different test images to try to detect all the possible
+# failure paths in the code, adding these did detect real problems
+print "# catch various types of invalid bmp files\n";
+my @tests =
+  (
+   # entries in each array ref are:
+   #  - basename of an invalid BMP file
+   #  - error message that should be produced
+   #  - description of what is being tested
+   #  - possible flag to indicate testing only on 32-bit machines
+   [ 'badplanes.bmp', 'not a BMP file', "invalid planes value" ],
+   [ 'badbits.bmp', 'unknown bit count for BMP file (5)', 
+     'should fail to read invalid bits' ],
+
+   # 1-bit/pixel BMPs
+   [ 'badused1.bmp', 'out of range colors used (3)',
+     'out of range palette size (1-bit)' ],
+   [ 'badcomp1.bmp', 'unknown 1-bit BMP compression (1)',
+     'invalid compression value (1-bit)' ],
+   [ 'bad1wid0.bmp', 'file size limit - image width of 0 is not positive',
+     'width 0 (1-bit)' ],
+   [ 'bad4oflow.bmp', 
+     'file size limit - integer overflow calculating storage',
+     'overflow integers on 32-bit machines (1-bit)', '32bitonly' ],
+   [ 'short1.bmp', 'failed reading 1-bit bmp data', 
+     'short 1-bit' ],
+
+   # 4-bit/pixel BMPs
+   [ 'badused4a.bmp', 'out of range colors used (272)', 
+     'should fail to read invalid pal size (272) (4-bit)' ],
+   [ 'badused4b.bmp', 'out of range colors used (17)',
+     'should fail to read invalid pal size (17) (4-bit)' ],
+   [ 'badcomp4.bmp', 'unknown 4-bit BMP compression (1)',
+     'invalid compression value (4-bit)' ],
+   [ 'short4.bmp', 'failed reading 4-bit bmp data', 
+     'short uncompressed 4-bit' ],
+   [ 'short4rle.bmp', 'missing data during decompression', 
+     'short compressed 4-bit' ],
+   [ 'bad4wid0.bmp', 'file size limit - image width of 0 is not positive',
+     'width 0 (4-bit)' ],
+   [ 'bad4widbig.bmp', 'file size limit - image width of -2147483628 is not positive',
+     'width big (4-bit)' ],
+   [ 'bad4oflow.bmp', 'file size limit - integer overflow calculating storage',
+     'overflow integers on 32-bit machines (4-bit)', '32bitonly' ],
+
+   # 8-bit/pixel BMPs
+   [ 'bad8useda.bmp', 'out of range colors used (257)',
+     'should fail to read invalid pal size (8-bit)' ],
+   [ 'bad8comp.bmp', 'unknown 8-bit BMP compression (2)',
+     'invalid compression value (8-bit)' ],
+   [ 'short8.bmp', 'failed reading 8-bit bmp data', 
+     'short uncompressed 8-bit' ],
+   [ 'short8rle.bmp', 'missing data during decompression', 
+     'short compressed 8-bit' ],
+   [ 'bad8wid0.bmp', 'file size limit - image width of 0 is not positive',
+     'width 0 (8-bit)' ],
+   [ 'bad8oflow.bmp', 'file size limit - integer overflow calculating storage',
+     'overflow integers on 32-bit machines (8-bit)', '32bitonly' ],
+
+   # 24-bit/pixel BMPs
+   [ 'short24.bmp', 'failed reading image data',
+     'short 24-bit' ],
+   [ 'bad24wid0.bmp', 'file size limit - image width of 0 is not positive',
+     'width 0 (24-bit)' ],
+   [ 'bad24oflow.bmp', 'file size limit - integer overflow calculating storage',
+     'overflow integers on 32-bit machines (24-bit)', '32bitonly' ],
+   [ 'bad24comp.bmp', 'unknown 24-bit BMP compression (4)',
+     'bad compression (24-bit)' ],
+  );
+use Config;
+my $ptrsize = $Config{ptrsize};
+for my $test (@tests) {
+  my ($file, $error, $comment, $bit32only) = @$test;
+ SKIP:
+  {
+    skip("only tested on 32-bit machines", 2)
+      if $bit32only && $ptrsize != 4;
+    ok(!$imoo->read(file=>"testimg/$file"), $comment);
+    print "# ", $imoo->errstr, "\n";
+    is($imoo->errstr, $error, "check error message");
+  }
+}
+
+# previously we didn't seek to the offbits position before reading
+# the image data, check we handle it correctly
+# in each case the first is an original image with a given number of
+# bits and the second is the same file with data inserted before the
+# image bits and the offset modified to suit
+my @comp =
+  (
+   [ 'winrgb2.bmp', 'winrgb2off.bmp', 1 ],
+   [ 'winrgb4.bmp', 'winrgb4off.bmp', 4 ],
+   [ 'winrgb8.bmp', 'winrgb8off.bmp', 8 ],
+   [ 'winrgb24.bmp', 'winrgb24off.bmp', 24 ],
+  );
+
+for my $comp (@comp) {
+  my ($base_file, $off_file, $bits) = @$comp;
+
+  my $base_im = Imager->new;
+  my $got_base = 
+    ok($base_im->read(file=>"testimg/$base_file"),
+        "read original")
+      or print "# ",$base_im->errstr,"\n";
+  my $off_im = Imager->new;
+  my $got_off =
+    ok($off_im->read(file=>"testimg/$off_file"),
+        "read offset file")
+      or print "# ",$off_im->errstr,"\n";
+ SKIP:
+  {
+    skip("missed one file", 1)
+      unless $got_base && $got_off;
+    is(i_img_diff($base_im->{IMG}, $off_im->{IMG}), 0,
+        "compare base and offset image ($bits bits)");
+  }
+}
+
+{ # check file limits are checked
+  my $limit_file = "testout/t107_24bit.bmp";
+  ok(Imager->set_file_limits(reset=>1, width=>149), "set width limit 149");
+  my $im = Imager->new;
+  ok(!$im->read(file=>$limit_file),
+     "should fail read due to size limits");
+  print "# ",$im->errstr,"\n";
+  like($im->errstr, qr/image width/, "check message");
+
+  ok(Imager->set_file_limits(reset=>1, height=>149), "set height limit 149");
+  ok(!$im->read(file=>$limit_file),
+     "should fail read due to size limits");
+  print "# ",$im->errstr,"\n";
+  like($im->errstr, qr/image height/, "check message");
+
+  ok(Imager->set_file_limits(reset=>1, width=>150), "set width limit 150");
+  ok($im->read(file=>$limit_file),
+     "should succeed - just inside width limit");
+  ok(Imager->set_file_limits(reset=>1, height=>150), "set height limit 150");
+  ok($im->read(file=>$limit_file),
+     "should succeed - just inside height limit");
+  
+  # 150 x 150 x 3 channel image uses 67500 bytes
+  ok(Imager->set_file_limits(reset=>1, bytes=>67499),
+     "set bytes limit 67499");
+  ok(!$im->read(file=>$limit_file),
+     "should fail - too many bytes");
+  print "# ",$im->errstr,"\n";
+  like($im->errstr, qr/storage size/, "check error message");
+  ok(Imager->set_file_limits(reset=>1, bytes=>67500),
+     "set bytes limit 67500");
+  ok($im->read(file=>$limit_file),
+     "should succeed - just inside bytes limit");
+  Imager->set_file_limits(reset=>1);
+}
+
+{ # various short read failure tests, each entry has:
+  # source filename, size, expected error
+  # these have been selected based on code coverage, to check each
+  # failure path is checked, where practical
+  my @tests =
+    (
+     [ 
+      "file truncated inside header",
+      "winrgb2.bmp", 
+      20, "file too short to be a BMP file"
+     ],
+     [
+      "1-bit, truncated inside palette",
+      "winrgb2.bmp", 
+      56, "reading BMP palette" 
+     ],
+     [ 
+      "1-bit, truncated in offset region",
+      "winrgb2off.bmp", 64, "failed skipping to image data offset" 
+     ],
+     [ 
+      "1-bit, truncated in image data",
+      "winrgb2.bmp", 96, "failed reading 1-bit bmp data"
+     ],
+     [
+      "4-bit, truncated inside palette",
+      "winrgb4.bmp",
+      56, "reading BMP palette"
+     ],
+     [
+      "4-bit, truncated in offset region",
+      "winrgb4off.bmp", 120, "failed skipping to image data offset",
+     ],
+     [
+      "4-bit, truncate in image data",
+      "winrgb4.bmp", 120, "failed reading 4-bit bmp data"
+     ],
+     [
+      "4-bit RLE, truncate in uncompressed data",
+      "comp4.bmp", 0x229, "missing data during decompression"
+     ],
+     [
+      "8-bit, truncated in palette",
+      "winrgb8.bmp", 1060, "reading BMP palette"
+      ],
+     [
+      "8-bit, truncated in offset region",
+      "winrgb8off.bmp", 1080, "failed skipping to image data offset"
+     ],
+     [
+      "8-bit, truncated in image data",
+      "winrgb8.bmp", 1080, "failed reading 8-bit bmp data"
+     ],
+     [
+      "8-bit RLE, truncate in uncompressed data",
+      "comp8.bmp", 0x68C, "missing data during decompression"
+     ],
+     [
+      "24-bit, truncate in offset region",
+      "winrgb24off.bmp", 56, "failed skipping to image data offset",
+     ],
+     [
+      "24-bit, truncate in image data",
+      "winrgb24.bmp", 100, "failed reading image data",
+     ],
+    );
+
+  my $test_index = 0;
+  for my $test (@tests) {
+    my ($desc, $srcfile, $size, $error) = @$test;
+    my $im = Imager->new;
+    open IMDATA, "< testimg/$srcfile"
+      or die "$test_index - $desc: Cannot open testimg/$srcfile: $!";
+    binmode IMDATA;
+    my $data;
+    read(IMDATA, $data, $size) == $size
+      or die "$test_index - $desc: Could not read $size data from $srcfile";
+    close IMDATA;
+    ok(!$im->read(data => $data, type =>'bmp'),
+       "$test_index - $desc: Should fail to read");
+    is($im->errstr, $error, "$test_index - $desc: check message");
+    ++$test_index;
+  }
+}
+
+{ # various short read success tests, each entry has:
+  # source filename, size, expected tags
+  print "# allow_incomplete tests\n";
+  my @tests =
+    (
+     [ 
+      "1-bit",
+      "winrgb2.bmp", 96,
+      {
+       bmp_compression_name => 'BI_RGB',
+       bmp_compression => 0,
+       bmp_used_colors => 2,
+       i_lines_read => 8,
+      },
+     ],
+     [
+      "4-bit",
+      "winrgb4.bmp", 250,
+      {
+       bmp_compression_name => 'BI_RGB',
+       bmp_compression => 0,
+       bmp_used_colors => 16,
+       i_lines_read => 11,
+      },
+     ],
+     [
+      "4-bit RLE - uncompressed seq",
+      "comp4.bmp", 0x229, 
+      {
+       bmp_compression_name => 'BI_RLE4',
+       bmp_compression => 2,
+       bmp_used_colors => 16,
+       i_lines_read => 44,
+      },
+     ],
+     [
+      "4-bit RLE - start seq",
+      "comp4.bmp", 0x97, 
+      {
+       bmp_compression_name => 'BI_RLE4',
+       bmp_compression => 2,
+       bmp_used_colors => 16,
+       i_lines_read => 8,
+      },
+     ],
+     [
+      "8-bit",
+      "winrgb8.bmp", 1250,
+      {
+       bmp_compression_name => 'BI_RGB',
+       bmp_compression => 0,
+       bmp_used_colors => 256,
+       i_lines_read => 8,
+      },
+     ],
+     [
+      "8-bit RLE - uncompressed seq",
+      "comp8.bmp", 0x68C, 
+      {
+       bmp_compression_name => 'BI_RLE8',
+       bmp_compression => 1,
+       bmp_used_colors => 256,
+       i_lines_read => 27,
+      },
+     ],
+     [
+      "8-bit RLE - initial seq",
+      "comp8.bmp", 0x487, 
+      {
+       bmp_compression_name => 'BI_RLE8',
+       bmp_compression => 1,
+       bmp_used_colors => 256,
+       i_lines_read => 20,
+      },
+     ],
+     [
+      "24-bit",
+      "winrgb24.bmp", 800,
+      {
+       bmp_compression_name => 'BI_RGB',
+       bmp_compression => 0,
+       bmp_used_colors => 0,
+       i_lines_read => 12,
+      },
+     ],
+    );
+
+  my $test_index = 0;
+  for my $test (@tests) {
+    my ($desc, $srcfile, $size, $tags) = @$test;
+    my $im = Imager->new;
+    open IMDATA, "< testimg/$srcfile"
+      or die "$test_index - $desc: Cannot open testimg/$srcfile: $!";
+    binmode IMDATA;
+    my $data;
+    read(IMDATA, $data, $size) == $size
+      or die "$test_index - $desc: Could not read $size data from $srcfile";
+    close IMDATA;
+    ok($im->read(data => $data, type =>'bmp', allow_incomplete => 1),
+       "$test_index - $desc: Should read successfully");
+    # check standard tags are set
+    is($im->tags(name => 'i_format'), 'bmp',
+       "$test_index - $desc: i_format set");
+    is($im->tags(name => 'i_incomplete'), 1, 
+       "$test_index - $desc: i_incomplete set");
+    my %check_tags;
+    for my $key (keys %$tags) {
+      $check_tags{$key} = $im->tags(name => $key);
+    }
+    is_deeply(\%check_tags, $tags, "$test_index - $desc: check tags");
+    ++$test_index;
+  }
+}
+
+{ # check handling of reading images with negative height
+  # each entry is:
+  # source file, description
+  print "# check handling of negative height values\n";
+  my @tests =
+    (
+     [ "winrgb2.bmp", "1-bit, uncompressed" ],
+     [ "winrgb4.bmp", "4-bit, uncompressed" ],
+     [ "winrgb8.bmp", "8-bit, uncompressed" ],
+     [ "winrgb24.bmp", "24-bit, uncompressed" ],
+     [ "comp4.bmp", "4-bit, RLE" ],
+     [ "comp8.bmp", "8-bit, RLE" ],
+    );
+  my $test_index = 0;
+  for my $test (@tests) {
+    my ($file, $desc) = @$test;
+    open IMDATA, "< testimg/$file"
+      or die "$test_index - Cannot open $file: $!";
+    binmode IMDATA;
+    my $data = do { local $/; <IMDATA> };
+    close IMDATA;
+    my $im_orig = Imager->new;
+    $im_orig->read(data => $data)
+      or die "Cannot load original $file: ", $im_orig->errstr;
+    
+    # now negate the height
+    my $orig_height = unpack("V", substr($data, 0x16, 4));
+    my $neg_height = 0xFFFFFFFF & ~($orig_height - 1);
+    substr($data, 0x16, 4) = pack("V", $neg_height);
+
+    # and read the modified image
+    my $im = Imager->new;
+    ok($im->read(data => $data),
+       "$test_index - $desc: read negated height image")
+      or print "# ", $im->errstr, "\n";
+
+    # flip orig to match what we should get
+    $im_orig->flip(dir => 'v');
+
+    # check it out
+    is_image($im, $im_orig, "$test_index - $desc: check image");
+
+    ++$test_index;
+  }
+}
+
+{ print "# patched data read failure tests\n";
+  # like the "various invalid format" tests, these generate fail
+  # images from other images included with Imager without providing a
+  # full bmp source, saving on dist size and focusing on the changes needed
+  # to cause the failure
+  # each entry is: source file, patches, expected error, description
+  
+  my @tests =
+    (
+     # low image data offsets
+     [ 
+      "winrgb2.bmp", 
+      { 10 => "3d 00 00 00" }, 
+      "image data offset too small (61)",
+      "1-bit, small image offset"
+     ],
+     [ 
+      "winrgb4.bmp", 
+      { 10 => "75 00 00 00" }, 
+      "image data offset too small (117)",
+      "4-bit, small image offset"
+     ],
+     [ 
+      "winrgb8.bmp", 
+      { 10 => "35 04 00 00" }, 
+      "image data offset too small (1077)",
+      "8-bit, small image offset"
+     ],
+     [ 
+      "winrgb24.bmp", 
+      { 10 => "35 00 00 00" }, 
+      "image data offset too small (53)",
+      "24-bit, small image offset"
+     ],
+     # compression issues
+     [
+      "comp8.bmp",
+      { 0x436 => "97" },
+      "invalid data during decompression",
+      "8bit, RLE run beyond edge of image"
+     ],
+     [
+      # caused glibc malloc or valgrind to complain
+      "comp8.bmp",
+      { 0x436 => "94 00 00 03" },
+      "invalid data during decompression",
+      "8bit, literal run beyond edge of image"
+     ],
+     [
+      "comp4.bmp",
+      { 0x76 => "FF bb FF BB" },
+      "invalid data during decompression",
+      "4bit - RLE run beyond edge of image"
+     ],
+     [
+      "comp4.bmp",
+      { 0x76 => "94 bb 00 FF" },
+      "invalid data during decompression",
+      "4bit - literal run beyond edge of image"
+     ],
+    );
+  my $test_index = 0;
+  for my $test (@tests) {
+    my ($filename, $patches, $error, $desc) = @$test;
+
+    my $data = load_patched_file("testimg/$filename", $patches);
+    my $im = Imager->new;
+    ok(!$im->read(data => $data, type=>'bmp'),
+       "$test_index - $desc:should fail to read");
+    is($im->errstr, $error, "$test_index - $desc:check message");
+    ++$test_index;
+  }
+}
+
+{ # various write failure tests
+  # each entry is:
+  # source, limit, expected error, description
+  my @tests =
+    (
+     [ 
+      "winrgb2.bmp", 1, 
+      "cannot write bmp header: limit reached",
+      "1-bit, writing header" 
+     ],
+     [ 
+      "winrgb4.bmp", 1, 
+      "cannot write bmp header: limit reached",
+      "4-bit, writing header" 
+     ],
+     [ 
+      "winrgb8.bmp", 1, 
+      "cannot write bmp header: limit reached",
+      "8-bit, writing header" 
+     ],
+     [ 
+      "winrgb24.bmp", 1, 
+      "cannot write bmp header: limit reached",
+      "24-bit, writing header" 
+     ],
+     [ 
+      "winrgb2.bmp", 0x38, 
+      "cannot write palette entry: limit reached",
+      "1-bit, writing palette" 
+     ],
+     [ 
+      "winrgb4.bmp", 0x38, 
+      "cannot write palette entry: limit reached",
+      "4-bit, writing palette" 
+     ],
+     [ 
+      "winrgb8.bmp", 0x38, 
+      "cannot write palette entry: limit reached",
+      "8-bit, writing palette" 
+     ],
+     [ 
+      "winrgb2.bmp", 0x40, 
+      "writing 1 bit/pixel packed data: limit reached",
+      "1-bit, writing image data" 
+     ],
+     [ 
+      "winrgb4.bmp", 0x80, 
+      "writing 4 bit/pixel packed data: limit reached",
+      "4-bit, writing image data" 
+     ],
+     [ 
+      "winrgb8.bmp", 0x440, 
+      "writing 8 bit/pixel packed data: limit reached",
+      "8-bit, writing image data" 
+     ],
+     [ 
+      "winrgb24.bmp", 0x39, 
+      "writing image data: limit reached",
+      "24-bit, writing image data" 
+     ],
+    );
+  print "# write failure tests\n";
+  my $test_index = 0;
+  for my $test (@tests) {
+    my ($file, $limit, $error, $desc) = @$test;
+
+    my $im = Imager->new;
+    $im->read(file => "testimg/$file")
+      or die "Cannot read $file: ", $im->errstr;
+
+    my $io = Imager::io_new_cb(limited_write($limit), undef, undef, undef, 1);
+    $io->set_buffered(0);
+    print "# writing with limit of $limit\n";
+    ok(!$im->write(type => 'bmp', io => $io),
+       "$test_index - $desc: write should fail");
+    is($im->errstr, $error, "$test_index - $desc: check error message");
+
+    ++$test_index;
+  }
+}
+
+{
+  ok(grep($_ eq 'bmp', Imager->read_types), "check bmp in read types");
+  ok(grep($_ eq 'bmp', Imager->write_types), "check bmp in write types");
+}
+
+{
+  # RT #30075
+  # give 4/2 channel images a background color when saving to BMP
+  my $im = Imager->new(xsize=>16, ysize=>16, channels=>4);
+  $im->box(filled => 1, xmin => 8, color => '#FFE0C0');
+  $im->box(filled => 1, color => NC(0, 192, 192, 128),
+          ymin => 8, xmax => 7);
+  ok($im->write(file=>"testout/t107_alpha.bmp", type=>'bmp'),
+     "should succeed writing 4 channel image");
+  push @files, "t107_alpha.bmp";
+  my $imread = Imager->new;
+  ok($imread->read(file => 'testout/t107_alpha.bmp'), "read it back");
+  is_color3($imread->getpixel('x' => 0, 'y' => 0), 0, 0, 0, 
+           "check transparent became black");
+  is_color3($imread->getpixel('x' => 8, 'y' => 0), 255, 224, 192,
+           "check color came through");
+  is_color3($imread->getpixel('x' => 0, 'y' => 15), 0, 96, 96,
+           "check translucent came through");
+  my $data;
+  ok($im->write(data => \$data, type => 'bmp', i_background => '#FF0000'),
+     "write with red background");
+  ok($imread->read(data => $data, type => 'bmp'),
+     "read it back");
+  is_color3($imread->getpixel('x' => 0, 'y' => 0), 255, 0, 0, 
+           "check transparent became red");
+  is_color3($imread->getpixel('x' => 8, 'y' => 0), 255, 224, 192,
+           "check color came through");
+  is_color3($imread->getpixel('x' => 0, 'y' => 15), 127, 96, 96,
+           "check translucent came through");
+}
+
+{ # RT 41406
+  my $data;
+  my $im = test_image();
+  ok($im->write(data => \$data, type => 'bmp'), "write using OO");
+  my $size = unpack("V", substr($data, 34, 4));
+  is($size, 67800, "check data size");
+}
+
+{ # check close failures are handled correctly
+  my $im = test_image();
+  my $fail_close = sub {
+    Imager::i_push_error(0, "synthetic close failure");
+    return 0;
+  };
+  ok(!$im->write(type => "bmp", callback => sub { 1 },
+                closecb => $fail_close),
+     "check failing close fails");
+    like($im->errstr, qr/synthetic close failure/,
+        "check error message");
+}
+
+Imager->close_log;
+
+unless ($ENV{IMAGER_KEEP_FILES}) {
+  unlink map "testout/$_", @files;
+  unlink "testout/t107bmp.log";
+}
+
+sub write_test {
+  my ($im, $filename) = @_;
+  local *FH;
+
+  if (open FH, "> $filename") {
+    binmode FH;
+    my $IO = Imager::io_new_fd(fileno(FH));
+    unless (ok(Imager::i_writebmp_wiol($im, $IO), $filename)) {
+      print "# ",Imager->_error_as_msg(),"\n";
+    }
+    undef $IO;
+    close FH;
+  }
+  else {
+    fail("could not open $filename: $!");
+  }
+}
+
+sub read_test {
+  my ($filename, $im, %tags) = @_;
+  local *FH;
+  
+  print "# read_test: $filename\n";
+
+  $tags{i_format} = "bmp";
+
+  if (open FH, "< $filename") {
+    binmode FH;
+    my $IO = Imager::io_new_fd(fileno(FH));
+    my $im_read = Imager::i_readbmp_wiol($IO);
+    if ($im_read) {
+      my $diff = i_img_diff($im, $im_read);
+      if ($diff > $base_diff) {
+       fail("image mismatch reading $filename");
+      }
+      else {
+        my $tags_ok = 1;
+        for my $tag (keys %tags) {
+          if (my $index = Imager::i_tags_find($im_read, $tag, 0)) {
+            my ($name, $value) = Imager::i_tags_get($im_read, $index);
+            my $exp_value = $tags{$tag};
+            print "#   tag $name = '$value' - expect '$exp_value'\n";
+            if ($exp_value =~ /\d/) {
+              if ($value != $tags{$tag}) {
+                print "# tag $tag value mismatch $tags{$tag} != $value\n";
+                $tags_ok = 0;
+              }
+            }
+            else {
+              if ($value ne $tags{$tag}) {
+                print "# tag $tag value mismatch $tags{$tag} != $value\n";
+                $tags_ok = 0;
+              }
+            }
+          }
+        }
+        ok($tags_ok, "reading $filename");
+        #  for my $i (0 .. Imager::i_tags_count($im_read)-1) {
+        #    my ($name, $value) = Imager::i_tags_get($im_read, $i);
+        #    print "# tag '$name' => '$value'\n";
+        #}
+      }
+    }
+    else {
+      fail("could not read $filename: ".Imager->_error_as_msg());
+    }
+    undef $IO;
+    close FH;
+  }
+  else {
+    fail("could not open $filename: $!");
+  }
+}
+
+sub limited_write {
+  my ($limit) = @_;
+
+  return
+     sub {
+       my ($data) = @_;
+       $limit -= length $data;
+       if ($limit >= 0) {
+         print "# write of ", length $data, " bytes successful ($limit left)\n" if $debug_writes;
+         return 1;
+       }
+       else {
+         print "# write of ", length $data, " bytes failed\n";
+         Imager::i_push_error(0, "limit reached");
+         return;
+       }
+     };
+}
+
+sub load_patched_file {
+  my ($filename, $patches) = @_;
+
+  open IMDATA, "< $filename"
+    or die "Cannot open $filename: $!";
+  binmode IMDATA;
+  my $data = do { local $/; <IMDATA> };
+  for my $offset (keys %$patches) {
+    (my $hdata = $patches->{$offset}) =~ tr/ //d;
+    my $pdata = pack("H*", $hdata);
+    substr($data, $offset, length $pdata) = $pdata;
+  }
+
+  return $data;
+}
diff --git a/t/200-file/330-tga.t b/t/200-file/330-tga.t
new file mode 100644 (file)
index 0000000..cfdd664
--- /dev/null
@@ -0,0 +1,302 @@
+#!perl -w
+use Imager qw(:all);
+use strict;
+use Test::More tests=>68;
+use Imager::Test qw(is_color4 is_image test_image);
+
+-d "testout" or mkdir "testout";
+
+init_log("testout/t108tga.log",1);
+
+my $img = create_test_image();
+my $base_diff = 0;
+
+write_test($img, "testout/t108_24bit.tga", 0, 0, "");
+write_test($img, "testout/t108_24bit_rle.tga", 0, 1, "");
+write_test($img, "testout/t108_15bit.tga", 1, 1, "");
+write_test($img, "testout/t108_15bit_rle.tga", 1, 1, "");
+
+# 'webmap' is noticably faster than the default
+my $im8 = Imager::i_img_to_pal($img, { make_colors=>'webmap',
+                                      translate=>'errdiff'});
+
+write_test($im8, "testout/t108_8bit.tga", 0, 0, "");
+write_test($im8, "testout/t108_8bit_rle.tga", 0, 1, "");
+write_test($im8, "testout/t108_8_15bit.tga", 1, 0, "");
+write_test($im8, "testout/t108_8_15bit_rle.tga", 1, 1, "");
+
+
+# use a fixed palette so we get reproducible results for the compressed
+# version
+
+my @bit4 = map { NC($_) }
+  qw(605844 966600 0148b2 00f800 bf0a33 5e009e
+     2ead1b 0000f8 004b01 fd0000 0e1695 000002);
+
+my @bit1 = (NC(0, 0, 0), NC(176, 160, 144));
+
+my $im4 = Imager::i_img_to_pal($img, { colors=>\@bit4,
+                                      make_colors=>'none' });
+
+my $im1 = Imager::i_img_to_pal($img, { colors=>\@bit1,
+                                      make_colors=>'none',
+                                      translate=>'errdiff' });
+
+write_test($im4, "testout/t108_4bit.tga", 0, 1, "");
+write_test($im1, "testout/t108_1bit.tga", 0, 1, "This is a comment!");
+
+read_test("testout/t108_24bit.tga", $img);
+read_test("testout/t108_8bit.tga",  $im8);
+read_test("testout/t108_4bit.tga",  $im4);
+read_test("testout/t108_1bit.tga",  $im1);
+
+# the following might have slight differences
+
+$base_diff = i_img_diff($img, $im8) * 2;
+
+print "# base difference $base_diff\n";
+
+my $imoo = Imager->new;
+ok($imoo->read(file=>'testout/t108_24bit.tga'),
+   "OO read image")
+  or print "# ",$imoo->errstr,"\n";
+
+ok($imoo->write(file=>'testout/t108_oo.tga'),
+   "OO write image")
+  or print "# ",$imoo->errstr,"\n";
+
+my ($type) = $imoo->tags(name=>'i_format');
+is($type, 'tga', "check i_format tag");
+
+# in 0.44 and earlier, reading an image with an idstring of 128 or more
+# bytes would result in an allocation error, if the platform char type
+# was signed
+$imoo = Imager->new;
+ok($imoo->read(file=>'testimg/longid.tga'), "read long id image");
+my ($id) = $imoo->tags(name=>'tga_idstring');
+is($id, "X" x 128, "check tga_idstring tag");
+my ($bitspp) = $imoo->tags(name=>'tga_bitspp');
+is($bitspp, 24, "check tga_bitspp tag");
+my ($compressed) = $imoo->tags(name=>'compressed');
+is($compressed, 1, "check compressed tag");
+
+{ # check file limits are checked
+  my $limit_file = "testout/t108_24bit.tga";
+  ok(Imager->set_file_limits(reset=>1, width=>149), "set width limit 149");
+  my $im = Imager->new;
+  ok(!$im->read(file=>$limit_file),
+     "should fail read due to size limits");
+  print "# ",$im->errstr,"\n";
+  like($im->errstr, qr/image width/, "check message");
+  
+  ok(Imager->set_file_limits(reset=>1, height=>149), "set height limit 149");
+  ok(!$im->read(file=>$limit_file),
+     "should fail read due to size limits");
+  print "# ",$im->errstr,"\n";
+  like($im->errstr, qr/image height/, "check message");
+  
+  ok(Imager->set_file_limits(reset=>1, width=>150), "set width limit 150");
+  ok($im->read(file=>$limit_file),
+     "should succeed - just inside width limit");
+  ok(Imager->set_file_limits(reset=>1, height=>150), "set height limit 150");
+  ok($im->read(file=>$limit_file),
+     "should succeed - just inside height limit");
+  
+  # 150 x 150 x 3 channel image uses 67500 bytes
+  ok(Imager->set_file_limits(reset=>1, bytes=>67499),
+     "set bytes limit 67499");
+  ok(!$im->read(file=>$limit_file),
+     "should fail - too many bytes");
+  print "# ",$im->errstr,"\n";
+  like($im->errstr, qr/storage size/, "check error message");
+  ok(Imager->set_file_limits(reset=>1, bytes=>67500),
+     "set bytes limit 67500");
+  ok($im->read(file=>$limit_file),
+     "should succeed - just inside bytes limit");
+  Imager->set_file_limits(reset=>1);
+}
+
+{ # Issue # 18397
+  # the issue is for 4 channel images to jpeg, but 2 channel images have
+  # a similar problem on tga
+  my $im = Imager->new(xsize=>100, ysize=>100, channels => 2);
+  my $data;
+  ok(!$im->write(data => \$data, type=>'tga'),
+     "check failure of writing a 2 channel image");
+  is($im->errstr, "Cannot store 2 channel image in targa format",
+     "check the error message");
+}
+
+{
+  ok(grep($_ eq 'tga', Imager->read_types), "check tga in read types");
+  ok(grep($_ eq 'tga', Imager->write_types), "check tga in write types");
+}
+
+{ # Issue #32926
+  # a sample image was read as all transparent
+  # it had bitsperpixel = 16 and atribute channel set to 1, so it
+  # should have an alpha channel.
+  # So we'll do what the gimp does and treat a zero value as opaque.
+
+  my $im = Imager->new;
+  ok($im->read(file => 'testimg/alpha16.tga'),
+     "read 16-bit/pixel alpha image");
+  my $c1 = $im->getpixel('x' => 0, 'y' => 0);
+  is_color4($c1, 0, 0, 0, 0, "check transparent pixel");
+  my $c2 = $im->getpixel('x' => 19, 'y' => 0);
+  is_color4($c2, 255, 0, 0, 255, "check opaque pixel");
+
+  # since this has an effect on writing too, write,it, read it, check it
+  my $data;
+  ok($im->write(data => \$data, type => 'tga', wierdpack => 1),
+     "write 16-bit/pixel w/alpha");
+  my $im2 = Imager->new;
+  ok($im2->read(data => $data), "read it back");
+  is_image($im, $im2, "check they match");
+}
+
+{ # prior to the types re-work we treated the tga xsize/ysize as
+  # signed short, which is wrong
+ SKIP:
+  {
+    my $im = Imager->new(xsize => 40960, ysize => 1);
+    my $data;
+    ok($im->write(data => \$data, type => "tga"),
+       "write a wide (but not too wide) image out");
+    my $im2 = Imager->new(data => $data);
+    ok($im2, "read it back in")
+      or skip("Couldn't read the wide image", 2);
+    is($im2->getwidth, 40960, "make sure the width survived the trip");
+    is($im2->getheight, 1, "make sure the height survived the trip");
+  }
+
+ SKIP:
+  {
+    my $im = Imager->new(xsize => 1, ysize => 40960);
+    my $data;
+    ok($im->write(data => \$data, type => "tga"),
+       "write a tall (but not too tall) image out");
+    my $im2 = Imager->new(data => $data);
+    ok($im2, "read it back in")
+      or skip("Couldn't read the tall image", 2);
+    is($im2->getwidth, 1, "make sure the width survived the trip");
+    is($im2->getheight, 40960, "make sure the height survived the trip");
+  }
+}
+
+{
+  # TGA files are limited to 0xFFFF x 0xFFFF pixels
+  my $max_dim = 0xFFFF;
+  {
+    my $im = Imager->new(xsize => 1+$max_dim, ysize => 1);
+    my $data = '';
+    ok(!$im->write(data => \$data, type => "tga"),
+       "fail to write too wide an image");
+    is($im->errstr, "image too large for TGA",
+       "check error message");
+  }
+ SKIP:
+  {
+    my $im = Imager->new(xsize => $max_dim, ysize => 1);
+    $im->box(fill => { hatch => "check4x4" });
+    my $data = '';
+    ok($im->write(data => \$data, type => "tga"),
+       "write image at width limit")
+      or print "# ", $im->errstr, "\n";
+    my $im2 = Imager->new(data => $data, ftype => "tga");
+    ok($im2, "read it ok")
+      or skip("cannot load the wide image", 1);
+    is($im->getwidth, $max_dim, "check width");
+    is($im->getheight, 1, "check height");
+  }
+  {
+    my $im = Imager->new(xsize => 1, ysize => 1+$max_dim);
+    my $data = '';
+    ok(!$im->write(data => \$data, type => "tga"),
+       "fail to write too tall an image");
+    is($im->errstr, "image too large for TGA",
+       "check error message");
+  }
+ SKIP:
+  {
+    my $im = Imager->new(xsize => 1, ysize => $max_dim);
+    $im->box(fill => { hatch => "check2x2" });
+    my $data = '';
+    ok($im->write(data => \$data, type => "tga"),
+       "write image at width limit");
+    my $im2 = Imager->new(data => $data, ftype => "tga");
+    ok($im2, "read it ok")
+      or skip("cannot load the wide image", 1);
+    is($im->getwidth, 1, "check width");
+    is($im->getheight, $max_dim, "check height");
+  }
+}
+
+{ # check close failures are handled correctly
+  my $im = test_image();
+  my $fail_close = sub {
+    Imager::i_push_error(0, "synthetic close failure");
+    return 0;
+  };
+  ok(!$im->write(type => "tga", callback => sub { 1 },
+                closecb => $fail_close),
+     "check failing close fails");
+    like($im->errstr, qr/synthetic close failure/,
+        "check error message");
+}
+
+sub write_test {
+  my ($im, $filename, $wierdpack, $compress, $idstring) = @_;
+  local *FH;
+
+  if (open FH, "> $filename") {
+    binmode FH;
+    my $IO = Imager::io_new_fd(fileno(FH));
+    ok(Imager::i_writetga_wiol($im, $IO, $wierdpack, $compress, $idstring),
+       "write $filename")
+      or print "# ",Imager->_error_as_msg(),"\n";
+    undef $IO;
+    close FH;
+  } else {
+    fail("write $filename: open failed: $!");
+  }
+}
+
+
+sub read_test {
+  my ($filename, $im, %tags) = @_;
+  local *FH;
+
+  if (open FH, "< $filename") {
+    binmode FH;
+    my $IO = Imager::io_new_fd(fileno(FH));
+    my $im_read = Imager::i_readtga_wiol($IO,-1);
+    if ($im_read) {
+      my $diff = i_img_diff($im, $im_read);
+      cmp_ok($diff, '<=', $base_diff,
+            "check read image vs original");
+    } else {
+      fail("read $filename ".Imager->_error_as_msg());
+    }
+    undef $IO;
+    close FH;
+  } else {
+    fail("read $filename, open failure: $!");
+  }
+}
+
+sub create_test_image {
+
+  my $green  = i_color_new(0,255,0,255);
+  my $blue   = i_color_new(0,0,255,255);
+  my $red    = i_color_new(255,0,0,255);
+
+  my $img    = Imager::ImgRaw::new(150,150,3);
+
+  i_box_filled($img, 70, 25, 130, 125, $green);
+  i_box_filled($img, 20, 25,  80, 125, $blue);
+  i_arc($img, 75, 75, 30, 0, 361, $red);
+  i_conv($img, [0.1, 0.2, 0.4, 0.2, 0.1]);
+
+  return $img;
+}
diff --git a/t/200-file/400-basic.t b/t/200-file/400-basic.t
new file mode 100644 (file)
index 0000000..994032f
--- /dev/null
@@ -0,0 +1,367 @@
+#!perl -w
+######################### We start with some black magic to print on failure.
+
+# this used to do the check for the load of Imager, but I want to be able 
+# to count tests, which means I need to load Imager first
+# since many of the early tests already do this, we don't really need to
+
+use strict;
+use Imager;
+use IO::Seekable;
+
+my $buggy_giflib_file = "buggy_giflib.txt";
+
+-d "testout" or mkdir "testout";
+
+Imager::init("log"=>"testout/t50basicoo.log");
+
+# single image/file types
+my @types = qw( jpeg png raw pnm gif tiff bmp tga );
+
+# multiple image/file formats
+my @mtypes = qw(tiff gif);
+
+my %hsh=%Imager::formats;
+
+my $test_num = 0;
+my $count;
+for my $type (@types) {
+  $count += 31 if $hsh{$type};
+}
+for my $type (@mtypes) {
+  $count += 7 if $hsh{$type};
+}
+
+print "1..$count\n";
+
+print "# avaliable formats:\n";
+for(keys %hsh) { print "# $_\n"; }
+
+#print Dumper(\%hsh);
+
+my $img = Imager->new();
+
+my %files;
+@files{@types} = ({ file => "JPEG/testimg/209_yonge.jpg"  },
+                 { file => "testimg/test.png"  },
+                 { file => "testimg/test.raw", xsize=>150, ysize=>150, type=>'raw', interleave => 0},
+                 { file => "testimg/penguin-base.ppm"  },
+                 { file => "GIF/testimg/expected.gif"  },
+                 { file => "TIFF/testimg/comp8.tif" },
+                  { file => "testimg/winrgb24.bmp" },
+                  { file => "testimg/test.tga" }, );
+my %writeopts =
+  (
+   gif=> { make_colors=>'webmap', translate=>'closest', gifquant=>'gen',
+         gif_delay=>20 },
+  );
+
+for my $type (@types) {
+  next unless $hsh{$type};
+  print "# type $type\n";
+  my %opts = %{$files{$type}};
+  my @a = map { "$_=>${opts{$_}}" } keys %opts;
+  print "#opening Format: $type, options: @a\n";
+  ok($img->read( %opts ), "reading from file", $img);
+  #or die "failed: ",$img->errstr,"\n";
+
+  my %mopts = %opts;
+  delete $mopts{file};
+
+  # read from a file handle
+  my $fh = IO::File->new($opts{file}, "r");
+  if (ok($fh, "opening $opts{file}")) {
+    binmode $fh;
+    my $fhimg = Imager->new;
+    if (ok($fhimg->read(fh=>$fh, %mopts), "read from fh")) {
+      ok($fh->seek(0, SEEK_SET), "seek after read");
+      if (ok($fhimg->read(fh=>$fh, %mopts, type=>$type), "read from fh")) {
+       ok(Imager::i_img_diff($img->{IMG}, $fhimg->{IMG}) == 0,
+          "image comparison after fh read");
+      }
+      else {
+       skip("no image to compare");
+      }
+      ok($fh->seek(0, SEEK_SET), "seek after read");
+    }
+
+    # read from a fd
+    my $fdimg = Imager->new;
+    if (ok($fdimg->read(fd=>fileno($fh), %mopts, type=>$type), "read from fd")) {
+      ok(Imager::i_img_diff($img->{IMG}, $fdimg->{IMG}) == 0,
+         "image comparistion after fd read");
+    }
+    else {
+      skip("no image to compare");
+    }
+    ok($fh->seek(0, SEEK_SET), "seek after fd read");
+    ok($fh->close, "close fh after reads");
+  }
+  else {
+    skip("couldn't open the damn file: $!", 7);
+  }
+
+  # read from a memory buffer
+  open DATA, "< $opts{file}"
+    or die "Cannot open $opts{file}: $!";
+  binmode DATA;
+  my $data = do { local $/; <DATA> };
+  close DATA;
+  my $bimg = Imager->new;
+  
+  if (ok($bimg->read(data=>$data, %mopts, type=>$type), "read from buffer", 
+        $img)) {
+    ok(Imager::i_img_diff($img->{IMG}, $bimg->{IMG}) == 0,
+       "comparing buffer read image");
+  }
+  else {
+    skip("nothing to compare");
+  }
+  
+  # read from callbacks, both with minimum and maximum reads
+  my $buf = $data;
+  my $seekpos = 0;
+  my $reader_min = 
+    sub { 
+      my ($size, $maxread) = @_;
+      my $out = substr($buf, $seekpos, $size);
+      $seekpos += length $out;
+      $out;
+    };
+  my $reader_max = 
+    sub { 
+      my ($size, $maxread) = @_;
+      my $out = substr($buf, $seekpos, $maxread);
+      $seekpos += length $out;
+      $out;
+    };
+  my $seeker =
+    sub {
+      my ($offset, $whence) = @_;
+      #print "io_seeker($offset, $whence)\n";
+      if ($whence == SEEK_SET) {
+       $seekpos = $offset;
+      }
+      elsif ($whence == SEEK_CUR) {
+       $seekpos += $offset;
+      }
+      else { # SEEK_END
+       $seekpos = length($buf) + $offset;
+      }
+      #print "-> $seekpos\n";
+      $seekpos;
+    };
+  my $cbimg = Imager->new;
+  ok($cbimg->read(callback=>$reader_min, seekcb=>$seeker, type=>$type, %mopts),
+     "read from callback min", $cbimg);
+  ok(Imager::i_img_diff($cbimg->{IMG}, $img->{IMG}) == 0,
+     "comparing mincb image");
+  $seekpos = 0;
+  ok($cbimg->read(callback=>$reader_max, seekcb=>$seeker, type=>$type, %mopts),
+     "read from callback max", $cbimg);
+  ok(Imager::i_img_diff($cbimg->{IMG}, $img->{IMG}) == 0,
+     "comparing maxcb image");
+}
+
+for my $type (@types) {
+  next unless $hsh{$type};
+
+  print "# write tests for $type\n";
+  # test writes
+  next unless $hsh{$type};
+  my $file = "testout/t50out.$type";
+  my $wimg = Imager->new;
+  # if this doesn't work, we're so screwed up anyway
+  
+  ok($wimg->read(file=>"testimg/penguin-base.ppm"),
+     "cannot read base file", $wimg);
+
+  # first to a file
+  print "# writing $type to a file\n";
+  my %extraopts;
+  %extraopts = %{$writeopts{$type}} if $writeopts{$type};
+  ok($wimg->write(file=>$file, %extraopts),
+     "writing $type to a file $file", $wimg);
+
+  print "# writing $type to a FH\n";
+  # to a FH
+  my $fh = IO::File->new($file, "w+")
+    or die "Could not create $file: $!";
+  binmode $fh;
+  ok($wimg->write(fh=>$fh, %extraopts, type=>$type),
+     "writing $type to a FH", $wimg);
+  ok($fh->seek(0, SEEK_END) > 0,
+     "seek after writing $type to a FH");
+  ok(print($fh "SUFFIX\n"),
+     "write to FH after writing $type");
+  ok($fh->close, "closing FH after writing $type");
+
+  if (ok(open(DATA, "< $file"), "opening data source")) {
+    binmode DATA;
+    my $data = do { local $/; <DATA> };
+    close DATA;
+
+    # writing to a buffer
+    print "# writing $type to a buffer\n";
+    my $buf = '';
+    ok($wimg->write(data=>\$buf, %extraopts, type=>$type),
+       "writing $type to a buffer", $wimg);
+    $buf .= "SUFFIX\n";
+    open DATA, "> testout/t50_buf.$type"
+      or die "Cannot create $type buffer file: $!";
+    binmode DATA;
+    print DATA $buf;
+    close DATA;
+    ok($data eq $buf, "comparing file data to buffer");
+
+    $buf = '';
+    my $seekpos = 0;
+    my $did_close;
+    my $writer = 
+      sub {
+       my ($what) = @_;
+       if ($seekpos > length $buf) {
+         $buf .= "\0" x ($seekpos - length $buf);
+       }
+       substr($buf, $seekpos, length $what) = $what;
+       $seekpos += length $what;
+       $did_close = 0; # the close must be last
+       1;
+      };
+    my $reader_min = 
+      sub { 
+       my ($size, $maxread) = @_;
+       my $out = substr($buf, $seekpos, $size);
+       $seekpos += length $out;
+       $out;
+      };
+    my $reader_max = 
+      sub { 
+       my ($size, $maxread) = @_;
+       my $out = substr($buf, $seekpos, $maxread);
+       $seekpos += length $out;
+       $out;
+      };
+    use IO::Seekable;
+    my $seeker =
+      sub {
+       my ($offset, $whence) = @_;
+       #print "io_seeker($offset, $whence)\n";
+       if ($whence == SEEK_SET) {
+         $seekpos = $offset;
+       }
+       elsif ($whence == SEEK_CUR) {
+         $seekpos += $offset;
+       }
+       else { # SEEK_END
+         $seekpos = length($buf) + $offset;
+       }
+       #print "-> $seekpos\n";
+       $seekpos;
+      };
+
+    my $closer = sub { ++$did_close; };
+
+    print "# writing $type via callbacks (mb=1)\n";
+    ok($wimg->write(writecb=>$writer, seekcb=>$seeker, closecb=>$closer,
+                   readcb=>$reader_min,
+                   %extraopts, type=>$type, maxbuffer=>1),
+       "writing $type to callback (mb=1)", $wimg);
+
+    ok($did_close, "checking closecb called");
+    $buf .= "SUFFIX\n";
+    ok($data eq $buf, "comparing callback output to file data");
+    print "# writing $type via callbacks (no mb)\n";
+    $buf = '';
+    $did_close = 0;
+    $seekpos = 0;
+    # we don't use the closecb here - used to make sure we don't get 
+    # a warning/error on an attempt to call an undef close sub
+    ok($wimg->write(writecb=>$writer, seekcb=>$seeker, readcb=>$reader_min,
+                   %extraopts, type=>$type),
+       "writing $type to callback (no mb)", $wimg);
+    $buf .= "SUFFIX\n";
+    ok($data eq $buf, "comparing callback output to file data");
+  }
+  else {
+    skip("couldn't open data source", 7);
+  }
+}
+
+my $img2 =  $img->crop(width=>50, height=>50);
+$img2 -> write(file=> 'testout/t50.ppm', type=>'pnm');
+
+undef($img);
+
+# multi image/file tests
+print "# multi-image write tests\n";
+for my $type (@mtypes) {
+  next unless $hsh{$type};
+  print "# $type\n";
+
+  my $file = "testout/t50out.$type";
+  my $wimg = Imager->new;
+
+  # if this doesn't work, we're so screwed up anyway
+  ok($wimg->read(file=>"testout/t50out.$type"),
+     "reading base file", $wimg);
+
+  ok(my $wimg2 = $wimg->copy, "copying base image", $wimg);
+  ok($wimg2->flip(dir=>'h'), "flipping base image", $wimg2);
+
+  my @out = ($wimg, $wimg2);
+  my %extraopts;
+  %extraopts = %{$writeopts{$type}} if $writeopts{$type};
+  ok(Imager->write_multi({ file=>"testout/t50_multi.$type", %extraopts },
+                         @out),
+     "writing multiple to a file", "Imager");
+
+  # make sure we get the same back
+  my @images = Imager->read_multi(file=>"testout/t50_multi.$type");
+  if (ok(@images == @out, "checking read image count")) {
+    for my $i (0 .. $#out) {
+      my $diff = Imager::i_img_diff($out[$i]{IMG}, $images[$i]{IMG});
+      print "# diff $diff\n";
+      ok($diff == 0, "comparing image $i");
+    }
+  }
+  else {
+    skip("wrong number of images read", 2);
+  }
+}
+
+
+Imager::malloc_state();
+
+#print "ok 2\n";
+
+sub ok {
+  my ($ok, $msg, $img, $why, $skipcount) = @_;
+
+  ++$test_num;
+  if ($ok) {
+    print "ok $test_num # $msg\n";
+    Imager::i_log_entry("ok $test_num # $msg\n", 0);
+  }
+  else {
+    my $err;
+    $err = $img->errstr if $img;
+    # VMS (if we ever support it) wants the whole line in one print
+    my $line = "not ok $test_num # line ".(caller)[2].": $msg";
+    $line .= ": $err" if $err;
+    print $line, "\n";
+    Imager::i_log_entry($line."\n", 0);
+  }
+  skip($why, $skipcount) if defined $why;
+  $ok;
+}
+
+sub skip {
+  my ($why, $skipcount) = @_;
+
+  $skipcount ||= 1;
+  for (1.. $skipcount) {
+    ++$test_num;
+    print "ok $test_num # skipped $why\n";
+  }
+}
diff --git a/t/250-draw/010-draw.t b/t/250-draw/010-draw.t
new file mode 100644 (file)
index 0000000..a1f7f2a
--- /dev/null
@@ -0,0 +1,353 @@
+#!perl -w
+use strict;
+use Test::More tests => 256;
+use Imager ':all';
+use Imager::Test qw(is_color3 is_image);
+use constant PI => 3.14159265358979;
+
+-d "testout" or mkdir "testout";
+
+init_log("testout/t21draw.log",1);
+
+my $redobj = NC(255, 0, 0);
+my $red = 'FF0000';
+my $greenobj = NC(0, 255, 0);
+my $green = [ 0, 255, 0 ];
+my $blueobj = NC(0, 0, 255);
+my $blue = { hue=>240, saturation=>1, value=>1 };
+my $white = '#FFFFFF';
+
+{
+  my $img = Imager->new(xsize=>100, ysize=>500);
+
+  ok($img->box(color=>$blueobj, xmin=>10, ymin=>10, xmax=>48, ymax=>18),
+     "box with color obj");
+  ok($img->box(color=>$blue, xmin=>10, ymin=>20, xmax=>48, ymax=>28),
+     "box with color");
+  ok($img->box(color=>$redobj, xmin=>10, ymin=>30, xmax=>28, ymax=>48, filled=>1),
+     "filled box with color obj");
+  ok($img->box(color=>$red, xmin=>30, ymin=>30, xmax=>48, ymax=>48, filled=>1),
+     "filled box with color");
+
+  ok($img->arc('x'=>75, 'y'=>25, r=>24, color=>$redobj),
+     "filled arc with colorobj");
+
+  ok($img->arc('x'=>75, 'y'=>25, r=>20, color=>$green),
+     "filled arc with colorobj");
+  ok($img->arc('x'=>75, 'y'=>25, r=>18, color=>$white, d1=>325, d2=>225),
+     "filled arc with color");
+
+  ok($img->arc('x'=>75, 'y'=>25, r=>18, color=>$blue, d1=>225, d2=>325),
+     "filled arc with color");
+  ok($img->arc('x'=>75, 'y'=>25, r=>15, color=>$green, aa=>1),
+     "filled arc with color");
+
+  ok($img->line(color=>$blueobj, x1=>5, y1=>55, x2=>35, y2=>95),
+     "line with colorobj");
+
+  # FIXME - neither the start nor end-point is set for a non-aa line
+  my $c = Imager::i_get_pixel($img->{IMG}, 5, 55);
+  ok(color_cmp($c, $blueobj) == 0, "# TODO start point not set");
+
+  ok($img->line(color=>$red, x1=>10, y1=>55, x2=>40, y2=>95, aa=>1),
+     "aa line with color");
+  ok($img->line(color=>$green, x1=>15, y1=>55, x2=>45, y2=>95, antialias=>1),
+     "antialias line with color");
+
+  ok($img->polyline(points=>[ [ 55, 55 ], [ 90, 60 ], [ 95, 95] ],
+                   color=>$redobj),
+     "polyline points with color obj");
+  ok($img->polyline('x'=>[ 55, 85, 90 ], 'y'=>[60, 65, 95], color=>$green, aa=>1),
+     "polyline xy with color aa");
+  ok($img->polyline('x'=>[ 55, 80, 85 ], 'y'=>[65, 70, 95], color=>$green, 
+                   antialias=>1),
+     "polyline xy with color antialias");
+
+  ok($img->setpixel('x'=>[35, 37, 39], 'y'=>[55, 57, 59], color=>$red),
+     "set array of pixels");
+  ok($img->setpixel('x'=>39, 'y'=>55, color=>$green),
+     "set single pixel");
+  use Imager::Color::Float;
+  my $flred = Imager::Color::Float->new(1, 0, 0, 0);
+  my $flgreen = Imager::Color::Float->new(0, 1, 0, 0);
+  ok($img->setpixel('x'=>[41, 43, 45], 'y'=>[55, 57, 59], color=>$flred),
+     "set array of float pixels");
+  ok($img->setpixel('x'=>45, 'y'=>55, color=>$flgreen),
+     "set single float pixel");
+  my @gp = $img->getpixel('x'=>[41, 43, 45], 'y'=>[55, 57, 59]);
+  ok(grep($_->isa('Imager::Color'), @gp) == 3, "check getpixel result type");
+  ok(grep(color_cmp($_, NC(255, 0, 0)) == 0, @gp) == 3, 
+     "check getpixel result colors");
+  my $gp = $img->getpixel('x'=>45, 'y'=>55);
+  ok($gp->isa('Imager::Color'), "check scalar getpixel type");
+  ok(color_cmp($gp, NC(0, 255, 0)) == 0, "check scalar getpixel color");
+  @gp = $img->getpixel('x'=>[35, 37, 39], 'y'=>[55, 57, 59], type=>'float');
+  ok(grep($_->isa('Imager::Color::Float'), @gp) == 3, 
+     "check getpixel float result type");
+  ok(grep(color_cmp($_, $flred) == 0, @gp) == 3,
+     "check getpixel float result type");
+  $gp = $img->getpixel('x'=>39, 'y'=>55, type=>'float');
+  ok($gp->isa('Imager::Color::Float'), "check scalar float getpixel type");
+  ok(color_cmp($gp, $flgreen) == 0, "check scalar float getpixel color");
+
+  # more complete arc tests
+  ok($img->arc(x=>25, 'y'=>125, r=>20, d1=>315, d2=>45, color=>$greenobj),
+     "color arc through angle 0");
+  # use diff combine here to make sure double writing is noticable
+  ok($img->arc(x=>75, 'y'=>125, r=>20, d1=>315, d2=>45,
+              fill => { solid=>$blueobj, combine => 'diff' }),
+     "fill arc through angle 0");
+  ok($img->arc(x=>25, 'y'=>175, r=>20, d1=>315, d2=>225, color=>$redobj),
+     "concave color arc");
+  angle_marker($img, 25, 175, 23, 315, 225);
+  ok($img->arc(x=>75, 'y'=>175, r=>20, d1=>315, d2=>225,
+              fill => { solid=>$greenobj, combine=>'diff' }),
+     "concave fill arc");
+  angle_marker($img, 75, 175, 23, 315, 225);
+  ok($img->arc(x=>25, y=>225, r=>20, d1=>135, d2=>45, color=>$redobj),
+     "another concave color arc");
+  angle_marker($img, 25, 225, 23, 45, 135);
+  ok($img->arc(x=>75, y=>225, r=>20, d1=>135, d2=>45, 
+              fill => { solid=>$blueobj, combine=>'diff' }),
+     "another concave fillarc");
+  angle_marker($img, 75, 225, 23, 45, 135);
+  ok($img->arc(x=>25, y=>275, r=>20, d1=>135, d2=>45, color=>$redobj, aa=>1),
+     "concave color arc aa");
+  ok($img->arc(x=>75, y=>275, r=>20, d1=>135, d2=>45, 
+              fill => { solid=>$blueobj, combine=>'diff' }, aa=>1),
+     "concave fill arc aa");
+
+  ok($img->circle(x=>25, y=>325, r=>20, color=>$redobj),
+     "color circle no aa");
+  ok($img->circle(x=>75, y=>325, r=>20, color=>$redobj, aa=>1),
+     "color circle aa");
+  ok($img->circle(x=>25, 'y'=>375, r=>20, 
+                 fill => { hatch=>'stipple', fg=>$blueobj, bg=>$redobj }),
+     "fill circle no aa");
+  ok($img->circle(x=>75, 'y'=>375, r=>20, aa=>1,
+                 fill => { hatch=>'stipple', fg=>$blueobj, bg=>$redobj }),
+     "fill circle aa");
+
+  ok($img->arc(x=>50, y=>450, r=>45, d1=>135, d2=>45, 
+              fill => { solid=>$blueobj, combine=>'diff' }),
+     "another concave fillarc");
+  angle_marker($img, 50, 450, 47, 45, 135);
+
+  ok($img->write(file=>'testout/t21draw.ppm'),
+     "saving output");
+}
+
+{
+  my $im = Imager->new(xsize => 400, ysize => 400);
+  ok($im->arc(x => 200, y => 202, r => 10, filled => 0),
+     "draw circle outline");
+  is_color3($im->getpixel(x => 200, y => 202), 0, 0, 0,
+           "check center not filled");
+  ok($im->arc(x => 198, y => 200, r => 13, filled => 0, color => "#f88"),
+     "draw circle outline");
+  is_color3($im->getpixel(x => 198, y => 200), 0, 0, 0,
+           "check center not filled");
+  ok($im->arc(x => 200, y => 200, r => 24, filled => 0, color => "#0ff"),
+     "draw circle outline");
+  my $r = 40;
+  while ($r < 180) {
+    ok($im->arc(x => 200, y => 200, r => $r, filled => 0, color => "#ff0"),
+       "draw circle outline r $r");
+    $r += 15;
+  }
+  ok($im->write(file => "testout/t21circout.ppm"),
+     "save arc outline");
+}
+
+{
+  my $im = Imager->new(xsize => 400, ysize => 400);
+  {
+    my $lc = Imager::Color->new(32, 32, 32);
+    my $an = 0;
+    while ($an < 360) {
+      my $an_r = $an * PI / 180;
+      my $ca = cos($an_r);
+      my $sa = sin($an_r);
+      $im->line(aa => 1, color => $lc,
+               x1 => 198 + 5 * $ca, y1 => 202 + 5 * $sa,
+               x2 => 198 + 190 * $ca, y2 => 202 + 190 * $sa);
+      $an += 5;
+    }
+  }
+  my $d1 = 0;
+  my $r = 20;
+  while ($d1 < 350) {
+    ok($im->arc(x => 198, y => 202, r => $r, d1 => $d1, d2 => $d1+300, filled => 0),
+       "draw arc outline r$r d1$d1 len 300");
+    ok($im->arc(x => 198, y => 202, r => $r+3, d1 => $d1, d2 => $d1+40, filled => 0, color => '#FFFF00'),
+       "draw arc outline r$r d1$d1 len 40");
+    $d1 += 15;
+    $r += 6;
+  }
+  is_color3($im->getpixel(x => 198, y => 202), 0, 0, 0,
+           "check center not filled");
+  ok($im->write(file => "testout/t21arcout.ppm"),
+     "save arc outline");
+}
+
+{
+  my $im = Imager->new(xsize => 400, ysize => 400);
+  ok($im->arc(x => 197, y => 201, r => 10, filled => 0, aa => 1, color => 'white'),
+     "draw circle outline");
+  is_color3($im->getpixel(x => 197, y => 201), 0, 0, 0,
+           "check center not filled");
+  ok($im->arc(x => 197, y => 205, r => 13, filled => 0, color => "#f88", aa => 1),
+     "draw circle outline");
+  is_color3($im->getpixel(x => 197, y => 205), 0, 0, 0,
+           "check center not filled");
+  ok($im->arc(x => 190, y => 215, r => 24, filled => 0, color => [0,0, 255, 128], aa => 1),
+     "draw circle outline");
+  my $r = 40;
+  while ($r < 190) {
+    ok($im->arc(x => 197, y => 201, r => $r, filled => 0, aa => 1, color => '#ff0'), "draw aa circle rad $r");
+    $r += 7;
+  }
+  ok($im->write(file => "testout/t21aacircout.ppm"),
+     "save arc outline");
+}
+
+{
+  my $im = Imager->new(xsize => 400, ysize => 400);
+  {
+    my $lc = Imager::Color->new(32, 32, 32);
+    my $an = 0;
+    while ($an < 360) {
+      my $an_r = $an * PI / 180;
+      my $ca = cos($an_r);
+      my $sa = sin($an_r);
+      $im->line(aa => 1, color => $lc,
+               x1 => 198 + 5 * $ca, y1 => 202 + 5 * $sa,
+               x2 => 198 + 190 * $ca, y2 => 202 + 190 * $sa);
+      $an += 5;
+    }
+  }
+  my $d1 = 0;
+  my $r = 20;
+  while ($d1 < 350) {
+    ok($im->arc(x => 198, y => 202, r => $r, d1 => $d1, d2 => $d1+300, filled => 0, aa => 1),
+       "draw aa arc outline r$r d1$d1 len 300");
+    ok($im->arc(x => 198, y => 202, r => $r+3, d1 => $d1, d2 => $d1+40, filled => 0, color => '#FFFF00', aa => 1),
+       "draw aa arc outline r$r d1$d1 len 40");
+    $d1 += 15;
+    $r += 6;
+  }
+  is_color3($im->getpixel(x => 198, y => 202), 0, 0, 0,
+           "check center not filled");
+  ok($im->write(file => "testout/t21aaarcout.ppm"),
+     "save arc outline");
+}
+
+{
+  my $im = Imager->new(xsize => 400, ysize => 400);
+
+  my $an = 0;
+  my $step = 15;
+  while ($an <= 360-$step) {
+    my $cx = int(200 + 20 * cos(($an+$step/2) * PI / 180));
+    my $cy = int(200 + 20 * sin(($an+$step/2) * PI / 180));
+
+    ok($im->arc(x => $cx, y => $cy, aa => 1, color => "#fff", 
+               d1 => $an, d2 => $an+$step, filled => 0, r => 170),
+      "angle starting from $an");
+    ok($im->arc(x => $cx+0.5, y => $cy+0.5, aa => 1, color => "#ff0", 
+               d1 => $an, d2 => $an+$step, r => 168),
+      "filled angle starting from $an");
+
+    $an += $step;
+  }
+  ok($im->write(file => "testout/t21aaarcs.ppm"),
+     "save arc outline");
+}
+
+{
+  # we document that drawing from d1 to d2 where d2 > d1 will draw an
+  # arc going through 360 degrees, test that
+  my $im = Imager->new(xsize => 200, ysize => 200);
+  ok($im->arc(x => 100, y => 100, aa => 0, filled => 0, color => '#fff',
+             d1 => 270, d2 => 90, r => 90), "draw non-aa arc through 0");
+  ok($im->arc(x => 100, y => 100, aa => 1, filled => 0, color => '#fff',
+             d1 => 270, d2 => 90, r => 80), "draw aa arc through 0");
+  ok($im->write(file => "testout/t21arc0.ppm"),
+     "save arc through 0");
+}
+
+{
+  # test drawing color defaults
+  {
+    my $im = Imager->new(xsize => 10, ysize => 10);
+    ok($im->box(), "default outline the image"); # should outline the image
+    is_color3($im->getpixel(x => 0, y => 0), 255, 255, 255,
+             "check outline default color TL");
+    is_color3($im->getpixel(x => 9, y => 5), 255, 255, 255,
+             "check outline default color MR");
+  }
+
+  {
+    my $im = Imager->new(xsize => 10, ysize => 10);
+    ok($im->box(filled => 1), "default fill the image"); # should fill the image
+    is_color3($im->getpixel(x => 0, y => 0), 255, 255, 255,
+             "check fill default color TL");
+    is_color3($im->getpixel(x => 5, y => 5), 255, 255, 255,
+             "check fill default color MM");
+  }
+}
+
+{
+  my $empty = Imager->new;
+  ok(!$empty->box(), "can't draw box to empty image");
+  is($empty->errstr, "box: empty input image", "check error message");
+  ok(!$empty->arc(), "can't draw arc to empty image");
+  is($empty->errstr, "arc: empty input image", "check error message");
+  ok(!$empty->line(x1 => 0, y1 => 0, x2 => 10, y2 => 0),
+     "can't draw line to empty image");
+  is($empty->errstr, "line: empty input image", "check error message");
+  ok(!$empty->polyline(points => [ [ 0, 0 ], [ 10, 0 ] ]),
+     "can't draw polyline to empty image");
+  is($empty->errstr, "polyline: empty input image", "check error message");
+  ok(!$empty->polygon(points => [ [ 0, 0 ], [ 10, 0 ], [ 0, 10 ] ]),
+     "can't draw polygon to empty image");
+  is($empty->errstr, "polygon: empty input image", "check error message");
+  ok(!$empty->flood_fill(x => 0, y => 0), "can't flood fill to empty image");
+  is($empty->errstr, "flood_fill: empty input image", "check error message");
+}
+
+
+malloc_state();
+
+unless ($ENV{IMAGER_KEEP_FILES}) {
+  unlink "testout/t21draw.ppm";
+  unlink "testout/t21circout.ppm";
+  unlink "testout/t21aacircout.ppm";
+  unlink "testout/t21arcout.ppm";
+  unlink "testout/t21aaarcout.ppm";
+  unlink "testout/t21aaarcs.ppm";
+  unlink "testout/t21arc0.ppm";
+}
+
+sub color_cmp {
+  my ($l, $r) = @_;
+  my @l = $l->rgba;
+  my @r = $r->rgba;
+  # print "# (",join(",", @l[0..2]),") <=> (",join(",", @r[0..2]),")\n";
+  return $l[0] <=> $r[0]
+    || $l[1] <=> $r[1]
+      || $l[2] <=> $r[2];
+}
+
+sub angle_marker {
+  my ($img, $x, $y, $radius, @angles) = @_;
+
+  for my $angle (@angles) {
+    my $x1 = int($x + $radius * cos($angle * PI / 180) + 0.5);
+    my $y1 = int($y + $radius * sin($angle * PI / 180) + 0.5);
+    my $x2 = int($x + (5+$radius) * cos($angle * PI / 180) + 0.5);
+    my $y2 = int($y + (5+$radius) * sin($angle * PI / 180) + 0.5);
+    
+    $img->line(x1=>$x1, y1=>$y1, x2=>$x2, y2=>$y2, color=>'#FFF');
+  }
+}
diff --git a/t/250-draw/020-flood.t b/t/250-draw/020-flood.t
new file mode 100644 (file)
index 0000000..767cbab
--- /dev/null
@@ -0,0 +1,69 @@
+#!perl -w
+use strict;
+use Test::More tests => 15;
+use Imager;
+use Imager::Test qw(is_image);
+
+-d "testout" or mkdir "testout";
+
+{ # flood_fill wouldn't fill to the right if the area was just a
+  # single scan-line
+  my $im = Imager->new(xsize => 5, ysize => 3);
+  ok($im, "make flood_fill test image");
+  ok($im->line(x1 => 0, y1 => 1, x2 => 4, y2 => 1, color => "white"),
+     "create fill area");
+  ok($im->flood_fill(x => 3, y => 1, color => "blue"),
+     "fill it");
+  my $cmp = Imager->new(xsize => 5, ysize => 3);
+  ok($cmp, "make test image");
+  ok($cmp->line(x1 => 0, y1 => 1, x2 => 4, y2 => 1, color => "blue"),
+     "synthezied filled area");
+  is_image($im, $cmp, "flood_fill filled horizontal line");
+}
+
+SKIP:
+{ # flood_fill won't fill entire line below if line above is shorter
+  my $im = Imager->new(file => "testimg/filltest.ppm");
+  ok($im, "Load test image")
+    or skip("Couldn't load test image: " . Imager->errstr, 3);
+
+  # fill from first bad place
+  my $fill1 = $im->copy;
+  ok($fill1->flood_fill(x => 8, y => 2, color => "#000000"),
+     "fill from a top most spot");
+  my $cmp = Imager->new(xsize => $im->getwidth, ysize => $im->getheight);
+  is_image($fill1, $cmp, "check it filled the lot");
+  ok($fill1->write(file => "testout/t22fill1.ppm"), "save");
+
+  # second bad place
+  my $fill2 = $im->copy;
+  ok($fill2->flood_fill(x => 17, y => 3, color => "#000000"),
+     "fill from not quite top most spot");
+  is_image($fill2, $cmp, "check it filled the lot");
+  ok($fill2->write(file => "testout/t22fill2.ppm"), "save");
+}
+
+{ # verticals
+  my $im = vimage("FFFFFF");
+  my $cmp = vimage("FF0000");
+
+  ok($im->flood_fill(x => 4, y=> 8, color => "FF0000"),
+     "fill at bottom of vertical well");
+  is_image($im, $cmp, "check the result");
+}
+
+unless ($ENV{IMAGER_KEEP_FILES}) {
+  unlink "testout/t22fill1.ppm";
+  unlink "testout/t22fill2.ppm";
+}
+
+# make a vertical test image
+sub vimage {
+  my $c = shift;
+
+  my $im = Imager->new(xsize => 10, ysize => 10);
+  $im->line(x1 => 1, y1 => 1, x2 => 8, y2 => 1, color => $c);
+  $im->line(x1 => 4, y1 => 2, x2 => 4, y2 => 8, color => $c);
+
+  return $im;
+}
diff --git a/t/250-draw/030-paste.t b/t/250-draw/030-paste.t
new file mode 100644 (file)
index 0000000..8599823
--- /dev/null
@@ -0,0 +1,315 @@
+#!perl -w
+use strict;
+use Test::More tests => 60;
+
+use Imager;
+use Imager::Test qw(is_image);
+
+#$Imager::DEBUG=1;
+
+-d "testout" or mkdir "testout";
+
+Imager::init('log'=>'testout/t66paste.log');
+
+# the original smoke tests
+my $img=Imager->new() || die "unable to create image object\n";
+
+ok($img->open(file=>'testimg/scale.ppm',type=>'pnm'), "load test img");
+
+my $nimg=Imager->new() or die "Unable to create image object\n";
+ok($nimg->open(file=>'testimg/scale.ppm',type=>'pnm'), "load test img again");
+
+ok($img->paste(img=>$nimg, top=>30, left=>30), "paste it")
+  or print "# ", $img->errstr, "\n";;
+
+ok($img->write(type=>'pnm',file=>'testout/t66.ppm'), "save it")
+  or print "# ", $img->errstr, "\n";
+
+{
+  my $empty = Imager->new;
+  ok(!$empty->paste(src => $nimg), "paste into empty image");
+  is($empty->errstr, "paste: empty input image",
+     "check error message");
+
+  ok(!$img->paste(src => $empty), "paste from empty image");
+  is($img->errstr, "paste: empty input image (for src)",
+     "check error message");
+
+  ok(!$img->paste(), "no source image");
+  is($img->errstr, "no source image");
+}
+
+# more stringent tests
+{
+  my $src = Imager->new(xsize => 100, ysize => 110);
+  $src->box(filled=>1, color=>'FF0000');
+
+  $src->box(filled=>1, color=>'0000FF', xmin => 20, ymin=>20,
+            xmax=>79, ymax=>79);
+
+  my $targ = Imager->new(xsize => 100, ysize => 110);
+  $targ->box(filled=>1, color =>'00FFFF');
+  $targ->box(filled=>1, color=>'00FF00', xmin=>20, ymin=>20, xmax=>79,
+             ymax=>79);
+  my $work = $targ->copy;
+  ok($work->paste(src=>$src, left => 15, top => 10), "paste whole image");
+  # build comparison image
+  my $cmp = $targ->copy;
+  $cmp->box(filled=>1, xmin=>15, ymin => 10, color=>'FF0000');
+  $cmp->box(filled=>1, xmin=>35, ymin => 30, xmax=>94, ymax=>89, 
+            color=>'0000FF');
+
+  is(Imager::i_img_diff($work->{IMG}, $cmp->{IMG}), 0,
+     "compare pasted and expected");
+
+  $work = $targ->copy;
+  ok($work->paste(src=>$src, left=>2, top=>7, src_minx => 10, src_miny => 15),
+     "paste from inside src");
+  $cmp = $targ->copy;
+  $cmp->box(filled=>1, xmin=>2, ymin=>7, xmax=>91, ymax=>101, color=>'FF0000');
+  $cmp->box(filled=>1, xmin=>12, ymin=>12, xmax=>71, ymax=>71, 
+            color=>'0000FF');
+  is(Imager::i_img_diff($work->{IMG}, $cmp->{IMG}), 0,
+     "compare pasted and expected");
+
+  # paste part source
+  $work = $targ->copy;
+  ok($work->paste(src=>$src, left=>15, top=>20, 
+                  src_minx=>10, src_miny=>15, src_maxx=>80, src_maxy =>70),
+     "paste src cropped all sides");
+  $cmp = $targ->copy;
+  $cmp->box(filled=>1, xmin=>15, ymin=>20, xmax=>84, ymax=>74, 
+            color=>'FF0000');
+  $cmp->box(filled=>1, xmin=>25, ymin=>25, xmax=>84, ymax=>74,
+            color=>'0000FF');
+  is(Imager::i_img_diff($work->{IMG}, $cmp->{IMG}), 0,
+     "compare pasted and expected");
+
+  # go by width instead
+  $work = $targ->copy;
+  ok($work->paste(src=>$src, left=>15, top=>20,
+                  src_minx=>10, src_miny => 15, width => 70, height => 55),
+     "same but specify width/height instead");
+  is(Imager::i_img_diff($work->{IMG}, $cmp->{IMG}), 0,
+     "compare pasted and expected");
+
+  # use src_coords
+  $work = $targ->copy;
+  ok($work->paste(src=>$src, left => 15, top => 20,
+                  src_coords => [ 10, 15, 80, 70 ]),
+     "using src_coords");
+  is(Imager::i_img_diff($work->{IMG}, $cmp->{IMG}), 0,
+     "compare pasted and expected");
+
+  {
+    # Issue #18712
+    # supplying just src_maxx would set the internal maxy to undef
+    # supplying just src_maxy would be ignored
+    # src_maxy (or it's derived value) was being bounds checked against 
+    # the image width instead of the image height
+    $work = $targ->copy;
+    my @warns;
+    local $SIG{__WARN__} = sub { push @warns, "@_"; print "# @_"; };
+    
+    ok($work->paste(src=>$src, left => 15, top => 20,
+                   src_maxx => 50),
+       "paste with just src_maxx");
+    ok(!@warns, "shouldn't warn");
+    my $cmp = $targ->copy;
+    $cmp->box(filled=>1, color => 'FF0000', xmin => 15, ymin => 20,
+             xmax => 64, ymax => 109);
+    $cmp->box(filled=>1, color => '0000FF', xmin => 35, ymin => 40,
+             xmax => 64, ymax => 99);
+    is(Imager::i_img_diff($work->{IMG}, $cmp->{IMG}), 0,
+       "check correctly pasted");
+
+    $work = $targ->copy;
+    @warns = ();
+    ok($work->paste(src=>$src, left=>15, top=>20,
+                   src_maxy => 60),
+       "paste with just src_maxy");
+    ok(!@warns, "shouldn't warn");
+    $cmp = $targ->copy;
+    $cmp->box(filled => 1, color => 'FF0000', xmin => 15, ymin => 20,
+             xmax => 99, ymax => 79);
+    $cmp->box(filled => 1, color => '0000FF', xmin => 35, ymin => 40,
+             xmax => 94, ymax => 79);
+    is(Imager::i_img_diff($work->{IMG}, $cmp->{IMG}), 0,
+       "check pasted correctly");
+
+    $work = $targ->copy;
+    @warns = ();
+    ok($work->paste(src=>$src, left=>15, top=>20,
+                   src_miny => 20, src_maxy => 105),
+       "paste with src_maxy > source width");
+
+    $cmp = $targ->copy;
+    $cmp->box(filled => 1, color => 'FF0000', xmin => 15, ymin => 20,
+             ymax => 104);
+    $cmp->box(filled => 1, color => '0000FF', xmin => 35, ymin => 20,
+             xmax => 94, ymax => 79);
+    is(Imager::i_img_diff($work->{IMG}, $cmp->{IMG}), 0,
+       "check pasted correctly");
+  }
+}
+
+{ # https://rt.cpan.org/Ticket/Display.html?id=30908
+  # we now adapt the source channels to the target
+  # check each combination works as expected
+
+  # various source images
+  my $src1 = Imager->new(xsize => 50, ysize => 50, channels => 1);
+  my $g_grey_full = Imager::Color->new(128, 255, 0, 0);
+  my $g_white_50 = Imager::Color->new(255, 128, 0, 0);
+  $src1->box(filled => 1, xmax => 24, color => $g_grey_full);
+
+  my $src2 = Imager->new(xsize => 50, ysize => 50, channels => 2);
+  $src2->box(filled => 1, xmax => 24, color => $g_grey_full);
+  $src2->box(filled => 1, xmin => 25, color => $g_white_50);
+
+  my $c_red_full = Imager::Color->new(255, 0, 0);
+  my $c_blue_full = Imager::Color->new(0, 0, 255);
+  my $src3 = Imager->new(xsize => 50, ysize => 50, channels => 3);
+  $src3->box(filled => 1, xmax => 24, color => $c_red_full);
+  $src3->box(filled => 1, xmin => 25, color => $c_blue_full);
+
+  my $c_green_50 = Imager::Color->new(0, 255, 0, 127);
+  my $src4 = Imager->new(xsize => 50, ysize => 50, channels => 4);
+  $src4->box(filled => 1, xmax => 24, color => $c_blue_full);
+  $src4->box(filled => 1, xmin => 25, color => $c_green_50);
+
+  my @left_box = ( box => [ 25, 25, 49, 74 ] );
+  my @right_box = ( box => [ 50, 25, 74, 74 ] );
+
+  { # 1 channel output
+    my $base = Imager->new(xsize => 100, ysize => 100, channels => 1);
+    $base->box(filled => 1, color => Imager::Color->new(64, 255, 0, 0));
+
+    my $work = $base->copy;
+    ok($work->paste(left => 25, top => 25, src => $src1), "paste 1 to 1");
+    my $comp = $base->copy;
+    $comp->box(filled => 1, color => $g_grey_full, @left_box);
+    $comp->box(filled => 1, color => [ 0, 0, 0, 0 ], @right_box);
+    is_image($work, $comp, "compare paste target to expected");
+
+    $work = $base->copy;
+    ok($work->paste(left => 25, top => 25, src => $src2), "paste 2 to 1");
+    $comp = $base->copy;
+    $comp->box(filled => 1, @left_box, color => $g_grey_full);
+    $comp->box(filled => 1, @right_box, color => [ 128, 0, 0, 0 ]);
+    is_image($work, $comp, "compare paste target to expected");
+
+    $work = $base->copy;
+    ok($work->paste(left => 25, top => 25, src => $src3), "paste 3 to 1");
+     $comp = $base->copy;
+    $comp->box(filled => 1, @left_box, color => [ 57, 255, 0, 0 ]);
+    $comp->box(filled => 1, @right_box, color => [ 18, 255, 0, 0 ]);
+    is_image($work, $comp, "compare paste target to expected");
+
+    $work = $base->copy;
+    ok($work->paste(left => 25, top => 25, src => $src4), "paste 4 to 1");
+    $comp = $base->copy;
+    $comp->box(filled => 1, color => [ 18, 255, 0, 0 ], @left_box);
+    $comp->box(filled => 1, color => [ 90, 255, 0, 0 ], @right_box);
+    is_image($work, $comp, "compare paste target to expected");
+  }
+
+  { # 2 channel output
+    my $base = Imager->new(xsize => 100, ysize => 100, channels => 2);
+    $base->box(filled => 1, color => [ 128, 128, 0, 0 ]);
+    
+    my $work = $base->copy;
+    ok($work->paste(top => 25, left => 25, src => $src1), "paste 1 to 2");
+    my $comp = $base->copy;
+    $comp->box(filled => 1, color => $g_grey_full, @left_box);
+    $comp->box(filled => 1, color => [ 0, 255, 0, 0 ], @right_box);
+    is_image($work, $comp, "compare paste target to expected");
+
+    $work = $base->copy;
+    ok($work->paste(top => 25, left => 25, src => $src2), "paste 2 to 2");
+    $comp = $base->copy;
+    $comp->box(filled => 1, color => $g_grey_full, @left_box);
+    $comp->box(filled => 1, color => $g_white_50, @right_box);
+    is_image($work, $comp, "compare paste target to expected");
+
+    $work = $base->copy;
+    ok($work->paste(top => 25, left => 25, src => $src3), "paste 3 to 2");
+    $comp = $base->copy;
+    $comp->box(filled => 1, color => [ 57, 255, 0, 0 ], @left_box);
+    $comp->box(filled => 1, color => [ 18, 255, 0, 0 ], @right_box);
+    is_image($work, $comp, "compare paste target to expected");
+
+    $work = $base->copy;
+    ok($work->paste(top => 25, left => 25, src => $src4), "paste 4 to 2");
+    $comp = $base->copy;
+    $comp->box(filled => 1, color => [ 18, 255, 0, 0 ], @left_box);
+    $comp->box(filled => 1, color => [ 180, 127, 0, 0 ], @right_box);
+    is_image($work, $comp, "compare paste target to expected");
+  }
+
+  { # 3 channel output
+    my $base = Imager->new(xsize => 100, ysize => 100, channels => 3);
+    $base->box(filled => 1, color => [ 128, 255, 0, 0 ]);
+    
+    my $work = $base->copy;
+    ok($work->paste(top => 25, left => 25, src => $src1), "paste 1 to 3");
+    my $comp = $base->copy;
+    $comp->box(filled => 1, color => [ 128, 128, 128, 255 ], @left_box);
+    $comp->box(filled => 1, color => [ 0, 0, 0, 0 ], @right_box);
+    is_image($work, $comp, "compare paste target to expected");
+
+    $work = $base->copy;
+    ok($work->paste(top => 25, left => 25, src => $src2), "paste 2 to 3");
+    $comp = $base->copy;
+    $comp->box(filled => 1, color => [ 128, 128, 128, 255 ], @left_box);
+    $comp->box(filled => 1, color => [ 128, 128, 128, 255 ], @right_box);
+    is_image($work, $comp, "compare paste target to expected");
+
+    $work = $base->copy;
+    ok($work->paste(top => 25, left => 25, src => $src3), "paste 3 to 3");
+    $comp = $base->copy;
+    $comp->box(filled => 1, color => [ 255, 0, 0 ], @left_box);
+    $comp->box(filled => 1, color => [ 0, 0, 255 ], @right_box);
+    is_image($work, $comp, "compare paste target to expected");
+
+    $work = $base->copy;
+    ok($work->paste(top => 25, left => 25, src => $src4), "paste 4 to 3");
+    $comp = $base->copy;
+    $comp->box(filled => 1, color => [ 0, 0, 255 ], @left_box);
+    $comp->box(filled => 1, color => [ 0, 127, 0 ], @right_box);
+    is_image($work, $comp, "compare paste target to expected");
+  }
+
+  { # 4 channel output
+    my $base = Imager->new(xsize => 100, ysize => 100, channels => 4);
+    $base->box(filled => 1, color => [ 128, 255, 64, 128 ]);
+    
+    my $work = $base->copy;
+    ok($work->paste(top => 25, left => 25, src => $src1), "paste 1 to 4");
+    my $comp = $base->copy;
+    $comp->box(filled => 1, color => [ 128, 128, 128, 255 ], @left_box);
+    $comp->box(filled => 1, color => [ 0, 0, 0, 255 ], @right_box);
+    is_image($work, $comp, "compare paste target to expected");
+
+    $work = $base->copy;
+    ok($work->paste(top => 25, left => 25, src => $src2), "paste 2 to 4");
+    $comp = $base->copy;
+    $comp->box(filled => 1, color => [ 128, 128, 128, 255 ], @left_box);
+    $comp->box(filled => 1, color => [ 255, 255, 255, 128 ], @right_box);
+    is_image($work, $comp, "compare paste target to expected");
+
+    $work = $base->copy;
+    ok($work->paste(top => 25, left => 25, src => $src3), "paste 3 to 4");
+    $comp = $base->copy;
+    $comp->box(filled => 1, color => [ 255, 0, 0 ], @left_box);
+    $comp->box(filled => 1, color => [ 0, 0, 255 ], @right_box);
+    is_image($work, $comp, "compare paste target to expected");
+
+    $work = $base->copy;
+    ok($work->paste(top => 25, left => 25, src => $src4), "paste 4 to 4");
+    $comp = $base->copy;
+    $comp->box(filled => 1, color => $c_blue_full, @left_box);
+    $comp->box(filled => 1, color => $c_green_50, @right_box);
+    is_image($work, $comp, "compare paste target to expected");
+  }
+}
diff --git a/t/250-draw/040-rubthru.t b/t/250-draw/040-rubthru.t
new file mode 100644 (file)
index 0000000..a1fa3d3
--- /dev/null
@@ -0,0 +1,327 @@
+#!perl -w
+use strict;
+use Test::More tests => 76;
+use Imager qw(:all :handy);
+use Imager::Test qw(is_image);
+
+-d "testout" or mkdir "testout";
+
+init_log("testout/t69rubthru.log", 1);
+
+my $src_height = 80;
+my $src_width = 80;
+
+# raw interface
+my $targ = Imager::ImgRaw::new(100, 100, 3);
+my $src = Imager::ImgRaw::new($src_height, $src_width, 4);
+my $halfred = NC(255, 0, 0, 128);
+i_box_filled($src, 20, 20, 60, 60, $halfred);
+ok(i_rubthru($targ, $src, 10, 10, 0, 0, $src_width, $src_height),
+   "low level rubthrough");
+my $c = Imager::i_get_pixel($targ, 10, 10);
+ok($c, "get pixel at (10, 10)");
+ok(color_cmp($c, NC(0, 0, 0)) == 0, "check for correct color");
+$c = Imager::i_get_pixel($targ, 30, 30);
+ok($c, "get pixel at (30, 30)");
+ok(color_cmp($c, NC(128, 0, 0)) == 0, "check color");
+
+my $black = NC(0, 0, 0);
+# reset the target and try a grey+alpha source
+i_box_filled($targ, 0, 0, 100, 100, $black);
+my $gsrc = Imager::ImgRaw::new($src_width, $src_height, 2);
+my $halfwhite = NC(255, 128, 0);
+i_box_filled($gsrc, 20, 20, 60, 60, $halfwhite);
+ok(i_rubthru($targ, $gsrc, 10, 10, 0, 0, $src_width, $src_height),
+   "low level with grey/alpha source");
+$c = Imager::i_get_pixel($targ, 15, 15);
+ok($c, "get at (15, 15)");
+ok(color_cmp($c, NC(0, 0, 0)) == 0, "check color");
+$c = Imager::i_get_pixel($targ, 30, 30);
+ok($c, "get pixel at (30, 30)");
+ok(color_cmp($c, NC(128, 128, 128)) == 0, "check color");
+
+# try grey target and grey alpha source
+my $gtarg = Imager::ImgRaw::new(100, 100, 1);
+ok(i_rubthru($gtarg, $gsrc, 10, 10, 0, 0, $src_width, $src_height), 
+   "low level with grey target and gray/alpha source");
+$c = Imager::i_get_pixel($gtarg, 10, 10);
+ok($c, "get pixel at 10, 10");
+is(($c->rgba)[0], 0, "check grey level");
+is((Imager::i_get_pixel($gtarg, 30, 30)->rgba)[0], 128,
+   "check grey level at 30, 30");
+
+# simple test for 16-bit/sample images
+my $targ16 = Imager::i_img_16_new(100, 100, 3);
+ok(i_rubthru($targ16, $src, 10, 10, 0, 0, $src_width, $src_height),
+   "smoke test vs 16-bit/sample image");
+$c = Imager::i_get_pixel($targ16, 30, 30);
+ok($c, "get pixel at 30, 30");
+ok(color_cmp($c, NC(128, 0, 0)) == 0, "check color");
+
+# check the OO interface
+my $ootarg = Imager->new(xsize=>100, ysize=>100);
+my $oosrc = Imager->new(xsize=>80, ysize=>80, channels=>4);
+$oosrc->box(color=>$halfred, xmin=>20, ymin=>20, xmax=>60, ymax=>60,
+            filled=>1);
+ok($ootarg->rubthrough(src=>$oosrc, tx=>10, ty=>10),
+   "oo rubthrough");
+ok(color_cmp(Imager::i_get_pixel($ootarg->{IMG}, 10, 10), NC(0, 0, 0)) == 0,
+   "check pixel at 10, 10");
+ok(color_cmp(Imager::i_get_pixel($ootarg->{IMG}, 30, 30), NC(128, 0, 0)) == 0,
+   "check pixel at 30, 30");
+
+my $oogtarg = Imager->new(xsize=>100, ysize=>100, channels=>1);
+
+{ # check empty image errors
+  my $empty = Imager->new;
+  ok(!$empty->rubthrough(src => $oosrc), "check empty target");
+  is($empty->errstr, 'rubthrough: empty input image', "check error message");
+  ok(!$oogtarg->rubthrough(src=>$empty), "check empty source");
+  is($oogtarg->errstr, 'rubthrough: empty input image (for src)',
+     "check error message");
+}
+
+{
+  # alpha source and target
+  for my $method (qw/rubthrough compose/) {
+
+    my $src = Imager->new(xsize => 10, ysize => 1, channels => 4);
+    my $targ = Imager->new(xsize => 10, ysize => 2, channels => 4);
+
+    # simple initialization
+    $targ->setscanline('y' => 1, x => 1,
+                      pixels =>
+                      [
+                       NC(255, 128, 0, 255),
+                       NC(255, 128, 0, 128),
+                       NC(255, 128, 0, 0),
+                       NC(255, 128, 0, 255),
+                       NC(255, 128, 0, 128),
+                       NC(255, 128, 0, 0),
+                       NC(255, 128, 0, 255),
+                       NC(255, 128, 0, 128),
+                       NC(255, 128, 0, 0),
+                      ]);
+    $src->setscanline('y' => 0,
+                     pixels =>
+                     [
+                      NC(0, 128, 255, 0),
+                      NC(0, 128, 255, 0),
+                      NC(0, 128, 255, 0),
+                      NC(0, 128, 255, 128),
+                      NC(0, 128, 255, 128),
+                      NC(0, 128, 255, 128),
+                      NC(0, 128, 255, 255),
+                      NC(0, 128, 255, 255),
+                      NC(0, 128, 255, 255),
+                     ]);
+    ok($targ->$method(src => $src, combine => 'normal',
+                     tx => 1, ty => 1), "do 4 on 4 $method");
+    iscolora($targ->getpixel(x => 1, 'y' => 1), NC(255, 128, 0, 255),
+            "check at zero source coverage on full targ coverage");
+    iscolora($targ->getpixel(x => 2, 'y' => 1), NC(255, 128, 0, 128),
+            "check at zero source coverage on half targ coverage");
+    iscolora($targ->getpixel(x => 3, 'y' => 1), NC(255, 128, 0, 0),
+            "check at zero source coverage on zero targ coverage");
+    iscolora($targ->getpixel(x => 4, 'y' => 1), NC(127, 128, 128, 255),
+            "check at half source_coverage on full targ coverage");
+    iscolora($targ->getpixel(x => 5, 'y' => 1), NC(85, 128, 170, 191),
+            "check at half source coverage on half targ coverage");
+    iscolora($targ->getpixel(x => 6, 'y' => 1), NC(0, 128, 255, 128),
+            "check at half source coverage on zero targ coverage");
+    iscolora($targ->getpixel(x => 7, 'y' => 1), NC(0, 128, 255, 255),
+            "check at full source_coverage on full targ coverage");
+    iscolora($targ->getpixel(x => 8, 'y' => 1), NC(0, 128, 255, 255),
+            "check at full source coverage on half targ coverage");
+    iscolora($targ->getpixel(x => 9, 'y' => 1), NC(0, 128, 255, 255),
+            "check at full source coverage on zero targ coverage");
+  }
+}
+
+{ # https://rt.cpan.org/Ticket/Display.html?id=30908
+  # we now adapt the source channels to the target
+  # check each combination works as expected
+
+  # various source images
+  my $src1 = Imager->new(xsize => 50, ysize => 50, channels => 1);
+  my $g_grey_full = Imager::Color->new(128, 255, 0, 0);
+  my $g_white_50 = Imager::Color->new(255, 128, 0, 0);
+  $src1->box(filled => 1, xmax => 24, color => $g_grey_full);
+
+  my $src2 = Imager->new(xsize => 50, ysize => 50, channels => 2);
+  $src2->box(filled => 1, xmax => 24, color => $g_grey_full);
+  $src2->box(filled => 1, xmin => 25, color => $g_white_50);
+
+  my $c_red_full = Imager::Color->new(255, 0, 0);
+  my $c_blue_full = Imager::Color->new(0, 0, 255);
+  my $src3 = Imager->new(xsize => 50, ysize => 50, channels => 3);
+  $src3->box(filled => 1, xmax => 24, color => $c_red_full);
+  $src3->box(filled => 1, xmin => 25, color => $c_blue_full);
+
+  my $c_green_50 = Imager::Color->new(0, 255, 0, 127);
+  my $src4 = Imager->new(xsize => 50, ysize => 50, channels => 4);
+  $src4->box(filled => 1, xmax => 24, color => $c_blue_full);
+  $src4->box(filled => 1, xmin => 25, color => $c_green_50);
+
+  my @left_box = ( box => [ 25, 25, 49, 74 ] );
+  my @right_box = ( box => [ 50, 25, 74, 74 ] );
+
+  { # 1 channel output
+    my $base = Imager->new(xsize => 100, ysize => 100, channels => 1);
+    $base->box(filled => 1, color => Imager::Color->new(64, 255, 0, 0));
+
+    my $work = $base->copy;
+    ok($work->rubthrough(left => 25, top => 25, src => $src1), "rubthrough 1 to 1");
+    my $comp = $base->copy;
+    $comp->box(filled => 1, color => $g_grey_full, @left_box);
+    $comp->box(filled => 1, color => [ 0, 0, 0, 0 ], @right_box);
+    is_image($work, $comp, "compare rubthrough target to expected");
+
+    $work = $base->copy;
+    ok($work->rubthrough(left => 25, top => 25, src => $src2), "rubthrough 2 to 1");
+    $comp = $base->copy;
+    $comp->box(filled => 1, @left_box, color => $g_grey_full);
+    $comp->box(filled => 1, @right_box, color => [ 159, 0, 0, 0 ]);
+    is_image($work, $comp, "compare rubthrough target to expected");
+
+    $work = $base->copy;
+    ok($work->rubthrough(left => 25, top => 25, src => $src3), "rubthrough 3 to 1");
+     $comp = $base->copy;
+    $comp->box(filled => 1, @left_box, color => [ 57, 255, 0, 0 ]);
+    $comp->box(filled => 1, @right_box, color => [ 18, 255, 0, 0 ]);
+    is_image($work, $comp, "compare rubthrough target to expected");
+
+    $work = $base->copy;
+    ok($work->rubthrough(left => 25, top => 25, src => $src4), "rubthrough 4 to 1");
+    $comp = $base->copy;
+    $comp->box(filled => 1, color => [ 18, 255, 0, 0 ], @left_box);
+    $comp->box(filled => 1, color => [ 121, 255, 0, 0 ], @right_box);
+    is_image($work, $comp, "compare rubthrough target to expected");
+  }
+
+  { # 2 channel output
+    my $base = Imager->new(xsize => 100, ysize => 100, channels => 2);
+    $base->box(filled => 1, color => [ 128, 128, 0, 0 ]);
+    
+    my $work = $base->copy;
+    ok($work->rubthrough(top => 25, left => 25, src => $src1), "rubthrough 1 to 2");
+    my $comp = $base->copy;
+    $comp->box(filled => 1, color => $g_grey_full, @left_box);
+    $comp->box(filled => 1, color => [ 0, 255, 0, 0 ], @right_box);
+    is_image($work, $comp, "compare rubthrough target to expected");
+
+    $work = $base->copy;
+    ok($work->rubthrough(top => 25, left => 25, src => $src2), "rubthrough 2 to 2");
+    $comp = $base->copy;
+    $comp->box(filled => 1, color => $g_grey_full, @left_box);
+    $comp->box(filled => 1, color => [ 213, 191, 0, 0 ], @right_box);
+    is_image($work, $comp, "compare rubthrough target to expected");
+
+    $work = $base->copy;
+    ok($work->rubthrough(top => 25, left => 25, src => $src3), "rubthrough 3 to 2");
+    $comp = $base->copy;
+    $comp->box(filled => 1, color => [ 57, 255, 0, 0 ], @left_box);
+    $comp->box(filled => 1, color => [ 18, 255, 0, 0 ], @right_box);
+    is_image($work, $comp, "compare rubthrough target to expected");
+
+    $work = $base->copy;
+    ok($work->rubthrough(top => 25, left => 25, src => $src4), "rubthrough 4 to 2");
+    $comp = $base->copy;
+    $comp->box(filled => 1, color => [ 18, 255, 0, 0 ], @left_box);
+    $comp->box(filled => 1, color => [ 162, 191, 0, 0 ], @right_box);
+    is_image($work, $comp, "compare rubthrough target to expected");
+  }
+
+  { # 3 channel output
+    my $base = Imager->new(xsize => 100, ysize => 100, channels => 3);
+    $base->box(filled => 1, color => [ 128, 255, 0, 0 ]);
+    
+    my $work = $base->copy;
+    ok($work->rubthrough(top => 25, left => 25, src => $src1), "rubthrough 1 to 3");
+    my $comp = $base->copy;
+    $comp->box(filled => 1, color => [ 128, 128, 128, 255 ], @left_box);
+    $comp->box(filled => 1, color => [ 0, 0, 0, 0 ], @right_box);
+    is_image($work, $comp, "compare rubthrough target to expected");
+
+    $work = $base->copy;
+    ok($work->rubthrough(top => 25, left => 25, src => $src2), "rubthrough 2 to 3");
+    $comp = $base->copy;
+    $comp->box(filled => 1, color => [ 128, 128, 128, 255 ], @left_box);
+    $comp->box(filled => 1, color => [ 191, 255, 128, 255 ], @right_box);
+    is_image($work, $comp, "compare rubthrough target to expected");
+
+    $work = $base->copy;
+    ok($work->rubthrough(top => 25, left => 25, src => $src3), "rubthrough 3 to 3");
+    $comp = $base->copy;
+    $comp->box(filled => 1, color => [ 255, 0, 0 ], @left_box);
+    $comp->box(filled => 1, color => [ 0, 0, 255 ], @right_box);
+    is_image($work, $comp, "compare rubthrough target to expected");
+
+    $work = $base->copy;
+    ok($work->rubthrough(top => 25, left => 25, src => $src4), "rubthrough 4 to 3");
+    $comp = $base->copy;
+    $comp->box(filled => 1, color => [ 0, 0, 255 ], @left_box);
+    $comp->box(filled => 1, color => [ 64, 255, 0 ], @right_box);
+    is_image($work, $comp, "compare rubthrough target to expected");
+  }
+
+  { # 4 channel output
+    my $base = Imager->new(xsize => 100, ysize => 100, channels => 4);
+    $base->box(filled => 1, color => [ 128, 255, 64, 128 ]);
+    
+    my $work = $base->copy;
+    ok($work->rubthrough(top => 25, left => 25, src => $src1), "rubthrough 1 to 4");
+    my $comp = $base->copy;
+    $comp->box(filled => 1, color => [ 128, 128, 128, 255 ], @left_box);
+    $comp->box(filled => 1, color => [ 0, 0, 0, 255 ], @right_box);
+    is_image($work, $comp, "compare rubthrough target to expected");
+
+    $work = $base->copy;
+    ok($work->rubthrough(top => 25, left => 25, src => $src2), "rubthrough 2 to 4");
+    $comp = $base->copy;
+    $comp->box(filled => 1, color => [ 128, 128, 128, 255 ], @left_box);
+    $comp->box(filled => 1, color => [ 213, 255, 192, 191 ], @right_box);
+    is_image($work, $comp, "compare rubthrough target to expected");
+
+    $work = $base->copy;
+    ok($work->rubthrough(top => 25, left => 25, src => $src3), "rubthrough 3 to 4");
+    $comp = $base->copy;
+    $comp->box(filled => 1, color => [ 255, 0, 0 ], @left_box);
+    $comp->box(filled => 1, color => [ 0, 0, 255 ], @right_box);
+    is_image($work, $comp, "compare rubthrough target to expected");
+
+    $work = $base->copy;
+    ok($work->rubthrough(top => 25, left => 25, src => $src4), "rubthrough 4 to 4");
+    $comp = $base->copy;
+    $comp->box(filled => 1, color => $c_blue_full, @left_box);
+    $comp->box(filled => 1, color => [ 43, 255, 21, 191], @right_box);
+    is_image($work, $comp, "compare rubthrough target to expected");
+  }
+}
+
+sub color_cmp {
+  my ($l, $r) = @_;
+  my @l = $l->rgba;
+  my @r = $r->rgba;
+  print "# (",join(",", @l[0..2]),") <=> (",join(",", @r[0..2]),")\n";
+  return $l[0] <=> $r[0]
+    || $l[1] <=> $r[1]
+      || $l[2] <=> $r[2];
+}
+
+sub iscolora {
+  my ($c1, $c2, $msg) = @_;
+
+  my $builder = Test::Builder->new;
+  my @c1 = $c1->rgba;
+  my @c2 = $c2->rgba;
+  if (!$builder->ok($c1[0] == $c2[0] && $c1[1] == $c2[1] && $c1[2] == $c2[2]
+                    && $c1[3] == $c2[3],
+                    $msg)) {
+    $builder->diag(<<DIAG);
+      got color: [ @c1 ]
+ expected color: [ @c2 ]
+DIAG
+  }
+}
+
diff --git a/t/250-draw/050-polyaa.t b/t/250-draw/050-polyaa.t
new file mode 100644 (file)
index 0000000..ace2e64
--- /dev/null
@@ -0,0 +1,279 @@
+#!perl -w
+
+use strict;
+use Test::More tests => 18;
+
+use Imager qw/NC/;
+use Imager::Test qw(is_image is_color3);
+
+sub PI () { 3.14159265358979323846 }
+
+-d "testout" or mkdir "testout";
+
+Imager::init_log("testout/t75aapolyaa.log",1);
+
+my $red   = Imager::Color->new(255,0,0);
+my $green = Imager::Color->new(0,255,0);
+my $blue  = Imager::Color->new(0,0,255);
+my $white = Imager::Color->new(255,255,255);
+
+{ # artifacts with multiple vertical lobes
+  # https://rt.cpan.org/Ticket/Display.html?id=43518
+  # previously this would have a full coverage pixel at (0,0) caused
+  # by the (20,0.5) point in the right lobe
+