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   close FH;
 409
 410   # make sure nothing bad happened
 411   open FH, "< testout/t105_pal.gif" or die $!;
 412   binmode FH;
 413   $io = Imager::io_new_fd(fileno(FH));
 414   ok((my @imgs2 = Imager::File::GIF::i_readgif_multi_wiol($io)) == 2,
 415      "re-reading saved paletted images");
 416   ok(i_img_diff($imgs[0], $imgs2[0]) == 0, "imgs[0] mismatch");
 417   ok(i_img_diff($imgs[1], $imgs2[1]) == 0, "imgs[1] mismatch");
 418 }
 419
 420 # test that the OO interface warns when we supply old options
 421 {
 422   my @warns;
 423   local $SIG{__WARN__} = sub { push(@warns, "@_") };
 424
 425   my $ooim = Imager->new;
 426   ok($ooim->read(file=>"testout/t105.gif"), "read into object");
 427   ok($ooim->write(file=>"testout/t105_warn.gif", interlace=>1),
 428      "save from object")
 429     or print "# ", $ooim->errstr, "\n";
 430   ok(grep(/Obsolete .* interlace .* gif_interlace/, @warns),
 431      "check for warning");
 432   init(warn_obsolete=>0);
 433   @warns = ();
 434   ok($ooim->write(file=>"testout/t105_warn.gif", interlace=>1),
 435      "save from object");
 436   ok(!grep(/Obsolete .* interlace .* gif_interlace/, @warns),
 437      "check for warning");
 438 }
 439
 440 # test that we get greyscale from 1 channel images
 441 # we check for each makemap, and for each translate
 442 print "# test writes of grayscale images - ticket #365\n";
 443 my $ooim = Imager->new(xsize=>50, ysize=>50, channels=>1);
 444 for (my $y = 0; $y < 50; $y += 10) {
 445   $ooim->box(box=>[ 0, $y, 49, $y+9], color=>NC($y*5,0,0), filled=>1);
 446 }
 447 my $ooim3 = $ooim->convert(preset=>'rgb');
 448 #$ooim3->write(file=>'testout/t105gray.ppm');
 449 my %maxerror = ( mediancut => 51000,
 450                  addi => 0,
 451                  closest => 0,
 452                  perturb => 0,
 453                  errdiff => 0 );
 454 for my $makemap (qw(mediancut addi)) {
 455   print "# make_colors => $makemap\n";
 456   ok( $ooim->write(file=>"testout/t105gray-$makemap.gif",
 457                    make_colors=>$makemap,
 458                    gifquant=>'gen'),
 459       "writing gif with makemap $makemap");
 460   my $im2 = Imager->new;
 461   if (ok($im2->read(file=>"testout/t105gray-$makemap.gif"),
 462          "reading written grayscale gif")) {
 463     my $diff = i_img_diff($ooim3->{IMG}, $im2->{IMG});
 464     ok($diff <= $maxerror{$makemap}, "comparing images $diff");
 465     #$im2->write(file=>"testout/t105gray-$makemap.ppm");
 466   }
 467   else {
 468   SKIP: { skip("could not get test image", 1); }
 469   }
 470 }
 471 for my $translate (qw(closest perturb errdiff)) {
 472   print "# translate => $translate\n";
 473   my @colors = map NC($_*50, $_*50, $_*50), 0..4;
 474   ok($ooim->write(file=>"testout/t105gray-$translate.gif",
 475                   translate=>$translate,
 476                   make_colors=>'none',
 477                   colors=>\@colors,
 478                   gifquant=>'gen'),
 479      "writing gif with translate $translate");
 480   my $im2 = Imager->new;
 481   if (ok($im2->read(file=>"testout/t105gray-$translate.gif"),
 482          "reading written grayscale gif")) {
 483     my $diff = i_img_diff($ooim3->{IMG}, $im2->{IMG});
 484     ok($diff <= $maxerror{$translate}, "comparing images $diff");
 485     #$im2->write(file=>"testout/t105gray-$translate.ppm");
 486   }
 487   else {
 488   SKIP: { skip("could not load test image", 1) }
 489   }
 490     }
 491
 492 # try to write an image with no colors - should error
 493 ok(!$ooim->write(file=>"testout/t105nocolors.gif",
 494                  make_colors=>'none',
 495                  colors=>[], gifquant=>'gen'),
 496    "write with no colors");
 497
 498 # try to write multiple with no colors, with separate maps
 499 # I don't see a way to test this, since we don't have a mechanism
 500 # to give the second image different quant options, we can't trigger
 501 # a failure just for the second image
 502
 503 # check that the i_format tag is set for both multiple and single
 504 # image reads
 505 {
 506   my @anim = Imager->read_multi(file=>"testout/t105_anim.gif");
 507   ok(@anim == 5, "check we got all the images");
 508   for my $frame (@anim) {
 509     my ($type) = $frame->tags(name=>'i_format');
 510     is($type, 'gif', "check i_format for animation frame");
 511   }
 512
 513   my $im = Imager->new;
 514   ok($im->read(file=>"testout/t105.gif"), "read some gif");
 515   my ($type) = $im->tags(name=>'i_format');
 516   is($type, 'gif', 'check i_format for single image read');
 517 }
 518
 519 { # check file limits are checked
 520   my $limit_file = "testout/t105.gif";
 521   ok(Imager->set_file_limits(reset=>1, width=>149), "set width limit 149");
 522   my $im = Imager->new;
 523   ok(!$im->read(file=>$limit_file),
 524      "should fail read due to size limits");
 525   print "# ",$im->errstr,"\n";
 526   like($im->errstr, qr/image width/, "check message");
 527
 528   ok(Imager->set_file_limits(reset=>1, height=>149), "set height limit 149");
 529   ok(!$im->read(file=>$limit_file),
 530      "should fail read due to size limits");
 531   print "# ",$im->errstr,"\n";
 532   like($im->errstr, qr/image height/, "check message");
 533
 534   ok(Imager->set_file_limits(reset=>1, width=>150), "set width limit 150");
 535   ok($im->read(file=>$limit_file),
 536      "should succeed - just inside width limit");
 537   ok(Imager->set_file_limits(reset=>1, height=>150), "set height limit 150");
 538   ok($im->read(file=>$limit_file),
 539      "should succeed - just inside height limit");
 540
 541   # 150 x 150 x 3 channel image uses 67500 bytes
 542   ok(Imager->set_file_limits(reset=>1, bytes=>67499),
 543      "set bytes limit 67499");
 544   ok(!$im->read(file=>$limit_file),
 545      "should fail - too many bytes");
 546   print "# ",$im->errstr,"\n";
 547   like($im->errstr, qr/storage size/, "check error message");
 548   ok(Imager->set_file_limits(reset=>1, bytes=>67500),
 549      "set bytes limit 67500");
 550   ok($im->read(file=>$limit_file),
 551      "should succeed - just inside bytes limit");
 552   Imager->set_file_limits(reset=>1);
 553 }
 554
 555 {
 556   print "# test OO interface reading of consolidated images\n";
 557   my $im = Imager->new;
 558   ok($im->read(file=>'testimg/screen2.gif', gif_consolidate=>1),
 559      "read image to consolidate");
 560   my $expected = Imager->new;
 561   ok($expected->read(file=>'testimg/expected.gif'),
 562      "read expected via OO");
 563   is(i_img_diff($im->{IMG}, $expected->{IMG}), 0,
 564      "compare them");
 565
 566   # check the default read doesn't match
 567   ok($im->read(file=>'testimg/screen2.gif'),
 568      "read same image without consolidate");
 569   isnt(i_img_diff($im->{IMG}, $expected->{IMG}), 0,
 570        "compare them - shouldn't include the overlayed second image");
 571 }
 572 {
 573   print "# test the reading of single pages\n";
 574   # build a test file
 575   my $test_file = 'testout/t105_multi_sing.gif';
 576   my $im1 = Imager->new(xsize=>100, ysize=>100);
 577   $im1->box(filled=>1, color=>$blue);
 578   $im1->addtag(name=>'gif_left', value=>10);
 579   $im1->addtag(name=>'gif_top', value=>15);
 580   $im1->addtag(name=>'gif_comment', value=>'First page');
 581   my $im2 = Imager->new(xsize=>50, ysize=>50);
 582   $im2->box(filled=>1, color=>$red);
 583   $im2->addtag(name=>'gif_left', value=>30);
 584   $im2->addtag(name=>'gif_top', value=>25);
 585   $im2->addtag(name=>'gif_comment', value=>'Second page');
 586   my $im3 = Imager->new(xsize=>25, ysize=>25);
 587   $im3->box(filled=>1, color=>$green);
 588   $im3->addtag(name=>'gif_left', value=>35);
 589   $im3->addtag(name=>'gif_top', value=>45);
 590   # don't set comment for $im3
 591   ok(Imager->write_multi({ file=> $test_file}, $im1, $im2, $im3),
 592      "write test file for single page reads");
 593
 594   my $res = Imager->new;
 595   # check we get the first image
 596   ok($res->read(file=>$test_file), "read default (first) page");
 597   is(i_img_diff($im1->{IMG}, $res->{IMG}), 0, "compare against first");
 598   # check tags
 599   is($res->tags(name=>'gif_left'), 10, "gif_left");
 600   is($res->tags(name=>'gif_top'), 15, "gif_top");
 601   is($res->tags(name=>'gif_comment'), 'First page', "gif_comment");
 602
 603   # get the second image
 604   ok($res->read(file=>$test_file, page=>1), "read second page")
 605     or print "# ",$res->errstr, "\n";
 606   is(i_img_diff($im2->{IMG}, $res->{IMG}), 0, "compare against second");
 607   # check tags
 608   is($res->tags(name=>'gif_left'), 30, "gif_left");
 609   is($res->tags(name=>'gif_top'), 25, "gif_top");
 610   is($res->tags(name=>'gif_comment'), 'Second page', "gif_comment");
 611
 612   # get the third image
 613   ok($res->read(file=>$test_file, page=>2), "read third page")
 614     or print "# ",$res->errstr, "\n";
 615   is(i_img_diff($im3->{IMG}, $res->{IMG}), 0, "compare against third");
 616   is($res->tags(name=>'gif_left'), 35, "gif_left");
 617   is($res->tags(name=>'gif_top'), 45, "gif_top");
 618   is($res->tags(name=>'gif_comment'), undef, 'gif_comment undef');
 619
 620   # try to read a fourth page
 621     ok(!$res->read(file=>$test_file, page=>3), "fail reading fourth page");
 622   cmp_ok($res->errstr, "=~", 'page 3 not found',
 623          "check error message");
 624 }
 625 SKIP:
 626 {
 627   skip("gif_loop not supported on giflib before 4.1", 6)
 628     unless $gifver >= 4.1;
 629   # testing writing the loop extension
 630   my $im1 = Imager->new(xsize => 100, ysize => 100);
 631   $im1->box(filled => 1, color => '#FF0000');
 632   my $im2 = Imager->new(xsize => 100, ysize => 100);
 633   $im2->box(filled => 1, color => '#00FF00');
 634   ok(Imager->write_multi({
 635                           gif_loop => 5,
 636                           gif_delay => 50,
 637                           file => 'testout/t105loop.gif'
 638                          }, $im1, $im2),
 639      "write with loop extension");
 640
 641   my @im = Imager->read_multi(file => 'testout/t105loop.gif');
 642   is(@im, 2, "read loop images back");
 643   is($im[0]->tags(name => 'gif_loop'), 5, "first loop read back");
 644   is($im[1]->tags(name => 'gif_loop'), 5, "second loop read back");
 645   is($im[0]->tags(name => 'gif_delay'), 50, "first delay read back");
 646   is($im[1]->tags(name => 'gif_delay'), 50, "second delay read back");
 647 }
 648 SKIP:
 649 { # check graphic control extension and ns loop tags are read correctly
 650   print "# check GCE and netscape loop extension tag values\n";
 651   my @im = Imager->read_multi(file => 'testimg/screen3.gif');
 652   is(@im, 2, "read 2 images from screen3.gif")
 653     or skip("Could not load testimg/screen3.gif:".Imager->errstr, 11);
 654   is($im[0]->tags(name => 'gif_delay'),          50, "0 - gif_delay");
 655   is($im[0]->tags(name => 'gif_disposal'),        2, "0 - gif_disposal");
 656   is($im[0]->tags(name => 'gif_trans_index'), undef, "0 - gif_trans_index");
 657   is($im[0]->tags(name => 'gif_user_input'),      0, "0 - gif_user_input");
 658   is($im[0]->tags(name => 'gif_loop'),            0, "0 - gif_loop");
 659   is($im[1]->tags(name => 'gif_delay'),          50, "1 - gif_delay");
 660   is($im[1]->tags(name => 'gif_disposal'),        2, "1 - gif_disposal");
 661   is($im[1]->tags(name => 'gif_trans_index'),     7, "1 - gif_trans_index");
 662   is($im[1]->tags(name => 'gif_trans_color'), 'color(255,255,255,0)',
 663      "1 - gif_trans_index");
 664   is($im[1]->tags(name => 'gif_user_input'),      0, "1 - gif_user_input");
 665   is($im[1]->tags(name => 'gif_loop'),            0, "1 - gif_loop");
 666 }
 667
 668 {
 669   # manually modified from a small gif, this had the palette
 670   # size changed to half the size, leaving an index out of range
 671   my $im = Imager->new;
 672   ok($im->read(file => 'testimg/badindex.gif', type => 'gif'),
 673      "read bad index gif")
 674     or print "# ", $im->errstr, "\n";
 675   my @indexes = $im->getscanline('y' => 0, type => 'index');
 676   is_deeply(\@indexes, [ 0..4 ], "check for correct indexes");
 677   is($im->colorcount, 5, "check the palette was adjusted");
 678   is_color3($im->getpixel('y' => 0, x => 4), 0, 0, 0,
 679             "check it was black added");
 680   is($im->tags(name => 'gif_colormap_size'), 4, 'color map size tag');
 681 }
 682
 683 {
 684   ok(grep($_ eq 'gif', Imager->read_types), "check gif in read types");
 685   ok(grep($_ eq 'gif', Imager->write_types), "check gif in write types");
 686 }
 687
 688 {
 689   # check screen tags handled correctly note the screen size
 690   # supplied is larger than the box covered by the images
 691   my $im1 = Imager->new(xsize => 10, ysize => 8);
 692   $im1->settag(name => 'gif_top', value => 4);
 693   $im1->settag(name => 'gif_screen_width', value => 18);
 694   $im1->settag(name => 'gif_screen_height', value => 16);
 695   my $im2 = Imager->new(xsize => 7, ysize => 10);
 696   $im2->settag(name => 'gif_left', value => 3);
 697   my @im = ( $im1, $im2 );
 698
 699   my $data;
 700   ok(Imager->write_multi({ data => \$data, type => 'gif' }, @im),
 701      "write with screen settings")
 702     or print "# ", Imager->errstr, "\n";
 703   my @result = Imager->read_multi(data => $data);
 704   is(@result, 2, "got 2 images back");
 705   is($result[0]->tags(name => 'gif_screen_width'), 18,
 706      "check result screen width");
 707   is($result[0]->tags(name => 'gif_screen_height'), 16,
 708      "check result screen height");
 709   is($result[0]->tags(name => 'gif_left'), 0,
 710      "check first gif_left");
 711   is($result[0]->tags(name => 'gif_top'), 4,
 712      "check first gif_top");
 713   is($result[1]->tags(name => 'gif_left'), 3,
 714      "check second gif_left");
 715   is($result[1]->tags(name => 'gif_top'), 0,
 716      "check second gif_top");
 717 }
 718
 719 { # test colors array returns colors
 720   my $data;
 721   my $im = test_image();
 722   my @colors;
 723   ok($im->write(data => \$data,
 724                 colors => \@colors,
 725                 make_colors => 'webmap',
 726                 translate => 'closest',
 727                 gifquant => 'gen',
 728                 type => 'gif'),
 729      "write using webmap to check color table");
 730   is(@colors, 216, "should be 216 colors in the webmap");
 731   is_color3($colors[0], 0, 0, 0, "first should be 000000");
 732   is_color3($colors[1], 0, 0, 0x33, "second should be 000033");
 733   is_color3($colors[8], 0, 0x33, 0x66, "9th should be 003366");
 734 }
 735
 736 { # a zero length extension could make read_/read_multi crash
 737   my ($im) = Imager->read_multi(file => "testimg/zerocomm.gif");
 738   ok($im, "read image with zero-length extension");
 739 }
 740
 741
 742 { # check close failures are handled correctly
 743   my $im = test_image_mono();
 744   my $fail_close = sub {
 745     Imager::i_push_error(0, "synthetic close failure");
 746     return 0;
 747   };
 748   ok(!$im->write(type => "gif", callback => sub { 1 },
 749                  closecb => $fail_close),
 750      "check failing close fails");
 751     like($im->errstr, qr/synthetic close failure/,
 752          "check error message");
 753 }
 754
 755
 756 sub test_readgif_cb {
 757   my ($size) = @_;
 758
 759   open FH, "<testimg/scale.gif" or die "Cannot open testimg/scale.gif";
 760   binmode FH;
 761   my $io = Imager::io_new_cb
 762     (
 763      undef,
 764      sub { my $tmp; read(FH, $tmp, $size) and $tmp },
 765      undef,
 766      undef
 767      );
 768   my $img = Imager::File::GIF::i_readgif_wiol($io);
 769   close FH;
 770   return $img;
 771 }
 772
 773 # tests for reading bad gif files
 774 sub read_failure {
 775   my ($filename) = @_;
 776
 777   open FH, "< $filename"
 778     or die "Cannot open $filename: $!";
 779   binmode FH;
 780   my $io = Imager::io_new_fd(fileno(FH));
 781   my ($result, $map) = Imager::File::GIF::i_readgif_wiol($io);
 782   ok(!$result, "attempt to read invalid image $filename ".Imager::_error_as_msg());
 783   close FH;
 784 }
 785
 786 sub _clear_tags {
 787   my (@imgs) = @_;
 788
 789   for my $img (@imgs) {
 790     $img->deltag(code=>0);
 791   }
 792 }
 793
 794 sub _add_tags {
 795   my ($img, %tags) = @_;
 796
 797   for my $key (keys %tags) {
 798     Imager::i_tags_add($img, $key, 0, $tags{$key}, 0);
 799   }
 800 }
 801
 802 sub ext_test {
 803   my ($testnum, $code, $count, $name) = @_;
 804
 805   $count ||= 1;
 806   $name ||= "gif$testnum";
 807
 808   # build our code
 809   my $script = "testout/$name.pl";
 810   if (open SCRIPT, "> $script") {
 811     print SCRIPT <<'PROLOG';
 812 #!perl -w
 813 if (lc $^O eq 'mswin32') {
 814   # avoid the dialog box that window's pops up on a GPF
 815   # if you want to debug this stuff, I suggest you comment out the
 816   # following
 817   eval {
 818     require Win32API::File;
 819     Win32API::File::SetErrorMode( Win32API::File::SEM_NOGPFAULTERRORBOX());
 820   };
 821 }
 822 PROLOG
 823
 824     print SCRIPT $code;
 825     close SCRIPT;
 826
 827     my $perl = $^X;
 828     $perl = qq/"$perl"/ if $perl =~ / /;
 829
 830     print "# script: $script\n";
 831     my $cmd = "$perl -Mblib $script";
 832     print "# command: $cmd\n";
 833
 834     my $ok = 1;
 835     my @out = `$cmd`; # should work on DOS and Win32
 836     my $found = 0;
 837     for (@out) {
 838       if (/^not ok\s+(?:\d+\s*)?#(.*)/ || /^not ok/) {
 839         my $msg = $1 || '';
 840         ok(0, $msg);
 841         $ok = 0;
 842         ++$found;
 843       }
 844       elsif (/^ok\s+(?:\d+\s*)?#(.*)/ || /^ok/) {
 845         my $msg = $1 || '';
 846         ok(1, $msg);
 847         ++$found;
 848       }
 849     }
 850     unless ($count == $found) {
 851       print "# didn't see enough ok/not ok\n";
 852       $ok = 0;
 853     }
 854     return $ok;
 855   }
 856   else {
 857     return skip("could not create test script $script: $!");
 858     return 0;
 859   }
 860 }