PNG re-work: paletted file writes
[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);
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 => 187;
14
15 # this loads Imager::File::PNG too
16 ok($Imager::formats{"png"}, "must have png format");
17
18 diag("Library version " . Imager::File::PNG::i_png_lib_version());
19
20 my $green  = i_color_new(0,   255, 0,   255);
21 my $blue   = i_color_new(0,   0,   255, 255);
22 my $red    = i_color_new(255, 0,   0,   255);
23
24 my $img    = test_image_raw();
25
26 my $timg = Imager::ImgRaw::new(20, 20, 4);
27 my $trans = i_color_new(255, 0, 0, 127);
28 i_box_filled($timg, 0, 0, 20, 20, $green);
29 i_box_filled($timg, 2, 2, 18, 18, $trans);
30
31 Imager::i_tags_add($img, "i_xres", 0, "300", 0);
32 Imager::i_tags_add($img, "i_yres", 0, undef, 200);
33 # the following confuses the GIMP
34 #Imager::i_tags_add($img, "i_aspect_only", 0, undef, 1);
35 open(FH,">testout/t102.png") || die "cannot open testout/t102.png for writing\n";
36 binmode(FH);
37 my $IO = Imager::io_new_fd(fileno(FH));
38 ok(Imager::File::PNG::i_writepng_wiol($img, $IO), "write")
39   or diag(Imager->_error_as_msg());
40 close(FH);
41
42 open(FH,"testout/t102.png") || die "cannot open testout/t102.png\n";
43 binmode(FH);
44 $IO = Imager::io_new_fd(fileno(FH));
45 my $cmpimg = Imager::File::PNG::i_readpng_wiol($IO);
46 close(FH);
47 ok($cmpimg, "read png");
48
49 print "# png average mean square pixel difference: ",sqrt(i_img_diff($img,$cmpimg))/150*150,"\n";
50 is(i_img_diff($img, $cmpimg), 0, "compare saved and original images");
51
52 my %tags = map { Imager::i_tags_get($cmpimg, $_) }
53   0..Imager::i_tags_count($cmpimg) - 1;
54 ok(abs($tags{i_xres} - 300) < 1, "i_xres: $tags{i_xres}");
55 ok(abs($tags{i_yres} - 200) < 1, "i_yres: $tags{i_yres}");
56 is($tags{i_format}, "png", "i_format: $tags{i_format}");
57
58 open FH, "> testout/t102_trans.png"
59   or die "Cannot open testout/t102_trans.png: $!";
60 binmode FH;
61 $IO = Imager::io_new_fd(fileno(FH));
62 ok(Imager::File::PNG::i_writepng_wiol($timg, $IO), "write tranparent");
63 close FH;
64
65 open FH,"testout/t102_trans.png" 
66   or die "cannot open testout/t102_trans.png\n";
67 binmode(FH);
68 $IO = Imager::io_new_fd(fileno(FH));
69 $cmpimg = Imager::File::PNG::i_readpng_wiol($IO);
70 ok($cmpimg, "read transparent");
71 close(FH);
72
73 print "# png average mean square pixel difference: ",sqrt(i_img_diff($timg,$cmpimg))/150*150,"\n";
74 is(i_img_diff($timg, $cmpimg), 0, "compare saved and original transparent");
75
76 # REGRESSION TEST
77 # png.c 1.1 would produce an incorrect image when loading images with
78 # less than 8 bits/pixel with a transparent palette entry
79 open FH, "< testimg/palette.png"
80   or die "cannot open testimg/palette.png: $!\n";
81 binmode FH;
82 $IO = Imager::io_new_fd(fileno(FH));
83 # 1.1 may segfault here (it does with libefence)
84 my $pimg = Imager::File::PNG::i_readpng_wiol($IO);
85 ok($pimg, "read transparent paletted image");
86 close FH;
87
88 open FH, "< testimg/palette_out.png"
89   or die "cannot open testimg/palette_out.png: $!\n";
90 binmode FH;
91 $IO = Imager::io_new_fd(fileno(FH));
92 my $poimg = Imager::File::PNG::i_readpng_wiol($IO);
93 ok($poimg, "read palette_out image");
94 close FH;
95 if (!is(i_img_diff($pimg, $poimg), 0, "images the same")) {
96   print <<EOS;
97 # this tests a bug in Imager's png.c v1.1
98 # if also tickles a bug in libpng before 1.0.5, so you may need to
99 # upgrade libpng
100 EOS
101 }
102
103 { # check file limits are checked
104   my $limit_file = "testout/t102.png";
105   ok(Imager->set_file_limits(reset=>1, width=>149), "set width limit 149");
106   my $im = Imager->new;
107   ok(!$im->read(file=>$limit_file),
108      "should fail read due to size limits");
109   print "# ",$im->errstr,"\n";
110   like($im->errstr, qr/image width/, "check message");
111   
112   ok(Imager->set_file_limits(reset=>1, height=>149), "set height limit 149");
113   ok(!$im->read(file=>$limit_file),
114      "should fail read due to size limits");
115   print "# ",$im->errstr,"\n";
116   like($im->errstr, qr/image height/, "check message");
117   
118   ok(Imager->set_file_limits(reset=>1, width=>150), "set width limit 150");
119   ok($im->read(file=>$limit_file),
120      "should succeed - just inside width limit");
121   ok(Imager->set_file_limits(reset=>1, height=>150), "set height limit 150");
122   ok($im->read(file=>$limit_file),
123      "should succeed - just inside height limit");
124   
125   # 150 x 150 x 3 channel image uses 67500 bytes
126   ok(Imager->set_file_limits(reset=>1, bytes=>67499),
127      "set bytes limit 67499");
128   ok(!$im->read(file=>$limit_file),
129        "should fail - too many bytes");
130   print "# ",$im->errstr,"\n";
131     like($im->errstr, qr/storage size/, "check error message");
132   ok(Imager->set_file_limits(reset=>1, bytes=>67500),
133      "set bytes limit 67500");
134   ok($im->read(file=>$limit_file),
135      "should succeed - just inside bytes limit");
136   Imager->set_file_limits(reset=>1);
137 }
138
139 { # check if the read_multi fallback works
140   my @imgs = Imager->read_multi(file => 'testout/t102.png');
141   is(@imgs, 1, "check the image was loaded");
142   is(i_img_diff($img, $imgs[0]), 0, "check image matches");
143   
144   # check the write_multi fallback
145   ok(Imager->write_multi({ file => 'testout/t102m.png', type => 'png' }, 
146                          @imgs),
147        'test write_multi() callback');
148   
149   # check that we fail if we actually write 2
150   ok(!Imager->write_multi({ file => 'testout/t102m.png', type => 'png' }, 
151                            @imgs, @imgs),
152      'test write_multi() callback failure');
153 }
154
155 { # check close failures are handled correctly
156   my $im = test_image();
157   my $fail_close = sub {
158     Imager::i_push_error(0, "synthetic close failure");
159     print "# closecb called\n";
160     return 0;
161   };
162   ok(!$im->write(type => "png", callback => sub { 1 },
163                  closecb => $fail_close),
164      "check failing close fails");
165     like($im->errstr, qr/synthetic close failure/,
166          "check error message");
167 }
168
169 {
170   ok(grep($_ eq 'png', Imager->read_types), "check png in read types");
171   ok(grep($_ eq 'png', Imager->write_types), "check png in write types");
172 }
173
174 { # read error reporting
175   my $im = Imager->new;
176   ok(!$im->read(file => "testimg/badcrc.png", type => "png"),
177      "read png with bad CRC chunk should fail");
178   is($im->errstr, "IHDR: CRC error", "check error message");
179 }
180
181 { # write error reporting
182   my $im = test_image();
183   ok(!$im->write(type => "png", callback => limited_write(1), buffered => 0),
184      "write limited to 1 byte should fail");
185   is($im->errstr, "Write error on an iolayer source.: limit reached",
186      "check error message");
187 }
188
189 SKIP:
190 { # https://sourceforge.net/tracker/?func=detail&aid=3314943&group_id=5624&atid=105624
191   # large images
192   Imager::File::PNG::i_png_lib_version() >= 10503
193       or skip("older libpng limits image sizes", 12);
194
195   {
196     my $im = Imager->new(xsize => 1000001, ysize => 1, channels => 1);
197     ok($im, "make a wide image");
198     my $data;
199     ok($im->write(data => \$data, type => "png"),
200        "write wide image as png")
201       or diag("write wide: " . $im->errstr);
202     my $im2 = Imager->new;
203     ok($im->read(data => $data, type => "png"),
204        "read wide image as png")
205       or diag("read wide: " . $im->errstr);
206     is($im->getwidth, 1000001, "check width");
207     is($im->getheight, 1, "check height");
208     is($im->getchannels, 1, "check channels");
209   }
210
211   {
212     my $im = Imager->new(xsize => 1, ysize => 1000001, channels => 1);
213     ok($im, "make a tall image");
214     my $data;
215     ok($im->write(data => \$data, type => "png"),
216        "write wide image as png")
217       or diag("write tall: " . $im->errstr);
218     my $im2 = Imager->new;
219     ok($im->read(data => $data, type => "png"),
220        "read tall image as png")
221       or diag("read tall: " . $im->errstr);
222     is($im->getwidth, 1, "check width");
223     is($im->getheight, 1000001, "check height");
224     is($im->getchannels, 1, "check channels");
225   }
226 }
227
228 { # test grayscale read as greyscale
229   my $im = Imager->new;
230   ok($im->read(file => "testimg/gray.png", type => "png"),
231      "read grayscale");
232   is($im->getchannels, 1, "check channel count");
233   is($im->type, "direct", "check type");
234   is($im->bits, 8, "check bits");
235   is($im->tags(name => "png_bits"), 8, "check png_bits tag");
236   is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
237 }
238
239 { # test grayscale + alpha read as greyscale + alpha
240   my $im = Imager->new;
241   ok($im->read(file => "testimg/graya.png", type => "png"),
242      "read grayscale + alpha");
243   is($im->getchannels, 2, "check channel count");
244   is($im->type, "direct", "check type");
245   is($im->bits, 8, "check bits");
246   is($im->tags(name => "png_bits"), 8, "check png_bits tag");
247   is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
248 }
249
250 { # test paletted + alpha read as paletted
251   my $im = Imager->new;
252   ok($im->read(file => "testimg/paltrans.png", type => "png"),
253      "read paletted with alpha");
254   is($im->getchannels, 4, "check channel count");
255   is($im->type, "paletted", "check type");
256   is($im->tags(name => "png_bits"), 8, "check png_bits tag");
257   is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
258 }
259
260 { # test paletted read as paletted
261   my $im = Imager->new;
262   ok($im->read(file => "testimg/pal.png", type => "png"),
263      "read paletted");
264   is($im->getchannels, 3, "check channel count");
265   is($im->type, "paletted", "check type");
266   is($im->tags(name => "png_bits"), 8, "check png_bits tag");
267   is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
268 }
269
270 { # test 16-bit rgb read as 16 bit
271   my $im = Imager->new;
272   ok($im->read(file => "testimg/rgb16.png", type => "png"),
273      "read 16-bit rgb");
274   is($im->getchannels, 3, "check channel count");
275   is($im->type, "direct", "check type");
276   is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
277   is($im->bits, 16, "check bits");
278   is($im->tags(name => "png_bits"), 16, "check png_bits tag");
279 }
280
281 { # test 1-bit grey read as mono
282   my $im = Imager->new;
283   ok($im->read(file => "testimg/bilevel.png", type => "png"),
284      "read bilevel png");
285   is($im->getchannels, 1, "check channel count");
286   is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
287   is($im->type, "paletted", "check type");
288   ok($im->is_bilevel, "should be bilevel");
289   is($im->tags(name => "png_bits"), 1, "check png_bits tag");
290 }
291
292 SKIP:
293 { # test interlaced read as interlaced and matches original
294   my $im_i = Imager->new(file => "testimg/rgb8i.png", filetype => "png");
295   ok($im_i, "read interlaced")
296     or skip("Could not read rgb8i.png: " . Imager->errstr, 7);
297   is($im_i->getchannels, 3, "check channel count");
298   is($im_i->type, "direct", "check type");
299   is($im_i->tags(name => "png_bits"), 8, "check png_bits");
300   is($im_i->tags(name => "png_interlace"), 1, "check png_interlace");
301
302   my $im = Imager->new(file => "testimg/rgb8.png", filetype => "png");
303   ok($im, "read non-interlaced")
304     or skip("Could not read testimg/rgb8.png: " . Imager->errstr, 2);
305   is($im->tags(name => "png_interlace"), 0, "check png_interlace");
306   is_image($im_i, $im, "compare interlaced and non-interlaced");
307 }
308
309 {
310   my @match =
311     (
312      [ "cover.png", "coveri.png" ],
313      [ "cover16.png", "cover16i.png" ],
314      [ "coverpal.png", "coverpali.png" ],
315     );
316   for my $match (@match) {
317     my ($normal, $interlace) = @$match;
318
319     my $n_im = Imager->new(file => "testimg/$normal");
320     ok($n_im, "read $normal")
321       or diag "reading $normal: ", Imager->errstr;
322     my $i_im = Imager->new(file => "testimg/$interlace");
323     ok($i_im, "read $interlace")
324       or diag "reading $interlace: ", Imager->errstr;
325   SKIP:
326     {
327       $n_im && $i_im
328         or skip("Couldn't read a file", 1);
329       is_image($i_im, $n_im, "check normal and interlace files read the same");
330     }
331   }
332 }
333
334 {
335   my $interlace = 0;
336   for my $name ("cover.png", "coveri.png") {
337   SKIP: {
338       my $im = Imager->new(file => "testimg/$name");
339       ok($im, "read $name")
340         or diag "Failed to read $name: ", Imager->errstr;
341       $im
342         or skip("Couldn't load $name", 5);
343       is($im->tags(name => "i_format"), "png", "$name: i_format");
344       is($im->tags(name => "png_bits"), 8, "$name: png_bits");
345       is($im->tags(name => "png_interlace"), $interlace,
346          "$name: png_interlace");
347       is($im->getchannels, 4, "$name: four channels");
348       is($im->type, "direct", "$name: direct type");
349
350       is_deeply([ $im->getsamples(y => 0, width => 5) ],
351                 [ ( 255, 255, 0, 255 ), ( 255, 255, 0, 191 ),
352                   ( 255, 255, 0, 127 ), ( 255, 255, 0, 63 ),
353                   ( 0, 0, 0, 0) ],
354                 "$name: check expected samples row 0");
355       is_deeply([ $im->getsamples(y => 1, width => 5) ],
356                 [ ( 255, 0, 0, 255 ), ( 255, 0, 0, 191 ),
357                   ( 255, 0, 0, 127 ), ( 255, 0, 0, 63 ),
358                   ( 0, 0, 0, 0) ],
359                 "$name: check expected samples row 1");
360     }
361     $interlace = 1;
362   }
363 }
364
365 {
366   my $interlace = 0;
367   for my $name ("coverpal.png", "coverpali.png") {
368   SKIP: {
369       my $im = Imager->new(file => "testimg/$name");
370       ok($im, "read $name")
371         or diag "Failed to read $name: ", Imager->errstr;
372       $im
373         or skip("Couldn't load $name", 5);
374       is($im->tags(name => "i_format"), "png", "$name: i_format");
375       is($im->tags(name => "png_bits"), 4, "$name: png_bits");
376       is($im->tags(name => "png_interlace"), $interlace,
377          "$name: png_interlace");
378       is($im->getchannels, 4, "$name: four channels");
379       is($im->type, "paletted", "$name: paletted type");
380
381       is_deeply([ $im->getsamples(y => 0, width => 5) ],
382                 [ ( 255, 255, 0, 255 ), ( 255, 255, 0, 191 ),
383                   ( 255, 255, 0, 127 ), ( 255, 255, 0, 63 ),
384                   ( 0, 0, 0, 0) ],
385                 "$name: check expected samples row 0");
386       is_deeply([ $im->getsamples(y => 1, width => 5) ],
387                 [ ( 255, 0, 0, 255 ), ( 255, 0, 0, 191 ),
388                   ( 255, 0, 0, 127 ), ( 255, 0, 0, 63 ),
389                   ( 0, 0, 0, 0) ],
390                 "$name: check expected samples row 1");
391     }
392     $interlace = 1;
393   }
394 }
395
396 {
397   my $interlace = 0;
398   for my $name ("cover16.png", "cover16i.png") {
399   SKIP: {
400       my $im = Imager->new(file => "testimg/$name");
401       ok($im, "read $name")
402         or diag "Failed to read $name: ", Imager->errstr;
403       $im
404         or skip("Couldn't load $name", 5);
405       is($im->tags(name => "i_format"), "png", "$name: i_format");
406       is($im->tags(name => "png_bits"), 16, "$name: png_bits");
407       is($im->tags(name => "png_interlace"), $interlace,
408          "$name: png_interlace");
409       is($im->getchannels, 4, "$name: four channels");
410       is($im->type, "direct", "$name: direct type");
411
412       is_deeply([ $im->getsamples(y => 0, width => 5, type => "16bit") ],
413                 [ ( 65535, 65535, 0, 65535 ), ( 65535, 65535, 0, 49087 ),
414                   ( 65535, 65535, 0, 32639 ), ( 65535, 65535, 0, 16191 ),
415                   ( 65535, 65535, 65535, 0) ],
416                 "$name: check expected samples row 0");
417       is_deeply([ $im->getsamples(y => 1, width => 5, type => "16bit") ],
418                 [ ( 65535, 0, 0, 65535 ), ( 65535, 0, 0, 49087 ),
419                   ( 65535, 0, 0, 32639 ), ( 65535, 0, 0, 16191 ),
420                   ( 65535, 65535, 65535, 0) ],
421                 "$name: check expected samples row 1");
422     }
423     $interlace = 1;
424   }
425 }
426
427 {
428   my $pim = Imager->new(xsize => 5, ysize => 2, channels => 3, type => "paletted");
429   ok($pim, "make a 3 channel paletted image");
430   ok($pim->addcolors(colors => [ qw(#000 #FFF #F00 #0F0 #00f) ]),
431      "add some colors");
432   is($pim->setscanline(y => 0, type => "index",
433                        pixels => [ 0, 1, 2, 4, 3 ]), 5, "set some pixels");
434   is($pim->setscanline(y => 1, type => "index",
435                        pixels => [ 4, 1, 0, 4, 2 ]), 5, "set some more pixels");
436   ok($pim->write(file => "testout/pal3.png"),
437      "write to testout/pal3.png")
438     or diag("Cannot save testout/pal3.png: ".$pim->errstr);
439   my $in = Imager->new(file => "testout/pal3.png");
440   ok($in, "read it back in")
441     or diag("Cann't read pal3.png back: " . Imager->errstr);
442   is_image($pim, $in, "check it matches");
443   is($in->type, "paletted", "make sure the result is paletted");
444   is($in->tags(name => "png_bits"), 4, "4 bit representation");
445 }
446
447 {
448   # make sure the code that pushes maxed alpha to the end doesn't break
449   my $pim = Imager->new(xsize => 8, ysize => 2, channels => 4, type => "paletted");
450   ok($pim, "make a 4 channel paletted image");
451   ok($pim->addcolors
452      (colors => [ NC(255, 255, 0, 128), qw(#000 #FFF #F00 #0F0 #00f),
453                   NC(0, 0, 0, 0), NC(255, 0, 128, 64) ]),
454      "add some colors");
455   is($pim->setscanline(y => 0, type => "index",
456                        pixels => [ 5, 0, 1, 7, 2, 4, 6, 3 ]), 8,
457      "set some pixels");
458   is($pim->setscanline(y => 1, type => "index",
459                        pixels => [ 7, 4, 6, 1, 0, 4, 2, 5 ]), 8,
460      "set some more pixels");
461   ok($pim->write(file => "testout/pal4.png"),
462      "write to testout/pal4.png")
463     or diag("Cannot save testout/pal4.png: ".$pim->errstr);
464   my $in = Imager->new(file => "testout/pal4.png");
465   ok($in, "read it back in")
466     or diag("Cann't read pal4.png back: " . Imager->errstr);
467   is_image($pim, $in, "check it matches");
468   is($in->type, "paletted", "make sure the result is paletted");
469   is($in->tags(name => "png_bits"), 4, "4 bit representation");
470 }
471
472 {
473   my $pim = Imager->new(xsize => 8, ysize => 2, channels => 1, type => "paletted");
474   ok($pim, "make a 1 channel paletted image");
475   ok($pim->addcolors(colors => [ map NC($_, 0, 0), 0, 7, 127, 255 ]),
476      "add some colors^Wgreys");
477   is($pim->setscanline(y => 0, type => "index",
478                        pixels => [ 0, 2, 1, 3, 2, 1, 0, 3 ]), 8,
479      "set some pixels");
480   is($pim->setscanline(y => 1, type => "index",
481                        pixels => [ 3, 0, 2, 1, 0, 0, 2, 3 ]), 8,
482      "set some more pixels");
483   ok($pim->write(file => "testout/pal1.png"),
484      "write to testout/pal1.png")
485     or diag("Cannot save testout/pal1.png: ".$pim->errstr);
486   my $in = Imager->new(file => "testout/pal1.png");
487   ok($in, "read it back in")
488     or diag("Cann't read pal1.png back: " . Imager->errstr);
489   # PNG doesn't have a paletted greyscale type, so it's written as
490   # paletted color, convert our source image for the comparison
491   my $cmpim = $pim->convert(preset => "rgb");
492   is_image($in, $cmpim, "check it matches");
493   is($in->type, "paletted", "make sure the result is paletted");
494   is($in->tags(name => "png_bits"), 2, "2 bit representation");
495 }
496
497 {
498   my $pim = Imager->new(xsize => 8, ysize => 2, channels => 2, type => "paletted");
499   ok($pim, "make a 2 channel paletted image");
500   ok($pim->addcolors(colors => [ NC(0, 255, 0), NC(128, 255, 0), NC(255, 255, 0), NC(128, 128, 0) ]),
501      "add some colors^Wgreys")
502     or diag("adding colors: " . $pim->errstr);
503   is($pim->setscanline(y => 0, type => "index",
504                        pixels => [ 0, 2, 1, 3, 2, 1, 0, 3 ]), 8,
505      "set some pixels");
506   is($pim->setscanline(y => 1, type => "index",
507                        pixels => [ 3, 0, 2, 1, 0, 0, 2, 3 ]), 8,
508      "set some more pixels");
509   ok($pim->write(file => "testout/pal2.png"),
510      "write to testout/pal2.png")
511     or diag("Cannot save testout/pal2.png: ".$pim->errstr);
512   my $in = Imager->new(file => "testout/pal2.png");
513   ok($in, "read it back in")
514     or diag("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 sub limited_write {
524   my ($limit) = @_;
525
526   return
527      sub {
528        my ($data) = @_;
529        $limit -= length $data;
530        if ($limit >= 0) {
531          print "# write of ", length $data, " bytes successful ($limit left)\n" if $debug_writes;
532          return 1;
533        }
534        else {
535          print "# write of ", length $data, " bytes failed\n";
536          Imager::i_push_error(0, "limit reached");
537          return;
538        }
539      };
540 }
541