libt1 support is deprecated
[imager.git] / fileformatdocs / tiffsigned.pl
CommitLineData
05c9b356
TC
1#!perl -w
2# Make a signed or floating point version of an uncompressed TIFF
3use strict;
4use Getopt::Long;
5
6my $mode = "int";
7GetOptions("m|mode=s" => \$mode);
8
9use constant TIFFTAG_BITSPERSAMPLE => 258;
10use constant TIFFTAG_SAMPLEFORMAT => 339;
11use constant SAMPLEFORMAT_UINT => 1;
12use constant SAMPLEFORMAT_INT => 2;
13use constant SAMPLEFORMAT_IEEEFP => 3;
14use constant SAMPLEFORMAT_VOID => 4;
15use constant TIFFTAG_COMPRESSION => 259;
16use constant COMPRESSION_NONE => 1;
17use constant TIFFTAG_SAMPLESPERPIXEL => 277;
18
19my $inname = shift;
20my $outname = shift
21 or die <<EOS;
22Usage: $0 [-m mode] input output
23 mode can be:
24 int
25 float
26 double
27EOS
28
29open my $fh, "<", $inname
30 or die "Cannot open $inname: $!\n";
31binmode $fh;
32
33my $data = do { local $/; <$fh> };
34
35close $fh;
36
37my $tiff = TIFFPP->new($data);
38
39$tiff->compression == COMPRESSION_NONE
40 or die "TIFF must be uncompressed\n";
41
42my $sample_count = $tiff->samples_per_pixel;
43
44if ($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}
66elsif ($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}
94elsif ($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
125open my $ofh, ">", $outname;
126binmode $ofh;
127
128print $ofh $tiff->data;
129close $ofh or die;
130
131package TIFFPP;
132
133use constant TIFFTAG_STRIPOFFSETS => 273;
134use constant TIFFTAG_STRIPBYTECOUNTS => 279;
135use constant TIFFTAG_SAMPLESPERPIXEL => 277;
136use constant TIFFTAG_BITSPERSAMPLE => 258;
137use constant TIFFTAG_SAMPLEFORMAT => 339;
138use constant TIFFTAG_COMPRESSION => 259;
139use constant COMPRESSION_NONE => 1;
140
141use constant TYPE_SHORT => 3;
142use constant TYPE_LONG => 4;
143
144use constant SAMPLEFORMAT_UINT => 1;
145use constant SAMPLEFORMAT_INT => 2;
146use constant SAMPLEFORMAT_IEEEFP => 3;
147use constant SAMPLEFORMAT_VOID => 4;
148
149my %types;
150my %type_names;
151
152my %bit_types;
153
154BEGIN {
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
257sub 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
296sub data {
297 $_[0]{data};
298}
299
300sub _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
337sub 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
367sub remove_tag {
368 my ($self, $tag) = @_;
369
370 if (delete $self->{ifdh}{$tag}) {
371 $self->{ifd} = [ grep $_->{tag} != $tag, @{$self->{ifd}} ];
372 }
373}
374
375sub 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
394sub 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
403sub 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
441sub _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
473sub 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
482sub 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
491sub _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
500sub _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
511sub 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
521sub pack_samples {
522 my ($self, $data, $bits, $formats) = @_;
523
524 my $pack = $self->_pack_format($bits, $formats);
525
526 pack "($pack)*", @$data;
527}