t/t10formats.t

   1 # Before `make install' is performed this script should be runnable with
   2 # `make test'. After `make install' it should work as `perl test.pl'
   3
   4 ######################### We start with some black magic to print on failure.
   5
   6 # Change 1..1 below to 1..last_test_to_print .
   7 # (It may become useful if the test is moved to ./t subdirectory.)
   8 use lib qw(blib/lib blib/arch);
   9
  10 BEGIN { $| = 1; print "1..28\n"; }
  11 END {print "not ok 1\n" unless $loaded;}
  12 use Imager qw(:all);
  13
  14 $loaded = 1;
  15 print "ok 1\n";
  16
  17
  18
  19 init_log("testout/t10formats.log",1);
  20
  21 i_has_format("jpeg") && print "# has jpeg\n";
  22 i_has_format("tiff") && print "# has tiff\n";
  23 i_has_format("png") && print "# has png\n";
  24 i_has_format("gif") && print "# has gif\n";
  25
  26 $green=i_color_new(0,255,0,255);
  27 $blue=i_color_new(0,0,255,255);
  28 $red=i_color_new(255,0,0,255);
  29
  30 $img=Imager::ImgRaw::new(150,150,3);
  31 $cmpimg=Imager::ImgRaw::new(150,150,3);
  32
  33 i_box_filled($img,70,25,130,125,$green);
  34 i_box_filled($img,20,25,80,125,$blue);
  35 i_arc($img,75,75,30,0,361,$red);
  36 i_conv($img,[0.1, 0.2, 0.4, 0.2, 0.1]);
  37
  38 if (!i_has_format("jpeg")) {
  39   print "ok 2 # skip\n";
  40   print "ok 3 # skip\n";
  41 } else {
  42   open(FH,">testout/t10.jpg") || die "cannot open testout/t10.jpg for writing\n";
  43   binmode(FH);
  44   i_writejpeg($img,fileno(FH),30);
  45   close(FH);
  46
  47   print "ok 2\n";
  48
  49   open(FH,"testout/t10.jpg") || die "cannot open testout/t10.jpg\n";
  50   binmode(FH);
  51
  52   ($cmpimg,undef)=i_readjpeg(fileno(FH));
  53   close(FH);
  54
  55   print "# jpeg average mean square pixel difference: ",sqrt(i_img_diff($img,$cmpimg))/150*150,"\n";
  56   print "ok 3\n";
  57 }
  58
  59 if (!i_has_format("png")) {
  60   print "ok 4 # skip\n";
  61   print "ok 5 # skip\n";
  62 } else {
  63   open(FH,">testout/t10.png") || die "cannot open testout/t10.png for writing\n";
  64   binmode(FH);
  65   i_writepng($img,fileno(FH)) || die "Cannot write testout/t10.png\n";
  66   close(FH);
  67
  68   print "ok 4\n";
  69
  70   open(FH,"testout/t10.png") || die "cannot open testout/t10.png\n";
  71   binmode(FH);
  72   $cmpimg=i_readpng(fileno(FH)) || die "Cannot read testout/t10.pmg\n";
  73   close(FH);
  74
  75   print "# png average mean square pixel difference: ",sqrt(i_img_diff($img,$cmpimg))/150*150,"\n";
  76   print "ok 5\n";
  77 }
  78
  79 open(FH,">testout/t10.raw") || die "Cannot open testout/t10.raw for writing\n";
  80 binmode(FH);
  81 i_writeraw($img,fileno(FH)) || die "Cannot write testout/t10.raw\n";
  82 close(FH);
  83
  84 print "ok 6\n";
  85
  86 open(FH,"testout/t10.raw") || die "Cannot open testout/t15.raw\n";
  87 binmode(FH);
  88 $cmpimg=i_readraw(fileno(FH),150,150,3,3,0) || die "Cannot read testout/t10.raw\n";
  89 close(FH);
  90
  91 print "# raw average mean square pixel difference: ",sqrt(i_img_diff($img,$cmpimg))/150*150,"\n";
  92 print "ok 7\n";
  93
  94 open(FH,">testout/t10.ppm") || die "Cannot open testout/t10.ppm\n";
  95 binmode(FH);
  96 i_writeppm($img,fileno(FH)) || die "Cannot write testout/t10.ppm\n";
  97 close(FH);
  98
  99 print "ok 8\n";
 100
 101 open(FH,"testout/t10.ppm") || die "Cannot open testout/t10.ppm\n";
 102 binmode(FH);
 103
 104 my $IO = Imager::io_new_fd(fileno(FH));
 105 $cmpimg=i_readpnm_wiol($IO,-1) || die "Cannot read testout/t10.ppm\n";
 106 close(FH);
 107
 108 print "ok 9\n";
 109
 110 if (!i_has_format("gif")) {
 111         for (10..25) { print "ok $_ # skip no gif support\n"; }
 112 } else {
 113     open(FH,">testout/t10.gif") || die "Cannot open testout/t10.gif\n";
 114     binmode(FH);
 115     i_writegifmc($img,fileno(FH),7) || die "Cannot write testout/t10.gif\n";
 116     close(FH);
 117
 118     print "ok 10\n";
 119
 120     open(FH,"testout/t10.gif") || die "Cannot open testout/t10.gif\n";
 121     binmode(FH);
 122     $img=i_readgif(fileno(FH)) || die "Cannot read testout/t10.gif\n";
 123     close(FH);
 124
 125     print "ok 11\n";
 126
 127     open(FH,"testout/t10.gif") || die "Cannot open testout/t10.gif\n";
 128     binmode(FH);
 129     ($img, $palette)=i_readgif(fileno(FH));
 130     $img || die "Cannot read testout/t10.gif\n";
 131     close(FH);
 132
 133     $palette=''; # just to skip a warning.
 134
 135     print "ok 12\n";
 136
 137     # check that reading interlaced/non-interlaced versions of
 138     # the same GIF produce the same image
 139     open(FH, "<testimg/scalei.gif") || die "Cannot open testimg/scalei.gif";
 140     binmode FH;
 141     ($imgi) = i_readgif(fileno(FH));
 142     $imgi || die "Cannot read testimg/scalei.gif";
 143     close FH;
 144     print "ok 13\n";
 145     open FH, "<testimg/scale.gif" or die "Cannot open testimg/scale.gif";
 146     binmode FH;
 147     ($imgni) = i_readgif(fileno(FH));
 148     $imgni or die "Cannot read testimg/scale.gif";
 149     close FH;
 150     print "ok 14\n";
 151
 152     open FH, ">testout/t10i.ppm" or die "Cannot create testout/t10i.ppm";
 153     binmode FH;
 154     i_writeppm($imgi, fileno(FH)) or die "Cannot write testout/t10i.ppm";
 155     close FH;
 156
 157     open FH, ">testout/t10ni.ppm" or die "Cannot create testout/t10ni.ppm";
 158     binmode FH;
 159     i_writeppm($imgni, fileno(FH)) or die "Cannot write testout/t10ni.ppm";
 160     close FH;
 161
 162     # compare them
 163     open FH, "<testout/t10i.ppm" or die "Cannot open testout/t10i.ppm";
 164     $datai = do { local $/; <FH> };
 165     close FH;
 166     open FH, "<testout/t10ni.ppm" or die "Cannot open testout/t10ni.ppm";
 167     $datani = do { local $/; <FH> };
 168     close FH;
 169     if ($datai eq $datani) {
 170       print "ok 15\n";
 171     }
 172     else {
 173       print "not ok 15\n";
 174     }
 175
 176     my $gifver = Imager::i_giflib_version();
 177     if ($gifver >= 4.0) {
 178       # reading with a callback
 179       # various sizes to make sure the buffering works
 180       # requested size
 181       open FH, "<testimg/scale.gif" or die "Cannot open testimg/scale.gif";
 182       binmode FH;
 183       # no callback version in giflib3, so don't overwrite a good image
 184       my $img2 = i_readgif_callback(sub { my $tmp; read(FH, $tmp, $_[0]) and $tmp });
 185       close FH;
 186       print $img ? "ok 16\n" : "not ok 16\n";
 187
 188       print test_readgif_cb(1) ? "ok 17\n" : "not ok 17\n";
 189       print test_readgif_cb(512) ? "ok 18\n" : "not ok 18\n";
 190       print test_readgif_cb(1024) ? "ok 19\n" : "not ok 19\n";
 191     }
 192     else {
 193       print "ok $_ # skip - giflib3 doesn't support callbacks\n" for (16..19);
 194     }
 195     open FH, ">testout/t10_mc.gif" or die "Cannot open testout/t10_mc.gif";
 196     binmode FH;
 197     i_writegifmc($img, fileno(FH), 7) or die "Cannot write testout/t10_mc.gif";
 198     close(FH);
 199
 200     # new writegif_gen
 201     # test webmap, custom errdiff map
 202     # (looks fairly awful)
 203     open FH, ">testout/t10_gen.gif" or die $!;
 204     binmode FH;
 205     i_writegif_gen(fileno(FH), { make_colors=>'webmap',
 206                                  translate=>'errdiff',
 207                                  errdiff=>'custom',
 208                                  errdiff_width=>2,
 209                                  errdiff_height=>2,
 210                                  errdiff_map=>[0, 1, 1, 0]}, $img)
 211       or die "Cannot writegif_gen";
 212     close FH;
 213     print "ok 20\n";
 214
 215     print "# the following tests are fairly slow\n";
 216
 217     # test animation, mc_addi, error diffusion, ordered transparency
 218     my @imgs;
 219     my $sortagreen = i_color_new(0, 255, 0, 63);
 220     for my $i (0..4) {
 221       my $im = Imager::ImgRaw::new(200, 200, 4);
 222       for my $j (0..$i-1) {
 223         my $fill = i_color_new(0, 128, 0, 255 * ($i-$j)/$i);
 224         i_box_filled($im, 0, $j*40, 199, $j*40+40, $fill);
 225       }
 226       i_box_filled($im, 0, $i*40, 199, 199, $blue);
 227       push(@imgs, $im);
 228     }
 229     my @gif_delays = (50) x 5;
 230     my @gif_disposal = (2) x 5;
 231     open FH, ">testout/t10_anim.gif" or die $!;
 232     binmode FH;
 233     i_writegif_gen(fileno(FH), { make_colors=>'addi',
 234                                  translate=>'closest',
 235                                  gif_delays=>\@gif_delays,
 236                                  gif_disposal=>\@gif_disposal,
 237                                  transp=>'ordered',
 238                                  tr_orddith=>'dot8'}, @imgs)
 239       or die "Cannot write anim gif";
 240     close FH;
 241     print "ok 21\n";
 242
 243     if ($gifver >= 4.0) {
 244       unless (fork) {
 245         # this can SIGSEGV with some versions of giflib
 246         open FH, ">testout/t10_anim_cb.gif" or die $!;
 247         i_writegif_callback(sub {
 248                               print FH $_[0]
 249                             },
 250                             -1, # max buffering
 251                             { make_colors=>'webmap',
 252                               translate=>'closest',
 253                               gif_delays=>\@gif_delays,
 254                               gif_disposal=>\@gif_disposal,
 255                               #transp=>'ordered',
 256                               tr_orddith=>'dot8'}, @imgs)
 257           or die "Cannot write anim gif";
 258         close FH;
 259         print "ok 22\n";
 260         exit;
 261       }
 262       if (wait > 0 && $?) {
 263         print "not ok 22 # you probably need to patch giflib\n";
 264         print <<EOS;
 265 #--- egif_lib.c 2000/12/11 07:33:12     1.1
 266 #+++ egif_lib.c 2000/12/11 07:33:48
 267 #@@ -167,6 +167,12 @@
 268 #         _GifError = E_GIF_ERR_NOT_ENOUGH_MEM;
 269 #         return NULL;
 270 #     }
 271 #+    if ((Private->HashTable = _InitHashTable()) == NULL) {
 272 #+        free(GifFile);
 273 #+        free(Private);
 274 #+        _GifError = E_GIF_ERR_NOT_ENOUGH_MEM;
 275 #+        return NULL;
 276 #+    }
 277 #
 278 #     GifFile->Private = (VoidPtr) Private;
 279 #     Private->FileHandle = 0;
 280 EOS
 281       }
 282     }
 283     else {
 284       print "ok 22 # skip - giflib3 doesn't support callbacks\n";
 285     }
 286     @imgs = ();
 287     for $g (0..3) {
 288       my $im = Imager::ImgRaw::new(200, 200, 3);
 289       for my $x (0 .. 39) {
 290         for my $y (0 .. 39) {
 291           my $c = i_color_new($x * 6, $y * 6, 32*$g+$x+$y, 255);
 292           i_box_filled($im, $x*5, $y*5, $x*5+4, $y*5+4, $c);
 293         }
 294       }
 295       push(@imgs, $im);
 296     }
 297     # test giflib with multiple palettes
 298     # (it was meant to test the NS loop extension too, but that's broken)
 299     # this looks better with make_colors=>'addi', translate=>'errdiff'
 300     # this test aims to overload the palette for each image, so the
 301     # output looks moderately horrible
 302     open FH, ">testout/t10_mult_pall.gif" or die "Cannot create file: $!";
 303     binmode FH;
 304     i_writegif_gen(fileno(FH), { make_colors=>'webmap',
 305                                  translate=>'giflib',
 306                                  gif_delays=>[ 50, 50, 50, 50 ],
 307                                  #gif_loop_count => 50,
 308                                  gif_each_palette => 1,
 309                                }, @imgs) or print "not ";
 310     close FH;
 311     print "ok 23\n";
 312
 313     # regression test: giflib doesn't like 1 colour images
 314     my $img1 = Imager::ImgRaw::new(100, 100, 3);
 315     i_box_filled($img1, 0, 0, 100, 100, $red);
 316     open FH, ">testout/t10_onecol.gif" or die $!;
 317     binmode FH;
 318     if (i_writegif_gen(fileno(FH), { translate=>'giflib'}, $img1)) {
 319       print "ok 24 # single colour write regression\n";
 320     } else {
 321       print "not ok 24 # single colour write regression\n";
 322     }
 323     close FH;
 324
 325     # transparency test
 326     # previously it was harder do write transparent images
 327     # tests the improvements
 328     my $timg = Imager::ImgRaw::new(20, 20, 4);
 329     my $trans = i_color_new(255, 0, 0, 127);
 330     i_box_filled($timg, 0, 0, 20, 20, $green);
 331     i_box_filled($timg, 2, 2, 18, 18, $trans);
 332     open FH, ">testout/t10_trans.gif" or die $!;
 333     binmode FH;
 334     i_writegif_gen(fileno(FH), { make_colors=>'addi',
 335                                  translate=>'closest',
 336                                  transp=>'ordered',
 337                                }, $timg) or print "not ";
 338     print "ok 25\n";
 339     close FH;
 340 }
 341
 342
 343
 344 if (!i_has_format("tiff")) {
 345   print "ok 26 # skip\n";
 346   print "ok 27 # skip\n";
 347   print "ok 28 # skip\n";
 348 } else {
 349   open(FH,">testout/t10.tiff") || die "cannot open testout/t10.tiff for writing\n";
 350   binmode(FH);
 351   my $IO = Imager::io_new_fd(fileno(FH));
 352   i_writetiff_wiol($img, $IO);
 353   close(FH);
 354
 355   print "ok 26\n";
 356
 357   open(FH,"testout/t10.tiff") or die "cannot open testout/t10.tiff\n";
 358   binmode(FH);
 359   $IO = Imager::io_new_fd(fileno(FH));
 360   $cmpimg = i_readtiff_wiol($IO, -1);
 361
 362   close(FH);
 363
 364   print "# tiff average mean square pixel difference: ",sqrt(i_img_diff($img,$cmpimg))/150*150,"\n";
 365   print "ok 27\n";
 366
 367   $IO = Imager::io_new_bufchain();
 368
 369   Imager::i_writetiff_wiol($img, $IO) or die "Cannot write to bufferchain\n";
 370   my $tiffdata = Imager::io_slurp($IO);
 371
 372   open(FH,"testout/t10.tiff");
 373   my $odata;
 374   { local $/;
 375     $odata = <FH>;
 376   }
 377
 378   if ($odata eq $tiffdata) {
 379     print "ok 28\n";
 380   } else {
 381     print "not ok 28\n";
 382   }
 383
 384
 385
 386 }
 387
 388
 389
 390 sub test_readgif_cb {
 391   my ($size) = @_;
 392
 393   open FH, "<testimg/scale.gif" or die "Cannot open testimg/scale.gif";
 394   binmode FH;
 395   my $img = i_readgif_callback(sub { my $tmp; read(FH, $tmp, $size) and $tmp });
 396   close FH;
 397   return $img;
 398 }
 399
 400 # malloc_state();