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