t/t106tiff.t

   1 #!perl -w
   2 print "1..69\n";
   3 use Imager qw(:all);
   4 $^W=1; # warnings during command-line tests
   5 $|=1;  # give us some progress in the test harness
   6 init_log("testout/t106tiff.log",1);
   7
   8 $green=i_color_new(0,255,0,255);
   9 $blue=i_color_new(0,0,255,255);
  10 $red=i_color_new(255,0,0,255);
  11
  12 $img=Imager::ImgRaw::new(150,150,3);
  13
  14 i_box_filled($img,70,25,130,125,$green);
  15 i_box_filled($img,20,25,80,125,$blue);
  16 i_arc($img,75,75,30,0,361,$red);
  17 i_conv($img,[0.1, 0.2, 0.4, 0.2, 0.1]);
  18
  19 my $timg = Imager::ImgRaw::new(20, 20, 4);
  20 my $trans = i_color_new(255, 0, 0, 127);
  21 i_box_filled($timg, 0, 0, 20, 20, $green);
  22 i_box_filled($timg, 2, 2, 18, 18, $trans);
  23
  24 my $test_num;
  25
  26 if (!i_has_format("tiff")) {
  27   for (1..69) {
  28     print "ok $_ # skip no tiff support\n";
  29   }
  30 } else {
  31   Imager::i_tags_add($img, "i_xres", 0, "300", 0);
  32   Imager::i_tags_add($img, "i_yres", 0, undef, 250);
  33   # resolutionunit is centimeters
  34   Imager::i_tags_add($img, "tiff_resolutionunit", 0, undef, 3);
  35   Imager::i_tags_add($img, "tiff_software", 0, "t106tiff.t", 0);
  36   open(FH,">testout/t106.tiff") || die "cannot open testout/t106.tiff for writing\n";
  37   binmode(FH);
  38   my $IO = Imager::io_new_fd(fileno(FH));
  39   i_writetiff_wiol($img, $IO);
  40   close(FH);
  41
  42   print "ok 1\n";
  43
  44   open(FH,"testout/t106.tiff") or die "cannot open testout/t106.tiff\n";
  45   binmode(FH);
  46   $IO = Imager::io_new_fd(fileno(FH));
  47   $cmpimg = i_readtiff_wiol($IO, -1);
  48
  49   close(FH);
  50
  51   print "# tiff average mean square pixel difference: ",sqrt(i_img_diff($img,$cmpimg))/150*150,"\n";
  52   print "ok 2\n";
  53
  54   i_img_diff($img, $cmpimg) and print "not ";
  55   print "ok 3\n";
  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   abs($tags{i_xres} - 300) < 0.5 or print "not ";
  61   print "ok 4\n";
  62   abs($tags{i_yres} - 250) < 0.5 or print "not ";
  63   print "ok 5\n";
  64   $tags{tiff_resolutionunit} == 3 or print "not ";
  65   print "ok 6\n";
  66   $tags{tiff_software} eq 't106tiff.t' or print "not ";
  67   print "ok 7\n";
  68
  69   $IO = Imager::io_new_bufchain();
  70
  71   Imager::i_writetiff_wiol($img, $IO) or die "Cannot write to bufferchain\n";
  72   my $tiffdata = Imager::io_slurp($IO);
  73
  74   open(FH,"testout/t106.tiff");
  75   binmode FH;
  76   my $odata;
  77   { local $/;
  78     $odata = <FH>;
  79   }
  80
  81   if ($odata eq $tiffdata) {
  82     print "ok 8\n";
  83   } else {
  84     print "not ok 8\n";
  85   }
  86
  87   # test Micksa's tiff writer
  88   # a shortish fax page
  89   my $faximg = Imager::ImgRaw::new(1728, 2000, 1);
  90   my $black = i_color_new(0,0,0,255);
  91   my $white = i_color_new(255,255,255,255);
  92   # vaguely test-patterny
  93   i_box_filled($faximg, 0, 0, 1728, 2000, $white);
  94   i_box_filled($faximg, 100,100,1628, 200, $black);
  95   my $width = 1;
  96   my $pos = 100;
  97   while ($width+$pos < 1628) {
  98     i_box_filled($faximg, $pos, 300, $pos+$width-1, 400, $black);
  99     $pos += $width + 20;
 100     $width += 2;
 101   }
 102   open FH, "> testout/t106tiff_fax.tiff"
 103     or die "Cannot create testout/t106tiff_fax.tiff: $!";
 104   binmode FH;
 105   $IO = Imager::io_new_fd(fileno(FH));
 106   i_writetiff_wiol_faxable($faximg, $IO, 1)
 107     or print "not ";
 108   print "ok 9\n";
 109   close FH;
 110
 111   # test the OO interface
 112   my $ooim = Imager->new;
 113   $ooim->read(file=>'testout/t106.tiff')
 114     or print "not ";
 115   print "ok 10\n";
 116   $ooim->write(file=>'testout/t106_oo.tiff')
 117     or print "not ";
 118   print "ok 11\n";
 119
 120   # OO with the fax image
 121   my $oofim = Imager->new;
 122   $oofim->read(file=>'testout/t106tiff_fax.tiff')
 123     or print "not ";
 124   print "ok 12\n";
 125
 126   # this should have tags set for the resolution
 127   %tags = map @$_, $oofim->tags;
 128   $tags{i_xres} == 204 or print "not ";
 129   print "ok 13\n";
 130   $tags{i_yres} == 196 or print "not ";
 131   print "ok 14\n";
 132   $tags{i_aspect_only} and print "not ";
 133   print "ok 15\n";
 134   # resunit_inches
 135   $tags{tiff_resolutionunit} == 2 or print "not ";
 136   print "ok 16\n";
 137
 138   $oofim->write(file=>'testout/t106_oo_fax.tiff', class=>'fax')
 139     or print "not ";
 140   print "ok 17\n";
 141
 142   # the following should fail since there's no type and no filename
 143   my $oodata;
 144   $ooim->write(data=>\$oodata)
 145     and print "not ";
 146   print "ok 18\n";
 147
 148   # OO to data
 149   $ooim->write(data=>\$oodata, type=>'tiff')
 150     or print 'not ';
 151   print "ok 19\n";
 152   $oodata eq $tiffdata or print "not ";
 153   print "ok 20\n";
 154
 155   # make sure we can write non-fine mode
 156   $oofim->write(file=>'testout/t106_oo_faxlo.tiff', class=>'fax', fax_fine=>0)
 157     or print "not ";
 158   print "ok 21\n";
 159
 160   # paletted reads
 161   my $img4 = Imager->new;
 162   $test_num = 22;
 163   ok($img4->read(file=>'testimg/comp4.tif'), "reading 4-bit paletted");
 164   ok($img4->type eq 'paletted', "image isn't paletted");
 165   print "# colors: ", $img4->colorcount,"\n";
 166   ok($img4->colorcount <= 16, "more than 16 colors!");
 167   #ok($img4->write(file=>'testout/t106_was4.ppm'),
 168   #   "Cannot write img4");
 169   # I know I'm using BMP before it's test, but comp4.tif started life
 170   # as comp4.bmp
 171   my $bmp4 = Imager->new;
 172   ok($bmp4->read(file=>'testimg/comp4.bmp'), "reading 4-bit bmp!");
 173   $diff = i_img_diff($img4->{IMG}, $bmp4->{IMG});
 174   print "# diff $diff\n";
 175   ok($diff == 0, "image mismatch");
 176   my $img8 = Imager->new;
 177   ok($img8->read(file=>'testimg/comp8.tif'), "reading 8-bit paletted");
 178   ok($img8->type eq 'paletted', "image isn't paletted");
 179   print "# colors: ", $img8->colorcount,"\n";
 180   #ok($img8->write(file=>'testout/t106_was8.ppm'),
 181   #   "Cannot write img8");
 182   ok($img8->colorcount == 256, "more colors than expected");
 183   my $bmp8 = Imager->new;
 184   ok($bmp8->read(file=>'testimg/comp8.bmp'), "reading 8-bit bmp!");
 185   $diff = i_img_diff($img8->{IMG}, $bmp8->{IMG});
 186   print "# diff $diff\n";
 187   ok($diff == 0, "image mismatch");
 188   my $bad = Imager->new;
 189   ok($bad->read(file=>'testimg/comp4bad.tif'), "bad image not returned");
 190   ok(scalar $bad->tags(name=>'i_incomplete'), "incomplete tag not set");
 191   ok($img8->write(file=>'testout/t106_pal8.tif'), "writing 8-bit paletted");
 192   my $cmp8 = Imager->new;
 193   ok($cmp8->read(file=>'testout/t106_pal8.tif'),
 194      "reading 8-bit paletted");
 195   #print "# ",$cmp8->errstr,"\n";
 196   ok($cmp8->type eq 'paletted', "pal8 isn't paletted");
 197   ok($cmp8->colorcount == 256, "pal8 bad colorcount");
 198   $diff = i_img_diff($img8->{IMG}, $cmp8->{IMG});
 199   print "# diff $diff\n";
 200   ok($diff == 0, "written image doesn't match read");
 201   ok($img4->write(file=>'testout/t106_pal4.tif'), "writing 4-bit paletted");
 202   ok(my $cmp4 = Imager->new->read(file=>'testout/t106_pal4.tif'),
 203      "reading 4-bit paletted");
 204   ok($cmp4->type eq 'paletted', "pal4 isn't paletted");
 205   ok($cmp4->colorcount == 16, "pal4 bad colorcount");
 206   $diff = i_img_diff($img4->{IMG}, $cmp4->{IMG});
 207   print "# diff $diff\n";
 208   ok($diff == 0, "written image doesn't match read");
 209
 210   my $work;
 211   my $seekpos;
 212   sub io_writer {
 213     my ($what) = @_;
 214     if ($seekpos > length $work) {
 215       $work .= "\0" x ($seekpos - length $work);
 216     }
 217     substr($work, $seekpos, length $what) = $what;
 218     $seekpos += length $what;
 219
 220     1;
 221   }
 222   sub io_reader {
 223     my ($size, $maxread) = @_;
 224     #print "io_reader($size, $maxread) pos $seekpos\n";
 225     my $out = substr($work, $seekpos, $maxread);
 226     $seekpos += length $out;
 227     $out;
 228   }
 229   sub io_reader2 {
 230     my ($size, $maxread) = @_;
 231     #print "io_reader2($size, $maxread) pos $seekpos\n";
 232     my $out = substr($work, $seekpos, $size);
 233     $seekpos += length $out;
 234     $out;
 235   }
 236   use IO::Seekable;
 237   sub io_seeker {
 238     my ($offset, $whence) = @_;
 239     #print "io_seeker($offset, $whence)\n";
 240     if ($whence == SEEK_SET) {
 241       $seekpos = $offset;
 242     }
 243     elsif ($whence == SEEK_CUR) {
 244       $seekpos += $offset;
 245     }
 246     else { # SEEK_END
 247       $seekpos = length($work) + $offset;
 248     }
 249     #print "-> $seekpos\n";
 250     $seekpos;
 251   }
 252   my $did_close;
 253   sub io_closer {
 254     ++$did_close;
 255   }
 256
 257   # read via cb
 258   $work = $tiffdata;
 259   $seekpos = 0;
 260   my $IO2 = Imager::io_new_cb(undef, \&io_reader, \&io_seeker, undef);
 261   ok($IO2, "new readcb obj");
 262   my $img5 = i_readtiff_wiol($IO2, -1);
 263   ok($img5, "read via cb");
 264   ok(i_img_diff($img5, $img) == 0, "read from cb diff");
 265
 266   # read via cb2
 267   $work = $tiffdata;
 268   $seekpos = 0;
 269   my $IO3 = Imager::io_new_cb(undef, \&io_reader2, \&io_seeker, undef);
 270   ok($IO3, "new readcb2 obj");
 271   my $img6 = i_readtiff_wiol($IO3, -1);
 272   ok($img6, "read via cb2");
 273   ok(i_img_diff($img6, $img) == 0, "read from cb2 diff");
 274
 275   # write via cb
 276   $work = '';
 277   $seekpos = 0;
 278   my $IO4 = Imager::io_new_cb(\&io_writer, \&io_reader, \&io_seeker,
 279                               \&io_closer);
 280   ok($IO4, "new writecb obj");
 281   ok(i_writetiff_wiol($img, $IO4), "write to cb");
 282   ok($work eq $odata, "write cb match");
 283   ok($did_close, "write cb did close");
 284   open D1, ">testout/d1.tiff" or die;
 285   print D1 $work;
 286   close D1;
 287   open D2, ">testout/d2.tiff" or die;
 288   print D2 $tiffdata;
 289   close D2;
 290
 291   # write via cb2
 292   $work = '';
 293   $seekpos = 0;
 294   $did_close = 0;
 295   my $IO5 = Imager::io_new_cb(\&io_writer, \&io_reader, \&io_seeker,
 296                               \&io_closer, 1);
 297   ok($IO5, "new writecb obj 2");
 298   ok(i_writetiff_wiol($img, $IO5), "write to cb2");
 299   ok($work eq $odata, "write cb2 match");
 300   ok($did_close, "write cb2 did close");
 301
 302   open D3, ">testout/d3.tiff" or die;
 303   print D3 $work;
 304   close D3;
 305
 306   # multi-image write/read
 307   my @imgs;
 308   push(@imgs, map $ooim->copy(), 1..3);
 309   for my $i (0..$#imgs) {
 310     $imgs[$i]->addtag(name=>"tiff_pagename", value=>"Page ".($i+1));
 311   }
 312   my $rc = Imager->write_multi({file=>'testout/t106_multi.tif'}, @imgs);
 313   ok($rc, "writing multiple images to tiff");
 314   my @out = Imager->read_multi(file=>'testout/t106_multi.tif');
 315   ok(@out == @imgs, "reading multiple images from tiff");
 316   @out == @imgs or print "# ",scalar @out, " ",Imager->errstr,"\n";
 317   for my $i (0..$#imgs) {
 318     ok(i_img_diff($imgs[$i]{IMG}, $out[$i]{IMG}) == 0,
 319        "comparing image $i");
 320     my ($tag) = $out[$i]->tags(name=>'tiff_pagename');
 321     ok($tag eq "Page ".($i+1),
 322        "tag doesn't match original image");
 323   }
 324
 325   # multi-image fax files
 326   ok(Imager->write_multi({file=>'testout/t106_faxmulti.tiff', class=>'fax'},
 327                          $oofim, $oofim), "write multi fax image");
 328   @imgs = Imager->read_multi(file=>'testout/t106_faxmulti.tiff');
 329   ok(@imgs == 2, "reading multipage fax");
 330   ok(Imager::i_img_diff($imgs[0]{IMG}, $oofim->{IMG}) == 0,
 331      "compare first fax image");
 332   ok(Imager::i_img_diff($imgs[1]{IMG}, $oofim->{IMG}) == 0,
 333      "compare second fax image");
 334 }
 335
 336 sub ok {
 337   my ($ok, $msg) = @_;
 338
 339   if ($ok) {
 340     print "ok ",$test_num++,"\n";
 341   }
 342   else {
 343     print "not ok ", $test_num++," # line ",(caller)[2]," $msg\n";
 344   }
 345 }