produce additional diagnostics on some TIFF tests
[imager.git] / TIFF / t / t10tiff.t
CommitLineData
faa9b3e7 1#!perl -w
66614d6e 2use strict;
afee75f6 3use Test::More tests => 217;
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