Imager/GIF/t/t10gif.t
#!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;
}
}