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);
   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 => 51;
  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 sub limited_write {
 228   my ($limit) = @_;
 229
 230   return
 231      sub {
 232        my ($data) = @_;
 233        $limit -= length $data;
 234        if ($limit >= 0) {
 235          print "# write of ", length $data, " bytes successful ($limit left)\n" if $debug_writes;
 236          return 1;
 237        }
 238        else {
 239          print "# write of ", length $data, " bytes failed\n";
 240          Imager::i_push_error(0, "limit reached");
 241          return;
 242        }
 243      };
 244 }