t/t105gif.t

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