[rt #74540] handle the TIFF SampleFormat tag
[imager.git] / TIFF / t / t10tiff.t
CommitLineData
faa9b3e7 1#!perl -w
66614d6e 2use strict;
05c9b356 3use Test::More tests => 247;
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) = @_;
6d5c85a2
TC
207 print "# io_reader($size, $maxread) pos $seekpos\n";
208 if ($seekpos + $maxread > length $work) {
209 $maxread = length($work) - $seekpos;
210 }
e83b349b
TC
211 my $out = substr($work, $seekpos, $maxread);
212 $seekpos += length $out;
213 $out;
214}
215sub io_reader2 {
216 my ($size, $maxread) = @_;
6d5c85a2 217 print "# io_reader2($size, $maxread) pos $seekpos\n";
e83b349b
TC
218 my $out = substr($work, $seekpos, $size);
219 $seekpos += length $out;
220 $out;
221}
222use IO::Seekable;
223sub io_seeker {
224 my ($offset, $whence) = @_;
6d5c85a2 225 print "# io_seeker($offset, $whence)\n";
e83b349b
TC
226 if ($whence == SEEK_SET) {
227 $seekpos = $offset;
10461f9a 228 }
e83b349b
TC
229 elsif ($whence == SEEK_CUR) {
230 $seekpos += $offset;
10461f9a 231 }
e83b349b
TC
232 else { # SEEK_END
233 $seekpos = length($work) + $offset;
10461f9a 234 }
e83b349b
TC
235 #print "-> $seekpos\n";
236 $seekpos;
237}
238my $did_close;
239sub io_closer {
240 ++$did_close;
241}
10461f9a 242
e83b349b
TC
243# read via cb
244$work = $tiffdata;
245$seekpos = 0;
246my $IO2 = Imager::io_new_cb(undef, \&io_reader, \&io_seeker, undef);
247ok($IO2, "new readcb obj");
e5ee047b 248my $img5 = Imager::File::TIFF::i_readtiff_wiol($IO2);
e83b349b
TC
249ok($img5, "read via cb");
250ok(i_img_diff($img5, $img) == 0, "read from cb diff");
251
252# read via cb2
253$work = $tiffdata;
254$seekpos = 0;
255my $IO3 = Imager::io_new_cb(undef, \&io_reader2, \&io_seeker, undef);
256ok($IO3, "new readcb2 obj");
e5ee047b 257my $img6 = Imager::File::TIFF::i_readtiff_wiol($IO3);
e83b349b
TC
258ok($img6, "read via cb2");
259ok(i_img_diff($img6, $img) == 0, "read from cb2 diff");
260
261# write via cb
262$work = '';
263$seekpos = 0;
264my $IO4 = Imager::io_new_cb(\&io_writer, \&io_reader, \&io_seeker,
265 \&io_closer);
266ok($IO4, "new writecb obj");
e5ee047b 267ok(Imager::File::TIFF::i_writetiff_wiol($img, $IO4), "write to cb");
e83b349b
TC
268is($work, $odata, "write cb match");
269ok($did_close, "write cb did close");
270open D1, ">testout/d1.tiff" or die;
271print D1 $work;
272close D1;
273open D2, ">testout/d2.tiff" or die;
274print D2 $tiffdata;
275close D2;
276
277# write via cb2
278$work = '';
279$seekpos = 0;
280$did_close = 0;
281my $IO5 = Imager::io_new_cb(\&io_writer, \&io_reader, \&io_seeker,
282 \&io_closer, 1);
283ok($IO5, "new writecb obj 2");
e5ee047b 284ok(Imager::File::TIFF::i_writetiff_wiol($img, $IO5), "write to cb2");
e83b349b
TC
285is($work, $odata, "write cb2 match");
286ok($did_close, "write cb2 did close");
287
288open D3, ">testout/d3.tiff" or die;
289print D3 $work;
290close D3;
291
6d5c85a2
TC
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
e83b349b
TC
330# multi-image write/read
331my @imgs;
332push(@imgs, map $ooim->copy(), 1..3);
333for my $i (0..$#imgs) {
334 $imgs[$i]->addtag(name=>"tiff_pagename", value=>"Page ".($i+1));
335}
336my $rc = Imager->write_multi({file=>'testout/t106_multi.tif'}, @imgs);
337ok($rc, "writing multiple images to tiff");
338my @out = Imager->read_multi(file=>'testout/t106_multi.tif');
339ok(@out == @imgs, "reading multiple images from tiff");
340@out == @imgs or print "# ",scalar @out, " ",Imager->errstr,"\n";
341for 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}
10461f9a 348
e83b349b
TC
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);
46c21d48
TC
353ok($rc, "writing 40 images to tiff")
354 or diag("writing 40 images: " . Imager->errstr);
e83b349b 355@out = Imager->read_multi(file=>'testout/t106_multi2.tif');
46c21d48
TC
356ok(@imgs == @out, "reading 40 images from tiff")
357 or diag("reading 40 images:" . Imager->errstr);
e83b349b
TC
358# force some allocation activity - helps crash here if it's the problem
359@out = @imgs = ();
360
361# multi-image fax files
362ok(Imager->write_multi({file=>'testout/t106_faxmulti.tiff', class=>'fax'},
46c21d48
TC
363 $oofim, $oofim), "write multi fax image")
364 or diag("writing 40 fax pages: " . Imager->errstr);
e83b349b 365@imgs = Imager->read_multi(file=>'testout/t106_faxmulti.tiff');
46c21d48
TC
366ok(@imgs == 2, "reading multipage fax")
367 or diag("reading 40 fax pages: " . Imager->errstr);
e83b349b
TC
368ok(Imager::i_img_diff($imgs[0]{IMG}, $oofim->{IMG}) == 0,
369 "compare first fax image");
370ok(Imager::i_img_diff($imgs[1]{IMG}, $oofim->{IMG}) == 0,
371 "compare second fax image");
372
373my ($format) = $imgs[0]->tags(name=>'i_format');
374is($format, 'tiff', "check i_format tag");
375
376my $unit = $imgs[0]->tags(name=>'tiff_resolutionunit');
377ok(defined $unit && $unit == 2, "check tiff_resolutionunit tag");
378my $unitname = $imgs[0]->tags(name=>'tiff_resolutionunit_name');
379is($unitname, 'inch', "check tiff_resolutionunit_name tag");
380
381my $warned = Imager->new;
382ok($warned->read(file=>"testimg/tiffwarn.tif"), "read tiffwarn.tif");
383my ($warning) = $warned->tags(name=>'i_warning');
afee75f6
TC
384ok(defined $warning, "check warning is set");
385like($warning, qr/[Uu]nknown field with tag 28712/,
386 "check that warning tag correct");
e83b349b
TC
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}
2691d220 416
e83b349b
TC
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);
6d5c85a2 425 ok(!$im->write(fh => \*TIFF, type=>'tiff', buffered => 0),
e83b349b
TC
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");
6d5c85a2 429 ok(!Imager->write_multi({ type => 'tiff', fh => \*TIFF, buffered => 0 }, $im),
e83b349b
TC
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");
6d5c85a2 433 ok(!$im->write(fh => \*TIFF, type=>'tiff', class=>'fax', buffered => 0),
e83b349b
TC
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");
6d5c85a2 437 ok(!Imager->write_multi({ type => 'tiff', fh => \*TIFF, class=>'fax', buffered => 0 }, $im),
e83b349b
TC
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}
2691d220 442
e83b349b
TC
443{ # test reading returns an error correctly - use test script as an
444 # invalid TIFF file
445 my $im = Imager->new;
e5ee047b 446 ok(!$im->read(file=>'t/t10tiff.t', type=>'tiff'),
e83b349b
TC
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}
2b405c9e 459
e83b349b
TC
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}
a50608d2 473
e83b349b
TC
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");
a50608d2
TC
507 }
508 }
e83b349b 509}
f245645a 510
e83b349b
TC
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}
bd8052a6 515
e83b349b
TC
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}
bd8052a6 525
e83b349b
TC
526SKIP:
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}
bd8052a6 554
e83b349b
TC
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;
ff97aa8e 560 ok($im16t->read(file => 'testimg/rgb16t.tif'), "read 16-bit rgb tiled");
e83b349b
TC
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}
bd8052a6 583
e83b349b
TC
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");
ff97aa8e
TC
606
607 # tiled, non-contig, should fallback to RGBA code
608 my $rgbatsep = Imager->new;
609 ok($rgbatsep->read(file => 'testimg/rgbatsep.tif'),
5b9f7f08
TC
610 "read tiled, separated rgba image")
611 or diag($rgbatsep->errstr);
ff97aa8e 612 is_image($rgba, $rgbatsep, "check they match");
e83b349b
TC
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}
bd8052a6 623
e83b349b
TC
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) {
bd8052a6 651 $ok = 0;
e83b349b 652 $msg = "($x,$y)[$ch] color mismatch got $c[$ch] vs expected $expect->[$ch]";
bd8052a6
TC
653 last CHECKER;
654 }
bd8052a6
TC
655 }
656 }
bd8052a6 657 }
e83b349b
TC
658 ok($ok, $msg);
659}
bd8052a6 660
e83b349b
TC
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;
bd8052a6
TC
682 }
683 }
bd8052a6 684 }
e83b349b
TC
685 ok($ok, $msg);
686}
bd8052a6 687
e83b349b
TC
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");
bd8052a6 699 is($im->tags(name => 'tiff_compression'), 'none', "no compression");
e83b349b
TC
700 is($im->getchannels, 3, 'correct channels');
701}
bd8052a6 702
e83b349b
TC
703{ # 8-bit writes
704 # and check compression
e5ee047b 705 my $compress = Imager::File::TIFF::i_tiff_has_compression('lzw') ? 'lzw' : 'packbits';
e83b349b
TC
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}
bd8052a6 723
e83b349b
TC
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}
bd8052a6 740
e83b349b
TC
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}
bd8052a6 770
e83b349b 771{ # fallback handling of tiff
e5ee047b
TC
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");
b89b3153 774}
2b405c9e 775
e83b349b 776
6b7197d0
TC
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}
69287763
TC
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;
81749 49 2A 00 0A 00 00 00 FE 00 0A 00 00 01 03 00
81801 00 00 00 01 00 00 00 01 01 03 00 01 00 00 00
81901 00 00 00 02 01 03 00 03 00 00 00 88 00 00 00
82003 01 03 00 01 00 00 00 05 80 00 00 06 01 03 00
82101 00 00 00 02 00 00 00 11 01 04 00 01 00 00 00
82208 00 00 00 12 01 03 00 01 00 00 00 01 00 00 00
82315 01 03 00 01 00 00 00 03 00 00 00 17 01 04 00
82401 00 00 00 02 00 00 00 1C 01 03 00 01 00 00 00
82501 00 00 00 90 00 00 00 08 00 08 00 08 00 FE 00
8260A 00 00 01 03 00 01 00 00 00 01 00 00 00 01 01
82703 00 01 00 00 00 01 00 00 00 02 01 03 00 03 00
82800 00 0E 01 00 00 03 01 03 00 01 00 00 00 05 80
82900 00 06 01 03 00 01 00 00 00 02 00 00 00 11 01
83004 00 01 00 00 00 8E 00 00 00 12 01 03 00 01 00
83100 00 01 00 00 00 15 01 03 00 01 00 00 00 03 00
83200 00 17 01 04 00 01 00 00 00 02 00 00 00 1C 01
83303 00 01 00 00 00 01 00 00 00 0A 00 00 00 08 00
83408 00 08 00
835HEX
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}
05c9b356
TC
849
850SKIP:
851{ # sample format
852 Imager::File::TIFF::i_tiff_has_compression("lzw")
853 or skip "No LZW support", 8;
854 Imager::File::TIFF::i_tiff_ieeefp()
855 or skip "No IEEE FP type", 8;
856
857 SKIP:
858 { # signed
859 my $cmp = Imager->new(file => "testimg/grey16.tif", filetype => "tiff")
860 or skip "Cannot read grey16.tif: ". Imager->errstr, 4;
861 my $im = Imager->new(file => "testimg/grey16sg.tif", filetype => "tiff");
862 ok($im, "read image with SampleFormat = signed int")
863 or skip "Couldn't read the file", 3;
864 is_image($im, $cmp, "check the images match");
865 my %tags = map @$_, $im->tags;
866 is($tags{tiff_sample_format}, 2, "check sample format");
867 is($tags{tiff_sample_format_name}, "int", "check sample format name");
868 }
869
870 SKIP:
871 { # float
872 my $cmp = Imager->new(file => "testimg/srgba32.tif", filetype => "tiff")
873 or skip "Cannot read srgaba32f.tif: ". Imager->errstr, 4;
874 my $im = Imager->new(file => "testimg/srgba32f.tif", filetype => "tiff");
875 ok($im, "read image with SampleFormat = float")
876 or skip "Couldn't read the file", 3;
877 is_image($im, $cmp, "check the images match");
878 my %tags = map @$_, $im->tags;
879 is($tags{tiff_sample_format}, 3, "check sample format");
880 is($tags{tiff_sample_format_name}, "ieeefp", "check sample format name");
881 }
882}