Various changes:
[imager.git] / t / t106tiff.t
1 #!perl -w
2 use strict;
3 use Test::More tests => 127;
4 use Imager qw(:all);
5 $^W=1; # warnings during command-line tests
6 $|=1;  # give us some progress in the test harness
7 init_log("testout/t106tiff.log",1);
8
9 my $green=i_color_new(0,255,0,255);
10 my $blue=i_color_new(0,0,255,255);
11 my $red=i_color_new(255,0,0,255);
12
13 my $img=Imager::ImgRaw::new(150,150,3);
14
15 i_box_filled($img,70,25,130,125,$green);
16 i_box_filled($img,20,25,80,125,$blue);
17 i_arc($img,75,75,30,0,361,$red);
18 i_conv($img,[0.1, 0.2, 0.4, 0.2, 0.1]);
19
20 my $timg = Imager::ImgRaw::new(20, 20, 4);
21 my $trans = i_color_new(255, 0, 0, 127);
22 i_box_filled($timg, 0, 0, 20, 20, $green);
23 i_box_filled($timg, 2, 2, 18, 18, $trans);
24
25 SKIP:
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");
34     skip("no tiff support", 123);
35   }
36
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);
41   Imager::i_tags_add($img, "tiff_software", 0, "t106tiff.t", 0);
42   open(FH,">testout/t106.tiff") || die "cannot open testout/t106.tiff for writing\n";
43   binmode(FH); 
44   my $IO = Imager::io_new_fd(fileno(FH));
45   ok(i_writetiff_wiol($img, $IO), "write low level");
46   close(FH);
47
48   open(FH,"testout/t106.tiff") or die "cannot open testout/t106.tiff\n";
49   binmode(FH);
50   $IO = Imager::io_new_fd(fileno(FH));
51   my $cmpimg = i_readtiff_wiol($IO, -1);
52   ok($cmpimg, "read low-level");
53
54   close(FH);
55
56   print "# tiff average mean square pixel difference: ",sqrt(i_img_diff($img,$cmpimg))/150*150,"\n";
57
58   ok(!i_img_diff($img, $cmpimg), "compare written and read image");
59
60   # check the tags are ok
61   my %tags = map { Imager::i_tags_get($cmpimg, $_) }
62     0 .. Imager::i_tags_count($cmpimg) - 1;
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");
67   is($tags{tiff_photometric}, 2, "tiff_photometric"); # PHOTOMETRIC_RGB is 2
68   is($tags{tiff_bitspersample}, 8, "tiff_bitspersample");
69
70   $IO = Imager::io_new_bufchain();
71   
72   ok(Imager::i_writetiff_wiol($img, $IO), "write to buffer chain");
73   my $tiffdata = Imager::io_slurp($IO);
74
75   open(FH,"testout/t106.tiff");
76   binmode FH;
77   my $odata;
78   { local $/;
79     $odata = <FH>;
80   }
81   
82   is($odata, $tiffdata, "same data in file as in memory");
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));
103   ok(i_writetiff_wiol_faxable($faximg, $IO, 1), "write faxable, low level");
104   close FH;
105
106   # test the OO interface
107   my $ooim = Imager->new;
108   ok($ooim->read(file=>'testout/t106.tiff'), "read OO");
109   ok($ooim->write(file=>'testout/t106_oo.tiff'), "write OO");
110
111   # OO with the fax image
112   my $oofim = Imager->new;
113   ok($oofim->read(file=>'testout/t106tiff_fax.tiff'),
114      "read fax OO");
115
116   # this should have tags set for the resolution
117   %tags = map @$_, $oofim->tags;
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");
121   # resunit_inches
122   is($tags{tiff_resolutionunit}, 2, "tiff_resolutionunit");
123   is($tags{tiff_bitspersample}, 1, "tiff_bitspersample");
124   is($tags{tiff_photometric}, 0, "tiff_photometric");
125
126   ok($oofim->write(file=>'testout/t106_oo_fax.tiff', class=>'fax'),
127      "write OO, faxable");
128
129   # the following should fail since there's no type and no filename
130   my $oodata;
131   ok(!$ooim->write(data=>\$oodata), "write with no type and no filename to guess with");
132
133   # OO to data
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");
137
138   # make sure we can write non-fine mode
139   ok($oofim->write(file=>'testout/t106_oo_faxlo.tiff', class=>'fax', fax_fine=>0), "write OO, fax standard mode");
140
141   # paletted reads
142   my $img4 = Imager->new;
143   ok($img4->read(file=>'testimg/comp4.tif'), "reading 4-bit paletted");
144   is($img4->type, 'paletted', "image isn't paletted");
145   print "# colors: ", $img4->colorcount,"\n";
146   cmp_ok($img4->colorcount, '<=', 16, "more than 16 colors!");
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!");
153   my $diff = i_img_diff($img4->{IMG}, $bmp4->{IMG});
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");
158   is($img8->type, 'paletted', "image isn't paletted");
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;
169   ok($bad->read(file=>'testimg/comp4bad.tif', 
170                 allow_partial=>1), "bad image not returned");
171   ok(scalar $bad->tags(name=>'i_incomplete'), "incomplete tag not set");
172   ok($img8->write(file=>'testout/t106_pal8.tif'), "writing 8-bit paletted");
173   my $cmp8 = Imager->new;
174   ok($cmp8->read(file=>'testout/t106_pal8.tif'),
175      "reading 8-bit paletted");
176   #print "# ",$cmp8->errstr,"\n";
177   is($cmp8->type, 'paletted', "pal8 isn't paletted");
178   is($cmp8->colorcount, 256, "pal8 bad colorcount");
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");
185   is($cmp4->type, 'paletted', "pal4 isn't paletted");
186   is($cmp4->colorcount, 16, "pal4 bad colorcount");
187   $diff = i_img_diff($img4->{IMG}, $cmp4->{IMG});
188   print "# diff $diff\n";
189   ok($diff == 0, "written image doesn't match read");
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");
263   is($work, $odata, "write cb match");
264   ok($did_close, "write cb did close");
265   open D1, ">testout/d1.tiff" or die;
266   print D1 $work;
267   close D1;
268   open D2, ">testout/d2.tiff" or die;
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");
280   is($work, $odata, "write cb2 match");
281   ok($did_close, "write cb2 did close");
282
283   open D3, ">testout/d3.tiff" or die;
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');
302     is($tag, "Page ".($i+1),
303        "tag doesn't match original image");
304   }
305
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;
309   $rc = Imager->write_multi({file=>'testout/t106_multi2.tif'}, @imgs);
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
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");
325
326   my ($format) = $imgs[0]->tags(name=>'i_format');
327   is($format, 'tiff', "check i_format tag");
328
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');
332   is($unitname, 'inch', "check tiff_resolutionunit_name tag");
333
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");
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   }
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");
400     # we get different magic number values depending on the platform
401     # byte ordering
402     cmp_ok($im->errstr, '=~',
403            "Error opening file: Not a TIFF (?:or MDI )?file, bad magic number (8483 \\(0x2123\\)|8993 \\(0x2321\\))", 
404            "check error message");
405     my @ims = Imager->read_multi(file =>'t/t106tiff.t', type=>'tiff');
406     ok(!@ims, "fail to read_multi script as image");
407     cmp_ok($im->errstr, '=~',
408            "Error opening file: Not a TIFF (?:or MDI )?file, bad magic number (8483 \\(0x2123\\)|8993 \\(0x2321\\))", 
409        "check error message");
410   }
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   }
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]"),
443          "read alpha test $test->[0]")
444           or print "# ", $im->errstr, "\n";
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   }
450 }
451