File Coverage

lib/Image/Info/TIFF.pm
Criterion Covered Total %
statement 109 124 87.9
branch 27 40 67.5
condition 4 5 80.0
subroutine 11 11 100.0
pod 1 1 100.0
total 152 181 83.9


line stmt bran cond sub pod time code
1             package Image::Info::TIFF;
2              
3             $VERSION = 0.05;
4              
5 4     4   31 use strict;
  4         8  
  4         123  
6 4     4   19 use Config;
  4         7  
  4         211  
7 4     4   22 use Carp qw(confess);
  4         7  
  4         200  
8 4     4   1175 use Image::TIFF;
  4         32  
  4         5519  
9              
10             my @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              
26             sub _hostbyteorder {
27 1023     1023   3640 my $hbo = $Config{byteorder};
28             # we only care about the order, not the length (for 64 bit, it might
29             # be 12345678)
30 1023 50       3015 if ($hbo =~ /^1234/) { return '1234' }
  1023         2222  
31 0 0       0 if ($hbo =~ /4321$/) { return '4321' }
  0         0  
32 0         0 die "Unexpected host byteorder: $hbo";
33             }
34              
35             sub _read
36             {
37             # read bytes, and move the file pointer forward
38 891     891   992 my($source, $len) = @_;
39 891         832 my $buf;
40 891         1909 my $n = read($source, $buf, $len);
41 891 50       1449 die "read failed: $!" unless defined $n;
42 891 100       1216 die "short read ($len/$n) at pos " . tell($source) unless $n == $len;
43 890         1436 $buf;
44             }
45              
46             sub _readbytes
47             {
48             # read bytes, but make the file pointer stand still
49 42     42   124 my ($fh,$offset,$len) = @_;
50 42         65 my $curoffset = tell($fh);
51 42         41 my $buf;
52 42         374 seek($fh,$offset,0);
53 42         321 my $n = read($fh,$buf,$len);
54 42 50       104 confess("short read($n/$len)") unless $n == $len;
55             # back to before.
56 42         329 seek($fh,$curoffset,0);
57 42         174 return $buf;
58             }
59              
60             sub _readrational
61             {
62 22     22   35 my ($fh,$offset,$byteorder,$count,$ar,$signed) = @_;
63 22         39 my $curoffset = tell($fh);
64 22         21 my $buf;
65 22         193 seek($fh,$offset,0);
66 22         62 while ($count > 0) {
67 22         29 my $num;
68             my $denom;
69 22 50       36 if ($signed) {
70 0         0 $num = unpack("l",_read_order($fh,4,$byteorder));
71 0         0 $denom = unpack("l",_read_order($fh,4,$byteorder));
72             } else {
73 22         35 $num = unpack("L",_read_order($fh,4,$byteorder));
74 22         37 $denom = unpack("L",_read_order($fh,4,$byteorder));
75             }
76 22         28 push(@{$ar},new Image::TIFF::Rational($num,$denom));
  22         88  
77 22         55 $count--;
78             }
79             # back to before.
80 22         204 seek($fh,$curoffset,0);
81             }
82              
83             sub _read_order
84             {
85 885     885   1171 my($source, $len,$byteorder) = @_;
86              
87 885         1069 my $buf = _read($source,$len);
88             # maybe reverse the read data?
89 884 100       1210 if ($byteorder ne _hostbyteorder()) {
90 83         180 my @bytes = unpack("C$len",$buf);
91 83         92 my @newbytes;
92             # swap bytes
93 83         126 for (my $i = $len-1; $i >= 0; $i--) {
94 254         364 push(@newbytes,$bytes[$i]);
95             }
96 83         176 $buf = pack("C$len",@newbytes);
97             }
98 884         1773 $buf;
99             }
100              
101             my %order = (
102             "MM\x00\x2a" => '4321',
103             "II\x2a\x00" => '1234',
104             );
105              
106             sub process_file
107             {
108 6     6 1 18 my($info, $fh) = @_;
109              
110 6         14 my $soi = _read($fh, 4);
111 6 50       20 die "TIFF: SOI missing" unless (defined($order{$soi}));
112             # XXX: should put this info in all pages?
113 6         30 $info->push_info(0, "file_media_type" => "image/tiff");
114 6         20 $info->push_info(0, "file_ext" => "tif");
115              
116 6         11 my $byteorder = $order{$soi};
117 6         13 my $ifdoff = unpack("L",_read_order($fh,4,$byteorder));
118 6         11 my $page = 0;
119 6         9 do {
120             # print "TIFF Directory at $ifdoff\n";
121 12         23 $ifdoff = _process_ifds($info,$fh,$page,0,$byteorder,$ifdoff);
122 11         35 $page++;
123             } while ($ifdoff);
124             }
125              
126             sub _process_ifds {
127 12     12   26 my($info, $fh, $page, $tagsseen, $byteorder, $ifdoffset) = @_;
128 12         23 my $curpos = tell($fh);
129 12         83 seek($fh,$ifdoffset,0);
130              
131 12         29 my $n = unpack("S",_read_order($fh, 2, $byteorder)); ## Number of entries
132 11         15 my $i = 1;
133 11         24 while ($n > 0) {
134             # process one IFD entry
135 203         295 my $tag = unpack("S",_read_order($fh,2,$byteorder));
136 203         348 my $fieldtype = unpack("S",_read_order($fh,2,$byteorder));
137 203 50       418 unless ($types[$fieldtype]) {
138 0         0 my $warnmsg = "Unrecognised fieldtype $fieldtype, ignoring following entries";
139 0         0 warn "$warnmsg\n";
140 0         0 $info->push_info($page, "Warn" => $warnmsg);
141 0         0 return 0;
142             }
143 203         199 my ($typename, $typepack, $typelen) = @{$types[$fieldtype]};
  203         329  
144 203         282 my $count = unpack("L",_read_order($fh,4,$byteorder));
145 203         320 my $value_offset_orig = _read_order($fh,4,$byteorder);
146 203         315 my $value_offset = unpack("L", $value_offset_orig);
147 203         206 my $val;
148             ## The 4 bytes of $value_offset may actually contains the value itself,
149             ## if it fits into 4 bytes.
150 203         241 my $len = $typelen * $count;
151 203 100       417 if ($len <= 4) {
    100          
    100          
    50          
152 139 100 100     270 if (($byteorder ne _hostbyteorder()) && ($len != 4)) {
153 12         26 my @bytes = unpack("C4", $value_offset_orig);
154 12         25 for (my $i=0; $i < 4 - $len; $i++) { shift @bytes; }
  24         38  
155 12         25 $value_offset_orig = pack("C$len", @bytes);
156             }
157 139         383 @$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 31         58 @$val = _readbytes($fh, $value_offset, $count - 1);
162             } elsif ($fieldtype == 5) {
163             ## Unsigned Rational
164 22         34 $val = [];
165 22         39 _readrational($fh,$value_offset,$byteorder,$count,$val,0);
166             } elsif ($fieldtype == 10) {
167             ## Signed Rational
168 0         0 $val = [];
169 0         0 _readrational($fh,$value_offset,$byteorder,$count,$val,1);
170             } else {
171             ## Just read $count thingies from the offset
172 11         29 @$val = unpack($typepack x $count, _readbytes($fh, $value_offset, $typelen * $count));
173             }
174             #look up tag
175 203         542 my $tn = Image::TIFF->exif_tagname($tag);
176 203         321 foreach my $v (@$val) {
177 221 100       392 if (ref($tn)) {
178 66         122 $v = $$tn{$v};
179 66         100 $tn = $$tn{__TAG__};
180             }
181             }
182 203 50       293 if ($tn eq "NewSubfileType") {
183             # start new page if necessary
184 0 0       0 if ($tagsseen) {
185 0         0 $page++;
186 0         0 $tagsseen = 0;
187             }
188             } else {
189 203         218 $tagsseen = 1;
190             }
191 203         193 my $vval;
192             ## If only one value, use direct
193 203 100       264 if (@$val <= 1) {
194 192   50     440 $val = $val->[0] || '';
195 192         264 $vval = $val;
196             } else {
197 11         38 $vval = '(' . join(',',@$val) . ')';
198             }
199             # print "$page/$i:$value_offset:$tag ($tn), fieldtype: $fieldtype, count: $count = $vval\n";
200 203 50       318 if ($tn eq "ExifOffset") {
201             # parse ExifSubIFD
202             # print "ExifSubIFD at $value_offset\n";
203 0         0 _process_ifds($info,$fh,$page,$tagsseen,$byteorder,$value_offset);
204             }
205 203         421 $info->push_info($page, $tn => $val);
206 203         251 $n--;
207 203         439 $i++;
208             }
209 11         23 my $ifdoff = unpack("L",_read_order($fh,4,$byteorder));
210             #print "next dir at $ifdoff\n";
211 11         103 seek($fh,$curpos,0);
212 11 100       37 return $ifdoff if $ifdoff;
213 5         14 0;
214             }
215             1;
216              
217             __END__