1package Image::Info::TIFF;
2
3$VERSION = 0.05;
4
5use strict;
6use Config;
7use Carp qw(confess);
8use Image::TIFF;
9
10my @types = (
11  [ "ERROR INVALID TYPE",     "?", 0],
12  [ "BYTE",      "C", 1],
13  [ "ASCII",     "A", 1],
14  [ "SHORT",     "S", 2],
15  [ "LONG",      "L", 4],
16  [ "RATIONAL",  "N2", 8],
17  [ "SBYTE",     "c", 1],
18  [ "UNDEFINED", "a", 1],
19  [ "SSHORT",    "s", 2],
20  [ "SLONG",     "l", 4],
21  [ "SRATIONAL", "N2", 8],
22  [ "FLOAT",     "f", 4],
23  [ "DOUBLE",    "d", 8],
24);
25
26sub _hostbyteorder {
27    my $hbo = $Config{byteorder};
28    # we only care about the order, not the length (for 64 bit, it might
29    # be 12345678)
30    if ($hbo =~ /^1234/) { return '1234' }
31    if ($hbo =~ /4321$/) { return '4321' }
32    die "Unexpected host byteorder: $hbo";
33}
34
35sub _read
36{
37    # read bytes, and move the file pointer forward
38    my($source, $len) = @_;
39    my $buf;
40    my $n = read($source, $buf, $len);
41    die "read failed: $!" unless defined $n;
42    die "short read ($len/$n) at pos " . tell($source) unless $n == $len;
43    $buf;
44}
45
46sub _readbytes
47{
48    # read bytes, but make the file pointer stand still
49    my ($fh,$offset,$len) = @_;
50    my $curoffset = tell($fh);
51    my $buf;
52    seek($fh,$offset,0);
53    my $n = read($fh,$buf,$len);
54    confess("short read($n/$len)") unless $n == $len;
55    # back to before.
56    seek($fh,$curoffset,0);
57    return $buf;
58}
59
60sub _readrational
61{
62    my ($fh,$offset,$byteorder,$count,$ar,$signed) = @_;
63    my $curoffset = tell($fh);
64    my $buf;
65    seek($fh,$offset,0);
66    while ($count > 0) {
67	my $num;
68	my $denom;
69	if ($signed) {
70	    $num = unpack("l",_read_order($fh,4,$byteorder));
71	    $denom = unpack("l",_read_order($fh,4,$byteorder));
72	} else {
73	    $num = unpack("L",_read_order($fh,4,$byteorder));
74	    $denom = unpack("L",_read_order($fh,4,$byteorder));
75	}
76	push(@{$ar},new Image::TIFF::Rational($num,$denom));
77	$count--;
78    }
79    # back to before.
80    seek($fh,$curoffset,0);
81}
82
83sub _read_order
84{
85    my($source, $len,$byteorder) = @_;
86
87    my $buf = _read($source,$len);
88    # maybe reverse the read data?
89    if ($byteorder ne _hostbyteorder()) {
90	my @bytes = unpack("C$len",$buf);
91	my @newbytes;
92	# swap bytes
93	for (my $i = $len-1; $i >= 0; $i--) {
94	    push(@newbytes,$bytes[$i]);
95	}
96	$buf = pack("C$len",@newbytes);
97    }
98    $buf;
99}
100
101my %order = (
102	     "MM\x00\x2a" => '4321',
103	     "II\x2a\x00" => '1234',
104	     );
105
106sub process_file
107{
108    my($info, $fh) = @_;
109
110    my $soi = _read($fh, 4);
111    die "TIFF: SOI missing" unless (defined($order{$soi}));
112    # XXX: should put this info in all pages?
113    $info->push_info(0, "file_media_type" => "image/tiff");
114    $info->push_info(0, "file_ext" => "tif");
115
116    my $byteorder = $order{$soi};
117    my $ifdoff = unpack("L",_read_order($fh,4,$byteorder));
118    my $page = 0;
119    do {
120      # print "TIFF Directory at $ifdoff\n";
121      $ifdoff = _process_ifds($info,$fh,$page,0,$byteorder,$ifdoff);
122      $page++;
123    } while ($ifdoff);
124}
125
126sub _process_ifds {
127    my($info, $fh, $page, $tagsseen, $byteorder, $ifdoffset) = @_;
128    my $curpos = tell($fh);
129    seek($fh,$ifdoffset,0);
130
131    my $n = unpack("S",_read_order($fh, 2, $byteorder)); ## Number of entries
132    my $i = 1;
133    while ($n > 0) {
134	# process one IFD entry
135	my $tag = unpack("S",_read_order($fh,2,$byteorder));
136	my $fieldtype = unpack("S",_read_order($fh,2,$byteorder));
137	unless ($types[$fieldtype]) {
138	  my $warnmsg = "Unrecognised fieldtype $fieldtype, ignoring following entries";
139	  warn "$warnmsg\n";
140	  $info->push_info($page, "Warn" => $warnmsg);
141	  return 0;
142	}
143        my ($typename, $typepack, $typelen) = @{$types[$fieldtype]};
144	my $count = unpack("L",_read_order($fh,4,$byteorder));
145        my $value_offset_orig = _read_order($fh,4,$byteorder);
146	my $value_offset = unpack("L", $value_offset_orig);
147	my $val;
148        ## The 4 bytes of $value_offset may actually contains the value itself,
149        ## if it fits into 4 bytes.
150        my $len = $typelen * $count;
151        if ($len <= 4) {
152          if (($byteorder ne _hostbyteorder()) && ($len != 4)) {
153	    my @bytes = unpack("C4", $value_offset_orig);
154	    for (my $i=0; $i < 4 - $len; $i++) { shift @bytes; }
155	    $value_offset_orig = pack("C$len", @bytes);
156          }
157          @$val = unpack($typepack x $count, $value_offset_orig);
158        } elsif ($fieldtype == 2) {
159          ## ASCII text. The last byte is a NUL, which we don't need
160          ## to include in the Perl string, so read one less than the count.
161          @$val = _readbytes($fh, $value_offset, $count - 1);
162	} elsif ($fieldtype == 5) {
163	  ## Unsigned Rational
164	  $val = [];
165	  _readrational($fh,$value_offset,$byteorder,$count,$val,0);
166        } elsif ($fieldtype == 10) {
167	  ## Signed Rational
168	  $val = [];
169          _readrational($fh,$value_offset,$byteorder,$count,$val,1);
170        } else {
171          ## Just read $count thingies from the offset
172	  @$val = unpack($typepack x $count, _readbytes($fh, $value_offset, $typelen * $count));
173	}
174	#look up tag
175	my $tn =  Image::TIFF->exif_tagname($tag);
176        foreach my $v (@$val) {
177	  if (ref($tn)) {
178	    $v = $$tn{$v};
179	    $tn = $$tn{__TAG__};
180	  }
181        }
182	if ($tn eq "NewSubfileType") {
183	    # start new page if necessary
184	    if ($tagsseen) {
185		$page++;
186		$tagsseen = 0;
187	    }
188	} else {
189	    $tagsseen = 1;
190	}
191        my $vval;
192        ## If only one value, use direct
193        if (@$val <= 1) {
194          $val = $val->[0] || '';
195          $vval = $val;
196        } else {
197          $vval = '(' . join(',',@$val) . ')';
198        }
199	# print "$page/$i:$value_offset:$tag ($tn), fieldtype: $fieldtype, count: $count = $vval\n";
200	if ($tn eq "ExifOffset") {
201	    # parse ExifSubIFD
202            # print "ExifSubIFD at $value_offset\n";
203	    _process_ifds($info,$fh,$page,$tagsseen,$byteorder,$value_offset);
204	}
205	$info->push_info($page, $tn => $val);
206	$n--;
207	$i++;
208    }
209    my $ifdoff = unpack("L",_read_order($fh,4,$byteorder));
210    #print "next dir at $ifdoff\n";
211    seek($fh,$curpos,0);
212    return $ifdoff if $ifdoff;
213    0;
214}
2151;
216
217__END__
218
219=pod
220
221=head1 NAME
222
223Image::Info::TIFF - TIFF support for Image::Info
224
225=head1 SYNOPSIS
226
227 use Image::Info qw(image_info dim);
228
229 my $info = image_info("image.tif");
230 if (my $error = $info->{error}) {
231     die "Can't parse image info: $error\n";
232 }
233 print $info->{BitPerSample};
234
235 my($w, $h) = dim($info);
236
237=head1 DESCRIPTION
238
239This module adds TIFF support for Image::Info.
240
241
242=head1 METHODS
243
244=head2 process_file()
245
246        $info->process_file($source, $options);
247
248Processes one file and sets the found info fields in the C<$info> object.
249
250=head1 SEE ALSO
251
252L<Image::Info>
253
254=head1 AUTHOR
255
256Jerrad Pierce <belg4mit@mit.edu>/<webmaster@pthbb.org>
257
258Patches and fixes by Ben Wheeler.
259
260This library is free software; you can redistribute it and/or
261modify it under the same terms as Perl itself.
262
263=begin register
264
265MAGIC: /^MM\x00\x2a/
266MAGIC: /^II\x2a\x00/
267
268The C<TIFF> spec can be found at:
269L<http://partners.adobe.com/public/developer/tiff/>
270
271The EXIF spec can be found at:
272L<http://www.exif.org/specifications.html>
273
274=end register
275
276=cut
277