t/t102png.t

   1 #!perl -w
   2 use strict;
   3 use lib 't';
   4 use Test::More tests => 13;
   5 # Before `make install' is performed this script should be runnable with
   6 # `make test'. After `make install' it should work as `perl test.pl'
   7
   8 ######################### We start with some black magic to print on failure.
   9
  10 # Change 1..1 below to 1..last_test_to_print .
  11 # (It may become useful if the test is moved to ./t subdirectory.)
  12 use lib qw(blib/lib blib/arch);
  13
  14 BEGIN { require 't/testtools.pl'; }
  15 BEGIN { use_ok('Imager', ':all') }
  16 init_log("testout/t102png.log",1);
  17
  18 i_has_format("png") && print "# has png\n";
  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    = Imager::ImgRaw::new(150, 150, 3);
  25
  26 i_box_filled($img, 70, 25, 130, 125, $green);
  27 i_box_filled($img, 20, 25, 80,  125, $blue);
  28 i_arc($img, 75, 75, 30, 0, 361, $red);
  29 i_conv($img,[0.1, 0.2, 0.4, 0.2, 0.1]);
  30
  31 my $timg = Imager::ImgRaw::new(20, 20, 4);
  32 my $trans = i_color_new(255, 0, 0, 127);
  33 i_box_filled($timg, 0, 0, 20, 20, $green);
  34 i_box_filled($timg, 2, 2, 18, 18, $trans);
  35
  36 if (!i_has_format("png")) {
  37  SKIP:
  38   {
  39     my $im = Imager->new;
  40     ok(!$im->read(file=>"testimg/palette.png"), "should fail to read png");
  41     is($im->errstr, "format 'png' not supported", "check no png message");
  42     $im = Imager->new(xsize=>2, ysize=>2);
  43     ok(!$im->write(file=>"testout/nopng.png"), "should fail to write png");
  44     is($im->errstr, 'format not supported', "check no png message");
  45     skip("no png support", 8);
  46   }
  47 } else {
  48   Imager::i_tags_add($img, "i_xres", 0, "300", 0);
  49   Imager::i_tags_add($img, "i_yres", 0, undef, 200);
  50   # the following confuses the GIMP
  51   #Imager::i_tags_add($img, "i_aspect_only", 0, undef, 1);
  52   open(FH,">testout/t102.png") || die "cannot open testout/t102.png for writing\n";
  53   binmode(FH);
  54   my $IO = Imager::io_new_fd(fileno(FH));
  55   ok(i_writepng_wiol($img, $IO), "write");
  56   close(FH);
  57
  58   open(FH,"testout/t102.png") || die "cannot open testout/t102.png\n";
  59   binmode(FH);
  60   $IO = Imager::io_new_fd(fileno(FH));
  61   my $cmpimg = i_readpng_wiol($IO, -1);
  62   close(FH);
  63   ok($cmpimg, "read png");
  64
  65   print "# png average mean square pixel difference: ",sqrt(i_img_diff($img,$cmpimg))/150*150,"\n";
  66   is(i_img_diff($img, $cmpimg), 0, "compare saved and original images");
  67
  68   my %tags = map { Imager::i_tags_get($cmpimg, $_) }
  69     0..Imager::i_tags_count($cmpimg) - 1;
  70   ok(abs($tags{i_xres} - 300) < 1, "i_xres: $tags{i_xres}");
  71   ok(abs($tags{i_yres} - 200) < 1, "i_yres: $tags{i_yres}");
  72   is($tags{i_format}, "png", "i_format: $tags{i_format}");
  73
  74   open FH, "> testout/t102_trans.png"
  75     or die "Cannot open testout/t102_trans.png: $!";
  76   binmode FH;
  77   $IO = Imager::io_new_fd(fileno(FH));
  78   ok(i_writepng_wiol($timg, $IO), "write tranparent");
  79   close FH;
  80
  81   open FH,"testout/t102_trans.png"
  82     or die "cannot open testout/t102_trans.png\n";
  83   binmode(FH);
  84   $IO = Imager::io_new_fd(fileno(FH));
  85   $cmpimg = i_readpng_wiol($IO, -1);
  86   ok($cmpimg, "read transparent");
  87   close(FH);
  88
  89   print "# png average mean square pixel difference: ",sqrt(i_img_diff($timg,$cmpimg))/150*150,"\n";
  90   is(i_img_diff($timg, $cmpimg), 0, "compare saved and original transparent");
  91
  92   # REGRESSION TEST
  93   # png.c 1.1 would produce an incorrect image when loading images with
  94   # less than 8 bits/pixel with a transparent palette entry
  95   open FH, "< testimg/palette.png"
  96     or die "cannot open testimg/palette.png: $!\n";
  97   binmode FH;
  98   $IO = Imager::io_new_fd(fileno(FH));
  99   # 1.1 may segfault here (it does with libefence)
 100   my $pimg = i_readpng_wiol($IO,-1);
 101   ok($pimg, "read transparent paletted image");
 102   close FH;
 103
 104   open FH, "< testimg/palette_out.png"
 105     or die "cannot open testimg/palette_out.png: $!\n";
 106   binmode FH;
 107   $IO = Imager::io_new_fd(fileno(FH));
 108   my $poimg = i_readpng_wiol($IO, -1);
 109   ok($poimg, "read palette_out image");
 110   close FH;
 111   if (!is(i_img_diff($pimg, $poimg), 0, "images the same")) {
 112     print <<EOS;
 113 # this tests a bug in Imager's png.c v1.1
 114 # if also tickles a bug in libpng before 1.0.5, so you may need to
 115 # upgrade libpng
 116 EOS
 117   }
 118 }