t/t106tiff.t

   1 #!perl -w
   2 print "1..20\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 if (!i_has_format("tiff")) {
  25   for (1..20) {
  26     print "ok $_ # skip no tiff support\n";
  27   }
  28 } else {
  29   Imager::i_tags_add($img, "i_xres", 0, "300", 0);
  30   Imager::i_tags_add($img, "i_yres", 0, undef, 250);
  31   # resolutionunit is centimeters
  32   Imager::i_tags_add($img, "tiff_resolutionunit", 0, undef, 3);
  33   open(FH,">testout/t106.tiff") || die "cannot open testout/t10.tiff for writing\n";
  34   binmode(FH);
  35   my $IO = Imager::io_new_fd(fileno(FH));
  36   i_writetiff_wiol($img, $IO);
  37   close(FH);
  38
  39   print "ok 1\n";
  40
  41   open(FH,"testout/t106.tiff") or die "cannot open testout/t106.tiff\n";
  42   binmode(FH);
  43   $IO = Imager::io_new_fd(fileno(FH));
  44   $cmpimg = i_readtiff_wiol($IO, -1);
  45
  46   close(FH);
  47
  48   print "# tiff average mean square pixel difference: ",sqrt(i_img_diff($img,$cmpimg))/150*150,"\n";
  49   print "ok 2\n";
  50
  51   i_img_diff($img, $cmpimg) and print "not ";
  52   print "ok 3\n";
  53
  54   # check the tags are ok
  55   my %tags = map { Imager::i_tags_get($cmpimg, $_) }
  56     0 .. Imager::i_tags_count($cmpimg) - 1;
  57   abs($tags{i_xres} - 300) < 0.5 or print "not ";
  58   print "ok 4\n";
  59   abs($tags{i_yres} - 250) < 0.5 or print "not ";
  60   print "ok 5\n";
  61   $tags{tiff_resolutionunit} == 3 or print "not ";
  62   print "ok 6\n";
  63
  64   $IO = Imager::io_new_bufchain();
  65
  66   Imager::i_writetiff_wiol($img, $IO) or die "Cannot write to bufferchain\n";
  67   my $tiffdata = Imager::io_slurp($IO);
  68
  69   open(FH,"testout/t106.tiff");
  70   my $odata;
  71   { local $/;
  72     $odata = <FH>;
  73   }
  74
  75   if ($odata eq $tiffdata) {
  76     print "ok 7\n";
  77   } else {
  78     print "not ok 7\n";
  79   }
  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   i_writetiff_wiol_faxable($faximg, $IO, 1)
 101     or print "not ";
 102   print "ok 8\n";
 103   close FH;
 104
 105   # test the OO interface
 106   my $ooim = Imager->new;
 107   $ooim->read(file=>'testout/t106.tiff')
 108     or print "not ";
 109   print "ok 9\n";
 110   $ooim->write(file=>'testout/t106_oo.tiff')
 111     or print "not ";
 112   print "ok 10\n";
 113
 114   # OO with the fax image
 115   my $oofim = Imager->new;
 116   $oofim->read(file=>'testout/t106tiff_fax.tiff')
 117     or print "not ";
 118   print "ok 11\n";
 119
 120   # this should have tags set for the resolution
 121   %tags = map @$_, $oofim->tags;
 122   $tags{i_xres} == 204 or print "not ";
 123   print "ok 12\n";
 124   $tags{i_yres} == 196 or print "not ";
 125   print "ok 13\n";
 126   $tags{i_aspect_only} and print "not ";
 127   print "ok 14\n";
 128   # resunit_inches
 129   $tags{tiff_resolutionunit} == 2 or print "not ";
 130   print "ok 15\n";
 131
 132   $oofim->write(file=>'testout/t106_oo_fax.tiff', class=>'fax')
 133     or print "not ";
 134   print "ok 16\n";
 135
 136   # the following should fail since there's no type and no filename
 137   my $oodata;
 138   $ooim->write(data=>\$oodata)
 139     and print "not ";
 140   print "ok 17\n";
 141
 142   # OO to data
 143   $ooim->write(data=>\$oodata, type=>'tiff')
 144     or print 'not ';
 145   print "ok 18\n";
 146   $oodata eq $tiffdata or print "not ";
 147   print "ok 19\n";
 148
 149   # make sure we can write non-fine mode
 150   $oofim->write(file=>'testout/t106_oo_faxlo.tiff', class=>'fax', fax_fine=>0)
 151     or print "not ";
 152   print "ok 20\n";
 153 }
 154