#!perl -w use strict; use Test::More tests => 247; use Imager qw(:all); use Imager::Test qw(is_image is_image_similar test_image test_image_16 test_image_double test_image_raw); BEGIN { use_ok("Imager::File::TIFF"); } -d "testout" or mkdir "testout"; $|=1; # give us some progress in the test harness init_log("testout/t106tiff.log",1); my $green=i_color_new(0,255,0,255); my $blue=i_color_new(0,0,255,255); my $red=i_color_new(255,0,0,255); my $img=test_image_raw(); my $ver_string = Imager::File::TIFF::i_tiff_libversion(); ok(my ($full, $major, $minor, $point) = $ver_string =~ /Version +((\d+)\.(\d+).(\d+))/, "extract library version") or diag("Could not extract from:\n$ver_string"); diag("libtiff release $full") if $full; # make something we can compare my $cmp_ver = sprintf("%03d%03d%03d", $major, $minor, $point); if ($cmp_ver lt '003007000') { diag("You have an old version of libtiff - $full, some tests will be skipped"); } Imager::i_tags_add($img, "i_xres", 0, "300", 0); Imager::i_tags_add($img, "i_yres", 0, undef, 250); # resolutionunit is centimeters Imager::i_tags_add($img, "tiff_resolutionunit", 0, undef, 3); Imager::i_tags_add($img, "tiff_software", 0, "t106tiff.t", 0); open(FH,">testout/t106.tiff") || die "cannot open testout/t106.tiff for writing\n"; binmode(FH); my $IO = Imager::io_new_fd(fileno(FH)); ok(Imager::File::TIFF::i_writetiff_wiol($img, $IO), "write low level") or print "# ", Imager->_error_as_msg, "\n"; close(FH); open(FH,"testout/t106.tiff") or die "cannot open testout/t106.tiff\n"; binmode(FH); $IO = Imager::io_new_fd(fileno(FH)); my $cmpimg = Imager::File::TIFF::i_readtiff_wiol($IO); ok($cmpimg, "read low-level"); close(FH); print "# tiff average mean square pixel difference: ",sqrt(i_img_diff($img,$cmpimg))/150*150,"\n"; ok(!i_img_diff($img, $cmpimg), "compare written and read image"); # check the tags are ok my %tags = map { Imager::i_tags_get($cmpimg, $_) } 0 .. Imager::i_tags_count($cmpimg) - 1; ok(abs($tags{i_xres} - 300) < 0.5, "i_xres in range"); ok(abs($tags{i_yres} - 250) < 0.5, "i_yres in range"); is($tags{tiff_resolutionunit}, 3, "tiff_resolutionunit"); is($tags{tiff_software}, 't106tiff.t', "tiff_software"); is($tags{tiff_photometric}, 2, "tiff_photometric"); # PHOTOMETRIC_RGB is 2 is($tags{tiff_bitspersample}, 8, "tiff_bitspersample"); $IO = Imager::io_new_bufchain(); ok(Imager::File::TIFF::i_writetiff_wiol($img, $IO), "write to buffer chain"); my $tiffdata = Imager::io_slurp($IO); open(FH,"testout/t106.tiff"); binmode FH; my $odata; { local $/; $odata = <FH>; } is($odata, $tiffdata, "same data in file as in memory"); # test Micksa's tiff writer # a shortish fax page my $faximg = Imager::ImgRaw::new(1728, 2000, 1); my $black = i_color_new(0,0,0,255); my $white = i_color_new(255,255,255,255); # vaguely test-patterny i_box_filled($faximg, 0, 0, 1728, 2000, $white); i_box_filled($faximg, 100,100,1628, 200, $black); my $width = 1; my $pos = 100; while ($width+$pos < 1628) { i_box_filled($faximg, $pos, 300, $pos+$width-1, 400, $black); $pos += $width + 20; $width += 2; } open FH, "> testout/t106tiff_fax.tiff" or die "Cannot create testout/t106tiff_fax.tiff: $!"; binmode FH; $IO = Imager::io_new_fd(fileno(FH)); ok(Imager::File::TIFF::i_writetiff_wiol_faxable($faximg, $IO, 1), "write faxable, low level"); close FH; # test the OO interface my $ooim = Imager->new; ok($ooim->read(file=>'testout/t106.tiff'), "read OO"); ok($ooim->write(file=>'testout/t106_oo.tiff'), "write OO"); # OO with the fax image my $oofim = Imager->new; ok($oofim->read(file=>'testout/t106tiff_fax.tiff'), "read fax OO"); # this should have tags set for the resolution %tags = map @$_, $oofim->tags; is($tags{i_xres}, 204, "fax i_xres"); is($tags{i_yres}, 196, "fax i_yres"); ok(!$tags{i_aspect_only}, "i_aspect_only"); # resunit_inches is($tags{tiff_resolutionunit}, 2, "tiff_resolutionunit"); is($tags{tiff_bitspersample}, 1, "tiff_bitspersample"); is($tags{tiff_photometric}, 0, "tiff_photometric"); ok($oofim->write(file=>'testout/t106_oo_fax.tiff', class=>'fax'), "write OO, faxable"); # the following should fail since there's no type and no filename my $oodata; ok(!$ooim->write(data=>\$oodata), "write with no type and no filename to guess with"); # OO to data ok($ooim->write(data=>\$oodata, type=>'tiff'), "write to data") or print "# ",$ooim->errstr, "\n"; is($oodata, $tiffdata, "check data matches between memory and file"); # make sure we can write non-fine mode ok($oofim->write(file=>'testout/t106_oo_faxlo.tiff', class=>'fax', fax_fine=>0), "write OO, fax standard mode"); # paletted reads my $img4 = Imager->new; ok($img4->read(file=>'testimg/comp4.tif'), "reading 4-bit paletted") or print "# ", $img4->errstr, "\n"; is($img4->type, 'paletted', "image isn't paletted"); print "# colors: ", $img4->colorcount,"\n"; cmp_ok($img4->colorcount, '<=', 16, "more than 16 colors!"); #ok($img4->write(file=>'testout/t106_was4.ppm'), # "Cannot write img4"); # I know I'm using BMP before it's test, but comp4.tif started life # as comp4.bmp my $bmp4 = Imager->new; ok($bmp4->read(file=>'testimg/comp4.bmp'), "reading 4-bit bmp!"); my $diff = i_img_diff($img4->{IMG}, $bmp4->{IMG}); print "# diff $diff\n"; ok($diff == 0, "image mismatch"); my $img4t = Imager->new; ok($img4t->read(file => 'testimg/comp4t.tif'), "read 4-bit paletted, tiled") or print "# ", $img4t->errstr, "\n"; is_image($bmp4, $img4t, "check tiled version matches"); my $img8 = Imager->new; ok($img8->read(file=>'testimg/comp8.tif'), "reading 8-bit paletted"); is($img8->type, 'paletted', "image isn't paletted"); print "# colors: ", $img8->colorcount,"\n"; #ok($img8->write(file=>'testout/t106_was8.ppm'), # "Cannot write img8"); ok($img8->colorcount == 256, "more colors than expected"); my $bmp8 = Imager->new; ok($bmp8->read(file=>'testimg/comp8.bmp'), "reading 8-bit bmp!"); $diff = i_img_diff($img8->{IMG}, $bmp8->{IMG}); print "# diff $diff\n"; ok($diff == 0, "image mismatch"); my $bad = Imager->new; ok($bad->read(file=>'testimg/comp4bad.tif', allow_incomplete=>1), "bad image not returned"); ok(scalar $bad->tags(name=>'i_incomplete'), "incomplete tag not set"); ok($img8->write(file=>'testout/t106_pal8.tif'), "writing 8-bit paletted"); my $cmp8 = Imager->new; ok($cmp8->read(file=>'testout/t106_pal8.tif'), "reading 8-bit paletted"); #print "# ",$cmp8->errstr,"\n"; is($cmp8->type, 'paletted', "pal8 isn't paletted"); is($cmp8->colorcount, 256, "pal8 bad colorcount"); $diff = i_img_diff($img8->{IMG}, $cmp8->{IMG}); print "# diff $diff\n"; ok($diff == 0, "written image doesn't match read"); ok($img4->write(file=>'testout/t106_pal4.tif'), "writing 4-bit paletted"); ok(my $cmp4 = Imager->new->read(file=>'testout/t106_pal4.tif'), "reading 4-bit paletted"); is($cmp4->type, 'paletted', "pal4 isn't paletted"); is($cmp4->colorcount, 16, "pal4 bad colorcount"); $diff = i_img_diff($img4->{IMG}, $cmp4->{IMG}); print "# diff $diff\n"; ok($diff == 0, "written image doesn't match read"); my $work; my $seekpos; sub io_writer { my ($what) = @_; if ($seekpos > length $work) { $work .= "\0" x ($seekpos - length $work); } substr($work, $seekpos, length $what) = $what; $seekpos += length $what; 1; } sub io_reader { my ($size, $maxread) = @_; print "# io_reader($size, $maxread) pos $seekpos\n"; if ($seekpos + $maxread > length $work) { $maxread = length($work) - $seekpos; } my $out = substr($work, $seekpos, $maxread); $seekpos += length $out; $out; } sub io_reader2 { my ($size, $maxread) = @_; print "# io_reader2($size, $maxread) pos $seekpos\n"; my $out = substr($work, $seekpos, $size); $seekpos += length $out; $out; } use IO::Seekable; sub io_seeker { my ($offset, $whence) = @_; print "# io_seeker($offset, $whence)\n"; if ($whence == SEEK_SET) { $seekpos = $offset; } elsif ($whence == SEEK_CUR) { $seekpos += $offset; } else { # SEEK_END $seekpos = length($work) + $offset; } #print "-> $seekpos\n"; $seekpos; } my $did_close; sub io_closer { ++$did_close; } # read via cb $work = $tiffdata; $seekpos = 0; my $IO2 = Imager::io_new_cb(undef, \&io_reader, \&io_seeker, undef); ok($IO2, "new readcb obj"); my $img5 = Imager::File::TIFF::i_readtiff_wiol($IO2); ok($img5, "read via cb"); ok(i_img_diff($img5, $img) == 0, "read from cb diff"); # read via cb2 $work = $tiffdata; $seekpos = 0; my $IO3 = Imager::io_new_cb(undef, \&io_reader2, \&io_seeker, undef); ok($IO3, "new readcb2 obj"); my $img6 = Imager::File::TIFF::i_readtiff_wiol($IO3); ok($img6, "read via cb2"); ok(i_img_diff($img6, $img) == 0, "read from cb2 diff"); # write via cb $work = ''; $seekpos = 0; my $IO4 = Imager::io_new_cb(\&io_writer, \&io_reader, \&io_seeker, \&io_closer); ok($IO4, "new writecb obj"); ok(Imager::File::TIFF::i_writetiff_wiol($img, $IO4), "write to cb"); is($work, $odata, "write cb match"); ok($did_close, "write cb did close"); open D1, ">testout/d1.tiff" or die; print D1 $work; close D1; open D2, ">testout/d2.tiff" or die; print D2 $tiffdata; close D2; # write via cb2 $work = ''; $seekpos = 0; $did_close = 0; my $IO5 = Imager::io_new_cb(\&io_writer, \&io_reader, \&io_seeker, \&io_closer, 1); ok($IO5, "new writecb obj 2"); ok(Imager::File::TIFF::i_writetiff_wiol($img, $IO5), "write to cb2"); is($work, $odata, "write cb2 match"); ok($did_close, "write cb2 did close"); open D3, ">testout/d3.tiff" or die; print D3 $work; close D3; { # check close failures are handled correctly { # single image my $im = test_image(); my $fail_close = sub { Imager::i_push_error(0, "synthetic close failure"); return 0; }; $work = ''; $seekpos = 0; ok(!$im->write(type => "tiff", readcb => \&io_reader, writecb => \&io_writer, seekcb => \&io_seeker, closecb => $fail_close), "check failing close fails"); like($im->errstr, qr/synthetic close failure/, "check error message"); } { # multiple images my $im = test_image(); my $fail_close = sub { Imager::i_push_error(0, "synthetic close failure"); return 0; }; $work = ''; $seekpos = 0; ok(!Imager->write_multi({type => "tiff", readcb => \&io_reader, writecb => \&io_writer, seekcb => \&io_seeker, closecb => $fail_close}, $im, $im), "check failing close fails"); like(Imager->errstr, qr/synthetic close failure/, "check error message"); } } # multi-image write/read my @imgs; push(@imgs, map $ooim->copy(), 1..3); for my $i (0..$#imgs) { $imgs[$i]->addtag(name=>"tiff_pagename", value=>"Page ".($i+1)); } my $rc = Imager->write_multi({file=>'testout/t106_multi.tif'}, @imgs); ok($rc, "writing multiple images to tiff"); my @out = Imager->read_multi(file=>'testout/t106_multi.tif'); ok(@out == @imgs, "reading multiple images from tiff"); @out == @imgs or print "# ",scalar @out, " ",Imager->errstr,"\n"; for my $i (0..$#imgs) { ok(i_img_diff($imgs[$i]{IMG}, $out[$i]{IMG}) == 0, "comparing image $i"); my ($tag) = $out[$i]->tags(name=>'tiff_pagename'); is($tag, "Page ".($i+1), "tag doesn't match original image"); } # writing even more images to tiff - we weren't handling more than five # correctly on read @imgs = map $ooim->copy(), 1..40; $rc = Imager->write_multi({file=>'testout/t106_multi2.tif'}, @imgs); ok($rc, "writing 40 images to tiff") or diag("writing 40 images: " . Imager->errstr); @out = Imager->read_multi(file=>'testout/t106_multi2.tif'); ok(@imgs == @out, "reading 40 images from tiff") or diag("reading 40 images:" . Imager->errstr); # force some allocation activity - helps crash here if it's the problem @out = @imgs = (); # multi-image fax files ok(Imager->write_multi({file=>'testout/t106_faxmulti.tiff', class=>'fax'}, $oofim, $oofim), "write multi fax image") or diag("writing 40 fax pages: " . Imager->errstr); @imgs = Imager->read_multi(file=>'testout/t106_faxmulti.tiff'); ok(@imgs == 2, "reading multipage fax") or diag("reading 40 fax pages: " . Imager->errstr); ok(Imager::i_img_diff($imgs[0]{IMG}, $oofim->{IMG}) == 0, "compare first fax image"); ok(Imager::i_img_diff($imgs[1]{IMG}, $oofim->{IMG}) == 0, "compare second fax image"); my ($format) = $imgs[0]->tags(name=>'i_format'); is($format, 'tiff', "check i_format tag"); my $unit = $imgs[0]->tags(name=>'tiff_resolutionunit'); ok(defined $unit && $unit == 2, "check tiff_resolutionunit tag"); my $unitname = $imgs[0]->tags(name=>'tiff_resolutionunit_name'); is($unitname, 'inch', "check tiff_resolutionunit_name tag"); my $warned = Imager->new; ok($warned->read(file=>"testimg/tiffwarn.tif"), "read tiffwarn.tif"); my ($warning) = $warned->tags(name=>'i_warning'); ok(defined $warning, "check warning is set"); like($warning, qr/[Uu]nknown field with tag 28712/, "check that warning tag correct"); { # support for reading a given page # first build a simple test image my $im1 = Imager->new(xsize=>50, ysize=>50); $im1->box(filled=>1, color=>$blue); $im1->addtag(name=>'tiff_pagename', value => "Page One"); my $im2 = Imager->new(xsize=>60, ysize=>60); $im2->box(filled=>1, color=>$green); $im2->addtag(name=>'tiff_pagename', value=>"Page Two"); # read second page my $page_file = 'testout/t106_pages.tif'; ok(Imager->write_multi({ file=> $page_file}, $im1, $im2), "build simple multiimage for page tests"); my $imwork = Imager->new; ok($imwork->read(file=>$page_file, page=>1), "read second page"); is($im2->getwidth, $imwork->getwidth, "check width"); is($im2->getwidth, $imwork->getheight, "check height"); is(i_img_diff($imwork->{IMG}, $im2->{IMG}), 0, "check image content"); my ($page_name) = $imwork->tags(name=>'tiff_pagename'); is($page_name, 'Page Two', "check tag we set"); # try an out of range page ok(!$imwork->read(file=>$page_file, page=>2), "check out of range page"); is($imwork->errstr, "could not switch to page 2", "check message"); } { # test writing returns an error message correctly # open a file read only and try to write to it open TIFF, "> testout/t106_empty.tif" or die; close TIFF; open TIFF, "< testout/t106_empty.tif" or skip "Cannot open testout/t106_empty.tif for reading", 8; binmode TIFF; my $im = Imager->new(xsize=>100, ysize=>100); ok(!$im->write(fh => \*TIFF, type=>'tiff', buffered => 0), "fail to write to read only handle"); cmp_ok($im->errstr, '=~', 'Could not create TIFF object: Error writing TIFF header: write\(\)', "check error message"); ok(!Imager->write_multi({ type => 'tiff', fh => \*TIFF, buffered => 0 }, $im), "fail to write multi to read only handle"); cmp_ok(Imager->errstr, '=~', 'Could not create TIFF object: Error writing TIFF header: write\(\)', "check error message"); ok(!$im->write(fh => \*TIFF, type=>'tiff', class=>'fax', buffered => 0), "fail to write to read only handle (fax)"); cmp_ok($im->errstr, '=~', 'Could not create TIFF object: Error writing TIFF header: write\(\)', "check error message"); ok(!Imager->write_multi({ type => 'tiff', fh => \*TIFF, class=>'fax', buffered => 0 }, $im), "fail to write multi to read only handle (fax)"); cmp_ok(Imager->errstr, '=~', 'Could not create TIFF object: Error writing TIFF header: write\(\)', "check error message"); } { # test reading returns an error correctly - use test script as an # invalid TIFF file my $im = Imager->new; ok(!$im->read(file=>'t/t10tiff.t', type=>'tiff'), "fail to read script as image"); # we get different magic number values depending on the platform # byte ordering cmp_ok($im->errstr, '=~', "Error opening file: Not a TIFF (?:or MDI )?file, bad magic number (8483 \\(0x2123\\)|8993 \\(0x2321\\))", "check error message"); my @ims = Imager->read_multi(file =>'t/t106tiff.t', type=>'tiff'); ok(!@ims, "fail to read_multi script as image"); cmp_ok($im->errstr, '=~', "Error opening file: Not a TIFF (?:or MDI )?file, bad magic number (8483 \\(0x2123\\)|8993 \\(0x2321\\))", "check error message"); } { # write_multi to data my $data; my $im = Imager->new(xsize => 50, ysize => 50); ok(Imager->write_multi({ data => \$data, type=>'tiff' }, $im, $im), "write multi to in memory"); ok(length $data, "make sure something written"); my @im = Imager->read_multi(data => $data); is(@im, 2, "make sure we can read it back"); is(Imager::i_img_diff($im[0]{IMG}, $im->{IMG}), 0, "check first image"); is(Imager::i_img_diff($im[1]{IMG}, $im->{IMG}), 0, "check second image"); } { # handling of an alpha channel for various images my $photo_rgb = 2; my $photo_cmyk = 5; my $photo_cielab = 8; my @alpha_images = ( [ 'srgb.tif', 3, $photo_rgb, '003005005' ], [ 'srgba.tif', 4, $photo_rgb, '003005005' ], [ 'srgbaa.tif', 4, $photo_rgb, '003005005' ], [ 'scmyk.tif', 3, $photo_cmyk, '003005005' ], [ 'scmyka.tif', 4, $photo_cmyk, '003005005' ], [ 'scmykaa.tif', 4, $photo_cmyk, '003005005' ], [ 'slab.tif', 3, $photo_cielab, '003006001' ], ); for my $test (@alpha_images) { my ($input, $channels, $photo, $need_ver) = @$test; SKIP: { my $skipped = $channels == 4 ? 4 : 3; $need_ver le $cmp_ver or skip("Your ancient tifflib is buggy/limited for this test", $skipped); my $im = Imager->new; ok($im->read(file => "testimg/$input"), "read alpha test $input") or print "# ", $im->errstr, "\n"; is($im->getchannels, $channels, "channels for $input match"); is($im->tags(name=>'tiff_photometric'), $photo, "photometric for $input match"); $channels == 4 or next; my $c = $im->getpixel(x => 0, 'y' => 7); is(($c->rgba)[3], 0, "bottom row should have 0 alpha"); } } } { ok(grep($_ eq 'tiff', Imager->read_types), "check tiff in read types"); ok(grep($_ eq 'tiff', Imager->write_types), "check tiff in write types"); } { # reading tile based images my $im = Imager->new; ok($im->read(file => 'testimg/pengtile.tif'), "read tiled image") or print "# ", $im->errstr, "\n"; # compare it my $comp = Imager->new; ok($comp->read(file => 'testimg/penguin-base.ppm'), 'read comparison image'); is_image($im, $comp, 'compare them'); } SKIP: { # failing to read tile based images # we grab our tiled image and patch a tile offset to nowhere ok(open(TIFF, '< testimg/pengtile.tif'), 'open pengtile.tif') or skip 'cannot open testimg/pengtile.tif', 4; $cmp_ver ge '003005007' or skip("Your ancient tifflib has bad error handling", 4); binmode TIFF; my $data = do { local $/; <TIFF>; }; # patch a tile offset substr($data, 0x1AFA0, 4) = pack("H*", "00000200"); #open PIPE, "| bytedump -a | less" or die; #print PIPE $data; #close PIPE; my $allow = Imager->new; ok($allow->read(data => $data, allow_incomplete => 1), "read incomplete tiled"); ok($allow->tags(name => 'i_incomplete'), 'i_incomplete set'); is($allow->tags(name => 'i_lines_read'), 173, 'check i_lines_read set appropriately'); my $fail = Imager->new; ok(!$fail->read(data => $data), "read fail tiled"); } { # read 16-bit/sample my $im16 = Imager->new; ok($im16->read(file => 'testimg/rgb16.tif'), "read 16-bit rgb"); is($im16->bits, 16, 'got a 16-bit image'); my $im16t = Imager->new; ok($im16t->read(file => 'testimg/rgb16t.tif'), "read 16-bit rgb tiled"); is($im16t->bits, 16, 'got a 16-bit image'); is_image($im16, $im16t, 'check they match'); my $grey16 = Imager->new; ok($grey16->read(file => 'testimg/grey16.tif'), "read 16-bit grey") or print "# ", $grey16->errstr, "\n"; is($grey16->bits, 16, 'got a 16-bit image'); is($grey16->getchannels, 1, 'and its grey'); my $comp16 = $im16->convert(matrix => [ [ 0.299, 0.587, 0.114 ] ]); is_image($grey16, $comp16, 'compare grey to converted'); my $grey32 = Imager->new; ok($grey32->read(file => 'testimg/grey32.tif'), "read 32-bit grey") or print "# ", $grey32->errstr, "\n"; is($grey32->bits, 'double', 'got a double image'); is($grey32->getchannels, 2, 'and its grey + alpha'); is($grey32->tags(name => 'tiff_bitspersample'), 32, "check bits per sample"); my $base = test_image_double->convert(preset =>'grey') ->convert(preset => 'addalpha'); is_image($grey32, $base, 'compare to original'); } { # read 16, 32-bit/sample and compare to the original my $rgba = Imager->new; ok($rgba->read(file => 'testimg/srgba.tif'), "read base rgba image"); my $rgba16 = Imager->new; ok($rgba16->read(file => 'testimg/srgba16.tif'), "read 16-bit/sample rgba image"); is_image($rgba, $rgba16, "check they match"); is($rgba16->bits, 16, 'check we got the right type'); my $rgba32 = Imager->new; ok($rgba32->read(file => 'testimg/srgba32.tif'), "read 32-bit/sample rgba image"); is_image($rgba, $rgba32, "check they match"); is($rgba32->bits, 'double', 'check we got the right type'); my $cmyka16 = Imager->new; ok($cmyka16->read(file => 'testimg/scmyka16.tif'), "read cmyk 16-bit") or print "# ", $cmyka16->errstr, "\n"; is($cmyka16->bits, 16, "check we got the right type"); is_image_similar($rgba, $cmyka16, 10, "check image data"); # tiled, non-contig, should fallback to RGBA code my $rgbatsep = Imager->new; ok($rgbatsep->read(file => 'testimg/rgbatsep.tif'), "read tiled, separated rgba image") or diag($rgbatsep->errstr); is_image($rgba, $rgbatsep, "check they match"); } { # read bi-level my $pbm = Imager->new; ok($pbm->read(file => 'testimg/imager.pbm'), "read original pbm"); my $tif = Imager->new; ok($tif->read(file => 'testimg/imager.tif'), "read mono tif"); is_image($pbm, $tif, "compare them"); is($tif->type, 'paletted', 'check image type'); is($tif->colorcount, 2, 'check we got a "mono" image'); } { # check alpha channels scaled correctly for fallback handler my $im = Imager->new; ok($im->read(file=>'testimg/alpha.tif'), 'read alpha check image'); my @colors = ( [ 0, 0, 0 ], [ 255, 255, 255 ], [ 127, 0, 127 ], [ 127, 127, 0 ], ); my @alphas = ( 255, 191, 127, 63 ); my $ok = 1; my $msg = 'alpha check ok'; CHECKER: for my $y (0 .. 3) { for my $x (0 .. 3) { my $c = $im->getpixel(x => $x, 'y' => $y); my @c = $c->rgba; my $alpha = pop @c; if ($alpha != $alphas[$y]) { $ok = 0; $msg = "($x,$y) alpha mismatch $alpha vs $alphas[$y]"; last CHECKER; } my $expect = $colors[$x]; for my $ch (0 .. 2) { if (abs($expect->[$ch]-$c[$ch]) > 3) { $ok = 0; $msg = "($x,$y)[$ch] color mismatch got $c[$ch] vs expected $expect->[$ch]"; last CHECKER; } } } } ok($ok, $msg); } { # check alpha channels scaled correctly for greyscale my $im = Imager->new; ok($im->read(file=>'testimg/gralpha.tif'), 'read alpha check grey image'); my @greys = ( 0, 255, 52, 112 ); my @alphas = ( 255, 191, 127, 63 ); my $ok = 1; my $msg = 'alpha check ok'; CHECKER: for my $y (0 .. 3) { for my $x (0 .. 3) { my $c = $im->getpixel(x => $x, 'y' => $y); my ($grey, $alpha) = $c->rgba; if ($alpha != $alphas[$y]) { $ok = 0; $msg = "($x,$y) alpha mismatch $alpha vs $alphas[$y]"; last CHECKER; } if (abs($greys[$x] - $grey) > 3) { $ok = 0; $msg = "($x,$y) grey mismatch $grey vs $greys[$x]"; last CHECKER; } } } ok($ok, $msg); } { # 16-bit writes my $orig = test_image_16(); my $data; ok($orig->write(data => \$data, type => 'tiff', tiff_compression => 'none'), "write 16-bit/sample"); my $im = Imager->new; ok($im->read(data => $data), "read it back"); is_image($im, $orig, "check read data matches"); is($im->tags(name => 'tiff_bitspersample'), 16, "correct bits"); is($im->bits, 16, 'check image bits'); is($im->tags(name => 'tiff_photometric'), 2, "correct photometric"); is($im->tags(name => 'tiff_compression'), 'none', "no compression"); is($im->getchannels, 3, 'correct channels'); } { # 8-bit writes # and check compression my $compress = Imager::File::TIFF::i_tiff_has_compression('lzw') ? 'lzw' : 'packbits'; my $orig = test_image()->convert(preset=>'grey') ->convert(preset => 'addalpha'); my $data; ok($orig->write(data => \$data, type => 'tiff', tiff_compression=> $compress), "write 8 bit") or print "# ", $orig->errstr, "\n"; my $im = Imager->new; ok($im->read(data => $data), "read it back"); is_image($im, $orig, "check read data matches"); is($im->tags(name => 'tiff_bitspersample'), 8, 'correct bits'); is($im->bits, 8, 'check image bits'); is($im->tags(name => 'tiff_photometric'), 1, 'correct photometric'); is($im->tags(name => 'tiff_compression'), $compress, "$compress compression"); is($im->getchannels, 2, 'correct channels'); } { # double writes my $orig = test_image_double()->convert(preset=>'addalpha'); my $data; ok($orig->write(data => \$data, type => 'tiff', tiff_compression => 'none'), "write 32-bit/sample from double") or print "# ", $orig->errstr, "\n"; my $im = Imager->new; ok($im->read(data => $data), "read it back"); is_image($im, $orig, "check read data matches"); is($im->tags(name => 'tiff_bitspersample'), 32, "correct bits"); is($im->bits, 'double', 'check image bits'); is($im->tags(name => 'tiff_photometric'), 2, "correct photometric"); is($im->tags(name => 'tiff_compression'), 'none', "no compression"); is($im->getchannels, 4, 'correct channels'); } { # bilevel my $im = test_image()->convert(preset => 'grey') ->to_paletted(make_colors => 'mono', translate => 'errdiff'); my $faxdata; # fax compression is written as miniswhite ok($im->write(data => \$faxdata, type => 'tiff', tiff_compression => 'fax3'), "write bilevel fax compressed"); my $fax = Imager->new; ok($fax->read(data => $faxdata), "read it back"); ok($fax->is_bilevel, "got a bi-level image back"); is($fax->tags(name => 'tiff_compression'), 'fax3', "check fax compression used"); is_image($fax, $im, "compare to original"); # other compresion written as minisblack my $packdata; ok($im->write(data => \$packdata, type => 'tiff', tiff_compression => 'jpeg'), "write bilevel packbits compressed"); my $packim = Imager->new; ok($packim->read(data => $packdata), "read it back"); ok($packim->is_bilevel, "got a bi-level image back"); is($packim->tags(name => 'tiff_compression'), 'packbits', "check fallback compression used"); is_image($packim, $im, "compare to original"); } { # fallback handling of tiff is(Imager::File::TIFF::i_tiff_has_compression('none'), 1, "can always do uncompresed"); is(Imager::File::TIFF::i_tiff_has_compression('xxx'), '', "can't do xxx compression"); } { # check file limits are checked my $limit_file = "testout/t106.tiff"; ok(Imager->set_file_limits(reset=>1, width=>149), "set width limit 149"); my $im = Imager->new; ok(!$im->read(file=>$limit_file), "should fail read due to size limits"); print "# ",$im->errstr,"\n"; like($im->errstr, qr/image width/, "check message"); ok(Imager->set_file_limits(reset=>1, height=>149), "set height limit 149"); ok(!$im->read(file=>$limit_file), "should fail read due to size limits"); print "# ",$im->errstr,"\n"; like($im->errstr, qr/image height/, "check message"); ok(Imager->set_file_limits(reset=>1, width=>150), "set width limit 150"); ok($im->read(file=>$limit_file), "should succeed - just inside width limit"); ok(Imager->set_file_limits(reset=>1, height=>150), "set height limit 150"); ok($im->read(file=>$limit_file), "should succeed - just inside height limit"); # 150 x 150 x 3 channel image uses 67500 bytes ok(Imager->set_file_limits(reset=>1, bytes=>67499), "set bytes limit 67499"); ok(!$im->read(file=>$limit_file), "should fail - too many bytes"); print "# ",$im->errstr,"\n"; like($im->errstr, qr/storage size/, "check error message"); ok(Imager->set_file_limits(reset=>1, bytes=>67500), "set bytes limit 67500"); ok($im->read(file=>$limit_file), "should succeed - just inside bytes limit"); Imager->set_file_limits(reset=>1); } { # this image has an IFD loop, which sends some TIFF readers into a # loop, including Corel PhotoPaint and the GIMP's tiff reader. my $ifdloop_hex = <<HEX; 49 49 2A 00 0A 00 00 00 FE 00 0A 00 00 01 03 00 01 00 00 00 01 00 00 00 01 01 03 00 01 00 00 00 01 00 00 00 02 01 03 00 03 00 00 00 88 00 00 00 03 01 03 00 01 00 00 00 05 80 00 00 06 01 03 00 01 00 00 00 02 00 00 00 11 01 04 00 01 00 00 00 08 00 00 00 12 01 03 00 01 00 00 00 01 00 00 00 15 01 03 00 01 00 00 00 03 00 00 00 17 01 04 00 01 00 00 00 02 00 00 00 1C 01 03 00 01 00 00 00 01 00 00 00 90 00 00 00 08 00 08 00 08 00 FE 00 0A 00 00 01 03 00 01 00 00 00 01 00 00 00 01 01 03 00 01 00 00 00 01 00 00 00 02 01 03 00 03 00 00 00 0E 01 00 00 03 01 03 00 01 00 00 00 05 80 00 00 06 01 03 00 01 00 00 00 02 00 00 00 11 01 04 00 01 00 00 00 8E 00 00 00 12 01 03 00 01 00 00 00 01 00 00 00 15 01 03 00 01 00 00 00 03 00 00 00 17 01 04 00 01 00 00 00 02 00 00 00 1C 01 03 00 01 00 00 00 01 00 00 00 0A 00 00 00 08 00 08 00 08 00 HEX $ifdloop_hex =~ tr/0-9A-F//cd; my $ifdloop = pack("H*", $ifdloop_hex); my $im = Imager->new; ok($im->read(data => $ifdloop, type => "tiff", page => 1), "read what should be valid"); ok(!$im->read(data => $ifdloop, type => "tiff", page => 2), "third page is after looping back to the start, if this fails, upgrade tifflib") or skip("tifflib is broken", 1); print "# ", $im->errstr, "\n"; my @im = Imager->read_multi(type => "tiff", data => $ifdloop); is(@im, 2, "should be only 2 images"); } SKIP: { # sample format Imager::File::TIFF::i_tiff_has_compression("lzw") or skip "No LZW support", 8; Imager::File::TIFF::i_tiff_ieeefp() or skip "No IEEE FP type", 8; SKIP: { # signed my $cmp = Imager->new(file => "testimg/grey16.tif", filetype => "tiff") or skip "Cannot read grey16.tif: ". Imager->errstr, 4; my $im = Imager->new(file => "testimg/grey16sg.tif", filetype => "tiff"); ok($im, "read image with SampleFormat = signed int") or skip "Couldn't read the file", 3; is_image($im, $cmp, "check the images match"); my %tags = map @$_, $im->tags; is($tags{tiff_sample_format}, 2, "check sample format"); is($tags{tiff_sample_format_name}, "int", "check sample format name"); } SKIP: { # float my $cmp = Imager->new(file => "testimg/srgba32.tif", filetype => "tiff") or skip "Cannot read srgaba32f.tif: ". Imager->errstr, 4; my $im = Imager->new(file => "testimg/srgba32f.tif", filetype => "tiff"); ok($im, "read image with SampleFormat = float") or skip "Couldn't read the file", 3; is_image($im, $cmp, "check the images match"); my %tags = map @$_, $im->tags; is($tags{tiff_sample_format}, 3, "check sample format"); is($tags{tiff_sample_format_name}, "ieeefp", "check sample format name"); } }