[imager.git] / PNG / t / 10png.t

#!perl -w
use strict;
use Imager qw(:all);
use Test::More;
use Imager::Test qw(test_image_raw test_image is_image);

my $debug_writes = 1;

-d "testout" or mkdir "testout";

init_log("testout/t102png.log",1);

plan tests => 151;

# this loads Imager::File::PNG too
ok($Imager::formats{"png"}, "must have png format");

diag("Library version " . Imager::File::PNG::i_png_lib_version());

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();

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);

Imager::i_tags_add($img, "i_xres", 0, "300", 0);
Imager::i_tags_add($img, "i_yres", 0, undef, 200);
# the following confuses the GIMP
#Imager::i_tags_add($img, "i_aspect_only", 0, undef, 1);
open(FH,">testout/t102.png") || die "cannot open testout/t102.png for writing\n";
binmode(FH);
my $IO = Imager::io_new_fd(fileno(FH));
ok(Imager::File::PNG::i_writepng_wiol($img, $IO), "write");
close(FH);

open(FH,"testout/t102.png") || die "cannot open testout/t102.png\n";
binmode(FH);
$IO = Imager::io_new_fd(fileno(FH));
my $cmpimg = Imager::File::PNG::i_readpng_wiol($IO);
close(FH);
ok($cmpimg, "read png");

print "# png average mean square pixel difference: ",sqrt(i_img_diff($img,$cmpimg))/150*150,"\n";
is(i_img_diff($img, $cmpimg), 0, "compare saved and original images");

my %tags = map { Imager::i_tags_get($cmpimg, $_) }
  0..Imager::i_tags_count($cmpimg) - 1;
ok(abs($tags{i_xres} - 300) < 1, "i_xres: $tags{i_xres}");
ok(abs($tags{i_yres} - 200) < 1, "i_yres: $tags{i_yres}");
is($tags{i_format}, "png", "i_format: $tags{i_format}");

open FH, "> testout/t102_trans.png"
  or die "Cannot open testout/t102_trans.png: $!";
binmode FH;
$IO = Imager::io_new_fd(fileno(FH));
ok(Imager::File::PNG::i_writepng_wiol($timg, $IO), "write tranparent");
close FH;

open FH,"testout/t102_trans.png" 
  or die "cannot open testout/t102_trans.png\n";
binmode(FH);
$IO = Imager::io_new_fd(fileno(FH));
$cmpimg = Imager::File::PNG::i_readpng_wiol($IO);
ok($cmpimg, "read transparent");
close(FH);

print "# png average mean square pixel difference: ",sqrt(i_img_diff($timg,$cmpimg))/150*150,"\n";
is(i_img_diff($timg, $cmpimg), 0, "compare saved and original transparent");

# REGRESSION TEST
# png.c 1.1 would produce an incorrect image when loading images with
# less than 8 bits/pixel with a transparent palette entry
open FH, "< testimg/palette.png"
  or die "cannot open testimg/palette.png: $!\n";
binmode FH;
$IO = Imager::io_new_fd(fileno(FH));
# 1.1 may segfault here (it does with libefence)
my $pimg = Imager::File::PNG::i_readpng_wiol($IO);
ok($pimg, "read transparent paletted image");
close FH;

open FH, "< testimg/palette_out.png"
  or die "cannot open testimg/palette_out.png: $!\n";
binmode FH;
$IO = Imager::io_new_fd(fileno(FH));
my $poimg = Imager::File::PNG::i_readpng_wiol($IO);
ok($poimg, "read palette_out image");
close FH;
if (!is(i_img_diff($pimg, $poimg), 0, "images the same")) {
  print <<EOS;
# this tests a bug in Imager's png.c v1.1
# if also tickles a bug in libpng before 1.0.5, so you may need to
# upgrade libpng
EOS
}

{ # check file limits are checked
  my $limit_file = "testout/t102.png";
  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 if the read_multi fallback works
  my @imgs = Imager->read_multi(file => 'testout/t102.png');
  is(@imgs, 1, "check the image was loaded");
  is(i_img_diff($img, $imgs[0]), 0, "check image matches");
  
  # check the write_multi fallback
  ok(Imager->write_multi({ file => 'testout/t102m.png', type => 'png' }, 
			 @imgs),
       'test write_multi() callback');
  
  # check that we fail if we actually write 2
  ok(!Imager->write_multi({ file => 'testout/t102m.png', type => 'png' }, 
			   @imgs, @imgs),
     'test write_multi() callback failure');
}

{ # check close failures are handled correctly
  my $im = test_image();
  my $fail_close = sub {
    Imager::i_push_error(0, "synthetic close failure");
    print "# closecb called\n";
    return 0;
  };
  ok(!$im->write(type => "png", callback => sub { 1 },
		 closecb => $fail_close),
     "check failing close fails");
    like($im->errstr, qr/synthetic close failure/,
	 "check error message");
}

{
  ok(grep($_ eq 'png', Imager->read_types), "check png in read types");
  ok(grep($_ eq 'png', Imager->write_types), "check png in write types");
}

{ # read error reporting
  my $im = Imager->new;
  ok(!$im->read(file => "testimg/badcrc.png", type => "png"),
     "read png with bad CRC chunk should fail");
  is($im->errstr, "IHDR: CRC error", "check error message");
}

{ # write error reporting
  my $im = test_image();
  ok(!$im->write(type => "png", callback => limited_write(1), buffered => 0),
     "write limited to 1 byte should fail");
  is($im->errstr, "Write error on an iolayer source.: limit reached",
     "check error message");
}

SKIP:
{ # https://sourceforge.net/tracker/?func=detail&aid=3314943&group_id=5624&atid=105624
  # large images
  Imager::File::PNG::i_png_lib_version() >= 10503
      or skip("older libpng limits image sizes", 12);

  {
    my $im = Imager->new(xsize => 1000001, ysize => 1, channels => 1);
    ok($im, "make a wide image");
    my $data;
    ok($im->write(data => \$data, type => "png"),
       "write wide image as png")
      or diag("write wide: " . $im->errstr);
    my $im2 = Imager->new;
    ok($im->read(data => $data, type => "png"),
       "read wide image as png")
      or diag("read wide: " . $im->errstr);
    is($im->getwidth, 1000001, "check width");
    is($im->getheight, 1, "check height");
    is($im->getchannels, 1, "check channels");
  }

  {
    my $im = Imager->new(xsize => 1, ysize => 1000001, channels => 1);
    ok($im, "make a tall image");
    my $data;
    ok($im->write(data => \$data, type => "png"),
       "write wide image as png")
      or diag("write tall: " . $im->errstr);
    my $im2 = Imager->new;
    ok($im->read(data => $data, type => "png"),
       "read tall image as png")
      or diag("read tall: " . $im->errstr);
    is($im->getwidth, 1, "check width");
    is($im->getheight, 1000001, "check height");
    is($im->getchannels, 1, "check channels");
  }
}

{ # test grayscale read as greyscale
  my $im = Imager->new;
  ok($im->read(file => "testimg/gray.png", type => "png"),
     "read grayscale");
  is($im->getchannels, 1, "check channel count");
  is($im->type, "direct", "check type");
  is($im->bits, 8, "check bits");
  is($im->tags(name => "png_bits"), 8, "check png_bits tag");
  is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
}

{ # test grayscale + alpha read as greyscale + alpha
  my $im = Imager->new;
  ok($im->read(file => "testimg/graya.png", type => "png"),
     "read grayscale + alpha");
  is($im->getchannels, 2, "check channel count");
  is($im->type, "direct", "check type");
  is($im->bits, 8, "check bits");
  is($im->tags(name => "png_bits"), 8, "check png_bits tag");
  is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
}

{ # test paletted + alpha read as paletted
  my $im = Imager->new;
  ok($im->read(file => "testimg/paltrans.png", type => "png"),
     "read paletted with alpha");
  is($im->getchannels, 4, "check channel count");
  is($im->type, "paletted", "check type");
  is($im->tags(name => "png_bits"), 8, "check png_bits tag");
  is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
}

{ # test paletted read as paletted
  my $im = Imager->new;
  ok($im->read(file => "testimg/pal.png", type => "png"),
     "read paletted");
  is($im->getchannels, 3, "check channel count");
  is($im->type, "paletted", "check type");
  is($im->tags(name => "png_bits"), 8, "check png_bits tag");
  is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
}

{ # test 16-bit rgb read as 16 bit
  my $im = Imager->new;
  ok($im->read(file => "testimg/rgb16.png", type => "png"),
     "read 16-bit rgb");
  is($im->getchannels, 3, "check channel count");
  is($im->type, "direct", "check type");
  is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
  is($im->bits, 16, "check bits");
  is($im->tags(name => "png_bits"), 16, "check png_bits tag");
}

{ # test 1-bit grey read as mono
  my $im = Imager->new;
  ok($im->read(file => "testimg/bilevel.png", type => "png"),
     "read bilevel png");
  is($im->getchannels, 1, "check channel count");
  is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
  is($im->type, "paletted", "check type");
  ok($im->is_bilevel, "should be bilevel");
  is($im->tags(name => "png_bits"), 1, "check png_bits tag");
}

SKIP:
{ # test interlaced read as interlaced and matches original
  my $im_i = Imager->new(file => "testimg/rgb8i.png", filetype => "png");
  ok($im_i, "read interlaced")
    or skip("Could not read rgb8i.png: " . Imager->errstr, 7);
  is($im_i->getchannels, 3, "check channel count");
  is($im_i->type, "direct", "check type");
  is($im_i->tags(name => "png_bits"), 8, "check png_bits");
  is($im_i->tags(name => "png_interlace"), 1, "check png_interlace");

  my $im = Imager->new(file => "testimg/rgb8.png", filetype => "png");
  ok($im, "read non-interlaced")
    or skip("Could not read testimg/rgb8.png: " . Imager->errstr, 2);
  is($im->tags(name => "png_interlace"), 0, "check png_interlace");
  is_image($im_i, $im, "compare interlaced and non-interlaced");
}

{
  my @match =
    (
     [ "cover.png", "coveri.png" ],
     [ "cover16.png", "cover16i.png" ],
     [ "coverpal.png", "coverpali.png" ],
    );
  for my $match (@match) {
    my ($normal, $interlace) = @$match;

    my $n_im = Imager->new(file => "testimg/$normal");
    ok($n_im, "read $normal")
      or diag "reading $normal: ", Imager->errstr;
    my $i_im = Imager->new(file => "testimg/$interlace");
    ok($i_im, "read $interlace")
      or diag "reading $interlace: ", Imager->errstr;
  SKIP:
    {
      $n_im && $i_im
	or skip("Couldn't read a file", 1);
      is_image($i_im, $n_im, "check normal and interlace files read the same");
    }
  }
}

{
  my $interlace = 0;
  for my $name ("cover.png", "coveri.png") {
  SKIP: {
      my $im = Imager->new(file => "testimg/$name");
      ok($im, "read $name")
	or diag "Failed to read $name: ", Imager->errstr;
      $im
	or skip("Couldn't load $name", 5);
      is($im->tags(name => "i_format"), "png", "$name: i_format");
      is($im->tags(name => "png_bits"), 8, "$name: png_bits");
      is($im->tags(name => "png_interlace"), $interlace,
	 "$name: png_interlace");
      is($im->getchannels, 4, "$name: four channels");
      is($im->type, "direct", "$name: direct type");

      is_deeply([ $im->getsamples(y => 0, width => 5) ],
		[ ( 255, 255, 0, 255 ), ( 255, 255, 0, 191 ),
		  ( 255, 255, 0, 127 ), ( 255, 255, 0, 63 ),
		  ( 0, 0, 0, 0) ],
		"$name: check expected samples row 0");
      is_deeply([ $im->getsamples(y => 1, width => 5) ],
		[ ( 255, 0, 0, 255 ), ( 255, 0, 0, 191 ),
		  ( 255, 0, 0, 127 ), ( 255, 0, 0, 63 ),
		  ( 0, 0, 0, 0) ],
		"$name: check expected samples row 1");
    }
    $interlace = 1;
  }
}

{
  my $interlace = 0;
  for my $name ("coverpal.png", "coverpali.png") {
  SKIP: {
      my $im = Imager->new(file => "testimg/$name");
      ok($im, "read $name")
	or diag "Failed to read $name: ", Imager->errstr;
      $im
	or skip("Couldn't load $name", 5);
      is($im->tags(name => "i_format"), "png", "$name: i_format");
      is($im->tags(name => "png_bits"), 4, "$name: png_bits");
      is($im->tags(name => "png_interlace"), $interlace,
	 "$name: png_interlace");
      is($im->getchannels, 4, "$name: four channels");
      is($im->type, "paletted", "$name: paletted type");

      is_deeply([ $im->getsamples(y => 0, width => 5) ],
		[ ( 255, 255, 0, 255 ), ( 255, 255, 0, 191 ),
		  ( 255, 255, 0, 127 ), ( 255, 255, 0, 63 ),
		  ( 0, 0, 0, 0) ],
		"$name: check expected samples row 0");
      is_deeply([ $im->getsamples(y => 1, width => 5) ],
		[ ( 255, 0, 0, 255 ), ( 255, 0, 0, 191 ),
		  ( 255, 0, 0, 127 ), ( 255, 0, 0, 63 ),
		  ( 0, 0, 0, 0) ],
		"$name: check expected samples row 1");
    }
    $interlace = 1;
  }
}

{
  my $interlace = 0;
  for my $name ("cover16.png", "cover16i.png") {
  SKIP: {
      my $im = Imager->new(file => "testimg/$name");
      ok($im, "read $name")
	or diag "Failed to read $name: ", Imager->errstr;
      $im
	or skip("Couldn't load $name", 5);
      is($im->tags(name => "i_format"), "png", "$name: i_format");
      is($im->tags(name => "png_bits"), 16, "$name: png_bits");
      is($im->tags(name => "png_interlace"), $interlace,
	 "$name: png_interlace");
      is($im->getchannels, 4, "$name: four channels");
      is($im->type, "direct", "$name: direct type");

      is_deeply([ $im->getsamples(y => 0, width => 5, type => "16bit") ],
		[ ( 65535, 65535, 0, 65535 ), ( 65535, 65535, 0, 49087 ),
		  ( 65535, 65535, 0, 32639 ), ( 65535, 65535, 0, 16191 ),
		  ( 65535, 65535, 65535, 0) ],
		"$name: check expected samples row 0");
      is_deeply([ $im->getsamples(y => 1, width => 5, type => "16bit") ],
		[ ( 65535, 0, 0, 65535 ), ( 65535, 0, 0, 49087 ),
		  ( 65535, 0, 0, 32639 ), ( 65535, 0, 0, 16191 ),
		  ( 65535, 65535, 65535, 0) ],
		"$name: check expected samples row 1");
    }
    $interlace = 1;
  }
}

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;
       }
     };
}
Commit	Line	Data
352c64ed TC	1	#!perl -w
352c64ed TC	2	use strict;
37a9be8e TC	3	use Imager qw(:all);
37a9be8e TC	4	use Test::More;
cfb628e2	5	use Imager::Test qw(test_image_raw test_image is_image);
1cdc4cbd	6
38eab175 TC	7	my $debug_writes = 1;
38eab175 TC	8
1d7e3124 TC	9	-d "testout" or mkdir "testout";
1d7e3124 TC	10
9e35eed7	11	init_log("testout/t102png.log",1);
1cdc4cbd	12
a4fa5d5e	13	plan tests => 151;
37a9be8e	14
a4fa5d5e TC	15	# this loads Imager::File::PNG too
a4fa5d5e TC	16	ok($Imager::formats{"png"}, "must have png format");
1cdc4cbd	17
647508aa TC	18	diag("Library version " . Imager::File::PNG::i_png_lib_version());
647508aa TC	19
352c64ed TC	20	my $green = i_color_new(0, 255, 0, 255);
	21	my $blue = i_color_new(0, 0, 255, 255);
	22	my $red = i_color_new(255, 0, 0, 255);
1cdc4cbd	23
37a9be8e	24	my $img = test_image_raw();
1cdc4cbd TC	25
	26	my $timg = Imager::ImgRaw::new(20, 20, 4);
	27	my $trans = i_color_new(255, 0, 0, 127);
	28	i_box_filled($timg, 0, 0, 20, 20, $green);
	29	i_box_filled($timg, 2, 2, 18, 18, $trans);
	30
37a9be8e TC	31	Imager::i_tags_add($img, "i_xres", 0, "300", 0);
	32	Imager::i_tags_add($img, "i_yres", 0, undef, 200);
	33	# the following confuses the GIMP
	34	#Imager::i_tags_add($img, "i_aspect_only", 0, undef, 1);
	35	open(FH,">testout/t102.png") \|\| die "cannot open testout/t102.png for writing\n";
	36	binmode(FH);
	37	my $IO = Imager::io_new_fd(fileno(FH));
1d7e3124	38	ok(Imager::File::PNG::i_writepng_wiol($img, $IO), "write");
37a9be8e TC	39	close(FH);
	40
	41	open(FH,"testout/t102.png") \|\| die "cannot open testout/t102.png\n";
	42	binmode(FH);
	43	$IO = Imager::io_new_fd(fileno(FH));
1d7e3124	44	my $cmpimg = Imager::File::PNG::i_readpng_wiol($IO);
37a9be8e TC	45	close(FH);
	46	ok($cmpimg, "read png");
	47
	48	print "# png average mean square pixel difference: ",sqrt(i_img_diff($img,$cmpimg))/150*150,"\n";
	49	is(i_img_diff($img, $cmpimg), 0, "compare saved and original images");
	50
	51	my %tags = map { Imager::i_tags_get($cmpimg, $_) }
	52	0..Imager::i_tags_count($cmpimg) - 1;
	53	ok(abs($tags{i_xres} - 300) < 1, "i_xres: $tags{i_xres}");
	54	ok(abs($tags{i_yres} - 200) < 1, "i_yres: $tags{i_yres}");
	55	is($tags{i_format}, "png", "i_format: $tags{i_format}");
	56
	57	open FH, "> testout/t102_trans.png"
	58	or die "Cannot open testout/t102_trans.png: $!";
	59	binmode FH;
	60	$IO = Imager::io_new_fd(fileno(FH));
1d7e3124	61	ok(Imager::File::PNG::i_writepng_wiol($timg, $IO), "write tranparent");
37a9be8e TC	62	close FH;
	63
	64	open FH,"testout/t102_trans.png"
	65	or die "cannot open testout/t102_trans.png\n";
	66	binmode(FH);
	67	$IO = Imager::io_new_fd(fileno(FH));
1d7e3124	68	$cmpimg = Imager::File::PNG::i_readpng_wiol($IO);
37a9be8e TC	69	ok($cmpimg, "read transparent");
	70	close(FH);
	71
	72	print "# png average mean square pixel difference: ",sqrt(i_img_diff($timg,$cmpimg))/150*150,"\n";
	73	is(i_img_diff($timg, $cmpimg), 0, "compare saved and original transparent");
	74
	75	# REGRESSION TEST
	76	# png.c 1.1 would produce an incorrect image when loading images with
	77	# less than 8 bits/pixel with a transparent palette entry
	78	open FH, "< testimg/palette.png"
	79	or die "cannot open testimg/palette.png: $!\n";
	80	binmode FH;
	81	$IO = Imager::io_new_fd(fileno(FH));
	82	# 1.1 may segfault here (it does with libefence)
1d7e3124	83	my $pimg = Imager::File::PNG::i_readpng_wiol($IO);
37a9be8e TC	84	ok($pimg, "read transparent paletted image");
	85	close FH;
	86
	87	open FH, "< testimg/palette_out.png"
	88	or die "cannot open testimg/palette_out.png: $!\n";
	89	binmode FH;
	90	$IO = Imager::io_new_fd(fileno(FH));
1d7e3124	91	my $poimg = Imager::File::PNG::i_readpng_wiol($IO);
37a9be8e TC	92	ok($poimg, "read palette_out image");
	93	close FH;
	94	if (!is(i_img_diff($pimg, $poimg), 0, "images the same")) {
	95	print <<EOS;
d8bbe40d TC	96	# this tests a bug in Imager's png.c v1.1
	97	# if also tickles a bug in libpng before 1.0.5, so you may need to
	98	# upgrade libpng
	99	EOS
37a9be8e TC	100	}
	101
	102	{ # check file limits are checked
	103	my $limit_file = "testout/t102.png";
	104	ok(Imager->set_file_limits(reset=>1, width=>149), "set width limit 149");
	105	my $im = Imager->new;
	106	ok(!$im->read(file=>$limit_file),
	107	"should fail read due to size limits");
	108	print "# ",$im->errstr,"\n";
	109	like($im->errstr, qr/image width/, "check message");
	110
	111	ok(Imager->set_file_limits(reset=>1, height=>149), "set height limit 149");
	112	ok(!$im->read(file=>$limit_file),
	113	"should fail read due to size limits");
	114	print "# ",$im->errstr,"\n";
	115	like($im->errstr, qr/image height/, "check message");
	116
	117	ok(Imager->set_file_limits(reset=>1, width=>150), "set width limit 150");
	118	ok($im->read(file=>$limit_file),
	119	"should succeed - just inside width limit");
	120	ok(Imager->set_file_limits(reset=>1, height=>150), "set height limit 150");
	121	ok($im->read(file=>$limit_file),
	122	"should succeed - just inside height limit");
	123
	124	# 150 x 150 x 3 channel image uses 67500 bytes
	125	ok(Imager->set_file_limits(reset=>1, bytes=>67499),
	126	"set bytes limit 67499");
	127	ok(!$im->read(file=>$limit_file),
77157728	128	"should fail - too many bytes");
37a9be8e	129	print "# ",$im->errstr,"\n";
77157728	130	like($im->errstr, qr/storage size/, "check error message");
37a9be8e TC	131	ok(Imager->set_file_limits(reset=>1, bytes=>67500),
	132	"set bytes limit 67500");
	133	ok($im->read(file=>$limit_file),
	134	"should succeed - just inside bytes limit");
	135	Imager->set_file_limits(reset=>1);
	136	}
e7ff1cf7	137
37a9be8e TC	138	{ # check if the read_multi fallback works
	139	my @imgs = Imager->read_multi(file => 'testout/t102.png');
	140	is(@imgs, 1, "check the image was loaded");
	141	is(i_img_diff($img, $imgs[0]), 0, "check image matches");
	142
	143	# check the write_multi fallback
	144	ok(Imager->write_multi({ file => 'testout/t102m.png', type => 'png' },
	145	@imgs),
	146	'test write_multi() callback');
	147
	148	# check that we fail if we actually write 2
	149	ok(!Imager->write_multi({ file => 'testout/t102m.png', type => 'png' },
e7ff1cf7	150	@imgs, @imgs),
37a9be8e TC	151	'test write_multi() callback failure');
37a9be8e TC	152	}
f245645a	153
6d5c85a2 TC	154	{ # check close failures are handled correctly
	155	my $im = test_image();
	156	my $fail_close = sub {
	157	Imager::i_push_error(0, "synthetic close failure");
9f1597be	158	print "# closecb called\n";
6d5c85a2 TC	159	return 0;
	160	};
	161	ok(!$im->write(type => "png", callback => sub { 1 },
	162	closecb => $fail_close),
	163	"check failing close fails");
	164	like($im->errstr, qr/synthetic close failure/,
	165	"check error message");
	166	}
	167
37a9be8e TC	168	{
	169	ok(grep($_ eq 'png', Imager->read_types), "check png in read types");
	170	ok(grep($_ eq 'png', Imager->write_types), "check png in write types");
1cdc4cbd	171	}
37a9be8e	172
38eab175 TC	173	{ # read error reporting
	174	my $im = Imager->new;
	175	ok(!$im->read(file => "testimg/badcrc.png", type => "png"),
	176	"read png with bad CRC chunk should fail");
	177	is($im->errstr, "IHDR: CRC error", "check error message");
	178	}
	179
	180	{ # write error reporting
	181	my $im = test_image();
	182	ok(!$im->write(type => "png", callback => limited_write(1), buffered => 0),
	183	"write limited to 1 byte should fail");
	184	is($im->errstr, "Write error on an iolayer source.: limit reached",
	185	"check error message");
	186	}
	187
9f1597be TC	188	SKIP:
	189	{ # https://sourceforge.net/tracker/?func=detail&aid=3314943&group_id=5624&atid=105624
	190	# large images
	191	Imager::File::PNG::i_png_lib_version() >= 10503
	192	or skip("older libpng limits image sizes", 12);
	193
	194	{
	195	my $im = Imager->new(xsize => 1000001, ysize => 1, channels => 1);
	196	ok($im, "make a wide image");
	197	my $data;
	198	ok($im->write(data => \$data, type => "png"),
	199	"write wide image as png")
	200	or diag("write wide: " . $im->errstr);
	201	my $im2 = Imager->new;
	202	ok($im->read(data => $data, type => "png"),
	203	"read wide image as png")
	204	or diag("read wide: " . $im->errstr);
	205	is($im->getwidth, 1000001, "check width");
	206	is($im->getheight, 1, "check height");
	207	is($im->getchannels, 1, "check channels");
	208	}
	209
	210	{
	211	my $im = Imager->new(xsize => 1, ysize => 1000001, channels => 1);
	212	ok($im, "make a tall image");
	213	my $data;
	214	ok($im->write(data => \$data, type => "png"),
	215	"write wide image as png")
	216	or diag("write tall: " . $im->errstr);
	217	my $im2 = Imager->new;
	218	ok($im->read(data => $data, type => "png"),
	219	"read tall image as png")
	220	or diag("read tall: " . $im->errstr);
	221	is($im->getwidth, 1, "check width");
	222	is($im->getheight, 1000001, "check height");
	223	is($im->getchannels, 1, "check channels");
	224	}
	225	}
	226
6d379e0d TC	227	{ # test grayscale read as greyscale
	228	my $im = Imager->new;
	229	ok($im->read(file => "testimg/gray.png", type => "png"),
	230	"read grayscale");
	231	is($im->getchannels, 1, "check channel count");
	232	is($im->type, "direct", "check type");
d3f58217	233	is($im->bits, 8, "check bits");
cfb628e2	234	is($im->tags(name => "png_bits"), 8, "check png_bits tag");
963d3602	235	is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
6d379e0d TC	236	}
	237
	238	{ # test grayscale + alpha read as greyscale + alpha
	239	my $im = Imager->new;
	240	ok($im->read(file => "testimg/graya.png", type => "png"),
	241	"read grayscale + alpha");
	242	is($im->getchannels, 2, "check channel count");
	243	is($im->type, "direct", "check type");
d3f58217	244	is($im->bits, 8, "check bits");
cfb628e2	245	is($im->tags(name => "png_bits"), 8, "check png_bits tag");
963d3602	246	is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
6d379e0d TC	247	}
	248
	249	{ # test paletted + alpha read as paletted
	250	my $im = Imager->new;
	251	ok($im->read(file => "testimg/paltrans.png", type => "png"),
	252	"read paletted with alpha");
	253	is($im->getchannels, 4, "check channel count");
6d379e0d	254	is($im->type, "paletted", "check type");
cfb628e2	255	is($im->tags(name => "png_bits"), 8, "check png_bits tag");
963d3602	256	is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
6d379e0d TC	257	}
	258
	259	{ # test paletted read as paletted
	260	my $im = Imager->new;
	261	ok($im->read(file => "testimg/pal.png", type => "png"),
d3f58217 TC	262	"read paletted");
d3f58217 TC	263	is($im->getchannels, 3, "check channel count");
d3f58217	264	is($im->type, "paletted", "check type");
cfb628e2	265	is($im->tags(name => "png_bits"), 8, "check png_bits tag");
963d3602	266	is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
d3f58217 TC	267	}
	268
	269	{ # test 16-bit rgb read as 16 bit
	270	my $im = Imager->new;
	271	ok($im->read(file => "testimg/rgb16.png", type => "png"),
	272	"read 16-bit rgb");
6d379e0d	273	is($im->getchannels, 3, "check channel count");
d3f58217	274	is($im->type, "direct", "check type");
963d3602	275	is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
d3f58217	276	is($im->bits, 16, "check bits");
cfb628e2	277	is($im->tags(name => "png_bits"), 16, "check png_bits tag");
d3f58217 TC	278	}
	279
	280	{ # test 1-bit grey read as mono
	281	my $im = Imager->new;
	282	ok($im->read(file => "testimg/bilevel.png", type => "png"),
	283	"read bilevel png");
	284	is($im->getchannels, 1, "check channel count");
963d3602	285	is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
6d379e0d	286	is($im->type, "paletted", "check type");
d3f58217	287	ok($im->is_bilevel, "should be bilevel");
cfb628e2	288	is($im->tags(name => "png_bits"), 1, "check png_bits tag");
cfb628e2 TC	289	}
	290
	291	SKIP:
	292	{ # test interlaced read as interlaced and matches original
	293	my $im_i = Imager->new(file => "testimg/rgb8i.png", filetype => "png");
	294	ok($im_i, "read interlaced")
	295	or skip("Could not read rgb8i.png: " . Imager->errstr, 7);
	296	is($im_i->getchannels, 3, "check channel count");
	297	is($im_i->type, "direct", "check type");
	298	is($im_i->tags(name => "png_bits"), 8, "check png_bits");
a4fa5d5e	299	is($im_i->tags(name => "png_interlace"), 1, "check png_interlace");
cfb628e2 TC	300
	301	my $im = Imager->new(file => "testimg/rgb8.png", filetype => "png");
	302	ok($im, "read non-interlaced")
	303	or skip("Could not read testimg/rgb8.png: " . Imager->errstr, 2);
a4fa5d5e	304	is($im->tags(name => "png_interlace"), 0, "check png_interlace");
cfb628e2	305	is_image($im_i, $im, "compare interlaced and non-interlaced");
6d379e0d TC	306	}
6d379e0d TC	307
a4fa5d5e TC	308	{
	309	my @match =
	310	(
	311	[ "cover.png", "coveri.png" ],
	312	[ "cover16.png", "cover16i.png" ],
	313	[ "coverpal.png", "coverpali.png" ],
	314	);
	315	for my $match (@match) {
	316	my ($normal, $interlace) = @$match;
	317
	318	my $n_im = Imager->new(file => "testimg/$normal");
	319	ok($n_im, "read $normal")
	320	or diag "reading $normal: ", Imager->errstr;
	321	my $i_im = Imager->new(file => "testimg/$interlace");
	322	ok($i_im, "read $interlace")
	323	or diag "reading $interlace: ", Imager->errstr;
	324	SKIP:
	325	{
	326	$n_im && $i_im
	327	or skip("Couldn't read a file", 1);
	328	is_image($i_im, $n_im, "check normal and interlace files read the same");
	329	}
	330	}
	331	}
	332
	333	{
	334	my $interlace = 0;
	335	for my $name ("cover.png", "coveri.png") {
	336	SKIP: {
	337	my $im = Imager->new(file => "testimg/$name");
	338	ok($im, "read $name")
	339	or diag "Failed to read $name: ", Imager->errstr;
	340	$im
	341	or skip("Couldn't load $name", 5);
	342	is($im->tags(name => "i_format"), "png", "$name: i_format");
	343	is($im->tags(name => "png_bits"), 8, "$name: png_bits");
	344	is($im->tags(name => "png_interlace"), $interlace,
	345	"$name: png_interlace");
	346	is($im->getchannels, 4, "$name: four channels");
	347	is($im->type, "direct", "$name: direct type");
	348
	349	is_deeply([ $im->getsamples(y => 0, width => 5) ],
	350	[ ( 255, 255, 0, 255 ), ( 255, 255, 0, 191 ),
	351	( 255, 255, 0, 127 ), ( 255, 255, 0, 63 ),
	352	( 0, 0, 0, 0) ],
	353	"$name: check expected samples row 0");
	354	is_deeply([ $im->getsamples(y => 1, width => 5) ],
	355	[ ( 255, 0, 0, 255 ), ( 255, 0, 0, 191 ),
	356	( 255, 0, 0, 127 ), ( 255, 0, 0, 63 ),
	357	( 0, 0, 0, 0) ],
	358	"$name: check expected samples row 1");
	359	}
	360	$interlace = 1;
	361	}
	362	}
	363
	364	{
	365	my $interlace = 0;
	366	for my $name ("coverpal.png", "coverpali.png") {
	367	SKIP: {
	368	my $im = Imager->new(file => "testimg/$name");
	369	ok($im, "read $name")
	370	or diag "Failed to read $name: ", Imager->errstr;
	371	$im
372	or skip("Couldn't load $name", 5);
373	is($im->tags(name => "i_format"), "png", "$name: i_format");
374	is($im->tags(name => "png_bits"), 4, "$name: png_bits");
375	is($im->tags(name => "png_interlace"), $interlace,
376	"$name: png_interlace");
377	is($im->getchannels, 4, "$name: four channels");
378	is($im->type, "paletted", "$name: paletted type");
379
380	is_deeply([ $im->getsamples(y => 0, width => 5) ],
381	[ ( 255, 255, 0, 255 ), ( 255, 255, 0, 191 ),
382	( 255, 255, 0, 127 ), ( 255, 255, 0, 63 ),
383	( 0, 0, 0, 0) ],
384	"$name: check expected samples row 0");
385	is_deeply([ $im->getsamples(y => 1, width => 5) ],
386	[ ( 255, 0, 0, 255 ), ( 255, 0, 0, 191 ),
387	( 255, 0, 0, 127 ), ( 255, 0, 0, 63 ),
388	( 0, 0, 0, 0) ],
389	"$name: check expected samples row 1");
390	}
391	$interlace = 1;
392	}
393	}
394
395	{
396	my $interlace = 0;
397	for my $name ("cover16.png", "cover16i.png") {
398	SKIP: {
399	my $im = Imager->new(file => "testimg/$name");
400	ok($im, "read $name")
401	or diag "Failed to read $name: ", Imager->errstr;
402	$im
403	or skip("Couldn't load $name", 5);
404	is($im->tags(name => "i_format"), "png", "$name: i_format");
405	is($im->tags(name => "png_bits"), 16, "$name: png_bits");
406	is($im->tags(name => "png_interlace"), $interlace,
407	"$name: png_interlace");
408	is($im->getchannels, 4, "$name: four channels");
409	is($im->type, "direct", "$name: direct type");
410
411	is_deeply([ $im->getsamples(y => 0, width => 5, type => "16bit") ],
412	[ ( 65535, 65535, 0, 65535 ), ( 65535, 65535, 0, 49087 ),
413	( 65535, 65535, 0, 32639 ), ( 65535, 65535, 0, 16191 ),
414	( 65535, 65535, 65535, 0) ],
415	"$name: check expected samples row 0");
416	is_deeply([ $im->getsamples(y => 1, width => 5, type => "16bit") ],
417	[ ( 65535, 0, 0, 65535 ), ( 65535, 0, 0, 49087 ),
418	( 65535, 0, 0, 32639 ), ( 65535, 0, 0, 16191 ),
419	( 65535, 65535, 65535, 0) ],
420	"$name: check expected samples row 1");
421	}
422	$interlace = 1;
423	}
424	}
425
38eab175 TC	426	sub limited_write {
	427	my ($limit) = @_;
	428
	429	return
	430	sub {
	431	my ($data) = @_;
	432	$limit -= length $data;
	433	if ($limit >= 0) {
	434	print "# write of ", length $data, " bytes successful ($limit left)\n" if $debug_writes;
	435	return 1;
	436	}
	437	else {
	438	print "# write of ", length $data, " bytes failed\n";
	439	Imager::i_push_error(0, "limit reached");
	440	return;
	441	}
	442	};
	443	}