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..24) { print "ok $_ # skip\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 $gifvertext = Imager::i_giflib_version();
 177     $gifvertext =~ /(\d+\.\d+)/;
 178     my $gifver = $1 || 0;
 179     if ($gifver >= 4.0) {
 180       # reading with a callback
 181       # various sizes to make sure the buffering works
 182       # requested size
 183       open FH, "<testimg/scale.gif" or die "Cannot open testimg/scale.gif";
 184       binmode FH;
 185       # no callback version in giflib3, so don't overwrite a good image
 186       my $img2 = i_readgif_callback(sub { my $tmp; read(FH, $tmp, $_[0]) and $tmp });
 187       close FH;
 188       print $img ? "ok 16\n" : "not ok 16\n";
 189
 190       print test_readgif_cb(1) ? "ok 17\n" : "not ok 17\n";
 191       print test_readgif_cb(512) ? "ok 18\n" : "not ok 18\n";
 192       print test_readgif_cb(1024) ? "ok 19\n" : "not ok 19\n";
 193     }
 194     else {
 195       print "ok $_ # skip - giflib3 doesn't support callbacks\n" for (16..19);
 196     }
 197     open FH, ">testout/t10_mc.gif" or die "Cannot open testout/t10_mc.gif";
 198     binmode FH;
 199     i_writegifmc($img, fileno(FH), 7) or die "Cannot write testout/t10_mc.gif";
 200     close(FH);
 201
 202     # new writegif_gen
 203     # test webmap, custom errdiff map
 204     # (looks fairly awful)
 205     open FH, ">testout/t10_gen.gif" or die $!;
 206     binmode FH;
 207     i_writegif_gen(fileno(FH), { make_colors=>'webmap',
 208                                  translate=>'errdiff',
 209                                  errdiff=>'custom',
 210                                  errdiff_width=>2,
 211                                  errdiff_height=>2,
 212                                  errdiff_map=>[0, 1, 1, 0]}, $img)
 213       or die "Cannot writegif_gen";
 214     close FH;
 215     print "ok 20\n";
 216
 217     print "# the following tests are fairly slow\n";
 218
 219     # test animation, mc_addi, error diffusion, ordered transparency
 220     my @imgs;
 221     my $sortagreen = i_color_new(0, 255, 0, 63);
 222     for my $i (0..4) {
 223       my $im = Imager::ImgRaw::new(200, 200, 4);
 224       for my $j (0..$i-1) {
 225         my $fill = i_color_new(0, 128, 0, 255 * ($i-$j)/$i);
 226         i_box_filled($im, 0, $j*40, 199, $j*40+40, $fill);
 227       }
 228       i_box_filled($im, 0, $i*40, 199, 199, $blue);
 229       push(@imgs, $im);
 230     }
 231     my @gif_delays = (50) x 5;
 232     my @gif_disposal = (2) x 5;
 233     open FH, ">testout/t10_anim.gif" or die $!;
 234     binmode FH;
 235     i_writegif_gen(fileno(FH), { make_colors=>'addi',
 236                                  translate=>'closest',
 237                                  gif_delays=>\@gif_delays,
 238                                  gif_disposal=>\@gif_disposal,
 239                                  transp=>'ordered',
 240                                  tr_orddith=>'dot8'}, @imgs)
 241       or die "Cannot write anim gif";
 242     close FH;
 243     print "ok 21\n";
 244
 245     if ($gifver >= 4.0) {
 246       unless (fork) {
 247         # this can SIGSEGV with some versions of giflib
 248         open FH, ">testout/t10_anim_cb.gif" or die $!;
 249         i_writegif_callback(sub {
 250                               print FH $_[0]
 251                             },
 252                             -1, # max buffering
 253                             { make_colors=>'webmap',
 254                               translate=>'closest',
 255                               gif_delays=>\@gif_delays,
 256                               gif_disposal=>\@gif_disposal,
 257                               #transp=>'ordered',
 258                               tr_orddith=>'dot8'}, @imgs)
 259           or die "Cannot write anim gif";
 260         close FH;
 261         print "ok 22\n";
 262         exit;
 263       }
 264       if (wait > 0 && $?) {
 265         print "not ok 22 # you probably need to patch giflib\n";
 266         print <<EOS;
 267 #--- egif_lib.c 2000/12/11 07:33:12     1.1
 268 #+++ egif_lib.c 2000/12/11 07:33:48
 269 #@@ -167,6 +167,12 @@
 270 #         _GifError = E_GIF_ERR_NOT_ENOUGH_MEM;
 271 #         return NULL;
 272 #     }
 273 #+    if ((Private->HashTable = _InitHashTable()) == NULL) {
 274 #+        free(GifFile);
 275 #+        free(Private);
 276 #+        _GifError = E_GIF_ERR_NOT_ENOUGH_MEM;
 277 #+        return NULL;
 278 #+    }
 279 #
 280 #     GifFile->Private = (VoidPtr) Private;
 281 #     Private->FileHandle = 0;
 282 EOS
 283       }
 284     }
 285     else {
 286       print "ok 22 # skip - giflib3 doesn't support callbacks\n";
 287     }
 288     @imgs = ();
 289     for $g (0..3) {
 290       my $im = Imager::ImgRaw::new(200, 200, 3);
 291       for my $x (0 .. 39) {
 292         for my $y (0 .. 39) {
 293           my $c = i_color_new($x * 6, $y * 6, 32*$g+$x+$y, 255);
 294           i_box_filled($im, $x*5, $y*5, $x*5+4, $y*5+4, $c);
 295         }
 296       }
 297       push(@imgs, $im);
 298     }
 299     # test giflib with multiple palettes
 300     # (it was meant to test the NS loop extension too, but that's broken)
 301     # this looks better with make_colors=>'addi', translate=>'errdiff'
 302     # this test aims to overload the palette for each image, so the
 303     # output looks moderately horrible
 304     open FH, ">testout/t10_mult_pall.gif" or die "Cannot create file: $!";
 305     binmode FH;
 306     i_writegif_gen(fileno(FH), { make_colors=>'webmap',
 307                                  translate=>'giflib',
 308                                  gif_delays=>[ 50, 50, 50, 50 ],
 309                                  #gif_loop_count => 50,
 310                                  gif_each_palette => 1,
 311                                }, @imgs) or print "not ";
 312     close FH;
 313     print "ok 23\n";
 314
 315     # regression test: giflib doesn't like 1 colour images
 316     my $img1 = Imager::ImgRaw::new(100, 100, 3);
 317     i_box_filled($img1, 0, 0, 100, 100, $red);
 318     open FH, ">testout/t10_onecol.gif" or die $!;
 319     binmode FH;
 320     if (i_writegif_gen(fileno(FH), { translate=>'giflib'}, $img1)) {
 321       print "ok 24 # single colour write regression\n";
 322     } else {
 323       print "not ok 24 # single colour write regression\n";
 324     }
 325     close FH;
 326
 327     # transparency test
 328     # previously it was harder do write transparent images
 329     # tests the improvements
 330     my $timg = Imager::ImgRaw::new(20, 20, 4);
 331     my $trans = i_color_new(255, 0, 0, 127);
 332     i_box_filled($timg, 0, 0, 20, 20, $green);
 333     i_box_filled($timg, 2, 2, 18, 18, $trans);
 334     open FH, ">testout/t10_trans.gif" or die $!;
 335     binmode FH;
 336     i_writegif_gen(fileno(FH), { make_colors=>'addi',
 337                                  translate=>'closest',
 338                                  transp=>'ordered',
 339                                }, $timg) or print "not ";
 340     print "ok 25\n";
 341     close FH;
 342 }
 343
 344
 345
 346 if (!i_has_format("tiff")) {
 347   print "ok 26 # skip\n";
 348   print "ok 27 # skip\n";
 349   print "ok 28 # skip\n";
 350 } else {
 351   open(FH,">testout/t10.tiff") || die "cannot open testout/t10.tiff for writing\n";
 352   binmode(FH);
 353   my $IO = Imager::io_new_fd(fileno(FH));
 354   i_writetiff_wiol($img, $IO);
 355   close(FH);
 356
 357   print "ok 26\n";
 358
 359   open(FH,"testout/t10.tiff") or die "cannot open testout/t10.tiff\n";
 360   binmode(FH);
 361   $IO = Imager::io_new_fd(fileno(FH));
 362   $cmpimg = i_readtiff_wiol($IO, -1);
 363
 364   close(FH);
 365
 366   print "# tiff average mean square pixel difference: ",sqrt(i_img_diff($img,$cmpimg))/150*150,"\n";
 367   print "ok 27\n";
 368
 369   $IO = Imager::io_new_bufchain();
 370
 371   Imager::i_writetiff_wiol($img, $IO) or die "Cannot write to bufferchain\n";
 372   my $tiffdata = Imager::io_slurp($IO);
 373
 374   open(FH,"testout/t10.tiff");
 375   my $odata;
 376   { local $/;
 377     $odata = <FH>;
 378   }
 379
 380   if ($odata eq $tiffdata) {
 381     print "ok 28\n";
 382   } else {
 383     print "not ok 28\n";
 384   }
 385
 386
 387
 388 }
 389
 390
 391
 392 sub test_readgif_cb {
 393   my ($size) = @_;
 394
 395   open FH, "<testimg/scale.gif" or die "Cannot open testimg/scale.gif";
 396   binmode FH;
 397   my $img = i_readgif_callback(sub { my $tmp; read(FH, $tmp, $size) and $tmp });
 398   close FH;
 399   return $img;
 400 }
 401
 402 # malloc_state();