t/t10gif.t - metacpan.org

#!perl -w

=pod

IF THIS TEST CRASHES

Giflib/libungif have a long history of bugs, so if this script crashes
and you aren't running version 4.1.4 of giflib or libungif then
UPGRADE.

=cut

use strict;
$|=1;
use Test::More;
use Imager qw(:all);
use Imager::Test qw(is_color3 test_image test_image_raw test_image_mono);
use Imager::File::GIF;

use Carp 'confess';
$SIG{__DIE__} = sub { confess @_ };

-d "testout" or mkdir "testout";

init_log("testout/t105gif.log",1);

plan tests => 146;

my $green=i_color_new(0,255,0,255);
my $blue=i_color_new(0,0,255,255);
my $red=i_color_new(255,0,0,255);

my $img=test_image_raw;

my $gifver = Imager::File::GIF::i_giflib_version();
diag("giflib version (from header) $gifver");

{
  open(FH,">testout/t105.gif") || die "Cannot open testout/t105.gif\n";
  binmode(FH);
  my $io = Imager::io_new_fd(fileno(FH));
  ok(Imager::File::GIF::i_writegif_wiol($io, {}, $img), "write low") or
    die "Cannot write testout/t105.gif\n";
  $io->close;
  close(FH);
}

{
  open(FH,"testout/t105.gif") || die "Cannot open testout/t105.gif\n";
  binmode(FH);
  my $io = Imager::io_new_fd(fileno(FH));
  ok($img=Imager::File::GIF::i_readgif_wiol($io), "read low")
    or die "Cannot read testout/t105.gif\n";
  close(FH);
}

{
  open(FH,"testout/t105.gif") || die "Cannot open testout/t105.gif\n";
  binmode(FH);
  my $io = Imager::io_new_fd(fileno(FH));
  ($img, my $palette)=Imager::File::GIF::i_readgif_wiol($io);
  ok($img, "read palette") or die "Cannot read testout/t105.gif\n";
  close(FH);
  $palette=''; # just to skip a warning.
}


# check that reading interlaced/non-interlaced versions of 
# the same GIF produce the same image
# I could replace this with code that used Imager's built-in
# image comparison code, but I know this code revealed the error
{
  open(FH, "<testimg/scalei.gif") || die "Cannot open testimg/scalei.gif";
  binmode FH;
  my $io = Imager::io_new_fd(fileno(FH));
  my ($imgi) = Imager::File::GIF::i_readgif_wiol($io);
  ok($imgi, "read interlaced") or die "Cannot read testimg/scalei.gif";
  close FH;

  open FH, "<testimg/scale.gif" or die "Cannot open testimg/scale.gif";
  binmode FH;
  $io = Imager::io_new_fd(fileno(FH));
  my ($imgni) = Imager::File::GIF::i_readgif_wiol($io);
  ok($imgni, "read normal") or die "Cannot read testimg/scale.gif";
  close FH;

  open FH, ">testout/t105i.ppm" or die "Cannot create testout/t105i.ppm";
  binmode FH;
  my $IO = Imager::io_new_fd( fileno(FH) );
  i_writeppm_wiol($imgi, $IO)
    or die "Cannot write testout/t105i.ppm";
  close FH;

  open FH, ">testout/t105ni.ppm" or die "Cannot create testout/t105ni.ppm";
  binmode FH;
  $IO = Imager::io_new_fd( fileno(FH) );
  i_writeppm_wiol($imgni, $IO)
    or die "Cannot write testout/t105ni.ppm";
  close FH;

  # compare them
  open FH, "<testout/t105i.ppm" or die "Cannot open testout/t105i.ppm";
  my $datai = do { local $/; <FH> };
  close FH;

  open FH, "<testout/t105ni.ppm" or die "Cannot open testout/t105ni.ppm";
  my $datani = do { local $/; <FH> };
  close FH;
  is($datai, $datani, "images match");
}

{
  # reading with a callback
  # various sizes to make sure the buffering works
  # requested size
  open FH, "<testimg/scale.gif" or die "Cannot open testimg/scale.gif";
  binmode FH;
  my $io = Imager::io_new_cb
    (
     undef,
     sub { my $tmp; read(FH, $tmp, $_[0]) and $tmp },
     undef,
     undef
     );
  # no callback version in giflib3, so don't overwrite a good image
  my $img2 = Imager::File::GIF::i_readgif_wiol($io);
  close FH; 
  ok($img, "reading with a callback");
  
  ok(test_readgif_cb(1), "read callback 1 char buffer");
  ok(test_readgif_cb(512), "read callback 512 char buffer");
  ok(test_readgif_cb(1024), "read callback 1024 char buffer");
}
# new writegif_gen
# test webmap, custom errdiff map
# (looks fairly awful)
{
  open FH, ">testout/t105_gen.gif" or die $!;
  binmode FH;
  my $io = Imager::io_new_fd(fileno(FH));
  ok(Imager::File::GIF::i_writegif_wiol
     ($io, { make_colors=>'webmap',
	     translate=>'errdiff',
	     errdiff=>'custom',
	     errdiff_width=>2,
	     errdiff_height=>2,
	     errdiff_map=>[0, 1, 1, 0]}, $img),
     "webmap, custom errdif map");
  close FH;
}

print "# the following tests are fairly slow\n";

# test animation, mc_addi, error diffusion, ordered transparency
my @imgs;
my $sortagreen = i_color_new(0, 255, 0, 63);
for my $i (0..4) {
  my $im = Imager::ImgRaw::new(200, 200, 4);
  _add_tags($im, gif_delay=>50, gif_disposal=>2);
  for my $j (0..$i-1) {
    my $fill = i_color_new(0, 128, 0, 255 * ($i-$j)/$i);
    i_box_filled($im, 0, $j*40, 199, $j*40+40, $fill);
  }
  i_box_filled($im, 0, $i*40, 199, 199, $blue);
  push(@imgs, $im);
}
{
  my @gif_delays = (50) x 5;
  my @gif_disposal = (2) x 5;
  open FH, ">testout/t105_anim.gif" or die $!;
  binmode FH;
  my $io = Imager::io_new_fd(fileno(FH));
  ok(Imager::File::GIF::i_writegif_wiol
     ($io, { make_colors=>'addi',
	     translate=>'closest',
	     gif_delays=>\@gif_delays,
	     gif_disposal=>\@gif_disposal,
	     gif_positions=> [ map [ $_*10, $_*10 ], 0..4 ],
	     gif_user_input=>[ 1, 0, 1, 0, 1 ],
	     transp=>'ordered',
	     'tr_orddith'=>'dot8'}, @imgs),
     "write anim gif");
  close FH;
}

@imgs = ();
my $c = i_color_new(0,0,0,0);
for my $g (0..3) {
  my $im = Imager::ImgRaw::new(200, 200, 3);
  _add_tags($im, gif_local_map=>1, gif_delay=>150, gif_loop=>10);
  for my $x (0 .. 39) {
    for my $y (0 .. 39) {
      $c->set($x * 6, $y * 6, 32*$g+$x+$y, 255);
      i_box_filled($im, $x*5, $y*5, $x*5+4, $y*5+4, $c);
    }
  }
  push(@imgs, $im);
}
# test giflib with multiple palettes
# (it was meant to test the NS loop extension too, but that's broken)
# this looks better with make_colors=>'addi', translate=>'errdiff'
# this test aims to overload the palette for each image, so the
# output looks moderately horrible
{
  open FH, ">testout/t105_mult_pall.gif" or die "Cannot create file: $!";
  binmode FH;
  my $io = Imager::io_new_fd(fileno(FH));
  ok(Imager::File::GIF::i_writegif_wiol
     ($io, { #make_colors=>'webmap',
	    translate=>'giflib',
	   }, @imgs), "write multiple palettes")
    or print "# ", join(":", map $_->[1], Imager::i_errors()),"\n";
  close FH;
}

{
  # regression test: giflib doesn't like 1 colour images
  my $img1 = Imager::ImgRaw::new(100, 100, 3);
  i_box_filled($img1, 0, 0, 100, 100, $red);
  open FH, ">testout/t105_onecol.gif" or die $!;
  binmode FH;
  my $io = Imager::io_new_fd(fileno(FH));
  ok(Imager::File::GIF::i_writegif_wiol($io, { translate=>'giflib'}, $img1),
     "single colour write regression");
  close FH;
}

{
  # transparency test
  # previously it was harder do write transparent images
  # tests the improvements
  my $timg = Imager::ImgRaw::new(20, 20, 4);
  my $trans = i_color_new(255, 0, 0, 127);
  i_box_filled($timg, 0, 0, 20, 20, $green);
  i_box_filled($timg, 2, 2, 18, 18, $trans);
  open FH, ">testout/t105_trans.gif" or die $!;
  binmode FH;
  my $io = Imager::io_new_fd(fileno(FH));
  ok(Imager::File::GIF::i_writegif_wiol
     ($io, { make_colors=>'addi',
	     translate=>'closest',
	     transp=>'ordered',
	   }, $timg), "write transparent");
  close FH;
}

# some error handling tests
# open a file handle for read and try to save to it
# is this idea portable?
# whether or not it is, giflib segfaults on this <sigh>
#open FH, "<testout/t105_trans.gif" or die $!;
#binmode FH; # habit, I suppose
#if (i_writegif_gen(fileno(FH), {}, $timg)) {
#  # this is meant to _fail_
#  print "not ok 18 # writing to read-only should fail";
#}
#else {
#  print "ok 18 # ",Imager::_error_as_msg(),"\n";
#}
#close FH;

{
  # try to read a file of the wrong format - the script will do
  open FH, "<t/t10gif.t"
    or die "Cannot open this script!: $!";
  binmode FH;
  my $io = Imager::io_new_fd(fileno(FH));
  ok(!Imager::File::GIF::i_readgif_wiol($io), 
     "read test script as gif should fail ". Imager::_error_as_msg());
  close FH;
}

{
  # try to save no images :)
  open FH, ">testout/t105_none.gif"
    or die "Cannot open testout/t105_none.gif: $!";
  binmode FH;
  my $io = Imager::io_new_fd(fileno(FH));
  if (ok(!Imager::File::GIF::i_writegif_wiol($io, {}, "hello"), "shouldn't be able to write a string as a gif")) {
    print "# ",Imager::_error_as_msg(),"\n";
  }
}

# try to read a truncated gif (no image descriptors)
read_failure('testimg/trimgdesc.gif');
# file truncated just after the image descriptor tag
read_failure('testimg/trmiddesc.gif');
# image has no colour map
read_failure('testimg/nocmap.gif');

{
  # image has a local colour map
  open FH, "< testimg/loccmap.gif"
    or die "Cannot open testimg/loccmap.gif: $!";
  binmode FH;
  my $io = Imager::io_new_fd(fileno(FH));
  ok(Imager::File::GIF::i_readgif_wiol($io),
     "read an image with only a local colour map");
  close FH;
}

{
  # image has global and local colour maps
  open FH, "< testimg/screen2.gif"
    or die "Cannot open testimg/screen2.gif: $!";
  binmode FH;
  my $io = Imager::io_new_fd(fileno(FH));
  my $ims = Imager::File::GIF::i_readgif_wiol($io);
  unless (ok($ims, "read an image with global and local colour map")) {
    print "# ",Imager::_error_as_msg(),"\n";
  }
  close FH;
  
  open FH, "< testimg/expected.gif"
    or die "Cannot open testimg/expected.gif: $!";
  binmode FH;
  $io = Imager::io_new_fd(fileno(FH));
  my $ime = Imager::File::GIF::i_readgif_wiol($io);
  close FH;
  ok($ime, "reading testimg/expected.gif");
 SKIP:
  {
    skip("could not read one or both of expected.gif or loccamp.gif", 1)
      unless $ims and $ime;
    unless (is(i_img_diff($ime, $ims), 0, 
	       "compare loccmap and expected")) {
      # save the bad one
      open FH, "> testout/t105_screen2.gif"
	or die "Cannot create testout/t105_screen.gif: $!";
      binmode FH;
      my $io = Imager::io_new_fd(fileno(FH));
      Imager::File::GIF::i_writegif_wiol($io, {}, $ims)
	or print "# could not save t105_screen.gif\n";
      close FH;
    }
  }
}

{
  # test reading a multi-image file into multiple images
  open FH, "< testimg/screen2.gif"
    or die "Cannot open testimg/screen2.gif: $!";
  binmode FH;
  my $io = Imager::io_new_fd(fileno(FH));
  @imgs = Imager::File::GIF::i_readgif_multi_wiol($io);
  ok(@imgs, "read multi-image file into multiple images");
  close FH;
  is(@imgs, 2, "should be 2 images");
  my $paletted = 1;
  for my $img (@imgs) {
    unless (Imager::i_img_type($img) == 1) {
      $paletted = 0;
      last;
    }
  }
  ok($paletted, "both images should be paletted");
  is(Imager::i_colorcount($imgs[0]), 4, "4 colours in first image");
  is(Imager::i_colorcount($imgs[1]), 2, "2 colours in second image");
  ok(Imager::i_tags_find($imgs[0], "gif_left", 0), 
     "gif_left tag should be there");
  my @tags = map {[ Imager::i_tags_get($imgs[1], $_) ]} 0..Imager::i_tags_count($imgs[1])-1;
  my ($left) = grep $_->[0] eq 'gif_left', @tags;
  ok($left && $left->[1] == 3, "check gif_left value");
}

{
  # screen3.gif was saved with 
  open FH, "< testimg/screen3.gif"
    or die "Cannot open testimg/screen3.gif: $!";
  binmode FH;
  my $io = Imager::io_new_fd(fileno(FH));
  @imgs = Imager::File::GIF::i_readgif_multi_wiol($io);
  ok(@imgs, "read screen3.gif");
  close FH;
  eval {
    require 'Data/Dumper.pm';
    Data::Dumper->import();
  };

  unless ($@) {
    # build a big map of all tags for all images
    my @tags = 
      map { 
	my $im = $_; 
	[ 
	 map { join ",", map { defined() ? $_ : "undef" } Imager::i_tags_get($im, $_) } 
	 0..Imager::i_tags_count($_)-1 
	] 
      } @imgs;
    my $dump = Dumper(\@tags);
    $dump =~ s/^/# /mg;
    print "# tags from gif\n", $dump;
  }

  # at this point @imgs should contain only paletted images
  ok(Imager::i_img_type($imgs[0]) == 1, "imgs[0] paletted");
  ok(Imager::i_img_type($imgs[1]) == 1, "imgs[1] paletted");

  # see how we go saving it
  open FH, ">testout/t105_pal.gif" or die $!;
  binmode FH;
  $io = Imager::io_new_fd(fileno(FH));
  ok(Imager::File::GIF::i_writegif_wiol
     ($io, { make_colors=>'addi',
	     translate=>'closest',
	     transp=>'ordered',
	   }, @imgs), "write from paletted")
    or diag(Imager->_error_as_msg());
  close FH;
  
  # make sure nothing bad happened
  open FH, "< testout/t105_pal.gif" or die $!;
  binmode FH;
  $io = Imager::io_new_fd(fileno(FH));
  ok((my @imgs2 = Imager::File::GIF::i_readgif_multi_wiol($io)) == 2,
     "re-reading saved paletted images");
  ok(i_img_diff($imgs[0], $imgs2[0]) == 0, "imgs[0] mismatch");
  ok(i_img_diff($imgs[1], $imgs2[1]) == 0, "imgs[1] mismatch");
}

# test that the OO interface warns when we supply old options
{
  my @warns;
  local $SIG{__WARN__} = sub { push(@warns, "@_") };
  
  my $ooim = Imager->new;
  ok($ooim->read(file=>"testout/t105.gif"), "read into object");
  ok($ooim->write(file=>"testout/t105_warn.gif", interlace=>1),
     "save from object")
    or print "# ", $ooim->errstr, "\n";
  ok(grep(/Obsolete .* interlace .* gif_interlace/, @warns),
     "check for warning");
  init(warn_obsolete=>0);
  @warns = ();
  ok($ooim->write(file=>"testout/t105_warn.gif", interlace=>1),
     "save from object");
  ok(!grep(/Obsolete .* interlace .* gif_interlace/, @warns),
     "check for warning");
}

# test that we get greyscale from 1 channel images
# we check for each makemap, and for each translate
print "# test writes of grayscale images - ticket #365\n"; 
my $ooim = Imager->new(xsize=>50, ysize=>50, channels=>1);
for (my $y = 0; $y < 50; $y += 10) {
  $ooim->box(box=>[ 0, $y, 49, $y+9], color=>NC($y*5,0,0), filled=>1);
}
my $ooim3 = $ooim->convert(preset=>'rgb');
#$ooim3->write(file=>'testout/t105gray.ppm');
my %maxerror = ( mediancut => 51000, 
		 addi => 0,
		 closest => 0,
		 perturb => 0,
		 errdiff => 0 );
for my $makemap (qw(mediancut addi)) {
  print "# make_colors => $makemap\n";
  ok( $ooim->write(file=>"testout/t105gray-$makemap.gif",
		   make_colors=>$makemap,
		   gifquant=>'gen'),
      "writing gif with makemap $makemap");
  my $im2 = Imager->new;
  if (ok($im2->read(file=>"testout/t105gray-$makemap.gif"),
	 "reading written grayscale gif")) {
    my $diff = i_img_diff($ooim3->{IMG}, $im2->{IMG});
    ok($diff <= $maxerror{$makemap}, "comparing images $diff");
    #$im2->write(file=>"testout/t105gray-$makemap.ppm");
  }
  else {
  SKIP: { skip("could not get test image", 1); }
  }
}
for my $translate (qw(closest perturb errdiff)) {
  print "# translate => $translate\n";
  my @colors = map NC($_*50, $_*50, $_*50), 0..4;
  ok($ooim->write(file=>"testout/t105gray-$translate.gif",
		  translate=>$translate,
		  make_colors=>'none',
		  colors=>\@colors,
		  gifquant=>'gen'),
     "writing gif with translate $translate");
  my $im2 = Imager->new;
  if (ok($im2->read(file=>"testout/t105gray-$translate.gif"),
	 "reading written grayscale gif")) {
    my $diff = i_img_diff($ooim3->{IMG}, $im2->{IMG});
    ok($diff <= $maxerror{$translate}, "comparing images $diff");
    #$im2->write(file=>"testout/t105gray-$translate.ppm");
  }
  else {
  SKIP: { skip("could not load test image", 1) }
  }
    }

# try to write an image with no colors - should error
ok(!$ooim->write(file=>"testout/t105nocolors.gif",
		 make_colors=>'none',
		 colors=>[], gifquant=>'gen'),
   "write with no colors");

# try to write multiple with no colors, with separate maps
# I don't see a way to test this, since we don't have a mechanism
# to give the second image different quant options, we can't trigger
# a failure just for the second image

# check that the i_format tag is set for both multiple and single
# image reads
{
  my @anim = Imager->read_multi(file=>"testout/t105_anim.gif");
  ok(@anim == 5, "check we got all the images");
  for my $frame (@anim) {
    my ($type) = $frame->tags(name=>'i_format');
    is($type, 'gif', "check i_format for animation frame");
  }
  
  my $im = Imager->new;
  ok($im->read(file=>"testout/t105.gif"), "read some gif");
  my ($type) = $im->tags(name=>'i_format');
  is($type, 'gif', 'check i_format for single image read');
}

{ # check file limits are checked
  my $limit_file = "testout/t105.gif";
  ok(Imager->set_file_limits(reset=>1, width=>149), "set width limit 149");
  my $im = Imager->new;
  ok(!$im->read(file=>$limit_file),
     "should fail read due to size limits");
  print "# ",$im->errstr,"\n";
  like($im->errstr, qr/image width/, "check message");
  
  ok(Imager->set_file_limits(reset=>1, height=>149), "set height limit 149");
  ok(!$im->read(file=>$limit_file),
     "should fail read due to size limits");
  print "# ",$im->errstr,"\n";
  like($im->errstr, qr/image height/, "check message");
  
  ok(Imager->set_file_limits(reset=>1, width=>150), "set width limit 150");
  ok($im->read(file=>$limit_file),
     "should succeed - just inside width limit");
  ok(Imager->set_file_limits(reset=>1, height=>150), "set height limit 150");
  ok($im->read(file=>$limit_file),
     "should succeed - just inside height limit");
  
  # 150 x 150 x 3 channel image uses 67500 bytes
  ok(Imager->set_file_limits(reset=>1, bytes=>67499),
     "set bytes limit 67499");
  ok(!$im->read(file=>$limit_file),
     "should fail - too many bytes");
  print "# ",$im->errstr,"\n";
  like($im->errstr, qr/storage size/, "check error message");
  ok(Imager->set_file_limits(reset=>1, bytes=>67500),
     "set bytes limit 67500");
  ok($im->read(file=>$limit_file),
     "should succeed - just inside bytes limit");
  Imager->set_file_limits(reset=>1);
}

{
  print "# test OO interface reading of consolidated images\n";
  my $im = Imager->new;
  ok($im->read(file=>'testimg/screen2.gif', gif_consolidate=>1),
     "read image to consolidate");
  my $expected = Imager->new;
  ok($expected->read(file=>'testimg/expected.gif'),
     "read expected via OO");
  is(i_img_diff($im->{IMG}, $expected->{IMG}), 0,
     "compare them");
  
  # check the default read doesn't match
  ok($im->read(file=>'testimg/screen2.gif'),
     "read same image without consolidate");
  isnt(i_img_diff($im->{IMG}, $expected->{IMG}), 0,
       "compare them - shouldn't include the overlayed second image");
}
{
  print "# test the reading of single pages\n";
  # build a test file
  my $test_file = 'testout/t105_multi_sing.gif';
  my $im1 = Imager->new(xsize=>100, ysize=>100);
  $im1->box(filled=>1, color=>$blue);
  $im1->addtag(name=>'gif_left', value=>10);
  $im1->addtag(name=>'gif_top', value=>15);
  $im1->addtag(name=>'gif_comment', value=>'First page');
  my $im2 = Imager->new(xsize=>50, ysize=>50);
  $im2->box(filled=>1, color=>$red);
  $im2->addtag(name=>'gif_left', value=>30);
  $im2->addtag(name=>'gif_top', value=>25);
  $im2->addtag(name=>'gif_comment', value=>'Second page');
  my $im3 = Imager->new(xsize=>25, ysize=>25);
  $im3->box(filled=>1, color=>$green);
  $im3->addtag(name=>'gif_left', value=>35);
  $im3->addtag(name=>'gif_top', value=>45);
  # don't set comment for $im3
  ok(Imager->write_multi({ file=> $test_file}, $im1, $im2, $im3),
     "write test file for single page reads");
  
  my $res = Imager->new;
  # check we get the first image
  ok($res->read(file=>$test_file), "read default (first) page");
  is(i_img_diff($im1->{IMG}, $res->{IMG}), 0, "compare against first");
  # check tags
  is($res->tags(name=>'gif_left'), 10, "gif_left");
  is($res->tags(name=>'gif_top'), 15, "gif_top");
  is($res->tags(name=>'gif_comment'), 'First page', "gif_comment");
  
  # get the second image
  ok($res->read(file=>$test_file, page=>1), "read second page")
    or print "# ",$res->errstr, "\n";
  is(i_img_diff($im2->{IMG}, $res->{IMG}), 0, "compare against second");
  # check tags
  is($res->tags(name=>'gif_left'), 30, "gif_left");
  is($res->tags(name=>'gif_top'), 25, "gif_top");
  is($res->tags(name=>'gif_comment'), 'Second page', "gif_comment");
  
  # get the third image
  ok($res->read(file=>$test_file, page=>2), "read third page")
    or print "# ",$res->errstr, "\n";
  is(i_img_diff($im3->{IMG}, $res->{IMG}), 0, "compare against third");
  is($res->tags(name=>'gif_left'), 35, "gif_left");
  is($res->tags(name=>'gif_top'), 45, "gif_top");
  is($res->tags(name=>'gif_comment'), undef, 'gif_comment undef');
  
  # try to read a fourth page
    ok(!$res->read(file=>$test_file, page=>3), "fail reading fourth page");
  cmp_ok($res->errstr, "=~", 'page 3 not found',
	 "check error message");
}
SKIP:
{
  skip("gif_loop not supported on giflib before 4.1", 6) 
    unless $gifver >= 4.1;
  # testing writing the loop extension
  my $im1 = Imager->new(xsize => 100, ysize => 100);
  $im1->box(filled => 1, color => '#FF0000');
  my $im2 = Imager->new(xsize => 100, ysize => 100);
  $im2->box(filled => 1, color => '#00FF00');
  ok(Imager->write_multi({
			  gif_loop => 5, 
			  gif_delay => 50, 
			  file => 'testout/t105loop.gif'
			 }, $im1, $im2),
     "write with loop extension");
  
  my @im = Imager->read_multi(file => 'testout/t105loop.gif');
  is(@im, 2, "read loop images back");
  is($im[0]->tags(name => 'gif_loop'), 5, "first loop read back");
  is($im[1]->tags(name => 'gif_loop'), 5, "second loop read back");
  is($im[0]->tags(name => 'gif_delay'), 50, "first delay read back");
  is($im[1]->tags(name => 'gif_delay'), 50, "second delay read back");
}
SKIP:
{ # check graphic control extension and ns loop tags are read correctly
  print "# check GCE and netscape loop extension tag values\n";
  my @im = Imager->read_multi(file => 'testimg/screen3.gif');
  is(@im, 2, "read 2 images from screen3.gif")
    or skip("Could not load testimg/screen3.gif:".Imager->errstr, 11);
  is($im[0]->tags(name => 'gif_delay'),          50, "0 - gif_delay");
  is($im[0]->tags(name => 'gif_disposal'),        2, "0 - gif_disposal");
  is($im[0]->tags(name => 'gif_trans_index'), undef, "0 - gif_trans_index");
  is($im[0]->tags(name => 'gif_user_input'),      0, "0 - gif_user_input");
  is($im[0]->tags(name => 'gif_loop'),            0, "0 - gif_loop");
  is($im[1]->tags(name => 'gif_delay'),          50, "1 - gif_delay");
  is($im[1]->tags(name => 'gif_disposal'),        2, "1 - gif_disposal");
  is($im[1]->tags(name => 'gif_trans_index'),     7, "1 - gif_trans_index");
  is($im[1]->tags(name => 'gif_trans_color'), 'color(255,255,255,0)',
     "1 - gif_trans_index");
  is($im[1]->tags(name => 'gif_user_input'),      0, "1 - gif_user_input");
  is($im[1]->tags(name => 'gif_loop'),            0, "1 - gif_loop");
}

{
  # manually modified from a small gif, this had the palette
  # size changed to half the size, leaving an index out of range
  my $im = Imager->new;
  ok($im->read(file => 'testimg/badindex.gif', type => 'gif'), 
     "read bad index gif")
    or print "# ", $im->errstr, "\n";
  my @indexes = $im->getscanline('y' => 0, type => 'index');
  is_deeply(\@indexes, [ 0..4 ], "check for correct indexes");
  is($im->colorcount, 5, "check the palette was adjusted");
  is_color3($im->getpixel('y' => 0, x => 4), 0, 0, 0, 
	    "check it was black added");
  is($im->tags(name => 'gif_colormap_size'), 4, 'color map size tag');
}

{
  ok(grep($_ eq 'gif', Imager->read_types), "check gif in read types");
  ok(grep($_ eq 'gif', Imager->write_types), "check gif in write types");
}

{
  # check screen tags handled correctly note the screen size
  # supplied is larger than the box covered by the images
  my $im1 = Imager->new(xsize => 10, ysize => 8);
  $im1->settag(name => 'gif_top', value => 4);
  $im1->settag(name => 'gif_screen_width', value => 18);
  $im1->settag(name => 'gif_screen_height', value => 16);
  my $im2 = Imager->new(xsize => 7, ysize => 10);
  $im2->settag(name => 'gif_left', value => 3);
  my @im = ( $im1, $im2 );
  
  my $data;
  ok(Imager->write_multi({ data => \$data, type => 'gif' }, @im),
     "write with screen settings")
    or print "# ", Imager->errstr, "\n";
  my @result = Imager->read_multi(data => $data);
  is(@result, 2, "got 2 images back");
  is($result[0]->tags(name => 'gif_screen_width'), 18,
     "check result screen width");
  is($result[0]->tags(name => 'gif_screen_height'), 16,
     "check result screen height");
  is($result[0]->tags(name => 'gif_left'), 0,
     "check first gif_left");
  is($result[0]->tags(name => 'gif_top'), 4,
     "check first gif_top");
  is($result[1]->tags(name => 'gif_left'), 3,
     "check second gif_left");
  is($result[1]->tags(name => 'gif_top'), 0,
     "check second gif_top");
}

{ # test colors array returns colors
  my $data;
  my $im = test_image();
  my @colors;
  ok($im->write(data => \$data, 
		colors => \@colors, 
		make_colors => 'webmap', 
		translate => 'closest',
		gifquant => 'gen',
		type => 'gif'),
     "write using webmap to check color table");
  is(@colors, 216, "should be 216 colors in the webmap");
  is_color3($colors[0], 0, 0, 0, "first should be 000000");
  is_color3($colors[1], 0, 0, 0x33, "second should be 000033");
  is_color3($colors[8], 0, 0x33, 0x66, "9th should be 003366");
}

{ # a zero length extension could make read_/read_multi crash
  my ($im) = Imager->read_multi(file => "testimg/zerocomm.gif");
  ok($im, "read image with zero-length extension");
}


{ # check close failures are handled correctly
  my $im = test_image_mono();
  my $fail_close = sub {
    Imager::i_push_error(0, "synthetic close failure");
    return 0;
  };
  ok(!$im->write(type => "gif", callback => sub { 1 },
		 closecb => $fail_close),
     "check failing close fails");
    like($im->errstr, qr/synthetic close failure/,
	 "check error message");
}


sub test_readgif_cb {
  my ($size) = @_;

  open FH, "<testimg/scale.gif" or die "Cannot open testimg/scale.gif";
  binmode FH;
  my $io = Imager::io_new_cb
    (
     undef,
     sub { my $tmp; read(FH, $tmp, $size) and $tmp },
     undef,
     undef
     );
  my $img = Imager::File::GIF::i_readgif_wiol($io);
  close FH; 
  return $img;
}

# tests for reading bad gif files
sub read_failure {
  my ($filename) = @_;

  open FH, "< $filename"
    or die "Cannot open $filename: $!";
  binmode FH;
  my $io = Imager::io_new_fd(fileno(FH));
  my ($result, $map) = Imager::File::GIF::i_readgif_wiol($io);
  ok(!$result, "attempt to read invalid image $filename ".Imager::_error_as_msg());
  close FH;
}

sub _clear_tags {
  my (@imgs) = @_;

  for my $img (@imgs) {
    $img->deltag(code=>0);
  }
}

sub _add_tags {
  my ($img, %tags) = @_;

  for my $key (keys %tags) {
    Imager::i_tags_add($img, $key, 0, $tags{$key}, 0);
  }
}

sub ext_test {
  my ($testnum, $code, $count, $name) = @_;

  $count ||= 1;
  $name ||= "gif$testnum";

  # build our code
  my $script = "testout/$name.pl";
  if (open SCRIPT, "> $script") {
    print SCRIPT <<'PROLOG';
#!perl -w
if (lc $^O eq 'mswin32') {
  # avoid the dialog box that window's pops up on a GPF
  # if you want to debug this stuff, I suggest you comment out the 
  # following
  eval {
    require Win32API::File;
    Win32API::File::SetErrorMode( Win32API::File::SEM_NOGPFAULTERRORBOX());
  };
}
PROLOG

    print SCRIPT $code;
    close SCRIPT;

    my $perl = $^X;
    $perl = qq/"$perl"/ if $perl =~ / /;

    print "# script: $script\n";
    my $cmd = "$perl -Mblib $script";
    print "# command: $cmd\n";

    my $ok = 1;
    my @out = `$cmd`; # should work on DOS and Win32
    my $found = 0;
    for (@out) {
      if (/^not ok\s+(?:\d+\s*)?#(.*)/ || /^not ok/) {
        my $msg = $1 || '';
        ok(0, $msg);
	$ok = 0;
	++$found;
      }
      elsif (/^ok\s+(?:\d+\s*)?#(.*)/ || /^ok/) {
        my $msg = $1 || '';
        ok(1, $msg);
	++$found;
      }
    }
    unless ($count == $found) {
      print "# didn't see enough ok/not ok\n";
      $ok = 0;
    }
    return $ok;
  }
  else {
    return skip("could not create test script $script: $!");
    return 0;
  }
}
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)