t/t107bmp.t

   1 #!perl -w
   2 use strict;
   3 use Test::More tests => 215;
   4 use Imager qw(:all);
   5 use Imager::Test qw(test_image_raw is_image is_color3 test_image);
   6
   7 -d "testout" or mkdir "testout";
   8
   9 Imager->open_log(log => "testout/t107bmp.log");
  10
  11 my @files;
  12 my $debug_writes = 0;
  13
  14 my $base_diff = 0;
  15 # if you change this make sure you generate new compressed versions
  16 my $green=i_color_new(0,255,0,255);
  17 my $blue=i_color_new(0,0,255,255);
  18 my $red=i_color_new(255,0,0,255);
  19
  20 my $img = test_image_raw();
  21
  22 Imager::i_tags_add($img, 'i_xres', 0, '300', 0);
  23 Imager::i_tags_add($img, 'i_yres', 0, undef, 300);
  24 write_test($img, "testout/t107_24bit.bmp");
  25 push @files, "t107_24bit.bmp";
  26 # 'webmap' is noticably faster than the default
  27 my $im8 = Imager::i_img_to_pal($img, { make_colors=>'webmap',
  28                                        translate=>'errdiff'});
  29 write_test($im8, "testout/t107_8bit.bmp");
  30 push @files, "t107_8bit.bmp";
  31 # use a fixed palette so we get reproducible results for the compressed
  32 # version
  33 my @pal16 = map { NC($_) }
  34   qw(605844 966600 0148b2 00f800 bf0a33 5e009e
  35      2ead1b 0000f8 004b01 fd0000 0e1695 000002);
  36 my $im4 = Imager::i_img_to_pal($img, { colors=>\@pal16, make_colors=>'none' });
  37 write_test($im4, "testout/t107_4bit.bmp");
  38 push @files, "t107_4bit.bmp";
  39 my $im1 = Imager::i_img_to_pal($img, { colors=>[ NC(0, 0, 0), NC(176, 160, 144) ],
  40                                make_colors=>'none', translate=>'errdiff' });
  41 write_test($im1, "testout/t107_1bit.bmp");
  42 push @files, "t107_1bit.bmp";
  43 my $bi_rgb = 0;
  44 my $bi_rle8 = 1;
  45 my $bi_rle4 = 2;
  46 my $bi_bitfields = 3;
  47 read_test("testout/t107_24bit.bmp", $img,
  48           bmp_compression=>0, bmp_bit_count => 24);
  49 read_test("testout/t107_8bit.bmp", $im8,
  50           bmp_compression=>0, bmp_bit_count => 8);
  51 read_test("testout/t107_4bit.bmp", $im4,
  52           bmp_compression=>0, bmp_bit_count => 4);
  53 read_test("testout/t107_1bit.bmp", $im1, bmp_compression=>0,
  54           bmp_bit_count=>1);
  55 # the following might have slight differences
  56 $base_diff = i_img_diff($img, $im8) * 2;
  57 print "# base difference $base_diff\n";
  58 read_test("testimg/comp4.bmp", $im4,
  59           bmp_compression=>$bi_rle4, bmp_bit_count => 4);
  60 read_test("testimg/comp8.bmp", $im8,
  61           bmp_compression=>$bi_rle8, bmp_bit_count => 8);
  62
  63 my $imoo = Imager->new;
  64 # read via OO
  65 ok($imoo->read(file=>'testout/t107_24bit.bmp'), "read via OO")
  66   or print "# ",$imoo->errstr,"\n";
  67
  68 ok($imoo->write(file=>'testout/t107_oo.bmp'), "write via OO")
  69   or print "# ",$imoo->errstr,"\n";
  70 push @files, "t107_oo.bmp";
  71
  72 # various invalid format tests
  73 # we have so many different test images to try to detect all the possible
  74 # failure paths in the code, adding these did detect real problems
  75 print "# catch various types of invalid bmp files\n";
  76 my @tests =
  77   (
  78    # entries in each array ref are:
  79    #  - basename of an invalid BMP file
  80    #  - error message that should be produced
  81    #  - description of what is being tested
  82    #  - possible flag to indicate testing only on 32-bit machines
  83    [ 'badplanes.bmp', 'not a BMP file', "invalid planes value" ],
  84    [ 'badbits.bmp', 'unknown bit count for BMP file (5)',
  85      'should fail to read invalid bits' ],
  86
  87    # 1-bit/pixel BMPs
  88    [ 'badused1.bmp', 'out of range colors used (3)',
  89      'out of range palette size (1-bit)' ],
  90    [ 'badcomp1.bmp', 'unknown 1-bit BMP compression (1)',
  91      'invalid compression value (1-bit)' ],
  92    [ 'bad1wid0.bmp', 'file size limit - image width of 0 is not positive',
  93      'width 0 (1-bit)' ],
  94    [ 'bad4oflow.bmp',
  95      'file size limit - integer overflow calculating storage',
  96      'overflow integers on 32-bit machines (1-bit)', '32bitonly' ],
  97    [ 'short1.bmp', 'failed reading 1-bit bmp data',
  98      'short 1-bit' ],
  99
 100    # 4-bit/pixel BMPs
 101    [ 'badused4a.bmp', 'out of range colors used (272)',
 102      'should fail to read invalid pal size (272) (4-bit)' ],
 103    [ 'badused4b.bmp', 'out of range colors used (17)',
 104      'should fail to read invalid pal size (17) (4-bit)' ],
 105    [ 'badcomp4.bmp', 'unknown 4-bit BMP compression (1)',
 106      'invalid compression value (4-bit)' ],
 107    [ 'short4.bmp', 'failed reading 4-bit bmp data',
 108      'short uncompressed 4-bit' ],
 109    [ 'short4rle.bmp', 'missing data during decompression',
 110      'short compressed 4-bit' ],
 111    [ 'bad4wid0.bmp', 'file size limit - image width of 0 is not positive',
 112      'width 0 (4-bit)' ],
 113    [ 'bad4widbig.bmp', 'file size limit - image width of -2147483628 is not positive',
 114      'width big (4-bit)' ],
 115    [ 'bad4oflow.bmp', 'file size limit - integer overflow calculating storage',
 116      'overflow integers on 32-bit machines (4-bit)', '32bitonly' ],
 117
 118    # 8-bit/pixel BMPs
 119    [ 'bad8useda.bmp', 'out of range colors used (257)',
 120      'should fail to read invalid pal size (8-bit)' ],
 121    [ 'bad8comp.bmp', 'unknown 8-bit BMP compression (2)',
 122      'invalid compression value (8-bit)' ],
 123    [ 'short8.bmp', 'failed reading 8-bit bmp data',
 124      'short uncompressed 8-bit' ],
 125    [ 'short8rle.bmp', 'missing data during decompression',
 126      'short compressed 8-bit' ],
 127    [ 'bad8wid0.bmp', 'file size limit - image width of 0 is not positive',
 128      'width 0 (8-bit)' ],
 129    [ 'bad8oflow.bmp', 'file size limit - integer overflow calculating storage',
 130      'overflow integers on 32-bit machines (8-bit)', '32bitonly' ],
 131
 132    # 24-bit/pixel BMPs
 133    [ 'short24.bmp', 'failed reading image data',
 134      'short 24-bit' ],
 135    [ 'bad24wid0.bmp', 'file size limit - image width of 0 is not positive',
 136      'width 0 (24-bit)' ],
 137    [ 'bad24oflow.bmp', 'file size limit - integer overflow calculating storage',
 138      'overflow integers on 32-bit machines (24-bit)', '32bitonly' ],
 139    [ 'bad24comp.bmp', 'unknown 24-bit BMP compression (4)',
 140      'bad compression (24-bit)' ],
 141   );
 142 use Config;
 143 my $ptrsize = $Config{ptrsize};
 144 for my $test (@tests) {
 145   my ($file, $error, $comment, $bit32only) = @$test;
 146  SKIP:
 147   {
 148     skip("only tested on 32-bit machines", 2)
 149       if $bit32only && $ptrsize != 4;
 150     ok(!$imoo->read(file=>"testimg/$file"), $comment);
 151     print "# ", $imoo->errstr, "\n";
 152     is($imoo->errstr, $error, "check error message");
 153   }
 154 }
 155
 156 # previously we didn't seek to the offbits position before reading
 157 # the image data, check we handle it correctly
 158 # in each case the first is an original image with a given number of
 159 # bits and the second is the same file with data inserted before the
 160 # image bits and the offset modified to suit
 161 my @comp =
 162   (
 163    [ 'winrgb2.bmp', 'winrgb2off.bmp', 1 ],
 164    [ 'winrgb4.bmp', 'winrgb4off.bmp', 4 ],
 165    [ 'winrgb8.bmp', 'winrgb8off.bmp', 8 ],
 166    [ 'winrgb24.bmp', 'winrgb24off.bmp', 24 ],
 167   );
 168
 169 for my $comp (@comp) {
 170   my ($base_file, $off_file, $bits) = @$comp;
 171
 172   my $base_im = Imager->new;
 173   my $got_base =
 174     ok($base_im->read(file=>"testimg/$base_file"),
 175         "read original")
 176       or print "# ",$base_im->errstr,"\n";
 177   my $off_im = Imager->new;
 178   my $got_off =
 179     ok($off_im->read(file=>"testimg/$off_file"),
 180         "read offset file")
 181       or print "# ",$off_im->errstr,"\n";
 182  SKIP:
 183   {
 184     skip("missed one file", 1)
 185       unless $got_base && $got_off;
 186     is(i_img_diff($base_im->{IMG}, $off_im->{IMG}), 0,
 187         "compare base and offset image ($bits bits)");
 188   }
 189 }
 190
 191 { # check file limits are checked
 192   my $limit_file = "testout/t107_24bit.bmp";
 193   ok(Imager->set_file_limits(reset=>1, width=>149), "set width limit 149");
 194   my $im = Imager->new;
 195   ok(!$im->read(file=>$limit_file),
 196      "should fail read due to size limits");
 197   print "# ",$im->errstr,"\n";
 198   like($im->errstr, qr/image width/, "check message");
 199
 200   ok(Imager->set_file_limits(reset=>1, height=>149), "set height limit 149");
 201   ok(!$im->read(file=>$limit_file),
 202      "should fail read due to size limits");
 203   print "# ",$im->errstr,"\n";
 204   like($im->errstr, qr/image height/, "check message");
 205
 206   ok(Imager->set_file_limits(reset=>1, width=>150), "set width limit 150");
 207   ok($im->read(file=>$limit_file),
 208      "should succeed - just inside width limit");
 209   ok(Imager->set_file_limits(reset=>1, height=>150), "set height limit 150");
 210   ok($im->read(file=>$limit_file),
 211      "should succeed - just inside height limit");
 212
 213   # 150 x 150 x 3 channel image uses 67500 bytes
 214   ok(Imager->set_file_limits(reset=>1, bytes=>67499),
 215      "set bytes limit 67499");
 216   ok(!$im->read(file=>$limit_file),
 217      "should fail - too many bytes");
 218   print "# ",$im->errstr,"\n";
 219   like($im->errstr, qr/storage size/, "check error message");
 220   ok(Imager->set_file_limits(reset=>1, bytes=>67500),
 221      "set bytes limit 67500");
 222   ok($im->read(file=>$limit_file),
 223      "should succeed - just inside bytes limit");
 224   Imager->set_file_limits(reset=>1);
 225 }
 226
 227 { # various short read failure tests, each entry has:
 228   # source filename, size, expected error
 229   # these have been selected based on code coverage, to check each
 230   # failure path is checked, where practical
 231   my @tests =
 232     (
 233      [
 234       "file truncated inside header",
 235       "winrgb2.bmp",
 236       20, "file too short to be a BMP file"
 237      ],
 238      [
 239       "1-bit, truncated inside palette",
 240       "winrgb2.bmp",
 241       56, "reading BMP palette"
 242      ],
 243      [
 244       "1-bit, truncated in offset region",
 245       "winrgb2off.bmp", 64, "failed skipping to image data offset"
 246      ],
 247      [
 248       "1-bit, truncated in image data",
 249       "winrgb2.bmp", 96, "failed reading 1-bit bmp data"
 250      ],
 251      [
 252       "4-bit, truncated inside palette",
 253       "winrgb4.bmp",
 254       56, "reading BMP palette"
 255      ],
 256      [
 257       "4-bit, truncated in offset region",
 258       "winrgb4off.bmp", 120, "failed skipping to image data offset",
 259      ],
 260      [
 261       "4-bit, truncate in image data",
 262       "winrgb4.bmp", 120, "failed reading 4-bit bmp data"
 263      ],
 264      [
 265       "4-bit RLE, truncate in uncompressed data",
 266       "comp4.bmp", 0x229, "missing data during decompression"
 267      ],
 268      [
 269       "8-bit, truncated in palette",
 270       "winrgb8.bmp", 1060, "reading BMP palette"
 271       ],
 272      [
 273       "8-bit, truncated in offset region",
 274       "winrgb8off.bmp", 1080, "failed skipping to image data offset"
 275      ],
 276      [
 277       "8-bit, truncated in image data",
 278       "winrgb8.bmp", 1080, "failed reading 8-bit bmp data"
 279      ],
 280      [
 281       "8-bit RLE, truncate in uncompressed data",
 282       "comp8.bmp", 0x68C, "missing data during decompression"
 283      ],
 284      [
 285       "24-bit, truncate in offset region",
 286       "winrgb24off.bmp", 56, "failed skipping to image data offset",
 287      ],
 288      [
 289       "24-bit, truncate in image data",
 290       "winrgb24.bmp", 100, "failed reading image data",
 291      ],
 292     );
 293
 294   my $test_index = 0;
 295   for my $test (@tests) {
 296     my ($desc, $srcfile, $size, $error) = @$test;
 297     my $im = Imager->new;
 298     open IMDATA, "< testimg/$srcfile"
 299       or die "$test_index - $desc: Cannot open testimg/$srcfile: $!";
 300     binmode IMDATA;
 301     my $data;
 302     read(IMDATA, $data, $size) == $size
 303       or die "$test_index - $desc: Could not read $size data from $srcfile";
 304     close IMDATA;
 305     ok(!$im->read(data => $data, type =>'bmp'),
 306        "$test_index - $desc: Should fail to read");
 307     is($im->errstr, $error, "$test_index - $desc: check message");
 308     ++$test_index;
 309   }
 310 }
 311
 312 { # various short read success tests, each entry has:
 313   # source filename, size, expected tags
 314   print "# allow_incomplete tests\n";
 315   my @tests =
 316     (
 317      [
 318       "1-bit",
 319       "winrgb2.bmp", 96,
 320       {
 321        bmp_compression_name => 'BI_RGB',
 322        bmp_compression => 0,
 323        bmp_used_colors => 2,
 324        i_lines_read => 8,
 325       },
 326      ],
 327      [
 328       "4-bit",
 329       "winrgb4.bmp", 250,
 330       {
 331        bmp_compression_name => 'BI_RGB',
 332        bmp_compression => 0,
 333        bmp_used_colors => 16,
 334        i_lines_read => 11,
 335       },
 336      ],
 337      [
 338       "4-bit RLE - uncompressed seq",
 339       "comp4.bmp", 0x229,
 340       {
 341        bmp_compression_name => 'BI_RLE4',
 342        bmp_compression => 2,
 343        bmp_used_colors => 16,
 344        i_lines_read => 44,
 345       },
 346      ],
 347      [
 348       "4-bit RLE - start seq",
 349       "comp4.bmp", 0x97,
 350       {
 351        bmp_compression_name => 'BI_RLE4',
 352        bmp_compression => 2,
 353        bmp_used_colors => 16,
 354        i_lines_read => 8,
 355       },
 356      ],
 357      [
 358       "8-bit",
 359       "winrgb8.bmp", 1250,
 360       {
 361        bmp_compression_name => 'BI_RGB',
 362        bmp_compression => 0,
 363        bmp_used_colors => 256,
 364        i_lines_read => 8,
 365       },
 366      ],
 367      [
 368       "8-bit RLE - uncompressed seq",
 369       "comp8.bmp", 0x68C,
 370       {
 371        bmp_compression_name => 'BI_RLE8',
 372        bmp_compression => 1,
 373        bmp_used_colors => 256,
 374        i_lines_read => 27,
 375       },
 376      ],
 377      [
 378       "8-bit RLE - initial seq",
 379       "comp8.bmp", 0x487,
 380       {
 381        bmp_compression_name => 'BI_RLE8',
 382        bmp_compression => 1,
 383        bmp_used_colors => 256,
 384        i_lines_read => 20,
 385       },
 386      ],
 387      [
 388       "24-bit",
 389       "winrgb24.bmp", 800,
 390       {
 391        bmp_compression_name => 'BI_RGB',
 392        bmp_compression => 0,
 393        bmp_used_colors => 0,
 394        i_lines_read => 12,
 395       },
 396      ],
 397     );
 398
 399   my $test_index = 0;
 400   for my $test (@tests) {
 401     my ($desc, $srcfile, $size, $tags) = @$test;
 402     my $im = Imager->new;
 403     open IMDATA, "< testimg/$srcfile"
 404       or die "$test_index - $desc: Cannot open testimg/$srcfile: $!";
 405     binmode IMDATA;
 406     my $data;
 407     read(IMDATA, $data, $size) == $size
 408       or die "$test_index - $desc: Could not read $size data from $srcfile";
 409     close IMDATA;
 410     ok($im->read(data => $data, type =>'bmp', allow_incomplete => 1),
 411        "$test_index - $desc: Should read successfully");
 412     # check standard tags are set
 413     is($im->tags(name => 'i_format'), 'bmp',
 414        "$test_index - $desc: i_format set");
 415     is($im->tags(name => 'i_incomplete'), 1,
 416        "$test_index - $desc: i_incomplete set");
 417     my %check_tags;
 418     for my $key (keys %$tags) {
 419       $check_tags{$key} = $im->tags(name => $key);
 420     }
 421     is_deeply(\%check_tags, $tags, "$test_index - $desc: check tags");
 422     ++$test_index;
 423   }
 424 }
 425
 426 { # check handling of reading images with negative height
 427   # each entry is:
 428   # source file, description
 429   print "# check handling of negative height values\n";
 430   my @tests =
 431     (
 432      [ "winrgb2.bmp", "1-bit, uncompressed" ],
 433      [ "winrgb4.bmp", "4-bit, uncompressed" ],
 434      [ "winrgb8.bmp", "8-bit, uncompressed" ],
 435      [ "winrgb24.bmp", "24-bit, uncompressed" ],
 436      [ "comp4.bmp", "4-bit, RLE" ],
 437      [ "comp8.bmp", "8-bit, RLE" ],
 438     );
 439   my $test_index = 0;
 440   for my $test (@tests) {
 441     my ($file, $desc) = @$test;
 442     open IMDATA, "< testimg/$file"
 443       or die "$test_index - Cannot open $file: $!";
 444     binmode IMDATA;
 445     my $data = do { local $/; <IMDATA> };
 446     close IMDATA;
 447     my $im_orig = Imager->new;
 448     $im_orig->read(data => $data)
 449       or die "Cannot load original $file: ", $im_orig->errstr;
 450
 451     # now negate the height
 452     my $orig_height = unpack("V", substr($data, 0x16, 4));
 453     my $neg_height = 0xFFFFFFFF & ~($orig_height - 1);
 454     substr($data, 0x16, 4) = pack("V", $neg_height);
 455
 456     # and read the modified image
 457     my $im = Imager->new;
 458     ok($im->read(data => $data),
 459        "$test_index - $desc: read negated height image")
 460       or print "# ", $im->errstr, "\n";
 461
 462     # flip orig to match what we should get
 463     $im_orig->flip(dir => 'v');
 464
 465     # check it out
 466     is_image($im, $im_orig, "$test_index - $desc: check image");
 467
 468     ++$test_index;
 469   }
 470 }
 471
 472 { print "# patched data read failure tests\n";
 473   # like the "various invalid format" tests, these generate fail
 474   # images from other images included with Imager without providing a
 475   # full bmp source, saving on dist size and focusing on the changes needed
 476   # to cause the failure
 477   # each entry is: source file, patches, expected error, description
 478
 479   my @tests =
 480     (
 481      # low image data offsets
 482      [
 483       "winrgb2.bmp",
 484       { 10 => "3d 00 00 00" },
 485       "image data offset too small (61)",
 486       "1-bit, small image offset"
 487      ],
 488      [
 489       "winrgb4.bmp",
 490       { 10 => "75 00 00 00" },
 491       "image data offset too small (117)",
 492       "4-bit, small image offset"
 493      ],
 494      [
 495       "winrgb8.bmp",
 496       { 10 => "35 04 00 00" },
 497       "image data offset too small (1077)",
 498       "8-bit, small image offset"
 499      ],
 500      [
 501       "winrgb24.bmp",
 502       { 10 => "35 00 00 00" },
 503       "image data offset too small (53)",
 504       "24-bit, small image offset"
 505      ],
 506      # compression issues
 507      [
 508       "comp8.bmp",
 509       { 0x436 => "97" },
 510       "invalid data during decompression",
 511       "8bit, RLE run beyond edge of image"
 512      ],
 513      [
 514       # caused glibc malloc or valgrind to complain
 515       "comp8.bmp",
 516       { 0x436 => "94 00 00 03" },
 517       "invalid data during decompression",
 518       "8bit, literal run beyond edge of image"
 519      ],
 520      [
 521       "comp4.bmp",
 522       { 0x76 => "FF bb FF BB" },
 523       "invalid data during decompression",
 524       "4bit - RLE run beyond edge of image"
 525      ],
 526      [
 527       "comp4.bmp",
 528       { 0x76 => "94 bb 00 FF" },
 529       "invalid data during decompression",
 530       "4bit - literal run beyond edge of image"
 531      ],
 532     );
 533   my $test_index = 0;
 534   for my $test (@tests) {
 535     my ($filename, $patches, $error, $desc) = @$test;
 536
 537     my $data = load_patched_file("testimg/$filename", $patches);
 538     my $im = Imager->new;
 539     ok(!$im->read(data => $data, type=>'bmp'),
 540        "$test_index - $desc:should fail to read");
 541     is($im->errstr, $error, "$test_index - $desc:check message");
 542     ++$test_index;
 543   }
 544 }
 545
 546 { # various write failure tests
 547   # each entry is:
 548   # source, limit, expected error, description
 549   my @tests =
 550     (
 551      [
 552       "winrgb2.bmp", 1,
 553       "cannot write bmp header: limit reached",
 554       "1-bit, writing header"
 555      ],
 556      [
 557       "winrgb4.bmp", 1,
 558       "cannot write bmp header: limit reached",
 559       "4-bit, writing header"
 560      ],
 561      [
 562       "winrgb8.bmp", 1,
 563       "cannot write bmp header: limit reached",
 564       "8-bit, writing header"
 565      ],
 566      [
 567       "winrgb24.bmp", 1,
 568       "cannot write bmp header: limit reached",
 569       "24-bit, writing header"
 570      ],
 571      [
 572       "winrgb2.bmp", 0x38,
 573       "cannot write palette entry: limit reached",
 574       "1-bit, writing palette"
 575      ],
 576      [
 577       "winrgb4.bmp", 0x38,
 578       "cannot write palette entry: limit reached",
 579       "4-bit, writing palette"
 580      ],
 581      [
 582       "winrgb8.bmp", 0x38,
 583       "cannot write palette entry: limit reached",
 584       "8-bit, writing palette"
 585      ],
 586      [
 587       "winrgb2.bmp", 0x40,
 588       "writing 1 bit/pixel packed data: limit reached",
 589       "1-bit, writing image data"
 590      ],
 591      [
 592       "winrgb4.bmp", 0x80,
 593       "writing 4 bit/pixel packed data: limit reached",
 594       "4-bit, writing image data"
 595      ],
 596      [
 597       "winrgb8.bmp", 0x440,
 598       "writing 8 bit/pixel packed data: limit reached",
 599       "8-bit, writing image data"
 600      ],
 601      [
 602       "winrgb24.bmp", 0x39,
 603       "writing image data: limit reached",
 604       "24-bit, writing image data"
 605      ],
 606     );
 607   print "# write failure tests\n";
 608   my $test_index = 0;
 609   for my $test (@tests) {
 610     my ($file, $limit, $error, $desc) = @$test;
 611
 612     my $im = Imager->new;
 613     $im->read(file => "testimg/$file")
 614       or die "Cannot read $file: ", $im->errstr;
 615
 616     my $io = Imager::io_new_cb(limited_write($limit), undef, undef, undef, 1);
 617     $io->set_buffered(0);
 618     print "# writing with limit of $limit\n";
 619     ok(!$im->write(type => 'bmp', io => $io),
 620        "$test_index - $desc: write should fail");
 621     is($im->errstr, $error, "$test_index - $desc: check error message");
 622
 623     ++$test_index;
 624   }
 625 }
 626
 627 {
 628   ok(grep($_ eq 'bmp', Imager->read_types), "check bmp in read types");
 629   ok(grep($_ eq 'bmp', Imager->write_types), "check bmp in write types");
 630 }
 631
 632 {
 633   # RT #30075
 634   # give 4/2 channel images a background color when saving to BMP
 635   my $im = Imager->new(xsize=>16, ysize=>16, channels=>4);
 636   $im->box(filled => 1, xmin => 8, color => '#FFE0C0');
 637   $im->box(filled => 1, color => NC(0, 192, 192, 128),
 638            ymin => 8, xmax => 7);
 639   ok($im->write(file=>"testout/t107_alpha.bmp", type=>'bmp'),
 640      "should succeed writing 4 channel image");
 641   push @files, "t107_alpha.bmp";
 642   my $imread = Imager->new;
 643   ok($imread->read(file => 'testout/t107_alpha.bmp'), "read it back");
 644   is_color3($imread->getpixel('x' => 0, 'y' => 0), 0, 0, 0,
 645             "check transparent became black");
 646   is_color3($imread->getpixel('x' => 8, 'y' => 0), 255, 224, 192,
 647             "check color came through");
 648   is_color3($imread->getpixel('x' => 0, 'y' => 15), 0, 96, 96,
 649             "check translucent came through");
 650   my $data;
 651   ok($im->write(data => \$data, type => 'bmp', i_background => '#FF0000'),
 652      "write with red background");
 653   ok($imread->read(data => $data, type => 'bmp'),
 654      "read it back");
 655   is_color3($imread->getpixel('x' => 0, 'y' => 0), 255, 0, 0,
 656             "check transparent became red");
 657   is_color3($imread->getpixel('x' => 8, 'y' => 0), 255, 224, 192,
 658             "check color came through");
 659   is_color3($imread->getpixel('x' => 0, 'y' => 15), 127, 96, 96,
 660             "check translucent came through");
 661 }
 662
 663 { # RT 41406
 664   my $data;
 665   my $im = test_image();
 666   ok($im->write(data => \$data, type => 'bmp'), "write using OO");
 667   my $size = unpack("V", substr($data, 34, 4));
 668   is($size, 67800, "check data size");
 669 }
 670
 671 { # check close failures are handled correctly
 672   my $im = test_image();
 673   my $fail_close = sub {
 674     Imager::i_push_error(0, "synthetic close failure");
 675     return 0;
 676   };
 677   ok(!$im->write(type => "bmp", callback => sub { 1 },
 678                  closecb => $fail_close),
 679      "check failing close fails");
 680     like($im->errstr, qr/synthetic close failure/,
 681          "check error message");
 682 }
 683
 684 Imager->close_log;
 685
 686 unless ($ENV{IMAGER_KEEP_FILES}) {
 687   unlink map "testout/$_", @files;
 688   unlink "testout/t107bmp.log";
 689 }
 690
 691 sub write_test {
 692   my ($im, $filename) = @_;
 693   local *FH;
 694
 695   if (open FH, "> $filename") {
 696     binmode FH;
 697     my $IO = Imager::io_new_fd(fileno(FH));
 698     unless (ok(Imager::i_writebmp_wiol($im, $IO), $filename)) {
 699       print "# ",Imager->_error_as_msg(),"\n";
 700     }
 701     undef $IO;
 702     close FH;
 703   }
 704   else {
 705     fail("could not open $filename: $!");
 706   }
 707 }
 708
 709 sub read_test {
 710   my ($filename, $im, %tags) = @_;
 711   local *FH;
 712
 713   print "# read_test: $filename\n";
 714
 715   $tags{i_format} = "bmp";
 716
 717   if (open FH, "< $filename") {
 718     binmode FH;
 719     my $IO = Imager::io_new_fd(fileno(FH));
 720     my $im_read = Imager::i_readbmp_wiol($IO);
 721     if ($im_read) {
 722       my $diff = i_img_diff($im, $im_read);
 723       if ($diff > $base_diff) {
 724         fail("image mismatch reading $filename");
 725       }
 726       else {
 727         my $tags_ok = 1;
 728         for my $tag (keys %tags) {
 729           if (my $index = Imager::i_tags_find($im_read, $tag, 0)) {
 730             my ($name, $value) = Imager::i_tags_get($im_read, $index);
 731             my $exp_value = $tags{$tag};
 732             print "#   tag $name = '$value' - expect '$exp_value'\n";
 733             if ($exp_value =~ /\d/) {
 734               if ($value != $tags{$tag}) {
 735                 print "# tag $tag value mismatch $tags{$tag} != $value\n";
 736                 $tags_ok = 0;
 737               }
 738             }
 739             else {
 740               if ($value ne $tags{$tag}) {
 741                 print "# tag $tag value mismatch $tags{$tag} != $value\n";
 742                 $tags_ok = 0;
 743               }
 744             }
 745           }
 746         }
 747         ok($tags_ok, "reading $filename");
 748         #  for my $i (0 .. Imager::i_tags_count($im_read)-1) {
 749         #    my ($name, $value) = Imager::i_tags_get($im_read, $i);
 750         #    print "# tag '$name' => '$value'\n";
 751         #}
 752       }
 753     }
 754     else {
 755       fail("could not read $filename: ".Imager->_error_as_msg());
 756     }
 757     undef $IO;
 758     close FH;
 759   }
 760   else {
 761     fail("could not open $filename: $!");
 762   }
 763 }
 764
 765 sub limited_write {
 766   my ($limit) = @_;
 767
 768   return
 769      sub {
 770        my ($data) = @_;
 771        $limit -= length $data;
 772        if ($limit >= 0) {
 773          print "# write of ", length $data, " bytes successful ($limit left)\n" if $debug_writes;
 774          return 1;
 775        }
 776        else {
 777          print "# write of ", length $data, " bytes failed\n";
 778          Imager::i_push_error(0, "limit reached");
 779          return;
 780        }
 781      };
 782 }
 783
 784 sub load_patched_file {
 785   my ($filename, $patches) = @_;
 786
 787   open IMDATA, "< $filename"
 788     or die "Cannot open $filename: $!";
 789   binmode IMDATA;
 790   my $data = do { local $/; <IMDATA> };
 791   for my $offset (keys %$patches) {
 792     (my $hdata = $patches->{$offset}) =~ tr/ //d;
 793     my $pdata = pack("H*", $hdata);
 794     substr($data, $offset, length $pdata) = $pdata;
 795   }
 796
 797   return $data;
 798 }