33680ba17e41aaa11c51168bd62bbb1887b3d5ad
[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 => 151;
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 close(FH);
40
41 open(FH,"testout/t102.png") || die "cannot open testout/t102.png\n";
42 binmode(FH);
43 $IO = Imager::io_new_fd(fileno(FH));
44 my $cmpimg = Imager::File::PNG::i_readpng_wiol($IO);
45 close(FH);
46 ok($cmpimg, "read png");
47
48 print "# png average mean square pixel difference: ",sqrt(i_img_diff($img,$cmpimg))/150*150,"\n";
49 is(i_img_diff($img, $cmpimg), 0, "compare saved and original images");
50
51 my %tags = map { Imager::i_tags_get($cmpimg, $_) }
52   0..Imager::i_tags_count($cmpimg) - 1;
53 ok(abs($tags{i_xres} - 300) < 1, "i_xres: $tags{i_xres}");
54 ok(abs($tags{i_yres} - 200) < 1, "i_yres: $tags{i_yres}");
55 is($tags{i_format}, "png", "i_format: $tags{i_format}");
56
57 open FH, "> testout/t102_trans.png"
58   or die "Cannot open testout/t102_trans.png: $!";
59 binmode FH;
60 $IO = Imager::io_new_fd(fileno(FH));
61 ok(Imager::File::PNG::i_writepng_wiol($timg, $IO), "write tranparent");
62 close FH;
63
64 open FH,"testout/t102_trans.png" 
65   or die "cannot open testout/t102_trans.png\n";
66 binmode(FH);
67 $IO = Imager::io_new_fd(fileno(FH));
68 $cmpimg = Imager::File::PNG::i_readpng_wiol($IO);
69 ok($cmpimg, "read transparent");
70 close(FH);
71
72 print "# png average mean square pixel difference: ",sqrt(i_img_diff($timg,$cmpimg))/150*150,"\n";
73 is(i_img_diff($timg, $cmpimg), 0, "compare saved and original transparent");
74
75 # REGRESSION TEST
76 # png.c 1.1 would produce an incorrect image when loading images with
77 # less than 8 bits/pixel with a transparent palette entry
78 open FH, "< testimg/palette.png"
79   or die "cannot open testimg/palette.png: $!\n";
80 binmode FH;
81 $IO = Imager::io_new_fd(fileno(FH));
82 # 1.1 may segfault here (it does with libefence)
83 my $pimg = Imager::File::PNG::i_readpng_wiol($IO);
84 ok($pimg, "read transparent paletted image");
85 close FH;
86
87 open FH, "< testimg/palette_out.png"
88   or die "cannot open testimg/palette_out.png: $!\n";
89 binmode FH;
90 $IO = Imager::io_new_fd(fileno(FH));
91 my $poimg = Imager::File::PNG::i_readpng_wiol($IO);
92 ok($poimg, "read palette_out image");
93 close FH;
94 if (!is(i_img_diff($pimg, $poimg), 0, "images the same")) {
95   print <<EOS;
96 # this tests a bug in Imager's png.c v1.1
97 # if also tickles a bug in libpng before 1.0.5, so you may need to
98 # upgrade libpng
99 EOS
100 }
101
102 { # check file limits are checked
103   my $limit_file = "testout/t102.png";
104   ok(Imager->set_file_limits(reset=>1, width=>149), "set width limit 149");
105   my $im = Imager->new;
106   ok(!$im->read(file=>$limit_file),
107      "should fail read due to size limits");
108   print "# ",$im->errstr,"\n";
109   like($im->errstr, qr/image width/, "check message");
110   
111   ok(Imager->set_file_limits(reset=>1, height=>149), "set height limit 149");
112   ok(!$im->read(file=>$limit_file),
113      "should fail read due to size limits");
114   print "# ",$im->errstr,"\n";
115   like($im->errstr, qr/image height/, "check message");
116   
117   ok(Imager->set_file_limits(reset=>1, width=>150), "set width limit 150");
118   ok($im->read(file=>$limit_file),
119      "should succeed - just inside width limit");
120   ok(Imager->set_file_limits(reset=>1, height=>150), "set height limit 150");
121   ok($im->read(file=>$limit_file),
122      "should succeed - just inside height limit");
123   
124   # 150 x 150 x 3 channel image uses 67500 bytes
125   ok(Imager->set_file_limits(reset=>1, bytes=>67499),
126      "set bytes limit 67499");
127   ok(!$im->read(file=>$limit_file),
128        "should fail - too many bytes");
129   print "# ",$im->errstr,"\n";
130     like($im->errstr, qr/storage size/, "check error message");
131   ok(Imager->set_file_limits(reset=>1, bytes=>67500),
132      "set bytes limit 67500");
133   ok($im->read(file=>$limit_file),
134      "should succeed - just inside bytes limit");
135   Imager->set_file_limits(reset=>1);
136 }
137
138 { # check if the read_multi fallback works
139   my @imgs = Imager->read_multi(file => 'testout/t102.png');
140   is(@imgs, 1, "check the image was loaded");
141   is(i_img_diff($img, $imgs[0]), 0, "check image matches");
142   
143   # check the write_multi fallback
144   ok(Imager->write_multi({ file => 'testout/t102m.png', type => 'png' }, 
145                          @imgs),
146        'test write_multi() callback');
147   
148   # check that we fail if we actually write 2
149   ok(!Imager->write_multi({ file => 'testout/t102m.png', type => 'png' }, 
150                            @imgs, @imgs),
151      'test write_multi() callback failure');
152 }
153
154 { # check close failures are handled correctly
155   my $im = test_image();
156   my $fail_close = sub {
157     Imager::i_push_error(0, "synthetic close failure");
158     print "# closecb called\n";
159     return 0;
160   };
161   ok(!$im->write(type => "png", callback => sub { 1 },
162                  closecb => $fail_close),
163      "check failing close fails");
164     like($im->errstr, qr/synthetic close failure/,
165          "check error message");
166 }
167
168 {
169   ok(grep($_ eq 'png', Imager->read_types), "check png in read types");
170   ok(grep($_ eq 'png', Imager->write_types), "check png in write types");
171 }
172
173 { # read error reporting
174   my $im = Imager->new;
175   ok(!$im->read(file => "testimg/badcrc.png", type => "png"),
176      "read png with bad CRC chunk should fail");
177   is($im->errstr, "IHDR: CRC error", "check error message");
178 }
179
180 { # write error reporting
181   my $im = test_image();
182   ok(!$im->write(type => "png", callback => limited_write(1), buffered => 0),
183      "write limited to 1 byte should fail");
184   is($im->errstr, "Write error on an iolayer source.: limit reached",
185      "check error message");
186 }
187
188 SKIP:
189 { # https://sourceforge.net/tracker/?func=detail&aid=3314943&group_id=5624&atid=105624
190   # large images
191   Imager::File::PNG::i_png_lib_version() >= 10503
192       or skip("older libpng limits image sizes", 12);
193
194   {
195     my $im = Imager->new(xsize => 1000001, ysize => 1, channels => 1);
196     ok($im, "make a wide image");
197     my $data;
198     ok($im->write(data => \$data, type => "png"),
199        "write wide image as png")
200       or diag("write wide: " . $im->errstr);
201     my $im2 = Imager->new;
202     ok($im->read(data => $data, type => "png"),
203        "read wide image as png")
204       or diag("read wide: " . $im->errstr);
205     is($im->getwidth, 1000001, "check width");
206     is($im->getheight, 1, "check height");
207     is($im->getchannels, 1, "check channels");
208   }
209
210   {
211     my $im = Imager->new(xsize => 1, ysize => 1000001, channels => 1);
212     ok($im, "make a tall image");
213     my $data;
214     ok($im->write(data => \$data, type => "png"),
215        "write wide image as png")
216       or diag("write tall: " . $im->errstr);
217     my $im2 = Imager->new;
218     ok($im->read(data => $data, type => "png"),
219        "read tall image as png")
220       or diag("read tall: " . $im->errstr);
221     is($im->getwidth, 1, "check width");
222     is($im->getheight, 1000001, "check height");
223     is($im->getchannels, 1, "check channels");
224   }
225 }
226
227 { # test grayscale read as greyscale
228   my $im = Imager->new;
229   ok($im->read(file => "testimg/gray.png", type => "png"),
230      "read grayscale");
231   is($im->getchannels, 1, "check channel count");
232   is($im->type, "direct", "check type");
233   is($im->bits, 8, "check bits");
234   is($im->tags(name => "png_bits"), 8, "check png_bits tag");
235   is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
236 }
237
238 { # test grayscale + alpha read as greyscale + alpha
239   my $im = Imager->new;
240   ok($im->read(file => "testimg/graya.png", type => "png"),
241      "read grayscale + alpha");
242   is($im->getchannels, 2, "check channel count");
243   is($im->type, "direct", "check type");
244   is($im->bits, 8, "check bits");
245   is($im->tags(name => "png_bits"), 8, "check png_bits tag");
246   is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
247 }
248
249 { # test paletted + alpha read as paletted
250   my $im = Imager->new;
251   ok($im->read(file => "testimg/paltrans.png", type => "png"),
252      "read paletted with alpha");
253   is($im->getchannels, 4, "check channel count");
254   is($im->type, "paletted", "check type");
255   is($im->tags(name => "png_bits"), 8, "check png_bits tag");
256   is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
257 }
258
259 { # test paletted read as paletted
260   my $im = Imager->new;
261   ok($im->read(file => "testimg/pal.png", type => "png"),
262      "read paletted");
263   is($im->getchannels, 3, "check channel count");
264   is($im->type, "paletted", "check type");
265   is($im->tags(name => "png_bits"), 8, "check png_bits tag");
266   is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
267 }
268
269 { # test 16-bit rgb read as 16 bit
270   my $im = Imager->new;
271   ok($im->read(file => "testimg/rgb16.png", type => "png"),
272      "read 16-bit rgb");
273   is($im->getchannels, 3, "check channel count");
274   is($im->type, "direct", "check type");
275   is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
276   is($im->bits, 16, "check bits");
277   is($im->tags(name => "png_bits"), 16, "check png_bits tag");
278 }
279
280 { # test 1-bit grey read as mono
281   my $im = Imager->new;
282   ok($im->read(file => "testimg/bilevel.png", type => "png"),
283      "read bilevel png");
284   is($im->getchannels, 1, "check channel count");
285   is($im->tags(name => "png_interlace"), 0, "check png_interlace tag");
286   is($im->type, "paletted", "check type");
287   ok($im->is_bilevel, "should be bilevel");
288   is($im->tags(name => "png_bits"), 1, "check png_bits tag");
289 }
290
291 SKIP:
292 { # test interlaced read as interlaced and matches original
293   my $im_i = Imager->new(file => "testimg/rgb8i.png", filetype => "png");
294   ok($im_i, "read interlaced")
295     or skip("Could not read rgb8i.png: " . Imager->errstr, 7);
296   is($im_i->getchannels, 3, "check channel count");
297   is($im_i->type, "direct", "check type");
298   is($im_i->tags(name => "png_bits"), 8, "check png_bits");
299   is($im_i->tags(name => "png_interlace"), 1, "check png_interlace");
300
301   my $im = Imager->new(file => "testimg/rgb8.png", filetype => "png");
302   ok($im, "read non-interlaced")
303     or skip("Could not read testimg/rgb8.png: " . Imager->errstr, 2);
304   is($im->tags(name => "png_interlace"), 0, "check png_interlace");
305   is_image($im_i, $im, "compare interlaced and non-interlaced");
306 }
307
308 {
309   my @match =
310     (
311      [ "cover.png", "coveri.png" ],
312      [ "cover16.png", "cover16i.png" ],
313      [ "coverpal.png", "coverpali.png" ],
314     );
315   for my $match (@match) {
316     my ($normal, $interlace) = @$match;
317
318     my $n_im = Imager->new(file => "testimg/$normal");
319     ok($n_im, "read $normal")
320       or diag "reading $normal: ", Imager->errstr;
321     my $i_im = Imager->new(file => "testimg/$interlace");
322     ok($i_im, "read $interlace")
323       or diag "reading $interlace: ", Imager->errstr;
324   SKIP:
325     {
326       $n_im && $i_im
327         or skip("Couldn't read a file", 1);
328       is_image($i_im, $n_im, "check normal and interlace files read the same");
329     }
330   }
331 }
332
333 {
334   my $interlace = 0;
335   for my $name ("cover.png", "coveri.png") {
336   SKIP: {
337       my $im = Imager->new(file => "testimg/$name");
338       ok($im, "read $name")
339         or diag "Failed to read $name: ", Imager->errstr;
340       $im
341         or skip("Couldn't load $name", 5);
342       is($im->tags(name => "i_format"), "png", "$name: i_format");
343       is($im->tags(name => "png_bits"), 8, "$name: png_bits");
344       is($im->tags(name => "png_interlace"), $interlace,
345          "$name: png_interlace");
346       is($im->getchannels, 4, "$name: four channels");
347       is($im->type, "direct", "$name: direct type");
348
349       is_deeply([ $im->getsamples(y => 0, width => 5) ],
350                 [ ( 255, 255, 0, 255 ), ( 255, 255, 0, 191 ),
351                   ( 255, 255, 0, 127 ), ( 255, 255, 0, 63 ),
352                   ( 0, 0, 0, 0) ],
353                 "$name: check expected samples row 0");
354       is_deeply([ $im->getsamples(y => 1, width => 5) ],
355                 [ ( 255, 0, 0, 255 ), ( 255, 0, 0, 191 ),
356                   ( 255, 0, 0, 127 ), ( 255, 0, 0, 63 ),
357                   ( 0, 0, 0, 0) ],
358                 "$name: check expected samples row 1");
359     }
360     $interlace = 1;
361   }
362 }
363
364 {
365   my $interlace = 0;
366   for my $name ("coverpal.png", "coverpali.png") {
367   SKIP: {
368       my $im = Imager->new(file => "testimg/$name");
369       ok($im, "read $name")
370         or diag "Failed to read $name: ", Imager->errstr;
371       $im
372         or skip("Couldn't load $name", 5);
373       is($im->tags(name => "i_format"), "png", "$name: i_format");
374       is($im->tags(name => "png_bits"), 4, "$name: png_bits");
375       is($im->tags(name => "png_interlace"), $interlace,
376          "$name: png_interlace");
377       is($im->getchannels, 4, "$name: four channels");
378       is($im->type, "paletted", "$name: paletted type");
379
380       is_deeply([ $im->getsamples(y => 0, width => 5) ],
381                 [ ( 255, 255, 0, 255 ), ( 255, 255, 0, 191 ),
382                   ( 255, 255, 0, 127 ), ( 255, 255, 0, 63 ),
383                   ( 0, 0, 0, 0) ],
384                 "$name: check expected samples row 0");
385       is_deeply([ $im->getsamples(y => 1, width => 5) ],
386                 [ ( 255, 0, 0, 255 ), ( 255, 0, 0, 191 ),
387                   ( 255, 0, 0, 127 ), ( 255, 0, 0, 63 ),
388                   ( 0, 0, 0, 0) ],
389                 "$name: check expected samples row 1");
390     }
391     $interlace = 1;
392   }
393 }
394
395 {
396   my $interlace = 0;
397   for my $name ("cover16.png", "cover16i.png") {
398   SKIP: {
399       my $im = Imager->new(file => "testimg/$name");
400       ok($im, "read $name")
401         or diag "Failed to read $name: ", Imager->errstr;
402       $im
403         or skip("Couldn't load $name", 5);
404       is($im->tags(name => "i_format"), "png", "$name: i_format");
405       is($im->tags(name => "png_bits"), 16, "$name: png_bits");
406       is($im->tags(name => "png_interlace"), $interlace,
407          "$name: png_interlace");
408       is($im->getchannels, 4, "$name: four channels");
409       is($im->type, "direct", "$name: direct type");
410
411       is_deeply([ $im->getsamples(y => 0, width => 5, type => "16bit") ],
412                 [ ( 65535, 65535, 0, 65535 ), ( 65535, 65535, 0, 49087 ),
413                   ( 65535, 65535, 0, 32639 ), ( 65535, 65535, 0, 16191 ),
414                   ( 65535, 65535, 65535, 0) ],
415                 "$name: check expected samples row 0");
416       is_deeply([ $im->getsamples(y => 1, width => 5, type => "16bit") ],
417                 [ ( 65535, 0, 0, 65535 ), ( 65535, 0, 0, 49087 ),
418                   ( 65535, 0, 0, 32639 ), ( 65535, 0, 0, 16191 ),
419                   ( 65535, 65535, 65535, 0) ],
420                 "$name: check expected samples row 1");
421     }
422     $interlace = 1;
423   }
424 }
425
426 sub limited_write {
427   my ($limit) = @_;
428
429   return
430      sub {
431        my ($data) = @_;
432        $limit -= length $data;
433        if ($limit >= 0) {
434          print "# write of ", length $data, " bytes successful ($limit left)\n" if $debug_writes;
435          return 1;
436        }
437        else {
438          print "# write of ", length $data, " bytes failed\n";
439          Imager::i_push_error(0, "limit reached");
440          return;
441        }
442      };
443 }