RT #94717 libpng 1.6.10 no longer considers CRC errors benign
[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 => 251;
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", 3;
187
188  SKIP:
189   {
190     Imager::File::PNG::i_png_lib_version() < 10610
191         or skip "1.6.10 and later treat CRC errors as non-benign", 1;
192     my $im = Imager->new;
193     ok($im->read(file => "testimg/badcrc.png", type => "png",
194                  png_ignore_benign_errors => 1),
195        "read bad crc with png_ignore_benign_errors");
196   }
197
198   my $im = Imager->new;
199   ok($im->read(file => "testimg/bipalette.png", type => "png",
200                png_ignore_benign_errors => 1),
201        "read grey image with palette with png_ignore_benign_errors");
202   ok(!$im->read(file => "testimg/bipalette.png", type => "png",
203                png_ignore_benign_errors => 0),
204        "read grey image with palette without png_ignore_benign_errors should fail");
205 }
206
207 { # write error reporting
208   my $im = test_image();
209   ok(!$im->write(type => "png", callback => limited_write(1), buffered => 0),
210      "write limited to 1 byte should fail");
211   is($im->errstr, "Write error on an iolayer source.: limit reached",
212      "check error message");
213 }
214
215 SKIP:
216 { # https://sourceforge.net/tracker/?func=detail&aid=3314943&group_id=5624&atid=105624
217   # large images
218   Imager::File::PNG::i_png_lib_version() >= 10503
219       or skip("older libpng limits image sizes", 12);
220
221   {
222     my $im = Imager->new(xsize => 1000001, ysize => 1, channels => 1);
223     ok($im, "make a wide image");
224     my $data;
225     ok($im->write(data => \$data, type => "png"),
226        "write wide image as png")
227       or diag("write wide: " . $im->errstr);
228     my $im2 = Imager->new;
229     ok($im->read(data => $data, type => "png"),
230        "read wide image as png")
231       or diag("read wide: " . $im->errstr);
232     is($im->getwidth, 1000001, "check width");
233     is($im->getheight, 1, "check height");
234     is($im->getchannels, 1, "check channels");
235   }
236
237   {
238     my $im = Imager->new(xsize => 1, ysize => 1000001, channels => 1);
239     ok($im, "make a tall image");
240     my $data;
241     ok($im->write(data => \$data, type => "png"),
242        "write wide image as png")
243       or diag("write tall: " . $im->errstr);
244     my $im2 = Imager->new;
245     ok($im->read(data => $data, type => "png"),
246        "read tall image as png")
247       or diag("read tall: " . $im->errstr);
248     is($im->getwidth, 1, "check width");
249     is($im->getheight, 1000001, "check height");
250     is($im->getchannels, 1, "check channels");
251   }
252 }
253
254 { # test grayscale read as greyscale
255   my $im = Imager->new;
256   ok($im->read(file => "testimg/gray.png", type => "png"),
257      "read grayscale");
258   is($im->getchannels, 1, "check channel count");
259   is($im->type, "direct", "check type");
260   is($im->bits, 8, "check bits");
261   is($im->tags(name => "png_bits"), 8, "check png_bits tag");
262   is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
263 }
264
265 { # test grayscale + alpha read as greyscale + alpha
266   my $im = Imager->new;
267   ok($im->read(file => "testimg/graya.png", type => "png"),
268      "read grayscale + alpha");
269   is($im->getchannels, 2, "check channel count");
270   is($im->type, "direct", "check type");
271   is($im->bits, 8, "check bits");
272   is($im->tags(name => "png_bits"), 8, "check png_bits tag");
273   is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
274 }
275
276 { # test paletted + alpha read as paletted
277   my $im = Imager->new;
278   ok($im->read(file => "testimg/paltrans.png", type => "png"),
279      "read paletted with alpha");
280   is($im->getchannels, 4, "check channel count");
281   is($im->type, "paletted", "check type");
282   is($im->tags(name => "png_bits"), 8, "check png_bits tag");
283   is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
284 }
285
286 { # test paletted read as paletted
287   my $im = Imager->new;
288   ok($im->read(file => "testimg/pal.png", type => "png"),
289      "read paletted");
290   is($im->getchannels, 3, "check channel count");
291   is($im->type, "paletted", "check type");
292   is($im->tags(name => "png_bits"), 8, "check png_bits tag");
293   is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
294 }
295
296 { # test 16-bit rgb read as 16 bit
297   my $im = Imager->new;
298   ok($im->read(file => "testimg/rgb16.png", type => "png"),
299      "read 16-bit rgb");
300   is($im->getchannels, 3, "check channel count");
301   is($im->type, "direct", "check type");
302   is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
303   is($im->bits, 16, "check bits");
304   is($im->tags(name => "png_bits"), 16, "check png_bits tag");
305 }
306
307 { # test 1-bit grey read as mono
308   my $im = Imager->new;
309   ok($im->read(file => "testimg/bilevel.png", type => "png"),
310      "read bilevel png");
311   is($im->getchannels, 1, "check channel count");
312   is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
313   is($im->type, "paletted", "check type");
314   ok($im->is_bilevel, "should be bilevel");
315   is($im->tags(name => "png_bits"), 1, "check png_bits tag");
316 }
317
318 SKIP:
319 { # test interlaced read as interlaced and matches original
320   my $im_i = Imager->new(file => "testimg/rgb8i.png", filetype => "png");
321   ok($im_i, "read interlaced")
322     or skip("Could not read rgb8i.png: " . Imager->errstr, 7);
323   is($im_i->getchannels, 3, "check channel count");
324   is($im_i->type, "direct", "check type");
325   is($im_i->tags(name => "png_bits"), 8, "check png_bits");
326   is($im_i->tags(name => "png_interlace"), 1, "check png_interlace");
327
328   my $im = Imager->new(file => "testimg/rgb8.png", filetype => "png");
329   ok($im, "read non-interlaced")
330     or skip("Could not read testimg/rgb8.png: " . Imager->errstr, 2);
331   is($im->tags(name => "png_interlace"), 0, "check png_interlace");
332   is_image($im_i, $im, "compare interlaced and non-interlaced");
333 }
334
335 {
336   my @match =
337     (
338      [ "cover.png", "coveri.png" ],
339      [ "cover16.png", "cover16i.png" ],
340      [ "coverpal.png", "coverpali.png" ],
341     );
342   for my $match (@match) {
343     my ($normal, $interlace) = @$match;
344
345     my $n_im = Imager->new(file => "testimg/$normal");
346     ok($n_im, "read $normal")
347       or diag "reading $normal: ", Imager->errstr;
348     my $i_im = Imager->new(file => "testimg/$interlace");
349     ok($i_im, "read $interlace")
350       or diag "reading $interlace: ", Imager->errstr;
351   SKIP:
352     {
353       $n_im && $i_im
354         or skip("Couldn't read a file", 1);
355       is_image($i_im, $n_im, "check normal and interlace files read the same");
356     }
357   }
358 }
359
360 {
361   my $interlace = 0;
362   for my $name ("cover.png", "coveri.png") {
363   SKIP: {
364       my $im = Imager->new(file => "testimg/$name");
365       ok($im, "read $name")
366         or diag "Failed to read $name: ", Imager->errstr;
367       $im
368         or skip("Couldn't load $name", 5);
369       is($im->tags(name => "i_format"), "png", "$name: i_format");
370       is($im->tags(name => "png_bits"), 8, "$name: png_bits");
371       is($im->tags(name => "png_interlace"), $interlace,
372          "$name: png_interlace");
373       is($im->getchannels, 4, "$name: four channels");
374       is($im->type, "direct", "$name: direct type");
375
376       is_deeply([ $im->getsamples(y => 0, width => 5) ],
377                 [ ( 255, 255, 0, 255 ), ( 255, 255, 0, 191 ),
378                   ( 255, 255, 0, 127 ), ( 255, 255, 0, 63 ),
379                   ( 0, 0, 0, 0) ],
380                 "$name: check expected samples row 0");
381       is_deeply([ $im->getsamples(y => 1, width => 5) ],
382                 [ ( 255, 0, 0, 255 ), ( 255, 0, 0, 191 ),
383                   ( 255, 0, 0, 127 ), ( 255, 0, 0, 63 ),
384                   ( 0, 0, 0, 0) ],
385                 "$name: check expected samples row 1");
386     }
387     $interlace = 1;
388   }
389 }
390
391 {
392   my $interlace = 0;
393   for my $name ("coverpal.png", "coverpali.png") {
394   SKIP: {
395       my $im = Imager->new(file => "testimg/$name");
396       ok($im, "read $name")
397         or diag "Failed to read $name: ", Imager->errstr;
398       $im
399         or skip("Couldn't load $name", 5);
400       is($im->tags(name => "i_format"), "png", "$name: i_format");
401       is($im->tags(name => "png_bits"), 4, "$name: png_bits");
402       is($im->tags(name => "png_interlace"), $interlace,
403          "$name: png_interlace");
404       is($im->getchannels, 4, "$name: four channels");
405       is($im->type, "paletted", "$name: paletted type");
406
407       is_deeply([ $im->getsamples(y => 0, width => 5) ],
408                 [ ( 255, 255, 0, 255 ), ( 255, 255, 0, 191 ),
409                   ( 255, 255, 0, 127 ), ( 255, 255, 0, 63 ),
410                   ( 0, 0, 0, 0) ],
411                 "$name: check expected samples row 0");
412       is_deeply([ $im->getsamples(y => 1, width => 5) ],
413                 [ ( 255, 0, 0, 255 ), ( 255, 0, 0, 191 ),
414                   ( 255, 0, 0, 127 ), ( 255, 0, 0, 63 ),
415                   ( 0, 0, 0, 0) ],
416                 "$name: check expected samples row 1");
417     }
418     $interlace = 1;
419   }
420 }
421
422 {
423   my $interlace = 0;
424   for my $name ("cover16.png", "cover16i.png") {
425   SKIP: {
426       my $im = Imager->new(file => "testimg/$name");
427       ok($im, "read $name")
428         or diag "Failed to read $name: ", Imager->errstr;
429       $im
430         or skip("Couldn't load $name", 5);
431       is($im->tags(name => "i_format"), "png", "$name: i_format");
432       is($im->tags(name => "png_bits"), 16, "$name: png_bits");
433       is($im->tags(name => "png_interlace"), $interlace,
434          "$name: png_interlace");
435       is($im->getchannels, 4, "$name: four channels");
436       is($im->type, "direct", "$name: direct type");
437
438       is_deeply([ $im->getsamples(y => 0, width => 5, type => "16bit") ],
439                 [ ( 65535, 65535, 0, 65535 ), ( 65535, 65535, 0, 49087 ),
440                   ( 65535, 65535, 0, 32639 ), ( 65535, 65535, 0, 16191 ),
441                   ( 65535, 65535, 65535, 0) ],
442                 "$name: check expected samples row 0");
443       is_deeply([ $im->getsamples(y => 1, width => 5, type => "16bit") ],
444                 [ ( 65535, 0, 0, 65535 ), ( 65535, 0, 0, 49087 ),
445                   ( 65535, 0, 0, 32639 ), ( 65535, 0, 0, 16191 ),
446                   ( 65535, 65535, 65535, 0) ],
447                 "$name: check expected samples row 1");
448     }
449     $interlace = 1;
450   }
451 }
452
453 {
454   my $pim = Imager->new(xsize => 5, ysize => 2, channels => 3, type => "paletted");
455   ok($pim, "make a 3 channel paletted image");
456   ok($pim->addcolors(colors => [ qw(000000 FFFFFF FF0000 00FF00 0000FF) ]),
457      "add some colors");
458   is($pim->setscanline(y => 0, type => "index",
459                        pixels => [ 0, 1, 2, 4, 3 ]), 5, "set some pixels");
460   is($pim->setscanline(y => 1, type => "index",
461                        pixels => [ 4, 1, 0, 4, 2 ]), 5, "set some more pixels");
462   ok($pim->write(file => "testout/pal3.png"),
463      "write to testout/pal3.png")
464     or diag("Cannot save testout/pal3.png: ".$pim->errstr);
465   my $in = Imager->new(file => "testout/pal3.png");
466   ok($in, "read it back in")
467     or diag("Cann't read pal3.png back: " . Imager->errstr);
468   is_image($pim, $in, "check it matches");
469   is($in->type, "paletted", "make sure the result is paletted");
470   is($in->tags(name => "png_bits"), 4, "4 bit representation");
471 }
472
473 {
474   # make sure the code that pushes maxed alpha to the end doesn't break
475   my $pim = Imager->new(xsize => 8, ysize => 2, channels => 4, type => "paletted");
476   ok($pim, "make a 4 channel paletted image");
477   ok($pim->addcolors
478      (colors => [ NC(255, 255, 0, 128), qw(000000 FFFFFF FF0000 00FF00 0000FF),
479                   NC(0, 0, 0, 0), NC(255, 0, 128, 64) ]),
480      "add some colors");
481   is($pim->setscanline(y => 0, type => "index",
482                        pixels => [ 5, 0, 1, 7, 2, 4, 6, 3 ]), 8,
483      "set some pixels");
484   is($pim->setscanline(y => 1, type => "index",
485                        pixels => [ 7, 4, 6, 1, 0, 4, 2, 5 ]), 8,
486      "set some more pixels");
487   ok($pim->write(file => "testout/pal4.png"),
488      "write to testout/pal4.png")
489     or diag("Cannot save testout/pal4.png: ".$pim->errstr);
490   my $in = Imager->new(file => "testout/pal4.png");
491   ok($in, "read it back in")
492     or diag("Cann't read pal4.png back: " . Imager->errstr);
493   is_image($pim, $in, "check it matches");
494   is($in->type, "paletted", "make sure the result is paletted");
495   is($in->tags(name => "png_bits"), 4, "4 bit representation");
496 }
497
498 {
499   my $pim = Imager->new(xsize => 8, ysize => 2, channels => 1, type => "paletted");
500   ok($pim, "make a 1 channel paletted image");
501   ok($pim->addcolors(colors => [ map NC($_, 0, 0), 0, 7, 127, 255 ]),
502      "add some colors^Wgreys");
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/pal1.png"),
510      "write to testout/pal1.png")
511     or diag("Cannot save testout/pal1.png: ".$pim->errstr);
512   my $in = Imager->new(file => "testout/pal1.png");
513   ok($in, "read it back in")
514     or diag("Cann'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 $pim = Imager->new(xsize => 8, ysize => 2, channels => 2, type => "paletted");
525   ok($pim, "make a 2 channel paletted image");
526   ok($pim->addcolors(colors => [ NC(0, 255, 0), NC(128, 255, 0), NC(255, 255, 0), NC(128, 128, 0) ]),
527      "add some colors^Wgreys")
528     or diag("adding colors: " . $pim->errstr);
529   is($pim->setscanline(y => 0, type => "index",
530                        pixels => [ 0, 2, 1, 3, 2, 1, 0, 3 ]), 8,
531      "set some pixels");
532   is($pim->setscanline(y => 1, type => "index",
533                        pixels => [ 3, 0, 2, 1, 0, 0, 2, 3 ]), 8,
534      "set some more pixels");
535   ok($pim->write(file => "testout/pal2.png"),
536      "write to testout/pal2.png")
537     or diag("Cannot save testout/pal2.png: ".$pim->errstr);
538   my $in = Imager->new(file => "testout/pal2.png");
539   ok($in, "read it back in")
540     or diag("Can't read pal1.png back: " . Imager->errstr);
541   # PNG doesn't have a paletted greyscale type, so it's written as
542   # paletted color, convert our source image for the comparison
543   my $cmpim = $pim->convert(preset => "rgb");
544   is_image($in, $cmpim, "check it matches");
545   is($in->type, "paletted", "make sure the result is paletted");
546   is($in->tags(name => "png_bits"), 2, "2 bit representation");
547 }
548
549 {
550   my $imbase = test_image();
551   my $mono = $imbase->convert(preset => "gray")
552     ->to_paletted(make_colors => "mono", translate => "errdiff");
553
554   ok($mono->write(file => "testout/bilevel.png"),
555      "write bilevel.png");
556   my $in = Imager->new(file => "testout/bilevel.png");
557   ok($in, "read it back in")
558     or diag("Can't read bilevel.png: " . Imager->errstr);
559   is_image($in, $mono, "check it matches");
560   is($in->type, "paletted", "make sure the result is paletted");
561   is($in->tags(name => "png_bits"), 1, "1 bit representation");
562 }
563
564 SKIP:
565 {
566   my $im = test_image_16();
567   ok($im->write(file => "testout/rgb16.png", type => "png"),
568      "write 16-bit/sample image")
569     or diag("Could not write rgb16.png: ".$im->errstr);
570   my $in = Imager->new(file => "testout/rgb16.png")
571     or diag("Could not read rgb16.png: ".Imager->errstr);
572   ok($in, "read rgb16.png back in")
573     or skip("Could not load image to check", 4);
574   is_imaged($in, $im, 0, "check image matches");
575   is($in->bits, 16, "check we got a 16-bit image");
576   is($in->type, "direct", "check it's direct");
577   is($in->tags(name => "png_bits"), 16, "check png_bits");
578 }
579
580 SKIP:
581 {
582   my $im = test_image_double();
583   my $cmp = $im->to_rgb16;
584   ok($im->write(file => "testout/rgbdbl.png", type => "png"),
585      "write double/sample image - should write as 16-bit/sample")
586     or diag("Could not write rgbdbl.png: ".$im->errstr);
587   my $in = Imager->new(file => "testout/rgbdbl.png")
588     or diag("Could not read rgbdbl.png: ".Imager->errstr);
589   ok($in, "read pngdbl.png back in")
590     or skip("Could not load image to check", 4);
591   is_imaged($in, $cmp, 0, "check image matches");
592   is($in->bits, 16, "check we got a 16-bit image");
593   is($in->type, "direct", "check it's direct");
594   is($in->tags(name => "png_bits"), 16, "check png_bits");
595 }
596
597 SKIP:
598 {
599   my $im = Imager->new(file => "testimg/comment.png");
600   ok($im, "read file with comment")
601     or diag("Cannot read comment.png: ".Imager->errstr);
602   $im
603     or skip("Cannot test tags file I can't read", 5);
604   is($im->tags(name => "i_comment"), "Test comment", "check i_comment");
605   is($im->tags(name => "png_interlace"), "0", "no interlace");
606   is($im->tags(name => "png_interlace_name"), "none", "no interlace (text)");
607   is($im->tags(name => "png_srgb_intent"), "0", "srgb perceptual");
608   is($im->tags(name => "png_time"), "2012-04-16T07:37:36",
609      "modification time");
610   is($im->tags(name => "i_background"), "color(255,255,255,255)",
611      "background color");
612 }
613
614 SKIP:
615 { # test tag writing
616   my $im = Imager->new(xsize => 1, ysize => 1);
617   ok($im->write(file => "testout/tags.png",
618                 i_comment => "A Comment",
619                 png_author => "An Author",
620                 png_author_compressed => 1,
621                 png_copyright => "A Copyright",
622                 png_creation_time => "16 April 2012 22:56:30+1000",
623                 png_description => "A Description",
624                 png_disclaimer => "A Disclaimer",
625                 png_software => "Some Software",
626                 png_source => "A Source",
627                 png_title => "A Title",
628                 png_warning => "A Warning",
629                 png_text0_key => "Custom Key",
630                 png_text0_text => "Custom Value",
631                 png_text0_compressed => 1,
632                 png_text1_key => "Custom Key2",
633                 png_text1_text => "Another Custom Value",
634                 png_time => "2012-04-20T00:15:10",
635                ),
636      "write with many tags")
637     or diag("Cannot write with many tags: ", $im->errstr);
638
639   my $imr = Imager->new(file => "testout/tags.png");
640   ok($imr, "read it back in")
641     or skip("Couldn't read it back: ". Imager->errstr, 1);
642
643   is_deeply({ map @$_, $imr->tags },
644             {
645              i_format => "png",
646              i_comment => "A Comment",
647              png_author => "An Author",
648              png_author_compressed => 1,
649              png_copyright => "A Copyright",
650              png_creation_time => "16 April 2012 22:56:30+1000",
651              png_description => "A Description",
652              png_disclaimer => "A Disclaimer",
653              png_software => "Some Software",
654              png_source => "A Source",
655              png_title => "A Title",
656              png_warning => "A Warning",
657              png_text0_key => "Custom Key",
658              png_text0_text => "Custom Value",
659              png_text0_compressed => 1,
660              png_text0_type => "text",
661              png_text1_key => "Custom Key2",
662              png_text1_text => "Another Custom Value",
663              png_text1_type => "text",
664              png_time => "2012-04-20T00:15:10",
665              png_interlace => 0,
666              png_interlace_name => "none",
667              png_bits => 8,
668             }, "check tags are what we expected");
669 }
670
671 SKIP:
672 { # cHRM test
673   my $im = Imager->new(xsize => 1, ysize => 1);
674   ok($im->write(file => "testout/tagschrm.png", type => "png",
675                 png_chroma_white_x => 0.3,
676                 png_chroma_white_y => 0.32,
677                 png_chroma_red_x => 0.7,
678                 png_chroma_red_y => 0.28,
679                 png_chroma_green_x => 0.075,
680                 png_chroma_green_y => 0.8,
681                 png_chroma_blue_x => 0.175,
682                 png_chroma_blue_y => 0.05),
683      "write cHRM chunk");
684   my $imr = Imager->new(file => "testout/tagschrm.png", ftype => "png");
685   ok($imr, "read tagschrm.png")
686     or diag("reading tagschrm.png: ".Imager->errstr);
687   $imr
688     or skip("read of tagschrm.png failed", 1);
689   is_deeply({ map @$_, $imr->tags },
690             {
691              i_format => "png",
692              png_interlace => 0,
693              png_interlace_name => "none",
694              png_bits => 8,
695              png_chroma_white_x => 0.3,
696              png_chroma_white_y => 0.32,
697              png_chroma_red_x => 0.7,
698              png_chroma_red_y => 0.28,
699              png_chroma_green_x => 0.075,
700              png_chroma_green_y => 0.8,
701              png_chroma_blue_x => 0.175,
702              png_chroma_blue_y => 0.05,
703             }, "check chroma tags written");
704 }
705
706 { # gAMA
707   my $im = Imager->new(xsize => 1, ysize => 1);
708   ok($im->write(file => "testout/tagsgama.png", type => "png",
709                png_gamma => 2.22),
710      "write with png_gammma tag");
711   my $imr = Imager->new(file => "testout/tagsgama.png", ftype => "png");
712   ok($imr, "read tagsgama.png")
713     or diag("reading tagsgama.png: ".Imager->errstr);
714   $imr
715     or skip("read of tagsgama.png failed", 1);
716   is_deeply({ map @$_, $imr->tags },
717             {
718              i_format => "png",
719              png_interlace => 0,
720              png_interlace_name => "none",
721              png_bits => 8,
722              png_gamma => "2.22",
723             }, "check gamma tag written");
724 }
725
726 { # various bad tag failures
727   my @tests =
728     (
729      [
730       [ png_chroma_white_x => 0.5 ],
731       "all png_chroma_* tags must be supplied or none"
732      ],
733      [
734       [ png_srgb_intent => 4 ],
735       "tag png_srgb_intent out of range"
736      ],
737      [
738       [ i_comment => "test\0with nul" ],
739       "tag i_comment may not contain NUL characters"
740      ],
741      [
742       [ png_text0_key => "" ],
743       "tag png_text0_key must be between 1 and 79 characters in length"
744      ],
745      [
746       [ png_text0_key => ("x" x 80) ],
747       "tag png_text0_key must be between 1 and 79 characters in length"
748      ],
749      [
750       [ png_text0_key => " x" ],
751       "tag png_text0_key may not contain leading or trailing spaces"
752      ],
753      [
754       [ png_text0_key => "x " ],
755       "tag png_text0_key may not contain leading or trailing spaces"
756      ],
757      [
758       [ png_text0_key => "x  y" ],
759       "tag png_text0_key may not contain consecutive spaces"
760      ],
761      [
762       [ png_text0_key => "\x7F" ],
763       "tag png_text0_key may only contain Latin1 characters 32-126, 161-255"
764      ],
765      [
766       [ png_text0_key => "x", png_text0_text => "a\0b" ],
767       "tag png_text0_text may not contain NUL characters"
768      ],
769      [
770       [ png_text0_key => "test" ],
771       "tag png_text0_key found but not png_text0_text"
772      ],
773      [
774       [ png_text0_text => "test" ],
775       "tag png_text0_text found but not png_text0_key"
776      ],
777      [
778       [ png_time => "bad format" ],
779       "png_time must be formatted 'y-m-dTh:m:s'"
780      ],
781      [
782       [ png_time => "2012-13-01T00:00:00" ],
783       "invalid date/time for png_time"
784      ],
785     ); 
786   my $im = Imager->new(xsize => 1, ysize => 1);
787   for my $test (@tests) {
788     my ($tags, $error) = @$test;
789     my $im2 = $im->copy;
790     my $data;
791     ok(!$im2->write(data => \$data, type => "png", @$tags),
792        "expect $error");
793     is($im2->errstr, $error, "check error message");
794   }
795 }
796
797 sub limited_write {
798   my ($limit) = @_;
799
800   return
801      sub {
802        my ($data) = @_;
803        $limit -= length $data;
804        if ($limit >= 0) {
805          print "# write of ", length $data, " bytes successful ($limit left)\n" if $debug_writes;
806          return 1;
807        }
808        else {
809          print "# write of ", length $data, " bytes failed\n";
810          Imager::i_push_error(0, "limit reached");
811          return;
812        }
813      };
814 }
815