RT #94717 libpng 1.6.10 no longer considers CRC errors benign
[imager.git] / PNG / t / 10png.t
CommitLineData
352c64ed
TC
1#!perl -w
2use strict;
37a9be8e
TC
3use Imager qw(:all);
4use Test::More;
d9610331 5use Imager::Test qw(test_image_raw test_image is_image is_imaged test_image_16 test_image_double);
1cdc4cbd 6
38eab175
TC
7my $debug_writes = 1;
8
1d7e3124
TC
9-d "testout" or mkdir "testout";
10
9e35eed7 11init_log("testout/t102png.log",1);
1cdc4cbd 12
4593278b 13plan tests => 251;
37a9be8e 14
a4fa5d5e
TC
15# this loads Imager::File::PNG too
16ok($Imager::formats{"png"}, "must have png format");
1cdc4cbd 17
647508aa
TC
18diag("Library version " . Imager::File::PNG::i_png_lib_version());
19
79f95bf1
TC
20my %png_feat = map { $_ => 1 } Imager::File::PNG->features;
21
352c64ed
TC
22my $green = i_color_new(0, 255, 0, 255);
23my $blue = i_color_new(0, 0, 255, 255);
24my $red = i_color_new(255, 0, 0, 255);
1cdc4cbd 25
37a9be8e 26my $img = test_image_raw();
1cdc4cbd
TC
27
28my $timg = Imager::ImgRaw::new(20, 20, 4);
29my $trans = i_color_new(255, 0, 0, 127);
30i_box_filled($timg, 0, 0, 20, 20, $green);
31i_box_filled($timg, 2, 2, 18, 18, $trans);
32
37a9be8e
TC
33Imager::i_tags_add($img, "i_xres", 0, "300", 0);
34Imager::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);
37open(FH,">testout/t102.png") || die "cannot open testout/t102.png for writing\n";
38binmode(FH);
39my $IO = Imager::io_new_fd(fileno(FH));
21c6936b
TC
40ok(Imager::File::PNG::i_writepng_wiol($img, $IO), "write")
41 or diag(Imager->_error_as_msg());
37a9be8e
TC
42close(FH);
43
44open(FH,"testout/t102.png") || die "cannot open testout/t102.png\n";
45binmode(FH);
46$IO = Imager::io_new_fd(fileno(FH));
1d7e3124 47my $cmpimg = Imager::File::PNG::i_readpng_wiol($IO);
37a9be8e
TC
48close(FH);
49ok($cmpimg, "read png");
50
51print "# png average mean square pixel difference: ",sqrt(i_img_diff($img,$cmpimg))/150*150,"\n";
52is(i_img_diff($img, $cmpimg), 0, "compare saved and original images");
53
54my %tags = map { Imager::i_tags_get($cmpimg, $_) }
55 0..Imager::i_tags_count($cmpimg) - 1;
56ok(abs($tags{i_xres} - 300) < 1, "i_xres: $tags{i_xres}");
57ok(abs($tags{i_yres} - 200) < 1, "i_yres: $tags{i_yres}");
58is($tags{i_format}, "png", "i_format: $tags{i_format}");
59
60open FH, "> testout/t102_trans.png"
61 or die "Cannot open testout/t102_trans.png: $!";
62binmode FH;
63$IO = Imager::io_new_fd(fileno(FH));
1d7e3124 64ok(Imager::File::PNG::i_writepng_wiol($timg, $IO), "write tranparent");
37a9be8e
TC
65close FH;
66
67open FH,"testout/t102_trans.png"
68 or die "cannot open testout/t102_trans.png\n";
69binmode(FH);
70$IO = Imager::io_new_fd(fileno(FH));
1d7e3124 71$cmpimg = Imager::File::PNG::i_readpng_wiol($IO);
37a9be8e
TC
72ok($cmpimg, "read transparent");
73close(FH);
74
75print "# png average mean square pixel difference: ",sqrt(i_img_diff($timg,$cmpimg))/150*150,"\n";
76is(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
81open FH, "< testimg/palette.png"
82 or die "cannot open testimg/palette.png: $!\n";
83binmode FH;
84$IO = Imager::io_new_fd(fileno(FH));
85# 1.1 may segfault here (it does with libefence)
1d7e3124 86my $pimg = Imager::File::PNG::i_readpng_wiol($IO);
37a9be8e
TC
87ok($pimg, "read transparent paletted image");
88close FH;
89
90open FH, "< testimg/palette_out.png"
91 or die "cannot open testimg/palette_out.png: $!\n";
92binmode FH;
93$IO = Imager::io_new_fd(fileno(FH));
1d7e3124 94my $poimg = Imager::File::PNG::i_readpng_wiol($IO);
37a9be8e
TC
95ok($poimg, "read palette_out image");
96close FH;
97if (!is(i_img_diff($pimg, $poimg), 0, "images the same")) {
98 print <<EOS;
d8bbe40d
TC
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
102EOS
37a9be8e
TC
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),
77157728 131 "should fail - too many bytes");
37a9be8e 132 print "# ",$im->errstr,"\n";
77157728 133 like($im->errstr, qr/storage size/, "check error message");
37a9be8e
TC
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}
e7ff1cf7 140
37a9be8e
TC
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' },
e7ff1cf7 153 @imgs, @imgs),
37a9be8e
TC
154 'test write_multi() callback failure');
155}
f245645a 156
6d5c85a2
TC
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");
9f1597be 161 print "# closecb called\n";
6d5c85a2
TC
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
37a9be8e
TC
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");
1cdc4cbd 174}
37a9be8e 175
38eab175
TC
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
57520a19
TC
183SKIP:
184{ # ignoring "benign" errors
79f95bf1 185 $png_feat{"benign-errors"}
4593278b
TC
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
57520a19 198 my $im = Imager->new;
4593278b 199 ok($im->read(file => "testimg/bipalette.png", type => "png",
57520a19 200 png_ignore_benign_errors => 1),
4593278b
TC
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");
57520a19
TC
205}
206
38eab175
TC
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
9f1597be
TC
215SKIP:
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
6d379e0d
TC
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");
d3f58217 260 is($im->bits, 8, "check bits");
cfb628e2 261 is($im->tags(name => "png_bits"), 8, "check png_bits tag");
963d3602 262 is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
6d379e0d
TC
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");
d3f58217 271 is($im->bits, 8, "check bits");
cfb628e2 272 is($im->tags(name => "png_bits"), 8, "check png_bits tag");
963d3602 273 is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
6d379e0d
TC
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");
6d379e0d 281 is($im->type, "paletted", "check type");
cfb628e2 282 is($im->tags(name => "png_bits"), 8, "check png_bits tag");
963d3602 283 is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
6d379e0d
TC
284}
285
286{ # test paletted read as paletted
287 my $im = Imager->new;
288 ok($im->read(file => "testimg/pal.png", type => "png"),
d3f58217
TC
289 "read paletted");
290 is($im->getchannels, 3, "check channel count");
d3f58217 291 is($im->type, "paletted", "check type");
cfb628e2 292 is($im->tags(name => "png_bits"), 8, "check png_bits tag");
963d3602 293 is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
d3f58217
TC
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");
6d379e0d 300 is($im->getchannels, 3, "check channel count");
d3f58217 301 is($im->type, "direct", "check type");
963d3602 302 is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
d3f58217 303 is($im->bits, 16, "check bits");
cfb628e2 304 is($im->tags(name => "png_bits"), 16, "check png_bits tag");
d3f58217
TC
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");
963d3602 312 is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
6d379e0d 313 is($im->type, "paletted", "check type");
d3f58217 314 ok($im->is_bilevel, "should be bilevel");
cfb628e2 315 is($im->tags(name => "png_bits"), 1, "check png_bits tag");
cfb628e2
TC
316}
317
318SKIP:
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");
a4fa5d5e 326 is($im_i->tags(name => "png_interlace"), 1, "check png_interlace");
cfb628e2
TC
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);
a4fa5d5e 331 is($im->tags(name => "png_interlace"), 0, "check png_interlace");
cfb628e2 332 is_image($im_i, $im, "compare interlaced and non-interlaced");
6d379e0d
TC
333}
334
a4fa5d5e
TC
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
21c6936b
TC
453{
454 my $pim = Imager->new(xsize => 5, ysize => 2, channels => 3, type => "paletted");
455 ok($pim, "make a 3 channel paletted image");
2a2a5ca0 456 ok($pim->addcolors(colors => [ qw(000000 FFFFFF FF0000 00FF00 0000FF) ]),
21c6936b
TC
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
2a2a5ca0 478 (colors => [ NC(255, 255, 0, 128), qw(000000 FFFFFF FF0000 00FF00 0000FF),
21c6936b
TC
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")
b8961d05 540 or diag("Can't read pal1.png back: " . Imager->errstr);
21c6936b
TC
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
b8961d05
TC
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
d9610331
TC
564SKIP:
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
580SKIP:
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
86464bbf
TC
597SKIP:
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");
6fa6c8ee 608 is($im->tags(name => "png_time"), "2012-04-16T07:37:36",
86464bbf 609 "modification time");
6fa6c8ee
TC
610 is($im->tags(name => "i_background"), "color(255,255,255,255)",
611 "background color");
86464bbf
TC
612}
613
d0f15206
TC
614SKIP:
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
671SKIP:
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
38eab175
TC
797sub 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}
21c6936b 815