t/t105gif.t

   1 #!perl -w
   2
   3 =pod
   4
   5 IF THIS TEST CRASHES
   6
   7 Giflib/libungif have a long history of bugs, so if this script crashes
   8 and you aren't running version 4.1.4 of giflib or libungif then
   9 UPGRADE.
  10
  11 =cut
  12
  13 use strict;
  14 $|=1;
  15 use Test::More;
  16 use Imager qw(:all);
  17 use Imager::Test qw(is_color3 test_image test_image_raw);
  18
  19 use Carp 'confess';
  20 $SIG{__DIE__} = sub { confess @_ };
  21
  22 my $buggy_giflib_file = "buggy_giflib.txt";
  23
  24 init_log("testout/t105gif.log",1);
  25
  26 i_has_format("gif")
  27   or plan skip_all => "no gif support";
  28
  29 plan tests => 145;
  30
  31 my $green=i_color_new(0,255,0,255);
  32 my $blue=i_color_new(0,0,255,255);
  33 my $red=i_color_new(255,0,0,255);
  34
  35 my $img=test_image_raw;
  36
  37 my $gifver = Imager::i_giflib_version();
  38 diag("giflib version (from header) $gifver");
  39
  40 open(FH,">testout/t105.gif") || die "Cannot open testout/t105.gif\n";
  41 binmode(FH);
  42 ok(i_writegifmc($img,fileno(FH),6), "write low") or
  43   die "Cannot write testout/t105.gif\n";
  44 close(FH);
  45
  46 open(FH,"testout/t105.gif") || die "Cannot open testout/t105.gif\n";
  47 binmode(FH);
  48 ok($img=i_readgif(fileno(FH)), "read low")
  49   or die "Cannot read testout/t105.gif\n";
  50 close(FH);
  51
  52 open(FH,"testout/t105.gif") || die "Cannot open testout/t105.gif\n";
  53 binmode(FH);
  54 ($img, my $palette)=i_readgif(fileno(FH));
  55 ok($img, "read palette") or die "Cannot read testout/t105.gif\n";
  56 close(FH);
  57
  58 $palette=''; # just to skip a warning.
  59
  60 # check that reading interlaced/non-interlaced versions of
  61 # the same GIF produce the same image
  62 # I could replace this with code that used Imager's built-in
  63 # image comparison code, but I know this code revealed the error
  64 open(FH, "<testimg/scalei.gif") || die "Cannot open testimg/scalei.gif";
  65 binmode FH;
  66 my ($imgi) = i_readgif(fileno(FH));
  67 ok($imgi, "read interlaced") or die "Cannot read testimg/scalei.gif";
  68 close FH;
  69 open FH, "<testimg/scale.gif" or die "Cannot open testimg/scale.gif";
  70 binmode FH;
  71 my ($imgni) = i_readgif(fileno(FH));
  72 ok($imgni, "read normal") or die "Cannot read testimg/scale.gif";
  73 close FH;
  74
  75 open FH, ">testout/t105i.ppm" or die "Cannot create testout/t105i.ppm";
  76 binmode FH;
  77 my $IO = Imager::io_new_fd( fileno(FH) );
  78 i_writeppm_wiol($imgi, $IO)
  79   or die "Cannot write testout/t105i.ppm";
  80 close FH;
  81
  82 open FH, ">testout/t105ni.ppm" or die "Cannot create testout/t105ni.ppm";
  83 binmode FH;
  84 $IO = Imager::io_new_fd( fileno(FH) );
  85 i_writeppm_wiol($imgni, $IO)
  86   or die "Cannot write testout/t105ni.ppm";
  87 close FH;
  88
  89 # compare them
  90 open FH, "<testout/t105i.ppm" or die "Cannot open testout/t105i.ppm";
  91 my $datai = do { local $/; <FH> };
  92 close FH;
  93
  94 open FH, "<testout/t105ni.ppm" or die "Cannot open testout/t105ni.ppm";
  95 my $datani = do { local $/; <FH> };
  96 close FH;
  97 is($datai, $datani, "images match");
  98
  99 SKIP:
 100 {
 101   skip("giflib3 doesn't support callbacks", 4) unless $gifver >= 4.0;
 102   # reading with a callback
 103   # various sizes to make sure the buffering works
 104   # requested size
 105   open FH, "<testimg/scale.gif" or die "Cannot open testimg/scale.gif";
 106   binmode FH;
 107   # no callback version in giflib3, so don't overwrite a good image
 108   my $img2 = i_readgif_callback(sub { my $tmp; read(FH, $tmp, $_[0]) and $tmp });
 109   close FH;
 110   ok($img, "reading with a callback");
 111
 112   ok(test_readgif_cb(1), "read callback 1 char buffer");
 113   ok(test_readgif_cb(512), "read callback 512 char buffer");
 114   ok(test_readgif_cb(1024), "read callback 1024 char buffer");
 115 }
 116 open FH, ">testout/t105_mc.gif" or die "Cannot open testout/t105_mc.gif";
 117 binmode FH;
 118 ok(i_writegifmc($img, fileno(FH), 7), "writegifmc");
 119 close(FH);
 120
 121 # new writegif_gen
 122 # test webmap, custom errdiff map
 123 # (looks fairly awful)
 124 open FH, ">testout/t105_gen.gif" or die $!;
 125 binmode FH;
 126 ok(i_writegif_gen(fileno(FH), { make_colors=>'webmap',
 127                                 translate=>'errdiff',
 128                                 errdiff=>'custom',
 129                                 errdiff_width=>2,
 130                                 errdiff_height=>2,
 131                                 errdiff_map=>[0, 1, 1, 0]}, $img),
 132        "webmap, custom errdif map");
 133 close FH;
 134
 135 print "# the following tests are fairly slow\n";
 136
 137 # test animation, mc_addi, error diffusion, ordered transparency
 138 my @imgs;
 139 my $sortagreen = i_color_new(0, 255, 0, 63);
 140 for my $i (0..4) {
 141   my $im = Imager::ImgRaw::new(200, 200, 4);
 142   _add_tags($im, gif_delay=>50, gif_disposal=>2);
 143   for my $j (0..$i-1) {
 144     my $fill = i_color_new(0, 128, 0, 255 * ($i-$j)/$i);
 145     i_box_filled($im, 0, $j*40, 199, $j*40+40, $fill);
 146   }
 147   i_box_filled($im, 0, $i*40, 199, 199, $blue);
 148   push(@imgs, $im);
 149 }
 150 my @gif_delays = (50) x 5;
 151 my @gif_disposal = (2) x 5;
 152 open FH, ">testout/t105_anim.gif" or die $!;
 153 binmode FH;
 154 ok(i_writegif_gen(fileno(FH), { make_colors=>'addi',
 155                                 translate=>'closest',
 156                                 gif_delays=>\@gif_delays,
 157                                 gif_disposal=>\@gif_disposal,
 158                                 gif_positions=> [ map [ $_*10, $_*10 ], 0..4 ],
 159                                 gif_user_input=>[ 1, 0, 1, 0, 1 ],
 160                                 transp=>'ordered',
 161                                 'tr_orddith'=>'dot8'}, @imgs),
 162    "write anim gif");
 163 close FH;
 164
 165 my $can_write_callback = 0;
 166 unlink $buggy_giflib_file;
 167 SKIP:
 168 {
 169   skip("giflib3 doesn't support callbacks", 1) unless $gifver >= 4.0;
 170   ++$can_write_callback;
 171   my $good = ext_test(14, <<'ENDOFCODE');
 172 use Imager qw(:all);
 173 use Imager::Test qw(test_image_raw);
 174 my $timg = test_image_raw();
 175 my @gif_delays = (50) x 5;
 176 my @gif_disposal = (2) x 5;
 177 my @imgs = ($timg) x 5;
 178 open FH, "> testout/t105_anim_cb.gif" or die $!;
 179 binmode FH;
 180 i_writegif_callback(sub {
 181                       print FH $_[0]
 182                     },
 183                     -1, # max buffering
 184                     { make_colors=>'webmap',
 185                       translate=>'closest',
 186                       gif_delays=>\@gif_delays,
 187                       gif_disposal=>\@gif_disposal,
 188                       #transp=>'ordered',
 189                       tr_orddith=>'dot8'}, @imgs)
 190   or die "Cannot write anim gif";
 191 close FH;
 192 print "ok 14\n";
 193 exit;
 194 ENDOFCODE
 195   unless ($good) {
 196     $can_write_callback = 0;
 197     fail("see $buggy_giflib_file");
 198     print STDERR "\nprobable buggy giflib - skipping tests that depend on a good giflib\n";
 199     print STDERR "see $buggy_giflib_file for more information\n";
 200     open FLAG, "> $buggy_giflib_file" or die;
 201     print FLAG <<EOS;
 202 This file is created by t105gif.t when test 14 fails.
 203
 204 This failure usually indicates you\'re using the original versions
 205 of giflib 4.1.0 - 4.1.3, which have a few bugs that Imager tickles.
 206
 207 You can apply the patch from:
 208
 209 http://www.develop-help.com/imager/giflib.patch
 210
 211 or you can just install Imager as is, if you only need to write GIFs to
 212 files or file descriptors (such as sockets).
 213
 214 One hunk of this patch is rejected (correctly) with giflib 4.1.3,
 215 since one bug that the patch fixes is fixed in 4.1.3.
 216
 217 If you don't feel comfortable with that apply the patch file that
 218 belongs to the following patch entry on sourceforge:
 219
 220 https://sourceforge.net/tracker/index.php?func=detail&aid=981255&group_id=102202&atid=631306
 221
 222 In previous versions of Imager only this test was careful about catching
 223 the error, we now skip any tests that crashed or failed when the buggy
 224 giflib was present.
 225 EOS
 226   }
 227 }
 228 @imgs = ();
 229 my $c = i_color_new(0,0,0,0);
 230 for my $g (0..3) {
 231   my $im = Imager::ImgRaw::new(200, 200, 3);
 232   _add_tags($im, gif_local_map=>1, gif_delay=>150, gif_loop=>10);
 233   for my $x (0 .. 39) {
 234     for my $y (0 .. 39) {
 235       $c->set($x * 6, $y * 6, 32*$g+$x+$y, 255);
 236       i_box_filled($im, $x*5, $y*5, $x*5+4, $y*5+4, $c);
 237     }
 238   }
 239   push(@imgs, $im);
 240 }
 241 # test giflib with multiple palettes
 242 # (it was meant to test the NS loop extension too, but that's broken)
 243 # this looks better with make_colors=>'addi', translate=>'errdiff'
 244 # this test aims to overload the palette for each image, so the
 245 # output looks moderately horrible
 246 open FH, ">testout/t105_mult_pall.gif" or die "Cannot create file: $!";
 247 binmode FH;
 248 ok(i_writegif_gen(fileno(FH), { #make_colors=>'webmap',
 249                                translate=>'giflib',
 250                               }, @imgs), "write multiple palettes")
 251   or print "# ", join(":", map $_->[1], Imager::i_errors()),"\n";
 252 close FH;
 253
 254 # regression test: giflib doesn't like 1 colour images
 255 my $img1 = Imager::ImgRaw::new(100, 100, 3);
 256 i_box_filled($img1, 0, 0, 100, 100, $red);
 257 open FH, ">testout/t105_onecol.gif" or die $!;
 258 binmode FH;
 259 ok(i_writegif_gen(fileno(FH), { translate=>'giflib'}, $img1),
 260    "single colour write regression");
 261 close FH;
 262
 263 # transparency test
 264 # previously it was harder do write transparent images
 265 # tests the improvements
 266 my $timg = Imager::ImgRaw::new(20, 20, 4);
 267 my $trans = i_color_new(255, 0, 0, 127);
 268 i_box_filled($timg, 0, 0, 20, 20, $green);
 269 i_box_filled($timg, 2, 2, 18, 18, $trans);
 270 open FH, ">testout/t105_trans.gif" or die $!;
 271 binmode FH;
 272 ok(i_writegif_gen(fileno(FH), { make_colors=>'addi',
 273                                 translate=>'closest',
 274                                 transp=>'ordered',
 275                               }, $timg), "write transparent");
 276 close FH;
 277
 278 # some error handling tests
 279 # open a file handle for read and try to save to it
 280 # is this idea portable?
 281 # whether or not it is, giflib segfaults on this <sigh>
 282 #open FH, "<testout/t105_trans.gif" or die $!;
 283 #binmode FH; # habit, I suppose
 284 #if (i_writegif_gen(fileno(FH), {}, $timg)) {
 285 #  # this is meant to _fail_
 286 #  print "not ok 18 # writing to read-only should fail";
 287 #}
 288 #else {
 289 #  print "ok 18 # ",Imager::_error_as_msg(),"\n";
 290 #}
 291 #close FH;
 292
 293 # try to read a file of the wrong format - the script will do
 294 open FH, "<t/t105gif.t"
 295   or die "Cannot open this script!: $!";
 296 binmode FH;
 297 ok(!i_readgif(fileno(FH)),
 298    "read test script as gif should fail ". Imager::_error_as_msg());
 299 close FH;
 300
 301 # try to save no images :)
 302 open FH, ">testout/t105_none.gif"
 303   or die "Cannot open testout/t105_none.gif: $!";
 304 binmode FH;
 305 if (ok(!i_writegif_gen(fileno(FH), {}, "hello"), "shouldn't be able to write a string as a gif")) {
 306   print "# ",Imager::_error_as_msg(),"\n";
 307 }
 308
 309 # try to read a truncated gif (no image descriptors)
 310 read_failure('testimg/trimgdesc.gif');
 311 # file truncated just after the image descriptor tag
 312 read_failure('testimg/trmiddesc.gif');
 313 # image has no colour map
 314 read_failure('testimg/nocmap.gif');
 315
 316 SKIP:
 317 {
 318   skip("see $buggy_giflib_file", 18) if -e $buggy_giflib_file;
 319   # image has a local colour map
 320   open FH, "< testimg/loccmap.gif"
 321     or die "Cannot open testimg/loccmap.gif: $!";
 322   binmode FH;
 323   ok(i_readgif(fileno(FH)), "read an image with only a local colour map");
 324   close FH;
 325
 326   # image has global and local colour maps
 327   open FH, "< testimg/screen2.gif"
 328     or die "Cannot open testimg/screen2.gif: $!";
 329   binmode FH;
 330   my $ims = i_readgif(fileno(FH));
 331   unless (ok($ims, "read an image with global and local colour map")) {
 332     print "# ",Imager::_error_as_msg(),"\n";
 333   }
 334   close FH;
 335
 336   open FH, "< testimg/expected.gif"
 337     or die "Cannot open testimg/expected.gif: $!";
 338   binmode FH;
 339   my $ime = i_readgif(fileno(FH));
 340   close FH;
 341   ok($ime, "reading testimg/expected.gif");
 342  SKIP:
 343   {
 344     skip("could not read one or both of expected.gif or loccamp.gif", 1)
 345           unless $ims and $ime;
 346     unless (is(i_img_diff($ime, $ims), 0,
 347                "compare loccmap and expected")) {
 348       # save the bad one
 349       open FH, "> testout/t105_screen2.gif"
 350         or die "Cannot create testout/t105_screen.gif: $!";
 351       binmode FH;
 352       i_writegifmc($ims, fileno(FH), 7)
 353         or print "# could not save t105_screen.gif\n";
 354       close FH;
 355     }
 356   }
 357
 358   # test reading a multi-image file into multiple images
 359   open FH, "< testimg/screen2.gif"
 360     or die "Cannot open testimg/screen2.gif: $!";
 361   binmode FH;
 362   @imgs = Imager::i_readgif_multi(fileno(FH));
 363   ok(@imgs, "read multi-image file into multiple images");
 364   close FH;
 365   is(@imgs, 2, "should be 2 images");
 366   my $paletted = 1;
 367   for my $img (@imgs) {
 368     unless (Imager::i_img_type($img) == 1) {
 369       $paletted = 0;
 370       last;
 371     }
 372   }
 373   ok($paletted, "both images should be paletted");
 374   is(Imager::i_colorcount($imgs[0]), 4, "4 colours in first image");
 375   is(Imager::i_colorcount($imgs[1]), 2, "2 colours in second image");
 376   ok(Imager::i_tags_find($imgs[0], "gif_left", 0),
 377      "gif_left tag should be there");
 378   my @tags = map {[ Imager::i_tags_get($imgs[1], $_) ]} 0..Imager::i_tags_count($imgs[1])-1;
 379   my ($left) = grep $_->[0] eq 'gif_left', @tags;
 380   ok($left && $left->[1] == 3, "check gif_left value");
 381
 382   # screen3.gif was saved with
 383   open FH, "< testimg/screen3.gif"
 384     or die "Cannot open testimg/screen3.gif: $!";
 385   binmode FH;
 386   @imgs = Imager::i_readgif_multi(fileno(FH));
 387   ok(@imgs, "read screen3.gif");
 388   close FH;
 389   eval {
 390     require 'Data/Dumper.pm';
 391     Data::Dumper->import();
 392   };
 393   unless ($@) {
 394     # build a big map of all tags for all images
 395     @tags =
 396       map {
 397         my $im = $_;
 398         [
 399          map { join ",", map { defined() ? $_ : "undef" } Imager::i_tags_get($im, $_) }
 400          0..Imager::i_tags_count($_)-1
 401         ]
 402       } @imgs;
 403     my $dump = Dumper(\@tags);
 404     $dump =~ s/^/# /mg;
 405     print "# tags from gif\n", $dump;
 406   }
 407
 408   # at this point @imgs should contain only paletted images
 409   ok(Imager::i_img_type($imgs[0]) == 1, "imgs[0] paletted");
 410   ok(Imager::i_img_type($imgs[1]) == 1, "imgs[1] paletted");
 411
 412   # see how we go saving it
 413   open FH, ">testout/t105_pal.gif" or die $!;
 414   binmode FH;
 415   ok(i_writegif_gen(fileno(FH), { make_colors=>'addi',
 416                                   translate=>'closest',
 417                                   transp=>'ordered',
 418                                 }, @imgs), "write from paletted");
 419   close FH;
 420
 421   # make sure nothing bad happened
 422   open FH, "< testout/t105_pal.gif" or die $!;
 423   binmode FH;
 424   ok((my @imgs2 = Imager::i_readgif_multi(fileno(FH))) == 2,
 425      "re-reading saved paletted images");
 426   ok(i_img_diff($imgs[0], $imgs2[0]) == 0, "imgs[0] mismatch");
 427   ok(i_img_diff($imgs[1], $imgs2[1]) == 0, "imgs[1] mismatch");
 428 }
 429
 430 # test that the OO interface warns when we supply old options
 431 {
 432   my @warns;
 433   local $SIG{__WARN__} = sub { push(@warns, "@_") };
 434
 435   my $ooim = Imager->new;
 436   ok($ooim->read(file=>"testout/t105.gif"), "read into object");
 437   ok($ooim->write(file=>"testout/t105_warn.gif", interlace=>1),
 438      "save from object")
 439     or print "# ", $ooim->errstr, "\n";
 440   ok(grep(/Obsolete .* interlace .* gif_interlace/, @warns),
 441      "check for warning");
 442   init(warn_obsolete=>0);
 443   @warns = ();
 444   ok($ooim->write(file=>"testout/t105_warn.gif", interlace=>1),
 445      "save from object");
 446   ok(!grep(/Obsolete .* interlace .* gif_interlace/, @warns),
 447      "check for warning");
 448 }
 449
 450 # test that we get greyscale from 1 channel images
 451 # we check for each makemap, and for each translate
 452 print "# test writes of grayscale images - ticket #365\n";
 453 my $ooim = Imager->new(xsize=>50, ysize=>50, channels=>1);
 454 for (my $y = 0; $y < 50; $y += 10) {
 455   $ooim->box(box=>[ 0, $y, 49, $y+9], color=>NC($y*5,0,0), filled=>1);
 456 }
 457 my $ooim3 = $ooim->convert(preset=>'rgb');
 458 #$ooim3->write(file=>'testout/t105gray.ppm');
 459 my %maxerror = ( mediancut => 51000,
 460                  addi => 0,
 461                  closest => 0,
 462                  perturb => 0,
 463                  errdiff => 0 );
 464 for my $makemap (qw(mediancut addi)) {
 465   print "# make_colors => $makemap\n";
 466   ok( $ooim->write(file=>"testout/t105gray-$makemap.gif",
 467                    make_colors=>$makemap,
 468                    gifquant=>'gen'),
 469       "writing gif with makemap $makemap");
 470   my $im2 = Imager->new;
 471   if (ok($im2->read(file=>"testout/t105gray-$makemap.gif"),
 472          "reading written grayscale gif")) {
 473     my $diff = i_img_diff($ooim3->{IMG}, $im2->{IMG});
 474     ok($diff <= $maxerror{$makemap}, "comparing images $diff");
 475     #$im2->write(file=>"testout/t105gray-$makemap.ppm");
 476   }
 477   else {
 478   SKIP: { skip("could not get test image", 1); }
 479   }
 480 }
 481 for my $translate (qw(closest perturb errdiff)) {
 482   print "# translate => $translate\n";
 483   my @colors = map NC($_*50, $_*50, $_*50), 0..4;
 484   ok($ooim->write(file=>"testout/t105gray-$translate.gif",
 485                   translate=>$translate,
 486                   make_colors=>'none',
 487                   colors=>\@colors,
 488                   gifquant=>'gen'),
 489      "writing gif with translate $translate");
 490   my $im2 = Imager->new;
 491   if (ok($im2->read(file=>"testout/t105gray-$translate.gif"),
 492          "reading written grayscale gif")) {
 493     my $diff = i_img_diff($ooim3->{IMG}, $im2->{IMG});
 494     ok($diff <= $maxerror{$translate}, "comparing images $diff");
 495     #$im2->write(file=>"testout/t105gray-$translate.ppm");
 496   }
 497   else {
 498   SKIP: { skip("could not load test image", 1) }
 499   }
 500     }
 501
 502 # try to write an image with no colors - should error
 503 ok(!$ooim->write(file=>"testout/t105nocolors.gif",
 504                  make_colors=>'none',
 505                  colors=>[], gifquant=>'gen'),
 506    "write with no colors");
 507
 508 # try to write multiple with no colors, with separate maps
 509 # I don't see a way to test this, since we don't have a mechanism
 510 # to give the second image different quant options, we can't trigger
 511 # a failure just for the second image
 512
 513 # check that the i_format tag is set for both multiple and single
 514 # image reads
 515 {
 516   my @anim = Imager->read_multi(file=>"testout/t105_anim.gif");
 517   ok(@anim == 5, "check we got all the images");
 518   for my $frame (@anim) {
 519     my ($type) = $frame->tags(name=>'i_format');
 520     is($type, 'gif', "check i_format for animation frame");
 521   }
 522
 523   my $im = Imager->new;
 524   ok($im->read(file=>"testout/t105.gif"), "read some gif");
 525   my ($type) = $im->tags(name=>'i_format');
 526   is($type, 'gif', 'check i_format for single image read');
 527 }
 528
 529 { # check file limits are checked
 530   my $limit_file = "testout/t105.gif";
 531   ok(Imager->set_file_limits(reset=>1, width=>149), "set width limit 149");
 532   my $im = Imager->new;
 533   ok(!$im->read(file=>$limit_file),
 534      "should fail read due to size limits");
 535   print "# ",$im->errstr,"\n";
 536   like($im->errstr, qr/image width/, "check message");
 537
 538   ok(Imager->set_file_limits(reset=>1, height=>149), "set height limit 149");
 539   ok(!$im->read(file=>$limit_file),
 540      "should fail read due to size limits");
 541   print "# ",$im->errstr,"\n";
 542   like($im->errstr, qr/image height/, "check message");
 543
 544   ok(Imager->set_file_limits(reset=>1, width=>150), "set width limit 150");
 545   ok($im->read(file=>$limit_file),
 546      "should succeed - just inside width limit");
 547   ok(Imager->set_file_limits(reset=>1, height=>150), "set height limit 150");
 548   ok($im->read(file=>$limit_file),
 549      "should succeed - just inside height limit");
 550
 551   # 150 x 150 x 3 channel image uses 67500 bytes
 552   ok(Imager->set_file_limits(reset=>1, bytes=>67499),
 553      "set bytes limit 67499");
 554   ok(!$im->read(file=>$limit_file),
 555      "should fail - too many bytes");
 556   print "# ",$im->errstr,"\n";
 557   like($im->errstr, qr/storage size/, "check error message");
 558   ok(Imager->set_file_limits(reset=>1, bytes=>67500),
 559      "set bytes limit 67500");
 560   ok($im->read(file=>$limit_file),
 561      "should succeed - just inside bytes limit");
 562   Imager->set_file_limits(reset=>1);
 563 }
 564
 565 {
 566   print "# test OO interface reading of consolidated images\n";
 567   my $im = Imager->new;
 568   ok($im->read(file=>'testimg/screen2.gif', gif_consolidate=>1),
 569      "read image to consolidate");
 570   my $expected = Imager->new;
 571   ok($expected->read(file=>'testimg/expected.gif'),
 572      "read expected via OO");
 573   is(i_img_diff($im->{IMG}, $expected->{IMG}), 0,
 574      "compare them");
 575
 576   # check the default read doesn't match
 577   ok($im->read(file=>'testimg/screen2.gif'),
 578      "read same image without consolidate");
 579   isnt(i_img_diff($im->{IMG}, $expected->{IMG}), 0,
 580        "compare them - shouldn't include the overlayed second image");
 581 }
 582 {
 583   print "# test the reading of single pages\n";
 584   # build a test file
 585   my $test_file = 'testout/t105_multi_sing.gif';
 586   my $im1 = Imager->new(xsize=>100, ysize=>100);
 587   $im1->box(filled=>1, color=>$blue);
 588   $im1->addtag(name=>'gif_left', value=>10);
 589   $im1->addtag(name=>'gif_top', value=>15);
 590   $im1->addtag(name=>'gif_comment', value=>'First page');
 591   my $im2 = Imager->new(xsize=>50, ysize=>50);
 592   $im2->box(filled=>1, color=>$red);
 593   $im2->addtag(name=>'gif_left', value=>30);
 594   $im2->addtag(name=>'gif_top', value=>25);
 595   $im2->addtag(name=>'gif_comment', value=>'Second page');
 596   my $im3 = Imager->new(xsize=>25, ysize=>25);
 597   $im3->box(filled=>1, color=>$green);
 598   $im3->addtag(name=>'gif_left', value=>35);
 599   $im3->addtag(name=>'gif_top', value=>45);
 600   # don't set comment for $im3
 601   ok(Imager->write_multi({ file=> $test_file}, $im1, $im2, $im3),
 602      "write test file for single page reads");
 603
 604   my $res = Imager->new;
 605   # check we get the first image
 606   ok($res->read(file=>$test_file), "read default (first) page");
 607   is(i_img_diff($im1->{IMG}, $res->{IMG}), 0, "compare against first");
 608   # check tags
 609   is($res->tags(name=>'gif_left'), 10, "gif_left");
 610   is($res->tags(name=>'gif_top'), 15, "gif_top");
 611   is($res->tags(name=>'gif_comment'), 'First page', "gif_comment");
 612
 613   # get the second image
 614   ok($res->read(file=>$test_file, page=>1), "read second page")
 615     or print "# ",$res->errstr, "\n";
 616   is(i_img_diff($im2->{IMG}, $res->{IMG}), 0, "compare against second");
 617   # check tags
 618   is($res->tags(name=>'gif_left'), 30, "gif_left");
 619   is($res->tags(name=>'gif_top'), 25, "gif_top");
 620   is($res->tags(name=>'gif_comment'), 'Second page', "gif_comment");
 621
 622   # get the third image
 623   ok($res->read(file=>$test_file, page=>2), "read third page")
 624     or print "# ",$res->errstr, "\n";
 625   is(i_img_diff($im3->{IMG}, $res->{IMG}), 0, "compare against third");
 626   is($res->tags(name=>'gif_left'), 35, "gif_left");
 627   is($res->tags(name=>'gif_top'), 45, "gif_top");
 628   is($res->tags(name=>'gif_comment'), undef, 'gif_comment undef');
 629
 630   # try to read a fourth page
 631     ok(!$res->read(file=>$test_file, page=>3), "fail reading fourth page");
 632   cmp_ok($res->errstr, "=~", 'page 3 not found',
 633          "check error message");
 634 }
 635 SKIP:
 636 {
 637   skip("gif_loop not supported on giflib before 4.1", 6)
 638     unless $gifver >= 4.1;
 639   # testing writing the loop extension
 640   my $im1 = Imager->new(xsize => 100, ysize => 100);
 641   $im1->box(filled => 1, color => '#FF0000');
 642   my $im2 = Imager->new(xsize => 100, ysize => 100);
 643   $im2->box(filled => 1, color => '#00FF00');
 644   ok(Imager->write_multi({
 645                           gif_loop => 5,
 646                           gif_delay => 50,
 647                           file => 'testout/t105loop.gif'
 648                          }, $im1, $im2),
 649      "write with loop extension");
 650
 651   my @im = Imager->read_multi(file => 'testout/t105loop.gif');
 652   is(@im, 2, "read loop images back");
 653   is($im[0]->tags(name => 'gif_loop'), 5, "first loop read back");
 654   is($im[1]->tags(name => 'gif_loop'), 5, "second loop read back");
 655   is($im[0]->tags(name => 'gif_delay'), 50, "first delay read back");
 656   is($im[1]->tags(name => 'gif_delay'), 50, "second delay read back");
 657 }
 658 SKIP:
 659 { # check graphic control extension and ns loop tags are read correctly
 660   print "# check GCE and netscape loop extension tag values\n";
 661   my @im = Imager->read_multi(file => 'testimg/screen3.gif');
 662   is(@im, 2, "read 2 images from screen3.gif")
 663     or skip("Could not load testimg/screen3.gif:".Imager->errstr, 11);
 664   is($im[0]->tags(name => 'gif_delay'),          50, "0 - gif_delay");
 665   is($im[0]->tags(name => 'gif_disposal'),        2, "0 - gif_disposal");
 666   is($im[0]->tags(name => 'gif_trans_index'), undef, "0 - gif_trans_index");
 667   is($im[0]->tags(name => 'gif_user_input'),      0, "0 - gif_user_input");
 668   is($im[0]->tags(name => 'gif_loop'),            0, "0 - gif_loop");
 669   is($im[1]->tags(name => 'gif_delay'),          50, "1 - gif_delay");
 670   is($im[1]->tags(name => 'gif_disposal'),        2, "1 - gif_disposal");
 671   is($im[1]->tags(name => 'gif_trans_index'),     7, "1 - gif_trans_index");
 672   is($im[1]->tags(name => 'gif_trans_color'), 'color(255,255,255,0)',
 673      "1 - gif_trans_index");
 674   is($im[1]->tags(name => 'gif_user_input'),      0, "1 - gif_user_input");
 675   is($im[1]->tags(name => 'gif_loop'),            0, "1 - gif_loop");
 676 }
 677
 678 {
 679   # manually modified from a small gif, this had the palette
 680   # size changed to half the size, leaving an index out of range
 681   my $im = Imager->new;
 682   ok($im->read(file => 'testimg/badindex.gif', type => 'gif'),
 683      "read bad index gif")
 684     or print "# ", $im->errstr, "\n";
 685   my @indexes = $im->getscanline('y' => 0, type => 'index');
 686   is_deeply(\@indexes, [ 0..4 ], "check for correct indexes");
 687   is($im->colorcount, 5, "check the palette was adjusted");
 688   is_color3($im->getpixel('y' => 0, x => 4), 0, 0, 0,
 689             "check it was black added");
 690   is($im->tags(name => 'gif_colormap_size'), 4, 'color map size tag');
 691 }
 692
 693 {
 694   ok(grep($_ eq 'gif', Imager->read_types), "check gif in read types");
 695   ok(grep($_ eq 'gif', Imager->write_types), "check gif in write types");
 696 }
 697
 698 {
 699   # check screen tags handled correctly note the screen size
 700   # supplied is larger than the box covered by the images
 701   my $im1 = Imager->new(xsize => 10, ysize => 8);
 702   $im1->settag(name => 'gif_top', value => 4);
 703   $im1->settag(name => 'gif_screen_width', value => 18);
 704   $im1->settag(name => 'gif_screen_height', value => 16);
 705   my $im2 = Imager->new(xsize => 7, ysize => 10);
 706   $im2->settag(name => 'gif_left', value => 3);
 707   my @im = ( $im1, $im2 );
 708
 709   my $data;
 710   ok(Imager->write_multi({ data => \$data, type => 'gif' }, @im),
 711      "write with screen settings")
 712     or print "# ", Imager->errstr, "\n";
 713   my @result = Imager->read_multi(data => $data);
 714   is(@result, 2, "got 2 images back");
 715   is($result[0]->tags(name => 'gif_screen_width'), 18,
 716      "check result screen width");
 717   is($result[0]->tags(name => 'gif_screen_height'), 16,
 718      "check result screen height");
 719   is($result[0]->tags(name => 'gif_left'), 0,
 720      "check first gif_left");
 721   is($result[0]->tags(name => 'gif_top'), 4,
 722      "check first gif_top");
 723   is($result[1]->tags(name => 'gif_left'), 3,
 724      "check second gif_left");
 725   is($result[1]->tags(name => 'gif_top'), 0,
 726      "check second gif_top");
 727 }
 728
 729 { # test colors array returns colors
 730   my $data;
 731   my $im = test_image();
 732   my @colors;
 733   ok($im->write(data => \$data,
 734                 colors => \@colors,
 735                 make_colors => 'webmap',
 736                 translate => 'closest',
 737                 gifquant => 'gen',
 738                 type => 'gif'),
 739      "write using webmap to check color table");
 740   is(@colors, 216, "should be 216 colors in the webmap");
 741   is_color3($colors[0], 0, 0, 0, "first should be 000000");
 742   is_color3($colors[1], 0, 0, 0x33, "second should be 000033");
 743   is_color3($colors[8], 0, 0x33, 0x66, "9th should be 003366");
 744 }
 745
 746 sub test_readgif_cb {
 747   my ($size) = @_;
 748
 749   open FH, "<testimg/scale.gif" or die "Cannot open testimg/scale.gif";
 750   binmode FH;
 751   my $img = i_readgif_callback(sub { my $tmp; read(FH, $tmp, $size) and $tmp });
 752   close FH;
 753   return $img;
 754 }
 755
 756 # tests for reading bad gif files
 757 sub read_failure {
 758   my ($filename) = @_;
 759
 760   open FH, "< $filename"
 761     or die "Cannot open $filename: $!";
 762   binmode FH;
 763   my ($result, $map) = i_readgif(fileno(FH));
 764   ok(!$result, "attempt to read invalid image $filename ".Imager::_error_as_msg());
 765   close FH;
 766 }
 767
 768 sub _clear_tags {
 769   my (@imgs) = @_;
 770
 771   for my $img (@imgs) {
 772     $img->deltag(code=>0);
 773   }
 774 }
 775
 776 sub _add_tags {
 777   my ($img, %tags) = @_;
 778
 779   for my $key (keys %tags) {
 780     Imager::i_tags_add($img, $key, 0, $tags{$key}, 0);
 781   }
 782 }
 783
 784 sub ext_test {
 785   my ($testnum, $code, $count, $name) = @_;
 786
 787   $count ||= 1;
 788   $name ||= "gif$testnum";
 789
 790   # build our code
 791   my $script = "testout/$name.pl";
 792   if (open SCRIPT, "> $script") {
 793     print SCRIPT <<'PROLOG';
 794 #!perl -w
 795 if (lc $^O eq 'mswin32') {
 796   # avoid the dialog box that window's pops up on a GPF
 797   # if you want to debug this stuff, I suggest you comment out the
 798   # following
 799   eval {
 800     require Win32API::File;
 801     Win32API::File::SetErrorMode( Win32API::File::SEM_NOGPFAULTERRORBOX());
 802   };
 803 }
 804 PROLOG
 805
 806     print SCRIPT $code;
 807     close SCRIPT;
 808
 809     my $perl = $^X;
 810     $perl = qq/"$perl"/ if $perl =~ / /;
 811
 812     print "# script: $script\n";
 813     my $cmd = "$perl -Mblib $script";
 814     print "# command: $cmd\n";
 815
 816     my $ok = 1;
 817     my @out = `$cmd`; # should work on DOS and Win32
 818     my $found = 0;
 819     for (@out) {
 820       if (/^not ok\s+(?:\d+\s*)?#(.*)/ || /^not ok/) {
 821         my $msg = $1 || '';
 822         ok(0, $msg);
 823         $ok = 0;
 824         ++$found;
 825       }
 826       elsif (/^ok\s+(?:\d+\s*)?#(.*)/ || /^ok/) {
 827         my $msg = $1 || '';
 828         ok(1, $msg);
 829         ++$found;
 830       }
 831     }
 832     unless ($count == $found) {
 833       print "# didn't see enough ok/not ok\n";
 834       $ok = 0;
 835     }
 836     return $ok;
 837   }
 838   else {
 839     return skip("could not create test script $script: $!");
 840     return 0;
 841   }
 842 }