PNG/t/10png.t - metacpan.org

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

my $debug_writes = 1;

-d "testout" or mkdir "testout";

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

plan tests => 251;

# 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 %png_feat = map { $_ => 1 } Imager::File::PNG->features;

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")
  or diag(Imager->_error_as_msg());
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");
}

SKIP:
{ # ignoring "benign" errors
  $png_feat{"benign-errors"}
      or skip "libpng not configured for benign error support", 3;

 SKIP:
  {
    Imager::File::PNG::i_png_lib_version() < 10610
	or skip "1.6.10 and later treat CRC errors as non-benign", 1;
    my $im = Imager->new;
    ok($im->read(file => "testimg/badcrc.png", type => "png",
		 png_ignore_benign_errors => 1),
       "read bad crc with png_ignore_benign_errors");
  }

  my $im = Imager->new;
  ok($im->read(file => "testimg/bipalette.png", type => "png",
	       png_ignore_benign_errors => 1),
       "read grey image with palette with png_ignore_benign_errors");
  ok(!$im->read(file => "testimg/bipalette.png", type => "png",
	       png_ignore_benign_errors => 0),
       "read grey image with palette without png_ignore_benign_errors should fail");
}

{ # 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;
  }
}

{
  my $pim = Imager->new(xsize => 5, ysize => 2, channels => 3, type => "paletted");
  ok($pim, "make a 3 channel paletted image");
  ok($pim->addcolors(colors => [ qw(000000 FFFFFF FF0000 00FF00 0000FF) ]),
     "add some colors");
  is($pim->setscanline(y => 0, type => "index",
		       pixels => [ 0, 1, 2, 4, 3 ]), 5, "set some pixels");
  is($pim->setscanline(y => 1, type => "index",
		       pixels => [ 4, 1, 0, 4, 2 ]), 5, "set some more pixels");
  ok($pim->write(file => "testout/pal3.png"),
     "write to testout/pal3.png")
    or diag("Cannot save testout/pal3.png: ".$pim->errstr);
  my $in = Imager->new(file => "testout/pal3.png");
  ok($in, "read it back in")
    or diag("Cann't read pal3.png back: " . Imager->errstr);
  is_image($pim, $in, "check it matches");
  is($in->type, "paletted", "make sure the result is paletted");
  is($in->tags(name => "png_bits"), 4, "4 bit representation");
}

{
  # make sure the code that pushes maxed alpha to the end doesn't break
  my $pim = Imager->new(xsize => 8, ysize => 2, channels => 4, type => "paletted");
  ok($pim, "make a 4 channel paletted image");
  ok($pim->addcolors
     (colors => [ NC(255, 255, 0, 128), qw(000000 FFFFFF FF0000 00FF00 0000FF),
		  NC(0, 0, 0, 0), NC(255, 0, 128, 64) ]),
     "add some colors");
  is($pim->setscanline(y => 0, type => "index",
		       pixels => [ 5, 0, 1, 7, 2, 4, 6, 3 ]), 8,
     "set some pixels");
  is($pim->setscanline(y => 1, type => "index",
		       pixels => [ 7, 4, 6, 1, 0, 4, 2, 5 ]), 8,
     "set some more pixels");
  ok($pim->write(file => "testout/pal4.png"),
     "write to testout/pal4.png")
    or diag("Cannot save testout/pal4.png: ".$pim->errstr);
  my $in = Imager->new(file => "testout/pal4.png");
  ok($in, "read it back in")
    or diag("Cann't read pal4.png back: " . Imager->errstr);
  is_image($pim, $in, "check it matches");
  is($in->type, "paletted", "make sure the result is paletted");
  is($in->tags(name => "png_bits"), 4, "4 bit representation");
}

{
  my $pim = Imager->new(xsize => 8, ysize => 2, channels => 1, type => "paletted");
  ok($pim, "make a 1 channel paletted image");
  ok($pim->addcolors(colors => [ map NC($_, 0, 0), 0, 7, 127, 255 ]),
     "add some colors^Wgreys");
  is($pim->setscanline(y => 0, type => "index",
		       pixels => [ 0, 2, 1, 3, 2, 1, 0, 3 ]), 8,
     "set some pixels");
  is($pim->setscanline(y => 1, type => "index",
		       pixels => [ 3, 0, 2, 1, 0, 0, 2, 3 ]), 8,
     "set some more pixels");
  ok($pim->write(file => "testout/pal1.png"),
     "write to testout/pal1.png")
    or diag("Cannot save testout/pal1.png: ".$pim->errstr);
  my $in = Imager->new(file => "testout/pal1.png");
  ok($in, "read it back in")
    or diag("Cann't read pal1.png back: " . Imager->errstr);
  # PNG doesn't have a paletted greyscale type, so it's written as
  # paletted color, convert our source image for the comparison
  my $cmpim = $pim->convert(preset => "rgb");
  is_image($in, $cmpim, "check it matches");
  is($in->type, "paletted", "make sure the result is paletted");
  is($in->tags(name => "png_bits"), 2, "2 bit representation");
}

{
  my $pim = Imager->new(xsize => 8, ysize => 2, channels => 2, type => "paletted");
  ok($pim, "make a 2 channel paletted image");
  ok($pim->addcolors(colors => [ NC(0, 255, 0), NC(128, 255, 0), NC(255, 255, 0), NC(128, 128, 0) ]),
     "add some colors^Wgreys")
    or diag("adding colors: " . $pim->errstr);
  is($pim->setscanline(y => 0, type => "index",
		       pixels => [ 0, 2, 1, 3, 2, 1, 0, 3 ]), 8,
     "set some pixels");
  is($pim->setscanline(y => 1, type => "index",
		       pixels => [ 3, 0, 2, 1, 0, 0, 2, 3 ]), 8,
     "set some more pixels");
  ok($pim->write(file => "testout/pal2.png"),
     "write to testout/pal2.png")
    or diag("Cannot save testout/pal2.png: ".$pim->errstr);
  my $in = Imager->new(file => "testout/pal2.png");
  ok($in, "read it back in")
    or diag("Can't read pal1.png back: " . Imager->errstr);
  # PNG doesn't have a paletted greyscale type, so it's written as
  # paletted color, convert our source image for the comparison
  my $cmpim = $pim->convert(preset => "rgb");
  is_image($in, $cmpim, "check it matches");
  is($in->type, "paletted", "make sure the result is paletted");
  is($in->tags(name => "png_bits"), 2, "2 bit representation");
}

{
  my $imbase = test_image();
  my $mono = $imbase->convert(preset => "gray")
    ->to_paletted(make_colors => "mono", translate => "errdiff");

  ok($mono->write(file => "testout/bilevel.png"),
     "write bilevel.png");
  my $in = Imager->new(file => "testout/bilevel.png");
  ok($in, "read it back in")
    or diag("Can't read bilevel.png: " . Imager->errstr);
  is_image($in, $mono, "check it matches");
  is($in->type, "paletted", "make sure the result is paletted");
  is($in->tags(name => "png_bits"), 1, "1 bit representation");
}

SKIP:
{
  my $im = test_image_16();
  ok($im->write(file => "testout/rgb16.png", type => "png"),
     "write 16-bit/sample image")
    or diag("Could not write rgb16.png: ".$im->errstr);
  my $in = Imager->new(file => "testout/rgb16.png")
    or diag("Could not read rgb16.png: ".Imager->errstr);
  ok($in, "read rgb16.png back in")
    or skip("Could not load image to check", 4);
  is_imaged($in, $im, 0, "check image matches");
  is($in->bits, 16, "check we got a 16-bit image");
  is($in->type, "direct", "check it's direct");
  is($in->tags(name => "png_bits"), 16, "check png_bits");
}

SKIP:
{
  my $im = test_image_double();
  my $cmp = $im->to_rgb16;
  ok($im->write(file => "testout/rgbdbl.png", type => "png"),
     "write double/sample image - should write as 16-bit/sample")
    or diag("Could not write rgbdbl.png: ".$im->errstr);
  my $in = Imager->new(file => "testout/rgbdbl.png")
    or diag("Could not read rgbdbl.png: ".Imager->errstr);
  ok($in, "read pngdbl.png back in")
    or skip("Could not load image to check", 4);
  is_imaged($in, $cmp, 0, "check image matches");
  is($in->bits, 16, "check we got a 16-bit image");
  is($in->type, "direct", "check it's direct");
  is($in->tags(name => "png_bits"), 16, "check png_bits");
}

SKIP:
{
  my $im = Imager->new(file => "testimg/comment.png");
  ok($im, "read file with comment")
    or diag("Cannot read comment.png: ".Imager->errstr);
  $im
    or skip("Cannot test tags file I can't read", 5);
  is($im->tags(name => "i_comment"), "Test comment", "check i_comment");
  is($im->tags(name => "png_interlace"), "0", "no interlace");
  is($im->tags(name => "png_interlace_name"), "none", "no interlace (text)");
  is($im->tags(name => "png_srgb_intent"), "0", "srgb perceptual");
  is($im->tags(name => "png_time"), "2012-04-16T07:37:36",
     "modification time");
  is($im->tags(name => "i_background"), "color(255,255,255,255)",
     "background color");
}

SKIP:
{ # test tag writing
  my $im = Imager->new(xsize => 1, ysize => 1);
  ok($im->write(file => "testout/tags.png",
		i_comment => "A Comment",
		png_author => "An Author",
		png_author_compressed => 1,
		png_copyright => "A Copyright",
		png_creation_time => "16 April 2012 22:56:30+1000",
		png_description => "A Description",
		png_disclaimer => "A Disclaimer",
		png_software => "Some Software",
		png_source => "A Source",
		png_title => "A Title",
		png_warning => "A Warning",
		png_text0_key => "Custom Key",
		png_text0_text => "Custom Value",
		png_text0_compressed => 1,
		png_text1_key => "Custom Key2",
		png_text1_text => "Another Custom Value",
		png_time => "2012-04-20T00:15:10",
	       ),
     "write with many tags")
    or diag("Cannot write with many tags: ", $im->errstr);

  my $imr = Imager->new(file => "testout/tags.png");
  ok($imr, "read it back in")
    or skip("Couldn't read it back: ". Imager->errstr, 1);

  is_deeply({ map @$_, $imr->tags },
	    {
	     i_format => "png",
	     i_comment => "A Comment",
	     png_author => "An Author",
	     png_author_compressed => 1,
	     png_copyright => "A Copyright",
	     png_creation_time => "16 April 2012 22:56:30+1000",
	     png_description => "A Description",
	     png_disclaimer => "A Disclaimer",
	     png_software => "Some Software",
	     png_source => "A Source",
	     png_title => "A Title",
	     png_warning => "A Warning",
	     png_text0_key => "Custom Key",
	     png_text0_text => "Custom Value",
	     png_text0_compressed => 1,
	     png_text0_type => "text",
	     png_text1_key => "Custom Key2",
	     png_text1_text => "Another Custom Value",
	     png_text1_type => "text",
	     png_time => "2012-04-20T00:15:10",
	     png_interlace => 0,
	     png_interlace_name => "none",
	     png_bits => 8,
	    }, "check tags are what we expected");
}

SKIP:
{ # cHRM test
  my $im = Imager->new(xsize => 1, ysize => 1);
  ok($im->write(file => "testout/tagschrm.png", type => "png",
		png_chroma_white_x => 0.3,
		png_chroma_white_y => 0.32,
		png_chroma_red_x => 0.7,
		png_chroma_red_y => 0.28,
		png_chroma_green_x => 0.075,
		png_chroma_green_y => 0.8,
		png_chroma_blue_x => 0.175,
		png_chroma_blue_y => 0.05),
     "write cHRM chunk");
  my $imr = Imager->new(file => "testout/tagschrm.png", ftype => "png");
  ok($imr, "read tagschrm.png")
    or diag("reading tagschrm.png: ".Imager->errstr);
  $imr
    or skip("read of tagschrm.png failed", 1);
  is_deeply({ map @$_, $imr->tags },
	    {
	     i_format => "png",
	     png_interlace => 0,
	     png_interlace_name => "none",
	     png_bits => 8,
	     png_chroma_white_x => 0.3,
	     png_chroma_white_y => 0.32,
	     png_chroma_red_x => 0.7,
	     png_chroma_red_y => 0.28,
	     png_chroma_green_x => 0.075,
	     png_chroma_green_y => 0.8,
	     png_chroma_blue_x => 0.175,
	     png_chroma_blue_y => 0.05,
	    }, "check chroma tags written");
}

{ # gAMA
  my $im = Imager->new(xsize => 1, ysize => 1);
  ok($im->write(file => "testout/tagsgama.png", type => "png",
	       png_gamma => 2.22),
     "write with png_gammma tag");
  my $imr = Imager->new(file => "testout/tagsgama.png", ftype => "png");
  ok($imr, "read tagsgama.png")
    or diag("reading tagsgama.png: ".Imager->errstr);
  $imr
    or skip("read of tagsgama.png failed", 1);
  is_deeply({ map @$_, $imr->tags },
	    {
	     i_format => "png",
	     png_interlace => 0,
	     png_interlace_name => "none",
	     png_bits => 8,
	     png_gamma => "2.22",
	    }, "check gamma tag written");
}

{ # various bad tag failures
  my @tests =
    (
     [
      [ png_chroma_white_x => 0.5 ],
      "all png_chroma_* tags must be supplied or none"
     ],
     [
      [ png_srgb_intent => 4 ],
      "tag png_srgb_intent out of range"
     ],
     [
      [ i_comment => "test\0with nul" ],
      "tag i_comment may not contain NUL characters"
     ],
     [
      [ png_text0_key => "" ],
      "tag png_text0_key must be between 1 and 79 characters in length"
     ],
     [
      [ png_text0_key => ("x" x 80) ],
      "tag png_text0_key must be between 1 and 79 characters in length"
     ],
     [
      [ png_text0_key => " x" ],
      "tag png_text0_key may not contain leading or trailing spaces"
     ],
     [
      [ png_text0_key => "x " ],
      "tag png_text0_key may not contain leading or trailing spaces"
     ],
     [
      [ png_text0_key => "x  y" ],
      "tag png_text0_key may not contain consecutive spaces"
     ],
     [
      [ png_text0_key => "\x7F" ],
      "tag png_text0_key may only contain Latin1 characters 32-126, 161-255"
     ],
     [
      [ png_text0_key => "x", png_text0_text => "a\0b" ],
      "tag png_text0_text may not contain NUL characters"
     ],
     [
      [ png_text0_key => "test" ],
      "tag png_text0_key found but not png_text0_text"
     ],
     [
      [ png_text0_text => "test" ],
      "tag png_text0_text found but not png_text0_key"
     ],
     [
      [ png_time => "bad format" ],
      "png_time must be formatted 'y-m-dTh:m:s'"
     ],
     [
      [ png_time => "2012-13-01T00:00:00" ],
      "invalid date/time for png_time"
     ],
    ); 
  my $im = Imager->new(xsize => 1, ysize => 1);
  for my $test (@tests) {
    my ($tags, $error) = @$test;
    my $im2 = $im->copy;
    my $data;
    ok(!$im2->write(data => \$data, type => "png", @$tags),
       "expect $error");
    is($im2->errstr, $error, "check error message");
  }
}

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;
       }
     };
}
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)