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