t/t105gif.t

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