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 $Imager::formats{"png"}
  14   or plan skip_all => "No png support";
  15
  16 plan tests => 93;
  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"), "adam7", "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 sub limited_write {
 309   my ($limit) = @_;
 310
 311   return
 312      sub {
 313        my ($data) = @_;
 314        $limit -= length $data;
 315        if ($limit >= 0) {
 316          print "# write of ", length $data, " bytes successful ($limit left)\n" if $debug_writes;
 317          return 1;
 318        }
 319        else {
 320          print "# write of ", length $data, " bytes failed\n";
 321          Imager::i_push_error(0, "limit reached");
 322          return;
 323        }
 324      };
 325 }