Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

303 lines (258 sloc) 9.669 kb
#!perl -w
use Imager qw(:all);
use strict;
use Test::More tests=>68;
use Imager::Test qw(is_color4 is_image test_image);
-d "testout" or mkdir "testout";
init_log("testout/t108tga.log",1);
my $img = create_test_image();
my $base_diff = 0;
write_test($img, "testout/t108_24bit.tga", 0, 0, "");
write_test($img, "testout/t108_24bit_rle.tga", 0, 1, "");
write_test($img, "testout/t108_15bit.tga", 1, 1, "");
write_test($img, "testout/t108_15bit_rle.tga", 1, 1, "");
# 'webmap' is noticably faster than the default
my $im8 = Imager::i_img_to_pal($img, { make_colors=>'webmap',
translate=>'errdiff'});
write_test($im8, "testout/t108_8bit.tga", 0, 0, "");
write_test($im8, "testout/t108_8bit_rle.tga", 0, 1, "");
write_test($im8, "testout/t108_8_15bit.tga", 1, 0, "");
write_test($im8, "testout/t108_8_15bit_rle.tga", 1, 1, "");
# use a fixed palette so we get reproducible results for the compressed
# version
my @bit4 = map { NC($_) }
qw(605844 966600 0148b2 00f800 bf0a33 5e009e
2ead1b 0000f8 004b01 fd0000 0e1695 000002);
my @bit1 = (NC(0, 0, 0), NC(176, 160, 144));
my $im4 = Imager::i_img_to_pal($img, { colors=>\@bit4,
make_colors=>'none' });
my $im1 = Imager::i_img_to_pal($img, { colors=>\@bit1,
make_colors=>'none',
translate=>'errdiff' });
write_test($im4, "testout/t108_4bit.tga", 0, 1, "");
write_test($im1, "testout/t108_1bit.tga", 0, 1, "This is a comment!");
read_test("testout/t108_24bit.tga", $img);
read_test("testout/t108_8bit.tga", $im8);
read_test("testout/t108_4bit.tga", $im4);
read_test("testout/t108_1bit.tga", $im1);
# the following might have slight differences
$base_diff = i_img_diff($img, $im8) * 2;
print "# base difference $base_diff\n";
my $imoo = Imager->new;
ok($imoo->read(file=>'testout/t108_24bit.tga'),
"OO read image")
or print "# ",$imoo->errstr,"\n";
ok($imoo->write(file=>'testout/t108_oo.tga'),
"OO write image")
or print "# ",$imoo->errstr,"\n";
my ($type) = $imoo->tags(name=>'i_format');
is($type, 'tga', "check i_format tag");
# in 0.44 and earlier, reading an image with an idstring of 128 or more
# bytes would result in an allocation error, if the platform char type
# was signed
$imoo = Imager->new;
ok($imoo->read(file=>'testimg/longid.tga'), "read long id image");
my ($id) = $imoo->tags(name=>'tga_idstring');
is($id, "X" x 128, "check tga_idstring tag");
my ($bitspp) = $imoo->tags(name=>'tga_bitspp');
is($bitspp, 24, "check tga_bitspp tag");
my ($compressed) = $imoo->tags(name=>'compressed');
is($compressed, 1, "check compressed tag");
{ # check file limits are checked
my $limit_file = "testout/t108_24bit.tga";
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);
}
{ # Issue # 18397
# the issue is for 4 channel images to jpeg, but 2 channel images have
# a similar problem on tga
my $im = Imager->new(xsize=>100, ysize=>100, channels => 2);
my $data;
ok(!$im->write(data => \$data, type=>'tga'),
"check failure of writing a 2 channel image");
is($im->errstr, "Cannot store 2 channel image in targa format",
"check the error message");
}
{
ok(grep($_ eq 'tga', Imager->read_types), "check tga in read types");
ok(grep($_ eq 'tga', Imager->write_types), "check tga in write types");
}
{ # Issue #32926
# a sample image was read as all transparent
# it had bitsperpixel = 16 and atribute channel set to 1, so it
# should have an alpha channel.
# So we'll do what the gimp does and treat a zero value as opaque.
my $im = Imager->new;
ok($im->read(file => 'testimg/alpha16.tga'),
"read 16-bit/pixel alpha image");
my $c1 = $im->getpixel('x' => 0, 'y' => 0);
is_color4($c1, 0, 0, 0, 0, "check transparent pixel");
my $c2 = $im->getpixel('x' => 19, 'y' => 0);
is_color4($c2, 255, 0, 0, 255, "check opaque pixel");
# since this has an effect on writing too, write,it, read it, check it
my $data;
ok($im->write(data => \$data, type => 'tga', wierdpack => 1),
"write 16-bit/pixel w/alpha");
my $im2 = Imager->new;
ok($im2->read(data => $data), "read it back");
is_image($im, $im2, "check they match");
}
{ # prior to the types re-work we treated the tga xsize/ysize as
# signed short, which is wrong
SKIP:
{
my $im = Imager->new(xsize => 40960, ysize => 1);
my $data;
ok($im->write(data => \$data, type => "tga"),
"write a wide (but not too wide) image out");
my $im2 = Imager->new(data => $data);
ok($im2, "read it back in")
or skip("Couldn't read the wide image", 2);
is($im2->getwidth, 40960, "make sure the width survived the trip");
is($im2->getheight, 1, "make sure the height survived the trip");
}
SKIP:
{
my $im = Imager->new(xsize => 1, ysize => 40960);
my $data;
ok($im->write(data => \$data, type => "tga"),
"write a tall (but not too tall) image out");
my $im2 = Imager->new(data => $data);
ok($im2, "read it back in")
or skip("Couldn't read the tall image", 2);
is($im2->getwidth, 1, "make sure the width survived the trip");
is($im2->getheight, 40960, "make sure the height survived the trip");
}
}
{
# TGA files are limited to 0xFFFF x 0xFFFF pixels
my $max_dim = 0xFFFF;
{
my $im = Imager->new(xsize => 1+$max_dim, ysize => 1);
my $data = '';
ok(!$im->write(data => \$data, type => "tga"),
"fail to write too wide an image");
is($im->errstr, "image too large for TGA",
"check error message");
}
SKIP:
{
my $im = Imager->new(xsize => $max_dim, ysize => 1);
$im->box(fill => { hatch => "check4x4" });
my $data = '';
ok($im->write(data => \$data, type => "tga"),
"write image at width limit")
or print "# ", $im->errstr, "\n";
my $im2 = Imager->new(data => $data, ftype => "tga");
ok($im2, "read it ok")
or skip("cannot load the wide image", 1);
is($im->getwidth, $max_dim, "check width");
is($im->getheight, 1, "check height");
}
{
my $im = Imager->new(xsize => 1, ysize => 1+$max_dim);
my $data = '';
ok(!$im->write(data => \$data, type => "tga"),
"fail to write too tall an image");
is($im->errstr, "image too large for TGA",
"check error message");
}
SKIP:
{
my $im = Imager->new(xsize => 1, ysize => $max_dim);
$im->box(fill => { hatch => "check2x2" });
my $data = '';
ok($im->write(data => \$data, type => "tga"),
"write image at width limit");
my $im2 = Imager->new(data => $data, ftype => "tga");
ok($im2, "read it ok")
or skip("cannot load the wide image", 1);
is($im->getwidth, 1, "check width");
is($im->getheight, $max_dim, "check height");
}
}
{ # check close failures are handled correctly
my $im = test_image();
my $fail_close = sub {
Imager::i_push_error(0, "synthetic close failure");
return 0;
};
ok(!$im->write(type => "tga", callback => sub { 1 },
closecb => $fail_close),
"check failing close fails");
like($im->errstr, qr/synthetic close failure/,
"check error message");
}
sub write_test {
my ($im, $filename, $wierdpack, $compress, $idstring) = @_;
local *FH;
if (open FH, "> $filename") {
binmode FH;
my $IO = Imager::io_new_fd(fileno(FH));
ok(Imager::i_writetga_wiol($im, $IO, $wierdpack, $compress, $idstring),
"write $filename")
or print "# ",Imager->_error_as_msg(),"\n";
undef $IO;
close FH;
} else {
fail("write $filename: open failed: $!");
}
}
sub read_test {
my ($filename, $im, %tags) = @_;
local *FH;
if (open FH, "< $filename") {
binmode FH;
my $IO = Imager::io_new_fd(fileno(FH));
my $im_read = Imager::i_readtga_wiol($IO,-1);
if ($im_read) {
my $diff = i_img_diff($im, $im_read);
cmp_ok($diff, '<=', $base_diff,
"check read image vs original");
} else {
fail("read $filename ".Imager->_error_as_msg());
}
undef $IO;
close FH;
} else {
fail("read $filename, open failure: $!");
}
}
sub create_test_image {
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]);
return $img;
}
Jump to Line
Something went wrong with that request. Please try again.