t/t105gif.t

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