[rt #74540] handle the TIFF SampleFormat tag
authorTony Cook <tony@develop-help.com>
Mon, 20 May 2013 13:31:38 +0000 (23:31 +1000)
committerTony Cook <tony@develop-help.com>
Mon, 20 May 2013 13:31:38 +0000 (23:31 +1000)
13 files changed:
Changes
MANIFEST
MANIFEST.SKIP
TIFF/Changes
TIFF/MANIFEST
TIFF/Makefile.PL
TIFF/TIFF.pm
TIFF/TIFF.xs
TIFF/imtiff.c
TIFF/t/t10tiff.t
TIFF/testimg/grey16sg.tif [new file with mode: 0644]
TIFF/testimg/srgba32f.tif [new file with mode: 0644]
fileformatdocs/tiffsigned.pl [new file with mode: 0644]

diff --git a/Changes b/Changes
index 52f9bdd..11a887a 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,5 +1,19 @@
 Imager release history.  Older releases can be found in Changes.old
 
+ - TIFF: handle SampleFormat = 2 by translating the signed integer
+   values to unsigned by flipping their sign bits.
+
+   Handle SampleFormat = 3 where possible.
+
+   SampleFormat is ignored for paletted images.
+
+   Mixed SampleFormat are be handled incorrectly, since libtiff
+   returns only the first SampleFormat value, and an image with both
+   an alpha channel and SampleFormat = 2 for color channels probably
+   has a different SampleFormat for the alpha channel.
+
+   https://rt.cpan.org/Ticket/Display.html?id=74540
+
 Imager 0.96 - 19 May 2013
 ===========
 
index a0ae7de..a6757d6 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -483,6 +483,7 @@ TIFF/testimg/comp8.bmp              Compressed 8-bit/pixel BMP
 TIFF/testimg/comp8.tif         8-bit/pixel paletted TIFF
 TIFF/testimg/gralpha.tif       Grey alpha test image
 TIFF/testimg/grey16.tif                16-bit/sample greyscale TIFF
+TIFF/testimg/grey16sg.tif      signed 16-bit/sample greyscale TIFF
 TIFF/testimg/grey32.tif                32-bit/sample greyscale+alpha TIFF
 TIFF/testimg/imager.pbm                Test bi-level
 TIFF/testimg/imager.tif                Test bi-level
@@ -500,6 +501,7 @@ TIFF/testimg/srgb.tif               Simple RGB image
 TIFF/testimg/srgba.tif         RGB with one alpha
 TIFF/testimg/srgba16.tif
 TIFF/testimg/srgba32.tif
+TIFF/testimg/srgba32f.tif      floating point sample RGBA
 TIFF/testimg/srgbaa.tif                RGB with 2 alpha
 TIFF/testimg/tiffwarn.tif      Generates a warning while being read
 TIFF/TIFF.pm
index 96d847e..9743d39 100644 (file)
@@ -27,6 +27,7 @@
 # editor trash
 ~$
 (^|/)\#.*\#$
+(^|/)\.\#
 
 # stuff we don't distribute
 ^TODO$
index eb1609e..f005596 100644 (file)
@@ -1,3 +1,20 @@
+Imager-File-TIFF 0.88
+=====================
+
+ - handle SampleFormat = 2 by translating the signed integer values to
+   unsigned by flipping their sign bits.
+
+   Handle SampleFormat = 3 where possible.
+
+   SampleFormat is ignored for paletted images.
+
+   Mixed SampleFormat are be handled incorrectly, since libtiff
+   returns only the first SampleFormat value, and an image with both
+   an alpha channel and SampleFormat = 2 for color channels probably
+   has a different SampleFormat for the alpha channel.
+
+   https://rt.cpan.org/Ticket/Display.html?id=74540
+
 Imager-File-TIFF 0.87
 =====================
 
index ceabaa8..4c1d84d 100644 (file)
@@ -16,6 +16,7 @@ testimg/comp8.bmp             Compressed 8-bit/pixel BMP
 testimg/comp8.tif              8-bit/pixel paletted TIFF
 testimg/gralpha.tif            Grey alpha test image
 testimg/grey16.tif             16-bit/sample greyscale TIFF
+testimg/grey16sg.tif           signed 16-bit/sample greyscale TIFF
 testimg/grey32.tif             32-bit/sample greyscale+alpha TIFF
 testimg/imager.pbm             Test bi-level
 testimg/imager.tif             Test bi-level
@@ -33,6 +34,7 @@ testimg/srgb.tif              Simple RGB image
 testimg/srgba.tif              RGB with one alpha
 testimg/srgba16.tif
 testimg/srgba32.tif
+testimg/srgba32f.tif           floating point sample RGBA
 testimg/srgbaa.tif             RGB with 2 alpha
 testimg/tiffwarn.tif           Generates a warning while being read
 TIFF.pm
index c292442..c8a8c38 100644 (file)
@@ -17,11 +17,18 @@ our %IMAGER_LIBS;
 
 my $MM_ver = eval $ExtUtils::MakeMaker::VERSION;
 
+my $define = "";
+my $fp_rep = unpack("H*", pack("f<", 1.25));
+if ($fp_rep eq "0000a03f") {
+  $define = "-DIEEEFP_TYPES";
+}
+
 my %opts = 
   (
    NAME => 'Imager::File::TIFF',
    VERSION_FROM => 'TIFF.pm',
    OBJECT => 'TIFF.o imtiff.o',
+   DEFINE => $define,
    clean => { FILES => 'testout' },
   );
 
@@ -86,7 +93,7 @@ if ($probe_res) {
 
   push @inc, $probe_res->{INC};
   $opts{LIBS} = $probe_res->{LIBS};
-  $opts{DEFINE} = $probe_res->{DEFINE};
+  $opts{DEFINE} .= " $probe_res->{DEFINE}";
   $opts{INC} = "@inc";
 
   if ($MM_ver > 6.06) {
index 9dd37f8..204ebcc 100644 (file)
@@ -4,7 +4,7 @@ use Imager;
 use vars qw($VERSION @ISA);
 
 BEGIN {
-  $VERSION = "0.87";
+  $VERSION = "0.88";
 
   require XSLoader;
   XSLoader::load('Imager::File::TIFF', $VERSION);
index c57486c..43be5af 100644 (file)
@@ -11,6 +11,12 @@ extern "C" {
 
 DEFINE_IMAGER_CALLBACKS;
 
+#ifdef IEEEFP_TYPES
+#define i_tiff_ieeefp() &PL_sv_yes
+#else
+#define i_tiff_ieeefp() &PL_sv_no
+#endif
+
 MODULE = Imager::File::TIFF  PACKAGE = Imager::File::TIFF
 
 Imager::ImgRaw
@@ -140,6 +146,8 @@ bool
 i_tiff_has_compression(name)
        const char *name
 
+SV *
+i_tiff_ieeefp()
 
 BOOT:
        PERL_INITIALIZE_IMAGER_CALLBACKS;
index 0bce6b2..ba1cc1f 100644 (file)
@@ -87,6 +87,18 @@ compress_values[] =
 static const int compress_value_count = 
   sizeof(compress_values) / sizeof(*compress_values);
 
+static struct tag_name
+sample_format_values[] =
+  {
+    "uint",      SAMPLEFORMAT_UINT,
+    "int",       SAMPLEFORMAT_INT,
+    "ieeefp",    SAMPLEFORMAT_IEEEFP,
+    "undefined", SAMPLEFORMAT_VOID,
+  };
+
+static const int sample_format_value_count = 
+  sizeof(sample_format_values) / sizeof(*sample_format_values);
+
 static int 
 myTIFFIsCODECConfigured(uint16 scheme);
 
@@ -130,6 +142,14 @@ struct read_state_tag {
      we use is EXTRASAMPLE_ASSOCALPHA then the color data will need to
      be scaled to match Imager's conventions */
   int scale_alpha;
+
+  /* number of color samples (not including alpha) */
+  int color_channels;
+
+  /* SampleFormat is 2 */
+  int sample_signed;
+
+  int sample_format;
 };
 
 static int tile_contig_getter(read_state_t *state, read_putter_t putter);
@@ -362,6 +382,7 @@ static i_img *read_one_tiff(TIFF *tif, int allow_incomplete) {
   uint16 planar_config;
   uint16 inkset;
   uint16 compress;
+  uint16 sample_format;
   int i;
   read_state_t state;
   read_setup_t setupf = NULL;
@@ -370,6 +391,7 @@ static i_img *read_one_tiff(TIFF *tif, int allow_incomplete) {
   int channels = MAXCHANNELS;
   size_t sample_size = ~0; /* force failure if some code doesn't set it */
   i_img_dim total_pixels;
+  int samples_integral;
 
   error = 0;
 
@@ -382,6 +404,13 @@ static i_img *read_one_tiff(TIFF *tif, int allow_incomplete) {
   TIFFGetFieldDefaulted(tif, TIFFTAG_PLANARCONFIG, &planar_config);
   TIFFGetFieldDefaulted(tif, TIFFTAG_INKSET, &inkset);
 
+  if (samples_per_pixel == 0) {
+    i_push_error(0, "invalid image: SamplesPerPixel is 0");
+    return NULL;
+  }
+
+  TIFFGetFieldDefaulted(tif, TIFFTAG_SAMPLEFORMAT, &sample_format);
+
   mm_log((1, "i_readtiff_wiol: width=%d, height=%d, channels=%d\n", width, height, samples_per_pixel));
   mm_log((1, "i_readtiff_wiol: %stiled\n", tiled?"":"not "));
   mm_log((1, "i_readtiff_wiol: %sbyte swapped\n", TIFFIsByteSwapped(tif)?"":"not "));
@@ -395,9 +424,16 @@ static i_img *read_one_tiff(TIFF *tif, int allow_incomplete) {
   state.bits_per_sample = bits_per_sample;
   state.samples_per_pixel = samples_per_pixel;
   state.photometric = photometric;
+  state.sample_signed = sample_format == SAMPLEFORMAT_INT;
+  state.sample_format = sample_format;
+
+  samples_integral = sample_format == SAMPLEFORMAT_UINT
+    || sample_format == SAMPLEFORMAT_INT 
+    || sample_format == SAMPLEFORMAT_VOID;  /* sample as UINT */
 
   /* yes, this if() is horrible */
-  if (photometric == PHOTOMETRIC_PALETTE && bits_per_sample <= 8) {
+  if (photometric == PHOTOMETRIC_PALETTE && bits_per_sample <= 8
+      && samples_integral) {
     setupf = setup_paletted;
     if (bits_per_sample == 8)
       putterf = paletted_putter8;
@@ -411,28 +447,32 @@ static i_img *read_one_tiff(TIFF *tif, int allow_incomplete) {
   }
   else if (bits_per_sample == 16 
           && photometric == PHOTOMETRIC_RGB
-          && samples_per_pixel >= 3) {
+          && samples_per_pixel >= 3
+          && samples_integral) {
     setupf = setup_16_rgb;
     putterf = putter_16;
     sample_size = 2;
     rgb_channels(&state, &channels);
   }
   else if (bits_per_sample == 16
-          && photometric == PHOTOMETRIC_MINISBLACK) {
+          && photometric == PHOTOMETRIC_MINISBLACK
+          && samples_integral) {
     setupf = setup_16_grey;
     putterf = putter_16;
     sample_size = 2;
     grey_channels(&state, &channels);
   }
   else if (bits_per_sample == 8
-          && photometric == PHOTOMETRIC_MINISBLACK) {
+          && photometric == PHOTOMETRIC_MINISBLACK
+          && samples_integral) {
     setupf = setup_8_grey;
     putterf = putter_8;
     sample_size = 1;
     grey_channels(&state, &channels);
   }
   else if (bits_per_sample == 8
-          && photometric == PHOTOMETRIC_RGB) {
+          && photometric == PHOTOMETRIC_RGB
+          && samples_integral) {
     setupf = setup_8_rgb;
     putterf = putter_8;
     sample_size = 1;
@@ -465,7 +505,8 @@ static i_img *read_one_tiff(TIFF *tif, int allow_incomplete) {
   else if (bits_per_sample == 8
           && photometric == PHOTOMETRIC_SEPARATED
           && inkset == INKSET_CMYK
-          && samples_per_pixel >= 4) {
+          && samples_per_pixel >= 4
+          && samples_integral) {
     setupf = setup_cmyk8;
     putterf = putter_cmyk8;
     sample_size = 1;
@@ -474,7 +515,8 @@ static i_img *read_one_tiff(TIFF *tif, int allow_incomplete) {
   else if (bits_per_sample == 16
           && photometric == PHOTOMETRIC_SEPARATED
           && inkset == INKSET_CMYK
-          && samples_per_pixel >= 4) {
+          && samples_per_pixel >= 4
+          && samples_integral) {
     setupf = setup_cmyk16;
     putterf = putter_cmyk16;
     sample_size = 2;
@@ -607,12 +649,25 @@ static i_img *read_one_tiff(TIFF *tif, int allow_incomplete) {
       break;
     }
   }
-  
+
+  if (TIFFGetField(tif, TIFFTAG_SAMPLEFORMAT, &sample_format)) {
+    /* only set the tag if the the TIFF tag is present */
+    i_tags_setn(&im->tags, "tiff_sample_format", sample_format);
+
+    for (i = 0; i < sample_format_value_count; ++i) {
+      if (sample_format_values[i].tag == sample_format) {
+       i_tags_set(&im->tags, "tiff_sample_format_name",
+                  sample_format_values[i].name, -1);
+       break;
+      }
+    }
+  }
+
   return im;
 }
 
 /*
-=item i_readtiff_wiol(im, ig)
+=item i_readtiff_wiol(ig, allow_incomplete, page)
 
 =cut
 */
@@ -2278,6 +2333,7 @@ rgb_channels(read_state_t *state, int *out_channels) {
   *out_channels = 3;
   state->alpha_chan = 0;
   state->scale_alpha = 0;
+  state->color_channels = 3;
 
   /* plain RGB */
   if (state->samples_per_pixel == 3)
@@ -2323,6 +2379,7 @@ grey_channels(read_state_t *state, int *out_channels) {
   *out_channels = 1;
   state->alpha_chan = 0;
   state->scale_alpha = 0;
+  state->color_channels = 1;
 
   /* plain grey */
   if (state->samples_per_pixel == 1)
@@ -2402,6 +2459,10 @@ putter_16(read_state_t *state, i_img_dim x, i_img_dim y, i_img_dim width, i_img_
       for (ch = 0; ch < out_chan; ++ch) {
        outp[ch] = p[ch];
       }
+      if (state->sample_signed) {
+       for (ch = 0; ch < state->color_channels; ++ch)
+         outp[ch] ^= 0x8000;
+      }
       if (state->alpha_chan && state->scale_alpha && outp[state->alpha_chan]) {
        for (ch = 0; ch < state->alpha_chan; ++ch) {
          int result = 0.5 + (outp[ch] * 65535.0 / outp[state->alpha_chan]);
@@ -2466,6 +2527,10 @@ putter_8(read_state_t *state, i_img_dim x, i_img_dim y, i_img_dim width, i_img_d
       for (ch = 0; ch < out_chan; ++ch) {
        outp->channel[ch] = p[ch];
       }
+      if (state->sample_signed) {
+       for (ch = 0; ch < state->color_channels; ++ch)
+         outp->channel[ch] ^= 0x80;
+      }
       if (state->alpha_chan && state->scale_alpha 
          && outp->channel[state->alpha_chan]) {
        for (ch = 0; ch < state->alpha_chan; ++ch) {
@@ -2529,9 +2594,25 @@ putter_32(read_state_t *state, i_img_dim x, i_img_dim y, i_img_dim width, i_img_
     i_fcolor *outp = state->line_buf;
 
     for (i = 0; i < width; ++i) {
-      for (ch = 0; ch < out_chan; ++ch) {
-       outp->channel[ch] = p[ch] / 4294967295.0;
+#ifdef IEEEFP_TYPES
+      if (state->sample_format == SAMPLEFORMAT_IEEEFP) {
+       const float *pv = (const float *)p;
+       for (ch = 0; ch < out_chan; ++ch) {
+         outp->channel[ch] = pv[ch];
+       }
+      }
+      else {
+#endif
+       for (ch = 0; ch < out_chan; ++ch) {
+         if (state->sample_signed && ch < state->color_channels)
+           outp->channel[ch] = (p[ch] ^ 0x80000000UL) / 4294967295.0;
+         else
+           outp->channel[ch] = p[ch] / 4294967295.0;
+       }
+#ifdef IEEEFP_TYPES
       }
+#endif
+
       if (state->alpha_chan && state->scale_alpha && outp->channel[state->alpha_chan]) {
        for (ch = 0; ch < state->alpha_chan; ++ch)
          outp->channel[ch] /= outp->channel[state->alpha_chan];
@@ -2616,6 +2697,7 @@ cmyk_channels(read_state_t *state, int *out_channels) {
   *out_channels = 3;
   state->alpha_chan = 0;
   state->scale_alpha = 0;
+  state->color_channels = 3;
 
   /* plain CMYK */
   if (state->samples_per_pixel == 4)
@@ -2680,6 +2762,12 @@ putter_cmyk8(read_state_t *state, i_img_dim x, i_img_dim y, i_img_dim width, i_i
       m = p[1];
       y = p[2];
       k = 255 - p[3];
+      if (state->sample_signed) {
+       c ^= 0x80;
+       m ^= 0x80;
+       y ^= 0x80;
+       k ^= 0x80;
+      }
       outp->rgba.r = (k * (255 - c)) / 255;
       outp->rgba.g = (k * (255 - m)) / 255;
       outp->rgba.b = (k * (255 - y)) / 255;
@@ -2741,6 +2829,12 @@ putter_cmyk16(read_state_t *state, i_img_dim x, i_img_dim y, i_img_dim width, i_
       m = p[1];
       y = p[2];
       k = 65535 - p[3];
+      if (state->sample_signed) {
+       c ^= 0x8000;
+       m ^= 0x8000;
+       y ^= 0x8000;
+       k ^= 0x8000;
+      }
       outp[0] = (k * (65535U - c)) / 65535U;
       outp[1] = (k * (65535U - m)) / 65535U;
       outp[2] = (k * (65535U - y)) / 65535U;
index 40d15ae..698f8a4 100644 (file)
@@ -1,6 +1,6 @@
 #!perl -w
 use strict;
-use Test::More tests => 239;
+use Test::More tests => 247;
 use Imager qw(:all);
 use Imager::Test qw(is_image is_image_similar test_image test_image_16 test_image_double test_image_raw);
 
@@ -846,3 +846,37 @@ HEX
   my @im = Imager->read_multi(type => "tiff", data => $ifdloop);
   is(@im, 2, "should be only 2 images");
 }
+
+SKIP:
+{ # sample format
+  Imager::File::TIFF::i_tiff_has_compression("lzw")
+      or skip "No LZW support", 8;
+  Imager::File::TIFF::i_tiff_ieeefp()
+      or skip "No IEEE FP type", 8;
+
+ SKIP:
+  { # signed
+    my $cmp = Imager->new(file => "testimg/grey16.tif", filetype => "tiff")
+      or skip "Cannot read grey16.tif: ". Imager->errstr, 4;
+    my $im = Imager->new(file => "testimg/grey16sg.tif", filetype => "tiff");
+    ok($im, "read image with SampleFormat = signed int")
+      or skip "Couldn't read the file", 3;
+    is_image($im, $cmp, "check the images match");
+    my %tags = map @$_, $im->tags;
+    is($tags{tiff_sample_format}, 2, "check sample format");
+    is($tags{tiff_sample_format_name}, "int", "check sample format name");
+  }
+
+ SKIP:
+  { # float
+    my $cmp = Imager->new(file => "testimg/srgba32.tif", filetype => "tiff")
+      or skip "Cannot read srgaba32f.tif: ". Imager->errstr, 4;
+    my $im = Imager->new(file => "testimg/srgba32f.tif", filetype => "tiff");
+    ok($im, "read image with SampleFormat = float")
+      or skip "Couldn't read the file", 3;
+    is_image($im, $cmp, "check the images match");
+    my %tags = map @$_, $im->tags;
+    is($tags{tiff_sample_format}, 3, "check sample format");
+    is($tags{tiff_sample_format_name}, "ieeefp", "check sample format name");
+  }
+}
diff --git a/TIFF/testimg/grey16sg.tif b/TIFF/testimg/grey16sg.tif
new file mode 100644 (file)
index 0000000..1ca614f
Binary files /dev/null and b/TIFF/testimg/grey16sg.tif differ
diff --git a/TIFF/testimg/srgba32f.tif b/TIFF/testimg/srgba32f.tif
new file mode 100644 (file)
index 0000000..3b8052b
Binary files /dev/null and b/TIFF/testimg/srgba32f.tif differ
diff --git a/fileformatdocs/tiffsigned.pl b/fileformatdocs/tiffsigned.pl
new file mode 100644 (file)
index 0000000..657ac66
--- /dev/null
@@ -0,0 +1,527 @@
+#!perl -w
+# Make a signed or floating point version of an uncompressed TIFF
+use strict;
+use Getopt::Long;
+
+my $mode = "int";
+GetOptions("m|mode=s" => \$mode);
+
+use constant TIFFTAG_BITSPERSAMPLE => 258;
+use constant TIFFTAG_SAMPLEFORMAT => 339;
+use constant SAMPLEFORMAT_UINT         => 1;
+use constant SAMPLEFORMAT_INT          => 2;
+use constant SAMPLEFORMAT_IEEEFP        => 3;
+use constant SAMPLEFORMAT_VOID         => 4;
+use constant TIFFTAG_COMPRESSION       => 259;
+use constant COMPRESSION_NONE          => 1;
+use constant TIFFTAG_SAMPLESPERPIXEL   => 277;
+
+my $inname = shift;
+my $outname = shift
+  or die <<EOS;
+Usage: $0 [-m mode] input output
+  mode can be:
+     int
+     float
+     double
+EOS
+
+open my $fh, "<", $inname
+  or die "Cannot open $inname: $!\n";
+binmode $fh;
+
+my $data = do { local $/; <$fh> };
+
+close $fh;
+
+my $tiff = TIFFPP->new($data);
+
+$tiff->compression == COMPRESSION_NONE
+  or die "TIFF must be uncompressed\n";
+
+my $sample_count = $tiff->samples_per_pixel;
+
+if ($mode eq "int") {
+  $tiff->each_strip
+    (
+     sub {
+       my ($data, $tiff)  = @_;
+       my ($values, $bits, $format) = $tiff->unpack_samples($data);
+       my $i = 0;
+       for my $value (@$values) {
+        my $limit=  1 << ($bits->[$i++] - 1);
+        $value -= $limit;
+        $i == @$bits and $i = 0;
+       }
+       return $tiff->pack_samples($values, undef, [ (SAMPLEFORMAT_INT) x $sample_count ]);
+     }
+    );
+  $tiff->add_tag
+    (
+     tag => TIFFTAG_SAMPLEFORMAT,
+     type => "SHORT",
+     value => [ (SAMPLEFORMAT_INT) x $sample_count ],
+    );
+}
+elsif ($mode eq "float") {
+  $tiff->each_strip
+    (
+     sub {
+       my ($data, $tiff)  = @_;
+       my ($values, $bits, $format) = $tiff->unpack_samples($data);
+       my $i = 0;
+       for my $value (@$values) {
+        my $limit =  2 ** ($bits->[$i++]) - 1;
+        $value /= $limit;
+        $i == @$bits and $i = 0;
+       }
+       return $tiff->pack_samples($values, [ (32) x $sample_count ], [ (SAMPLEFORMAT_IEEEFP) x $sample_count ]);
+     }
+    );
+  $tiff->add_tag
+    (
+     tag => TIFFTAG_SAMPLEFORMAT,
+     type => "SHORT",
+     value => [ (SAMPLEFORMAT_IEEEFP) x $sample_count ],
+    );
+  $tiff->add_tag
+    (
+     tag => TIFFTAG_BITSPERSAMPLE,
+     type => "SHORT",
+     value => [ ( 32 ) x $sample_count ]
+    );
+}
+elsif ($mode eq "double") {
+  $tiff->each_strip
+    (
+     sub {
+       my ($data, $tiff)  = @_;
+       my ($values, $bits, $format) = $tiff->unpack_samples($data);
+       my $i = 0;
+       for my $value (@$values) {
+        my $limit=  2 ** ($bits->[$i++] - 1) - 1;
+        $value /= $limit;
+        $i == @$bits and $i = 0;
+       }
+       return $tiff->pack_samples($values, [ (64) x $sample_count ], [ (SAMPLEFORMAT_IEEEFP) x $sample_count ]);
+     }
+    );
+  $tiff->add_tag
+    (
+     tag => TIFFTAG_SAMPLEFORMAT,
+     type => "SHORT",
+     value => [ (SAMPLEFORMAT_IEEEFP) x $sample_count ],
+    );
+  $tiff->add_tag
+    (
+     tag => TIFFTAG_BITSPERSAMPLE,
+     type => "SHORT",
+     value => [ ( 64 ) x $sample_count ]
+    );
+}
+
+$tiff->save_ifd;
+
+open my $ofh, ">", $outname;
+binmode $ofh;
+
+print $ofh $tiff->data;
+close $ofh or die;
+
+package TIFFPP;
+
+use constant TIFFTAG_STRIPOFFSETS => 273;
+use constant TIFFTAG_STRIPBYTECOUNTS => 279;
+use constant TIFFTAG_SAMPLESPERPIXEL   => 277;
+use constant TIFFTAG_BITSPERSAMPLE => 258;
+use constant TIFFTAG_SAMPLEFORMAT => 339;
+use constant TIFFTAG_COMPRESSION => 259;
+use constant COMPRESSION_NONE          => 1;
+
+use constant TYPE_SHORT => 3;
+use constant TYPE_LONG => 4;
+
+use constant SAMPLEFORMAT_UINT         => 1;
+use constant SAMPLEFORMAT_INT          => 2;
+use constant SAMPLEFORMAT_IEEEFP        => 3;
+use constant SAMPLEFORMAT_VOID         => 4;
+
+my %types;
+my %type_names;
+
+my %bit_types;
+
+BEGIN {
+  %types =
+    (
+     1 =>
+     {
+      name => "BYTE",
+      size => 1,
+      pack => sub { pack("C*", @{$_[0]}), scalar @{$_[0]} },
+      unpack => sub { [ unpack "C*", $_[0] ] },
+     },
+     2 =>
+     {
+      name => "ASCII",
+      size => 1,
+     },
+     3 =>
+     {
+      name => "SHORT",
+      size => 2,
+      pack => sub { pack("$_[1]{SHORT}*", @{$_[0]}), scalar @{$_[0]} },
+      unpack => sub { [ unpack "$_[1]{SHORT}*", $_[0] ] },
+     },
+     4 =>
+     {
+      name => "LONG",
+      size => 4,
+      pack => sub { pack("$_[1]{LONG}*", @{$_[0]}), scalar @{$_[0]} },
+      unpack => sub { [ unpack "$_[1]{LONG}*", $_[0] ] },
+     },
+     5 =>
+     {
+      name => "RATIONAL",
+      size => 8,
+      pack => sub { pack("$_[1]{LONG}*", map @$_, @{$_[0]}), scalar @{$_[0]} },
+      unpack => sub {
+       my @raw = unpack("$_[1]{LONG}*", $_[0]);
+       return [ map [ @raw[$_*2, $_*2+1] ], 0 .. $#raw/2 ];
+      },
+     },
+     6 =>
+     {
+      name => "SBYTE",
+      size => 1,
+      pack => sub { pack("c*", @{$_[0]}), scalar @{$_[0]} },
+      unpack => sub { [ unpack "c*", $_[0] ] },
+     },
+     7 =>
+     {
+      name => "UNDEFINED",
+      size => 1,
+      pack => sub { $_[0], length $_[0] },
+      unpack => sub { $_[0] },
+     },
+     8 =>
+     {
+      name => "SSHORT",
+      size => 2,
+      pack => sub { pack("$_[1]{SSHORT}*", @{$_[0]}), scalar @{$_[0]} },
+      unpack => sub { [ unpack "$_[1]{SSHORT}*", $_[0] ] },
+     },
+     9 =>
+     {
+      name => "SLONG",
+      size => 4,
+      pack => sub { pack("$_[1]{SLONG}*", @{$_[0]}), scalar @{$_[0]} },
+      unpack => sub { [ unpack "$_[1]{SLONG}*", $_[0] ] },
+     },
+     10 =>
+     {
+      name => "SRATIONAL",
+      size => 8,
+      pack => sub { pack("($_[1]{SLONG}$_[1]{LONG})*", map @$_, @{$_[0]}), scalar @{$_[0]} },
+      unpack => sub {
+       my @raw = unpack("($_[1]{SLONG}$_[1]{LONG})*", $_[0]);
+       return [ map [ @raw[$_*2, $_*2+1] ], 0 .. $#raw/2 ];
+      },
+     },
+     11 =>
+     {
+      name => "FLOAT",
+      size => 4,
+      pack => sub { pack("$_[1]{FLOAT}*", @{$_[0]}), scalar @{$_[0]} },
+      unpack => sub { [ unpack "$_[1]{FLOAT}*", $_[0] ] },
+     },
+     12 =>
+     {
+      name => "DOUBLE",
+      size => 8,
+      pack => sub { pack("$_[1]{DOUBLE}*", @{$_[0]}), scalar @{$_[0]} },
+      unpack => sub { [ unpack "$_[1]{DOUBLE}*", $_[0] ] },
+     },
+    );
+
+  %type_names = map { $types{$_}->{name} => $_ } keys %types;
+
+  %bit_types =
+    (
+     8 => 'BYTE',
+     16 => 'SHORT',
+     32 => 'LONG',
+    );
+}
+
+sub new {
+  my ($class, $data) = @_;
+
+  my %opts =
+    (
+     data => $data,
+    );
+
+  if (substr($data, 0, 2) eq "II") {
+    $opts{LONG} = "V";
+    $opts{SHORT} = "v";
+    $opts{SLONG} = "l<";
+    $opts{SSHORT} = "s<";
+    $opts{FLOAT} = "f<";
+    $opts{DOUBLE} = "d<";
+  }
+  elsif (substr($data, 0, 2) eq "MM") {
+    $opts{LONG} = "N";
+    $opts{SHORT} = "n";
+    $opts{SLONG} = "l>";
+    $opts{SSHORT} = "s>";
+    $opts{FLOAT} = "f>";
+    $opts{DOUBLE} = "d>";
+  }
+  else {
+    die "Not a TIFF file (bad byte-order)\n";
+  }
+  substr($data, 2, 2) eq "\x2A\0"
+    or die "Not a TIFF file (bad TIFF marker)\n";
+  my $ifd_off = unpack($opts{LONG}, substr($data, 4, 4));
+  $ifd_off < length $data
+    or die "Invalid TIFF - IFD offset too long\n";
+
+  my $self = bless \%opts, $class;
+  $self->_load_ifd(4, $ifd_off);
+
+  $self;
+}
+
+sub data {
+  $_[0]{data};
+}
+
+sub _load_ifd {
+  my ($self, $off_ptr, $off) = @_;
+
+  $self->{off_ptr} = $off_ptr;
+  $self->{ifd_off} = $off;
+  my $count = unpack($self->{SHORT}, substr($self->{data}, $off, 2));
+  $self->{ifd_size} = $count;
+  $off += 2;
+  my @ifds;
+  my ($short, $long) = ($self->{SHORT}, $self->{LONG});
+  for my $index (1 .. $count) {
+    my ($tag, $type, $count, $value) =
+      unpack("$short$short${long}a4", substr($self->{data}, $off, 12));
+    $types{$type}
+      or die "Unknown type $type in IFD\n";
+    my $size = $types{$type}{size} * $count;
+
+    my $item_off = $size > 4 ? unpack($long, $value) : $off + 8;
+    my $data = substr($self->{data}, $item_off, $size);
+    push @ifds,
+      {
+       tag => $tag,
+       type => $type,
+       count => $count,
+       offset => $item_off,
+       data => $data,
+       original => 1,
+      };
+    $off += 12;
+  }
+  my %ifd = map { $_->{tag} => $_ } @ifds;
+  $self->{ifd} = \@ifds;
+  $self->{ifdh} = \%ifd;
+
+  $self->{next_ifd} = unpack($long, substr($self->{data}, $off, 4));
+}
+
+sub save_ifd {
+  my ($self) = @_;
+
+  my @ifd = sort { $a->{tag} <=> $b->{tag} } @{$self->{ifd}};
+  my $ifd = pack($self->{SHORT}, scalar(@ifd));
+  my ($short, $long) = ($self->{SHORT}, $self->{LONG});
+  for my $entry (@ifd) {
+    my %entry = %$entry;
+    if (!$entry{original} && length $entry{data} > 4) {
+       $entry{offset} = length $self->{data};
+       $self->{data} .= $entry{data};
+    }
+    if (length $entry{data} > 4) {
+      $ifd .= pack("$short$short$long$long", @entry{qw(tag type count offset)});
+    }
+    else {
+      $ifd .= pack("$short$short${long}a4", @entry{qw(tag type count data)});
+    }
+  }
+  $ifd .= pack($long, $self->{next_ifd});
+  if (scalar(@ifd) <= $self->{ifd_size}) {
+    substr($self->{data}, $self->{ifd_off}, length $ifd, $ifd);
+  }
+  else {
+    $self->{ifd_off} = length $self->{data};
+    $self->{data} .= $ifd;
+    substr($self->{data}, $self->{off_ptr}, 4, pack($long, $self->{ifd_off}));
+  }
+}
+
+sub remove_tag {
+  my ($self, $tag) = @_;
+
+  if (delete $self->{ifdh}{$tag}) {
+    $self->{ifd} = [ grep $_->{tag} != $tag, @{$self->{ifd}} ];
+  }
+}
+
+sub add_tag {
+  my ($self, %opts) = @_;
+
+  unless ($opts{type} =~ /[0-9]/) {
+    $opts{type} = $type_names{$opts{type}}
+      or die "add_tag: Invalid type\n";
+  }
+
+  if ($opts{value} && !exists $opts{data}) {
+    @opts{qw(data count)} = $types{$opts{type}}{pack}->($opts{value}, $self);
+  }
+
+  if ($self->{ifdh}{$opts{tag}}) {
+    $self->remove_tag($opts{tag});
+  }
+  push @{$self->{ifd}}, \%opts;
+  $self->{ifdh}{$opts{tag}} = \%opts;
+}
+
+sub tag_value {
+  my ($self, $tag) = @_;
+
+  my $val = $self->{ifdh}{$tag}
+    or return;
+
+  return $types{$val->{type}}{unpack}->($val->{data}, $self);
+}
+
+sub each_strip {
+  my ($self, $cb) = @_;
+
+  my $offsets = $self->tag_value(TIFFTAG_STRIPOFFSETS);
+  my $sizes = $self->tag_value(TIFFTAG_STRIPBYTECOUNTS);
+  @$offsets == @$sizes
+    or die "Strip offset and byte counts do not match\n";
+  for my $i (0 .. $#$offsets) {
+    my $bytes = substr($self->{data}, $offsets->[$i], $sizes->[$i]);
+    $bytes = $cb->($bytes, $self);
+    if (length $bytes > $sizes->[$i]) {
+      $offsets->[$i] = length $self->{data};
+      $self->{data} .= $bytes;
+    }
+    else {
+      substr($self->{data}, $offsets->[$i], length $bytes, $bytes);
+    }
+    $sizes->[$i] = length $bytes;
+  }
+  my $off_type = TYPE_SHORT;
+  my $count_type = TYPE_SHORT;
+  $_ > 0xFFFF and $off_type = TYPE_LONG for @$offsets;
+  $_ > 0xFFFF and $count_type = TYPE_LONG for @$sizes;
+
+  $self->add_tag
+    (
+     tag => TIFFTAG_STRIPOFFSETS,
+     type => $off_type,
+     value => $offsets,
+    );
+  $self->add_tag
+    (
+     tag => TIFFTAG_STRIPBYTECOUNTS,
+     type => $count_type,
+     value => $sizes,
+    );
+}
+
+sub _pack_format {
+  my ($self, $bits, $formats) = @_;
+
+  $bits ||= $self->_bitspersample;
+  $formats ||= $self->_sampleformat;
+  @$bits == @$formats
+    or die "Mismatch between bitsperlsample and sampleformat counts\n";
+  my $pack = '';
+  for my $i (0 .. $#$bits) {
+    my $type;
+    if ($formats->[$i] == SAMPLEFORMAT_IEEEFP) {
+      if ($bits->[$i] == 32) {
+       $type = "FLOAT";
+      }
+      elsif ($bits->[$i] == 64) {
+       $type = "DOUBLE";
+      }
+      else {
+       die "No IEEEFP format for bits $bits->[$i]\n";
+      }
+    }
+    else {
+      $type = $bit_types{$bits->[$i]}
+       or die "Can't pack $bits->[$i] bits\n";
+      $type = "S$type" if $formats->[$i] == SAMPLEFORMAT_INT;
+    }
+    $pack .= $self->{$type};
+  }
+
+  wantarray ? ($pack, $bits, $formats) : $pack;
+}
+
+sub samples_per_pixel {
+  my ($self) = @_;
+
+  my $spp = $self->tag_value(TIFFTAG_SAMPLESPERPIXEL);
+  $spp or return 1;
+
+  return $spp->[0];
+}
+
+sub compression {
+  my ($self) = @_;
+
+  my $comp = $self->tag_value(TIFFTAG_COMPRESSION);
+  $comp or return COMPRESSION_NONE;
+
+  return $comp->[0];
+}
+
+sub _bitspersample {
+  my ($self) = @_;
+
+  my $bps = $self->tag_value(TIFFTAG_BITSPERSAMPLE);
+  $bps or $bps = [ ( 1 ) x $self->samples_per_pixel ];
+
+  return $bps;
+}
+
+sub _sampleformat {
+  my ($self) = @_;
+
+  my $formats = $self->tag_value(TIFFTAG_SAMPLEFORMAT);
+  unless ($formats) {
+    $formats = [ ( SAMPLEFORMAT_UINT ) x $self->samples_per_pixel ];
+  }
+
+  return $formats;
+}
+
+sub unpack_samples {
+  my ($self, $data, $bits, $formats) = @_;
+
+  my ($pack, $rbits, $rformats) = $self->_pack_format($bits, $formats);
+
+  my $values = [ unpack "($pack)*", $data ];
+
+  wantarray ? ( $values, $rbits, $rformats) : $values;
+}
+
+sub pack_samples {
+  my ($self, $data, $bits, $formats) = @_;
+
+  my $pack = $self->_pack_format($bits, $formats);
+
+  pack "($pack)*", @$data;
+}