he unpack code for ICO/CUR file handling could extend 32-bit unsigned values to 64...
[imager.git] / 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 }