PNG/t/10png.t

   1 #!perl -w
   2 use strict;
   3 use Imager qw(:all);
   4 use Test::More;
   5 use Imager::Test qw(test_image_raw test_image is_image is_imaged test_image_16 test_image_double);
   6
   7 my $debug_writes = 1;
   8
   9 -d "testout" or mkdir "testout";
  10
  11 init_log("testout/t102png.log",1);
  12
  13 plan tests => 248;
  14
  15 # this loads Imager::File::PNG too
  16 ok($Imager::formats{"png"}, "must have png format");
  17
  18 diag("Library version " . Imager::File::PNG::i_png_lib_version());
  19
  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);
  23
  24 my $img    = test_image_raw();
  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
  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));
  38 ok(Imager::File::PNG::i_writepng_wiol($img, $IO), "write")
  39   or diag(Imager->_error_as_msg());
  40 close(FH);
  41
  42 open(FH,"testout/t102.png") || die "cannot open testout/t102.png\n";
  43 binmode(FH);
  44 $IO = Imager::io_new_fd(fileno(FH));
  45 my $cmpimg = Imager::File::PNG::i_readpng_wiol($IO);
  46 close(FH);
  47 ok($cmpimg, "read png");
  48
  49 print "# png average mean square pixel difference: ",sqrt(i_img_diff($img,$cmpimg))/150*150,"\n";
  50 is(i_img_diff($img, $cmpimg), 0, "compare saved and original images");
  51
  52 my %tags = map { Imager::i_tags_get($cmpimg, $_) }
  53   0..Imager::i_tags_count($cmpimg) - 1;
  54 ok(abs($tags{i_xres} - 300) < 1, "i_xres: $tags{i_xres}");
  55 ok(abs($tags{i_yres} - 200) < 1, "i_yres: $tags{i_yres}");
  56 is($tags{i_format}, "png", "i_format: $tags{i_format}");
  57
  58 open FH, "> testout/t102_trans.png"
  59   or die "Cannot open testout/t102_trans.png: $!";
  60 binmode FH;
  61 $IO = Imager::io_new_fd(fileno(FH));
  62 ok(Imager::File::PNG::i_writepng_wiol($timg, $IO), "write tranparent");
  63 close FH;
  64
  65 open FH,"testout/t102_trans.png"
  66   or die "cannot open testout/t102_trans.png\n";
  67 binmode(FH);
  68 $IO = Imager::io_new_fd(fileno(FH));
  69 $cmpimg = Imager::File::PNG::i_readpng_wiol($IO);
  70 ok($cmpimg, "read transparent");
  71 close(FH);
  72
  73 print "# png average mean square pixel difference: ",sqrt(i_img_diff($timg,$cmpimg))/150*150,"\n";
  74 is(i_img_diff($timg, $cmpimg), 0, "compare saved and original transparent");
  75
  76 # REGRESSION TEST
  77 # png.c 1.1 would produce an incorrect image when loading images with
  78 # less than 8 bits/pixel with a transparent palette entry
  79 open FH, "< testimg/palette.png"
  80   or die "cannot open testimg/palette.png: $!\n";
  81 binmode FH;
  82 $IO = Imager::io_new_fd(fileno(FH));
  83 # 1.1 may segfault here (it does with libefence)
  84 my $pimg = Imager::File::PNG::i_readpng_wiol($IO);
  85 ok($pimg, "read transparent paletted image");
  86 close FH;
  87
  88 open FH, "< testimg/palette_out.png"
  89   or die "cannot open testimg/palette_out.png: $!\n";
  90 binmode FH;
  91 $IO = Imager::io_new_fd(fileno(FH));
  92 my $poimg = Imager::File::PNG::i_readpng_wiol($IO);
  93 ok($poimg, "read palette_out image");
  94 close FH;
  95 if (!is(i_img_diff($pimg, $poimg), 0, "images the same")) {
  96   print <<EOS;
  97 # this tests a bug in Imager's png.c v1.1
  98 # if also tickles a bug in libpng before 1.0.5, so you may need to
  99 # upgrade libpng
 100 EOS
 101 }
 102
 103 { # check file limits are checked
 104   my $limit_file = "testout/t102.png";
 105   ok(Imager->set_file_limits(reset=>1, width=>149), "set width limit 149");
 106   my $im = Imager->new;
 107   ok(!$im->read(file=>$limit_file),
 108      "should fail read due to size limits");
 109   print "# ",$im->errstr,"\n";
 110   like($im->errstr, qr/image width/, "check message");
 111
 112   ok(Imager->set_file_limits(reset=>1, height=>149), "set height limit 149");
 113   ok(!$im->read(file=>$limit_file),
 114      "should fail read due to size limits");
 115   print "# ",$im->errstr,"\n";
 116   like($im->errstr, qr/image height/, "check message");
 117
 118   ok(Imager->set_file_limits(reset=>1, width=>150), "set width limit 150");
 119   ok($im->read(file=>$limit_file),
 120      "should succeed - just inside width limit");
 121   ok(Imager->set_file_limits(reset=>1, height=>150), "set height limit 150");
 122   ok($im->read(file=>$limit_file),
 123      "should succeed - just inside height limit");
 124
 125   # 150 x 150 x 3 channel image uses 67500 bytes
 126   ok(Imager->set_file_limits(reset=>1, bytes=>67499),
 127      "set bytes limit 67499");
 128   ok(!$im->read(file=>$limit_file),
 129        "should fail - too many bytes");
 130   print "# ",$im->errstr,"\n";
 131     like($im->errstr, qr/storage size/, "check error message");
 132   ok(Imager->set_file_limits(reset=>1, bytes=>67500),
 133      "set bytes limit 67500");
 134   ok($im->read(file=>$limit_file),
 135      "should succeed - just inside bytes limit");
 136   Imager->set_file_limits(reset=>1);
 137 }
 138
 139 { # check if the read_multi fallback works
 140   my @imgs = Imager->read_multi(file => 'testout/t102.png');
 141   is(@imgs, 1, "check the image was loaded");
 142   is(i_img_diff($img, $imgs[0]), 0, "check image matches");
 143
 144   # check the write_multi fallback
 145   ok(Imager->write_multi({ file => 'testout/t102m.png', type => 'png' },
 146                          @imgs),
 147        'test write_multi() callback');
 148
 149   # check that we fail if we actually write 2
 150   ok(!Imager->write_multi({ file => 'testout/t102m.png', type => 'png' },
 151                            @imgs, @imgs),
 152      'test write_multi() callback failure');
 153 }
 154
 155 { # check close failures are handled correctly
 156   my $im = test_image();
 157   my $fail_close = sub {
 158     Imager::i_push_error(0, "synthetic close failure");
 159     print "# closecb called\n";
 160     return 0;
 161   };
 162   ok(!$im->write(type => "png", callback => sub { 1 },
 163                  closecb => $fail_close),
 164      "check failing close fails");
 165     like($im->errstr, qr/synthetic close failure/,
 166          "check error message");
 167 }
 168
 169 {
 170   ok(grep($_ eq 'png', Imager->read_types), "check png in read types");
 171   ok(grep($_ eq 'png', Imager->write_types), "check png in write types");
 172 }
 173
 174 { # read error reporting
 175   my $im = Imager->new;
 176   ok(!$im->read(file => "testimg/badcrc.png", type => "png"),
 177      "read png with bad CRC chunk should fail");
 178   is($im->errstr, "IHDR: CRC error", "check error message");
 179 }
 180
 181 { # write error reporting
 182   my $im = test_image();
 183   ok(!$im->write(type => "png", callback => limited_write(1), buffered => 0),
 184      "write limited to 1 byte should fail");
 185   is($im->errstr, "Write error on an iolayer source.: limit reached",
 186      "check error message");
 187 }
 188
 189 SKIP:
 190 { # https://sourceforge.net/tracker/?func=detail&aid=3314943&group_id=5624&atid=105624
 191   # large images
 192   Imager::File::PNG::i_png_lib_version() >= 10503
 193       or skip("older libpng limits image sizes", 12);
 194
 195   {
 196     my $im = Imager->new(xsize => 1000001, ysize => 1, channels => 1);
 197     ok($im, "make a wide image");
 198     my $data;
 199     ok($im->write(data => \$data, type => "png"),
 200        "write wide image as png")
 201       or diag("write wide: " . $im->errstr);
 202     my $im2 = Imager->new;
 203     ok($im->read(data => $data, type => "png"),
 204        "read wide image as png")
 205       or diag("read wide: " . $im->errstr);
 206     is($im->getwidth, 1000001, "check width");
 207     is($im->getheight, 1, "check height");
 208     is($im->getchannels, 1, "check channels");
 209   }
 210
 211   {
 212     my $im = Imager->new(xsize => 1, ysize => 1000001, channels => 1);
 213     ok($im, "make a tall image");
 214     my $data;
 215     ok($im->write(data => \$data, type => "png"),
 216        "write wide image as png")
 217       or diag("write tall: " . $im->errstr);
 218     my $im2 = Imager->new;
 219     ok($im->read(data => $data, type => "png"),
 220        "read tall image as png")
 221       or diag("read tall: " . $im->errstr);
 222     is($im->getwidth, 1, "check width");
 223     is($im->getheight, 1000001, "check height");
 224     is($im->getchannels, 1, "check channels");
 225   }
 226 }
 227
 228 { # test grayscale read as greyscale
 229   my $im = Imager->new;
 230   ok($im->read(file => "testimg/gray.png", type => "png"),
 231      "read grayscale");
 232   is($im->getchannels, 1, "check channel count");
 233   is($im->type, "direct", "check type");
 234   is($im->bits, 8, "check bits");
 235   is($im->tags(name => "png_bits"), 8, "check png_bits tag");
 236   is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
 237 }
 238
 239 { # test grayscale + alpha read as greyscale + alpha
 240   my $im = Imager->new;
 241   ok($im->read(file => "testimg/graya.png", type => "png"),
 242      "read grayscale + alpha");
 243   is($im->getchannels, 2, "check channel count");
 244   is($im->type, "direct", "check type");
 245   is($im->bits, 8, "check bits");
 246   is($im->tags(name => "png_bits"), 8, "check png_bits tag");
 247   is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
 248 }
 249
 250 { # test paletted + alpha read as paletted
 251   my $im = Imager->new;
 252   ok($im->read(file => "testimg/paltrans.png", type => "png"),
 253      "read paletted with alpha");
 254   is($im->getchannels, 4, "check channel count");
 255   is($im->type, "paletted", "check type");
 256   is($im->tags(name => "png_bits"), 8, "check png_bits tag");
 257   is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
 258 }
 259
 260 { # test paletted read as paletted
 261   my $im = Imager->new;
 262   ok($im->read(file => "testimg/pal.png", type => "png"),
 263      "read paletted");
 264   is($im->getchannels, 3, "check channel count");
 265   is($im->type, "paletted", "check type");
 266   is($im->tags(name => "png_bits"), 8, "check png_bits tag");
 267   is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
 268 }
 269
 270 { # test 16-bit rgb read as 16 bit
 271   my $im = Imager->new;
 272   ok($im->read(file => "testimg/rgb16.png", type => "png"),
 273      "read 16-bit rgb");
 274   is($im->getchannels, 3, "check channel count");
 275   is($im->type, "direct", "check type");
 276   is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
 277   is($im->bits, 16, "check bits");
 278   is($im->tags(name => "png_bits"), 16, "check png_bits tag");
 279 }
 280
 281 { # test 1-bit grey read as mono
 282   my $im = Imager->new;
 283   ok($im->read(file => "testimg/bilevel.png", type => "png"),
 284      "read bilevel png");
 285   is($im->getchannels, 1, "check channel count");
 286   is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
 287   is($im->type, "paletted", "check type");
 288   ok($im->is_bilevel, "should be bilevel");
 289   is($im->tags(name => "png_bits"), 1, "check png_bits tag");
 290 }
 291
 292 SKIP:
 293 { # test interlaced read as interlaced and matches original
 294   my $im_i = Imager->new(file => "testimg/rgb8i.png", filetype => "png");
 295   ok($im_i, "read interlaced")
 296     or skip("Could not read rgb8i.png: " . Imager->errstr, 7);
 297   is($im_i->getchannels, 3, "check channel count");
 298   is($im_i->type, "direct", "check type");
 299   is($im_i->tags(name => "png_bits"), 8, "check png_bits");
 300   is($im_i->tags(name => "png_interlace"), 1, "check png_interlace");
 301
 302   my $im = Imager->new(file => "testimg/rgb8.png", filetype => "png");
 303   ok($im, "read non-interlaced")
 304     or skip("Could not read testimg/rgb8.png: " . Imager->errstr, 2);
 305   is($im->tags(name => "png_interlace"), 0, "check png_interlace");
 306   is_image($im_i, $im, "compare interlaced and non-interlaced");
 307 }
 308
 309 {
 310   my @match =
 311     (
 312      [ "cover.png", "coveri.png" ],
 313      [ "cover16.png", "cover16i.png" ],
 314      [ "coverpal.png", "coverpali.png" ],
 315     );
 316   for my $match (@match) {
 317     my ($normal, $interlace) = @$match;
 318
 319     my $n_im = Imager->new(file => "testimg/$normal");
 320     ok($n_im, "read $normal")
 321       or diag "reading $normal: ", Imager->errstr;
 322     my $i_im = Imager->new(file => "testimg/$interlace");
 323     ok($i_im, "read $interlace")
 324       or diag "reading $interlace: ", Imager->errstr;
 325   SKIP:
 326     {
 327       $n_im && $i_im
 328         or skip("Couldn't read a file", 1);
 329       is_image($i_im, $n_im, "check normal and interlace files read the same");
 330     }
 331   }
 332 }
 333
 334 {
 335   my $interlace = 0;
 336   for my $name ("cover.png", "coveri.png") {
 337   SKIP: {
 338       my $im = Imager->new(file => "testimg/$name");
 339       ok($im, "read $name")
 340         or diag "Failed to read $name: ", Imager->errstr;
 341       $im
 342         or skip("Couldn't load $name", 5);
 343       is($im->tags(name => "i_format"), "png", "$name: i_format");
 344       is($im->tags(name => "png_bits"), 8, "$name: png_bits");
 345       is($im->tags(name => "png_interlace"), $interlace,
 346          "$name: png_interlace");
 347       is($im->getchannels, 4, "$name: four channels");
 348       is($im->type, "direct", "$name: direct type");
 349
 350       is_deeply([ $im->getsamples(y => 0, width => 5) ],
 351                 [ ( 255, 255, 0, 255 ), ( 255, 255, 0, 191 ),
 352                   ( 255, 255, 0, 127 ), ( 255, 255, 0, 63 ),
 353                   ( 0, 0, 0, 0) ],
 354                 "$name: check expected samples row 0");
 355       is_deeply([ $im->getsamples(y => 1, width => 5) ],
 356                 [ ( 255, 0, 0, 255 ), ( 255, 0, 0, 191 ),
 357                   ( 255, 0, 0, 127 ), ( 255, 0, 0, 63 ),
 358                   ( 0, 0, 0, 0) ],
 359                 "$name: check expected samples row 1");
 360     }
 361     $interlace = 1;
 362   }
 363 }
 364
 365 {
 366   my $interlace = 0;
 367   for my $name ("coverpal.png", "coverpali.png") {
 368   SKIP: {
 369       my $im = Imager->new(file => "testimg/$name");
 370       ok($im, "read $name")
 371         or diag "Failed to read $name: ", Imager->errstr;
 372       $im
 373         or skip("Couldn't load $name", 5);
 374       is($im->tags(name => "i_format"), "png", "$name: i_format");
 375       is($im->tags(name => "png_bits"), 4, "$name: png_bits");
 376       is($im->tags(name => "png_interlace"), $interlace,
 377          "$name: png_interlace");
 378       is($im->getchannels, 4, "$name: four channels");
 379       is($im->type, "paletted", "$name: paletted type");
 380
 381       is_deeply([ $im->getsamples(y => 0, width => 5) ],
 382                 [ ( 255, 255, 0, 255 ), ( 255, 255, 0, 191 ),
 383                   ( 255, 255, 0, 127 ), ( 255, 255, 0, 63 ),
 384                   ( 0, 0, 0, 0) ],
 385                 "$name: check expected samples row 0");
 386       is_deeply([ $im->getsamples(y => 1, width => 5) ],
 387                 [ ( 255, 0, 0, 255 ), ( 255, 0, 0, 191 ),
 388                   ( 255, 0, 0, 127 ), ( 255, 0, 0, 63 ),
 389                   ( 0, 0, 0, 0) ],
 390                 "$name: check expected samples row 1");
 391     }
 392     $interlace = 1;
 393   }
 394 }
 395
 396 {
 397   my $interlace = 0;
 398   for my $name ("cover16.png", "cover16i.png") {
 399   SKIP: {
 400       my $im = Imager->new(file => "testimg/$name");
 401       ok($im, "read $name")
 402         or diag "Failed to read $name: ", Imager->errstr;
 403       $im
 404         or skip("Couldn't load $name", 5);
 405       is($im->tags(name => "i_format"), "png", "$name: i_format");
 406       is($im->tags(name => "png_bits"), 16, "$name: png_bits");
 407       is($im->tags(name => "png_interlace"), $interlace,
 408          "$name: png_interlace");
 409       is($im->getchannels, 4, "$name: four channels");
 410       is($im->type, "direct", "$name: direct type");
 411
 412       is_deeply([ $im->getsamples(y => 0, width => 5, type => "16bit") ],
 413                 [ ( 65535, 65535, 0, 65535 ), ( 65535, 65535, 0, 49087 ),
 414                   ( 65535, 65535, 0, 32639 ), ( 65535, 65535, 0, 16191 ),
 415                   ( 65535, 65535, 65535, 0) ],
 416                 "$name: check expected samples row 0");
 417       is_deeply([ $im->getsamples(y => 1, width => 5, type => "16bit") ],
 418                 [ ( 65535, 0, 0, 65535 ), ( 65535, 0, 0, 49087 ),
 419                   ( 65535, 0, 0, 32639 ), ( 65535, 0, 0, 16191 ),
 420                   ( 65535, 65535, 65535, 0) ],
 421                 "$name: check expected samples row 1");
 422     }
 423     $interlace = 1;
 424   }
 425 }
 426
 427 {
 428   my $pim = Imager->new(xsize => 5, ysize => 2, channels => 3, type => "paletted");
 429   ok($pim, "make a 3 channel paletted image");
 430   ok($pim->addcolors(colors => [ qw(000000 FFFFFF FF0000 00FF00 0000FF) ]),
 431      "add some colors");
 432   is($pim->setscanline(y => 0, type => "index",
 433                        pixels => [ 0, 1, 2, 4, 3 ]), 5, "set some pixels");
 434   is($pim->setscanline(y => 1, type => "index",
 435                        pixels => [ 4, 1, 0, 4, 2 ]), 5, "set some more pixels");
 436   ok($pim->write(file => "testout/pal3.png"),
 437      "write to testout/pal3.png")
 438     or diag("Cannot save testout/pal3.png: ".$pim->errstr);
 439   my $in = Imager->new(file => "testout/pal3.png");
 440   ok($in, "read it back in")
 441     or diag("Cann't read pal3.png back: " . Imager->errstr);
 442   is_image($pim, $in, "check it matches");
 443   is($in->type, "paletted", "make sure the result is paletted");
 444   is($in->tags(name => "png_bits"), 4, "4 bit representation");
 445 }
 446
 447 {
 448   # make sure the code that pushes maxed alpha to the end doesn't break
 449   my $pim = Imager->new(xsize => 8, ysize => 2, channels => 4, type => "paletted");
 450   ok($pim, "make a 4 channel paletted image");
 451   ok($pim->addcolors
 452      (colors => [ NC(255, 255, 0, 128), qw(000000 FFFFFF FF0000 00FF00 0000FF),
 453                   NC(0, 0, 0, 0), NC(255, 0, 128, 64) ]),
 454      "add some colors");
 455   is($pim->setscanline(y => 0, type => "index",
 456                        pixels => [ 5, 0, 1, 7, 2, 4, 6, 3 ]), 8,
 457      "set some pixels");
 458   is($pim->setscanline(y => 1, type => "index",
 459                        pixels => [ 7, 4, 6, 1, 0, 4, 2, 5 ]), 8,
 460      "set some more pixels");
 461   ok($pim->write(file => "testout/pal4.png"),
 462      "write to testout/pal4.png")
 463     or diag("Cannot save testout/pal4.png: ".$pim->errstr);
 464   my $in = Imager->new(file => "testout/pal4.png");
 465   ok($in, "read it back in")
 466     or diag("Cann't read pal4.png back: " . Imager->errstr);
 467   is_image($pim, $in, "check it matches");
 468   is($in->type, "paletted", "make sure the result is paletted");
 469   is($in->tags(name => "png_bits"), 4, "4 bit representation");
 470 }
 471
 472 {
 473   my $pim = Imager->new(xsize => 8, ysize => 2, channels => 1, type => "paletted");
 474   ok($pim, "make a 1 channel paletted image");
 475   ok($pim->addcolors(colors => [ map NC($_, 0, 0), 0, 7, 127, 255 ]),
 476      "add some colors^Wgreys");
 477   is($pim->setscanline(y => 0, type => "index",
 478                        pixels => [ 0, 2, 1, 3, 2, 1, 0, 3 ]), 8,
 479      "set some pixels");
 480   is($pim->setscanline(y => 1, type => "index",
 481                        pixels => [ 3, 0, 2, 1, 0, 0, 2, 3 ]), 8,
 482      "set some more pixels");
 483   ok($pim->write(file => "testout/pal1.png"),
 484      "write to testout/pal1.png")
 485     or diag("Cannot save testout/pal1.png: ".$pim->errstr);
 486   my $in = Imager->new(file => "testout/pal1.png");
 487   ok($in, "read it back in")
 488     or diag("Cann't read pal1.png back: " . Imager->errstr);
 489   # PNG doesn't have a paletted greyscale type, so it's written as
 490   # paletted color, convert our source image for the comparison
 491   my $cmpim = $pim->convert(preset => "rgb");
 492   is_image($in, $cmpim, "check it matches");
 493   is($in->type, "paletted", "make sure the result is paletted");
 494   is($in->tags(name => "png_bits"), 2, "2 bit representation");
 495 }
 496
 497 {
 498   my $pim = Imager->new(xsize => 8, ysize => 2, channels => 2, type => "paletted");
 499   ok($pim, "make a 2 channel paletted image");
 500   ok($pim->addcolors(colors => [ NC(0, 255, 0), NC(128, 255, 0), NC(255, 255, 0), NC(128, 128, 0) ]),
 501      "add some colors^Wgreys")
 502     or diag("adding colors: " . $pim->errstr);
 503   is($pim->setscanline(y => 0, type => "index",
 504                        pixels => [ 0, 2, 1, 3, 2, 1, 0, 3 ]), 8,
 505      "set some pixels");
 506   is($pim->setscanline(y => 1, type => "index",
 507                        pixels => [ 3, 0, 2, 1, 0, 0, 2, 3 ]), 8,
 508      "set some more pixels");
 509   ok($pim->write(file => "testout/pal2.png"),
 510      "write to testout/pal2.png")
 511     or diag("Cannot save testout/pal2.png: ".$pim->errstr);
 512   my $in = Imager->new(file => "testout/pal2.png");
 513   ok($in, "read it back in")
 514     or diag("Can't read pal1.png back: " . Imager->errstr);
 515   # PNG doesn't have a paletted greyscale type, so it's written as
 516   # paletted color, convert our source image for the comparison
 517   my $cmpim = $pim->convert(preset => "rgb");
 518   is_image($in, $cmpim, "check it matches");
 519   is($in->type, "paletted", "make sure the result is paletted");
 520   is($in->tags(name => "png_bits"), 2, "2 bit representation");
 521 }
 522
 523 {
 524   my $imbase = test_image();
 525   my $mono = $imbase->convert(preset => "gray")
 526     ->to_paletted(make_colors => "mono", translate => "errdiff");
 527
 528   ok($mono->write(file => "testout/bilevel.png"),
 529      "write bilevel.png");
 530   my $in = Imager->new(file => "testout/bilevel.png");
 531   ok($in, "read it back in")
 532     or diag("Can't read bilevel.png: " . Imager->errstr);
 533   is_image($in, $mono, "check it matches");
 534   is($in->type, "paletted", "make sure the result is paletted");
 535   is($in->tags(name => "png_bits"), 1, "1 bit representation");
 536 }
 537
 538 SKIP:
 539 {
 540   my $im = test_image_16();
 541   ok($im->write(file => "testout/rgb16.png", type => "png"),
 542      "write 16-bit/sample image")
 543     or diag("Could not write rgb16.png: ".$im->errstr);
 544   my $in = Imager->new(file => "testout/rgb16.png")
 545     or diag("Could not read rgb16.png: ".Imager->errstr);
 546   ok($in, "read rgb16.png back in")
 547     or skip("Could not load image to check", 4);
 548   is_imaged($in, $im, 0, "check image matches");
 549   is($in->bits, 16, "check we got a 16-bit image");
 550   is($in->type, "direct", "check it's direct");
 551   is($in->tags(name => "png_bits"), 16, "check png_bits");
 552 }
 553
 554 SKIP:
 555 {
 556   my $im = test_image_double();
 557   my $cmp = $im->to_rgb16;
 558   ok($im->write(file => "testout/rgbdbl.png", type => "png"),
 559      "write double/sample image - should write as 16-bit/sample")
 560     or diag("Could not write rgbdbl.png: ".$im->errstr);
 561   my $in = Imager->new(file => "testout/rgbdbl.png")
 562     or diag("Could not read rgbdbl.png: ".Imager->errstr);
 563   ok($in, "read pngdbl.png back in")
 564     or skip("Could not load image to check", 4);
 565   is_imaged($in, $cmp, 0, "check image matches");
 566   is($in->bits, 16, "check we got a 16-bit image");
 567   is($in->type, "direct", "check it's direct");
 568   is($in->tags(name => "png_bits"), 16, "check png_bits");
 569 }
 570
 571 SKIP:
 572 {
 573   my $im = Imager->new(file => "testimg/comment.png");
 574   ok($im, "read file with comment")
 575     or diag("Cannot read comment.png: ".Imager->errstr);
 576   $im
 577     or skip("Cannot test tags file I can't read", 5);
 578   is($im->tags(name => "i_comment"), "Test comment", "check i_comment");
 579   is($im->tags(name => "png_interlace"), "0", "no interlace");
 580   is($im->tags(name => "png_interlace_name"), "none", "no interlace (text)");
 581   is($im->tags(name => "png_srgb_intent"), "0", "srgb perceptual");
 582   is($im->tags(name => "png_time"), "2012-04-16T07:37:36",
 583      "modification time");
 584   is($im->tags(name => "i_background"), "color(255,255,255,255)",
 585      "background color");
 586 }
 587
 588 SKIP:
 589 { # test tag writing
 590   my $im = Imager->new(xsize => 1, ysize => 1);
 591   ok($im->write(file => "testout/tags.png",
 592                 i_comment => "A Comment",
 593                 png_author => "An Author",
 594                 png_author_compressed => 1,
 595                 png_copyright => "A Copyright",
 596                 png_creation_time => "16 April 2012 22:56:30+1000",
 597                 png_description => "A Description",
 598                 png_disclaimer => "A Disclaimer",
 599                 png_software => "Some Software",
 600                 png_source => "A Source",
 601                 png_title => "A Title",
 602                 png_warning => "A Warning",
 603                 png_text0_key => "Custom Key",
 604                 png_text0_text => "Custom Value",
 605                 png_text0_compressed => 1,
 606                 png_text1_key => "Custom Key2",
 607                 png_text1_text => "Another Custom Value",
 608                 png_time => "2012-04-20T00:15:10",
 609                ),
 610      "write with many tags")
 611     or diag("Cannot write with many tags: ", $im->errstr);
 612
 613   my $imr = Imager->new(file => "testout/tags.png");
 614   ok($imr, "read it back in")
 615     or skip("Couldn't read it back: ". Imager->errstr, 1);
 616
 617   is_deeply({ map @$_, $imr->tags },
 618             {
 619              i_format => "png",
 620              i_comment => "A Comment",
 621              png_author => "An Author",
 622              png_author_compressed => 1,
 623              png_copyright => "A Copyright",
 624              png_creation_time => "16 April 2012 22:56:30+1000",
 625              png_description => "A Description",
 626              png_disclaimer => "A Disclaimer",
 627              png_software => "Some Software",
 628              png_source => "A Source",
 629              png_title => "A Title",
 630              png_warning => "A Warning",
 631              png_text0_key => "Custom Key",
 632              png_text0_text => "Custom Value",
 633              png_text0_compressed => 1,
 634              png_text0_type => "text",
 635              png_text1_key => "Custom Key2",
 636              png_text1_text => "Another Custom Value",
 637              png_text1_type => "text",
 638              png_time => "2012-04-20T00:15:10",
 639              png_interlace => 0,
 640              png_interlace_name => "none",
 641              png_bits => 8,
 642             }, "check tags are what we expected");
 643 }
 644
 645 SKIP:
 646 { # cHRM test
 647   my $im = Imager->new(xsize => 1, ysize => 1);
 648   ok($im->write(file => "testout/tagschrm.png", type => "png",
 649                 png_chroma_white_x => 0.3,
 650                 png_chroma_white_y => 0.32,
 651                 png_chroma_red_x => 0.7,
 652                 png_chroma_red_y => 0.28,
 653                 png_chroma_green_x => 0.075,
 654                 png_chroma_green_y => 0.8,
 655                 png_chroma_blue_x => 0.175,
 656                 png_chroma_blue_y => 0.05),
 657      "write cHRM chunk");
 658   my $imr = Imager->new(file => "testout/tagschrm.png", ftype => "png");
 659   ok($imr, "read tagschrm.png")
 660     or diag("reading tagschrm.png: ".Imager->errstr);
 661   $imr
 662     or skip("read of tagschrm.png failed", 1);
 663   is_deeply({ map @$_, $imr->tags },
 664             {
 665              i_format => "png",
 666              png_interlace => 0,
 667              png_interlace_name => "none",
 668              png_bits => 8,
 669              png_chroma_white_x => 0.3,
 670              png_chroma_white_y => 0.32,
 671              png_chroma_red_x => 0.7,
 672              png_chroma_red_y => 0.28,
 673              png_chroma_green_x => 0.075,
 674              png_chroma_green_y => 0.8,
 675              png_chroma_blue_x => 0.175,
 676              png_chroma_blue_y => 0.05,
 677             }, "check chroma tags written");
 678 }
 679
 680 { # gAMA
 681   my $im = Imager->new(xsize => 1, ysize => 1);
 682   ok($im->write(file => "testout/tagsgama.png", type => "png",
 683                png_gamma => 2.22),
 684      "write with png_gammma tag");
 685   my $imr = Imager->new(file => "testout/tagsgama.png", ftype => "png");
 686   ok($imr, "read tagsgama.png")
 687     or diag("reading tagsgama.png: ".Imager->errstr);
 688   $imr
 689     or skip("read of tagsgama.png failed", 1);
 690   is_deeply({ map @$_, $imr->tags },
 691             {
 692              i_format => "png",
 693              png_interlace => 0,
 694              png_interlace_name => "none",
 695              png_bits => 8,
 696              png_gamma => "2.22",
 697             }, "check gamma tag written");
 698 }
 699
 700 { # various bad tag failures
 701   my @tests =
 702     (
 703      [
 704       [ png_chroma_white_x => 0.5 ],
 705       "all png_chroma_* tags must be supplied or none"
 706      ],
 707      [
 708       [ png_srgb_intent => 4 ],
 709       "tag png_srgb_intent out of range"
 710      ],
 711      [
 712       [ i_comment => "test\0with nul" ],
 713       "tag i_comment may not contain NUL characters"
 714      ],
 715      [
 716       [ png_text0_key => "" ],
 717       "tag png_text0_key must be between 1 and 79 characters in length"
 718      ],
 719      [
 720       [ png_text0_key => ("x" x 80) ],
 721       "tag png_text0_key must be between 1 and 79 characters in length"
 722      ],
 723      [
 724       [ png_text0_key => " x" ],
 725       "tag png_text0_key may not contain leading or trailing spaces"
 726      ],
 727      [
 728       [ png_text0_key => "x " ],
 729       "tag png_text0_key may not contain leading or trailing spaces"
 730      ],
 731      [
 732       [ png_text0_key => "x  y" ],
 733       "tag png_text0_key may not contain consecutive spaces"
 734      ],
 735      [
 736       [ png_text0_key => "\x7F" ],
 737       "tag png_text0_key may only contain Latin1 characters 32-126, 161-255"
 738      ],
 739      [
 740       [ png_text0_key => "x", png_text0_text => "a\0b" ],
 741       "tag png_text0_text may not contain NUL characters"
 742      ],
 743      [
 744       [ png_text0_key => "test" ],
 745       "tag png_text0_key found but not png_text0_text"
 746      ],
 747      [
 748       [ png_text0_text => "test" ],
 749       "tag png_text0_text found but not png_text0_key"
 750      ],
 751      [
 752       [ png_time => "bad format" ],
 753       "png_time must be formatted 'y-m-dTh:m:s'"
 754      ],
 755      [
 756       [ png_time => "2012-13-01T00:00:00" ],
 757       "invalid date/time for png_time"
 758      ],
 759     );
 760   my $im = Imager->new(xsize => 1, ysize => 1);
 761   for my $test (@tests) {
 762     my ($tags, $error) = @$test;
 763     my $im2 = $im->copy;
 764     my $data;
 765     ok(!$im2->write(data => \$data, type => "png", @$tags),
 766        "expect $error");
 767     is($im2->errstr, $error, "check error message");
 768   }
 769 }
 770
 771 sub limited_write {
 772   my ($limit) = @_;
 773
 774   return
 775      sub {
 776        my ($data) = @_;
 777        $limit -= length $data;
 778        if ($limit >= 0) {
 779          print "# write of ", length $data, " bytes successful ($limit left)\n" if $debug_writes;
 780          return 1;
 781        }
 782        else {
 783          print "# write of ", length $data, " bytes failed\n";
 784          Imager::i_push_error(0, "limit reached");
 785          return;
 786        }
 787      };
 788 }
 789