t/t102png.t

   1 #!perl -w
   2 use strict;
   3 use Test::More tests => 34;
   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     cmp_ok($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     cmp_ok($im->errstr, '=~', "format 'png' not supported", "check no png message");
  44     ok(!grep($_ eq 'png', Imager->read_types), "check png not in read types");
  45     ok(!grep($_ eq 'png', Imager->write_types), "check png not in write types");
  46     skip("no png support", 27);
  47   }
  48 } else {
  49   Imager::i_tags_add($img, "i_xres", 0, "300", 0);
  50   Imager::i_tags_add($img, "i_yres", 0, undef, 200);
  51   # the following confuses the GIMP
  52   #Imager::i_tags_add($img, "i_aspect_only", 0, undef, 1);
  53   open(FH,">testout/t102.png") || die "cannot open testout/t102.png for writing\n";
  54   binmode(FH);
  55   my $IO = Imager::io_new_fd(fileno(FH));
  56   ok(i_writepng_wiol($img, $IO), "write");
  57   close(FH);
  58
  59   open(FH,"testout/t102.png") || die "cannot open testout/t102.png\n";
  60   binmode(FH);
  61   $IO = Imager::io_new_fd(fileno(FH));
  62   my $cmpimg = i_readpng_wiol($IO, -1);
  63   close(FH);
  64   ok($cmpimg, "read png");
  65
  66   print "# png average mean square pixel difference: ",sqrt(i_img_diff($img,$cmpimg))/150*150,"\n";
  67   is(i_img_diff($img, $cmpimg), 0, "compare saved and original images");
  68
  69   my %tags = map { Imager::i_tags_get($cmpimg, $_) }
  70     0..Imager::i_tags_count($cmpimg) - 1;
  71   ok(abs($tags{i_xres} - 300) < 1, "i_xres: $tags{i_xres}");
  72   ok(abs($tags{i_yres} - 200) < 1, "i_yres: $tags{i_yres}");
  73   is($tags{i_format}, "png", "i_format: $tags{i_format}");
  74
  75   open FH, "> testout/t102_trans.png"
  76     or die "Cannot open testout/t102_trans.png: $!";
  77   binmode FH;
  78   $IO = Imager::io_new_fd(fileno(FH));
  79   ok(i_writepng_wiol($timg, $IO), "write tranparent");
  80   close FH;
  81
  82   open FH,"testout/t102_trans.png"
  83     or die "cannot open testout/t102_trans.png\n";
  84   binmode(FH);
  85   $IO = Imager::io_new_fd(fileno(FH));
  86   $cmpimg = i_readpng_wiol($IO, -1);
  87   ok($cmpimg, "read transparent");
  88   close(FH);
  89
  90   print "# png average mean square pixel difference: ",sqrt(i_img_diff($timg,$cmpimg))/150*150,"\n";
  91   is(i_img_diff($timg, $cmpimg), 0, "compare saved and original transparent");
  92
  93   # REGRESSION TEST
  94   # png.c 1.1 would produce an incorrect image when loading images with
  95   # less than 8 bits/pixel with a transparent palette entry
  96   open FH, "< testimg/palette.png"
  97     or die "cannot open testimg/palette.png: $!\n";
  98   binmode FH;
  99   $IO = Imager::io_new_fd(fileno(FH));
 100   # 1.1 may segfault here (it does with libefence)
 101   my $pimg = i_readpng_wiol($IO,-1);
 102   ok($pimg, "read transparent paletted image");
 103   close FH;
 104
 105   open FH, "< testimg/palette_out.png"
 106     or die "cannot open testimg/palette_out.png: $!\n";
 107   binmode FH;
 108   $IO = Imager::io_new_fd(fileno(FH));
 109   my $poimg = i_readpng_wiol($IO, -1);
 110   ok($poimg, "read palette_out image");
 111   close FH;
 112   if (!is(i_img_diff($pimg, $poimg), 0, "images the same")) {
 113     print <<EOS;
 114 # this tests a bug in Imager's png.c v1.1
 115 # if also tickles a bug in libpng before 1.0.5, so you may need to
 116 # upgrade libpng
 117 EOS
 118   }
 119
 120   { # check file limits are checked
 121     my $limit_file = "testout/t102.png";
 122     ok(Imager->set_file_limits(reset=>1, width=>149), "set width limit 149");
 123     my $im = Imager->new;
 124     ok(!$im->read(file=>$limit_file),
 125        "should fail read due to size limits");
 126     print "# ",$im->errstr,"\n";
 127     like($im->errstr, qr/image width/, "check message");
 128
 129     ok(Imager->set_file_limits(reset=>1, height=>149), "set height limit 149");
 130     ok(!$im->read(file=>$limit_file),
 131        "should fail read due to size limits");
 132     print "# ",$im->errstr,"\n";
 133     like($im->errstr, qr/image height/, "check message");
 134
 135     ok(Imager->set_file_limits(reset=>1, width=>150), "set width limit 150");
 136     ok($im->read(file=>$limit_file),
 137        "should succeed - just inside width limit");
 138     ok(Imager->set_file_limits(reset=>1, height=>150), "set height limit 150");
 139     ok($im->read(file=>$limit_file),
 140        "should succeed - just inside height limit");
 141
 142     # 150 x 150 x 3 channel image uses 67500 bytes
 143     ok(Imager->set_file_limits(reset=>1, bytes=>67499),
 144        "set bytes limit 67499");
 145     ok(!$im->read(file=>$limit_file),
 146        "should fail - too many bytes");
 147     print "# ",$im->errstr,"\n";
 148     like($im->errstr, qr/storage size/, "check error message");
 149     ok(Imager->set_file_limits(reset=>1, bytes=>67500),
 150        "set bytes limit 67500");
 151     ok($im->read(file=>$limit_file),
 152        "should succeed - just inside bytes limit");
 153     Imager->set_file_limits(reset=>1);
 154   }
 155
 156   { # check if the read_multi fallback works
 157     my @imgs = Imager->read_multi(file => 'testout/t102.png');
 158     is(@imgs, 1, "check the image was loaded");
 159     is(i_img_diff($img, $imgs[0]), 0, "check image matches");
 160
 161     # check the write_multi fallback
 162     ok(Imager->write_multi({ file => 'testout/t102m.png', type => 'png' },
 163                            @imgs),
 164        'test write_multi() callback');
 165
 166     # check that we fail if we actually write 2
 167     ok(!Imager->write_multi({ file => 'testout/t102m.png', type => 'png' },
 168                            @imgs, @imgs),
 169        'test write_multi() callback failure');
 170   }
 171
 172   {
 173     ok(grep($_ eq 'png', Imager->read_types), "check png in read types");
 174     ok(grep($_ eq 'png', Imager->write_types), "check png in write types");
 175   }
 176 }