#!perl -w
-print "1..4\n";
-use Imager qw(:all);
use strict;
-init_log("testout/t107bmp.log",1);
+use Test::More tests => 215;
+use Imager qw(:all);
+use Imager::Test qw(test_image_raw is_image is_color3 test_image);
+
+-d "testout" or mkdir "testout";
+Imager->open_log(log => "testout/t107bmp.log");
+
+my @files;
+my $debug_writes = 0;
+
+my $base_diff = 0;
+# if you change this make sure you generate new compressed versions
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);
-my $cmpimg=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 $img = test_image_raw();
-write_test(1, $img, "testout/t107_24bit.bmp");
+Imager::i_tags_add($img, 'i_xres', 0, '300', 0);
+Imager::i_tags_add($img, 'i_yres', 0, undef, 300);
+write_test($img, "testout/t107_24bit.bmp");
+push @files, "t107_24bit.bmp";
# 'webmap' is noticably faster than the default
my $im8 = Imager::i_img_to_pal($img, { make_colors=>'webmap',
translate=>'errdiff'});
-write_test(2, $im8, "testout/t107_8bit.bmp");
-my $im4 = Imager::i_img_to_pal($img, { max_colors=>16 });
-write_test(3, $im4, "testout/t107_4bit.bmp");
+write_test($im8, "testout/t107_8bit.bmp");
+push @files, "t107_8bit.bmp";
+# use a fixed palette so we get reproducible results for the compressed
+# version
+my @pal16 = map { NC($_) }
+ qw(605844 966600 0148b2 00f800 bf0a33 5e009e
+ 2ead1b 0000f8 004b01 fd0000 0e1695 000002);
+my $im4 = Imager::i_img_to_pal($img, { colors=>\@pal16, make_colors=>'none' });
+write_test($im4, "testout/t107_4bit.bmp");
+push @files, "t107_4bit.bmp";
my $im1 = Imager::i_img_to_pal($img, { colors=>[ NC(0, 0, 0), NC(176, 160, 144) ],
make_colors=>'none', translate=>'errdiff' });
-write_test(4, $im1, "testout/t107_1bit.bmp");
+write_test($im1, "testout/t107_1bit.bmp");
+push @files, "t107_1bit.bmp";
+my $bi_rgb = 0;
+my $bi_rle8 = 1;
+my $bi_rle4 = 2;
+my $bi_bitfields = 3;
+read_test("testout/t107_24bit.bmp", $img,
+ bmp_compression=>0, bmp_bit_count => 24);
+read_test("testout/t107_8bit.bmp", $im8,
+ bmp_compression=>0, bmp_bit_count => 8);
+read_test("testout/t107_4bit.bmp", $im4,
+ bmp_compression=>0, bmp_bit_count => 4);
+read_test("testout/t107_1bit.bmp", $im1, bmp_compression=>0,
+ bmp_bit_count=>1);
+# the following might have slight differences
+$base_diff = i_img_diff($img, $im8) * 2;
+print "# base difference $base_diff\n";
+read_test("testimg/comp4.bmp", $im4,
+ bmp_compression=>$bi_rle4, bmp_bit_count => 4);
+read_test("testimg/comp8.bmp", $im8,
+ bmp_compression=>$bi_rle8, bmp_bit_count => 8);
+
+my $imoo = Imager->new;
+# read via OO
+ok($imoo->read(file=>'testout/t107_24bit.bmp'), "read via OO")
+ or print "# ",$imoo->errstr,"\n";
+
+ok($imoo->write(file=>'testout/t107_oo.bmp'), "write via OO")
+ or print "# ",$imoo->errstr,"\n";
+push @files, "t107_oo.bmp";
+
+# various invalid format tests
+# we have so many different test images to try to detect all the possible
+# failure paths in the code, adding these did detect real problems
+print "# catch various types of invalid bmp files\n";
+my @tests =
+ (
+ # entries in each array ref are:
+ # - basename of an invalid BMP file
+ # - error message that should be produced
+ # - description of what is being tested
+ # - possible flag to indicate testing only on 32-bit machines
+ [ 'badplanes.bmp', 'not a BMP file', "invalid planes value" ],
+ [ 'badbits.bmp', 'unknown bit count for BMP file (5)',
+ 'should fail to read invalid bits' ],
+
+ # 1-bit/pixel BMPs
+ [ 'badused1.bmp', 'out of range colors used (3)',
+ 'out of range palette size (1-bit)' ],
+ [ 'badcomp1.bmp', 'unknown 1-bit BMP compression (1)',
+ 'invalid compression value (1-bit)' ],
+ [ 'bad1wid0.bmp', 'file size limit - image width of 0 is not positive',
+ 'width 0 (1-bit)' ],
+ [ 'bad4oflow.bmp',
+ 'file size limit - integer overflow calculating storage',
+ 'overflow integers on 32-bit machines (1-bit)', '32bitonly' ],
+ [ 'short1.bmp', 'failed reading 1-bit bmp data',
+ 'short 1-bit' ],
+
+ # 4-bit/pixel BMPs
+ [ 'badused4a.bmp', 'out of range colors used (272)',
+ 'should fail to read invalid pal size (272) (4-bit)' ],
+ [ 'badused4b.bmp', 'out of range colors used (17)',
+ 'should fail to read invalid pal size (17) (4-bit)' ],
+ [ 'badcomp4.bmp', 'unknown 4-bit BMP compression (1)',
+ 'invalid compression value (4-bit)' ],
+ [ 'short4.bmp', 'failed reading 4-bit bmp data',
+ 'short uncompressed 4-bit' ],
+ [ 'short4rle.bmp', 'missing data during decompression',
+ 'short compressed 4-bit' ],
+ [ 'bad4wid0.bmp', 'file size limit - image width of 0 is not positive',
+ 'width 0 (4-bit)' ],
+ [ 'bad4widbig.bmp', 'file size limit - image width of -2147483628 is not positive',
+ 'width big (4-bit)' ],
+ [ 'bad4oflow.bmp', 'file size limit - integer overflow calculating storage',
+ 'overflow integers on 32-bit machines (4-bit)', '32bitonly' ],
+
+ # 8-bit/pixel BMPs
+ [ 'bad8useda.bmp', 'out of range colors used (257)',
+ 'should fail to read invalid pal size (8-bit)' ],
+ [ 'bad8comp.bmp', 'unknown 8-bit BMP compression (2)',
+ 'invalid compression value (8-bit)' ],
+ [ 'short8.bmp', 'failed reading 8-bit bmp data',
+ 'short uncompressed 8-bit' ],
+ [ 'short8rle.bmp', 'missing data during decompression',
+ 'short compressed 8-bit' ],
+ [ 'bad8wid0.bmp', 'file size limit - image width of 0 is not positive',
+ 'width 0 (8-bit)' ],
+ [ 'bad8oflow.bmp', 'file size limit - integer overflow calculating storage',
+ 'overflow integers on 32-bit machines (8-bit)', '32bitonly' ],
+
+ # 24-bit/pixel BMPs
+ [ 'short24.bmp', 'failed reading image data',
+ 'short 24-bit' ],
+ [ 'bad24wid0.bmp', 'file size limit - image width of 0 is not positive',
+ 'width 0 (24-bit)' ],
+ [ 'bad24oflow.bmp', 'file size limit - integer overflow calculating storage',
+ 'overflow integers on 32-bit machines (24-bit)', '32bitonly' ],
+ [ 'bad24comp.bmp', 'unknown 24-bit BMP compression (4)',
+ 'bad compression (24-bit)' ],
+ );
+use Config;
+my $ptrsize = $Config{ptrsize};
+for my $test (@tests) {
+ my ($file, $error, $comment, $bit32only) = @$test;
+ SKIP:
+ {
+ skip("only tested on 32-bit machines", 2)
+ if $bit32only && $ptrsize != 4;
+ ok(!$imoo->read(file=>"testimg/$file"), $comment);
+ print "# ", $imoo->errstr, "\n";
+ is($imoo->errstr, $error, "check error message");
+ }
+}
+
+# previously we didn't seek to the offbits position before reading
+# the image data, check we handle it correctly
+# in each case the first is an original image with a given number of
+# bits and the second is the same file with data inserted before the
+# image bits and the offset modified to suit
+my @comp =
+ (
+ [ 'winrgb2.bmp', 'winrgb2off.bmp', 1 ],
+ [ 'winrgb4.bmp', 'winrgb4off.bmp', 4 ],
+ [ 'winrgb8.bmp', 'winrgb8off.bmp', 8 ],
+ [ 'winrgb24.bmp', 'winrgb24off.bmp', 24 ],
+ );
+
+for my $comp (@comp) {
+ my ($base_file, $off_file, $bits) = @$comp;
+
+ my $base_im = Imager->new;
+ my $got_base =
+ ok($base_im->read(file=>"testimg/$base_file"),
+ "read original")
+ or print "# ",$base_im->errstr,"\n";
+ my $off_im = Imager->new;
+ my $got_off =
+ ok($off_im->read(file=>"testimg/$off_file"),
+ "read offset file")
+ or print "# ",$off_im->errstr,"\n";
+ SKIP:
+ {
+ skip("missed one file", 1)
+ unless $got_base && $got_off;
+ is(i_img_diff($base_im->{IMG}, $off_im->{IMG}), 0,
+ "compare base and offset image ($bits bits)");
+ }
+}
+
+{ # check file limits are checked
+ my $limit_file = "testout/t107_24bit.bmp";
+ 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);
+}
+
+{ # various short read failure tests, each entry has:
+ # source filename, size, expected error
+ # these have been selected based on code coverage, to check each
+ # failure path is checked, where practical
+ my @tests =
+ (
+ [
+ "file truncated inside header",
+ "winrgb2.bmp",
+ 20, "file too short to be a BMP file"
+ ],
+ [
+ "1-bit, truncated inside palette",
+ "winrgb2.bmp",
+ 56, "reading BMP palette"
+ ],
+ [
+ "1-bit, truncated in offset region",
+ "winrgb2off.bmp", 64, "failed skipping to image data offset"
+ ],
+ [
+ "1-bit, truncated in image data",
+ "winrgb2.bmp", 96, "failed reading 1-bit bmp data"
+ ],
+ [
+ "4-bit, truncated inside palette",
+ "winrgb4.bmp",
+ 56, "reading BMP palette"
+ ],
+ [
+ "4-bit, truncated in offset region",
+ "winrgb4off.bmp", 120, "failed skipping to image data offset",
+ ],
+ [
+ "4-bit, truncate in image data",
+ "winrgb4.bmp", 120, "failed reading 4-bit bmp data"
+ ],
+ [
+ "4-bit RLE, truncate in uncompressed data",
+ "comp4.bmp", 0x229, "missing data during decompression"
+ ],
+ [
+ "8-bit, truncated in palette",
+ "winrgb8.bmp", 1060, "reading BMP palette"
+ ],
+ [
+ "8-bit, truncated in offset region",
+ "winrgb8off.bmp", 1080, "failed skipping to image data offset"
+ ],
+ [
+ "8-bit, truncated in image data",
+ "winrgb8.bmp", 1080, "failed reading 8-bit bmp data"
+ ],
+ [
+ "8-bit RLE, truncate in uncompressed data",
+ "comp8.bmp", 0x68C, "missing data during decompression"
+ ],
+ [
+ "24-bit, truncate in offset region",
+ "winrgb24off.bmp", 56, "failed skipping to image data offset",
+ ],
+ [
+ "24-bit, truncate in image data",
+ "winrgb24.bmp", 100, "failed reading image data",
+ ],
+ );
+
+ my $test_index = 0;
+ for my $test (@tests) {
+ my ($desc, $srcfile, $size, $error) = @$test;
+ my $im = Imager->new;
+ open IMDATA, "< testimg/$srcfile"
+ or die "$test_index - $desc: Cannot open testimg/$srcfile: $!";
+ binmode IMDATA;
+ my $data;
+ read(IMDATA, $data, $size) == $size
+ or die "$test_index - $desc: Could not read $size data from $srcfile";
+ close IMDATA;
+ ok(!$im->read(data => $data, type =>'bmp'),
+ "$test_index - $desc: Should fail to read");
+ is($im->errstr, $error, "$test_index - $desc: check message");
+ ++$test_index;
+ }
+}
+
+{ # various short read success tests, each entry has:
+ # source filename, size, expected tags
+ print "# allow_incomplete tests\n";
+ my @tests =
+ (
+ [
+ "1-bit",
+ "winrgb2.bmp", 96,
+ {
+ bmp_compression_name => 'BI_RGB',
+ bmp_compression => 0,
+ bmp_used_colors => 2,
+ i_lines_read => 8,
+ },
+ ],
+ [
+ "4-bit",
+ "winrgb4.bmp", 250,
+ {
+ bmp_compression_name => 'BI_RGB',
+ bmp_compression => 0,
+ bmp_used_colors => 16,
+ i_lines_read => 11,
+ },
+ ],
+ [
+ "4-bit RLE - uncompressed seq",
+ "comp4.bmp", 0x229,
+ {
+ bmp_compression_name => 'BI_RLE4',
+ bmp_compression => 2,
+ bmp_used_colors => 16,
+ i_lines_read => 44,
+ },
+ ],
+ [
+ "4-bit RLE - start seq",
+ "comp4.bmp", 0x97,
+ {
+ bmp_compression_name => 'BI_RLE4',
+ bmp_compression => 2,
+ bmp_used_colors => 16,
+ i_lines_read => 8,
+ },
+ ],
+ [
+ "8-bit",
+ "winrgb8.bmp", 1250,
+ {
+ bmp_compression_name => 'BI_RGB',
+ bmp_compression => 0,
+ bmp_used_colors => 256,
+ i_lines_read => 8,
+ },
+ ],
+ [
+ "8-bit RLE - uncompressed seq",
+ "comp8.bmp", 0x68C,
+ {
+ bmp_compression_name => 'BI_RLE8',
+ bmp_compression => 1,
+ bmp_used_colors => 256,
+ i_lines_read => 27,
+ },
+ ],
+ [
+ "8-bit RLE - initial seq",
+ "comp8.bmp", 0x487,
+ {
+ bmp_compression_name => 'BI_RLE8',
+ bmp_compression => 1,
+ bmp_used_colors => 256,
+ i_lines_read => 20,
+ },
+ ],
+ [
+ "24-bit",
+ "winrgb24.bmp", 800,
+ {
+ bmp_compression_name => 'BI_RGB',
+ bmp_compression => 0,
+ bmp_used_colors => 0,
+ i_lines_read => 12,
+ },
+ ],
+ );
+
+ my $test_index = 0;
+ for my $test (@tests) {
+ my ($desc, $srcfile, $size, $tags) = @$test;
+ my $im = Imager->new;
+ open IMDATA, "< testimg/$srcfile"
+ or die "$test_index - $desc: Cannot open testimg/$srcfile: $!";
+ binmode IMDATA;
+ my $data;
+ read(IMDATA, $data, $size) == $size
+ or die "$test_index - $desc: Could not read $size data from $srcfile";
+ close IMDATA;
+ ok($im->read(data => $data, type =>'bmp', allow_incomplete => 1),
+ "$test_index - $desc: Should read successfully");
+ # check standard tags are set
+ is($im->tags(name => 'i_format'), 'bmp',
+ "$test_index - $desc: i_format set");
+ is($im->tags(name => 'i_incomplete'), 1,
+ "$test_index - $desc: i_incomplete set");
+ my %check_tags;
+ for my $key (keys %$tags) {
+ $check_tags{$key} = $im->tags(name => $key);
+ }
+ is_deeply(\%check_tags, $tags, "$test_index - $desc: check tags");
+ ++$test_index;
+ }
+}
+
+{ # check handling of reading images with negative height
+ # each entry is:
+ # source file, description
+ print "# check handling of negative height values\n";
+ my @tests =
+ (
+ [ "winrgb2.bmp", "1-bit, uncompressed" ],
+ [ "winrgb4.bmp", "4-bit, uncompressed" ],
+ [ "winrgb8.bmp", "8-bit, uncompressed" ],
+ [ "winrgb24.bmp", "24-bit, uncompressed" ],
+ [ "comp4.bmp", "4-bit, RLE" ],
+ [ "comp8.bmp", "8-bit, RLE" ],
+ );
+ my $test_index = 0;
+ for my $test (@tests) {
+ my ($file, $desc) = @$test;
+ open IMDATA, "< testimg/$file"
+ or die "$test_index - Cannot open $file: $!";
+ binmode IMDATA;
+ my $data = do { local $/; <IMDATA> };
+ close IMDATA;
+ my $im_orig = Imager->new;
+ $im_orig->read(data => $data)
+ or die "Cannot load original $file: ", $im_orig->errstr;
+
+ # now negate the height
+ my $orig_height = unpack("V", substr($data, 0x16, 4));
+ my $neg_height = 0xFFFFFFFF & ~($orig_height - 1);
+ substr($data, 0x16, 4) = pack("V", $neg_height);
+
+ # and read the modified image
+ my $im = Imager->new;
+ ok($im->read(data => $data),
+ "$test_index - $desc: read negated height image")
+ or print "# ", $im->errstr, "\n";
+
+ # flip orig to match what we should get
+ $im_orig->flip(dir => 'v');
+
+ # check it out
+ is_image($im, $im_orig, "$test_index - $desc: check image");
+
+ ++$test_index;
+ }
+}
+
+{ print "# patched data read failure tests\n";
+ # like the "various invalid format" tests, these generate fail
+ # images from other images included with Imager without providing a
+ # full bmp source, saving on dist size and focusing on the changes needed
+ # to cause the failure
+ # each entry is: source file, patches, expected error, description
+
+ my @tests =
+ (
+ # low image data offsets
+ [
+ "winrgb2.bmp",
+ { 10 => "3d 00 00 00" },
+ "image data offset too small (61)",
+ "1-bit, small image offset"
+ ],
+ [
+ "winrgb4.bmp",
+ { 10 => "75 00 00 00" },
+ "image data offset too small (117)",
+ "4-bit, small image offset"
+ ],
+ [
+ "winrgb8.bmp",
+ { 10 => "35 04 00 00" },
+ "image data offset too small (1077)",
+ "8-bit, small image offset"
+ ],
+ [
+ "winrgb24.bmp",
+ { 10 => "35 00 00 00" },
+ "image data offset too small (53)",
+ "24-bit, small image offset"
+ ],
+ # compression issues
+ [
+ "comp8.bmp",
+ { 0x436 => "97" },
+ "invalid data during decompression",
+ "8bit, RLE run beyond edge of image"
+ ],
+ [
+ # caused glibc malloc or valgrind to complain
+ "comp8.bmp",
+ { 0x436 => "94 00 00 03" },
+ "invalid data during decompression",
+ "8bit, literal run beyond edge of image"
+ ],
+ [
+ "comp4.bmp",
+ { 0x76 => "FF bb FF BB" },
+ "invalid data during decompression",
+ "4bit - RLE run beyond edge of image"
+ ],
+ [
+ "comp4.bmp",
+ { 0x76 => "94 bb 00 FF" },
+ "invalid data during decompression",
+ "4bit - literal run beyond edge of image"
+ ],
+ );
+ 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=>'bmp'),
+ "$test_index - $desc:should fail to read");
+ is($im->errstr, $error, "$test_index - $desc:check message");
+ ++$test_index;
+ }
+}
+
+{ # various write failure tests
+ # each entry is:
+ # source, limit, expected error, description
+ my @tests =
+ (
+ [
+ "winrgb2.bmp", 1,
+ "cannot write bmp header: limit reached",
+ "1-bit, writing header"
+ ],
+ [
+ "winrgb4.bmp", 1,
+ "cannot write bmp header: limit reached",
+ "4-bit, writing header"
+ ],
+ [
+ "winrgb8.bmp", 1,
+ "cannot write bmp header: limit reached",
+ "8-bit, writing header"
+ ],
+ [
+ "winrgb24.bmp", 1,
+ "cannot write bmp header: limit reached",
+ "24-bit, writing header"
+ ],
+ [
+ "winrgb2.bmp", 0x38,
+ "cannot write palette entry: limit reached",
+ "1-bit, writing palette"
+ ],
+ [
+ "winrgb4.bmp", 0x38,
+ "cannot write palette entry: limit reached",
+ "4-bit, writing palette"
+ ],
+ [
+ "winrgb8.bmp", 0x38,
+ "cannot write palette entry: limit reached",
+ "8-bit, writing palette"
+ ],
+ [
+ "winrgb2.bmp", 0x40,
+ "writing 1 bit/pixel packed data: limit reached",
+ "1-bit, writing image data"
+ ],
+ [
+ "winrgb4.bmp", 0x80,
+ "writing 4 bit/pixel packed data: limit reached",
+ "4-bit, writing image data"
+ ],
+ [
+ "winrgb8.bmp", 0x440,
+ "writing 8 bit/pixel packed data: limit reached",
+ "8-bit, writing image data"
+ ],
+ [
+ "winrgb24.bmp", 0x39,
+ "writing image data: limit reached",
+ "24-bit, writing image data"
+ ],
+ );
+ print "# write failure tests\n";
+ my $test_index = 0;
+ for my $test (@tests) {
+ my ($file, $limit, $error, $desc) = @$test;
+
+ my $im = Imager->new;
+ $im->read(file => "testimg/$file")
+ or die "Cannot read $file: ", $im->errstr;
+
+ my $io = Imager::io_new_cb(limited_write($limit), undef, undef, undef, 1);
+ $io->set_buffered(0);
+ print "# writing with limit of $limit\n";
+ ok(!$im->write(type => 'bmp', io => $io),
+ "$test_index - $desc: write should fail");
+ is($im->errstr, $error, "$test_index - $desc: check error message");
+
+ ++$test_index;
+ }
+}
+
+{
+ ok(grep($_ eq 'bmp', Imager->read_types), "check bmp in read types");
+ ok(grep($_ eq 'bmp', Imager->write_types), "check bmp in write types");
+}
+
+{
+ # RT #30075
+ # give 4/2 channel images a background color when saving to BMP
+ my $im = Imager->new(xsize=>16, ysize=>16, channels=>4);
+ $im->box(filled => 1, xmin => 8, color => '#FFE0C0');
+ $im->box(filled => 1, color => NC(0, 192, 192, 128),
+ ymin => 8, xmax => 7);
+ ok($im->write(file=>"testout/t107_alpha.bmp", type=>'bmp'),
+ "should succeed writing 4 channel image");
+ push @files, "t107_alpha.bmp";
+ my $imread = Imager->new;
+ ok($imread->read(file => 'testout/t107_alpha.bmp'), "read it back");
+ is_color3($imread->getpixel('x' => 0, 'y' => 0), 0, 0, 0,
+ "check transparent became black");
+ is_color3($imread->getpixel('x' => 8, 'y' => 0), 255, 224, 192,
+ "check color came through");
+ is_color3($imread->getpixel('x' => 0, 'y' => 15), 0, 96, 96,
+ "check translucent came through");
+ my $data;
+ ok($im->write(data => \$data, type => 'bmp', i_background => '#FF0000'),
+ "write with red background");
+ ok($imread->read(data => $data, type => 'bmp'),
+ "read it back");
+ is_color3($imread->getpixel('x' => 0, 'y' => 0), 255, 0, 0,
+ "check transparent became red");
+ is_color3($imread->getpixel('x' => 8, 'y' => 0), 255, 224, 192,
+ "check color came through");
+ is_color3($imread->getpixel('x' => 0, 'y' => 15), 127, 96, 96,
+ "check translucent came through");
+}
+
+{ # RT 41406
+ my $data;
+ my $im = test_image();
+ ok($im->write(data => \$data, type => 'bmp'), "write using OO");
+ my $size = unpack("V", substr($data, 34, 4));
+ is($size, 67800, "check data size");
+}
+
+{ # 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 => "bmp", callback => sub { 1 },
+ closecb => $fail_close),
+ "check failing close fails");
+ like($im->errstr, qr/synthetic close failure/,
+ "check error message");
+}
+
+Imager->close_log;
+
+unless ($ENV{IMAGER_KEEP_FILES}) {
+ unlink map "testout/$_", @files;
+ unlink "testout/t107bmp.log";
+}
sub write_test {
- my ($test_num, $im, $filename) = @_;
+ my ($im, $filename) = @_;
local *FH;
if (open FH, "> $filename") {
binmode FH;
my $IO = Imager::io_new_fd(fileno(FH));
- if (Imager::i_writebmp_wiol($im, $IO)) {
- print "ok $test_num\n";
+ unless (ok(Imager::i_writebmp_wiol($im, $IO), $filename)) {
+ print "# ",Imager->_error_as_msg(),"\n";
+ }
+ undef $IO;
+ close FH;
+ }
+ else {
+ fail("could not open $filename: $!");
+ }
+}
+
+sub read_test {
+ my ($filename, $im, %tags) = @_;
+ local *FH;
+
+ print "# read_test: $filename\n";
+
+ $tags{i_format} = "bmp";
+
+ if (open FH, "< $filename") {
+ binmode FH;
+ my $IO = Imager::io_new_fd(fileno(FH));
+ my $im_read = Imager::i_readbmp_wiol($IO);
+ if ($im_read) {
+ my $diff = i_img_diff($im, $im_read);
+ if ($diff > $base_diff) {
+ fail("image mismatch reading $filename");
+ }
+ else {
+ my $tags_ok = 1;
+ for my $tag (keys %tags) {
+ if (my $index = Imager::i_tags_find($im_read, $tag, 0)) {
+ my ($name, $value) = Imager::i_tags_get($im_read, $index);
+ my $exp_value = $tags{$tag};
+ print "# tag $name = '$value' - expect '$exp_value'\n";
+ if ($exp_value =~ /\d/) {
+ if ($value != $tags{$tag}) {
+ print "# tag $tag value mismatch $tags{$tag} != $value\n";
+ $tags_ok = 0;
+ }
+ }
+ else {
+ if ($value ne $tags{$tag}) {
+ print "# tag $tag value mismatch $tags{$tag} != $value\n";
+ $tags_ok = 0;
+ }
+ }
+ }
+ }
+ ok($tags_ok, "reading $filename");
+ # for my $i (0 .. Imager::i_tags_count($im_read)-1) {
+ # my ($name, $value) = Imager::i_tags_get($im_read, $i);
+ # print "# tag '$name' => '$value'\n";
+ #}
+ }
}
else {
- print "not ok $test_num # ",Imager->_error_as_msg(),"\n";
+ fail("could not read $filename: ".Imager->_error_as_msg());
}
undef $IO;
close FH;
}
else {
- print "not ok $test_num # $!\n";
+ fail("could not open $filename: $!");
+ }
+}
+
+sub limited_write {
+ my ($limit) = @_;
+
+ return
+ sub {
+ my ($data) = @_;
+ $limit -= length $data;
+ if ($limit >= 0) {
+ print "# write of ", length $data, " bytes successful ($limit left)\n" if $debug_writes;
+ return 1;
+ }
+ else {
+ print "# write of ", length $data, " bytes failed\n";
+ Imager::i_push_error(0, "limit reached");
+ return;
+ }
+ };
+}
+
+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;
}
projects / imager.git / blobdiff