t/t102png.t

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