t/t107bmp.t

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