TIFF/t/t10tiff.t

   1 #!perl -w
   2 use strict;
   3 use Test::More tests => 239;
   4 use Imager qw(:all);
   5 use Imager::Test qw(is_image is_image_similar test_image test_image_16 test_image_double test_image_raw);
   6
   7 BEGIN { use_ok("Imager::File::TIFF"); }
   8
   9 -d "testout"
  10   or mkdir "testout";
  11
  12 $|=1;  # give us some progress in the test harness
  13 init_log("testout/t106tiff.log",1);
  14
  15 my $green=i_color_new(0,255,0,255);
  16 my $blue=i_color_new(0,0,255,255);
  17 my $red=i_color_new(255,0,0,255);
  18
  19 my $img=test_image_raw();
  20
  21 my $ver_string = Imager::File::TIFF::i_tiff_libversion();
  22 ok(my ($full, $major, $minor, $point) =
  23    $ver_string =~ /Version +((\d+)\.(\d+).(\d+))/,
  24    "extract library version")
  25   or diag("Could not extract from:\n$ver_string");
  26 diag("libtiff release $full") if $full;
  27 # make something we can compare
  28 my $cmp_ver = sprintf("%03d%03d%03d", $major, $minor, $point);
  29 if ($cmp_ver lt '003007000') {
  30   diag("You have an old version of libtiff - $full, some tests will be skipped");
  31 }
  32
  33 Imager::i_tags_add($img, "i_xres", 0, "300", 0);
  34 Imager::i_tags_add($img, "i_yres", 0, undef, 250);
  35 # resolutionunit is centimeters
  36 Imager::i_tags_add($img, "tiff_resolutionunit", 0, undef, 3);
  37 Imager::i_tags_add($img, "tiff_software", 0, "t106tiff.t", 0);
  38 open(FH,">testout/t106.tiff") || die "cannot open testout/t106.tiff for writing\n";
  39 binmode(FH);
  40 my $IO = Imager::io_new_fd(fileno(FH));
  41 ok(Imager::File::TIFF::i_writetiff_wiol($img, $IO), "write low level")
  42   or print "# ", Imager->_error_as_msg, "\n";
  43 close(FH);
  44
  45 open(FH,"testout/t106.tiff") or die "cannot open testout/t106.tiff\n";
  46 binmode(FH);
  47 $IO = Imager::io_new_fd(fileno(FH));
  48 my $cmpimg = Imager::File::TIFF::i_readtiff_wiol($IO);
  49 ok($cmpimg, "read low-level");
  50
  51 close(FH);
  52
  53 print "# tiff average mean square pixel difference: ",sqrt(i_img_diff($img,$cmpimg))/150*150,"\n";
  54
  55 ok(!i_img_diff($img, $cmpimg), "compare written and read image");
  56
  57 # check the tags are ok
  58 my %tags = map { Imager::i_tags_get($cmpimg, $_) }
  59   0 .. Imager::i_tags_count($cmpimg) - 1;
  60 ok(abs($tags{i_xres} - 300) < 0.5, "i_xres in range");
  61 ok(abs($tags{i_yres} - 250) < 0.5, "i_yres in range");
  62 is($tags{tiff_resolutionunit}, 3, "tiff_resolutionunit");
  63 is($tags{tiff_software}, 't106tiff.t', "tiff_software");
  64 is($tags{tiff_photometric}, 2, "tiff_photometric"); # PHOTOMETRIC_RGB is 2
  65 is($tags{tiff_bitspersample}, 8, "tiff_bitspersample");
  66
  67 $IO = Imager::io_new_bufchain();
  68
  69 ok(Imager::File::TIFF::i_writetiff_wiol($img, $IO), "write to buffer chain");
  70 my $tiffdata = Imager::io_slurp($IO);
  71
  72 open(FH,"testout/t106.tiff");
  73 binmode FH;
  74 my $odata;
  75 { local $/;
  76   $odata = <FH>;
  77 }
  78
  79 is($odata, $tiffdata, "same data in file as in memory");
  80
  81 # test Micksa's tiff writer
  82 # a shortish fax page
  83 my $faximg = Imager::ImgRaw::new(1728, 2000, 1);
  84 my $black = i_color_new(0,0,0,255);
  85 my $white = i_color_new(255,255,255,255);
  86 # vaguely test-patterny
  87 i_box_filled($faximg, 0, 0, 1728, 2000, $white);
  88 i_box_filled($faximg, 100,100,1628, 200, $black);
  89 my $width = 1;
  90 my $pos = 100;
  91 while ($width+$pos < 1628) {
  92   i_box_filled($faximg, $pos, 300, $pos+$width-1, 400, $black);
  93   $pos += $width + 20;
  94   $width += 2;
  95 }
  96 open FH, "> testout/t106tiff_fax.tiff"
  97   or die "Cannot create testout/t106tiff_fax.tiff: $!";
  98 binmode FH;
  99 $IO = Imager::io_new_fd(fileno(FH));
 100 ok(Imager::File::TIFF::i_writetiff_wiol_faxable($faximg, $IO, 1), "write faxable, low level");
 101 close FH;
 102
 103 # test the OO interface
 104 my $ooim = Imager->new;
 105 ok($ooim->read(file=>'testout/t106.tiff'), "read OO");
 106 ok($ooim->write(file=>'testout/t106_oo.tiff'), "write OO");
 107
 108 # OO with the fax image
 109 my $oofim = Imager->new;
 110 ok($oofim->read(file=>'testout/t106tiff_fax.tiff'),
 111    "read fax OO");
 112
 113 # this should have tags set for the resolution
 114 %tags = map @$_, $oofim->tags;
 115 is($tags{i_xres}, 204, "fax i_xres");
 116 is($tags{i_yres}, 196, "fax i_yres");
 117 ok(!$tags{i_aspect_only}, "i_aspect_only");
 118 # resunit_inches
 119 is($tags{tiff_resolutionunit}, 2, "tiff_resolutionunit");
 120 is($tags{tiff_bitspersample}, 1, "tiff_bitspersample");
 121 is($tags{tiff_photometric}, 0, "tiff_photometric");
 122
 123 ok($oofim->write(file=>'testout/t106_oo_fax.tiff', class=>'fax'),
 124    "write OO, faxable");
 125
 126 # the following should fail since there's no type and no filename
 127 my $oodata;
 128 ok(!$ooim->write(data=>\$oodata), "write with no type and no filename to guess with");
 129
 130 # OO to data
 131 ok($ooim->write(data=>\$oodata, type=>'tiff'), "write to data")
 132   or print "# ",$ooim->errstr, "\n";
 133 is($oodata, $tiffdata, "check data matches between memory and file");
 134
 135 # make sure we can write non-fine mode
 136 ok($oofim->write(file=>'testout/t106_oo_faxlo.tiff', class=>'fax', fax_fine=>0), "write OO, fax standard mode");
 137
 138 # paletted reads
 139 my $img4 = Imager->new;
 140 ok($img4->read(file=>'testimg/comp4.tif'), "reading 4-bit paletted")
 141   or print "# ", $img4->errstr, "\n";
 142 is($img4->type, 'paletted', "image isn't paletted");
 143 print "# colors: ", $img4->colorcount,"\n";
 144   cmp_ok($img4->colorcount, '<=', 16, "more than 16 colors!");
 145 #ok($img4->write(file=>'testout/t106_was4.ppm'),
 146 #   "Cannot write img4");
 147 # I know I'm using BMP before it's test, but comp4.tif started life
 148 # as comp4.bmp
 149 my $bmp4 = Imager->new;
 150 ok($bmp4->read(file=>'testimg/comp4.bmp'), "reading 4-bit bmp!");
 151 my $diff = i_img_diff($img4->{IMG}, $bmp4->{IMG});
 152 print "# diff $diff\n";
 153 ok($diff == 0, "image mismatch");
 154 my $img4t = Imager->new;
 155 ok($img4t->read(file => 'testimg/comp4t.tif'), "read 4-bit paletted, tiled")
 156   or print "# ", $img4t->errstr, "\n";
 157 is_image($bmp4, $img4t, "check tiled version matches");
 158 my $img8 = Imager->new;
 159 ok($img8->read(file=>'testimg/comp8.tif'), "reading 8-bit paletted");
 160 is($img8->type, 'paletted', "image isn't paletted");
 161 print "# colors: ", $img8->colorcount,"\n";
 162 #ok($img8->write(file=>'testout/t106_was8.ppm'),
 163 #   "Cannot write img8");
 164 ok($img8->colorcount == 256, "more colors than expected");
 165 my $bmp8 = Imager->new;
 166 ok($bmp8->read(file=>'testimg/comp8.bmp'), "reading 8-bit bmp!");
 167 $diff = i_img_diff($img8->{IMG}, $bmp8->{IMG});
 168 print "# diff $diff\n";
 169 ok($diff == 0, "image mismatch");
 170 my $bad = Imager->new;
 171 ok($bad->read(file=>'testimg/comp4bad.tif',
 172               allow_incomplete=>1), "bad image not returned");
 173 ok(scalar $bad->tags(name=>'i_incomplete'), "incomplete tag not set");
 174 ok($img8->write(file=>'testout/t106_pal8.tif'), "writing 8-bit paletted");
 175 my $cmp8 = Imager->new;
 176 ok($cmp8->read(file=>'testout/t106_pal8.tif'),
 177    "reading 8-bit paletted");
 178 #print "# ",$cmp8->errstr,"\n";
 179 is($cmp8->type, 'paletted', "pal8 isn't paletted");
 180 is($cmp8->colorcount, 256, "pal8 bad colorcount");
 181 $diff = i_img_diff($img8->{IMG}, $cmp8->{IMG});
 182 print "# diff $diff\n";
 183 ok($diff == 0, "written image doesn't match read");
 184 ok($img4->write(file=>'testout/t106_pal4.tif'), "writing 4-bit paletted");
 185 ok(my $cmp4 = Imager->new->read(file=>'testout/t106_pal4.tif'),
 186    "reading 4-bit paletted");
 187 is($cmp4->type, 'paletted', "pal4 isn't paletted");
 188 is($cmp4->colorcount, 16, "pal4 bad colorcount");
 189 $diff = i_img_diff($img4->{IMG}, $cmp4->{IMG});
 190 print "# diff $diff\n";
 191 ok($diff == 0, "written image doesn't match read");
 192
 193 my $work;
 194 my $seekpos;
 195 sub io_writer {
 196   my ($what) = @_;
 197   if ($seekpos > length $work) {
 198     $work .= "\0" x ($seekpos - length $work);
 199   }
 200   substr($work, $seekpos, length $what) = $what;
 201   $seekpos += length $what;
 202
 203   1;
 204 }
 205 sub io_reader {
 206   my ($size, $maxread) = @_;
 207   print "# io_reader($size, $maxread) pos $seekpos\n";
 208   if ($seekpos + $maxread > length $work) {
 209     $maxread = length($work) - $seekpos;
 210   }
 211   my $out = substr($work, $seekpos, $maxread);
 212   $seekpos += length $out;
 213   $out;
 214 }
 215 sub io_reader2 {
 216   my ($size, $maxread) = @_;
 217   print "# io_reader2($size, $maxread) pos $seekpos\n";
 218   my $out = substr($work, $seekpos, $size);
 219   $seekpos += length $out;
 220   $out;
 221 }
 222 use IO::Seekable;
 223 sub io_seeker {
 224   my ($offset, $whence) = @_;
 225   print "# io_seeker($offset, $whence)\n";
 226   if ($whence == SEEK_SET) {
 227     $seekpos = $offset;
 228   }
 229   elsif ($whence == SEEK_CUR) {
 230     $seekpos += $offset;
 231   }
 232   else { # SEEK_END
 233     $seekpos = length($work) + $offset;
 234   }
 235   #print "-> $seekpos\n";
 236   $seekpos;
 237 }
 238 my $did_close;
 239 sub io_closer {
 240   ++$did_close;
 241 }
 242
 243 # read via cb
 244 $work = $tiffdata;
 245 $seekpos = 0;
 246 my $IO2 = Imager::io_new_cb(undef, \&io_reader, \&io_seeker, undef);
 247 ok($IO2, "new readcb obj");
 248 my $img5 = Imager::File::TIFF::i_readtiff_wiol($IO2);
 249 ok($img5, "read via cb");
 250 ok(i_img_diff($img5, $img) == 0, "read from cb diff");
 251
 252 # read via cb2
 253 $work = $tiffdata;
 254 $seekpos = 0;
 255 my $IO3 = Imager::io_new_cb(undef, \&io_reader2, \&io_seeker, undef);
 256 ok($IO3, "new readcb2 obj");
 257 my $img6 = Imager::File::TIFF::i_readtiff_wiol($IO3);
 258 ok($img6, "read via cb2");
 259 ok(i_img_diff($img6, $img) == 0, "read from cb2 diff");
 260
 261 # write via cb
 262 $work = '';
 263 $seekpos = 0;
 264 my $IO4 = Imager::io_new_cb(\&io_writer, \&io_reader, \&io_seeker,
 265                             \&io_closer);
 266 ok($IO4, "new writecb obj");
 267 ok(Imager::File::TIFF::i_writetiff_wiol($img, $IO4), "write to cb");
 268 is($work, $odata, "write cb match");
 269 ok($did_close, "write cb did close");
 270 open D1, ">testout/d1.tiff" or die;
 271 print D1 $work;
 272 close D1;
 273 open D2, ">testout/d2.tiff" or die;
 274 print D2 $tiffdata;
 275 close D2;
 276
 277 # write via cb2
 278 $work = '';
 279 $seekpos = 0;
 280 $did_close = 0;
 281 my $IO5 = Imager::io_new_cb(\&io_writer, \&io_reader, \&io_seeker,
 282                             \&io_closer, 1);
 283 ok($IO5, "new writecb obj 2");
 284 ok(Imager::File::TIFF::i_writetiff_wiol($img, $IO5), "write to cb2");
 285 is($work, $odata, "write cb2 match");
 286 ok($did_close, "write cb2 did close");
 287
 288 open D3, ">testout/d3.tiff" or die;
 289 print D3 $work;
 290 close D3;
 291
 292
 293 { # check close failures are handled correctly
 294   { # single image
 295     my $im = test_image();
 296     my $fail_close = sub {
 297       Imager::i_push_error(0, "synthetic close failure");
 298       return 0;
 299     };
 300     $work = '';
 301     $seekpos = 0;
 302     ok(!$im->write(type => "tiff",
 303                    readcb => \&io_reader,
 304                    writecb => \&io_writer,
 305                    seekcb => \&io_seeker,
 306                    closecb => $fail_close),
 307        "check failing close fails");
 308     like($im->errstr, qr/synthetic close failure/,
 309          "check error message");
 310   }
 311   { # multiple images
 312     my $im = test_image();
 313     my $fail_close = sub {
 314       Imager::i_push_error(0, "synthetic close failure");
 315       return 0;
 316     };
 317     $work = '';
 318     $seekpos = 0;
 319     ok(!Imager->write_multi({type => "tiff",
 320                              readcb => \&io_reader,
 321                              writecb => \&io_writer,
 322                              seekcb => \&io_seeker,
 323                              closecb => $fail_close}, $im, $im),
 324        "check failing close fails");
 325     like(Imager->errstr, qr/synthetic close failure/,
 326          "check error message");
 327   }
 328 }
 329
 330 # multi-image write/read
 331 my @imgs;
 332 push(@imgs, map $ooim->copy(), 1..3);
 333 for my $i (0..$#imgs) {
 334   $imgs[$i]->addtag(name=>"tiff_pagename", value=>"Page ".($i+1));
 335 }
 336 my $rc = Imager->write_multi({file=>'testout/t106_multi.tif'}, @imgs);
 337 ok($rc, "writing multiple images to tiff");
 338 my @out = Imager->read_multi(file=>'testout/t106_multi.tif');
 339 ok(@out == @imgs, "reading multiple images from tiff");
 340 @out == @imgs or print "# ",scalar @out, " ",Imager->errstr,"\n";
 341 for my $i (0..$#imgs) {
 342   ok(i_img_diff($imgs[$i]{IMG}, $out[$i]{IMG}) == 0,
 343      "comparing image $i");
 344   my ($tag) = $out[$i]->tags(name=>'tiff_pagename');
 345   is($tag, "Page ".($i+1),
 346      "tag doesn't match original image");
 347 }
 348
 349 # writing even more images to tiff - we weren't handling more than five
 350 # correctly on read
 351 @imgs = map $ooim->copy(), 1..40;
 352 $rc = Imager->write_multi({file=>'testout/t106_multi2.tif'}, @imgs);
 353 ok($rc, "writing 40 images to tiff")
 354   or diag("writing 40 images: " . Imager->errstr);
 355 @out = Imager->read_multi(file=>'testout/t106_multi2.tif');
 356 ok(@imgs == @out, "reading 40 images from tiff")
 357   or diag("reading 40 images:" . Imager->errstr);
 358 # force some allocation activity - helps crash here if it's the problem
 359 @out = @imgs = ();
 360
 361 # multi-image fax files
 362 ok(Imager->write_multi({file=>'testout/t106_faxmulti.tiff', class=>'fax'},
 363                        $oofim, $oofim), "write multi fax image")
 364   or diag("writing 40 fax pages: " . Imager->errstr);
 365 @imgs = Imager->read_multi(file=>'testout/t106_faxmulti.tiff');
 366 ok(@imgs == 2, "reading multipage fax")
 367   or diag("reading 40 fax pages: " . Imager->errstr);
 368 ok(Imager::i_img_diff($imgs[0]{IMG}, $oofim->{IMG}) == 0,
 369    "compare first fax image");
 370 ok(Imager::i_img_diff($imgs[1]{IMG}, $oofim->{IMG}) == 0,
 371    "compare second fax image");
 372
 373 my ($format) = $imgs[0]->tags(name=>'i_format');
 374 is($format, 'tiff', "check i_format tag");
 375
 376 my $unit = $imgs[0]->tags(name=>'tiff_resolutionunit');
 377 ok(defined $unit && $unit == 2, "check tiff_resolutionunit tag");
 378 my $unitname = $imgs[0]->tags(name=>'tiff_resolutionunit_name');
 379 is($unitname, 'inch', "check tiff_resolutionunit_name tag");
 380
 381 my $warned = Imager->new;
 382 ok($warned->read(file=>"testimg/tiffwarn.tif"), "read tiffwarn.tif");
 383 my ($warning) = $warned->tags(name=>'i_warning');
 384 ok(defined $warning, "check warning is set");
 385 like($warning, qr/[Uu]nknown field with tag 28712/,
 386      "check that warning tag correct");
 387
 388 { # support for reading a given page
 389   # first build a simple test image
 390   my $im1 = Imager->new(xsize=>50, ysize=>50);
 391   $im1->box(filled=>1, color=>$blue);
 392   $im1->addtag(name=>'tiff_pagename', value => "Page One");
 393   my $im2 = Imager->new(xsize=>60, ysize=>60);
 394   $im2->box(filled=>1, color=>$green);
 395   $im2->addtag(name=>'tiff_pagename', value=>"Page Two");
 396
 397   # read second page
 398   my $page_file = 'testout/t106_pages.tif';
 399   ok(Imager->write_multi({ file=> $page_file}, $im1, $im2),
 400      "build simple multiimage for page tests");
 401   my $imwork = Imager->new;
 402   ok($imwork->read(file=>$page_file, page=>1),
 403      "read second page");
 404   is($im2->getwidth, $imwork->getwidth, "check width");
 405   is($im2->getwidth, $imwork->getheight, "check height");
 406   is(i_img_diff($imwork->{IMG}, $im2->{IMG}), 0,
 407      "check image content");
 408   my ($page_name) = $imwork->tags(name=>'tiff_pagename');
 409   is($page_name, 'Page Two', "check tag we set");
 410
 411   # try an out of range page
 412   ok(!$imwork->read(file=>$page_file, page=>2),
 413      "check out of range page");
 414   is($imwork->errstr, "could not switch to page 2", "check message");
 415 }
 416
 417 { # test writing returns an error message correctly
 418   # open a file read only and try to write to it
 419   open TIFF, "> testout/t106_empty.tif" or die;
 420   close TIFF;
 421   open TIFF, "< testout/t106_empty.tif"
 422     or skip "Cannot open testout/t106_empty.tif for reading", 8;
 423   binmode TIFF;
 424   my $im = Imager->new(xsize=>100, ysize=>100);
 425   ok(!$im->write(fh => \*TIFF, type=>'tiff', buffered => 0),
 426      "fail to write to read only handle");
 427   cmp_ok($im->errstr, '=~', 'Could not create TIFF object: Error writing TIFF header: write\(\)',
 428          "check error message");
 429   ok(!Imager->write_multi({ type => 'tiff', fh => \*TIFF, buffered => 0 }, $im),
 430      "fail to write multi to read only handle");
 431   cmp_ok(Imager->errstr, '=~', 'Could not create TIFF object: Error writing TIFF header: write\(\)',
 432          "check error message");
 433   ok(!$im->write(fh => \*TIFF, type=>'tiff', class=>'fax', buffered => 0),
 434      "fail to write to read only handle (fax)");
 435   cmp_ok($im->errstr, '=~', 'Could not create TIFF object: Error writing TIFF header: write\(\)',
 436          "check error message");
 437   ok(!Imager->write_multi({ type => 'tiff', fh => \*TIFF, class=>'fax', buffered => 0 }, $im),
 438      "fail to write multi to read only handle (fax)");
 439   cmp_ok(Imager->errstr, '=~', 'Could not create TIFF object: Error writing TIFF header: write\(\)',
 440          "check error message");
 441 }
 442
 443 { # test reading returns an error correctly - use test script as an
 444   # invalid TIFF file
 445   my $im = Imager->new;
 446   ok(!$im->read(file=>'t/t10tiff.t', type=>'tiff'),
 447      "fail to read script as image");
 448   # we get different magic number values depending on the platform
 449   # byte ordering
 450   cmp_ok($im->errstr, '=~',
 451          "Error opening file: Not a TIFF (?:or MDI )?file, bad magic number (8483 \\(0x2123\\)|8993 \\(0x2321\\))",
 452          "check error message");
 453   my @ims = Imager->read_multi(file =>'t/t106tiff.t', type=>'tiff');
 454   ok(!@ims, "fail to read_multi script as image");
 455   cmp_ok($im->errstr, '=~',
 456          "Error opening file: Not a TIFF (?:or MDI )?file, bad magic number (8483 \\(0x2123\\)|8993 \\(0x2321\\))",
 457          "check error message");
 458 }
 459
 460 { # write_multi to data
 461   my $data;
 462   my $im = Imager->new(xsize => 50, ysize => 50);
 463   ok(Imager->write_multi({ data => \$data, type=>'tiff' }, $im, $im),
 464      "write multi to in memory");
 465   ok(length $data, "make sure something written");
 466   my @im = Imager->read_multi(data => $data);
 467   is(@im, 2, "make sure we can read it back");
 468   is(Imager::i_img_diff($im[0]{IMG}, $im->{IMG}), 0,
 469      "check first image");
 470   is(Imager::i_img_diff($im[1]{IMG}, $im->{IMG}), 0,
 471      "check second image");
 472 }
 473
 474 { # handling of an alpha channel for various images
 475   my $photo_rgb = 2;
 476   my $photo_cmyk = 5;
 477   my $photo_cielab = 8;
 478   my @alpha_images =
 479     (
 480      [ 'srgb.tif',    3, $photo_rgb,    '003005005' ],
 481      [ 'srgba.tif',   4, $photo_rgb,    '003005005' ],
 482      [ 'srgbaa.tif',  4, $photo_rgb,    '003005005' ],
 483      [ 'scmyk.tif',   3, $photo_cmyk,   '003005005' ],
 484      [ 'scmyka.tif',  4, $photo_cmyk,   '003005005' ],
 485      [ 'scmykaa.tif', 4, $photo_cmyk,   '003005005' ],
 486      [ 'slab.tif',    3, $photo_cielab, '003006001' ],
 487     );
 488
 489   for my $test (@alpha_images) {
 490     my ($input, $channels, $photo, $need_ver) = @$test;
 491
 492   SKIP: {
 493       my $skipped = $channels == 4 ? 4 : 3;
 494       $need_ver le $cmp_ver
 495         or skip("Your ancient tifflib is buggy/limited for this test", $skipped);
 496       my $im = Imager->new;
 497       ok($im->read(file => "testimg/$input"),
 498          "read alpha test $input")
 499         or print "# ", $im->errstr, "\n";
 500       is($im->getchannels, $channels, "channels for $input match");
 501       is($im->tags(name=>'tiff_photometric'), $photo,
 502          "photometric for $input match");
 503       $channels == 4
 504         or next;
 505       my $c = $im->getpixel(x => 0, 'y' => 7);
 506       is(($c->rgba)[3], 0, "bottom row should have 0 alpha");
 507     }
 508   }
 509 }
 510
 511 {
 512   ok(grep($_ eq 'tiff', Imager->read_types), "check tiff in read types");
 513   ok(grep($_ eq 'tiff', Imager->write_types), "check tiff in write types");
 514 }
 515
 516 { # reading tile based images
 517   my $im = Imager->new;
 518   ok($im->read(file => 'testimg/pengtile.tif'), "read tiled image")
 519     or print "# ", $im->errstr, "\n";
 520   # compare it
 521   my $comp = Imager->new;
 522   ok($comp->read(file => 'testimg/penguin-base.ppm'), 'read comparison image');
 523   is_image($im, $comp, 'compare them');
 524 }
 525
 526 SKIP:
 527 { # failing to read tile based images
 528   # we grab our tiled image and patch a tile offset to nowhere
 529   ok(open(TIFF, '< testimg/pengtile.tif'), 'open pengtile.tif')
 530     or skip 'cannot open testimg/pengtile.tif', 4;
 531
 532   $cmp_ver ge '003005007'
 533     or skip("Your ancient tifflib has bad error handling", 4);
 534   binmode TIFF;
 535   my $data = do { local $/; <TIFF>; };
 536
 537   # patch a tile offset
 538   substr($data, 0x1AFA0, 4) = pack("H*", "00000200");
 539
 540   #open PIPE, "| bytedump -a | less" or die;
 541   #print PIPE $data;
 542   #close PIPE;
 543
 544   my $allow = Imager->new;
 545   ok($allow->read(data => $data, allow_incomplete => 1),
 546      "read incomplete tiled");
 547   ok($allow->tags(name => 'i_incomplete'), 'i_incomplete set');
 548   is($allow->tags(name => 'i_lines_read'), 173,
 549      'check i_lines_read set appropriately');
 550
 551   my $fail = Imager->new;
 552   ok(!$fail->read(data => $data), "read fail tiled");
 553 }
 554
 555 { # read 16-bit/sample
 556   my $im16 = Imager->new;
 557   ok($im16->read(file => 'testimg/rgb16.tif'), "read 16-bit rgb");
 558   is($im16->bits, 16, 'got a 16-bit image');
 559   my $im16t = Imager->new;
 560   ok($im16t->read(file => 'testimg/rgb16t.tif'), "read 16-bit rgb tiled");
 561   is($im16t->bits, 16, 'got a 16-bit image');
 562   is_image($im16, $im16t, 'check they match');
 563
 564   my $grey16 = Imager->new;
 565   ok($grey16->read(file => 'testimg/grey16.tif'), "read 16-bit grey")
 566     or print "# ", $grey16->errstr, "\n";
 567   is($grey16->bits, 16, 'got a 16-bit image');
 568   is($grey16->getchannels, 1, 'and its grey');
 569   my $comp16 = $im16->convert(matrix => [ [ 0.299, 0.587, 0.114 ] ]);
 570   is_image($grey16, $comp16, 'compare grey to converted');
 571
 572   my $grey32 = Imager->new;
 573   ok($grey32->read(file => 'testimg/grey32.tif'), "read 32-bit grey")
 574     or print "# ", $grey32->errstr, "\n";
 575   is($grey32->bits, 'double', 'got a double image');
 576   is($grey32->getchannels, 2, 'and its grey + alpha');
 577   is($grey32->tags(name => 'tiff_bitspersample'), 32,
 578      "check bits per sample");
 579   my $base = test_image_double->convert(preset =>'grey')
 580     ->convert(preset => 'addalpha');
 581   is_image($grey32, $base, 'compare to original');
 582 }
 583
 584 { # read 16, 32-bit/sample and compare to the original
 585   my $rgba = Imager->new;
 586   ok($rgba->read(file => 'testimg/srgba.tif'),
 587      "read base rgba image");
 588   my $rgba16 = Imager->new;
 589   ok($rgba16->read(file => 'testimg/srgba16.tif'),
 590      "read 16-bit/sample rgba image");
 591   is_image($rgba, $rgba16, "check they match");
 592   is($rgba16->bits, 16, 'check we got the right type');
 593
 594   my $rgba32 = Imager->new;
 595   ok($rgba32->read(file => 'testimg/srgba32.tif'),
 596      "read 32-bit/sample rgba image");
 597   is_image($rgba, $rgba32, "check they match");
 598   is($rgba32->bits, 'double', 'check we got the right type');
 599
 600   my $cmyka16 = Imager->new;
 601   ok($cmyka16->read(file => 'testimg/scmyka16.tif'),
 602      "read cmyk 16-bit")
 603     or print "# ", $cmyka16->errstr, "\n";
 604   is($cmyka16->bits, 16, "check we got the right type");
 605   is_image_similar($rgba, $cmyka16, 10, "check image data");
 606
 607   # tiled, non-contig, should fallback to RGBA code
 608   my $rgbatsep = Imager->new;
 609   ok($rgbatsep->read(file => 'testimg/rgbatsep.tif'),
 610      "read tiled, separated rgba image")
 611     or diag($rgbatsep->errstr);
 612   is_image($rgba, $rgbatsep, "check they match");
 613 }
 614 { # read bi-level
 615   my $pbm = Imager->new;
 616   ok($pbm->read(file => 'testimg/imager.pbm'), "read original pbm");
 617   my $tif = Imager->new;
 618   ok($tif->read(file => 'testimg/imager.tif'), "read mono tif");
 619   is_image($pbm, $tif, "compare them");
 620   is($tif->type, 'paletted', 'check image type');
 621   is($tif->colorcount, 2, 'check we got a "mono" image');
 622 }
 623
 624 { # check alpha channels scaled correctly for fallback handler
 625   my $im = Imager->new;
 626   ok($im->read(file=>'testimg/alpha.tif'), 'read alpha check image');
 627   my @colors =
 628     (
 629      [ 0, 0, 0 ],
 630      [ 255, 255, 255 ],
 631      [ 127, 0, 127 ],
 632      [ 127, 127, 0 ],
 633     );
 634   my @alphas = ( 255, 191, 127, 63 );
 635   my $ok = 1;
 636   my $msg = 'alpha check ok';
 637  CHECKER:
 638   for my $y (0 .. 3) {
 639     for my $x (0 .. 3) {
 640       my $c = $im->getpixel(x => $x, 'y' => $y);
 641       my @c = $c->rgba;
 642       my $alpha = pop @c;
 643       if ($alpha != $alphas[$y]) {
 644         $ok = 0;
 645         $msg = "($x,$y) alpha mismatch $alpha vs $alphas[$y]";
 646         last CHECKER;
 647       }
 648       my $expect = $colors[$x];
 649       for my $ch (0 .. 2) {
 650         if (abs($expect->[$ch]-$c[$ch]) > 3) {
 651           $ok = 0;
 652           $msg = "($x,$y)[$ch] color mismatch got $c[$ch] vs expected $expect->[$ch]";
 653           last CHECKER;
 654         }
 655       }
 656     }
 657   }
 658   ok($ok, $msg);
 659 }
 660
 661 { # check alpha channels scaled correctly for greyscale
 662   my $im = Imager->new;
 663   ok($im->read(file=>'testimg/gralpha.tif'), 'read alpha check grey image');
 664   my @greys = ( 0, 255, 52, 112 );
 665   my @alphas = ( 255, 191, 127, 63 );
 666   my $ok = 1;
 667   my $msg = 'alpha check ok';
 668  CHECKER:
 669   for my $y (0 .. 3) {
 670     for my $x (0 .. 3) {
 671       my $c = $im->getpixel(x => $x, 'y' => $y);
 672       my ($grey, $alpha) = $c->rgba;
 673       if ($alpha != $alphas[$y]) {
 674         $ok = 0;
 675         $msg = "($x,$y) alpha mismatch $alpha vs $alphas[$y]";
 676         last CHECKER;
 677       }
 678       if (abs($greys[$x] - $grey) > 3) {
 679         $ok = 0;
 680         $msg = "($x,$y) grey mismatch $grey vs $greys[$x]";
 681         last CHECKER;
 682       }
 683     }
 684   }
 685   ok($ok, $msg);
 686 }
 687
 688 { # 16-bit writes
 689   my $orig = test_image_16();
 690   my $data;
 691   ok($orig->write(data => \$data, type => 'tiff',
 692                   tiff_compression => 'none'), "write 16-bit/sample");
 693   my $im = Imager->new;
 694   ok($im->read(data => $data), "read it back");
 695   is_image($im, $orig, "check read data matches");
 696   is($im->tags(name => 'tiff_bitspersample'), 16, "correct bits");
 697   is($im->bits, 16, 'check image bits');
 698   is($im->tags(name => 'tiff_photometric'), 2, "correct photometric");
 699     is($im->tags(name => 'tiff_compression'), 'none', "no compression");
 700   is($im->getchannels, 3, 'correct channels');
 701 }
 702
 703 { # 8-bit writes
 704   # and check compression
 705   my $compress = Imager::File::TIFF::i_tiff_has_compression('lzw') ? 'lzw' : 'packbits';
 706   my $orig = test_image()->convert(preset=>'grey')
 707     ->convert(preset => 'addalpha');
 708   my $data;
 709   ok($orig->write(data => \$data, type => 'tiff',
 710                   tiff_compression=> $compress),
 711      "write 8 bit")
 712     or print "# ", $orig->errstr, "\n";
 713   my $im = Imager->new;
 714   ok($im->read(data => $data), "read it back");
 715   is_image($im, $orig, "check read data matches");
 716   is($im->tags(name => 'tiff_bitspersample'), 8, 'correct bits');
 717   is($im->bits, 8, 'check image bits');
 718   is($im->tags(name => 'tiff_photometric'), 1, 'correct photometric');
 719   is($im->tags(name => 'tiff_compression'), $compress,
 720      "$compress compression");
 721   is($im->getchannels, 2, 'correct channels');
 722 }
 723
 724 { # double writes
 725   my $orig = test_image_double()->convert(preset=>'addalpha');
 726   my $data;
 727   ok($orig->write(data => \$data, type => 'tiff',
 728                   tiff_compression => 'none'),
 729      "write 32-bit/sample from double")
 730     or print "# ", $orig->errstr, "\n";
 731   my $im = Imager->new;
 732   ok($im->read(data => $data), "read it back");
 733   is_image($im, $orig, "check read data matches");
 734   is($im->tags(name => 'tiff_bitspersample'), 32, "correct bits");
 735   is($im->bits, 'double', 'check image bits');
 736   is($im->tags(name => 'tiff_photometric'), 2, "correct photometric");
 737   is($im->tags(name => 'tiff_compression'), 'none', "no compression");
 738   is($im->getchannels, 4, 'correct channels');
 739 }
 740
 741 { # bilevel
 742   my $im = test_image()->convert(preset => 'grey')
 743     ->to_paletted(make_colors => 'mono',
 744                   translate => 'errdiff');
 745   my $faxdata;
 746
 747   # fax compression is written as miniswhite
 748   ok($im->write(data => \$faxdata, type => 'tiff',
 749                 tiff_compression => 'fax3'),
 750      "write bilevel fax compressed");
 751   my $fax = Imager->new;
 752   ok($fax->read(data => $faxdata), "read it back");
 753   ok($fax->is_bilevel, "got a bi-level image back");
 754   is($fax->tags(name => 'tiff_compression'), 'fax3',
 755      "check fax compression used");
 756   is_image($fax, $im, "compare to original");
 757
 758   # other compresion written as minisblack
 759   my $packdata;
 760   ok($im->write(data => \$packdata, type => 'tiff',
 761                 tiff_compression => 'jpeg'),
 762      "write bilevel packbits compressed");
 763   my $packim = Imager->new;
 764   ok($packim->read(data => $packdata), "read it back");
 765   ok($packim->is_bilevel, "got a bi-level image back");
 766   is($packim->tags(name => 'tiff_compression'), 'packbits',
 767      "check fallback compression used");
 768   is_image($packim, $im, "compare to original");
 769 }
 770
 771 { # fallback handling of tiff
 772   is(Imager::File::TIFF::i_tiff_has_compression('none'), 1, "can always do uncompresed");
 773   is(Imager::File::TIFF::i_tiff_has_compression('xxx'), '', "can't do xxx compression");
 774 }
 775
 776
 777 { # check file limits are checked
 778   my $limit_file = "testout/t106.tiff";
 779   ok(Imager->set_file_limits(reset=>1, width=>149), "set width limit 149");
 780   my $im = Imager->new;
 781   ok(!$im->read(file=>$limit_file),
 782      "should fail read due to size limits");
 783   print "# ",$im->errstr,"\n";
 784   like($im->errstr, qr/image width/, "check message");
 785
 786   ok(Imager->set_file_limits(reset=>1, height=>149), "set height limit 149");
 787   ok(!$im->read(file=>$limit_file),
 788      "should fail read due to size limits");
 789   print "# ",$im->errstr,"\n";
 790   like($im->errstr, qr/image height/, "check message");
 791
 792   ok(Imager->set_file_limits(reset=>1, width=>150), "set width limit 150");
 793   ok($im->read(file=>$limit_file),
 794      "should succeed - just inside width limit");
 795   ok(Imager->set_file_limits(reset=>1, height=>150), "set height limit 150");
 796   ok($im->read(file=>$limit_file),
 797      "should succeed - just inside height limit");
 798
 799   # 150 x 150 x 3 channel image uses 67500 bytes
 800   ok(Imager->set_file_limits(reset=>1, bytes=>67499),
 801      "set bytes limit 67499");
 802   ok(!$im->read(file=>$limit_file),
 803      "should fail - too many bytes");
 804   print "# ",$im->errstr,"\n";
 805   like($im->errstr, qr/storage size/, "check error message");
 806   ok(Imager->set_file_limits(reset=>1, bytes=>67500),
 807      "set bytes limit 67500");
 808   ok($im->read(file=>$limit_file),
 809      "should succeed - just inside bytes limit");
 810   Imager->set_file_limits(reset=>1);
 811 }
 812
 813 {
 814   # this image has an IFD loop, which sends some TIFF readers into a
 815   # loop, including Corel PhotoPaint and the GIMP's tiff reader.
 816   my $ifdloop_hex = <<HEX;
 817 49 49 2A 00 0A 00 00 00 FE 00 0A 00 00 01 03 00
 818 01 00 00 00 01 00 00 00 01 01 03 00 01 00 00 00
 819 01 00 00 00 02 01 03 00 03 00 00 00 88 00 00 00
 820 03 01 03 00 01 00 00 00 05 80 00 00 06 01 03 00
 821 01 00 00 00 02 00 00 00 11 01 04 00 01 00 00 00
 822 08 00 00 00 12 01 03 00 01 00 00 00 01 00 00 00
 823 15 01 03 00 01 00 00 00 03 00 00 00 17 01 04 00
 824 01 00 00 00 02 00 00 00 1C 01 03 00 01 00 00 00
 825 01 00 00 00 90 00 00 00 08 00 08 00 08 00 FE 00
 826 0A 00 00 01 03 00 01 00 00 00 01 00 00 00 01 01
 827 03 00 01 00 00 00 01 00 00 00 02 01 03 00 03 00
 828 00 00 0E 01 00 00 03 01 03 00 01 00 00 00 05 80
 829 00 00 06 01 03 00 01 00 00 00 02 00 00 00 11 01
 830 04 00 01 00 00 00 8E 00 00 00 12 01 03 00 01 00
 831 00 00 01 00 00 00 15 01 03 00 01 00 00 00 03 00
 832 00 00 17 01 04 00 01 00 00 00 02 00 00 00 1C 01
 833 03 00 01 00 00 00 01 00 00 00 0A 00 00 00 08 00
 834 08 00 08 00
 835 HEX
 836   $ifdloop_hex =~ tr/0-9A-F//cd;
 837   my $ifdloop = pack("H*", $ifdloop_hex);
 838
 839   my $im = Imager->new;
 840   ok($im->read(data => $ifdloop, type => "tiff", page => 1),
 841      "read what should be valid");
 842   ok(!$im->read(data => $ifdloop, type => "tiff", page => 2),
 843      "third page is after looping back to the start, if this fails, upgrade tifflib")
 844     or skip("tifflib is broken", 1);
 845   print "# ", $im->errstr, "\n";
 846   my @im = Imager->read_multi(type => "tiff", data => $ifdloop);
 847   is(@im, 2, "should be only 2 images");
 848 }