Various changes:
[imager.git] / t / t106tiff.t
CommitLineData
faa9b3e7 1#!perl -w
66614d6e 2use strict;
a50608d2 3use Test::More tests => 127;
b89b3153 4use Imager qw(:all);
4c2d6970
TC
5$^W=1; # warnings during command-line tests
6$|=1; # give us some progress in the test harness
e2cb7e23 7init_log("testout/t106tiff.log",1);
b89b3153 8
66614d6e
TC
9my $green=i_color_new(0,255,0,255);
10my $blue=i_color_new(0,0,255,255);
11my $red=i_color_new(255,0,0,255);
b89b3153 12
66614d6e 13my $img=Imager::ImgRaw::new(150,150,3);
b89b3153
TC
14
15i_box_filled($img,70,25,130,125,$green);
16i_box_filled($img,20,25,80,125,$blue);
17i_arc($img,75,75,30,0,361,$red);
18i_conv($img,[0.1, 0.2, 0.4, 0.2, 0.1]);
19
20my $timg = Imager::ImgRaw::new(20, 20, 4);
21my $trans = i_color_new(255, 0, 0, 127);
22i_box_filled($timg, 0, 0, 20, 20, $green);
23i_box_filled($timg, 2, 2, 18, 18, $trans);
24
66614d6e
TC
25SKIP:
26{
27 unless (i_has_format("tiff")) {
28 my $im = Imager->new;
29 ok(!$im->read(file=>"testimg/comp4.tif"), "should fail to read tif");
30 is($im->errstr, "format 'tiff' not supported", "check no tiff message");
31 $im = Imager->new(xsize=>2, ysize=>2);
32 ok(!$im->write(file=>"testout/notiff.tif"), "should fail to write tiff");
33 is($im->errstr, 'format not supported', "check no tiff message");
a50608d2 34 skip("no tiff support", 123);
99616a52 35 }
66614d6e 36
faa9b3e7
TC
37 Imager::i_tags_add($img, "i_xres", 0, "300", 0);
38 Imager::i_tags_add($img, "i_yres", 0, undef, 250);
39 # resolutionunit is centimeters
40 Imager::i_tags_add($img, "tiff_resolutionunit", 0, undef, 3);
fd9a31d2 41 Imager::i_tags_add($img, "tiff_software", 0, "t106tiff.t", 0);
5c829fcf 42 open(FH,">testout/t106.tiff") || die "cannot open testout/t106.tiff for writing\n";
b89b3153
TC
43 binmode(FH);
44 my $IO = Imager::io_new_fd(fileno(FH));
66614d6e 45 ok(i_writetiff_wiol($img, $IO), "write low level");
b89b3153
TC
46 close(FH);
47
e2cb7e23 48 open(FH,"testout/t106.tiff") or die "cannot open testout/t106.tiff\n";
b89b3153
TC
49 binmode(FH);
50 $IO = Imager::io_new_fd(fileno(FH));
66614d6e
TC
51 my $cmpimg = i_readtiff_wiol($IO, -1);
52 ok($cmpimg, "read low-level");
b89b3153
TC
53
54 close(FH);
55
56 print "# tiff average mean square pixel difference: ",sqrt(i_img_diff($img,$cmpimg))/150*150,"\n";
b89b3153 57
66614d6e 58 ok(!i_img_diff($img, $cmpimg), "compare written and read image");
4c2d6970 59
faa9b3e7
TC
60 # check the tags are ok
61 my %tags = map { Imager::i_tags_get($cmpimg, $_) }
62 0 .. Imager::i_tags_count($cmpimg) - 1;
66614d6e
TC
63 ok(abs($tags{i_xres} - 300) < 0.5, "i_xres in range");
64 ok(abs($tags{i_yres} - 250) < 0.5, "i_yres in range");
65 is($tags{tiff_resolutionunit}, 3, "tiff_resolutionunit");
66 is($tags{tiff_software}, 't106tiff.t', "tiff_software");
f00e06a0
TC
67 is($tags{tiff_photometric}, 2, "tiff_photometric"); # PHOTOMETRIC_RGB is 2
68 is($tags{tiff_bitspersample}, 8, "tiff_bitspersample");
faa9b3e7 69
b89b3153
TC
70 $IO = Imager::io_new_bufchain();
71
66614d6e 72 ok(Imager::i_writetiff_wiol($img, $IO), "write to buffer chain");
b89b3153
TC
73 my $tiffdata = Imager::io_slurp($IO);
74
e2cb7e23 75 open(FH,"testout/t106.tiff");
607b851c 76 binmode FH;
b89b3153
TC
77 my $odata;
78 { local $/;
79 $odata = <FH>;
80 }
81
66614d6e 82 is($odata, $tiffdata, "same data in file as in memory");
d2dfdcc9
TC
83
84 # test Micksa's tiff writer
85 # a shortish fax page
86 my $faximg = Imager::ImgRaw::new(1728, 2000, 1);
87 my $black = i_color_new(0,0,0,255);
88 my $white = i_color_new(255,255,255,255);
89 # vaguely test-patterny
90 i_box_filled($faximg, 0, 0, 1728, 2000, $white);
91 i_box_filled($faximg, 100,100,1628, 200, $black);
92 my $width = 1;
93 my $pos = 100;
94 while ($width+$pos < 1628) {
95 i_box_filled($faximg, $pos, 300, $pos+$width-1, 400, $black);
96 $pos += $width + 20;
97 $width += 2;
98 }
99 open FH, "> testout/t106tiff_fax.tiff"
100 or die "Cannot create testout/t106tiff_fax.tiff: $!";
101 binmode FH;
102 $IO = Imager::io_new_fd(fileno(FH));
66614d6e 103 ok(i_writetiff_wiol_faxable($faximg, $IO, 1), "write faxable, low level");
d2dfdcc9 104 close FH;
4c2d6970
TC
105
106 # test the OO interface
107 my $ooim = Imager->new;
66614d6e
TC
108 ok($ooim->read(file=>'testout/t106.tiff'), "read OO");
109 ok($ooim->write(file=>'testout/t106_oo.tiff'), "write OO");
4c2d6970
TC
110
111 # OO with the fax image
112 my $oofim = Imager->new;
66614d6e
TC
113 ok($oofim->read(file=>'testout/t106tiff_fax.tiff'),
114 "read fax OO");
faa9b3e7
TC
115
116 # this should have tags set for the resolution
117 %tags = map @$_, $oofim->tags;
66614d6e
TC
118 is($tags{i_xres}, 204, "fax i_xres");
119 is($tags{i_yres}, 196, "fax i_yres");
120 ok(!$tags{i_aspect_only}, "i_aspect_only");
faa9b3e7 121 # resunit_inches
66614d6e 122 is($tags{tiff_resolutionunit}, 2, "tiff_resolutionunit");
f00e06a0 123 is($tags{tiff_bitspersample}, 1, "tiff_bitspersample");
7ebd46b0 124 is($tags{tiff_photometric}, 0, "tiff_photometric");
faa9b3e7 125
66614d6e
TC
126 ok($oofim->write(file=>'testout/t106_oo_fax.tiff', class=>'fax'),
127 "write OO, faxable");
4c2d6970
TC
128
129 # the following should fail since there's no type and no filename
130 my $oodata;
66614d6e 131 ok(!$ooim->write(data=>\$oodata), "write with no type and no filename to guess with");
4c2d6970
TC
132
133 # OO to data
66614d6e
TC
134 ok($ooim->write(data=>\$oodata, type=>'tiff'), "write to data")
135 or print "# ",$ooim->errstr, "\n";
136 is($oodata, $tiffdata, "check data matches between memory and file");
4c2d6970
TC
137
138 # make sure we can write non-fine mode
66614d6e 139 ok($oofim->write(file=>'testout/t106_oo_faxlo.tiff', class=>'fax', fax_fine=>0), "write OO, fax standard mode");
5bb828f1
TC
140
141 # paletted reads
142 my $img4 = Imager->new;
5bb828f1 143 ok($img4->read(file=>'testimg/comp4.tif'), "reading 4-bit paletted");
5386861e 144 is($img4->type, 'paletted', "image isn't paletted");
5bb828f1 145 print "# colors: ", $img4->colorcount,"\n";
5386861e 146 cmp_ok($img4->colorcount, '<=', 16, "more than 16 colors!");
5bb828f1
TC
147 #ok($img4->write(file=>'testout/t106_was4.ppm'),
148 # "Cannot write img4");
149 # I know I'm using BMP before it's test, but comp4.tif started life
150 # as comp4.bmp
151 my $bmp4 = Imager->new;
152 ok($bmp4->read(file=>'testimg/comp4.bmp'), "reading 4-bit bmp!");
66614d6e 153 my $diff = i_img_diff($img4->{IMG}, $bmp4->{IMG});
5bb828f1
TC
154 print "# diff $diff\n";
155 ok($diff == 0, "image mismatch");
156 my $img8 = Imager->new;
157 ok($img8->read(file=>'testimg/comp8.tif'), "reading 8-bit paletted");
5386861e 158 is($img8->type, 'paletted', "image isn't paletted");
5bb828f1
TC
159 print "# colors: ", $img8->colorcount,"\n";
160 #ok($img8->write(file=>'testout/t106_was8.ppm'),
161 # "Cannot write img8");
162 ok($img8->colorcount == 256, "more colors than expected");
163 my $bmp8 = Imager->new;
164 ok($bmp8->read(file=>'testimg/comp8.bmp'), "reading 8-bit bmp!");
165 $diff = i_img_diff($img8->{IMG}, $bmp8->{IMG});
166 print "# diff $diff\n";
167 ok($diff == 0, "image mismatch");
168 my $bad = Imager->new;
9c106321
TC
169 ok($bad->read(file=>'testimg/comp4bad.tif',
170 allow_partial=>1), "bad image not returned");
5bb828f1 171 ok(scalar $bad->tags(name=>'i_incomplete'), "incomplete tag not set");
f62b2d84 172 ok($img8->write(file=>'testout/t106_pal8.tif'), "writing 8-bit paletted");
230e675b
TC
173 my $cmp8 = Imager->new;
174 ok($cmp8->read(file=>'testout/t106_pal8.tif'),
f62b2d84 175 "reading 8-bit paletted");
230e675b 176 #print "# ",$cmp8->errstr,"\n";
5386861e
TC
177 is($cmp8->type, 'paletted', "pal8 isn't paletted");
178 is($cmp8->colorcount, 256, "pal8 bad colorcount");
f62b2d84
TC
179 $diff = i_img_diff($img8->{IMG}, $cmp8->{IMG});
180 print "# diff $diff\n";
181 ok($diff == 0, "written image doesn't match read");
182 ok($img4->write(file=>'testout/t106_pal4.tif'), "writing 4-bit paletted");
183 ok(my $cmp4 = Imager->new->read(file=>'testout/t106_pal4.tif'),
184 "reading 4-bit paletted");
5386861e
TC
185 is($cmp4->type, 'paletted', "pal4 isn't paletted");
186 is($cmp4->colorcount, 16, "pal4 bad colorcount");
f62b2d84
TC
187 $diff = i_img_diff($img4->{IMG}, $cmp4->{IMG});
188 print "# diff $diff\n";
189 ok($diff == 0, "written image doesn't match read");
10461f9a
TC
190
191 my $work;
192 my $seekpos;
193 sub io_writer {
194 my ($what) = @_;
195 if ($seekpos > length $work) {
196 $work .= "\0" x ($seekpos - length $work);
197 }
198 substr($work, $seekpos, length $what) = $what;
199 $seekpos += length $what;
200
201 1;
202 }
203 sub io_reader {
204 my ($size, $maxread) = @_;
205 #print "io_reader($size, $maxread) pos $seekpos\n";
206 my $out = substr($work, $seekpos, $maxread);
207 $seekpos += length $out;
208 $out;
209 }
210 sub io_reader2 {
211 my ($size, $maxread) = @_;
212 #print "io_reader2($size, $maxread) pos $seekpos\n";
213 my $out = substr($work, $seekpos, $size);
214 $seekpos += length $out;
215 $out;
216 }
217 use IO::Seekable;
218 sub io_seeker {
219 my ($offset, $whence) = @_;
220 #print "io_seeker($offset, $whence)\n";
221 if ($whence == SEEK_SET) {
222 $seekpos = $offset;
223 }
224 elsif ($whence == SEEK_CUR) {
225 $seekpos += $offset;
226 }
227 else { # SEEK_END
228 $seekpos = length($work) + $offset;
229 }
230 #print "-> $seekpos\n";
231 $seekpos;
232 }
233 my $did_close;
234 sub io_closer {
235 ++$did_close;
236 }
237
238 # read via cb
239 $work = $tiffdata;
240 $seekpos = 0;
241 my $IO2 = Imager::io_new_cb(undef, \&io_reader, \&io_seeker, undef);
242 ok($IO2, "new readcb obj");
243 my $img5 = i_readtiff_wiol($IO2, -1);
244 ok($img5, "read via cb");
245 ok(i_img_diff($img5, $img) == 0, "read from cb diff");
246
247 # read via cb2
248 $work = $tiffdata;
249 $seekpos = 0;
250 my $IO3 = Imager::io_new_cb(undef, \&io_reader2, \&io_seeker, undef);
251 ok($IO3, "new readcb2 obj");
252 my $img6 = i_readtiff_wiol($IO3, -1);
253 ok($img6, "read via cb2");
254 ok(i_img_diff($img6, $img) == 0, "read from cb2 diff");
255
256 # write via cb
257 $work = '';
258 $seekpos = 0;
259 my $IO4 = Imager::io_new_cb(\&io_writer, \&io_reader, \&io_seeker,
260 \&io_closer);
261 ok($IO4, "new writecb obj");
262 ok(i_writetiff_wiol($img, $IO4), "write to cb");
5386861e 263 is($work, $odata, "write cb match");
10461f9a 264 ok($did_close, "write cb did close");
332033c5 265 open D1, ">testout/d1.tiff" or die;
10461f9a
TC
266 print D1 $work;
267 close D1;
332033c5 268 open D2, ">testout/d2.tiff" or die;
10461f9a
TC
269 print D2 $tiffdata;
270 close D2;
271
272 # write via cb2
273 $work = '';
274 $seekpos = 0;
275 $did_close = 0;
276 my $IO5 = Imager::io_new_cb(\&io_writer, \&io_reader, \&io_seeker,
277 \&io_closer, 1);
278 ok($IO5, "new writecb obj 2");
279 ok(i_writetiff_wiol($img, $IO5), "write to cb2");
5386861e 280 is($work, $odata, "write cb2 match");
10461f9a
TC
281 ok($did_close, "write cb2 did close");
282
332033c5 283 open D3, ">testout/d3.tiff" or die;
10461f9a
TC
284 print D3 $work;
285 close D3;
286
287 # multi-image write/read
288 my @imgs;
289 push(@imgs, map $ooim->copy(), 1..3);
290 for my $i (0..$#imgs) {
291 $imgs[$i]->addtag(name=>"tiff_pagename", value=>"Page ".($i+1));
292 }
293 my $rc = Imager->write_multi({file=>'testout/t106_multi.tif'}, @imgs);
294 ok($rc, "writing multiple images to tiff");
295 my @out = Imager->read_multi(file=>'testout/t106_multi.tif');
296 ok(@out == @imgs, "reading multiple images from tiff");
297 @out == @imgs or print "# ",scalar @out, " ",Imager->errstr,"\n";
298 for my $i (0..$#imgs) {
299 ok(i_img_diff($imgs[$i]{IMG}, $out[$i]{IMG}) == 0,
300 "comparing image $i");
301 my ($tag) = $out[$i]->tags(name=>'tiff_pagename');
5386861e 302 is($tag, "Page ".($i+1),
10461f9a
TC
303 "tag doesn't match original image");
304 }
305
be371490
TC
306 # writing even more images to tiff - we weren't handling more than five
307 # correctly on read
308 @imgs = map $ooim->copy(), 1..40;
0cb68c19 309 $rc = Imager->write_multi({file=>'testout/t106_multi2.tif'}, @imgs);
be371490
TC
310 ok($rc, "writing 40 images to tiff");
311 @out = Imager->read_multi(file=>'testout/t106_multi2.tif');
312 ok(@imgs == @out, "reading 40 images from tiff");
313 # force some allocation activity - helps crash here if it's the problem
314 @out = @imgs = ();
315
10461f9a
TC
316 # multi-image fax files
317 ok(Imager->write_multi({file=>'testout/t106_faxmulti.tiff', class=>'fax'},
318 $oofim, $oofim), "write multi fax image");
319 @imgs = Imager->read_multi(file=>'testout/t106_faxmulti.tiff');
320 ok(@imgs == 2, "reading multipage fax");
321 ok(Imager::i_img_diff($imgs[0]{IMG}, $oofim->{IMG}) == 0,
322 "compare first fax image");
323 ok(Imager::i_img_diff($imgs[1]{IMG}, $oofim->{IMG}) == 0,
324 "compare second fax image");
8c3af7b3
TC
325
326 my ($format) = $imgs[0]->tags(name=>'i_format');
5386861e 327 is($format, 'tiff', "check i_format tag");
ffeb4a67 328
3cff89e2
TC
329 my $unit = $imgs[0]->tags(name=>'tiff_resolutionunit');
330 ok(defined $unit && $unit == 2, "check tiff_resolutionunit tag");
331 my $unitname = $imgs[0]->tags(name=>'tiff_resolutionunit_name');
5386861e 332 is($unitname, 'inch', "check tiff_resolutionunit_name tag");
3cff89e2 333
ffeb4a67
TC
334 my $warned = Imager->new;
335 ok($warned->read(file=>"testimg/tiffwarn.tif"), "read tiffwarn.tif");
336 my ($warning) = $warned->tags(name=>'i_warning');
337 ok(defined $warning && $warning =~ /unknown field with tag 28712/,
338 "check that warning tag set and correct");
8f8bd9aa
TC
339
340 { # support for reading a given page
341 # first build a simple test image
342 my $im1 = Imager->new(xsize=>50, ysize=>50);
343 $im1->box(filled=>1, color=>$blue);
344 $im1->addtag(name=>'tiff_pagename', value => "Page One");
345 my $im2 = Imager->new(xsize=>60, ysize=>60);
346 $im2->box(filled=>1, color=>$green);
347 $im2->addtag(name=>'tiff_pagename', value=>"Page Two");
348
349 # read second page
350 my $page_file = 'testout/t106_pages.tif';
351 ok(Imager->write_multi({ file=> $page_file}, $im1, $im2),
352 "build simple multiimage for page tests");
353 my $imwork = Imager->new;
354 ok($imwork->read(file=>$page_file, page=>1),
355 "read second page");
356 is($im2->getwidth, $imwork->getwidth, "check width");
357 is($im2->getwidth, $imwork->getheight, "check height");
358 is(i_img_diff($imwork->{IMG}, $im2->{IMG}), 0,
359 "check image content");
360 my ($page_name) = $imwork->tags(name=>'tiff_pagename');
361 is($page_name, 'Page Two', "check tag we set");
362
363 # try an out of range page
364 ok(!$imwork->read(file=>$page_file, page=>2),
365 "check out of range page");
366 is($imwork->errstr, "could not switch to page 2", "check message");
367 }
2691d220
TC
368
369 { # test writing returns an error message correctly
370 # open a file read only and try to write to it
371 open TIFF, "> testout/t106_empty.tif" or die;
372 close TIFF;
373 open TIFF, "< testout/t106_empty.tif"
374 or skip "Cannot open testout/t106_empty.tif for reading", 8;
375 binmode TIFF;
376 my $im = Imager->new(xsize=>100, ysize=>100);
377 ok(!$im->write(fh => \*TIFF, type=>'tiff'),
378 "fail to write to read only handle");
379 cmp_ok($im->errstr, '=~', 'Could not create TIFF object: Error writing TIFF header: write\(\)',
380 "check error message");
381 ok(!Imager->write_multi({ type => 'tiff', fh => \*TIFF }, $im),
382 "fail to write multi to read only handle");
383 cmp_ok(Imager->errstr, '=~', 'Could not create TIFF object: Error writing TIFF header: write\(\)',
384 "check error message");
385 ok(!$im->write(fh => \*TIFF, type=>'tiff', class=>'fax'),
386 "fail to write to read only handle (fax)");
387 cmp_ok($im->errstr, '=~', 'Could not create TIFF object: Error writing TIFF header: write\(\)',
388 "check error message");
389 ok(!Imager->write_multi({ type => 'tiff', fh => \*TIFF, class=>'fax' }, $im),
390 "fail to write multi to read only handle (fax)");
391 cmp_ok(Imager->errstr, '=~', 'Could not create TIFF object: Error writing TIFF header: write\(\)',
392 "check error message");
393 }
394
395 { # test reading returns an error correctly - use test script as an
396 # invalid TIFF file
397 my $im = Imager->new;
398 ok(!$im->read(file=>'t/t106tiff.t', type=>'tiff'),
399 "fail to read script as image");
f364e883
TC
400 # we get different magic number values depending on the platform
401 # byte ordering
402 cmp_ok($im->errstr, '=~',
91add018 403 "Error opening file: Not a TIFF (?:or MDI )?file, bad magic number (8483 \\(0x2123\\)|8993 \\(0x2321\\))",
f364e883 404 "check error message");
2691d220
TC
405 my @ims = Imager->read_multi(file =>'t/t106tiff.t', type=>'tiff');
406 ok(!@ims, "fail to read_multi script as image");
f364e883 407 cmp_ok($im->errstr, '=~',
91add018 408 "Error opening file: Not a TIFF (?:or MDI )?file, bad magic number (8483 \\(0x2123\\)|8993 \\(0x2321\\))",
2691d220
TC
409 "check error message");
410 }
2b405c9e
TC
411
412 { # write_multi to data
413 my $data;
414 my $im = Imager->new(xsize => 50, ysize => 50);
415 ok(Imager->write_multi({ data => \$data, type=>'tiff' }, $im, $im),
416 "write multi to in memory");
417 ok(length $data, "make sure something written");
418 my @im = Imager->read_multi(data => $data);
419 is(@im, 2, "make sure we can read it back");
420 is(Imager::i_img_diff($im[0]{IMG}, $im->{IMG}), 0,
421 "check first image");
422 is(Imager::i_img_diff($im[1]{IMG}, $im->{IMG}), 0,
423 "check second image");
424 }
a50608d2
TC
425
426 { # handling of an alpha channel for various images
427 my $photo_rgb = 2;
428 my $photo_cmyk = 5;
429 my $photo_cielab = 8;
430 my @alpha_images =
431 (
432 [ 'srgb.tif', 3, $photo_rgb ],
433 [ 'srgba.tif', 4, $photo_rgb ],
434 [ 'srgbaa.tif', 4, $photo_rgb ],
435 [ 'scmyk.tif', 3, $photo_cmyk ],
436 [ 'scmyka.tif', 4, $photo_cmyk ],
437 [ 'scmykaa.tif', 4, $photo_cmyk ],
438 [ 'slab.tif', 3, $photo_cielab ],
439 );
440 for my $test (@alpha_images) {
441 my $im = Imager->new;
442 ok($im->read(file => "testimg/$test->[0]"),
8a41a626
TC
443 "read alpha test $test->[0]")
444 or print "# ", $im->errstr, "\n";
a50608d2
TC
445 is($im->getchannels, $test->[1], "channels for $test->[0] match");
446 is($im->tags(name=>'tiff_photometric'), $test->[2],
447 "photometric for $test->[0] match");
448 }
449 }
b89b3153 450}
2b405c9e 451