t/t106tiff.t

   1 #!perl -w
   2 use strict;
   3 use Test::More;
   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 i_has_format("tiff")
   8   or plan skip_all => "no tiff support";
   9
  10 plan tests => 215;
  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::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(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 = i_readtiff_wiol($IO, -1);
  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::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(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   my $out = substr($work, $seekpos, $maxread);
 209   $seekpos += length $out;
 210   $out;
 211 }
 212 sub io_reader2 {
 213   my ($size, $maxread) = @_;
 214   #print "io_reader2($size, $maxread) pos $seekpos\n";
 215   my $out = substr($work, $seekpos, $size);
 216   $seekpos += length $out;
 217   $out;
 218 }
 219 use IO::Seekable;
 220 sub io_seeker {
 221   my ($offset, $whence) = @_;
 222   #print "io_seeker($offset, $whence)\n";
 223   if ($whence == SEEK_SET) {
 224     $seekpos = $offset;
 225   }
 226   elsif ($whence == SEEK_CUR) {
 227     $seekpos += $offset;
 228   }
 229   else { # SEEK_END
 230     $seekpos = length($work) + $offset;
 231   }
 232   #print "-> $seekpos\n";
 233   $seekpos;
 234 }
 235 my $did_close;
 236 sub io_closer {
 237   ++$did_close;
 238 }
 239
 240 # read via cb
 241 $work = $tiffdata;
 242 $seekpos = 0;
 243 my $IO2 = Imager::io_new_cb(undef, \&io_reader, \&io_seeker, undef);
 244 ok($IO2, "new readcb obj");
 245 my $img5 = i_readtiff_wiol($IO2, -1);
 246 ok($img5, "read via cb");
 247 ok(i_img_diff($img5, $img) == 0, "read from cb diff");
 248
 249 # read via cb2
 250 $work = $tiffdata;
 251 $seekpos = 0;
 252 my $IO3 = Imager::io_new_cb(undef, \&io_reader2, \&io_seeker, undef);
 253 ok($IO3, "new readcb2 obj");
 254 my $img6 = i_readtiff_wiol($IO3, -1);
 255 ok($img6, "read via cb2");
 256 ok(i_img_diff($img6, $img) == 0, "read from cb2 diff");
 257
 258 # write via cb
 259 $work = '';
 260 $seekpos = 0;
 261 my $IO4 = Imager::io_new_cb(\&io_writer, \&io_reader, \&io_seeker,
 262                             \&io_closer);
 263 ok($IO4, "new writecb obj");
 264 ok(i_writetiff_wiol($img, $IO4), "write to cb");
 265 is($work, $odata, "write cb match");
 266 ok($did_close, "write cb did close");
 267 open D1, ">testout/d1.tiff" or die;
 268 print D1 $work;
 269 close D1;
 270 open D2, ">testout/d2.tiff" or die;
 271 print D2 $tiffdata;
 272 close D2;
 273
 274 # write via cb2
 275 $work = '';
 276 $seekpos = 0;
 277 $did_close = 0;
 278 my $IO5 = Imager::io_new_cb(\&io_writer, \&io_reader, \&io_seeker,
 279                             \&io_closer, 1);
 280 ok($IO5, "new writecb obj 2");
 281 ok(i_writetiff_wiol($img, $IO5), "write to cb2");
 282 is($work, $odata, "write cb2 match");
 283 ok($did_close, "write cb2 did close");
 284
 285 open D3, ">testout/d3.tiff" or die;
 286 print D3 $work;
 287 close D3;
 288
 289 # multi-image write/read
 290 my @imgs;
 291 push(@imgs, map $ooim->copy(), 1..3);
 292 for my $i (0..$#imgs) {
 293   $imgs[$i]->addtag(name=>"tiff_pagename", value=>"Page ".($i+1));
 294 }
 295 my $rc = Imager->write_multi({file=>'testout/t106_multi.tif'}, @imgs);
 296 ok($rc, "writing multiple images to tiff");
 297 my @out = Imager->read_multi(file=>'testout/t106_multi.tif');
 298 ok(@out == @imgs, "reading multiple images from tiff");
 299 @out == @imgs or print "# ",scalar @out, " ",Imager->errstr,"\n";
 300 for my $i (0..$#imgs) {
 301   ok(i_img_diff($imgs[$i]{IMG}, $out[$i]{IMG}) == 0,
 302      "comparing image $i");
 303   my ($tag) = $out[$i]->tags(name=>'tiff_pagename');
 304   is($tag, "Page ".($i+1),
 305      "tag doesn't match original image");
 306 }
 307
 308 # writing even more images to tiff - we weren't handling more than five
 309 # correctly on read
 310 @imgs = map $ooim->copy(), 1..40;
 311 $rc = Imager->write_multi({file=>'testout/t106_multi2.tif'}, @imgs);
 312 ok($rc, "writing 40 images to tiff");
 313 @out = Imager->read_multi(file=>'testout/t106_multi2.tif');
 314 ok(@imgs == @out, "reading 40 images from tiff");
 315 # force some allocation activity - helps crash here if it's the problem
 316 @out = @imgs = ();
 317
 318 # multi-image fax files
 319 ok(Imager->write_multi({file=>'testout/t106_faxmulti.tiff', class=>'fax'},
 320                        $oofim, $oofim), "write multi fax image");
 321 @imgs = Imager->read_multi(file=>'testout/t106_faxmulti.tiff');
 322 ok(@imgs == 2, "reading multipage fax");
 323 ok(Imager::i_img_diff($imgs[0]{IMG}, $oofim->{IMG}) == 0,
 324    "compare first fax image");
 325 ok(Imager::i_img_diff($imgs[1]{IMG}, $oofim->{IMG}) == 0,
 326    "compare second fax image");
 327
 328 my ($format) = $imgs[0]->tags(name=>'i_format');
 329 is($format, 'tiff', "check i_format tag");
 330
 331 my $unit = $imgs[0]->tags(name=>'tiff_resolutionunit');
 332 ok(defined $unit && $unit == 2, "check tiff_resolutionunit tag");
 333 my $unitname = $imgs[0]->tags(name=>'tiff_resolutionunit_name');
 334 is($unitname, 'inch', "check tiff_resolutionunit_name tag");
 335
 336 my $warned = Imager->new;
 337 ok($warned->read(file=>"testimg/tiffwarn.tif"), "read tiffwarn.tif");
 338 my ($warning) = $warned->tags(name=>'i_warning');
 339 ok(defined $warning && $warning =~ /unknown field with tag 28712/,
 340    "check that warning tag set and correct");
 341
 342 { # support for reading a given page
 343   # first build a simple test image
 344   my $im1 = Imager->new(xsize=>50, ysize=>50);
 345   $im1->box(filled=>1, color=>$blue);
 346   $im1->addtag(name=>'tiff_pagename', value => "Page One");
 347   my $im2 = Imager->new(xsize=>60, ysize=>60);
 348   $im2->box(filled=>1, color=>$green);
 349   $im2->addtag(name=>'tiff_pagename', value=>"Page Two");
 350
 351   # read second page
 352   my $page_file = 'testout/t106_pages.tif';
 353   ok(Imager->write_multi({ file=> $page_file}, $im1, $im2),
 354      "build simple multiimage for page tests");
 355   my $imwork = Imager->new;
 356   ok($imwork->read(file=>$page_file, page=>1),
 357      "read second page");
 358   is($im2->getwidth, $imwork->getwidth, "check width");
 359   is($im2->getwidth, $imwork->getheight, "check height");
 360   is(i_img_diff($imwork->{IMG}, $im2->{IMG}), 0,
 361      "check image content");
 362   my ($page_name) = $imwork->tags(name=>'tiff_pagename');
 363   is($page_name, 'Page Two', "check tag we set");
 364
 365   # try an out of range page
 366   ok(!$imwork->read(file=>$page_file, page=>2),
 367      "check out of range page");
 368   is($imwork->errstr, "could not switch to page 2", "check message");
 369 }
 370
 371 { # test writing returns an error message correctly
 372   # open a file read only and try to write to it
 373   open TIFF, "> testout/t106_empty.tif" or die;
 374   close TIFF;
 375   open TIFF, "< testout/t106_empty.tif"
 376     or skip "Cannot open testout/t106_empty.tif for reading", 8;
 377   binmode TIFF;
 378   my $im = Imager->new(xsize=>100, ysize=>100);
 379   ok(!$im->write(fh => \*TIFF, type=>'tiff'),
 380      "fail to write to read only handle");
 381   cmp_ok($im->errstr, '=~', 'Could not create TIFF object: Error writing TIFF header: write\(\)',
 382          "check error message");
 383   ok(!Imager->write_multi({ type => 'tiff', fh => \*TIFF }, $im),
 384      "fail to write multi to read only handle");
 385   cmp_ok(Imager->errstr, '=~', 'Could not create TIFF object: Error writing TIFF header: write\(\)',
 386          "check error message");
 387   ok(!$im->write(fh => \*TIFF, type=>'tiff', class=>'fax'),
 388      "fail to write to read only handle (fax)");
 389   cmp_ok($im->errstr, '=~', 'Could not create TIFF object: Error writing TIFF header: write\(\)',
 390          "check error message");
 391   ok(!Imager->write_multi({ type => 'tiff', fh => \*TIFF, class=>'fax' }, $im),
 392      "fail to write multi to read only handle (fax)");
 393   cmp_ok(Imager->errstr, '=~', 'Could not create TIFF object: Error writing TIFF header: write\(\)',
 394          "check error message");
 395 }
 396
 397 { # test reading returns an error correctly - use test script as an
 398   # invalid TIFF file
 399   my $im = Imager->new;
 400   ok(!$im->read(file=>'t/t106tiff.t', type=>'tiff'),
 401      "fail to read script as image");
 402   # we get different magic number values depending on the platform
 403   # byte ordering
 404   cmp_ok($im->errstr, '=~',
 405          "Error opening file: Not a TIFF (?:or MDI )?file, bad magic number (8483 \\(0x2123\\)|8993 \\(0x2321\\))",
 406          "check error message");
 407   my @ims = Imager->read_multi(file =>'t/t106tiff.t', type=>'tiff');
 408   ok(!@ims, "fail to read_multi script as image");
 409   cmp_ok($im->errstr, '=~',
 410          "Error opening file: Not a TIFF (?:or MDI )?file, bad magic number (8483 \\(0x2123\\)|8993 \\(0x2321\\))",
 411          "check error message");
 412 }
 413
 414 { # write_multi to data
 415   my $data;
 416   my $im = Imager->new(xsize => 50, ysize => 50);
 417   ok(Imager->write_multi({ data => \$data, type=>'tiff' }, $im, $im),
 418      "write multi to in memory");
 419   ok(length $data, "make sure something written");
 420   my @im = Imager->read_multi(data => $data);
 421   is(@im, 2, "make sure we can read it back");
 422   is(Imager::i_img_diff($im[0]{IMG}, $im->{IMG}), 0,
 423      "check first image");
 424   is(Imager::i_img_diff($im[1]{IMG}, $im->{IMG}), 0,
 425      "check second image");
 426 }
 427
 428 { # handling of an alpha channel for various images
 429   my $photo_rgb = 2;
 430   my $photo_cmyk = 5;
 431   my $photo_cielab = 8;
 432   my @alpha_images =
 433     (
 434      [ 'srgb.tif',    3, $photo_rgb,    '003005005' ],
 435      [ 'srgba.tif',   4, $photo_rgb,    '003005005' ],
 436      [ 'srgbaa.tif',  4, $photo_rgb,    '003005005' ],
 437      [ 'scmyk.tif',   3, $photo_cmyk,   '003005005' ],
 438      [ 'scmyka.tif',  4, $photo_cmyk,   '003005005' ],
 439      [ 'scmykaa.tif', 4, $photo_cmyk,   '003005005' ],
 440      [ 'slab.tif',    3, $photo_cielab, '003006001' ],
 441     );
 442
 443   for my $test (@alpha_images) {
 444     my ($input, $channels, $photo, $need_ver) = @$test;
 445
 446   SKIP: {
 447       my $skipped = $channels == 4 ? 4 : 3;
 448       $need_ver le $cmp_ver
 449         or skip("Your ancient tifflib is buggy/limited for this test", $skipped);
 450       my $im = Imager->new;
 451       ok($im->read(file => "testimg/$input"),
 452          "read alpha test $input")
 453         or print "# ", $im->errstr, "\n";
 454       is($im->getchannels, $channels, "channels for $input match");
 455       is($im->tags(name=>'tiff_photometric'), $photo,
 456          "photometric for $input match");
 457       $channels == 4
 458         or next;
 459       my $c = $im->getpixel(x => 0, 'y' => 7);
 460       is(($c->rgba)[3], 0, "bottom row should have 0 alpha");
 461     }
 462   }
 463 }
 464
 465 {
 466   ok(grep($_ eq 'tiff', Imager->read_types), "check tiff in read types");
 467   ok(grep($_ eq 'tiff', Imager->write_types), "check tiff in write types");
 468 }
 469
 470 { # reading tile based images
 471   my $im = Imager->new;
 472   ok($im->read(file => 'testimg/pengtile.tif'), "read tiled image")
 473     or print "# ", $im->errstr, "\n";
 474   # compare it
 475   my $comp = Imager->new;
 476   ok($comp->read(file => 'testimg/penguin-base.ppm'), 'read comparison image');
 477   is_image($im, $comp, 'compare them');
 478 }
 479
 480 SKIP:
 481 { # failing to read tile based images
 482   # we grab our tiled image and patch a tile offset to nowhere
 483   ok(open(TIFF, '< testimg/pengtile.tif'), 'open pengtile.tif')
 484     or skip 'cannot open testimg/pengtile.tif', 4;
 485
 486   $cmp_ver ge '003005007'
 487     or skip("Your ancient tifflib has bad error handling", 4);
 488   binmode TIFF;
 489   my $data = do { local $/; <TIFF>; };
 490
 491   # patch a tile offset
 492   substr($data, 0x1AFA0, 4) = pack("H*", "00000200");
 493
 494   #open PIPE, "| bytedump -a | less" or die;
 495   #print PIPE $data;
 496   #close PIPE;
 497
 498   my $allow = Imager->new;
 499   ok($allow->read(data => $data, allow_incomplete => 1),
 500      "read incomplete tiled");
 501   ok($allow->tags(name => 'i_incomplete'), 'i_incomplete set');
 502   is($allow->tags(name => 'i_lines_read'), 173,
 503      'check i_lines_read set appropriately');
 504
 505   my $fail = Imager->new;
 506   ok(!$fail->read(data => $data), "read fail tiled");
 507 }
 508
 509 { # read 16-bit/sample
 510   my $im16 = Imager->new;
 511   ok($im16->read(file => 'testimg/rgb16.tif'), "read 16-bit rgb");
 512   is($im16->bits, 16, 'got a 16-bit image');
 513   my $im16t = Imager->new;
 514   ok($im16t->read(file => 'testimg/rgb16t.tif'), "read 16-bit rgb tiled");
 515   is($im16t->bits, 16, 'got a 16-bit image');
 516   is_image($im16, $im16t, 'check they match');
 517
 518   my $grey16 = Imager->new;
 519   ok($grey16->read(file => 'testimg/grey16.tif'), "read 16-bit grey")
 520     or print "# ", $grey16->errstr, "\n";
 521   is($grey16->bits, 16, 'got a 16-bit image');
 522   is($grey16->getchannels, 1, 'and its grey');
 523   my $comp16 = $im16->convert(matrix => [ [ 0.299, 0.587, 0.114 ] ]);
 524   is_image($grey16, $comp16, 'compare grey to converted');
 525
 526   my $grey32 = Imager->new;
 527   ok($grey32->read(file => 'testimg/grey32.tif'), "read 32-bit grey")
 528     or print "# ", $grey32->errstr, "\n";
 529   is($grey32->bits, 'double', 'got a double image');
 530   is($grey32->getchannels, 2, 'and its grey + alpha');
 531   is($grey32->tags(name => 'tiff_bitspersample'), 32,
 532      "check bits per sample");
 533   my $base = test_image_double->convert(preset =>'grey')
 534     ->convert(preset => 'addalpha');
 535   is_image($grey32, $base, 'compare to original');
 536 }
 537
 538 { # read 16, 32-bit/sample and compare to the original
 539   my $rgba = Imager->new;
 540   ok($rgba->read(file => 'testimg/srgba.tif'),
 541      "read base rgba image");
 542   my $rgba16 = Imager->new;
 543   ok($rgba16->read(file => 'testimg/srgba16.tif'),
 544      "read 16-bit/sample rgba image");
 545   is_image($rgba, $rgba16, "check they match");
 546   is($rgba16->bits, 16, 'check we got the right type');
 547
 548   my $rgba32 = Imager->new;
 549   ok($rgba32->read(file => 'testimg/srgba32.tif'),
 550      "read 32-bit/sample rgba image");
 551   is_image($rgba, $rgba32, "check they match");
 552   is($rgba32->bits, 'double', 'check we got the right type');
 553
 554   my $cmyka16 = Imager->new;
 555   ok($cmyka16->read(file => 'testimg/scmyka16.tif'),
 556      "read cmyk 16-bit")
 557     or print "# ", $cmyka16->errstr, "\n";
 558   is($cmyka16->bits, 16, "check we got the right type");
 559   is_image_similar($rgba, $cmyka16, 10, "check image data");
 560
 561   # tiled, non-contig, should fallback to RGBA code
 562   my $rgbatsep = Imager->new;
 563   ok($rgbatsep->read(file => 'testimg/rgbatsep.tif'),
 564      "read tiled, separated rgba image")
 565     or diag($rgbatsep->errstr);
 566   is_image($rgba, $rgbatsep, "check they match");
 567 }
 568 { # read bi-level
 569   my $pbm = Imager->new;
 570   ok($pbm->read(file => 'testimg/imager.pbm'), "read original pbm");
 571   my $tif = Imager->new;
 572   ok($tif->read(file => 'testimg/imager.tif'), "read mono tif");
 573   is_image($pbm, $tif, "compare them");
 574   is($tif->type, 'paletted', 'check image type');
 575   is($tif->colorcount, 2, 'check we got a "mono" image');
 576 }
 577
 578 { # check alpha channels scaled correctly for fallback handler
 579   my $im = Imager->new;
 580   ok($im->read(file=>'testimg/alpha.tif'), 'read alpha check image');
 581   my @colors =
 582     (
 583      [ 0, 0, 0 ],
 584      [ 255, 255, 255 ],
 585      [ 127, 0, 127 ],
 586      [ 127, 127, 0 ],
 587     );
 588   my @alphas = ( 255, 191, 127, 63 );
 589   my $ok = 1;
 590   my $msg = 'alpha check ok';
 591  CHECKER:
 592   for my $y (0 .. 3) {
 593     for my $x (0 .. 3) {
 594       my $c = $im->getpixel(x => $x, 'y' => $y);
 595       my @c = $c->rgba;
 596       my $alpha = pop @c;
 597       if ($alpha != $alphas[$y]) {
 598         $ok = 0;
 599         $msg = "($x,$y) alpha mismatch $alpha vs $alphas[$y]";
 600         last CHECKER;
 601       }
 602       my $expect = $colors[$x];
 603       for my $ch (0 .. 2) {
 604         if (abs($expect->[$ch]-$c[$ch]) > 3) {
 605           $ok = 0;
 606           $msg = "($x,$y)[$ch] color mismatch got $c[$ch] vs expected $expect->[$ch]";
 607           last CHECKER;
 608         }
 609       }
 610     }
 611   }
 612   ok($ok, $msg);
 613 }
 614
 615 { # check alpha channels scaled correctly for greyscale
 616   my $im = Imager->new;
 617   ok($im->read(file=>'testimg/gralpha.tif'), 'read alpha check grey image');
 618   my @greys = ( 0, 255, 52, 112 );
 619   my @alphas = ( 255, 191, 127, 63 );
 620   my $ok = 1;
 621   my $msg = 'alpha check ok';
 622  CHECKER:
 623   for my $y (0 .. 3) {
 624     for my $x (0 .. 3) {
 625       my $c = $im->getpixel(x => $x, 'y' => $y);
 626       my ($grey, $alpha) = $c->rgba;
 627       if ($alpha != $alphas[$y]) {
 628         $ok = 0;
 629         $msg = "($x,$y) alpha mismatch $alpha vs $alphas[$y]";
 630         last CHECKER;
 631       }
 632       if (abs($greys[$x] - $grey) > 3) {
 633         $ok = 0;
 634         $msg = "($x,$y) grey mismatch $grey vs $greys[$x]";
 635         last CHECKER;
 636       }
 637     }
 638   }
 639   ok($ok, $msg);
 640 }
 641
 642 { # 16-bit writes
 643   my $orig = test_image_16();
 644   my $data;
 645   ok($orig->write(data => \$data, type => 'tiff',
 646                   tiff_compression => 'none'), "write 16-bit/sample");
 647   my $im = Imager->new;
 648   ok($im->read(data => $data), "read it back");
 649   is_image($im, $orig, "check read data matches");
 650   is($im->tags(name => 'tiff_bitspersample'), 16, "correct bits");
 651   is($im->bits, 16, 'check image bits');
 652   is($im->tags(name => 'tiff_photometric'), 2, "correct photometric");
 653     is($im->tags(name => 'tiff_compression'), 'none', "no compression");
 654   is($im->getchannels, 3, 'correct channels');
 655 }
 656
 657 { # 8-bit writes
 658   # and check compression
 659   my $compress = Imager::i_tiff_has_compression('lzw') ? 'lzw' : 'packbits';
 660   my $orig = test_image()->convert(preset=>'grey')
 661     ->convert(preset => 'addalpha');
 662   my $data;
 663   ok($orig->write(data => \$data, type => 'tiff',
 664                   tiff_compression=> $compress),
 665      "write 8 bit")
 666     or print "# ", $orig->errstr, "\n";
 667   my $im = Imager->new;
 668   ok($im->read(data => $data), "read it back");
 669   is_image($im, $orig, "check read data matches");
 670   is($im->tags(name => 'tiff_bitspersample'), 8, 'correct bits');
 671   is($im->bits, 8, 'check image bits');
 672   is($im->tags(name => 'tiff_photometric'), 1, 'correct photometric');
 673   is($im->tags(name => 'tiff_compression'), $compress,
 674      "$compress compression");
 675   is($im->getchannels, 2, 'correct channels');
 676 }
 677
 678 { # double writes
 679   my $orig = test_image_double()->convert(preset=>'addalpha');
 680   my $data;
 681   ok($orig->write(data => \$data, type => 'tiff',
 682                   tiff_compression => 'none'),
 683      "write 32-bit/sample from double")
 684     or print "# ", $orig->errstr, "\n";
 685   my $im = Imager->new;
 686   ok($im->read(data => $data), "read it back");
 687   is_image($im, $orig, "check read data matches");
 688   is($im->tags(name => 'tiff_bitspersample'), 32, "correct bits");
 689   is($im->bits, 'double', 'check image bits');
 690   is($im->tags(name => 'tiff_photometric'), 2, "correct photometric");
 691   is($im->tags(name => 'tiff_compression'), 'none', "no compression");
 692   is($im->getchannels, 4, 'correct channels');
 693 }
 694
 695 { # bilevel
 696   my $im = test_image()->convert(preset => 'grey')
 697     ->to_paletted(make_colors => 'mono',
 698                   translate => 'errdiff');
 699   my $faxdata;
 700
 701   # fax compression is written as miniswhite
 702   ok($im->write(data => \$faxdata, type => 'tiff',
 703                 tiff_compression => 'fax3'),
 704      "write bilevel fax compressed");
 705   my $fax = Imager->new;
 706   ok($fax->read(data => $faxdata), "read it back");
 707   ok($fax->is_bilevel, "got a bi-level image back");
 708   is($fax->tags(name => 'tiff_compression'), 'fax3',
 709      "check fax compression used");
 710   is_image($fax, $im, "compare to original");
 711
 712   # other compresion written as minisblack
 713   my $packdata;
 714   ok($im->write(data => \$packdata, type => 'tiff',
 715                 tiff_compression => 'jpeg'),
 716      "write bilevel packbits compressed");
 717   my $packim = Imager->new;
 718   ok($packim->read(data => $packdata), "read it back");
 719   ok($packim->is_bilevel, "got a bi-level image back");
 720   is($packim->tags(name => 'tiff_compression'), 'packbits',
 721      "check fallback compression used");
 722   is_image($packim, $im, "compare to original");
 723 }
 724
 725 { # fallback handling of tiff
 726   is(Imager::i_tiff_has_compression('none'), 1, "can always do uncompresed");
 727   is(Imager::i_tiff_has_compression('xxx'), '', "can't do xxx compression");
 728 }
 729
 730