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