t/t105gif.t

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