fileformatdocs/tiffsigned.pl

   1 #!perl -w
   2 # Make a signed or floating point version of an uncompressed TIFF
   3 use strict;
   4 use Getopt::Long;
   5
   6 my $mode = "int";
   7 GetOptions("m|mode=s" => \$mode);
   8
   9 use constant TIFFTAG_BITSPERSAMPLE => 258;
  10 use constant TIFFTAG_SAMPLEFORMAT => 339;
  11 use constant SAMPLEFORMAT_UINT          => 1;
  12 use constant SAMPLEFORMAT_INT           => 2;
  13 use constant SAMPLEFORMAT_IEEEFP        => 3;
  14 use constant SAMPLEFORMAT_VOID          => 4;
  15 use constant TIFFTAG_COMPRESSION        => 259;
  16 use constant COMPRESSION_NONE           => 1;
  17 use constant TIFFTAG_SAMPLESPERPIXEL    => 277;
  18
  19 my $inname = shift;
  20 my $outname = shift
  21   or die <<EOS;
  22 Usage: $0 [-m mode] input output
  23   mode can be:
  24      int
  25      float
  26      double
  27 EOS
  28
  29 open my $fh, "<", $inname
  30   or die "Cannot open $inname: $!\n";
  31 binmode $fh;
  32
  33 my $data = do { local $/; <$fh> };
  34
  35 close $fh;
  36
  37 my $tiff = TIFFPP->new($data);
  38
  39 $tiff->compression == COMPRESSION_NONE
  40   or die "TIFF must be uncompressed\n";
  41
  42 my $sample_count = $tiff->samples_per_pixel;
  43
  44 if ($mode eq "int") {
  45   $tiff->each_strip
  46     (
  47      sub {
  48        my ($data, $tiff)  = @_;
  49        my ($values, $bits, $format) = $tiff->unpack_samples($data);
  50        my $i = 0;
  51        for my $value (@$values) {
  52          my $limit=  1 << ($bits->[$i++] - 1);
  53          $value -= $limit;
  54          $i == @$bits and $i = 0;
  55        }
  56        return $tiff->pack_samples($values, undef, [ (SAMPLEFORMAT_INT) x $sample_count ]);
  57      }
  58     );
  59   $tiff->add_tag
  60     (
  61      tag => TIFFTAG_SAMPLEFORMAT,
  62      type => "SHORT",
  63      value => [ (SAMPLEFORMAT_INT) x $sample_count ],
  64     );
  65 }
  66 elsif ($mode eq "float") {
  67   $tiff->each_strip
  68     (
  69      sub {
  70        my ($data, $tiff)  = @_;
  71        my ($values, $bits, $format) = $tiff->unpack_samples($data);
  72        my $i = 0;
  73        for my $value (@$values) {
  74          my $limit =  2 ** ($bits->[$i++]) - 1;
  75          $value /= $limit;
  76          $i == @$bits and $i = 0;
  77        }
  78        return $tiff->pack_samples($values, [ (32) x $sample_count ], [ (SAMPLEFORMAT_IEEEFP) x $sample_count ]);
  79      }
  80     );
  81   $tiff->add_tag
  82     (
  83      tag => TIFFTAG_SAMPLEFORMAT,
  84      type => "SHORT",
  85      value => [ (SAMPLEFORMAT_IEEEFP) x $sample_count ],
  86     );
  87   $tiff->add_tag
  88     (
  89      tag => TIFFTAG_BITSPERSAMPLE,
  90      type => "SHORT",
  91      value => [ ( 32 ) x $sample_count ]
  92     );
  93 }
  94 elsif ($mode eq "double") {
  95   $tiff->each_strip
  96     (
  97      sub {
  98        my ($data, $tiff)  = @_;
  99        my ($values, $bits, $format) = $tiff->unpack_samples($data);
 100        my $i = 0;
 101        for my $value (@$values) {
 102          my $limit=  2 ** ($bits->[$i++] - 1) - 1;
 103          $value /= $limit;
 104          $i == @$bits and $i = 0;
 105        }
 106        return $tiff->pack_samples($values, [ (64) x $sample_count ], [ (SAMPLEFORMAT_IEEEFP) x $sample_count ]);
 107      }
 108     );
 109   $tiff->add_tag
 110     (
 111      tag => TIFFTAG_SAMPLEFORMAT,
 112      type => "SHORT",
 113      value => [ (SAMPLEFORMAT_IEEEFP) x $sample_count ],
 114     );
 115   $tiff->add_tag
 116     (
 117      tag => TIFFTAG_BITSPERSAMPLE,
 118      type => "SHORT",
 119      value => [ ( 64 ) x $sample_count ]
 120     );
 121 }
 122
 123 $tiff->save_ifd;
 124
 125 open my $ofh, ">", $outname;
 126 binmode $ofh;
 127
 128 print $ofh $tiff->data;
 129 close $ofh or die;
 130
 131 package TIFFPP;
 132
 133 use constant TIFFTAG_STRIPOFFSETS => 273;
 134 use constant TIFFTAG_STRIPBYTECOUNTS => 279;
 135 use constant TIFFTAG_SAMPLESPERPIXEL    => 277;
 136 use constant TIFFTAG_BITSPERSAMPLE => 258;
 137 use constant TIFFTAG_SAMPLEFORMAT => 339;
 138 use constant TIFFTAG_COMPRESSION => 259;
 139 use constant COMPRESSION_NONE           => 1;
 140
 141 use constant TYPE_SHORT => 3;
 142 use constant TYPE_LONG => 4;
 143
 144 use constant SAMPLEFORMAT_UINT          => 1;
 145 use constant SAMPLEFORMAT_INT           => 2;
 146 use constant SAMPLEFORMAT_IEEEFP        => 3;
 147 use constant SAMPLEFORMAT_VOID          => 4;
 148
 149 my %types;
 150 my %type_names;
 151
 152 my %bit_types;
 153
 154 BEGIN {
 155   %types =
 156     (
 157      1 =>
 158      {
 159       name => "BYTE",
 160       size => 1,
 161       pack => sub { pack("C*", @{$_[0]}), scalar @{$_[0]} },
 162       unpack => sub { [ unpack "C*", $_[0] ] },
 163      },
 164      2 =>
 165      {
 166       name => "ASCII",
 167       size => 1,
 168      },
 169      3 =>
 170      {
 171       name => "SHORT",
 172       size => 2,
 173       pack => sub { pack("$_[1]{SHORT}*", @{$_[0]}), scalar @{$_[0]} },
 174       unpack => sub { [ unpack "$_[1]{SHORT}*", $_[0] ] },
 175      },
 176      4 =>
 177      {
 178       name => "LONG",
 179       size => 4,
 180       pack => sub { pack("$_[1]{LONG}*", @{$_[0]}), scalar @{$_[0]} },
 181       unpack => sub { [ unpack "$_[1]{LONG}*", $_[0] ] },
 182      },
 183      5 =>
 184      {
 185       name => "RATIONAL",
 186       size => 8,
 187       pack => sub { pack("$_[1]{LONG}*", map @$_, @{$_[0]}), scalar @{$_[0]} },
 188       unpack => sub {
 189         my @raw = unpack("$_[1]{LONG}*", $_[0]);
 190         return [ map [ @raw[$_*2, $_*2+1] ], 0 .. $#raw/2 ];
 191       },
 192      },
 193      6 =>
 194      {
 195       name => "SBYTE",
 196       size => 1,
 197       pack => sub { pack("c*", @{$_[0]}), scalar @{$_[0]} },
 198       unpack => sub { [ unpack "c*", $_[0] ] },
 199      },
 200      7 =>
 201      {
 202       name => "UNDEFINED",
 203       size => 1,
 204       pack => sub { $_[0], length $_[0] },
 205       unpack => sub { $_[0] },
 206      },
 207      8 =>
 208      {
 209       name => "SSHORT",
 210       size => 2,
 211       pack => sub { pack("$_[1]{SSHORT}*", @{$_[0]}), scalar @{$_[0]} },
 212       unpack => sub { [ unpack "$_[1]{SSHORT}*", $_[0] ] },
 213      },
 214      9 =>
 215      {
 216       name => "SLONG",
 217       size => 4,
 218       pack => sub { pack("$_[1]{SLONG}*", @{$_[0]}), scalar @{$_[0]} },
 219       unpack => sub { [ unpack "$_[1]{SLONG}*", $_[0] ] },
 220      },
 221      10 =>
 222      {
 223       name => "SRATIONAL",
 224       size => 8,
 225       pack => sub { pack("($_[1]{SLONG}$_[1]{LONG})*", map @$_, @{$_[0]}), scalar @{$_[0]} },
 226       unpack => sub {
 227         my @raw = unpack("($_[1]{SLONG}$_[1]{LONG})*", $_[0]);
 228         return [ map [ @raw[$_*2, $_*2+1] ], 0 .. $#raw/2 ];
 229       },
 230      },
 231      11 =>
 232      {
 233       name => "FLOAT",
 234       size => 4,
 235       pack => sub { pack("$_[1]{FLOAT}*", @{$_[0]}), scalar @{$_[0]} },
 236       unpack => sub { [ unpack "$_[1]{FLOAT}*", $_[0] ] },
 237      },
 238      12 =>
 239      {
 240       name => "DOUBLE",
 241       size => 8,
 242       pack => sub { pack("$_[1]{DOUBLE}*", @{$_[0]}), scalar @{$_[0]} },
 243       unpack => sub { [ unpack "$_[1]{DOUBLE}*", $_[0] ] },
 244      },
 245     );
 246
 247   %type_names = map { $types{$_}->{name} => $_ } keys %types;
 248
 249   %bit_types =
 250     (
 251      8 => 'BYTE',
 252      16 => 'SHORT',
 253      32 => 'LONG',
 254     );
 255 }
 256
 257 sub new {
 258   my ($class, $data) = @_;
 259
 260   my %opts =
 261     (
 262      data => $data,
 263     );
 264
 265   if (substr($data, 0, 2) eq "II") {
 266     $opts{LONG} = "V";
 267     $opts{SHORT} = "v";
 268     $opts{SLONG} = "l<";
 269     $opts{SSHORT} = "s<";
 270     $opts{FLOAT} = "f<";
 271     $opts{DOUBLE} = "d<";
 272   }
 273   elsif (substr($data, 0, 2) eq "MM") {
 274     $opts{LONG} = "N";
 275     $opts{SHORT} = "n";
 276     $opts{SLONG} = "l>";
 277     $opts{SSHORT} = "s>";
 278     $opts{FLOAT} = "f>";
 279     $opts{DOUBLE} = "d>";
 280   }
 281   else {
 282     die "Not a TIFF file (bad byte-order)\n";
 283   }
 284   substr($data, 2, 2) eq "\x2A\0"
 285     or die "Not a TIFF file (bad TIFF marker)\n";
 286   my $ifd_off = unpack($opts{LONG}, substr($data, 4, 4));
 287   $ifd_off < length $data
 288     or die "Invalid TIFF - IFD offset too long\n";
 289
 290   my $self = bless \%opts, $class;
 291   $self->_load_ifd(4, $ifd_off);
 292
 293   $self;
 294 }
 295
 296 sub data {
 297   $_[0]{data};
 298 }
 299
 300 sub _load_ifd {
 301   my ($self, $off_ptr, $off) = @_;
 302
 303   $self->{off_ptr} = $off_ptr;
 304   $self->{ifd_off} = $off;
 305   my $count = unpack($self->{SHORT}, substr($self->{data}, $off, 2));
 306   $self->{ifd_size} = $count;
 307   $off += 2;
 308   my @ifds;
 309   my ($short, $long) = ($self->{SHORT}, $self->{LONG});
 310   for my $index (1 .. $count) {
 311     my ($tag, $type, $count, $value) =
 312       unpack("$short$short${long}a4", substr($self->{data}, $off, 12));
 313     $types{$type}
 314       or die "Unknown type $type in IFD\n";
 315     my $size = $types{$type}{size} * $count;
 316
 317     my $item_off = $size > 4 ? unpack($long, $value) : $off + 8;
 318     my $data = substr($self->{data}, $item_off, $size);
 319     push @ifds,
 320       {
 321        tag => $tag,
 322        type => $type,
 323        count => $count,
 324        offset => $item_off,
 325        data => $data,
 326        original => 1,
 327       };
 328     $off += 12;
 329   }
 330   my %ifd = map { $_->{tag} => $_ } @ifds;
 331   $self->{ifd} = \@ifds;
 332   $self->{ifdh} = \%ifd;
 333
 334   $self->{next_ifd} = unpack($long, substr($self->{data}, $off, 4));
 335 }
 336
 337 sub save_ifd {
 338   my ($self) = @_;
 339
 340   my @ifd = sort { $a->{tag} <=> $b->{tag} } @{$self->{ifd}};
 341   my $ifd = pack($self->{SHORT}, scalar(@ifd));
 342   my ($short, $long) = ($self->{SHORT}, $self->{LONG});
 343   for my $entry (@ifd) {
 344     my %entry = %$entry;
 345     if (!$entry{original} && length $entry{data} > 4) {
 346         $entry{offset} = length $self->{data};
 347         $self->{data} .= $entry{data};
 348     }
 349     if (length $entry{data} > 4) {
 350       $ifd .= pack("$short$short$long$long", @entry{qw(tag type count offset)});
 351     }
 352     else {
 353       $ifd .= pack("$short$short${long}a4", @entry{qw(tag type count data)});
 354     }
 355   }
 356   $ifd .= pack($long, $self->{next_ifd});
 357   if (scalar(@ifd) <= $self->{ifd_size}) {
 358     substr($self->{data}, $self->{ifd_off}, length $ifd, $ifd);
 359   }
 360   else {
 361     $self->{ifd_off} = length $self->{data};
 362     $self->{data} .= $ifd;
 363     substr($self->{data}, $self->{off_ptr}, 4, pack($long, $self->{ifd_off}));
 364   }
 365 }
 366
 367 sub remove_tag {
 368   my ($self, $tag) = @_;
 369
 370   if (delete $self->{ifdh}{$tag}) {
 371     $self->{ifd} = [ grep $_->{tag} != $tag, @{$self->{ifd}} ];
 372   }
 373 }
 374
 375 sub add_tag {
 376   my ($self, %opts) = @_;
 377
 378   unless ($opts{type} =~ /[0-9]/) {
 379     $opts{type} = $type_names{$opts{type}}
 380       or die "add_tag: Invalid type\n";
 381   }
 382
 383   if ($opts{value} && !exists $opts{data}) {
 384     @opts{qw(data count)} = $types{$opts{type}}{pack}->($opts{value}, $self);
 385   }
 386
 387   if ($self->{ifdh}{$opts{tag}}) {
 388     $self->remove_tag($opts{tag});
 389   }
 390   push @{$self->{ifd}}, \%opts;
 391   $self->{ifdh}{$opts{tag}} = \%opts;
 392 }
 393
 394 sub tag_value {
 395   my ($self, $tag) = @_;
 396
 397   my $val = $self->{ifdh}{$tag}
 398     or return;
 399
 400   return $types{$val->{type}}{unpack}->($val->{data}, $self);
 401 }
 402
 403 sub each_strip {
 404   my ($self, $cb) = @_;
 405
 406   my $offsets = $self->tag_value(TIFFTAG_STRIPOFFSETS);
 407   my $sizes = $self->tag_value(TIFFTAG_STRIPBYTECOUNTS);
 408   @$offsets == @$sizes
 409     or die "Strip offset and byte counts do not match\n";
 410   for my $i (0 .. $#$offsets) {
 411     my $bytes = substr($self->{data}, $offsets->[$i], $sizes->[$i]);
 412     $bytes = $cb->($bytes, $self);
 413     if (length $bytes > $sizes->[$i]) {
 414       $offsets->[$i] = length $self->{data};
 415       $self->{data} .= $bytes;
 416     }
 417     else {
 418       substr($self->{data}, $offsets->[$i], length $bytes, $bytes);
 419     }
 420     $sizes->[$i] = length $bytes;
 421   }
 422   my $off_type = TYPE_SHORT;
 423   my $count_type = TYPE_SHORT;
 424   $_ > 0xFFFF and $off_type = TYPE_LONG for @$offsets;
 425   $_ > 0xFFFF and $count_type = TYPE_LONG for @$sizes;
 426
 427   $self->add_tag
 428     (
 429      tag => TIFFTAG_STRIPOFFSETS,
 430      type => $off_type,
 431      value => $offsets,
 432     );
 433   $self->add_tag
 434     (
 435      tag => TIFFTAG_STRIPBYTECOUNTS,
 436      type => $count_type,
 437      value => $sizes,
 438     );
 439 }
 440
 441 sub _pack_format {
 442   my ($self, $bits, $formats) = @_;
 443
 444   $bits ||= $self->_bitspersample;
 445   $formats ||= $self->_sampleformat;
 446   @$bits == @$formats
 447     or die "Mismatch between bitsperlsample and sampleformat counts\n";
 448   my $pack = '';
 449   for my $i (0 .. $#$bits) {
 450     my $type;
 451     if ($formats->[$i] == SAMPLEFORMAT_IEEEFP) {
 452       if ($bits->[$i] == 32) {
 453         $type = "FLOAT";
 454       }
 455       elsif ($bits->[$i] == 64) {
 456         $type = "DOUBLE";
 457       }
 458       else {
 459         die "No IEEEFP format for bits $bits->[$i]\n";
 460       }
 461     }
 462     else {
 463       $type = $bit_types{$bits->[$i]}
 464         or die "Can't pack $bits->[$i] bits\n";
 465       $type = "S$type" if $formats->[$i] == SAMPLEFORMAT_INT;
 466     }
 467     $pack .= $self->{$type};
 468   }
 469
 470   wantarray ? ($pack, $bits, $formats) : $pack;
 471 }
 472
 473 sub samples_per_pixel {
 474   my ($self) = @_;
 475
 476   my $spp = $self->tag_value(TIFFTAG_SAMPLESPERPIXEL);
 477   $spp or return 1;
 478
 479   return $spp->[0];
 480 }
 481
 482 sub compression {
 483   my ($self) = @_;
 484
 485   my $comp = $self->tag_value(TIFFTAG_COMPRESSION);
 486   $comp or return COMPRESSION_NONE;
 487
 488   return $comp->[0];
 489 }
 490
 491 sub _bitspersample {
 492   my ($self) = @_;
 493
 494   my $bps = $self->tag_value(TIFFTAG_BITSPERSAMPLE);
 495   $bps or $bps = [ ( 1 ) x $self->samples_per_pixel ];
 496
 497   return $bps;
 498 }
 499
 500 sub _sampleformat {
 501   my ($self) = @_;
 502
 503   my $formats = $self->tag_value(TIFFTAG_SAMPLEFORMAT);
 504   unless ($formats) {
 505     $formats = [ ( SAMPLEFORMAT_UINT ) x $self->samples_per_pixel ];
 506   }
 507
 508   return $formats;
 509 }
 510
 511 sub unpack_samples {
 512   my ($self, $data, $bits, $formats) = @_;
 513
 514   my ($pack, $rbits, $rformats) = $self->_pack_format($bits, $formats);
 515
 516   my $values = [ unpack "($pack)*", $data ];
 517
 518   wantarray ? ( $values, $rbits, $rformats) : $values;
 519 }
 520
 521 sub pack_samples {
 522   my ($self, $data, $bits, $formats) = @_;
 523
 524   my $pack = $self->_pack_format($bits, $formats);
 525
 526   pack "($pack)*", @$data;
 527 }