t/t106tiff.t

   1 #!perl -w
   2 use strict;
   3 use lib 't';
   4 use Test::More tests => 89;
   5 use Imager qw(:all);
   6 $^W=1; # warnings during command-line tests
   7 $|=1;  # give us some progress in the test harness
   8 init_log("testout/t106tiff.log",1);
   9
  10 my $green=i_color_new(0,255,0,255);
  11 my $blue=i_color_new(0,0,255,255);
  12 my $red=i_color_new(255,0,0,255);
  13
  14 my $img=Imager::ImgRaw::new(150,150,3);
  15
  16 i_box_filled($img,70,25,130,125,$green);
  17 i_box_filled($img,20,25,80,125,$blue);
  18 i_arc($img,75,75,30,0,361,$red);
  19 i_conv($img,[0.1, 0.2, 0.4, 0.2, 0.1]);
  20
  21 my $timg = Imager::ImgRaw::new(20, 20, 4);
  22 my $trans = i_color_new(255, 0, 0, 127);
  23 i_box_filled($timg, 0, 0, 20, 20, $green);
  24 i_box_filled($timg, 2, 2, 18, 18, $trans);
  25
  26 SKIP:
  27 {
  28   unless (i_has_format("tiff")) {
  29     my $im = Imager->new;
  30     ok(!$im->read(file=>"testimg/comp4.tif"), "should fail to read tif");
  31     is($im->errstr, "format 'tiff' not supported", "check no tiff message");
  32     $im = Imager->new(xsize=>2, ysize=>2);
  33     ok(!$im->write(file=>"testout/notiff.tif"), "should fail to write tiff");
  34     is($im->errstr, 'format not supported', "check no tiff message");
  35     skip("no tiff support", 85);
  36   }
  37
  38   Imager::i_tags_add($img, "i_xres", 0, "300", 0);
  39   Imager::i_tags_add($img, "i_yres", 0, undef, 250);
  40   # resolutionunit is centimeters
  41   Imager::i_tags_add($img, "tiff_resolutionunit", 0, undef, 3);
  42   Imager::i_tags_add($img, "tiff_software", 0, "t106tiff.t", 0);
  43   open(FH,">testout/t106.tiff") || die "cannot open testout/t106.tiff for writing\n";
  44   binmode(FH);
  45   my $IO = Imager::io_new_fd(fileno(FH));
  46   ok(i_writetiff_wiol($img, $IO), "write low level");
  47   close(FH);
  48
  49   open(FH,"testout/t106.tiff") or die "cannot open testout/t106.tiff\n";
  50   binmode(FH);
  51   $IO = Imager::io_new_fd(fileno(FH));
  52   my $cmpimg = i_readtiff_wiol($IO, -1);
  53   ok($cmpimg, "read low-level");
  54
  55   close(FH);
  56
  57   print "# tiff average mean square pixel difference: ",sqrt(i_img_diff($img,$cmpimg))/150*150,"\n";
  58
  59   ok(!i_img_diff($img, $cmpimg), "compare written and read image");
  60
  61   # check the tags are ok
  62   my %tags = map { Imager::i_tags_get($cmpimg, $_) }
  63     0 .. Imager::i_tags_count($cmpimg) - 1;
  64   ok(abs($tags{i_xres} - 300) < 0.5, "i_xres in range");
  65   ok(abs($tags{i_yres} - 250) < 0.5, "i_yres in range");
  66   is($tags{tiff_resolutionunit}, 3, "tiff_resolutionunit");
  67   is($tags{tiff_software}, 't106tiff.t', "tiff_software");
  68   is($tags{tiff_photometric}, 2, "tiff_photometric"); # PHOTOMETRIC_RGB is 2
  69   is($tags{tiff_bitspersample}, 8, "tiff_bitspersample");
  70
  71   $IO = Imager::io_new_bufchain();
  72
  73   ok(Imager::i_writetiff_wiol($img, $IO), "write to buffer chain");
  74   my $tiffdata = Imager::io_slurp($IO);
  75
  76   open(FH,"testout/t106.tiff");
  77   binmode FH;
  78   my $odata;
  79   { local $/;
  80     $odata = <FH>;
  81   }
  82
  83   is($odata, $tiffdata, "same data in file as in memory");
  84
  85   # test Micksa's tiff writer
  86   # a shortish fax page
  87   my $faximg = Imager::ImgRaw::new(1728, 2000, 1);
  88   my $black = i_color_new(0,0,0,255);
  89   my $white = i_color_new(255,255,255,255);
  90   # vaguely test-patterny
  91   i_box_filled($faximg, 0, 0, 1728, 2000, $white);
  92   i_box_filled($faximg, 100,100,1628, 200, $black);
  93   my $width = 1;
  94   my $pos = 100;
  95   while ($width+$pos < 1628) {
  96     i_box_filled($faximg, $pos, 300, $pos+$width-1, 400, $black);
  97     $pos += $width + 20;
  98     $width += 2;
  99   }
 100   open FH, "> testout/t106tiff_fax.tiff"
 101     or die "Cannot create testout/t106tiff_fax.tiff: $!";
 102   binmode FH;
 103   $IO = Imager::io_new_fd(fileno(FH));
 104   ok(i_writetiff_wiol_faxable($faximg, $IO, 1), "write faxable, low level");
 105   close FH;
 106
 107   # test the OO interface
 108   my $ooim = Imager->new;
 109   ok($ooim->read(file=>'testout/t106.tiff'), "read OO");
 110   ok($ooim->write(file=>'testout/t106_oo.tiff'), "write OO");
 111
 112   # OO with the fax image
 113   my $oofim = Imager->new;
 114   ok($oofim->read(file=>'testout/t106tiff_fax.tiff'),
 115      "read fax OO");
 116
 117   # this should have tags set for the resolution
 118   %tags = map @$_, $oofim->tags;
 119   is($tags{i_xres}, 204, "fax i_xres");
 120   is($tags{i_yres}, 196, "fax i_yres");
 121   ok(!$tags{i_aspect_only}, "i_aspect_only");
 122   # resunit_inches
 123   is($tags{tiff_resolutionunit}, 2, "tiff_resolutionunit");
 124   is($tags{tiff_bitspersample}, 1, "tiff_bitspersample");
 125   is($tags{tiff_photometric}, 1, "tiff_photometric");
 126
 127   ok($oofim->write(file=>'testout/t106_oo_fax.tiff', class=>'fax'),
 128      "write OO, faxable");
 129
 130   # the following should fail since there's no type and no filename
 131   my $oodata;
 132   ok(!$ooim->write(data=>\$oodata), "write with no type and no filename to guess with");
 133
 134   # OO to data
 135   ok($ooim->write(data=>\$oodata, type=>'tiff'), "write to data")
 136     or print "# ",$ooim->errstr, "\n";
 137   is($oodata, $tiffdata, "check data matches between memory and file");
 138
 139   # make sure we can write non-fine mode
 140   ok($oofim->write(file=>'testout/t106_oo_faxlo.tiff', class=>'fax', fax_fine=>0), "write OO, fax standard mode");
 141
 142   # paletted reads
 143   my $img4 = Imager->new;
 144   ok($img4->read(file=>'testimg/comp4.tif'), "reading 4-bit paletted");
 145   ok($img4->type eq 'paletted', "image isn't paletted");
 146   print "# colors: ", $img4->colorcount,"\n";
 147   ok($img4->colorcount <= 16, "more than 16 colors!");
 148   #ok($img4->write(file=>'testout/t106_was4.ppm'),
 149   #   "Cannot write img4");
 150   # I know I'm using BMP before it's test, but comp4.tif started life
 151   # as comp4.bmp
 152   my $bmp4 = Imager->new;
 153   ok($bmp4->read(file=>'testimg/comp4.bmp'), "reading 4-bit bmp!");
 154   my $diff = i_img_diff($img4->{IMG}, $bmp4->{IMG});
 155   print "# diff $diff\n";
 156   ok($diff == 0, "image mismatch");
 157   my $img8 = Imager->new;
 158   ok($img8->read(file=>'testimg/comp8.tif'), "reading 8-bit paletted");
 159   ok($img8->type eq 'paletted', "image isn't paletted");
 160   print "# colors: ", $img8->colorcount,"\n";
 161   #ok($img8->write(file=>'testout/t106_was8.ppm'),
 162   #   "Cannot write img8");
 163   ok($img8->colorcount == 256, "more colors than expected");
 164   my $bmp8 = Imager->new;
 165   ok($bmp8->read(file=>'testimg/comp8.bmp'), "reading 8-bit bmp!");
 166   $diff = i_img_diff($img8->{IMG}, $bmp8->{IMG});
 167   print "# diff $diff\n";
 168   ok($diff == 0, "image mismatch");
 169   my $bad = Imager->new;
 170   ok($bad->read(file=>'testimg/comp4bad.tif'), "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   ok($cmp8->type eq 'paletted', "pal8 isn't paletted");
 178   ok($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   ok($cmp4->type eq 'paletted', "pal4 isn't paletted");
 186   ok($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   ok($work eq $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   ok($work eq $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     ok($tag eq "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   ok(defined $format && $format eq '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   ok(defined $unitname && $unitname eq 'inch',
 333      "check tiff_resolutionunit_name tag");
 334
 335   my $warned = Imager->new;
 336   ok($warned->read(file=>"testimg/tiffwarn.tif"), "read tiffwarn.tif");
 337   my ($warning) = $warned->tags(name=>'i_warning');
 338   ok(defined $warning && $warning =~ /unknown field with tag 28712/,
 339      "check that warning tag set and correct");
 340
 341   { # support for reading a given page
 342     # first build a simple test image
 343     my $im1 = Imager->new(xsize=>50, ysize=>50);
 344     $im1->box(filled=>1, color=>$blue);
 345     $im1->addtag(name=>'tiff_pagename', value => "Page One");
 346     my $im2 = Imager->new(xsize=>60, ysize=>60);
 347     $im2->box(filled=>1, color=>$green);
 348     $im2->addtag(name=>'tiff_pagename', value=>"Page Two");
 349
 350     # read second page
 351     my $page_file = 'testout/t106_pages.tif';
 352     ok(Imager->write_multi({ file=> $page_file}, $im1, $im2),
 353        "build simple multiimage for page tests");
 354     my $imwork = Imager->new;
 355     ok($imwork->read(file=>$page_file, page=>1),
 356        "read second page");
 357     is($im2->getwidth, $imwork->getwidth, "check width");
 358     is($im2->getwidth, $imwork->getheight, "check height");
 359     is(i_img_diff($imwork->{IMG}, $im2->{IMG}), 0,
 360        "check image content");
 361     my ($page_name) = $imwork->tags(name=>'tiff_pagename');
 362     is($page_name, 'Page Two', "check tag we set");
 363
 364     # try an out of range page
 365     ok(!$imwork->read(file=>$page_file, page=>2),
 366        "check out of range page");
 367     is($imwork->errstr, "could not switch to page 2", "check message");
 368   }
 369 }