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