t/t105gif.t

   1 #!perl -w
   2 use strict;
   3 $|=1;
   4 use lib 't';
   5 use Test::More tests => 69;
   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", 65);
  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) if $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     if ($gifver >= 4.0) {
 172       ++$can_write_callback;
 173       my $good = ext_test(14, <<'ENDOFCODE');
 174 use Imager;
 175 require "t/testtools.pl";
 176 my $timg = test_img();
 177 my @gif_delays = (50) x 5;
 178 my @gif_disposal = (2) x 5;
 179 my @imgs = ($timg) x 5;
 180 open FH, "> testout/t105_anim_cb.gif" or die $!;
 181 binmode FH;
 182 i_writegif_callback(sub {
 183                       print FH $_[0]
 184                     },
 185                     -1, # max buffering
 186                     { make_colors=>'webmap',
 187                       translate=>'closest',
 188                       gif_delays=>\@gif_delays,
 189                       gif_disposal=>\@gif_disposal,
 190                       #transp=>'ordered',
 191                       tr_orddith=>'dot8'}, @imgs)
 192   or die "Cannot write anim gif";
 193 close FH;
 194 print "ok 14\n";
 195 exit;
 196 ENDOFCODE
 197       unless ($good) {
 198         $can_write_callback = 0;
 199         print "not ok 14 # see $buggy_giflib_file\n";
 200         print STDERR "\nprobable buggy giflib - skipping tests that depend on a good giflib\n";
 201         print STDERR "see $buggy_giflib_file for more information\n";
 202         open FLAG, "> $buggy_giflib_file" or die;
 203         print FLAG <<EOS;
 204 This file is created by t105gif.t when test 14 fails.
 205
 206 This failure usually indicates you\'re using the original versions
 207 of giflib 4.1.0 - 4.1.3, which have a few bugs that Imager tickles.
 208
 209 You can apply the patch from:
 210
 211 http://www.develop-help.com/imager/giflib.patch
 212
 213 or you can just install Imager as is, if you only need to write GIFs to
 214 files or file descriptors (such as sockets).
 215
 216 One hunk of this patch is rejected (correctly) with giflib 4.1.3,
 217 since one bug that the patch fixes is fixed in 4.1.3.
 218
 219 If you don't feel comfortable with that apply the patch file that
 220 belongs to the following patch entry on sourceforge:
 221
 222 https://sourceforge.net/tracker/index.php?func=detail&aid=981255&group_id=102202&atid=631306
 223
 224 In previous versions of Imager only this test was careful about catching
 225 the error, we now skip any tests that crashed or failed when the buggy
 226 giflib was present.
 227 EOS
 228       }
 229     }
 230     else {
 231       print "ok 14 # skip giflib3 doesn't support callbacks\n";
 232     }
 233     @imgs = ();
 234     my $c = i_color_new(0,0,0,0);
 235     for my $g (0..3) {
 236       my $im = Imager::ImgRaw::new(200, 200, 3);
 237       _add_tags($im, gif_local_map=>1, gif_delay=>150, gif_loop=>10);
 238       for my $x (0 .. 39) {
 239         for my $y (0 .. 39) {
 240           $c->set($x * 6, $y * 6, 32*$g+$x+$y, 255);
 241           i_box_filled($im, $x*5, $y*5, $x*5+4, $y*5+4, $c);
 242         }
 243       }
 244       push(@imgs, $im);
 245     }
 246     # test giflib with multiple palettes
 247     # (it was meant to test the NS loop extension too, but that's broken)
 248     # this looks better with make_colors=>'addi', translate=>'errdiff'
 249     # this test aims to overload the palette for each image, so the
 250     # output looks moderately horrible
 251     open FH, ">testout/t105_mult_pall.gif" or die "Cannot create file: $!";
 252     binmode FH;
 253     ok(i_writegif_gen(fileno(FH), { #make_colors=>'webmap',
 254                                      translate=>'giflib',
 255                                    }, @imgs), "write multiple palettes")
 256       or print "# ", join(":", map $_->[1], Imager::i_errors()),"\n";
 257     close FH;
 258
 259     # regression test: giflib doesn't like 1 colour images
 260     my $img1 = Imager::ImgRaw::new(100, 100, 3);
 261     i_box_filled($img1, 0, 0, 100, 100, $red);
 262     open FH, ">testout/t105_onecol.gif" or die $!;
 263     binmode FH;
 264     ok(i_writegif_gen(fileno(FH), { translate=>'giflib'}, $img1),
 265        "single colour write regression");
 266     close FH;
 267
 268     # transparency test
 269     # previously it was harder do write transparent images
 270     # tests the improvements
 271     my $timg = Imager::ImgRaw::new(20, 20, 4);
 272     my $trans = i_color_new(255, 0, 0, 127);
 273     i_box_filled($timg, 0, 0, 20, 20, $green);
 274     i_box_filled($timg, 2, 2, 18, 18, $trans);
 275     open FH, ">testout/t105_trans.gif" or die $!;
 276     binmode FH;
 277     ok(i_writegif_gen(fileno(FH), { make_colors=>'addi',
 278                                  translate=>'closest',
 279                                  transp=>'ordered',
 280                                }, $timg), "write transparent");
 281     close FH;
 282
 283     # some error handling tests
 284     # open a file handle for read and try to save to it
 285     # is this idea portable?
 286     # whether or not it is, giflib segfaults on this <sigh>
 287     #open FH, "<testout/t105_trans.gif" or die $!;
 288     #binmode FH; # habit, I suppose
 289     #if (i_writegif_gen(fileno(FH), {}, $timg)) {
 290     #  # this is meant to _fail_
 291     #  print "not ok 18 # writing to read-only should fail";
 292     #}
 293     #else {
 294     #  print "ok 18 # ",Imager::_error_as_msg(),"\n";
 295     #}
 296     #close FH;
 297
 298     # try to read a file of the wrong format - the script will do
 299     open FH, "<t/t105gif.t"
 300       or die "Cannot open this script!: $!";
 301     binmode FH;
 302     ok(!i_readgif(fileno(FH)),
 303        "read test script as gif should fail ". Imager::_error_as_msg());
 304     close FH;
 305
 306     # try to save no images :)
 307     open FH, ">testout/t105_none.gif"
 308       or die "Cannot open testout/t105_none.gif: $!";
 309     binmode FH;
 310     if (ok(!i_writegif_gen(fileno(FH), {}, "hello"), "shouldn't be able to write a string as a gif")) {
 311       print "# ",Imager::_error_as_msg(),"\n";
 312     }
 313
 314     # try to read a truncated gif (no image descriptors)
 315     read_failure('testimg/trimgdesc.gif');
 316     # file truncated just after the image descriptor tag
 317     read_failure('testimg/trmiddesc.gif');
 318     # image has no colour map
 319     read_failure('testimg/nocmap.gif');
 320
 321     SKIP:
 322     {
 323       skip("see $buggy_giflib_file", 8) if -e $buggy_giflib_file;
 324       # image has a local colour map
 325       open FH, "< testimg/loccmap.gif"
 326         or die "Cannot open testimg/loccmap.gif: $!";
 327       binmode FH;
 328       ok(i_readgif(fileno(FH)), "read an image with only a local colour map");
 329       close FH;
 330
 331       # image has global and local colour maps
 332       open FH, "< testimg/screen2.gif"
 333         or die "Cannot open testimg/screen2.gif: $!";
 334       binmode FH;
 335       my $ims = i_readgif(fileno(FH));
 336       unless (ok($ims, "read an image with global and local colour map")) {
 337         print "# ",Imager::_error_as_msg(),"\n";
 338       }
 339       close FH;
 340
 341       open FH, "< testimg/expected.gif"
 342         or die "Cannot open testimg/expected.gif: $!";
 343       binmode FH;
 344       my $ime = i_readgif(fileno(FH));
 345       close FH;
 346       ok($ime, "reading testimg/expected.gif");
 347     SKIP:
 348       {
 349         skip("could not read one or both of expected.gif or loccamp.gif", 1)
 350           unless $ims and $ime;
 351         unless (is(i_img_diff($ime, $ims), 0,
 352                    "compare loccmap and expected")) {
 353           # save the bad one
 354           open FH, "> testout/t105_screen2.gif"
 355             or die "Cannot create testout/t105_screen.gif: $!";
 356           binmode FH;
 357           i_writegifmc($ims, fileno(FH), 7)
 358             or print "# could not save t105_screen.gif\n";
 359           close FH;
 360         }
 361       }
 362
 363       # test reading a multi-image file into multiple images
 364       open FH, "< testimg/screen2.gif"
 365         or die "Cannot open testimg/screen2.gif: $!";
 366       binmode FH;
 367       @imgs = Imager::i_readgif_multi(fileno(FH));
 368       ok(@imgs, "read multi-image file into multiple images");
 369       close FH;
 370       is(@imgs, 2, "should be 2 images");
 371       my $paletted = 1;
 372       for my $img (@imgs) {
 373         unless (Imager::i_img_type($img) == 1) {
 374           $paletted = 0;
 375           last;
 376         }
 377       }
 378       ok($paletted, "both images should be paletted");
 379       is(Imager::i_colorcount($imgs[0]), 4, "4 colours in first image");
 380       is(Imager::i_colorcount($imgs[1]), 2, "2 colours in second image");
 381       ok(Imager::i_tags_find($imgs[0], "gif_left", 0),
 382          "gif_left tag should be there");
 383       my @tags = map {[ Imager::i_tags_get($imgs[1], $_) ]} 0..Imager::i_tags_count($imgs[1])-1;
 384       my ($left) = grep $_->[0] eq 'gif_left', @tags;
 385       ok($left && $left->[1] == 3, "check gif_left value");
 386
 387       # screen3.gif was saved with
 388       open FH, "< testimg/screen3.gif"
 389         or die "Cannot open testimg/screen3.gif: $!";
 390       binmode FH;
 391       @imgs = Imager::i_readgif_multi(fileno(FH));
 392       ok(@imgs, "read screen3.gif");
 393       close FH;
 394       eval {
 395         require 'Data/Dumper.pm';
 396         Data::Dumper->import();
 397       };
 398       unless ($@) {
 399         # build a big map of all tags for all images
 400         @tags =
 401           map {
 402             my $im = $_;
 403             [
 404              map { join ",", map { defined() ? $_ : "undef" } Imager::i_tags_get($im, $_) }
 405              0..Imager::i_tags_count($_)-1
 406             ]
 407           } @imgs;
 408         my $dump = Dumper(\@tags);
 409         $dump =~ s/^/# /mg;
 410         print "# tags from gif\n", $dump;
 411       }
 412
 413       # at this point @imgs should contain only paletted images
 414       ok(Imager::i_img_type($imgs[0]) == 1, "imgs[0] paletted");
 415       ok(Imager::i_img_type($imgs[1]) == 1, "imgs[1] paletted");
 416
 417       # see how we go saving it
 418       open FH, ">testout/t105_pal.gif" or die $!;
 419       binmode FH;
 420       ok(i_writegif_gen(fileno(FH), { make_colors=>'addi',
 421                                           translate=>'closest',
 422                                           transp=>'ordered',
 423                                         }, @imgs), "write from paletted");
 424       close FH;
 425
 426       # make sure nothing bad happened
 427       open FH, "< testout/t105_pal.gif" or die $!;
 428       binmode FH;
 429       ok((my @imgs2 = Imager::i_readgif_multi(fileno(FH))) == 2,
 430          "re-reading saved paletted images");
 431       ok(i_img_diff($imgs[0], $imgs2[0]) == 0, "imgs[0] mismatch");
 432       ok(i_img_diff($imgs[1], $imgs2[1]) == 0, "imgs[1] mismatch");
 433     }
 434
 435     # test that the OO interface warns when we supply old options
 436     {
 437       my @warns;
 438       local $SIG{__WARN__} = sub { push(@warns, "@_") };
 439
 440       my $ooim = Imager->new;
 441       ok($ooim->read(file=>"testout/t105.gif"), "read into object");
 442       ok($ooim->write(file=>"testout/t105_warn.gif", interlace=>1),
 443         "save from object");
 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
 534 sub test_readgif_cb {
 535   my ($size) = @_;
 536
 537   open FH, "<testimg/scale.gif" or die "Cannot open testimg/scale.gif";
 538   binmode FH;
 539   my $img = i_readgif_callback(sub { my $tmp; read(FH, $tmp, $size) and $tmp });
 540   close FH;
 541   return $img;
 542 }
 543
 544 # tests for reading bad gif files
 545 sub read_failure {
 546   my ($filename) = @_;
 547
 548   open FH, "< $filename"
 549     or die "Cannot open $filename: $!";
 550   binmode FH;
 551   my ($result, $map) = i_readgif(fileno(FH));
 552   ok(!$result, "attempt to read invalid image $filename ".Imager::_error_as_msg());
 553   close FH;
 554 }
 555
 556 sub _clear_tags {
 557   my (@imgs) = @_;
 558
 559   for my $img (@imgs) {
 560     $img->deltag(code=>0);
 561   }
 562 }
 563
 564 sub _add_tags {
 565   my ($img, %tags) = @_;
 566
 567   for my $key (keys %tags) {
 568     Imager::i_tags_add($img, $key, 0, $tags{$key}, 0);
 569   }
 570 }
 571
 572 sub ext_test {
 573   my ($testnum, $code, $count, $name) = @_;
 574
 575   $count ||= 1;
 576   $name ||= "gif$testnum";
 577
 578   # build our code
 579   my $script = "testout/$name.pl";
 580   if (open SCRIPT, "> $script") {
 581     print SCRIPT <<'PROLOG';
 582 #!perl -w
 583 if (lc $^O eq 'mswin32') {
 584   # avoid the dialog box that window's pops up on a GPF
 585   # if you want to debug this stuff, I suggest you comment out the
 586   # following
 587   eval {
 588     require Win32API::File;
 589     Win32API::File::SetErrorMode( Win32API::File::SEM_NOGPFAULTERRORBOX());
 590   };
 591 }
 592 PROLOG
 593
 594     print SCRIPT $code;
 595     close SCRIPT;
 596
 597     my $perl = $^X;
 598     $perl = qq/"$perl"/ if $perl =~ / /;
 599
 600     print "# script: $script\n";
 601     my $cmd = "$perl -Mblib $script";
 602     print "# command: $cmd\n";
 603
 604     my $ok = 1;
 605     my @out = `$cmd`; # should work on DOS and Win32
 606     my $found = 0;
 607     for (@out) {
 608       if (/^not ok\s+(?:\d+\s*)?#(.*)/ || /^not ok/) {
 609         my $msg = $1 || '';
 610         ok(0, $msg);
 611         $ok = 0;
 612         ++$found;
 613       }
 614       elsif (/^ok\s+(?:\d+\s*)?#(.*)/ || /^ok/) {
 615         my $msg = $1 || '';
 616         ok(1, $msg);
 617         ++$found;
 618       }
 619     }
 620     unless ($count == $found) {
 621       print "# didn't see enough ok/not ok\n";
 622       $ok = 0;
 623     }
 624     return $ok;
 625   }
 626   else {
 627     return skip("could not create test script $script: $!");
 628     return 0;
 629   }
 630 }