Imager/SGI/t/10read.t
#!perl -w
use strict;
use Imager;
use Imager::Test qw(is_image is_color3);
use Test::More tests => 103;
-d 'testout' or mkdir 'testout', 0777;
Imager::init_log('testout/10read.log', 2);
{
my $im_verb = Imager->new;
ok($im_verb->read(file => 'testimg/verb.rgb'), "read verbatim")
or print "# ", $im_verb->errstr, "\n";
is($im_verb->getchannels, 3, "check channels");
is($im_verb->getwidth, 20, "check width");
is($im_verb->getheight, 20, "check height");
is_color3($im_verb->getpixel(x => 0, 'y' => 0), 255, 0, 0, "check 0,0");
is_color3($im_verb->getpixel(x => 1, 'y' => 2), 255, 255, 0, "check 0,2");
is_color3($im_verb->getpixel(x => 2, 'y' => 4), 0, 255, 255, "check 2,5");
is($im_verb->tags(name => 'i_format'), 'sgi', "check i_format tag");
is($im_verb->tags(name => 'sgi_rle'), 0, "check sgi_rgb");
is($im_verb->tags(name => 'sgi_pixmin'), 0, "check pixmin");
is($im_verb->tags(name => 'sgi_pixmax'), 255, "check pixmax");
is($im_verb->tags(name => 'sgi_bpc'), 1, "check bpc");
is($im_verb->tags(name => 'i_comment'), 'test image',
"check name string");
my $im_rle = Imager->new;
ok($im_rle->read(file => 'testimg/rle.rgb'), "read rle")
or print "# ", $im_rle->errstr, "\n";
is($im_rle->tags(name => 'sgi_rle'), 1, "check sgi_rgb");
my $im_rleagr = Imager->new;
ok($im_rleagr->read(file => 'testimg/rleagr.rgb'), "read rleagr")
or print "# ", $im_rleagr->errstr, "\n";
my $im6 = Imager->new;
ok($im6->read(file => 'testimg/verb6.rgb'), "read verbatim 6-bit")
or print "# ", $im6->errstr, "\n";
is($im6->tags(name => 'sgi_pixmax'), 63, "check pixmax");
is_image($im_verb, $im_rle, "compare verbatim to rle");
is_image($im_verb, $im_rleagr, "compare verbatim to rleagr");
is_image($im_verb, $im6, "compare verbatim to verb 6-bit");
my $im_verb12 = Imager->new;
ok($im_verb12->read(file => 'testimg/verb12.rgb'), "read verbatim 12")
or print "# ", $im_verb12->errstr, "\n";
is($im_verb12->bits, 16, "check bits on verb12");
is($im_verb12->tags(name => 'sgi_pixmax'), 4095, "check pixmax");
my $im_verb16 = Imager->new;
ok($im_verb16->read(file => 'testimg/verb16.rgb'), "read verbatim 16")
or print "# ", $im_verb16->errstr, "\n";
is($im_verb16->bits, 16, "check bits on verb16");
is($im_verb16->tags(name => 'sgi_pixmax'), 65535, "check pixmax");
is_image($im_verb, $im_verb12, "compare verbatim to verb12");
is_image($im_verb, $im_verb16, "compare verbatim to verb16");
my $im_rle6 = Imager->new;
ok($im_rle6->read(file => 'testimg/rle6.rgb'), "read rle 6 bit");
is($im_rle6->tags(name => 'sgi_pixmax'), 63, 'check pixmax');
is_image($im_verb, $im_rle6, 'compare verbatim to rle6');
my $im_rle12 = Imager->new;
ok($im_rle12->read(file => 'testimg/rle12.rgb'), 'read rle 12 bit')
or print "# ", $im_rle12->errstr, "\n";
is($im_rle12->tags(name => 'sgi_pixmax'), 4095, 'check pixmax');
is_image($im_verb, $im_rle12, 'compare verbatim to rle12');
my $im_rle16 = Imager->new;
ok($im_rle16->read(file => 'testimg/rle16.rgb'), 'read rle 16 bit')
or print "# ", $im_rle16->errstr, "\n";
is($im_rle16->tags(name => 'sgi_pixmax'), 65535, 'check pixmax');
is($im_rle16->tags(name => 'sgi_bpc'), 2, "check bpc");
is_image($im_verb, $im_rle16, 'compare verbatim to rle16');
}
{
# short read tests, each is source file, limit, match, description
my @tests =
(
[
'verb.rgb', 100,
'SGI image: could not read header', 'header',
],
[
'verb.rgb', 512,
'SGI image: cannot read image data',
'verbatim image data'
],
[
'rle.rgb', 512,
'SGI image: short read reading RLE start table',
'rle start table'
],
[
'rle.rgb', 752,
'SGI image: short read reading RLE length table',
'rle length table'
],
[
'rle.rgb', 0x510,
"SGI image: cannot read RLE data",
'read rle data'
],
[
'rle.rgb', 0x50E,
"SGI image: cannot seek to RLE data",
'seek rle data'
],
[
'verb16.rgb', 512,
'SGI image: cannot read image data',
'read image data (16-bit)'
],
[
'rle16.rgb', 512,
'SGI image: short read reading RLE start table',
'rle start table (16-bit)',
],
[
'rle16.rgb', 0x42f,
'SGI image: cannot seek to RLE data',
'seek RLE data (16-bit)'
],
[
'rle16.rgb', 0x64A,
'SGI image: cannot read RLE data',
'read rle image data (16-bit)'
],
);
for my $test (@tests) {
my ($src, $size, $match, $desc) = @$test;
open SRC, "< testimg/$src"
or die "Cannot open testimg/$src: $!";
binmode SRC;
my $data;
read(SRC, $data, $size) == $size
or die "Could not read $size bytes from $src";
close SRC;
my $im = Imager->new;
ok(!$im->read(data => $data, type => 'sgi'),
"read: $desc");
is($im->errstr, $match, "error match: $desc");
}
}
{
# each entry is: source file, patches, expected error, description
my @tests =
(
[
'verb.rgb',
{ 0 => '00 00' },
'SGI image: invalid magic number',
'bad magic',
],
[
'verb.rgb',
{ 104 => '00 00 00 01' },
'SGI image: invalid value for colormap (1)',
'invalid colormap field',
],
[
'verb.rgb',
{ 3 => '03' },
'SGI image: invalid value for BPC (3)',
'invalid bpc field',
],
[
'verb.rgb',
{ 2 => '03' },
'SGI image: invalid storage type field',
'invalid storage type field',
],
[
'verb.rgb',
{ 4 => '00 04' },
'SGI image: invalid dimension field',
'invalid dimension field',
],
[
'rle.rgb',
{ 0x2f0 => '00 00 00 2b' },
'SGI image: ridiculous RLE line length 43',
'invalid rle length',
],
[
'rle.rgb',
{ 0x3E0 => '95' },
'SGI image: literal run overflows scanline',
'literal run overflow scanline',
],
[
'rle.rgb',
{ 0x3E0 => '87' },
'SGI image: literal run consumes more data than available',
'literal run consuming too much data',
],
[
'rle.rgb',
{ 0x3E0 => '15' },
'SGI image: RLE run overflows scanline',
'RLE run overflows scanline',
],
[
'rle.rgb',
{ 0x3E0 => '81 FF 12 00 01' },
'SGI image: RLE run has no data for pixel',
'RLE run has no data for pixel',
],
[
'rle.rgb',
{ 0x3E0 => '81 FF 12 00' },
'SGI image: incomplete RLE scanline',
'incomplete RLE scanline',
],
[
'rle.rgb',
{ 0x2F0 => '00 00 00 06' },
'SGI image: unused RLE data',
'unused RLE data',
],
[
'verb.rgb',
{ 0x0c => '00 00 00 FF 00 00 00 00' },
'SGI image: invalid pixmin >= pixmax',
'bad pixmin/pixmax',
],
[
'rle16.rgb',
{ 0x2f0 => '00 00 00 0B' },
'SGI image: invalid RLE length value for BPC=2',
'bad RLE table (length) (bpc=2)'
],
[
'rle16.rgb',
{ 0x2f0 => '00 00 00 53' },
'SGI image: ridiculous RLE line length 83',
'way too big RLE line length (16-bit)'
],
[
'rle16.rgb',
{ 0x426 => '00 95' },
'SGI image: literal run overflows scanline',
'literal overflow scanline (bpc=2)'
],
[
'rle16.rgb',
{ 0x426 => '00 93' },
'SGI image: literal run consumes more data than available',
'literal overflow data (bpc=2)'
],
[
'rle16.rgb',
{ 0x3EA => '00 15' },
'SGI image: RLE run overflows scanline',
'rle overflow scanline (bpc=2)'
],
[
'rle16.rgb',
{ 0x3EA => '00 15' },
'SGI image: RLE run overflows scanline',
'rle overflow scanline (bpc=2)'
],
[
'rle16.rgb',
{ 0x3EA => '00 83 ff ff ff ff ff ff 00 01' },
'SGI image: RLE run has no data for pixel',
'rle code no argument (bpc=2)'
],
[
'rle16.rgb',
{ 0x3EA => '00 14 ff ff 00 00' },
'SGI image: unused RLE data',
'unused RLE data (bpc=2)'
],
[
'rle16.rgb',
{ 0x3EA => '00 12 ff ff' },
'SGI image: incomplete RLE scanline',
'incomplete rle scanline (bpc=2)'
],
);
# invalid file tests - take our original files and patch them a
# little to make them invalid
my $test_index = 0;
for my $test (@tests) {
my ($filename, $patches, $error, $desc) = @$test;
my $data = load_patched_file("testimg/$filename", $patches);
my $im = Imager->new;
ok(!$im->read(data => $data, type=>'sgi'),
"$test_index - $desc:should fail to read");
is($im->errstr, $error, "$test_index - $desc:check message");
++$test_index;
}
}
sub load_patched_file {
my ($filename, $patches) = @_;
open IMDATA, "< $filename"
or die "Cannot open $filename: $!";
binmode IMDATA;
my $data = do { local $/; <IMDATA> };
for my $offset (keys %$patches) {
(my $hdata = $patches->{$offset}) =~ tr/ //d;
my $pdata = pack("H*", $hdata);
substr($data, $offset, length $pdata) = $pdata;
}
return $data;
}