t/t105gif.t

   1 #!perl -w
   2 use strict;
   3 $|=1;
   4 print "1..40\n";
   5 use Imager qw(:all);
   6
   7 sub ok ($$$);
   8
   9 init_log("testout/t105gif.log",1);
  10
  11 my $green=i_color_new(0,255,0,255);
  12 my $blue=i_color_new(0,0,255,255);
  13 my $red=i_color_new(255,0,0,255);
  14
  15 my $img=Imager::ImgRaw::new(150,150,3);
  16
  17 i_box_filled($img,70,25,130,125,$green);
  18 i_box_filled($img,20,25,80,125,$blue);
  19 i_arc($img,75,75,30,0,361,$red);
  20 i_conv($img,[0.1, 0.2, 0.4, 0.2, 0.1]);
  21
  22 my $timg = Imager::ImgRaw::new(20, 20, 4);
  23 my $trans = i_color_new(255, 0, 0, 127);
  24 i_box_filled($timg, 0, 0, 20, 20, $green);
  25 i_box_filled($timg, 2, 2, 18, 18, $trans);
  26
  27 if (!i_has_format("gif")) {
  28   for (1..40) { print "ok $_ # skip no gif support\n"; }
  29 } else {
  30     open(FH,">testout/t105.gif") || die "Cannot open testout/t105.gif\n";
  31     binmode(FH);
  32     i_writegifmc($img,fileno(FH),7) || die "Cannot write testout/t105.gif\n";
  33     close(FH);
  34
  35     print "ok 1\n";
  36
  37     open(FH,"testout/t105.gif") || die "Cannot open testout/t105.gif\n";
  38     binmode(FH);
  39     $img=i_readgif(fileno(FH)) || die "Cannot read testout/t105.gif\n";
  40     close(FH);
  41
  42     print "ok 2\n";
  43
  44     open(FH,"testout/t105.gif") || die "Cannot open testout/t105.gif\n";
  45     binmode(FH);
  46     ($img, my $palette)=i_readgif(fileno(FH));
  47     $img || die "Cannot read testout/t105.gif\n";
  48     close(FH);
  49
  50     $palette=''; # just to skip a warning.
  51
  52     print "ok 3\n";
  53
  54     # check that reading interlaced/non-interlaced versions of
  55     # the same GIF produce the same image
  56     # I could replace this with code that used Imager's built-in
  57     # image comparison code, but I know this code revealed the error
  58     open(FH, "<testimg/scalei.gif") || die "Cannot open testimg/scalei.gif";
  59     binmode FH;
  60     my ($imgi) = i_readgif(fileno(FH));
  61     $imgi || die "Cannot read testimg/scalei.gif";
  62     close FH;
  63     print "ok 4\n";
  64     open FH, "<testimg/scale.gif" or die "Cannot open testimg/scale.gif";
  65     binmode FH;
  66     my ($imgni) = i_readgif(fileno(FH));
  67     $imgni or die "Cannot read testimg/scale.gif";
  68     close FH;
  69     print "ok 5\n";
  70
  71     open FH, ">testout/t105i.ppm" or die "Cannot create testout/t105i.ppm";
  72     binmode FH;
  73     my $IO = Imager::io_new_fd( fileno(FH) );
  74     i_writeppm_wiol($imgi, $IO) or die "Cannot write testout/t105i.ppm";
  75     close FH;
  76
  77
  78     open FH, ">testout/t105ni.ppm" or die "Cannot create testout/t105ni.ppm";
  79     binmode FH;
  80     $IO = Imager::io_new_fd( fileno(FH) );
  81     i_writeppm_wiol($imgni, $IO) or die "Cannot write testout/t105ni.ppm";
  82     close FH;
  83
  84     # compare them
  85     open FH, "<testout/t105i.ppm" or die "Cannot open testout/t105i.ppm";
  86     my $datai = do { local $/; <FH> };
  87     close FH;
  88
  89     open FH, "<testout/t105ni.ppm" or die "Cannot open testout/t105ni.ppm";
  90     my $datani = do { local $/; <FH> };
  91     close FH;
  92     if ($datai eq $datani) {
  93       print "ok 6\n";
  94     }
  95     else {
  96       print "not ok 6\n";
  97     }
  98
  99     my $gifver = Imager::i_giflib_version();
 100     if ($gifver >= 4.0) {
 101       # reading with a callback
 102       # various sizes to make sure the buffering works
 103       # requested size
 104       open FH, "<testimg/scale.gif" or die "Cannot open testimg/scale.gif";
 105       binmode FH;
 106       # no callback version in giflib3, so don't overwrite a good image
 107       my $img2 = i_readgif_callback(sub { my $tmp; read(FH, $tmp, $_[0]) and $tmp });
 108       close FH;
 109       print $img ? "ok 7\n" : "not ok 7\n";
 110
 111       print test_readgif_cb(1) ? "ok 8\n" : "not ok 8\n";
 112       print test_readgif_cb(512) ? "ok 9\n" : "not ok 9\n";
 113       print test_readgif_cb(1024) ? "ok 10\n" : "not ok 10\n";
 114     }
 115     else {
 116       for (7..10) {
 117         print "ok $_ # skip giflib3 doesn't support callbacks\n";
 118       }
 119     }
 120     open FH, ">testout/t105_mc.gif" or die "Cannot open testout/t105_mc.gif";
 121     binmode FH;
 122     i_writegifmc($img, fileno(FH), 7) or print "not ";
 123     close(FH);
 124     print "ok 11\n";
 125
 126     # new writegif_gen
 127     # test webmap, custom errdiff map
 128     # (looks fairly awful)
 129     open FH, ">testout/t105_gen.gif" or die $!;
 130     binmode FH;
 131     i_writegif_gen(fileno(FH), { make_colors=>'webmap',
 132                                  translate=>'errdiff',
 133                                  errdiff=>'custom',
 134                                  errdiff_width=>2,
 135                                  errdiff_height=>2,
 136                                  errdiff_map=>[0, 1, 1, 0]}, $img)
 137       or print "not ";
 138     close FH;
 139     print "ok 12\n";
 140
 141     print "# the following tests are fairly slow\n";
 142
 143     # test animation, mc_addi, error diffusion, ordered transparency
 144     my @imgs;
 145     my $sortagreen = i_color_new(0, 255, 0, 63);
 146     for my $i (0..4) {
 147       my $im = Imager::ImgRaw::new(200, 200, 4);
 148       for my $j (0..$i-1) {
 149         my $fill = i_color_new(0, 128, 0, 255 * ($i-$j)/$i);
 150         i_box_filled($im, 0, $j*40, 199, $j*40+40, $fill);
 151       }
 152       i_box_filled($im, 0, $i*40, 199, 199, $blue);
 153       push(@imgs, $im);
 154     }
 155     my @gif_delays = (50) x 5;
 156     my @gif_disposal = (2) x 5;
 157     open FH, ">testout/t105_anim.gif" or die $!;
 158     binmode FH;
 159     i_writegif_gen(fileno(FH), { make_colors=>'addi',
 160                                  translate=>'closest',
 161                                  gif_delays=>\@gif_delays,
 162                                  gif_disposal=>\@gif_disposal,
 163                                  gif_positions=> [ map [ $_*10, $_*10 ], 0..4 ],
 164                                  gif_user_input=>[ 1, 0, 1, 0, 1 ],
 165                                  transp=>'ordered',
 166                                  tr_orddith=>'dot8'}, @imgs)
 167       or die "Cannot write anim gif";
 168     close FH;
 169     print "ok 13\n";
 170
 171     my $can_write_callback = 0;
 172     if ($gifver >= 4.0) {
 173       ++$can_write_callback;
 174       unless (fork) {
 175         # this can SIGSEGV with some versions of giflib
 176         open FH, ">testout/t105_anim_cb.gif" or die $!;
 177         i_writegif_callback(sub {
 178                               print FH $_[0]
 179                             },
 180                             -1, # max buffering
 181                             { make_colors=>'webmap',
 182                               translate=>'closest',
 183                               gif_delays=>\@gif_delays,
 184                               gif_disposal=>\@gif_disposal,
 185                               #transp=>'ordered',
 186                               tr_orddith=>'dot8'}, @imgs)
 187           or die "Cannot write anim gif";
 188         close FH;
 189         print "ok 14\n";
 190         exit;
 191       }
 192       if (wait > 0 && $?) {
 193         $can_write_callback = 0;
 194         print "not ok 14 # you probably need to patch giflib\n";
 195         print <<EOS;
 196 #--- egif_lib.c 2000/12/11 07:33:12     1.1
 197 #+++ egif_lib.c 2000/12/11 07:33:48
 198 #@@ -167,6 +167,12 @@
 199 #         _GifError = E_GIF_ERR_NOT_ENOUGH_MEM;
 200 #         return NULL;
 201 #     }
 202 #+    if ((Private->HashTable = _InitHashTable()) == NULL) {
 203 #+        free(GifFile);
 204 #+        free(Private);
 205 #+        _GifError = E_GIF_ERR_NOT_ENOUGH_MEM;
 206 #+        return NULL;
 207 #+    }
 208 #
 209 #     GifFile->Private = (VoidPtr) Private;
 210 #     Private->FileHandle = 0;
 211 EOS
 212       }
 213     }
 214     else {
 215       print "ok 14 # skip giflib3 doesn't support callbacks\n";
 216     }
 217     @imgs = ();
 218     for my $g (0..3) {
 219       my $im = Imager::ImgRaw::new(200, 200, 3);
 220       for my $x (0 .. 39) {
 221         for my $y (0 .. 39) {
 222           my $c = i_color_new($x * 6, $y * 6, 32*$g+$x+$y, 255);
 223           i_box_filled($im, $x*5, $y*5, $x*5+4, $y*5+4, $c);
 224         }
 225       }
 226       push(@imgs, $im);
 227     }
 228     # test giflib with multiple palettes
 229     # (it was meant to test the NS loop extension too, but that's broken)
 230     # this looks better with make_colors=>'addi', translate=>'errdiff'
 231     # this test aims to overload the palette for each image, so the
 232     # output looks moderately horrible
 233     open FH, ">testout/t105_mult_pall.gif" or die "Cannot create file: $!";
 234     binmode FH;
 235     if (i_writegif_gen(fileno(FH), { make_colors=>'webmap',
 236                                      translate=>'giflib',
 237                                      gif_delays=>[ 50, 50, 50, 50 ],
 238                                      #gif_loop_count => 50,
 239                                      gif_each_palette => 1,
 240                                    }, @imgs)) {
 241       print "ok 15\n";
 242     }
 243     else {
 244       print "not ok 15 # ", join(":", map $_->[1], Imager::i_errors()),"\n";
 245     }
 246     close FH;
 247
 248     # regression test: giflib doesn't like 1 colour images
 249     my $img1 = Imager::ImgRaw::new(100, 100, 3);
 250     i_box_filled($img1, 0, 0, 100, 100, $red);
 251     open FH, ">testout/t105_onecol.gif" or die $!;
 252     binmode FH;
 253     if (i_writegif_gen(fileno(FH), { translate=>'giflib'}, $img1)) {
 254       print "ok 16 # single colour write regression\n";
 255     } else {
 256       print "not ok 16 # single colour write regression\n";
 257     }
 258     close FH;
 259
 260     # transparency test
 261     # previously it was harder do write transparent images
 262     # tests the improvements
 263     my $timg = Imager::ImgRaw::new(20, 20, 4);
 264     my $trans = i_color_new(255, 0, 0, 127);
 265     i_box_filled($timg, 0, 0, 20, 20, $green);
 266     i_box_filled($timg, 2, 2, 18, 18, $trans);
 267     open FH, ">testout/t105_trans.gif" or die $!;
 268     binmode FH;
 269     i_writegif_gen(fileno(FH), { make_colors=>'addi',
 270                                  translate=>'closest',
 271                                  transp=>'ordered',
 272                                }, $timg) or print "not ";
 273     print "ok 17\n";
 274     close FH;
 275
 276     # some error handling tests
 277     # open a file handle for read and try to save to it
 278     # is this idea portable?
 279     # whether or not it is, giflib segfaults on this <sigh>
 280     #open FH, "<testout/t105_trans.gif" or die $!;
 281     #binmode FH; # habit, I suppose
 282     #if (i_writegif_gen(fileno(FH), {}, $timg)) {
 283     #  # this is meant to _fail_
 284     #  print "not ok 18 # writing to read-only should fail";
 285     #}
 286     #else {
 287     #  print "ok 18 # ",Imager::_error_as_msg(),"\n";
 288     #}
 289     #close FH;
 290
 291     # try to read a file of the wrong format - the script will do
 292     open FH, "<t/t105gif.t"
 293       or die "Cannot open this script!: $!";
 294     binmode FH;
 295     my $im2 = i_readgif(fileno(FH));
 296     if ($im2) {
 297       # this should have failed
 298       print "not ok 18 # giflib think script if a GIF file\n";
 299     }
 300     else {
 301       print "ok 18 # ",Imager::_error_as_msg(),"\n";
 302     }
 303     close FH;
 304
 305     # try to save no images :)
 306     open FH, ">testout/t105_none.gif"
 307       or die "Cannot open testout/t105_none.gif: $!";
 308     binmode FH;
 309     if (i_writegif_gen(fileno(FH), {}, "hello")) {
 310       print "not ok 19 # shouldn't be able to save strings\n";
 311     }
 312     else {
 313       print "ok 19 # ",Imager::_error_as_msg(),"\n";
 314     }
 315
 316     # try to read a truncated gif (no image descriptors)
 317     read_failure('testimg/trimgdesc.gif', 20);
 318     # file truncated just after the image descriptor tag
 319     read_failure('testimg/trmiddesc.gif', 21);
 320     # image has no colour map
 321     read_failure('testimg/nocmap.gif', 22);
 322
 323     # image has a local colour map
 324     open FH, "< testimg/loccmap.gif"
 325       or die "Cannot open testimg/loccmap.gif: $!";
 326     binmode FH;
 327     if (i_readgif(fileno(FH))) {
 328       print "ok 23\n";
 329     }
 330     else {
 331       print "not ok 23 # failed to read image with only a local colour map";
 332     }
 333     close FH;
 334
 335     # image has global and local colour maps
 336     open FH, "< testimg/screen2.gif"
 337       or die "Cannot open testimg/screen2.gif: $!";
 338     binmode FH;
 339     my $ims = i_readgif(fileno(FH));
 340     if ($ims) {
 341       print "ok 24\n";
 342     }
 343     else {
 344       print "not ok 24 # ",Imager::_error_as_msg(),"\n";
 345     }
 346     close FH;
 347     open FH, "< testimg/expected.gif"
 348       or die "Cannot open testimg/expected.gif: $!";
 349     binmode FH;
 350     my $ime = i_readgif(fileno(FH));
 351     close FH;
 352     if ($ime) {
 353       print "ok 25\n";
 354     }
 355     else {
 356       print "not ok 25 # ",Imager::_error_as_msg(),"\n";
 357     }
 358     if ($ims && $ime) {
 359       if (i_img_diff($ime, $ims)) {
 360         print "not ok 26 # mismatch ",i_img_diff($ime, $ims),"\n";
 361         # save the bad one
 362         open FH, "> testout/t105_screen2.gif"
 363           or die "Cannot create testout/t105_screen.gif: $!";
 364         binmode FH;
 365         i_writegifmc($ims, fileno(FH), 7)
 366           or print "# could not save t105_screen.gif\n";
 367         close FH;
 368       }
 369       else {
 370         print "ok 26\n";
 371       }
 372     }
 373     else {
 374       print "ok 26 # skipped\n";
 375     }
 376
 377     # test reading a multi-image file into multiple images
 378     open FH, "< testimg/screen2.gif"
 379       or die "Cannot open testimg/screen2.gif: $!";
 380     binmode FH;
 381     @imgs = Imager::i_readgif_multi(fileno(FH))
 382       or print "not ";
 383     print "ok 27\n";
 384     close FH;
 385     @imgs == 2 or print "not ";
 386     print "ok 28\n";
 387     for my $img (@imgs) {
 388       unless (Imager::i_img_type($img) == 1) {
 389         print "not ";
 390         last;
 391       }
 392     }
 393     print "ok 29\n";
 394     Imager::i_colorcount($imgs[0]) == 4 or print "not ";
 395     print "ok 30\n";
 396     Imager::i_colorcount($imgs[1]) == 2 or print "not ";
 397     print "ok 31\n";
 398     Imager::i_tags_find($imgs[0], "gif_left", 0) or print "not ";
 399     print "ok 32\n";
 400     my @tags = map {[ Imager::i_tags_get($imgs[1], $_) ]} 0..Imager::i_tags_count($imgs[1])-1;
 401     my ($left) = grep $_->[0] eq 'gif_left', @tags;
 402     $left && $left->[1] == 3 or print "not ";
 403     print "ok 33\n";
 404
 405     # screen3.gif was saved with
 406     open FH, "< testimg/screen3.gif"
 407       or die "Cannot open testimg/screen3.gif: $!";
 408     binmode FH;
 409     @imgs = Imager::i_readgif_multi(fileno(FH))
 410       or print "not ";
 411     print "ok 34\n";
 412     close FH;
 413     eval {
 414       require 'Data/Dumper.pm';
 415       Data::Dumper->import();
 416     };
 417     unless ($@) {
 418       # build a big map of all tags for all images
 419       @tags =
 420         map {
 421           my $im = $_;
 422           [
 423            map { join ",", map { defined() ? $_ : "undef" } Imager::i_tags_get($im, $_) }
 424            0..Imager::i_tags_count($_)-1
 425           ]
 426         } @imgs;
 427       my $dump = Dumper(\@tags);
 428       $dump =~ s/^/# /mg;
 429       print "# tags from gif\n", $dump;
 430     }
 431
 432     # at this point @imgs should contain only paletted images
 433     ok(35, Imager::i_img_type($imgs[0]) == 1, "imgs[0] not paletted");
 434     ok(36, Imager::i_img_type($imgs[1]) == 1, "imgs[1] not paletted");
 435
 436     # see how we go saving it
 437     open FH, ">testout/t105_pal.gif" or die $!;
 438     binmode FH;
 439     ok(37, i_writegif_gen(fileno(FH), { make_colors=>'addi',
 440                                         translate=>'closest',
 441                                         transp=>'ordered',
 442                                       }, @imgs), "write from paletted");
 443     close FH;
 444
 445     # make sure nothing bad happened
 446     open FH, "< testout/t105_pal.gif" or die $!;
 447     binmode FH;
 448     ok(38, (my @imgs2 = Imager::i_readgif_multi(fileno(FH))) == 2,
 449        "re-reading saved paletted images");
 450     ok(39, i_img_diff($imgs[0], $imgs2[0]) == 0, "imgs[0] mismatch");
 451     ok(40, i_img_diff($imgs[1], $imgs2[1]) == 0, "imgs[1] mismatch");
 452 }
 453
 454 sub ok ($$$) {
 455   my ($num, $ok, $comment) = @_;
 456
 457   if ($ok) {
 458     print "ok $num\n";
 459   }
 460   else {
 461     print "not ok $num # line ",(caller)[2],": $comment \n";
 462   }
 463 }
 464
 465 sub test_readgif_cb {
 466   my ($size) = @_;
 467
 468   open FH, "<testimg/scale.gif" or die "Cannot open testimg/scale.gif";
 469   binmode FH;
 470   my $img = i_readgif_callback(sub { my $tmp; read(FH, $tmp, $size) and $tmp });
 471   close FH;
 472   return $img;
 473 }
 474
 475 # tests for reading bad gif files
 476 sub read_failure {
 477   my ($filename, $testnum) = @_;
 478
 479   open FH, "< $filename"
 480     or die "Cannot open $filename: $!";
 481   binmode FH;
 482   my ($result, $map) = i_readgif(fileno(FH));
 483   if ($result) {
 484     print "not ok $testnum # this is an invalid file, we succeeded\n";
 485   }
 486   else {
 487     print "ok $testnum # ",Imager::_error_as_msg(),"\n";
 488   }
 489   close FH;
 490 }
 491