t/t107bmp.t

   1 #!perl -w
   2 use strict;
   3 use Test::More tests => 191;
   4 use Imager qw(:all);
   5 use Imager::Test qw(test_image_raw is_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     );
 497   my $test_index = 0;
 498   for my $test (@tests) {
 499     my ($filename, $patches, $error, $desc) = @$test;
 500
 501     my $data = load_patched_file("testimg/$filename", $patches);
 502     my $im = Imager->new;
 503     ok(!$im->read(data => $data, type=>'bmp'),
 504        "$test_index - $desc:should fail to read");
 505     is($im->errstr, $error, "$test_index - $desc:check message");
 506     ++$test_index;
 507   }
 508 }
 509
 510 { # various write failure tests
 511   # each entry is:
 512   # source, limit, expected error, description
 513   my @tests =
 514     (
 515      [
 516       "winrgb2.bmp", 1,
 517       "cannot write bmp header: limit reached",
 518       "1-bit, writing header"
 519      ],
 520      [
 521       "winrgb4.bmp", 1,
 522       "cannot write bmp header: limit reached",
 523       "4-bit, writing header"
 524      ],
 525      [
 526       "winrgb8.bmp", 1,
 527       "cannot write bmp header: limit reached",
 528       "8-bit, writing header"
 529      ],
 530      [
 531       "winrgb24.bmp", 1,
 532       "cannot write bmp header: limit reached",
 533       "24-bit, writing header"
 534      ],
 535      [
 536       "winrgb2.bmp", 0x38,
 537       "cannot write palette entry: limit reached",
 538       "1-bit, writing palette"
 539      ],
 540      [
 541       "winrgb4.bmp", 0x38,
 542       "cannot write palette entry: limit reached",
 543       "4-bit, writing palette"
 544      ],
 545      [
 546       "winrgb8.bmp", 0x38,
 547       "cannot write palette entry: limit reached",
 548       "8-bit, writing palette"
 549      ],
 550      [
 551       "winrgb2.bmp", 0x40,
 552       "writing 1 bit/pixel packed data: limit reached",
 553       "1-bit, writing image data"
 554      ],
 555      [
 556       "winrgb4.bmp", 0x80,
 557       "writing 4 bit/pixel packed data: limit reached",
 558       "4-bit, writing image data"
 559      ],
 560      [
 561       "winrgb8.bmp", 0x440,
 562       "writing 8 bit/pixel packed data: limit reached",
 563       "8-bit, writing image data"
 564      ],
 565      [
 566       "winrgb24.bmp", 0x39,
 567       "writing image data: limit reached",
 568       "24-bit, writing image data"
 569      ],
 570     );
 571   print "# write failure tests\n";
 572   my $test_index = 0;
 573   for my $test (@tests) {
 574     my ($file, $limit, $error, $desc) = @$test;
 575
 576     my $im = Imager->new;
 577     $im->read(file => "testimg/$file")
 578       or die "Cannot read $file: ", $im->errstr;
 579
 580     ok(!$im->write(type => 'bmp', callback => limited_write($limit),
 581                    maxbuffer => 1),
 582        "$test_index - $desc: write should fail");
 583     is($im->errstr, $error, "$test_index - $desc: check error message");
 584
 585     ++$test_index;
 586   }
 587 }
 588
 589 sub write_test {
 590   my ($im, $filename) = @_;
 591   local *FH;
 592
 593   if (open FH, "> $filename") {
 594     binmode FH;
 595     my $IO = Imager::io_new_fd(fileno(FH));
 596     unless (ok(Imager::i_writebmp_wiol($im, $IO), $filename)) {
 597       print "# ",Imager->_error_as_msg(),"\n";
 598     }
 599     undef $IO;
 600     close FH;
 601   }
 602   else {
 603     fail("could not open $filename: $!");
 604   }
 605 }
 606
 607 sub read_test {
 608   my ($filename, $im, %tags) = @_;
 609   local *FH;
 610
 611   print "# read_test: $filename\n";
 612
 613   $tags{i_format} = "bmp";
 614
 615   if (open FH, "< $filename") {
 616     binmode FH;
 617     my $IO = Imager::io_new_fd(fileno(FH));
 618     my $im_read = Imager::i_readbmp_wiol($IO);
 619     if ($im_read) {
 620       my $diff = i_img_diff($im, $im_read);
 621       if ($diff > $base_diff) {
 622         fail("image mismatch reading $filename");
 623       }
 624       else {
 625         my $tags_ok = 1;
 626         for my $tag (keys %tags) {
 627           if (my $index = Imager::i_tags_find($im_read, $tag, 0)) {
 628             my ($name, $value) = Imager::i_tags_get($im_read, $index);
 629             my $exp_value = $tags{$tag};
 630             print "#   tag $name = '$value' - expect '$exp_value'\n";
 631             if ($exp_value =~ /\d/) {
 632               if ($value != $tags{$tag}) {
 633                 print "# tag $tag value mismatch $tags{$tag} != $value\n";
 634                 $tags_ok = 0;
 635               }
 636             }
 637             else {
 638               if ($value ne $tags{$tag}) {
 639                 print "# tag $tag value mismatch $tags{$tag} != $value\n";
 640                 $tags_ok = 0;
 641               }
 642             }
 643           }
 644         }
 645         ok($tags_ok, "reading $filename");
 646         #  for my $i (0 .. Imager::i_tags_count($im_read)-1) {
 647         #    my ($name, $value) = Imager::i_tags_get($im_read, $i);
 648         #    print "# tag '$name' => '$value'\n";
 649         #}
 650       }
 651     }
 652     else {
 653       fail("could not read $filename: ".Imager->_error_as_msg());
 654     }
 655     undef $IO;
 656     close FH;
 657   }
 658   else {
 659     fail("could not open $filename: $!");
 660   }
 661 }
 662
 663 sub limited_write {
 664   my ($limit) = @_;
 665
 666   return
 667      sub {
 668        my ($data) = @_;
 669        $limit -= length $data;
 670        if ($limit >= 0) {
 671          print "# write of ", length $data, " bytes successful ($limit left)\n" if $debug_writes;
 672          return 1;
 673        }
 674        else {
 675          print "# write of ", length $data, " bytes failed\n";
 676          Imager::i_push_error(0, "limit reached");
 677          return;
 678        }
 679      };
 680 }
 681
 682 sub load_patched_file {
 683   my ($filename, $patches) = @_;
 684
 685   open IMDATA, "< $filename"
 686     or die "Cannot open $filename: $!";
 687   binmode IMDATA;
 688   my $data = do { local $/; <IMDATA> };
 689   for my $offset (keys %$patches) {
 690     (my $hdata = $patches->{$offset}) =~ tr/ //d;
 691     my $pdata = pack("H*", $hdata);
 692     substr($data, $offset, length $pdata) = $pdata;
 693   }
 694
 695   return $data;
 696 }