<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">#!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" =&gt; \$mode);

use constant TIFFTAG_BITSPERSAMPLE =&gt; 258;
use constant TIFFTAG_SAMPLEFORMAT =&gt; 339;
use constant SAMPLEFORMAT_UINT		=&gt; 1;
use constant SAMPLEFORMAT_INT		=&gt; 2;
use constant SAMPLEFORMAT_IEEEFP        =&gt; 3;
use constant SAMPLEFORMAT_VOID		=&gt; 4;
use constant TIFFTAG_COMPRESSION	=&gt; 259;
use constant COMPRESSION_NONE		=&gt; 1;
use constant TIFFTAG_SAMPLESPERPIXEL	=&gt; 277;

my $inname = shift;
my $outname = shift
  or die &lt;&lt;EOS;
Usage: $0 [-m mode] input output
  mode can be:
     int
     float
     double
EOS

open my $fh, "&lt;", $inname
  or die "Cannot open $inname: $!\n";
binmode $fh;

my $data = do { local $/; &lt;$fh&gt; };

close $fh;

my $tiff = TIFFPP-&gt;new($data);

$tiff-&gt;compression == COMPRESSION_NONE
  or die "TIFF must be uncompressed\n";

my $sample_count = $tiff-&gt;samples_per_pixel;

if ($mode eq "int") {
  $tiff-&gt;each_strip
    (
     sub {
       my ($data, $tiff)  = @_;
       my ($values, $bits, $format) = $tiff-&gt;unpack_samples($data);
       my $i = 0;
       for my $value (@$values) {
	 my $limit=  1 &lt;&lt; ($bits-&gt;[$i++] - 1);
	 $value -= $limit;
	 $i == @$bits and $i = 0;
       }
       return $tiff-&gt;pack_samples($values, undef, [ (SAMPLEFORMAT_INT) x $sample_count ]);
     }
    );
  $tiff-&gt;add_tag
    (
     tag =&gt; TIFFTAG_SAMPLEFORMAT,
     type =&gt; "SHORT",
     value =&gt; [ (SAMPLEFORMAT_INT) x $sample_count ],
    );
}
elsif ($mode eq "float") {
  $tiff-&gt;each_strip
    (
     sub {
       my ($data, $tiff)  = @_;
       my ($values, $bits, $format) = $tiff-&gt;unpack_samples($data);
       my $i = 0;
       for my $value (@$values) {
	 my $limit =  2 ** ($bits-&gt;[$i++]) - 1;
	 $value /= $limit;
	 $i == @$bits and $i = 0;
       }
       return $tiff-&gt;pack_samples($values, [ (32) x $sample_count ], [ (SAMPLEFORMAT_IEEEFP) x $sample_count ]);
     }
    );
  $tiff-&gt;add_tag
    (
     tag =&gt; TIFFTAG_SAMPLEFORMAT,
     type =&gt; "SHORT",
     value =&gt; [ (SAMPLEFORMAT_IEEEFP) x $sample_count ],
    );
  $tiff-&gt;add_tag
    (
     tag =&gt; TIFFTAG_BITSPERSAMPLE,
     type =&gt; "SHORT",
     value =&gt; [ ( 32 ) x $sample_count ]
    );
}
elsif ($mode eq "double") {
  $tiff-&gt;each_strip
    (
     sub {
       my ($data, $tiff)  = @_;
       my ($values, $bits, $format) = $tiff-&gt;unpack_samples($data);
       my $i = 0;
       for my $value (@$values) {
	 my $limit=  2 ** ($bits-&gt;[$i++] - 1) - 1;
	 $value /= $limit;
	 $i == @$bits and $i = 0;
       }
       return $tiff-&gt;pack_samples($values, [ (64) x $sample_count ], [ (SAMPLEFORMAT_IEEEFP) x $sample_count ]);
     }
    );
  $tiff-&gt;add_tag
    (
     tag =&gt; TIFFTAG_SAMPLEFORMAT,
     type =&gt; "SHORT",
     value =&gt; [ (SAMPLEFORMAT_IEEEFP) x $sample_count ],
    );
  $tiff-&gt;add_tag
    (
     tag =&gt; TIFFTAG_BITSPERSAMPLE,
     type =&gt; "SHORT",
     value =&gt; [ ( 64 ) x $sample_count ]
    );
}

$tiff-&gt;save_ifd;

open my $ofh, "&gt;", $outname;
binmode $ofh;

print $ofh $tiff-&gt;data;
close $ofh or die;

package TIFFPP;

use constant TIFFTAG_STRIPOFFSETS =&gt; 273;
use constant TIFFTAG_STRIPBYTECOUNTS =&gt; 279;
use constant TIFFTAG_SAMPLESPERPIXEL	=&gt; 277;
use constant TIFFTAG_BITSPERSAMPLE =&gt; 258;
use constant TIFFTAG_SAMPLEFORMAT =&gt; 339;
use constant TIFFTAG_COMPRESSION =&gt; 259;
use constant COMPRESSION_NONE		=&gt; 1;

use constant TYPE_SHORT =&gt; 3;
use constant TYPE_LONG =&gt; 4;

use constant SAMPLEFORMAT_UINT		=&gt; 1;
use constant SAMPLEFORMAT_INT		=&gt; 2;
use constant SAMPLEFORMAT_IEEEFP        =&gt; 3;
use constant SAMPLEFORMAT_VOID		=&gt; 4;

my %types;
my %type_names;

my %bit_types;

BEGIN {
  %types =
    (
     1 =&gt;
     {
      name =&gt; "BYTE",
      size =&gt; 1,
      pack =&gt; sub { pack("C*", @{$_[0]}), scalar @{$_[0]} },
      unpack =&gt; sub { [ unpack "C*", $_[0] ] },
     },
     2 =&gt;
     {
      name =&gt; "ASCII",
      size =&gt; 1,
     },
     3 =&gt;
     {
      name =&gt; "SHORT",
      size =&gt; 2,
      pack =&gt; sub { pack("$_[1]{SHORT}*", @{$_[0]}), scalar @{$_[0]} },
      unpack =&gt; sub { [ unpack "$_[1]{SHORT}*", $_[0] ] },
     },
     4 =&gt;
     {
      name =&gt; "LONG",
      size =&gt; 4,
      pack =&gt; sub { pack("$_[1]{LONG}*", @{$_[0]}), scalar @{$_[0]} },
      unpack =&gt; sub { [ unpack "$_[1]{LONG}*", $_[0] ] },
     },
     5 =&gt;
     {
      name =&gt; "RATIONAL",
      size =&gt; 8,
      pack =&gt; sub { pack("$_[1]{LONG}*", map @$_, @{$_[0]}), scalar @{$_[0]} },
      unpack =&gt; sub {
	my @raw = unpack("$_[1]{LONG}*", $_[0]);
	return [ map [ @raw[$_*2, $_*2+1] ], 0 .. $#raw/2 ];
      },
     },
     6 =&gt;
     {
      name =&gt; "SBYTE",
      size =&gt; 1,
      pack =&gt; sub { pack("c*", @{$_[0]}), scalar @{$_[0]} },
      unpack =&gt; sub { [ unpack "c*", $_[0] ] },
     },
     7 =&gt;
     {
      name =&gt; "UNDEFINED",
      size =&gt; 1,
      pack =&gt; sub { $_[0], length $_[0] },
      unpack =&gt; sub { $_[0] },
     },
     8 =&gt;
     {
      name =&gt; "SSHORT",
      size =&gt; 2,
      pack =&gt; sub { pack("$_[1]{SSHORT}*", @{$_[0]}), scalar @{$_[0]} },
      unpack =&gt; sub { [ unpack "$_[1]{SSHORT}*", $_[0] ] },
     },
     9 =&gt;
     {
      name =&gt; "SLONG",
      size =&gt; 4,
      pack =&gt; sub { pack("$_[1]{SLONG}*", @{$_[0]}), scalar @{$_[0]} },
      unpack =&gt; sub { [ unpack "$_[1]{SLONG}*", $_[0] ] },
     },
     10 =&gt;
     {
      name =&gt; "SRATIONAL",
      size =&gt; 8,
      pack =&gt; sub { pack("($_[1]{SLONG}$_[1]{LONG})*", map @$_, @{$_[0]}), scalar @{$_[0]} },
      unpack =&gt; sub {
	my @raw = unpack("($_[1]{SLONG}$_[1]{LONG})*", $_[0]);
	return [ map [ @raw[$_*2, $_*2+1] ], 0 .. $#raw/2 ];
      },
     },
     11 =&gt;
     {
      name =&gt; "FLOAT",
      size =&gt; 4,
      pack =&gt; sub { pack("$_[1]{FLOAT}*", @{$_[0]}), scalar @{$_[0]} },
      unpack =&gt; sub { [ unpack "$_[1]{FLOAT}*", $_[0] ] },
     },
     12 =&gt;
     {
      name =&gt; "DOUBLE",
      size =&gt; 8,
      pack =&gt; sub { pack("$_[1]{DOUBLE}*", @{$_[0]}), scalar @{$_[0]} },
      unpack =&gt; sub { [ unpack "$_[1]{DOUBLE}*", $_[0] ] },
     },
    );

  %type_names = map { $types{$_}-&gt;{name} =&gt; $_ } keys %types;

  %bit_types =
    (
     8 =&gt; 'BYTE',
     16 =&gt; 'SHORT',
     32 =&gt; 'LONG',
    );
}

sub new {
  my ($class, $data) = @_;

  my %opts =
    (
     data =&gt; $data,
    );

  if (substr($data, 0, 2) eq "II") {
    $opts{LONG} = "V";
    $opts{SHORT} = "v";
    $opts{SLONG} = "l&lt;";
    $opts{SSHORT} = "s&lt;";
    $opts{FLOAT} = "f&lt;";
    $opts{DOUBLE} = "d&lt;";
  }
  elsif (substr($data, 0, 2) eq "MM") {
    $opts{LONG} = "N";
    $opts{SHORT} = "n";
    $opts{SLONG} = "l&gt;";
    $opts{SSHORT} = "s&gt;";
    $opts{FLOAT} = "f&gt;";
    $opts{DOUBLE} = "d&gt;";
  }
  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 &lt; length $data
    or die "Invalid TIFF - IFD offset too long\n";

  my $self = bless \%opts, $class;
  $self-&gt;_load_ifd(4, $ifd_off);

  $self;
}

sub data {
  $_[0]{data};
}

sub _load_ifd {
  my ($self, $off_ptr, $off) = @_;

  $self-&gt;{off_ptr} = $off_ptr;
  $self-&gt;{ifd_off} = $off;
  my $count = unpack($self-&gt;{SHORT}, substr($self-&gt;{data}, $off, 2));
  $self-&gt;{ifd_size} = $count;
  $off += 2;
  my @ifds;
  my ($short, $long) = ($self-&gt;{SHORT}, $self-&gt;{LONG});
  for my $index (1 .. $count) {
    my ($tag, $type, $count, $value) =
      unpack("$short$short${long}a4", substr($self-&gt;{data}, $off, 12));
    $types{$type}
      or die "Unknown type $type in IFD\n";
    my $size = $types{$type}{size} * $count;

    my $item_off = $size &gt; 4 ? unpack($long, $value) : $off + 8;
    my $data = substr($self-&gt;{data}, $item_off, $size);
    push @ifds,
      {
       tag =&gt; $tag,
       type =&gt; $type,
       count =&gt; $count,
       offset =&gt; $item_off,
       data =&gt; $data,
       original =&gt; 1,
      };
    $off += 12;
  }
  my %ifd = map { $_-&gt;{tag} =&gt; $_ } @ifds;
  $self-&gt;{ifd} = \@ifds;
  $self-&gt;{ifdh} = \%ifd;

  $self-&gt;{next_ifd} = unpack($long, substr($self-&gt;{data}, $off, 4));
}

sub save_ifd {
  my ($self) = @_;

  my @ifd = sort { $a-&gt;{tag} &lt;=&gt; $b-&gt;{tag} } @{$self-&gt;{ifd}};
  my $ifd = pack($self-&gt;{SHORT}, scalar(@ifd));
  my ($short, $long) = ($self-&gt;{SHORT}, $self-&gt;{LONG});
  for my $entry (@ifd) {
    my %entry = %$entry;
    if (!$entry{original} &amp;&amp; length $entry{data} &gt; 4) {
	$entry{offset} = length $self-&gt;{data};
	$self-&gt;{data} .= $entry{data};
    }
    if (length $entry{data} &gt; 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-&gt;{next_ifd});
  if (scalar(@ifd) &lt;= $self-&gt;{ifd_size}) {
    substr($self-&gt;{data}, $self-&gt;{ifd_off}, length $ifd, $ifd);
  }
  else {
    $self-&gt;{ifd_off} = length $self-&gt;{data};
    $self-&gt;{data} .= $ifd;
    substr($self-&gt;{data}, $self-&gt;{off_ptr}, 4, pack($long, $self-&gt;{ifd_off}));
  }
}

sub remove_tag {
  my ($self, $tag) = @_;

  if (delete $self-&gt;{ifdh}{$tag}) {
    $self-&gt;{ifd} = [ grep $_-&gt;{tag} != $tag, @{$self-&gt;{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} &amp;&amp; !exists $opts{data}) {
    @opts{qw(data count)} = $types{$opts{type}}{pack}-&gt;($opts{value}, $self);
  }

  if ($self-&gt;{ifdh}{$opts{tag}}) {
    $self-&gt;remove_tag($opts{tag});
  }
  push @{$self-&gt;{ifd}}, \%opts;
  $self-&gt;{ifdh}{$opts{tag}} = \%opts;
}

sub tag_value {
  my ($self, $tag) = @_;

  my $val = $self-&gt;{ifdh}{$tag}
    or return;

  return $types{$val-&gt;{type}}{unpack}-&gt;($val-&gt;{data}, $self);
}

sub each_strip {
  my ($self, $cb) = @_;

  my $offsets = $self-&gt;tag_value(TIFFTAG_STRIPOFFSETS);
  my $sizes = $self-&gt;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-&gt;{data}, $offsets-&gt;[$i], $sizes-&gt;[$i]);
    $bytes = $cb-&gt;($bytes, $self);
    if (length $bytes &gt; $sizes-&gt;[$i]) {
      $offsets-&gt;[$i] = length $self-&gt;{data};
      $self-&gt;{data} .= $bytes;
    }
    else {
      substr($self-&gt;{data}, $offsets-&gt;[$i], length $bytes, $bytes);
    }
    $sizes-&gt;[$i] = length $bytes;
  }
  my $off_type = TYPE_SHORT;
  my $count_type = TYPE_SHORT;
  $_ &gt; 0xFFFF and $off_type = TYPE_LONG for @$offsets;
  $_ &gt; 0xFFFF and $count_type = TYPE_LONG for @$sizes;

  $self-&gt;add_tag
    (
     tag =&gt; TIFFTAG_STRIPOFFSETS,
     type =&gt; $off_type,
     value =&gt; $offsets,
    );
  $self-&gt;add_tag
    (
     tag =&gt; TIFFTAG_STRIPBYTECOUNTS,
     type =&gt; $count_type,
     value =&gt; $sizes,
    );
}

sub _pack_format {
  my ($self, $bits, $formats) = @_;

  $bits ||= $self-&gt;_bitspersample;
  $formats ||= $self-&gt;_sampleformat;
  @$bits == @$formats
    or die "Mismatch between bitsperlsample and sampleformat counts\n";
  my $pack = '';
  for my $i (0 .. $#$bits) {
    my $type;
    if ($formats-&gt;[$i] == SAMPLEFORMAT_IEEEFP) {
      if ($bits-&gt;[$i] == 32) {
	$type = "FLOAT";
      }
      elsif ($bits-&gt;[$i] == 64) {
	$type = "DOUBLE";
      }
      else {
	die "No IEEEFP format for bits $bits-&gt;[$i]\n";
      }
    }
    else {
      $type = $bit_types{$bits-&gt;[$i]}
	or die "Can't pack $bits-&gt;[$i] bits\n";
      $type = "S$type" if $formats-&gt;[$i] == SAMPLEFORMAT_INT;
    }
    $pack .= $self-&gt;{$type};
  }

  wantarray ? ($pack, $bits, $formats) : $pack;
}

sub samples_per_pixel {
  my ($self) = @_;

  my $spp = $self-&gt;tag_value(TIFFTAG_SAMPLESPERPIXEL);
  $spp or return 1;

  return $spp-&gt;[0];
}

sub compression {
  my ($self) = @_;

  my $comp = $self-&gt;tag_value(TIFFTAG_COMPRESSION);
  $comp or return COMPRESSION_NONE;

  return $comp-&gt;[0];
}

sub _bitspersample {
  my ($self) = @_;

  my $bps = $self-&gt;tag_value(TIFFTAG_BITSPERSAMPLE);
  $bps or $bps = [ ( 1 ) x $self-&gt;samples_per_pixel ];

  return $bps;
}

sub _sampleformat {
  my ($self) = @_;

  my $formats = $self-&gt;tag_value(TIFFTAG_SAMPLEFORMAT);
  unless ($formats) {
    $formats = [ ( SAMPLEFORMAT_UINT ) x $self-&gt;samples_per_pixel ];
  }

  return $formats;
}

sub unpack_samples {
  my ($self, $data, $bits, $formats) = @_;

  my ($pack, $rbits, $rformats) = $self-&gt;_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-&gt;_pack_format($bits, $formats);

  pack "($pack)*", @$data;
}
</pre></body></html>