[imager.git] / t / t105gif.t

#!perl -w
use strict;
$|=1;
print "1..45\n";
use Imager qw(:all);

sub ok ($$$);

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

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=Imager::ImgRaw::new(150,150,3);

i_box_filled($img,70,25,130,125,$green);
i_box_filled($img,20,25,80,125,$blue);
i_arc($img,75,75,30,0,361,$red);
i_conv($img,[0.1, 0.2, 0.4, 0.2, 0.1]);

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);

if (!i_has_format("gif")) {
  for (1..45) { print "ok $_ # skip no gif support\n"; }
} else {
    open(FH,">testout/t105.gif") || die "Cannot open testout/t105.gif\n";
    binmode(FH);
    i_writegifmc($img,fileno(FH),6) || die "Cannot write testout/t105.gif\n";
    close(FH);

    print "ok 1\n";

    open(FH,"testout/t105.gif") || die "Cannot open testout/t105.gif\n";
    binmode(FH);
    $img=i_readgif(fileno(FH)) || die "Cannot read testout/t105.gif\n";
    close(FH);

    print "ok 2\n";

    open(FH,"testout/t105.gif") || die "Cannot open testout/t105.gif\n";
    binmode(FH);
    ($img, my $palette)=i_readgif(fileno(FH));
    $img || die "Cannot read testout/t105.gif\n";
    close(FH);

    $palette=''; # just to skip a warning.

    print "ok 3\n";

    # 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 ($imgi) = i_readgif(fileno(FH));
    $imgi || die "Cannot read testimg/scalei.gif";
    close FH;
    print "ok 4\n";
    open FH, "<testimg/scale.gif" or die "Cannot open testimg/scale.gif";
    binmode FH;
    my ($imgni) = i_readgif(fileno(FH));
    $imgni or die "Cannot read testimg/scale.gif";
    close FH;
    print "ok 5\n";

    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;
    if ($datai eq $datani) {
      print "ok 6\n";
    }
    else {
      print "not ok 6\n";
    }

    my $gifver = Imager::i_giflib_version();
    if ($gifver >= 4.0) {
      # 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;
      # no callback version in giflib3, so don't overwrite a good image
      my $img2 = i_readgif_callback(sub { my $tmp; read(FH, $tmp, $_[0]) and $tmp });
      close FH; 
      print $img ? "ok 7\n" : "not ok 7\n";

      print test_readgif_cb(1) ? "ok 8\n" : "not ok 8\n";
      print test_readgif_cb(512) ? "ok 9\n" : "not ok 9\n";
      print test_readgif_cb(1024) ? "ok 10\n" : "not ok 10\n";
    }
    else {
      for (7..10) {
	print "ok $_ # skip giflib3 doesn't support callbacks\n";
      }
    }
    open FH, ">testout/t105_mc.gif" or die "Cannot open testout/t105_mc.gif";
    binmode FH;
    i_writegifmc($img, fileno(FH), 7) or print "not ";
    close(FH);
    print "ok 11\n";

    # new writegif_gen
    # test webmap, custom errdiff map
    # (looks fairly awful)
    open FH, ">testout/t105_gen.gif" or die $!;
    binmode FH;
    i_writegif_gen(fileno(FH), { make_colors=>'webmap',
	                         translate=>'errdiff',
				 errdiff=>'custom',
				 errdiff_width=>2,
				 errdiff_height=>2,
				 errdiff_map=>[0, 1, 1, 0]}, $img)
      or print "not ";
    close FH;
    print "ok 12\n";    

    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;
    i_writegif_gen(fileno(FH), { 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)
      or die "Cannot write anim gif";
    close FH;
    print "ok 13\n";

    my $can_write_callback = 0;
    if ($gifver >= 4.0) {
      ++$can_write_callback;
      unless (fork) {
	# this can SIGSEGV with some versions of giflib
	open FH, ">testout/t105_anim_cb.gif" or die $!;
	i_writegif_callback(sub { 
			      print FH $_[0] 
			    },
			    -1, # max buffering
			    { make_colors=>'webmap',	
			      translate=>'closest',
			      gif_delays=>\@gif_delays,
			      gif_disposal=>\@gif_disposal,
			      #transp=>'ordered',
			      tr_orddith=>'dot8'}, @imgs)
	  or die "Cannot write anim gif";
	close FH;
	print "ok 14\n";
	exit;
      }
      if (wait > 0 && $?) {
        $can_write_callback = 0;
	print "not ok 14 # you probably need to patch giflib\n";
	print <<EOS;
#--- egif_lib.c	2000/12/11 07:33:12	1.1
#+++ egif_lib.c	2000/12/11 07:33:48
#@@ -167,6 +167,12 @@
#         _GifError = E_GIF_ERR_NOT_ENOUGH_MEM;
#         return NULL;
#     }
#+    if ((Private->HashTable = _InitHashTable()) == NULL) {
#+        free(GifFile);
#+        free(Private);
#+        _GifError = E_GIF_ERR_NOT_ENOUGH_MEM;
#+        return NULL;
#+    }
#
#     GifFile->Private = (VoidPtr) Private;
#     Private->FileHandle = 0;
EOS
      }
    }
    else {
      print "ok 14 # skip giflib3 doesn't support callbacks\n";
    }
    @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;
    if (i_writegif_gen(fileno(FH), { #make_colors=>'webmap',
                                     translate=>'giflib',
                                   }, @imgs)) {
      print "ok 15\n";
    }
    else {
      print "not ok 15 # ", 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;
    if (i_writegif_gen(fileno(FH), { translate=>'giflib'}, $img1)) {
      print "ok 16 # single colour write regression\n";
    } else {
      print "not ok 16 # single colour write regression\n";
    }
    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;
    i_writegif_gen(fileno(FH), { make_colors=>'addi',
				 translate=>'closest',
				 transp=>'ordered',
			       }, $timg) or print "not ";
    print "ok 17\n";
    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/t105gif.t"
      or die "Cannot open this script!: $!";
    binmode FH;
    my $im2 = i_readgif(fileno(FH));
    if ($im2) {
      # this should have failed
      print "not ok 18 # giflib think script if a GIF file\n";
    }
    else {
      print "ok 18 # ",Imager::_error_as_msg(),"\n";
    }
    close FH;

    # try to save no images :)
    open FH, ">testout/t105_none.gif"
      or die "Cannot open testout/t105_none.gif: $!";
    binmode FH;
    if (i_writegif_gen(fileno(FH), {}, "hello")) {
      print "not ok 19 # shouldn't be able to save strings\n";
    }
    else {
      print "ok 19 # ",Imager::_error_as_msg(),"\n";
    }

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

    # image has a local colour map
    open FH, "< testimg/loccmap.gif"
      or die "Cannot open testimg/loccmap.gif: $!";
    binmode FH;
    if (i_readgif(fileno(FH))) {
      print "ok 23\n";
    }
    else {
      print "not ok 23 # failed to read 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 $ims = i_readgif(fileno(FH));
    if ($ims) {
      print "ok 24\n";
    }
    else {
      print "not ok 24 # ",Imager::_error_as_msg(),"\n";
    }
    close FH;
    open FH, "< testimg/expected.gif"
      or die "Cannot open testimg/expected.gif: $!";
    binmode FH;
    my $ime = i_readgif(fileno(FH));
    close FH;
    if ($ime) {
      print "ok 25\n";
    }
    else {
      print "not ok 25 # ",Imager::_error_as_msg(),"\n";
    }
    if ($ims && $ime) {
      if (i_img_diff($ime, $ims)) {
	print "not ok 26 # mismatch ",i_img_diff($ime, $ims),"\n";
	# save the bad one
	open FH, "> testout/t105_screen2.gif"
	  or die "Cannot create testout/t105_screen.gif: $!";
	binmode FH;
	i_writegifmc($ims, fileno(FH), 7)
	  or print "# could not save t105_screen.gif\n";
	close FH;
      }
      else {
	print "ok 26\n";
      }
    }
    else {
      print "ok 26 # skipped\n";
    }

    # test reading a multi-image file into multiple images
    open FH, "< testimg/screen2.gif"
      or die "Cannot open testimg/screen2.gif: $!";
    binmode FH;
    @imgs = Imager::i_readgif_multi(fileno(FH))
      or print "not ";
    print "ok 27\n";
    close FH;
    @imgs == 2 or print "not ";
    print "ok 28\n";
    for my $img (@imgs) {
      unless (Imager::i_img_type($img) == 1) {
        print "not ";
        last;
      }
    }
    print "ok 29\n";
    Imager::i_colorcount($imgs[0]) == 4 or print "not ";
    print "ok 30\n";
    Imager::i_colorcount($imgs[1]) == 2 or print "not ";
    print "ok 31\n";
    Imager::i_tags_find($imgs[0], "gif_left", 0) or print "not ";
    print "ok 32\n";
    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;
    $left && $left->[1] == 3 or print "not ";
    print "ok 33\n";

    # screen3.gif was saved with 
    open FH, "< testimg/screen3.gif"
      or die "Cannot open testimg/screen3.gif: $!";
    binmode FH;
    @imgs = Imager::i_readgif_multi(fileno(FH))
      or print "not ";
    print "ok 34\n";
    close FH;
    eval {
      require 'Data/Dumper.pm';
      Data::Dumper->import();
    };
    unless ($@) {
      # build a big map of all tags for all images
      @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(35, Imager::i_img_type($imgs[0]) == 1, "imgs[0] not paletted");
    ok(36, Imager::i_img_type($imgs[1]) == 1, "imgs[1] not paletted");

    # see how we go saving it
    open FH, ">testout/t105_pal.gif" or die $!;
    binmode FH;
    ok(37, i_writegif_gen(fileno(FH), { make_colors=>'addi',
                                        translate=>'closest',
                                        transp=>'ordered',
                                      }, @imgs), "write from paletted");
    close FH;
    
    # make sure nothing bad happened
    open FH, "< testout/t105_pal.gif" or die $!;
    binmode FH;
    ok(38, (my @imgs2 = Imager::i_readgif_multi(fileno(FH))) == 2,
       "re-reading saved paletted images");
    ok(39, i_img_diff($imgs[0], $imgs2[0]) == 0, "imgs[0] mismatch");
    ok(40, 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(41, $ooim->read(file=>"testout/t105.gif"), "read into object");
      ok(42, $ooim->write(file=>"testout/t105_warn.gif", interlace=>1),
        "save from object");
      ok(43, grep(/Obsolete .* interlace .* gif_interlace/, @warns),
        "check for warning");
      init(warn_obsolete=>0);
      @warns = ();
      ok(44, $ooim->write(file=>"testout/t105_warn.gif", interlace=>1),
        "save from object");
      ok(45, !grep(/Obsolete .* interlace .* gif_interlace/, @warns),
        "check for warning");
    }
}

sub ok ($$$) {
  my ($num, $ok, $comment) = @_;

  if ($ok) {
    print "ok $num\n";
  }
  else {
    print "not ok $num # line ",(caller)[2],": $comment \n";
  }
}

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

  open FH, "<testimg/scale.gif" or die "Cannot open testimg/scale.gif";
  binmode FH;
  my $img = i_readgif_callback(sub { my $tmp; read(FH, $tmp, $size) and $tmp });
  close FH; 
  return $img;
}

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

  open FH, "< $filename"
    or die "Cannot open $filename: $!";
  binmode FH;
  my ($result, $map) = i_readgif(fileno(FH));
  if ($result) {
    print "not ok $testnum # this is an invalid file, we succeeded\n";
  }
  else {
    print "ok $testnum # ",Imager::_error_as_msg(),"\n";
  }
  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);
  }
}
Commit	Line	Data
bf9dd17c TC	1	#!perl -w
bf9dd17c TC	2	use strict;
d75cf895	3	$\|=1;
97c4effc	4	print "1..45\n";
efdb8061 TC	5	use Imager qw(:all);
efdb8061 TC	6
bf9dd17c TC	7	sub ok ($$$);
bf9dd17c TC	8
efdb8061 TC	9	init_log("testout/t105gif.log",1);
efdb8061 TC	10
bf9dd17c TC	11	my $green=i_color_new(0,255,0,255);
	12	my $blue=i_color_new(0,0,255,255);
	13	my $red=i_color_new(255,0,0,255);
efdb8061	14
bf9dd17c	15	my $img=Imager::ImgRaw::new(150,150,3);
efdb8061 TC	16
	17	i_box_filled($img,70,25,130,125,$green);
	18	i_box_filled($img,20,25,80,125,$blue);
	19	i_arc($img,75,75,30,0,361,$red);
	20	i_conv($img,[0.1, 0.2, 0.4, 0.2, 0.1]);
	21
	22	my $timg = Imager::ImgRaw::new(20, 20, 4);
	23	my $trans = i_color_new(255, 0, 0, 127);
	24	i_box_filled($timg, 0, 0, 20, 20, $green);
	25	i_box_filled($timg, 2, 2, 18, 18, $trans);
	26
	27	if (!i_has_format("gif")) {
97c4effc	28	for (1..45) { print "ok $_ # skip no gif support\n"; }
efdb8061 TC	29	} else {
	30	open(FH,">testout/t105.gif") \|\| die "Cannot open testout/t105.gif\n";
	31	binmode(FH);
97c4effc	32	i_writegifmc($img,fileno(FH),6) \|\| die "Cannot write testout/t105.gif\n";
efdb8061 TC	33	close(FH);
	34
	35	print "ok 1\n";
	36
	37	open(FH,"testout/t105.gif") \|\| die "Cannot open testout/t105.gif\n";
	38	binmode(FH);
	39	$img=i_readgif(fileno(FH)) \|\| die "Cannot read testout/t105.gif\n";
	40	close(FH);
	41
	42	print "ok 2\n";
	43
	44	open(FH,"testout/t105.gif") \|\| die "Cannot open testout/t105.gif\n";
	45	binmode(FH);
bf9dd17c	46	($img, my $palette)=i_readgif(fileno(FH));
efdb8061 TC	47	$img \|\| die "Cannot read testout/t105.gif\n";
	48	close(FH);
	49
	50	$palette=''; # just to skip a warning.
	51
	52	print "ok 3\n";
067d6bdc	53
efdb8061 TC	54	# check that reading interlaced/non-interlaced versions of
	55	# the same GIF produce the same image
	56	# I could replace this with code that used Imager's built-in
	57	# image comparison code, but I know this code revealed the error
	58	open(FH, "<testimg/scalei.gif") \|\| die "Cannot open testimg/scalei.gif";
	59	binmode FH;
bf9dd17c	60	my ($imgi) = i_readgif(fileno(FH));
efdb8061 TC	61	$imgi \|\| die "Cannot read testimg/scalei.gif";
	62	close FH;
	63	print "ok 4\n";
	64	open FH, "<testimg/scale.gif" or die "Cannot open testimg/scale.gif";
	65	binmode FH;
bf9dd17c	66	my ($imgni) = i_readgif(fileno(FH));
efdb8061 TC	67	$imgni or die "Cannot read testimg/scale.gif";
	68	close FH;
	69	print "ok 5\n";
	70
	71	open FH, ">testout/t105i.ppm" or die "Cannot create testout/t105i.ppm";
	72	binmode FH;
bf9dd17c	73	my $IO = Imager::io_new_fd( fileno(FH) );
067d6bdc	74	i_writeppm_wiol($imgi, $IO) or die "Cannot write testout/t105i.ppm";
efdb8061 TC	75	close FH;
efdb8061 TC	76
067d6bdc	77
efdb8061 TC	78	open FH, ">testout/t105ni.ppm" or die "Cannot create testout/t105ni.ppm";
efdb8061 TC	79	binmode FH;
067d6bdc AMH	80	$IO = Imager::io_new_fd( fileno(FH) );
067d6bdc AMH	81	i_writeppm_wiol($imgni, $IO) or die "Cannot write testout/t105ni.ppm";
efdb8061 TC	82	close FH;
	83
	84	# compare them
	85	open FH, "<testout/t105i.ppm" or die "Cannot open testout/t105i.ppm";
bf9dd17c	86	my $datai = do { local $/; <FH> };
efdb8061	87	close FH;
067d6bdc	88
efdb8061	89	open FH, "<testout/t105ni.ppm" or die "Cannot open testout/t105ni.ppm";
bf9dd17c	90	my $datani = do { local $/; <FH> };
efdb8061 TC	91	close FH;
	92	if ($datai eq $datani) {
	93	print "ok 6\n";
	94	}
	95	else {
	96	print "not ok 6\n";
	97	}
	98
2529ff7d	99	my $gifver = Imager::i_giflib_version();
efdb8061 TC	100	if ($gifver >= 4.0) {
	101	# reading with a callback
	102	# various sizes to make sure the buffering works
	103	# requested size
	104	open FH, "<testimg/scale.gif" or die "Cannot open testimg/scale.gif";
	105	binmode FH;
	106	# no callback version in giflib3, so don't overwrite a good image
	107	my $img2 = i_readgif_callback(sub { my $tmp; read(FH, $tmp, $_[0]) and $tmp });
	108	close FH;
	109	print $img ? "ok 7\n" : "not ok 7\n";
067d6bdc	110
efdb8061 TC	111	print test_readgif_cb(1) ? "ok 8\n" : "not ok 8\n";
	112	print test_readgif_cb(512) ? "ok 9\n" : "not ok 9\n";
	113	print test_readgif_cb(1024) ? "ok 10\n" : "not ok 10\n";
	114	}
	115	else {
48412c20 AMH	116	for (7..10) {
	117	print "ok $_ # skip giflib3 doesn't support callbacks\n";
	118	}
efdb8061 TC	119	}
	120	open FH, ">testout/t105_mc.gif" or die "Cannot open testout/t105_mc.gif";
	121	binmode FH;
	122	i_writegifmc($img, fileno(FH), 7) or print "not ";
	123	close(FH);
	124	print "ok 11\n";
	125
	126	# new writegif_gen
	127	# test webmap, custom errdiff map
	128	# (looks fairly awful)
	129	open FH, ">testout/t105_gen.gif" or die $!;
	130	binmode FH;
	131	i_writegif_gen(fileno(FH), { make_colors=>'webmap',
	132	translate=>'errdiff',
	133	errdiff=>'custom',
	134	errdiff_width=>2,
	135	errdiff_height=>2,
	136	errdiff_map=>[0, 1, 1, 0]}, $img)
	137	or print "not ";
	138	close FH;
	139	print "ok 12\n";
	140
	141	print "# the following tests are fairly slow\n";
	142
	143	# test animation, mc_addi, error diffusion, ordered transparency
	144	my @imgs;
	145	my $sortagreen = i_color_new(0, 255, 0, 63);
	146	for my $i (0..4) {
	147	my $im = Imager::ImgRaw::new(200, 200, 4);
97c4effc	148	_add_tags($im, gif_delay=>50, gif_disposal=>2);
efdb8061 TC	149	for my $j (0..$i-1) {
	150	my $fill = i_color_new(0, 128, 0, 255 * ($i-$j)/$i);
	151	i_box_filled($im, 0, $j40, 199, $j40+40, $fill);
	152	}
	153	i_box_filled($im, 0, $i*40, 199, 199, $blue);
	154	push(@imgs, $im);
	155	}
	156	my @gif_delays = (50) x 5;
	157	my @gif_disposal = (2) x 5;
	158	open FH, ">testout/t105_anim.gif" or die $!;
	159	binmode FH;
	160	i_writegif_gen(fileno(FH), { make_colors=>'addi',
	161	translate=>'closest',
	162	gif_delays=>\@gif_delays,
	163	gif_disposal=>\@gif_disposal,
46a04ceb TC	164	gif_positions=> [ map [ $_10, $_10 ], 0..4 ],
46a04ceb TC	165	gif_user_input=>[ 1, 0, 1, 0, 1 ],
efdb8061 TC	166	transp=>'ordered',
	167	tr_orddith=>'dot8'}, @imgs)
	168	or die "Cannot write anim gif";
	169	close FH;
	170	print "ok 13\n";
	171
10461f9a	172	my $can_write_callback = 0;
efdb8061	173	if ($gifver >= 4.0) {
10461f9a	174	++$can_write_callback;
efdb8061 TC	175	unless (fork) {
	176	# this can SIGSEGV with some versions of giflib
	177	open FH, ">testout/t105_anim_cb.gif" or die $!;
	178	i_writegif_callback(sub {
	179	print FH $_[0]
	180	},
	181	-1, # max buffering
	182	{ make_colors=>'webmap',
	183	translate=>'closest',
	184	gif_delays=>\@gif_delays,
	185	gif_disposal=>\@gif_disposal,
	186	#transp=>'ordered',
	187	tr_orddith=>'dot8'}, @imgs)
	188	or die "Cannot write anim gif";
	189	close FH;
	190	print "ok 14\n";
	191	exit;
	192	}
	193	if (wait > 0 && $?) {
10461f9a	194	$can_write_callback = 0;
efdb8061 TC	195	print "not ok 14 # you probably need to patch giflib\n";
	196	print <<EOS;
	197	#--- egif_lib.c 2000/12/11 07:33:12 1.1
	198	#+++ egif_lib.c 2000/12/11 07:33:48
	199	#@@ -167,6 +167,12 @@
	200	# _GifError = E_GIF_ERR_NOT_ENOUGH_MEM;
	201	# return NULL;
	202	# }
	203	#+ if ((Private->HashTable = _InitHashTable()) == NULL) {
	204	#+ free(GifFile);
	205	#+ free(Private);
	206	#+ _GifError = E_GIF_ERR_NOT_ENOUGH_MEM;
	207	#+ return NULL;
	208	#+ }
	209	#
	210	# GifFile->Private = (VoidPtr) Private;
	211	# Private->FileHandle = 0;
	212	EOS
	213	}
	214	}
	215	else {
	216	print "ok 14 # skip giflib3 doesn't support callbacks\n";
	217	}
	218	@imgs = ();
97c4effc	219	my $c = i_color_new(0,0,0,0);
bf9dd17c	220	for my $g (0..3) {
efdb8061	221	my $im = Imager::ImgRaw::new(200, 200, 3);
97c4effc	222	_add_tags($im, gif_local_map=>1, gif_delay=>150, gif_loop=>10);
efdb8061 TC	223	for my $x (0 .. 39) {
efdb8061 TC	224	for my $y (0 .. 39) {
97c4effc	225	$c->set($x * 6, $y * 6, 32*$g+$x+$y, 255);
efdb8061 TC	226	i_box_filled($im, $x5, $y5, $x5+4, $y5+4, $c);
	227	}
	228	}
	229	push(@imgs, $im);
	230	}
	231	# test giflib with multiple palettes
	232	# (it was meant to test the NS loop extension too, but that's broken)
	233	# this looks better with make_colors=>'addi', translate=>'errdiff'
	234	# this test aims to overload the palette for each image, so the
	235	# output looks moderately horrible
	236	open FH, ">testout/t105_mult_pall.gif" or die "Cannot create file: $!";
	237	binmode FH;
97c4effc	238	if (i_writegif_gen(fileno(FH), { #make_colors=>'webmap',
faa9b3e7	239	translate=>'giflib',
faa9b3e7 TC	240	}, @imgs)) {
	241	print "ok 15\n";
	242	}
	243	else {
	244	print "not ok 15 # ", join(":", map $_->[1], Imager::i_errors()),"\n";
	245	}
efdb8061	246	close FH;
efdb8061 TC	247
	248	# regression test: giflib doesn't like 1 colour images
	249	my $img1 = Imager::ImgRaw::new(100, 100, 3);
	250	i_box_filled($img1, 0, 0, 100, 100, $red);
	251	open FH, ">testout/t105_onecol.gif" or die $!;
	252	binmode FH;
	253	if (i_writegif_gen(fileno(FH), { translate=>'giflib'}, $img1)) {
	254	print "ok 16 # single colour write regression\n";
	255	} else {
	256	print "not ok 16 # single colour write regression\n";
	257	}
	258	close FH;
	259
	260	# transparency test
	261	# previously it was harder do write transparent images
	262	# tests the improvements
	263	my $timg = Imager::ImgRaw::new(20, 20, 4);
	264	my $trans = i_color_new(255, 0, 0, 127);
	265	i_box_filled($timg, 0, 0, 20, 20, $green);
	266	i_box_filled($timg, 2, 2, 18, 18, $trans);
	267	open FH, ">testout/t105_trans.gif" or die $!;
	268	binmode FH;
	269	i_writegif_gen(fileno(FH), { make_colors=>'addi',
	270	translate=>'closest',
	271	transp=>'ordered',
	272	}, $timg) or print "not ";
	273	print "ok 17\n";
	274	close FH;
	275
	276	# some error handling tests
	277	# open a file handle for read and try to save to it
	278	# is this idea portable?
	279	# whether or not it is, giflib segfaults on this <sigh>
	280	#open FH, "<testout/t105_trans.gif" or die $!;
	281	#binmode FH; # habit, I suppose
	282	#if (i_writegif_gen(fileno(FH), {}, $timg)) {
	283	# # this is meant to _fail_
	284	# print "not ok 18 # writing to read-only should fail";
	285	#}
	286	#else {
	287	# print "ok 18 # ",Imager::_error_as_msg(),"\n";
	288	#}
	289	#close FH;
	290
	291	# try to read a file of the wrong format - the script will do
	292	open FH, "<t/t105gif.t"
	293	or die "Cannot open this script!: $!";
	294	binmode FH;
	295	my $im2 = i_readgif(fileno(FH));
	296	if ($im2) {
	297	# this should have failed
	298	print "not ok 18 # giflib think script if a GIF file\n";
	299	}
	300	else {
	301	print "ok 18 # ",Imager::_error_as_msg(),"\n";
	302	}
2529ff7d	303	close FH;
efdb8061 TC	304
	305	# try to save no images :)
	306	open FH, ">testout/t105_none.gif"
	307	or die "Cannot open testout/t105_none.gif: $!";
	308	binmode FH;
	309	if (i_writegif_gen(fileno(FH), {}, "hello")) {
	310	print "not ok 19 # shouldn't be able to save strings\n";
	311	}
	312	else {
	313	print "ok 19 # ",Imager::_error_as_msg(),"\n";
	314	}
efdb8061	315
e6172a17 TC	316	# try to read a truncated gif (no image descriptors)
	317	read_failure('testimg/trimgdesc.gif', 20);
	318	# file truncated just after the image descriptor tag
	319	read_failure('testimg/trmiddesc.gif', 21);
	320	# image has no colour map
	321	read_failure('testimg/nocmap.gif', 22);
efdb8061	322
e6172a17 TC	323	# image has a local colour map
	324	open FH, "< testimg/loccmap.gif"
	325	or die "Cannot open testimg/loccmap.gif: $!";
	326	binmode FH;
	327	if (i_readgif(fileno(FH))) {
	328	print "ok 23\n";
	329	}
	330	else {
	331	print "not ok 23 # failed to read image with only a local colour map";
	332	}
cf267b86	333	close FH;
43a881d3 TC	334
	335	# image has global and local colour maps
	336	open FH, "< testimg/screen2.gif"
	337	or die "Cannot open testimg/screen2.gif: $!";
	338	binmode FH;
	339	my $ims = i_readgif(fileno(FH));
	340	if ($ims) {
	341	print "ok 24\n";
	342	}
	343	else {
	344	print "not ok 24 # ",Imager::_error_as_msg(),"\n";
	345	}
	346	close FH;
	347	open FH, "< testimg/expected.gif"
	348	or die "Cannot open testimg/expected.gif: $!";
	349	binmode FH;
	350	my $ime = i_readgif(fileno(FH));
	351	close FH;
	352	if ($ime) {
	353	print "ok 25\n";
	354	}
	355	else {
	356	print "not ok 25 # ",Imager::_error_as_msg(),"\n";
	357	}
	358	if ($ims && $ime) {
	359	if (i_img_diff($ime, $ims)) {
	360	print "not ok 26 # mismatch ",i_img_diff($ime, $ims),"\n";
	361	# save the bad one
	362	open FH, "> testout/t105_screen2.gif"
	363	or die "Cannot create testout/t105_screen.gif: $!";
	364	binmode FH;
	365	i_writegifmc($ims, fileno(FH), 7)
	366	or print "# could not save t105_screen.gif\n";
	367	close FH;
	368	}
	369	else {
	370	print "ok 26\n";
	371	}
	372	}
	373	else {
	374	print "ok 26 # skipped\n";
	375	}
faa9b3e7 TC	376
	377	# test reading a multi-image file into multiple images
	378	open FH, "< testimg/screen2.gif"
	379	or die "Cannot open testimg/screen2.gif: $!";
	380	binmode FH;
	381	@imgs = Imager::i_readgif_multi(fileno(FH))
	382	or print "not ";
	383	print "ok 27\n";
	384	close FH;
	385	@imgs == 2 or print "not ";
	386	print "ok 28\n";
	387	for my $img (@imgs) {
	388	unless (Imager::i_img_type($img) == 1) {
	389	print "not ";
	390	last;
	391	}
	392	}
	393	print "ok 29\n";
	394	Imager::i_colorcount($imgs[0]) == 4 or print "not ";
	395	print "ok 30\n";
	396	Imager::i_colorcount($imgs[1]) == 2 or print "not ";
	397	print "ok 31\n";
	398	Imager::i_tags_find($imgs[0], "gif_left", 0) or print "not ";
	399	print "ok 32\n";
	400	my @tags = map {[ Imager::i_tags_get($imgs[1], $_) ]} 0..Imager::i_tags_count($imgs[1])-1;
	401	my ($left) = grep $_->[0] eq 'gif_left', @tags;
	402	$left && $left->[1] == 3 or print "not ";
	403	print "ok 33\n";
bf9dd17c	404
faa9b3e7 TC	405	# screen3.gif was saved with
	406	open FH, "< testimg/screen3.gif"
	407	or die "Cannot open testimg/screen3.gif: $!";
	408	binmode FH;
	409	@imgs = Imager::i_readgif_multi(fileno(FH))
	410	or print "not ";
	411	print "ok 34\n";
bf9dd17c	412	close FH;
9d540150 TC	413	eval {
	414	require 'Data/Dumper.pm';
	415	Data::Dumper->import();
	416	};
	417	unless ($@) {
	418	# build a big map of all tags for all images
	419	@tags =
	420	map {
	421	my $im = $_;
	422	[
	423	map { join ",", map { defined() ? $_ : "undef" } Imager::i_tags_get($im, $_) }
	424	0..Imager::i_tags_count($_)-1
	425	]
	426	} @imgs;
	427	my $dump = Dumper(\@tags);
	428	$dump =~ s/^/# /mg;
	429	print "# tags from gif\n", $dump;
	430	}
bf9dd17c TC	431
	432	# at this point @imgs should contain only paletted images
	433	ok(35, Imager::i_img_type($imgs[0]) == 1, "imgs[0] not paletted");
	434	ok(36, Imager::i_img_type($imgs[1]) == 1, "imgs[1] not paletted");
	435
	436	# see how we go saving it
	437	open FH, ">testout/t105_pal.gif" or die $!;
	438	binmode FH;
	439	ok(37, i_writegif_gen(fileno(FH), { make_colors=>'addi',
	440	translate=>'closest',
	441	transp=>'ordered',
	442	}, @imgs), "write from paletted");
	443	close FH;
	444
	445	# make sure nothing bad happened
	446	open FH, "< testout/t105_pal.gif" or die $!;
	447	binmode FH;
	448	ok(38, (my @imgs2 = Imager::i_readgif_multi(fileno(FH))) == 2,
	449	"re-reading saved paletted images");
	450	ok(39, i_img_diff($imgs[0], $imgs2[0]) == 0, "imgs[0] mismatch");
	451	ok(40, i_img_diff($imgs[1], $imgs2[1]) == 0, "imgs[1] mismatch");
97c4effc TC	452
	453	# test that the OO interface warns when we supply old options
	454	{
	455	my @warns;
	456	local $SIG{__WARN__} = sub { push(@warns, "@_") };
	457
	458	my $ooim = Imager->new;
	459	ok(41, $ooim->read(file=>"testout/t105.gif"), "read into object");
	460	ok(42, $ooim->write(file=>"testout/t105_warn.gif", interlace=>1),
	461	"save from object");
	462	ok(43, grep(/Obsolete .* interlace .* gif_interlace/, @warns),
	463	"check for warning");
	464	init(warn_obsolete=>0);
	465	@warns = ();
	466	ok(44, $ooim->write(file=>"testout/t105_warn.gif", interlace=>1),
	467	"save from object");
	468	ok(45, !grep(/Obsolete .* interlace .* gif_interlace/, @warns),
	469	"check for warning");
	470	}
bf9dd17c TC	471	}
	472
	473	sub ok ($$$) {
	474	my ($num, $ok, $comment) = @_;
	475
	476	if ($ok) {
	477	print "ok $num\n";
	478	}
	479	else {
	480	print "not ok $num # line ",(caller)[2],": $comment \n";
	481	}
e6172a17	482	}
efdb8061 TC	483
	484	sub test_readgif_cb {
	485	my ($size) = @_;
	486
	487	open FH, "<testimg/scale.gif" or die "Cannot open testimg/scale.gif";
	488	binmode FH;
	489	my $img = i_readgif_callback(sub { my $tmp; read(FH, $tmp, $size) and $tmp });
	490	close FH;
	491	return $img;
	492	}
e6172a17 TC	493
	494	# tests for reading bad gif files
	495	sub read_failure {
	496	my ($filename, $testnum) = @_;
	497
	498	open FH, "< $filename"
	499	or die "Cannot open $filename: $!";
	500	binmode FH;
	501	my ($result, $map) = i_readgif(fileno(FH));
	502	if ($result) {
	503	print "not ok $testnum # this is an invalid file, we succeeded\n";
	504	}
	505	else {
	506	print "ok $testnum # ",Imager::_error_as_msg(),"\n";
	507	}
	508	close FH;
	509	}
	510
97c4effc TC	511	sub _clear_tags {
	512	my (@imgs) = @_;
	513
	514	for my $img (@imgs) {
	515	$img->deltag(code=>0);
	516	}
	517	}
	518
	519	sub _add_tags {
	520	my ($img, %tags) = @_;
	521
	522	for my $key (keys %tags) {
	523	Imager::i_tags_add($img, $key, 0, $tags{$key}, 0);
	524	}
	525	}