t/t105gif.t

   1 #!perl -w
   2 use strict;
   3 $|=1;
   4 print "1..61\n";
   5 use Imager qw(:all);
   6 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, 61, "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 version
 213 of giflib 4.1.0, which has 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 In previous versions of Imager only this test was careful about catching
 223 the error, we now skip any tests that crashed or failed when the buggy
 224 giflib was present.
 225 EOS
 226       }
 227     }
 228     else {
 229       print "ok 14 # skip giflib3 doesn't support callbacks\n";
 230     }
 231     @imgs = ();
 232     my $c = i_color_new(0,0,0,0);
 233     for my $g (0..3) {
 234       my $im = Imager::ImgRaw::new(200, 200, 3);
 235       _add_tags($im, gif_local_map=>1, gif_delay=>150, gif_loop=>10);
 236       for my $x (0 .. 39) {
 237         for my $y (0 .. 39) {
 238           $c->set($x * 6, $y * 6, 32*$g+$x+$y, 255);
 239           i_box_filled($im, $x*5, $y*5, $x*5+4, $y*5+4, $c);
 240         }
 241       }
 242       push(@imgs, $im);
 243     }
 244     # test giflib with multiple palettes
 245     # (it was meant to test the NS loop extension too, but that's broken)
 246     # this looks better with make_colors=>'addi', translate=>'errdiff'
 247     # this test aims to overload the palette for each image, so the
 248     # output looks moderately horrible
 249     open FH, ">testout/t105_mult_pall.gif" or die "Cannot create file: $!";
 250     binmode FH;
 251     if (i_writegif_gen(fileno(FH), { #make_colors=>'webmap',
 252                                      translate=>'giflib',
 253                                    }, @imgs)) {
 254       print "ok 15\n";
 255     }
 256     else {
 257       print "not ok 15 # ", join(":", map $_->[1], Imager::i_errors()),"\n";
 258     }
 259     close FH;
 260
 261     # regression test: giflib doesn't like 1 colour images
 262     my $img1 = Imager::ImgRaw::new(100, 100, 3);
 263     i_box_filled($img1, 0, 0, 100, 100, $red);
 264     open FH, ">testout/t105_onecol.gif" or die $!;
 265     binmode FH;
 266     if (i_writegif_gen(fileno(FH), { translate=>'giflib'}, $img1)) {
 267       print "ok 16 # single colour write regression\n";
 268     } else {
 269       print "not ok 16 # single colour write regression\n";
 270     }
 271     close FH;
 272
 273     # transparency test
 274     # previously it was harder do write transparent images
 275     # tests the improvements
 276     my $timg = Imager::ImgRaw::new(20, 20, 4);
 277     my $trans = i_color_new(255, 0, 0, 127);
 278     i_box_filled($timg, 0, 0, 20, 20, $green);
 279     i_box_filled($timg, 2, 2, 18, 18, $trans);
 280     open FH, ">testout/t105_trans.gif" or die $!;
 281     binmode FH;
 282     i_writegif_gen(fileno(FH), { make_colors=>'addi',
 283                                  translate=>'closest',
 284                                  transp=>'ordered',
 285                                }, $timg) or print "not ";
 286     print "ok 17\n";
 287     close FH;
 288
 289     # some error handling tests
 290     # open a file handle for read and try to save to it
 291     # is this idea portable?
 292     # whether or not it is, giflib segfaults on this <sigh>
 293     #open FH, "<testout/t105_trans.gif" or die $!;
 294     #binmode FH; # habit, I suppose
 295     #if (i_writegif_gen(fileno(FH), {}, $timg)) {
 296     #  # this is meant to _fail_
 297     #  print "not ok 18 # writing to read-only should fail";
 298     #}
 299     #else {
 300     #  print "ok 18 # ",Imager::_error_as_msg(),"\n";
 301     #}
 302     #close FH;
 303
 304     # try to read a file of the wrong format - the script will do
 305     open FH, "<t/t105gif.t"
 306       or die "Cannot open this script!: $!";
 307     binmode FH;
 308     my $im2 = i_readgif(fileno(FH));
 309     if ($im2) {
 310       # this should have failed
 311       print "not ok 18 # giflib think script if a GIF file\n";
 312     }
 313     else {
 314       print "ok 18 # ",Imager::_error_as_msg(),"\n";
 315     }
 316     close FH;
 317
 318     # try to save no images :)
 319     open FH, ">testout/t105_none.gif"
 320       or die "Cannot open testout/t105_none.gif: $!";
 321     binmode FH;
 322     if (i_writegif_gen(fileno(FH), {}, "hello")) {
 323       print "not ok 19 # shouldn't be able to save strings\n";
 324     }
 325     else {
 326       print "ok 19 # ",Imager::_error_as_msg(),"\n";
 327     }
 328
 329     # try to read a truncated gif (no image descriptors)
 330     read_failure('testimg/trimgdesc.gif', 20);
 331     # file truncated just after the image descriptor tag
 332     read_failure('testimg/trmiddesc.gif', 21);
 333     # image has no colour map
 334     read_failure('testimg/nocmap.gif', 22);
 335
 336     unless (-e $buggy_giflib_file) {
 337       # image has a local colour map
 338       open FH, "< testimg/loccmap.gif"
 339         or die "Cannot open testimg/loccmap.gif: $!";
 340       binmode FH;
 341       if (i_readgif(fileno(FH))) {
 342         print "ok 23\n";
 343       }
 344       else {
 345         print "not ok 23 # failed to read image with only a local colour map";
 346       }
 347       close FH;
 348
 349       # image has global and local colour maps
 350       open FH, "< testimg/screen2.gif"
 351         or die "Cannot open testimg/screen2.gif: $!";
 352       binmode FH;
 353       my $ims = i_readgif(fileno(FH));
 354       if ($ims) {
 355         print "ok 24\n";
 356       }
 357       else {
 358         print "not ok 24 # ",Imager::_error_as_msg(),"\n";
 359       }
 360       close FH;
 361       open FH, "< testimg/expected.gif"
 362         or die "Cannot open testimg/expected.gif: $!";
 363       binmode FH;
 364       my $ime = i_readgif(fileno(FH));
 365       close FH;
 366       if ($ime) {
 367         print "ok 25\n";
 368       }
 369       else {
 370         print "not ok 25 # ",Imager::_error_as_msg(),"\n";
 371       }
 372       if ($ims && $ime) {
 373         if (i_img_diff($ime, $ims)) {
 374           print "not ok 26 # mismatch ",i_img_diff($ime, $ims),"\n";
 375           # save the bad one
 376           open FH, "> testout/t105_screen2.gif"
 377             or die "Cannot create testout/t105_screen.gif: $!";
 378           binmode FH;
 379           i_writegifmc($ims, fileno(FH), 7)
 380             or print "# could not save t105_screen.gif\n";
 381           close FH;
 382         }
 383         else {
 384           print "ok 26\n";
 385         }
 386       }
 387       else {
 388         print "ok 26 # skipped\n";
 389       }
 390
 391       # test reading a multi-image file into multiple images
 392       open FH, "< testimg/screen2.gif"
 393         or die "Cannot open testimg/screen2.gif: $!";
 394       binmode FH;
 395       @imgs = Imager::i_readgif_multi(fileno(FH))
 396         or print "not ";
 397       print "ok 27\n";
 398       close FH;
 399       @imgs == 2 or print "not ";
 400       print "ok 28\n";
 401       for my $img (@imgs) {
 402         unless (Imager::i_img_type($img) == 1) {
 403           print "not ";
 404           last;
 405         }
 406       }
 407       print "ok 29\n";
 408       Imager::i_colorcount($imgs[0]) == 4 or print "not ";
 409       print "ok 30\n";
 410       Imager::i_colorcount($imgs[1]) == 2 or print "not ";
 411       print "ok 31\n";
 412       Imager::i_tags_find($imgs[0], "gif_left", 0) or print "not ";
 413       print "ok 32\n";
 414       my @tags = map {[ Imager::i_tags_get($imgs[1], $_) ]} 0..Imager::i_tags_count($imgs[1])-1;
 415       my ($left) = grep $_->[0] eq 'gif_left', @tags;
 416       $left && $left->[1] == 3 or print "not ";
 417       print "ok 33\n";
 418
 419       # screen3.gif was saved with
 420       open FH, "< testimg/screen3.gif"
 421         or die "Cannot open testimg/screen3.gif: $!";
 422       binmode FH;
 423       @imgs = Imager::i_readgif_multi(fileno(FH))
 424         or print "not ";
 425       print "ok 34\n";
 426       close FH;
 427       eval {
 428         require 'Data/Dumper.pm';
 429         Data::Dumper->import();
 430       };
 431       unless ($@) {
 432         # build a big map of all tags for all images
 433         @tags =
 434           map {
 435             my $im = $_;
 436             [
 437              map { join ",", map { defined() ? $_ : "undef" } Imager::i_tags_get($im, $_) }
 438              0..Imager::i_tags_count($_)-1
 439             ]
 440           } @imgs;
 441         my $dump = Dumper(\@tags);
 442         $dump =~ s/^/# /mg;
 443         print "# tags from gif\n", $dump;
 444       }
 445
 446       # at this point @imgs should contain only paletted images
 447       ok(35, Imager::i_img_type($imgs[0]) == 1, "imgs[0] not paletted");
 448       ok(36, Imager::i_img_type($imgs[1]) == 1, "imgs[1] not paletted");
 449
 450       # see how we go saving it
 451       open FH, ">testout/t105_pal.gif" or die $!;
 452       binmode FH;
 453       ok(37, i_writegif_gen(fileno(FH), { make_colors=>'addi',
 454                                           translate=>'closest',
 455                                           transp=>'ordered',
 456                                         }, @imgs), "write from paletted");
 457       close FH;
 458
 459       # make sure nothing bad happened
 460       open FH, "< testout/t105_pal.gif" or die $!;
 461       binmode FH;
 462       ok(38, (my @imgs2 = Imager::i_readgif_multi(fileno(FH))) == 2,
 463          "re-reading saved paletted images");
 464       ok(39, i_img_diff($imgs[0], $imgs2[0]) == 0, "imgs[0] mismatch");
 465       ok(40, i_img_diff($imgs[1], $imgs2[1]) == 0, "imgs[1] mismatch");
 466     }
 467     else {
 468       for (23..40) {
 469         print "ok $_ # skip see $buggy_giflib_file\n";
 470       }
 471     }
 472     # test that the OO interface warns when we supply old options
 473     {
 474       my @warns;
 475       local $SIG{__WARN__} = sub { push(@warns, "@_") };
 476
 477       my $ooim = Imager->new;
 478       ok(41, $ooim->read(file=>"testout/t105.gif"), "read into object");
 479       ok(42, $ooim->write(file=>"testout/t105_warn.gif", interlace=>1),
 480         "save from object");
 481       ok(43, grep(/Obsolete .* interlace .* gif_interlace/, @warns),
 482         "check for warning");
 483       init(warn_obsolete=>0);
 484       @warns = ();
 485       ok(44, $ooim->write(file=>"testout/t105_warn.gif", interlace=>1),
 486         "save from object");
 487       ok(45, !grep(/Obsolete .* interlace .* gif_interlace/, @warns),
 488         "check for warning");
 489     }
 490
 491     # test that we get greyscale from 1 channel images
 492     # we check for each makemap, and for each translate
 493     print "# test writes of grayscale images - ticket #365\n";
 494     my $num = 46;
 495     my $ooim = Imager->new(xsize=>50, ysize=>50, channels=>1);
 496     for (my $y = 0; $y < 50; $y += 10) {
 497       $ooim->box(box=>[ 0, $y, 49, $y+9], color=>NC($y*5,0,0), filled=>1);
 498     }
 499     my $ooim3 = $ooim->convert(preset=>'rgb');
 500     #$ooim3->write(file=>'testout/t105gray.ppm');
 501     my %maxerror = ( mediancut => 51000,
 502                      addi => 0,
 503                      closest => 0,
 504                      perturb => 0,
 505                      errdiff => 0 );
 506     for my $makemap (qw(mediancut addi)) {
 507       print "# make_colors => $makemap\n";
 508       ok($num++, $ooim->write(file=>"testout/t105gray-$makemap.gif",
 509                               make_colors=>$makemap,
 510                               gifquant=>'gen'),
 511          "writing gif with makemap $makemap");
 512       my $im2 = Imager->new;
 513       if (ok($num++, $im2->read(file=>"testout/t105gray-$makemap.gif"),
 514              "reading written grayscale gif")) {
 515         my $diff = i_img_diff($ooim3->{IMG}, $im2->{IMG});
 516         ok($num++, $diff <= $maxerror{$makemap}, "comparing images $diff");
 517         #$im2->write(file=>"testout/t105gray-$makemap.ppm");
 518       }
 519       else {
 520         print "ok $num # skip\n";
 521         ++$num;
 522       }
 523     }
 524     for my $translate (qw(closest perturb errdiff)) {
 525       print "# translate => $translate\n";
 526       my @colors = map NC($_*50, $_*50, $_*50), 0..4;
 527       ok($num++, $ooim->write(file=>"testout/t105gray-$translate.gif",
 528                               translate=>$translate,
 529                               make_colors=>'none',
 530                               colors=>\@colors,
 531                               gifquant=>'gen'),
 532          "writing gif with translate $translate");
 533       my $im2 = Imager->new;
 534       if (ok($num++, $im2->read(file=>"testout/t105gray-$translate.gif"),
 535              "reading written grayscale gif")) {
 536         my $diff = i_img_diff($ooim3->{IMG}, $im2->{IMG});
 537         ok($num++, $diff <= $maxerror{$translate}, "comparing images $diff");
 538         #$im2->write(file=>"testout/t105gray-$translate.ppm");
 539       }
 540       else {
 541         print "ok $num # skip\n";
 542         ++$num;
 543       }
 544     }
 545
 546     # try to write an image with no colors - should error
 547     ok($num++, !$ooim->write(file=>"testout/t105nocolors.gif",
 548                             make_colors=>'none',
 549                             colors=>[], gifquant=>'gen'),
 550        "write with no colors");
 551
 552     # try to write multiple with no colors, with separate maps
 553     # I don't see a way to test this, since we don't have a mechanism
 554     # to give the second image different quant options, we can't trigger
 555     # a failure just for the second image
 556 }
 557
 558 sub ok ($$$) {
 559   my ($num, $ok, $comment) = @_;
 560
 561   if ($ok) {
 562     print "ok $num\n";
 563   }
 564   else {
 565     print "not ok $num # line ",(caller)[2],": $comment \n";
 566   }
 567 }
 568
 569 sub test_readgif_cb {
 570   my ($size) = @_;
 571
 572   open FH, "<testimg/scale.gif" or die "Cannot open testimg/scale.gif";
 573   binmode FH;
 574   my $img = i_readgif_callback(sub { my $tmp; read(FH, $tmp, $size) and $tmp });
 575   close FH;
 576   return $img;
 577 }
 578
 579 # tests for reading bad gif files
 580 sub read_failure {
 581   my ($filename, $testnum) = @_;
 582
 583   open FH, "< $filename"
 584     or die "Cannot open $filename: $!";
 585   binmode FH;
 586   my ($result, $map) = i_readgif(fileno(FH));
 587   if ($result) {
 588     print "not ok $testnum # this is an invalid file, we succeeded\n";
 589   }
 590   else {
 591     print "ok $testnum # ",Imager::_error_as_msg(),"\n";
 592   }
 593   close FH;
 594 }
 595
 596 sub _clear_tags {
 597   my (@imgs) = @_;
 598
 599   for my $img (@imgs) {
 600     $img->deltag(code=>0);
 601   }
 602 }
 603
 604 sub _add_tags {
 605   my ($img, %tags) = @_;
 606
 607   for my $key (keys %tags) {
 608     Imager::i_tags_add($img, $key, 0, $tags{$key}, 0);
 609   }
 610 }
 611
 612 sub ext_test {
 613   my ($testnum, $code, $count, $name) = @_;
 614
 615   $count ||= 1;
 616   $name ||= "gif$testnum";
 617
 618   # build our code
 619   my $script = "testout/$name.pl";
 620   if (open SCRIPT, "> $script") {
 621     print SCRIPT <<'PROLOG';
 622 #!perl -w
 623 if (lc $^O eq 'mswin32') {
 624   # avoid the dialog box that window's pops up on a GPF
 625   # if you want to debug this stuff, I suggest you comment out the
 626   # following
 627   eval {
 628     require Win32API::File;
 629     Win32API::File::SetErrorMode( Win32API::File::SEM_NOGPFAULTERRORBOX());
 630   };
 631 }
 632 PROLOG
 633
 634     print SCRIPT $code;
 635     close SCRIPT;
 636
 637     my $perl = $^X;
 638     $perl = qq/"$perl"/ if $perl =~ / /;
 639
 640     print "# script: $script\n";
 641     my $cmd = "$perl -Mblib $script";
 642     print "# command: $cmd\n";
 643
 644     my $ok = 1;
 645     my @out = `$cmd`; # should work on DOS and Win32
 646     print @out;
 647     my $found = 0;
 648     for (@out) {
 649       if (/^not ok/) {
 650         $ok = 0;
 651         ++$found;
 652       }
 653       elsif (/^ok/) {
 654         ++$found;
 655       }
 656     }
 657     unless ($count == $found) {
 658       print "# didn't see enough ok/not ok\n";
 659       $ok = 0;
 660     }
 661     return $ok;
 662   }
 663   else {
 664     return skip($testnum, $count, "could not create test script $script: $!");
 665     return 0;
 666   }
 667 }