avoid looping badly on IFD loops in TIFF images, assuming a recent enough libtiff
[imager.git] / TIFF / t / t10tiff.t
1 #!perl -w
2 use strict;
3 use Test::More tests => 232;
4 use Imager qw(:all);
5 use Imager::Test qw(is_image is_image_similar test_image test_image_16 test_image_double test_image_raw);
6
7 BEGIN { use_ok("Imager::File::TIFF"); }
8
9 -d "testout"
10   or mkdir "testout";
11
12 $|=1;  # give us some progress in the test harness
13 init_log("testout/t106tiff.log",1);
14
15 my $green=i_color_new(0,255,0,255);
16 my $blue=i_color_new(0,0,255,255);
17 my $red=i_color_new(255,0,0,255);
18
19 my $img=test_image_raw();
20
21 my $ver_string = Imager::File::TIFF::i_tiff_libversion();
22 ok(my ($full, $major, $minor, $point) = 
23    $ver_string =~ /Version +((\d+)\.(\d+).(\d+))/,
24    "extract library version")
25   or diag("Could not extract from:\n$ver_string");
26 diag("libtiff release $full") if $full;
27 # make something we can compare
28 my $cmp_ver = sprintf("%03d%03d%03d", $major, $minor, $point);
29 if ($cmp_ver lt '003007000') {
30   diag("You have an old version of libtiff - $full, some tests will be skipped");
31 }
32
33 Imager::i_tags_add($img, "i_xres", 0, "300", 0);
34 Imager::i_tags_add($img, "i_yres", 0, undef, 250);
35 # resolutionunit is centimeters
36 Imager::i_tags_add($img, "tiff_resolutionunit", 0, undef, 3);
37 Imager::i_tags_add($img, "tiff_software", 0, "t106tiff.t", 0);
38 open(FH,">testout/t106.tiff") || die "cannot open testout/t106.tiff for writing\n";
39 binmode(FH); 
40 my $IO = Imager::io_new_fd(fileno(FH));
41 ok(Imager::File::TIFF::i_writetiff_wiol($img, $IO), "write low level")
42   or print "# ", Imager->_error_as_msg, "\n";
43 close(FH);
44
45 open(FH,"testout/t106.tiff") or die "cannot open testout/t106.tiff\n";
46 binmode(FH);
47 $IO = Imager::io_new_fd(fileno(FH));
48 my $cmpimg = Imager::File::TIFF::i_readtiff_wiol($IO);
49 ok($cmpimg, "read low-level");
50
51 close(FH);
52
53 print "# tiff average mean square pixel difference: ",sqrt(i_img_diff($img,$cmpimg))/150*150,"\n";
54
55 ok(!i_img_diff($img, $cmpimg), "compare written and read image");
56
57 # check the tags are ok
58 my %tags = map { Imager::i_tags_get($cmpimg, $_) }
59   0 .. Imager::i_tags_count($cmpimg) - 1;
60 ok(abs($tags{i_xres} - 300) < 0.5, "i_xres in range");
61 ok(abs($tags{i_yres} - 250) < 0.5, "i_yres in range");
62 is($tags{tiff_resolutionunit}, 3, "tiff_resolutionunit");
63 is($tags{tiff_software}, 't106tiff.t', "tiff_software");
64 is($tags{tiff_photometric}, 2, "tiff_photometric"); # PHOTOMETRIC_RGB is 2
65 is($tags{tiff_bitspersample}, 8, "tiff_bitspersample");
66
67 $IO = Imager::io_new_bufchain();
68
69 ok(Imager::File::TIFF::i_writetiff_wiol($img, $IO), "write to buffer chain");
70 my $tiffdata = Imager::io_slurp($IO);
71
72 open(FH,"testout/t106.tiff");
73 binmode FH;
74 my $odata;
75 { local $/;
76   $odata = <FH>;
77 }
78
79 is($odata, $tiffdata, "same data in file as in memory");
80
81 # test Micksa's tiff writer
82 # a shortish fax page
83 my $faximg = Imager::ImgRaw::new(1728, 2000, 1);
84 my $black = i_color_new(0,0,0,255);
85 my $white = i_color_new(255,255,255,255);
86 # vaguely test-patterny
87 i_box_filled($faximg, 0, 0, 1728, 2000, $white);
88 i_box_filled($faximg, 100,100,1628, 200, $black);
89 my $width = 1;
90 my $pos = 100;
91 while ($width+$pos < 1628) {
92   i_box_filled($faximg, $pos, 300, $pos+$width-1, 400, $black);
93   $pos += $width + 20;
94   $width += 2;
95 }
96 open FH, "> testout/t106tiff_fax.tiff"
97   or die "Cannot create testout/t106tiff_fax.tiff: $!";
98 binmode FH;
99 $IO = Imager::io_new_fd(fileno(FH));
100 ok(Imager::File::TIFF::i_writetiff_wiol_faxable($faximg, $IO, 1), "write faxable, low level");
101 close FH;
102
103 # test the OO interface
104 my $ooim = Imager->new;
105 ok($ooim->read(file=>'testout/t106.tiff'), "read OO");
106 ok($ooim->write(file=>'testout/t106_oo.tiff'), "write OO");
107
108 # OO with the fax image
109 my $oofim = Imager->new;
110 ok($oofim->read(file=>'testout/t106tiff_fax.tiff'),
111    "read fax OO");
112
113 # this should have tags set for the resolution
114 %tags = map @$_, $oofim->tags;
115 is($tags{i_xres}, 204, "fax i_xres");
116 is($tags{i_yres}, 196, "fax i_yres");
117 ok(!$tags{i_aspect_only}, "i_aspect_only");
118 # resunit_inches
119 is($tags{tiff_resolutionunit}, 2, "tiff_resolutionunit");
120 is($tags{tiff_bitspersample}, 1, "tiff_bitspersample");
121 is($tags{tiff_photometric}, 0, "tiff_photometric");
122
123 ok($oofim->write(file=>'testout/t106_oo_fax.tiff', class=>'fax'),
124    "write OO, faxable");
125
126 # the following should fail since there's no type and no filename
127 my $oodata;
128 ok(!$ooim->write(data=>\$oodata), "write with no type and no filename to guess with");
129
130 # OO to data
131 ok($ooim->write(data=>\$oodata, type=>'tiff'), "write to data")
132   or print "# ",$ooim->errstr, "\n";
133 is($oodata, $tiffdata, "check data matches between memory and file");
134
135 # make sure we can write non-fine mode
136 ok($oofim->write(file=>'testout/t106_oo_faxlo.tiff', class=>'fax', fax_fine=>0), "write OO, fax standard mode");
137
138 # paletted reads
139 my $img4 = Imager->new;
140 ok($img4->read(file=>'testimg/comp4.tif'), "reading 4-bit paletted")
141   or print "# ", $img4->errstr, "\n";
142 is($img4->type, 'paletted', "image isn't paletted");
143 print "# colors: ", $img4->colorcount,"\n";
144   cmp_ok($img4->colorcount, '<=', 16, "more than 16 colors!");
145 #ok($img4->write(file=>'testout/t106_was4.ppm'),
146 #   "Cannot write img4");
147 # I know I'm using BMP before it's test, but comp4.tif started life 
148 # as comp4.bmp
149 my $bmp4 = Imager->new;
150 ok($bmp4->read(file=>'testimg/comp4.bmp'), "reading 4-bit bmp!");
151 my $diff = i_img_diff($img4->{IMG}, $bmp4->{IMG});
152 print "# diff $diff\n";
153 ok($diff == 0, "image mismatch");
154 my $img4t = Imager->new;
155 ok($img4t->read(file => 'testimg/comp4t.tif'), "read 4-bit paletted, tiled")
156   or print "# ", $img4t->errstr, "\n";
157 is_image($bmp4, $img4t, "check tiled version matches");
158 my $img8 = Imager->new;
159 ok($img8->read(file=>'testimg/comp8.tif'), "reading 8-bit paletted");
160 is($img8->type, 'paletted', "image isn't paletted");
161 print "# colors: ", $img8->colorcount,"\n";
162 #ok($img8->write(file=>'testout/t106_was8.ppm'),
163 #   "Cannot write img8");
164 ok($img8->colorcount == 256, "more colors than expected");
165 my $bmp8 = Imager->new;
166 ok($bmp8->read(file=>'testimg/comp8.bmp'), "reading 8-bit bmp!");
167 $diff = i_img_diff($img8->{IMG}, $bmp8->{IMG});
168 print "# diff $diff\n";
169 ok($diff == 0, "image mismatch");
170 my $bad = Imager->new;
171 ok($bad->read(file=>'testimg/comp4bad.tif', 
172               allow_incomplete=>1), "bad image not returned");
173 ok(scalar $bad->tags(name=>'i_incomplete'), "incomplete tag not set");
174 ok($img8->write(file=>'testout/t106_pal8.tif'), "writing 8-bit paletted");
175 my $cmp8 = Imager->new;
176 ok($cmp8->read(file=>'testout/t106_pal8.tif'),
177    "reading 8-bit paletted");
178 #print "# ",$cmp8->errstr,"\n";
179 is($cmp8->type, 'paletted', "pal8 isn't paletted");
180 is($cmp8->colorcount, 256, "pal8 bad colorcount");
181 $diff = i_img_diff($img8->{IMG}, $cmp8->{IMG});
182 print "# diff $diff\n";
183 ok($diff == 0, "written image doesn't match read");
184 ok($img4->write(file=>'testout/t106_pal4.tif'), "writing 4-bit paletted");
185 ok(my $cmp4 = Imager->new->read(file=>'testout/t106_pal4.tif'),
186    "reading 4-bit paletted");
187 is($cmp4->type, 'paletted', "pal4 isn't paletted");
188 is($cmp4->colorcount, 16, "pal4 bad colorcount");
189 $diff = i_img_diff($img4->{IMG}, $cmp4->{IMG});
190 print "# diff $diff\n";
191 ok($diff == 0, "written image doesn't match read");
192
193 my $work;
194 my $seekpos;
195 sub io_writer {
196   my ($what) = @_;
197   if ($seekpos > length $work) {
198     $work .= "\0" x ($seekpos - length $work);
199   }
200   substr($work, $seekpos, length $what) = $what;
201   $seekpos += length $what;
202   
203   1;
204 }
205 sub io_reader {
206   my ($size, $maxread) = @_;
207   #print "io_reader($size, $maxread) pos $seekpos\n";
208   my $out = substr($work, $seekpos, $maxread);
209   $seekpos += length $out;
210   $out;
211 }
212 sub io_reader2 {
213   my ($size, $maxread) = @_;
214   #print "io_reader2($size, $maxread) pos $seekpos\n";
215   my $out = substr($work, $seekpos, $size);
216   $seekpos += length $out;
217   $out;
218 }
219 use IO::Seekable;
220 sub io_seeker {
221   my ($offset, $whence) = @_;
222   #print "io_seeker($offset, $whence)\n";
223   if ($whence == SEEK_SET) {
224     $seekpos = $offset;
225   }
226   elsif ($whence == SEEK_CUR) {
227     $seekpos += $offset;
228   }
229   else { # SEEK_END
230     $seekpos = length($work) + $offset;
231   }
232   #print "-> $seekpos\n";
233   $seekpos;
234 }
235 my $did_close;
236 sub io_closer {
237   ++$did_close;
238 }
239
240 # read via cb
241 $work = $tiffdata;
242 $seekpos = 0;
243 my $IO2 = Imager::io_new_cb(undef, \&io_reader, \&io_seeker, undef);
244 ok($IO2, "new readcb obj");
245 my $img5 = Imager::File::TIFF::i_readtiff_wiol($IO2);
246 ok($img5, "read via cb");
247 ok(i_img_diff($img5, $img) == 0, "read from cb diff");
248
249 # read via cb2
250 $work = $tiffdata;
251 $seekpos = 0;
252 my $IO3 = Imager::io_new_cb(undef, \&io_reader2, \&io_seeker, undef);
253 ok($IO3, "new readcb2 obj");
254 my $img6 = Imager::File::TIFF::i_readtiff_wiol($IO3);
255 ok($img6, "read via cb2");
256 ok(i_img_diff($img6, $img) == 0, "read from cb2 diff");
257
258 # write via cb
259 $work = '';
260 $seekpos = 0;
261 my $IO4 = Imager::io_new_cb(\&io_writer, \&io_reader, \&io_seeker,
262                             \&io_closer);
263 ok($IO4, "new writecb obj");
264 ok(Imager::File::TIFF::i_writetiff_wiol($img, $IO4), "write to cb");
265 is($work, $odata, "write cb match");
266 ok($did_close, "write cb did close");
267 open D1, ">testout/d1.tiff" or die;
268 print D1 $work;
269 close D1;
270 open D2, ">testout/d2.tiff" or die;
271 print D2 $tiffdata;
272 close D2;
273
274 # write via cb2
275 $work = '';
276 $seekpos = 0;
277 $did_close = 0;
278 my $IO5 = Imager::io_new_cb(\&io_writer, \&io_reader, \&io_seeker,
279                             \&io_closer, 1);
280 ok($IO5, "new writecb obj 2");
281 ok(Imager::File::TIFF::i_writetiff_wiol($img, $IO5), "write to cb2");
282 is($work, $odata, "write cb2 match");
283 ok($did_close, "write cb2 did close");
284
285 open D3, ">testout/d3.tiff" or die;
286 print D3 $work;
287 close D3;
288
289 # multi-image write/read
290 my @imgs;
291 push(@imgs, map $ooim->copy(), 1..3);
292 for my $i (0..$#imgs) {
293   $imgs[$i]->addtag(name=>"tiff_pagename", value=>"Page ".($i+1));
294 }
295 my $rc = Imager->write_multi({file=>'testout/t106_multi.tif'}, @imgs);
296 ok($rc, "writing multiple images to tiff");
297 my @out = Imager->read_multi(file=>'testout/t106_multi.tif');
298 ok(@out == @imgs, "reading multiple images from tiff");
299 @out == @imgs or print "# ",scalar @out, " ",Imager->errstr,"\n";
300 for my $i (0..$#imgs) {
301   ok(i_img_diff($imgs[$i]{IMG}, $out[$i]{IMG}) == 0,
302      "comparing image $i");
303   my ($tag) = $out[$i]->tags(name=>'tiff_pagename');
304   is($tag, "Page ".($i+1),
305      "tag doesn't match original image");
306 }
307
308 # writing even more images to tiff - we weren't handling more than five
309 # correctly on read
310 @imgs = map $ooim->copy(), 1..40;
311 $rc = Imager->write_multi({file=>'testout/t106_multi2.tif'}, @imgs);
312 ok($rc, "writing 40 images to tiff")
313   or diag("writing 40 images: " . Imager->errstr);
314 @out = Imager->read_multi(file=>'testout/t106_multi2.tif');
315 ok(@imgs == @out, "reading 40 images from tiff")
316   or diag("reading 40 images:" . Imager->errstr);
317 # force some allocation activity - helps crash here if it's the problem
318 @out = @imgs = ();
319
320 # multi-image fax files
321 ok(Imager->write_multi({file=>'testout/t106_faxmulti.tiff', class=>'fax'},
322                        $oofim, $oofim), "write multi fax image")
323   or diag("writing 40 fax pages: " . Imager->errstr);
324 @imgs = Imager->read_multi(file=>'testout/t106_faxmulti.tiff');
325 ok(@imgs == 2, "reading multipage fax")
326   or diag("reading 40 fax pages: " . Imager->errstr);
327 ok(Imager::i_img_diff($imgs[0]{IMG}, $oofim->{IMG}) == 0,
328    "compare first fax image");
329 ok(Imager::i_img_diff($imgs[1]{IMG}, $oofim->{IMG}) == 0,
330    "compare second fax image");
331
332 my ($format) = $imgs[0]->tags(name=>'i_format');
333 is($format, 'tiff', "check i_format tag");
334
335 my $unit = $imgs[0]->tags(name=>'tiff_resolutionunit');
336 ok(defined $unit && $unit == 2, "check tiff_resolutionunit tag");
337 my $unitname = $imgs[0]->tags(name=>'tiff_resolutionunit_name');
338 is($unitname, 'inch', "check tiff_resolutionunit_name tag");
339
340 my $warned = Imager->new;
341 ok($warned->read(file=>"testimg/tiffwarn.tif"), "read tiffwarn.tif");
342 my ($warning) = $warned->tags(name=>'i_warning');
343 ok(defined $warning, "check warning is set");
344 like($warning, qr/[Uu]nknown field with tag 28712/,
345      "check that warning tag correct");
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 }
375
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 }
401
402 { # test reading returns an error correctly - use test script as an
403   # invalid TIFF file
404   my $im = Imager->new;
405   ok(!$im->read(file=>'t/t10tiff.t', type=>'tiff'),
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 }
418
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 }
432
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");
466     }
467   }
468 }
469
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 }
474
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 }
484
485 SKIP:
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 }
513
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;
519   ok($im16t->read(file => 'testimg/rgb16t.tif'), "read 16-bit rgb tiled");
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 }
542
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");
565
566   # tiled, non-contig, should fallback to RGBA code
567   my $rgbatsep = Imager->new;
568   ok($rgbatsep->read(file => 'testimg/rgbatsep.tif'),
569      "read tiled, separated rgba image")
570     or diag($rgbatsep->errstr);
571   is_image($rgba, $rgbatsep, "check they match");
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 }
582
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) {
610           $ok = 0;
611           $msg = "($x,$y)[$ch] color mismatch got $c[$ch] vs expected $expect->[$ch]";
612           last CHECKER;
613         }
614       }
615     }
616   }
617   ok($ok, $msg);
618 }
619
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;
641       }
642     }
643   }
644   ok($ok, $msg);
645 }
646
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");
658     is($im->tags(name => 'tiff_compression'), 'none', "no compression");
659   is($im->getchannels, 3, 'correct channels');
660 }
661
662 { # 8-bit writes
663   # and check compression
664   my $compress = Imager::File::TIFF::i_tiff_has_compression('lzw') ? 'lzw' : 'packbits';
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 }
682
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 }
699
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 }
729
730 { # fallback handling of tiff
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");
733 }
734
735
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 }
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;
776 49 49 2A 00 0A 00 00 00 FE 00 0A 00 00 01 03 00
777 01 00 00 00 01 00 00 00 01 01 03 00 01 00 00 00
778 01 00 00 00 02 01 03 00 03 00 00 00 88 00 00 00
779 03 01 03 00 01 00 00 00 05 80 00 00 06 01 03 00
780 01 00 00 00 02 00 00 00 11 01 04 00 01 00 00 00
781 08 00 00 00 12 01 03 00 01 00 00 00 01 00 00 00
782 15 01 03 00 01 00 00 00 03 00 00 00 17 01 04 00
783 01 00 00 00 02 00 00 00 1C 01 03 00 01 00 00 00
784 01 00 00 00 90 00 00 00 08 00 08 00 08 00 FE 00
785 0A 00 00 01 03 00 01 00 00 00 01 00 00 00 01 01
786 03 00 01 00 00 00 01 00 00 00 02 01 03 00 03 00
787 00 00 0E 01 00 00 03 01 03 00 01 00 00 00 05 80
788 00 00 06 01 03 00 01 00 00 00 02 00 00 00 11 01
789 04 00 01 00 00 00 8E 00 00 00 12 01 03 00 01 00
790 00 00 01 00 00 00 15 01 03 00 01 00 00 00 03 00
791 00 00 17 01 04 00 01 00 00 00 02 00 00 00 1C 01
792 03 00 01 00 00 00 01 00 00 00 0A 00 00 00 08 00
793 08 00 08 00
794 HEX
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 }