40d15aeb91f501106e36ed4ee35211c02d84ccff
[imager.git] / TIFF / t / t10tiff.t
1 #!perl -w
2 use strict;
3 use Test::More tests => 239;
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   if ($seekpos + $maxread > length $work) {
209     $maxread = length($work) - $seekpos;
210   }
211   my $out = substr($work, $seekpos, $maxread);
212   $seekpos += length $out;
213   $out;
214 }
215 sub io_reader2 {
216   my ($size, $maxread) = @_;
217   print "# io_reader2($size, $maxread) pos $seekpos\n";
218   my $out = substr($work, $seekpos, $size);
219   $seekpos += length $out;
220   $out;
221 }
222 use IO::Seekable;
223 sub io_seeker {
224   my ($offset, $whence) = @_;
225   print "# io_seeker($offset, $whence)\n";
226   if ($whence == SEEK_SET) {
227     $seekpos = $offset;
228   }
229   elsif ($whence == SEEK_CUR) {
230     $seekpos += $offset;
231   }
232   else { # SEEK_END
233     $seekpos = length($work) + $offset;
234   }
235   #print "-> $seekpos\n";
236   $seekpos;
237 }
238 my $did_close;
239 sub io_closer {
240   ++$did_close;
241 }
242
243 # read via cb
244 $work = $tiffdata;
245 $seekpos = 0;
246 my $IO2 = Imager::io_new_cb(undef, \&io_reader, \&io_seeker, undef);
247 ok($IO2, "new readcb obj");
248 my $img5 = Imager::File::TIFF::i_readtiff_wiol($IO2);
249 ok($img5, "read via cb");
250 ok(i_img_diff($img5, $img) == 0, "read from cb diff");
251
252 # read via cb2
253 $work = $tiffdata;
254 $seekpos = 0;
255 my $IO3 = Imager::io_new_cb(undef, \&io_reader2, \&io_seeker, undef);
256 ok($IO3, "new readcb2 obj");
257 my $img6 = Imager::File::TIFF::i_readtiff_wiol($IO3);
258 ok($img6, "read via cb2");
259 ok(i_img_diff($img6, $img) == 0, "read from cb2 diff");
260
261 # write via cb
262 $work = '';
263 $seekpos = 0;
264 my $IO4 = Imager::io_new_cb(\&io_writer, \&io_reader, \&io_seeker,
265                             \&io_closer);
266 ok($IO4, "new writecb obj");
267 ok(Imager::File::TIFF::i_writetiff_wiol($img, $IO4), "write to cb");
268 is($work, $odata, "write cb match");
269 ok($did_close, "write cb did close");
270 open D1, ">testout/d1.tiff" or die;
271 print D1 $work;
272 close D1;
273 open D2, ">testout/d2.tiff" or die;
274 print D2 $tiffdata;
275 close D2;
276
277 # write via cb2
278 $work = '';
279 $seekpos = 0;
280 $did_close = 0;
281 my $IO5 = Imager::io_new_cb(\&io_writer, \&io_reader, \&io_seeker,
282                             \&io_closer, 1);
283 ok($IO5, "new writecb obj 2");
284 ok(Imager::File::TIFF::i_writetiff_wiol($img, $IO5), "write to cb2");
285 is($work, $odata, "write cb2 match");
286 ok($did_close, "write cb2 did close");
287
288 open D3, ">testout/d3.tiff" or die;
289 print D3 $work;
290 close D3;
291
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
330 # multi-image write/read
331 my @imgs;
332 push(@imgs, map $ooim->copy(), 1..3);
333 for my $i (0..$#imgs) {
334   $imgs[$i]->addtag(name=>"tiff_pagename", value=>"Page ".($i+1));
335 }
336 my $rc = Imager->write_multi({file=>'testout/t106_multi.tif'}, @imgs);
337 ok($rc, "writing multiple images to tiff");
338 my @out = Imager->read_multi(file=>'testout/t106_multi.tif');
339 ok(@out == @imgs, "reading multiple images from tiff");
340 @out == @imgs or print "# ",scalar @out, " ",Imager->errstr,"\n";
341 for 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 }
348
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);
353 ok($rc, "writing 40 images to tiff")
354   or diag("writing 40 images: " . Imager->errstr);
355 @out = Imager->read_multi(file=>'testout/t106_multi2.tif');
356 ok(@imgs == @out, "reading 40 images from tiff")
357   or diag("reading 40 images:" . Imager->errstr);
358 # force some allocation activity - helps crash here if it's the problem
359 @out = @imgs = ();
360
361 # multi-image fax files
362 ok(Imager->write_multi({file=>'testout/t106_faxmulti.tiff', class=>'fax'},
363                        $oofim, $oofim), "write multi fax image")
364   or diag("writing 40 fax pages: " . Imager->errstr);
365 @imgs = Imager->read_multi(file=>'testout/t106_faxmulti.tiff');
366 ok(@imgs == 2, "reading multipage fax")
367   or diag("reading 40 fax pages: " . Imager->errstr);
368 ok(Imager::i_img_diff($imgs[0]{IMG}, $oofim->{IMG}) == 0,
369    "compare first fax image");
370 ok(Imager::i_img_diff($imgs[1]{IMG}, $oofim->{IMG}) == 0,
371    "compare second fax image");
372
373 my ($format) = $imgs[0]->tags(name=>'i_format');
374 is($format, 'tiff', "check i_format tag");
375
376 my $unit = $imgs[0]->tags(name=>'tiff_resolutionunit');
377 ok(defined $unit && $unit == 2, "check tiff_resolutionunit tag");
378 my $unitname = $imgs[0]->tags(name=>'tiff_resolutionunit_name');
379 is($unitname, 'inch', "check tiff_resolutionunit_name tag");
380
381 my $warned = Imager->new;
382 ok($warned->read(file=>"testimg/tiffwarn.tif"), "read tiffwarn.tif");
383 my ($warning) = $warned->tags(name=>'i_warning');
384 ok(defined $warning, "check warning is set");
385 like($warning, qr/[Uu]nknown field with tag 28712/,
386      "check that warning tag correct");
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 }
416
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);
425   ok(!$im->write(fh => \*TIFF, type=>'tiff', buffered => 0),
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");
429   ok(!Imager->write_multi({ type => 'tiff', fh => \*TIFF, buffered => 0 }, $im),
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");
433   ok(!$im->write(fh => \*TIFF, type=>'tiff', class=>'fax', buffered => 0),
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");
437   ok(!Imager->write_multi({ type => 'tiff', fh => \*TIFF, class=>'fax', buffered => 0 }, $im),
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 }
442
443 { # test reading returns an error correctly - use test script as an
444   # invalid TIFF file
445   my $im = Imager->new;
446   ok(!$im->read(file=>'t/t10tiff.t', type=>'tiff'),
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 }
459
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 }
473
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");
507     }
508   }
509 }
510
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 }
515
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 }
525
526 SKIP:
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 }
554
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;
560   ok($im16t->read(file => 'testimg/rgb16t.tif'), "read 16-bit rgb tiled");
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 }
583
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");
606
607   # tiled, non-contig, should fallback to RGBA code
608   my $rgbatsep = Imager->new;
609   ok($rgbatsep->read(file => 'testimg/rgbatsep.tif'),
610      "read tiled, separated rgba image")
611     or diag($rgbatsep->errstr);
612   is_image($rgba, $rgbatsep, "check they match");
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 }
623
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) {
651           $ok = 0;
652           $msg = "($x,$y)[$ch] color mismatch got $c[$ch] vs expected $expect->[$ch]";
653           last CHECKER;
654         }
655       }
656     }
657   }
658   ok($ok, $msg);
659 }
660
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;
682       }
683     }
684   }
685   ok($ok, $msg);
686 }
687
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");
699     is($im->tags(name => 'tiff_compression'), 'none', "no compression");
700   is($im->getchannels, 3, 'correct channels');
701 }
702
703 { # 8-bit writes
704   # and check compression
705   my $compress = Imager::File::TIFF::i_tiff_has_compression('lzw') ? 'lzw' : 'packbits';
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 }
723
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 }
740
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 }
770
771 { # fallback handling of tiff
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");
774 }
775
776
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 }
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;
817 49 49 2A 00 0A 00 00 00 FE 00 0A 00 00 01 03 00
818 01 00 00 00 01 00 00 00 01 01 03 00 01 00 00 00
819 01 00 00 00 02 01 03 00 03 00 00 00 88 00 00 00
820 03 01 03 00 01 00 00 00 05 80 00 00 06 01 03 00
821 01 00 00 00 02 00 00 00 11 01 04 00 01 00 00 00
822 08 00 00 00 12 01 03 00 01 00 00 00 01 00 00 00
823 15 01 03 00 01 00 00 00 03 00 00 00 17 01 04 00
824 01 00 00 00 02 00 00 00 1C 01 03 00 01 00 00 00
825 01 00 00 00 90 00 00 00 08 00 08 00 08 00 FE 00
826 0A 00 00 01 03 00 01 00 00 00 01 00 00 00 01 01
827 03 00 01 00 00 00 01 00 00 00 02 01 03 00 03 00
828 00 00 0E 01 00 00 03 01 03 00 01 00 00 00 05 80
829 00 00 06 01 03 00 01 00 00 00 02 00 00 00 11 01
830 04 00 01 00 00 00 8E 00 00 00 12 01 03 00 01 00
831 00 00 01 00 00 00 15 01 03 00 01 00 00 00 03 00
832 00 00 17 01 04 00 01 00 00 00 02 00 00 00 1C 01
833 03 00 01 00 00 00 01 00 00 00 0A 00 00 00 08 00
834 08 00 08 00
835 HEX
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 }