#!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; }