8b15b84b3e707442e2fca1d0a1adc741bd5ec8d6
[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 }