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