t/t102png.t

   1 #!perl -w
   2 use strict;
   3 use Imager qw(:all);
   4 use Test::More;
   5 use Imager::Test qw(test_image_raw);
   6
   7 init_log("testout/t102png.log",1);
   8
   9 i_has_format("png")
  10   or skip_all("No png support");
  11
  12 plan tests => 33;
  13
  14 my $green  = i_color_new(0,   255, 0,   255);
  15 my $blue   = i_color_new(0,   0,   255, 255);
  16 my $red    = i_color_new(255, 0,   0,   255);
  17
  18 my $img    = test_image_raw();
  19
  20 my $timg = Imager::ImgRaw::new(20, 20, 4);
  21 my $trans = i_color_new(255, 0, 0, 127);
  22 i_box_filled($timg, 0, 0, 20, 20, $green);
  23 i_box_filled($timg, 2, 2, 18, 18, $trans);
  24
  25 Imager::i_tags_add($img, "i_xres", 0, "300", 0);
  26 Imager::i_tags_add($img, "i_yres", 0, undef, 200);
  27 # the following confuses the GIMP
  28 #Imager::i_tags_add($img, "i_aspect_only", 0, undef, 1);
  29 open(FH,">testout/t102.png") || die "cannot open testout/t102.png for writing\n";
  30 binmode(FH);
  31 my $IO = Imager::io_new_fd(fileno(FH));
  32 ok(i_writepng_wiol($img, $IO), "write");
  33 close(FH);
  34
  35 open(FH,"testout/t102.png") || die "cannot open testout/t102.png\n";
  36 binmode(FH);
  37 $IO = Imager::io_new_fd(fileno(FH));
  38 my $cmpimg = i_readpng_wiol($IO, -1);
  39 close(FH);
  40 ok($cmpimg, "read png");
  41
  42 print "# png average mean square pixel difference: ",sqrt(i_img_diff($img,$cmpimg))/150*150,"\n";
  43 is(i_img_diff($img, $cmpimg), 0, "compare saved and original images");
  44
  45 my %tags = map { Imager::i_tags_get($cmpimg, $_) }
  46   0..Imager::i_tags_count($cmpimg) - 1;
  47 ok(abs($tags{i_xres} - 300) < 1, "i_xres: $tags{i_xres}");
  48 ok(abs($tags{i_yres} - 200) < 1, "i_yres: $tags{i_yres}");
  49 is($tags{i_format}, "png", "i_format: $tags{i_format}");
  50
  51 open FH, "> testout/t102_trans.png"
  52   or die "Cannot open testout/t102_trans.png: $!";
  53 binmode FH;
  54 $IO = Imager::io_new_fd(fileno(FH));
  55 ok(i_writepng_wiol($timg, $IO), "write tranparent");
  56 close FH;
  57
  58 open FH,"testout/t102_trans.png"
  59   or die "cannot open testout/t102_trans.png\n";
  60 binmode(FH);
  61 $IO = Imager::io_new_fd(fileno(FH));
  62 $cmpimg = i_readpng_wiol($IO, -1);
  63 ok($cmpimg, "read transparent");
  64 close(FH);
  65
  66 print "# png average mean square pixel difference: ",sqrt(i_img_diff($timg,$cmpimg))/150*150,"\n";
  67 is(i_img_diff($timg, $cmpimg), 0, "compare saved and original transparent");
  68
  69 # REGRESSION TEST
  70 # png.c 1.1 would produce an incorrect image when loading images with
  71 # less than 8 bits/pixel with a transparent palette entry
  72 open FH, "< testimg/palette.png"
  73   or die "cannot open testimg/palette.png: $!\n";
  74 binmode FH;
  75 $IO = Imager::io_new_fd(fileno(FH));
  76 # 1.1 may segfault here (it does with libefence)
  77 my $pimg = i_readpng_wiol($IO,-1);
  78 ok($pimg, "read transparent paletted image");
  79 close FH;
  80
  81 open FH, "< testimg/palette_out.png"
  82   or die "cannot open testimg/palette_out.png: $!\n";
  83 binmode FH;
  84 $IO = Imager::io_new_fd(fileno(FH));
  85 my $poimg = i_readpng_wiol($IO, -1);
  86 ok($poimg, "read palette_out image");
  87 close FH;
  88 if (!is(i_img_diff($pimg, $poimg), 0, "images the same")) {
  89   print <<EOS;
  90 # this tests a bug in Imager's png.c v1.1
  91 # if also tickles a bug in libpng before 1.0.5, so you may need to
  92 # upgrade libpng
  93 EOS
  94 }
  95
  96 { # check file limits are checked
  97   my $limit_file = "testout/t102.png";
  98   ok(Imager->set_file_limits(reset=>1, width=>149), "set width limit 149");
  99   my $im = Imager->new;
 100   ok(!$im->read(file=>$limit_file),
 101      "should fail read due to size limits");
 102   print "# ",$im->errstr,"\n";
 103   like($im->errstr, qr/image width/, "check message");
 104
 105   ok(Imager->set_file_limits(reset=>1, height=>149), "set height limit 149");
 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 height/, "check message");
 110
 111   ok(Imager->set_file_limits(reset=>1, width=>150), "set width limit 150");
 112   ok($im->read(file=>$limit_file),
 113      "should succeed - just inside width limit");
 114   ok(Imager->set_file_limits(reset=>1, height=>150), "set height limit 150");
 115   ok($im->read(file=>$limit_file),
 116      "should succeed - just inside height limit");
 117
 118   # 150 x 150 x 3 channel image uses 67500 bytes
 119   ok(Imager->set_file_limits(reset=>1, bytes=>67499),
 120      "set bytes limit 67499");
 121   ok(!$im->read(file=>$limit_file),
 122        "should fail - too many bytes");
 123   print "# ",$im->errstr,"\n";
 124     like($im->errstr, qr/storage size/, "check error message");
 125   ok(Imager->set_file_limits(reset=>1, bytes=>67500),
 126      "set bytes limit 67500");
 127   ok($im->read(file=>$limit_file),
 128      "should succeed - just inside bytes limit");
 129   Imager->set_file_limits(reset=>1);
 130 }
 131
 132 { # check if the read_multi fallback works
 133   my @imgs = Imager->read_multi(file => 'testout/t102.png');
 134   is(@imgs, 1, "check the image was loaded");
 135   is(i_img_diff($img, $imgs[0]), 0, "check image matches");
 136
 137   # check the write_multi fallback
 138   ok(Imager->write_multi({ file => 'testout/t102m.png', type => 'png' },
 139                          @imgs),
 140        'test write_multi() callback');
 141
 142   # check that we fail if we actually write 2
 143   ok(!Imager->write_multi({ file => 'testout/t102m.png', type => 'png' },
 144                            @imgs, @imgs),
 145      'test write_multi() callback failure');
 146 }
 147
 148 {
 149   ok(grep($_ eq 'png', Imager->read_types), "check png in read types");
 150   ok(grep($_ eq 'png', Imager->write_types), "check png in write types");
 151 }
 152