source: main/trunk/greenstone2/perllib/cpan/Image/ExifTool/PhaseOne.pm@ 34921

Last change on this file since 34921 was 34921, checked in by anupama, 3 years ago

Committing the improvements to EmbeddedMetaPlugin's processing of Keywords vs other metadata fields. Keywords were literally stored as arrays of words rather than phrases in PDFs (at least in Diego's sample PDF), whereas other meta fields like Subjects and Creators stored them as arrays of phrases. To get both to work, Kathy updated EXIF to a newer version, to retrieve the actual EXIF values stored in the PDF. And Kathy and Dr Bainbridge came up with a new option that I added called apply_join_before_split_to_metafields that's a regex which can list the metadata fields to apply the join_before_split to and whcih previously always got applied to all metadata fields. Now it's applied to any *Keywords metafields by default, as that's the metafield we have experience of that behaves differently to the others, as it stores by word instead of phrases. Tested on Diego's sample PDF. Diego has double-checked it to works on his sample PDF too, setting the split char to ; and turning on the join_before_split and leaving apply_join_before_split_to_metafields at its default of .*Keywords. File changes are strings.properties for the tooltip, the plugin introducing the option and working with it and Kathy's EXIF updates affecting cpan/File and cpan/Image.
File size: 26.1 KB
Line 
1#------------------------------------------------------------------------------
2# File: PhaseOne.pm
3#
4# Description: Phase One maker notes tags
5#
6# Revisions: 2013-02-17 - P. Harvey Created
7#
8# References: 1) http://www.cybercom.net/~dcoffin/dcraw/
9#------------------------------------------------------------------------------
10
11package Image::ExifTool::PhaseOne;
12
13use strict;
14use vars qw($VERSION);
15use Image::ExifTool qw(:DataAccess :Utils);
16use Image::ExifTool::Exif;
17
18$VERSION = '1.06';
19
20sub WritePhaseOne($$$);
21sub ProcessPhaseOne($$$);
22
23# default formats based on PhaseOne format size
24my @formatName = ( undef, 'string', 'int16s', undef, 'int32s' );
25
26# Phase One maker notes (ref PH)
27%Image::ExifTool::PhaseOne::Main = (
28 PROCESS_PROC => \&ProcessPhaseOne,
29 WRITE_PROC => \&WritePhaseOne,
30 CHECK_PROC => \&Image::ExifTool::Exif::CheckExif,
31 WRITABLE => '1',
32 FORMAT => 'int32s',
33 GROUPS => { 0 => 'MakerNotes', 2 => 'Camera' },
34 VARS => { ENTRY_SIZE => 16 }, # (entries contain a format field)
35 NOTES => 'These tags are extracted from the maker notes of Phase One images.',
36 0x0100 => { #1
37 Name => 'CameraOrientation',
38 ValueConv => '$val & 0x03', # ignore other bits for now
39 PrintConv => {
40 0 => 'Horizontal (normal)',
41 1 => 'Rotate 90 CW',
42 2 => 'Rotate 270 CW',
43 3 => 'Rotate 180',
44 },
45 },
46 # 0x0101 - int32u: 96,160,192,256,544 (same as 0x0213)
47 0x0102 => { Name => 'SerialNumber', Format => 'string' },
48 # 0x0103 - int32u: 19,20,59769034
49 # 0x0104 - int32u: 50,200
50 0x0105 => 'ISO',
51 0x0106 => {
52 Name => 'ColorMatrix1',
53 Format => 'float',
54 Count => 9,
55 PrintConv => q{
56 my @a = map { sprintf('%.3f', $_) } split ' ', $val;
57 return "@a";
58 },
59 PrintConvInv => '$val',
60 },
61 0x0107 => { Name => 'WB_RGBLevels', Format => 'float', Count => 3 },
62 0x0108 => 'SensorWidth',
63 0x0109 => 'SensorHeight',
64 0x010a => 'SensorLeftMargin', #1
65 0x010b => 'SensorTopMargin', #1
66 0x010c => 'ImageWidth',
67 0x010d => 'ImageHeight',
68 0x010e => { #1
69 Name => 'RawFormat',
70 # 1 = raw bit mask 0x5555 (>1 mask 0x1354)
71 # >2 = compressed
72 # 5 = non-linear
73 PrintConv => { #PH
74 1 => 'RAW 1', #? (encrypted)
75 2 => 'RAW 2', #? (encrypted)
76 3 => 'IIQ L',
77 # 4?
78 5 => 'IIQ S',
79 6 => 'IIQ Sv2',
80 },
81 },
82 0x010f => {
83 Name => 'RawData',
84 Format => 'undef', # (actually 2-byte integers, but don't convert)
85 Binary => 1,
86 PutFirst => 1,
87 Writable => 0,
88 Drop => 1, # don't copy to other file types
89 },
90 0x0110 => { #1
91 Name => 'SensorCalibration',
92 SubDirectory => { TagTable => 'Image::ExifTool::PhaseOne::SensorCalibration' },
93 },
94 0x0112 => {
95 Name => 'DateTimeOriginal',
96 Description => 'Date/Time Original',
97 Format => 'int32u',
98 Writable => 0, # (don't write because this is an encryption key for RawFormat 1 and 2)
99 Priority => 0,
100 Shift => 'Time',
101 Groups => { 2 => 'Time' },
102 Notes => 'may be used as a key to encrypt the raw data', #1
103 ValueConv => 'ConvertUnixTime($val)',
104 ValueConvInv => 'GetUnixTime($val)',
105 PrintConv => '$self->ConvertDateTime($val)',
106 PrintConvInv => '$self->InverseDateTime($val)',
107 },
108 0x0113 => 'ImageNumber', # (NC)
109 0x0203 => { Name => 'Software', Format => 'string' },
110 0x0204 => { Name => 'System', Format => 'string' },
111 # 0x020b - int32u: 0,1
112 # 0x020c - int32u: 1,2
113 # 0x020e - int32u: 1,3
114 0x0210 => { # (NC) (used in linearization formula - ref 1)
115 Name => 'SensorTemperature',
116 Format => 'float',
117 PrintConv => 'sprintf("%.2f C",$val)',
118 PrintConvInv => '$val=~s/ ?C//; $val',
119 },
120 0x0211 => { # (NC)
121 Name => 'SensorTemperature2',
122 Format => 'float',
123 PrintConv => 'sprintf("%.2f C",$val)',
124 PrintConvInv => '$val=~s/ ?C//; $val',
125 },
126 0x0212 => {
127 Name => 'UnknownDate',
128 Format => 'int32u',
129 Groups => { 2 => 'Time' },
130 # (this time is within about 10 minutes before or after 0x0112)
131 Unknown => 1,
132 Shift => 'Time',
133 ValueConv => 'ConvertUnixTime($val)',
134 ValueConvInv => 'GetUnixTime($val)',
135 PrintConv => '$self->ConvertDateTime($val)',
136 PrintConvInv => '$self->InverseDateTime($val)',
137 },
138 # 0x0213 - int32u: 96,160,192,256,544 (same as 0x0101)
139 # 0x0215 - int32u: 4,5
140 # 0x021a - used by dcraw
141 0x021c => { Name => 'StripOffsets', Binary => 1, Writable => 0 },
142 0x021d => 'BlackLevel', #1
143 # 0x021e - int32u: 1
144 # 0x0220 - int32u: 32
145 # 0x0221 - float: 0-271
146 0x0222 => 'SplitColumn', #1
147 0x0223 => { Name => 'BlackLevelData', Format => 'int16u', Count => -1, Binary => 1 }, #1
148 # 0x0224 - int32u: 1688,2748,3372
149 0x0225 => {
150 Name => 'PhaseOne_0x0225',
151 Format => 'int16s',
152 Count => -1,
153 Flags => ['Unknown','Hidden'],
154 PrintConv => 'length($val) > 60 ? substr($val,0,55) . "[...]" : $val',
155 },
156 0x0226 => {
157 Name => 'ColorMatrix2',
158 Format => 'float',
159 Count => 9,
160 PrintConv => q{
161 my @a = map { sprintf('%.3f', $_) } split ' ', $val;
162 return "@a";
163 },
164 PrintConvInv => '$val',
165 },
166 # 0x0227 - int32u: 0,1
167 # 0x0228 - int32u: 1,2
168 # 0x0229 - int32s: -2,0
169 0x0267 => { #PH
170 Name => 'AFAdjustment',
171 Format => 'float',
172 },
173 0x022b => { #PH
174 Name => 'PhaseOne_0x022b',
175 Format => 'float',
176 Flags => ['Unknown','Hidden'],
177 },
178 # 0x0242 - int32u: 55
179 # 0x0244 - int32u: 102
180 # 0x0245 - float: 1.2
181 0x0258 => { #PH
182 Name => 'PhaseOne_0x0258',
183 Format => 'int16s',
184 Flags => ['Unknown','Hidden'],
185 PrintConv => 'length($val) > 60 ? substr($val,0,55) . "[...]" : $val',
186 },
187 0x025a => { #PH
188 Name => 'PhaseOne_0x025a',
189 Format => 'int16s',
190 Flags => ['Unknown','Hidden'],
191 PrintConv => 'length($val) > 60 ? substr($val,0,55) . "[...]" : $val',
192 },
193 # 0x0300 - int32u: 100,101,102
194 0x0301 => { Name => 'FirmwareVersions', Format => 'string' },
195 # 0x0304 - int32u: 8,3073,3076
196 0x0400 => {
197 Name => 'ShutterSpeedValue',
198 Format => 'float',
199 ValueConv => 'abs($val)<100 ? 2**(-$val) : 0',
200 ValueConvInv => '$val>0 ? -log($val)/log(2) : -100',
201 PrintConv => 'Image::ExifTool::Exif::PrintExposureTime($val)',
202 PrintConvInv => 'Image::ExifTool::Exif::ConvertFraction($val)',
203 },
204 0x0401 => {
205 Name => 'ApertureValue',
206 Format => 'float',
207 ValueConv => '2 ** ($val / 2)',
208 ValueConvInv => '$val>0 ? 2*log($val)/log(2) : 0',
209 PrintConv => 'sprintf("%.1f",$val)',
210 PrintConvInv => '$val',
211 },
212 0x0402 => {
213 Name => 'ExposureCompensation',
214 Format => 'float',
215 PrintConv => 'sprintf("%.3f",$val)',
216 PrintConvInv => '$val',
217 },
218 0x0403 => {
219 Name => 'FocalLength',
220 Format => 'float',
221 PrintConv => 'sprintf("%.1f mm",$val)',
222 PrintConvInv => '$val=~s/\s*mm$//;$val',
223 },
224 # 0x0404 - int32u: 0,3
225 # 0x0405 - int32u? (big numbers)
226 # 0x0406 - int32u: 1
227 # 0x0407 - float: -0.333 (exposure compensation again?)
228 # 0x0408-0x0409 - int32u: 1
229 0x0410 => { Name => 'CameraModel', Format => 'string' },
230 # 0x0411 - int32u: 33556736
231 0x0412 => { Name => 'LensModel', Format => 'string' },
232 0x0414 => {
233 Name => 'MaxApertureValue',
234 Format => 'float',
235 ValueConv => '2 ** ($val / 2)',
236 ValueConvInv => '$val>0 ? 2*log($val)/log(2) : 0',
237 PrintConv => 'sprintf("%.1f",$val)',
238 PrintConvInv => '$val',
239 },
240 0x0415 => {
241 Name => 'MinApertureValue',
242 Format => 'float',
243 ValueConv => '2 ** ($val / 2)',
244 ValueConvInv => '$val>0 ? 2*log($val)/log(2) : 0',
245 PrintConv => 'sprintf("%.1f",$val)',
246 PrintConvInv => '$val',
247 },
248 # 0x0416 - float: (min focal length? ref LR, Credo50) (but looks more like an int32u date for the 645DF - PH)
249 # 0x0417 - float: 80 (max focal length? ref LR)
250 0x0455 => { #PH
251 Name => 'Viewfinder',
252 Format => 'string',
253 },
254);
255
256# Phase One metadata (ref 1)
257%Image::ExifTool::PhaseOne::SensorCalibration = (
258 PROCESS_PROC => \&ProcessPhaseOne,
259 WRITE_PROC => \&WritePhaseOne,
260 CHECK_PROC => \&Image::ExifTool::Exif::CheckExif,
261 GROUPS => { 0 => 'MakerNotes', 2 => 'Camera' },
262 TAG_PREFIX => 'SensorCalibration',
263 WRITE_GROUP => 'PhaseOne',
264 VARS => { ENTRY_SIZE => 12 }, # (entries do not contain a format field)
265 0x0400 => {
266 Name => 'SensorDefects',
267 # list of defects. each defect is 4 x int16u values:
268 # 0=column, 1=row, 2=type (129=bad pixel, 131=bad column), 3=?
269 # (but it isn't really worth the time decoding this -- it can be a few hundred kB)
270 Format => 'undef',
271 Binary => 1,
272 },
273 0x0401 => {
274 Name => 'AllColorFlatField1',
275 Format => 'undef',
276 Flags => ['Unknown','Binary'],
277 },
278 0x0404 => { #PH
279 Name => 'SensorCalibration_0x0404',
280 Format => 'string',
281 Flags => ['Unknown','Hidden'],
282 },
283 0x0405 => { #PH
284 Name => 'SensorCalibration_0x0405',
285 Format => 'string',
286 Flags => ['Unknown','Hidden'],
287 },
288 0x0406 => { #PH
289 Name => 'SensorCalibration_0x0406',
290 Format => 'string',
291 Flags => ['Unknown','Hidden'],
292 },
293 0x0407 => { #PH
294 Name => 'SerialNumber',
295 Format => 'string',
296 Writable => 1,
297 },
298 0x0408 => { #PH
299 Name => 'SensorCalibration_0x0408',
300 Format => 'float',
301 Flags => ['Unknown','Hidden'],
302 },
303 0x040b => {
304 Name => 'RedBlueFlatField',
305 Format => 'undef',
306 Flags => ['Unknown','Binary'],
307 },
308 0x040f => { #PH
309 Name => 'SensorCalibration_0x040f',
310 Format => 'undef',
311 Flags => ['Unknown','Hidden'],
312 },
313 0x0410 => {
314 Name => 'AllColorFlatField2',
315 Format => 'undef',
316 Flags => ['Unknown','Binary'],
317 },
318 # 0x0412 - used by dcraw
319 0x0413 => { #PH
320 Name => 'SensorCalibration_0x0413',
321 Format => 'double',
322 Flags => ['Unknown','Hidden'],
323 },
324 0x0414 => { #PH
325 Name => 'SensorCalibration_0x0414',
326 Format => 'undef',
327 Flags => ['Unknown','Hidden'],
328 ValueConv => q{
329 my $order = GetByteOrder();
330 if (length $val >= 8 and SetByteOrder(substr($val,0,2))) {
331 $val = ReadValue(\$val, 2, 'int16u', 1, length($val)-2) . ' ' .
332 ReadValue(\$val, 4, 'float', undef, length($val)-4);
333 SetByteOrder($order);
334 }
335 return $val;
336 },
337 },
338 0x0416 => {
339 Name => 'AllColorFlatField3',
340 Format => 'undef',
341 Flags => ['Unknown','Binary'],
342 },
343 0x0418 => { #PH
344 Name => 'SensorCalibration_0x0418',
345 Format => 'undef',
346 Flags => ['Unknown','Hidden'],
347 },
348 0x0419 => {
349 Name => 'LinearizationCoefficients1',
350 Format => 'float',
351 PrintConv => 'my @a=split " ",$val;join " ", map { sprintf("%.5g",$_) } @a',
352 },
353 0x041a => {
354 Name => 'LinearizationCoefficients2',
355 Format => 'float',
356 PrintConv => 'my @a=split " ",$val;join " ", map { sprintf("%.5g",$_) } @a',
357 },
358 0x041c => { #PH
359 Name => 'SensorCalibration_0x041c',
360 Format => 'float',
361 Flags => ['Unknown','Hidden'],
362 },
363 0x041e => { #PH
364 Name => 'SensorCalibration_0x041e',
365 Format => 'undef',
366 Flags => ['Unknown','Hidden'],
367 ValueConv => q{
368 my $order = GetByteOrder();
369 if (length $val >= 8 and SetByteOrder(substr($val,0,2))) {
370 $val = ReadValue(\$val, 2, 'int16u', 1, length($val)-2) . ' ' .
371 ReadValue(\$val, 4, 'float', undef, length($val)-4);
372 SetByteOrder($order);
373 }
374 return $val;
375 },
376 },
377);
378
379#------------------------------------------------------------------------------
380# Do HTML dump of an IFD entry
381# Inputs: 0) ExifTool ref, 1) tag table ref, 3) tag ID, 4) tag value,
382# 5) IFD entry offset, 6) IFD entry size, 7) parameter hash
383sub HtmlDump($$$$$$%)
384{
385 my ($et, $tagTablePtr, $tagID, $value, $entry, $entryLen, %parms) = @_;
386 my ($dirName, $index, $formatStr, $dataPos, $base, $size, $valuePtr) =
387 @parms{qw(DirName Index Format DataPos Base Size Start)};
388 my $tagInfo = $et->GetTagInfo($tagTablePtr, $tagID);
389 my ($tagName, $colName, $subdir);
390 my $count = $parms{Count} || $size;
391 $base = 0 unless defined $base;
392 if ($tagInfo) {
393 $tagName = $$tagInfo{Name};
394 $subdir = $$tagInfo{SubDirectory};
395 if ($$tagInfo{Format}) {
396 $formatStr = $$tagInfo{Format};
397 $count = $size / Image::ExifTool::FormatSize($formatStr);
398 }
399 } else {
400 $tagName = sprintf("Tag 0x%.4x", $tagID);
401 }
402 my $dname = sprintf("${dirName}-%.2d", $index);
403 # build our tool tip
404 my $fstr = "$formatStr\[$count]";
405 my $tip = sprintf("Tag ID: 0x%.4x\n", $tagID) .
406 "Format: $fstr\nSize: $size bytes\n";
407 if ($size > 4) {
408 $tip .= sprintf("Value offset: 0x%.4x\n", $valuePtr - $base);
409 $tip .= sprintf("Actual offset: 0x%.4x\n", $valuePtr + $dataPos);
410 $tip .= sprintf("Offset base: 0x%.4x\n", $dataPos + $base);
411 $colName = "<span class=F>$tagName</span>";
412 } else {
413 $colName = $tagName;
414 }
415 unless (ref $value) {
416 my $tval = length($value) > 32 ? substr($value,0,28) . '[...]' : $value;
417 $tval =~ tr/\x00-\x1f\x7f-\xff/./;
418 $tip .= "Value: $tval";
419 }
420 $et->HDump($entry+$dataPos, $entryLen, "$dname $colName", $tip, 1);
421 if ($size > 4) {
422 my $dumpPos = $valuePtr + $dataPos;
423 # add value data block
424 $et->HDump($dumpPos,$size,"$tagName value",'SAME', $subdir ? 0x04 : 0);
425 }
426}
427
428#------------------------------------------------------------------------------
429# Write PhaseOne maker notes (both types of PhaseOne IFD)
430# Inputs: 0) ExifTool object ref, 1) source dirInfo ref, 2) tag table ref
431# Returns: data block or undef on error
432sub WritePhaseOne($$$)
433{
434 my ($et, $dirInfo, $tagTablePtr) = @_;
435 $et or return 1; # allow dummy access to autoload this package
436
437 # nothing to do if we aren't changing any PhaseOne tags
438 my $newTags = $et->GetNewTagInfoHash($tagTablePtr);
439 return undef unless %$newTags or $$et{DropTags} or $$et{EDIT_DIRS}{PhaseOne};
440
441 my $dataPt = $$dirInfo{DataPt};
442 my $dataPos = $$dirInfo{DataPos} || 0;
443 my $dirStart = $$dirInfo{DirStart} || 0;
444 my $dirLen = $$dirInfo{DirLen} || $$dirInfo{DataLen} - $dirStart;
445 my $dirName = $$dirInfo{DirName};
446 my $verbose = $et->Options('Verbose');
447
448 return undef if $dirLen < 12;
449 unless ($$tagTablePtr{VARS} and $$tagTablePtr{VARS}{ENTRY_SIZE}) {
450 $et->WarnOnce("No ENTRY_SIZE for $$tagTablePtr{TABLE_NAME}");
451 return undef;
452 }
453 my $entrySize = $$tagTablePtr{VARS}{ENTRY_SIZE};
454 my $ifdType = $$tagTablePtr{TAG_PREFIX} || 'PhaseOne';
455 my $hdr = substr($$dataPt, $dirStart, 12);
456 if ($entrySize == 16) {
457 return undef unless $hdr =~ /^(IIII.waR|MMMMRaw.)/s;
458 } elsif ($hdr !~ /^(IIII\x01\0\0\0|MMMM\0\0\0\x01)/s) {
459 $et->Warn("Unrecognized $ifdType directory version");
460 return undef;
461 }
462 SetByteOrder(substr($hdr, 0, 2));
463 # get offset to start of PhaseOne directory
464 my $ifdStart = Get32u(\$hdr, 8);
465 return undef if $ifdStart + 8 > $dirLen;
466 # initialize output directory buffer with (fixed) number of entries plus 4-byte padding
467 my $dirBuff = substr($$dataPt, $dirStart + $ifdStart, 8);
468 # get number of entries in PhaseOne directory
469 my $numEntries = Get32u(\$dirBuff, 0);
470 my $ifdEnd = $ifdStart + 8 + $entrySize * $numEntries;
471 return undef if $numEntries < 2 or $numEntries > 300 or $ifdEnd > $dirLen;
472 my $hdrBuff = $hdr;
473 my $valBuff = ''; # buffer for value data
474 my $fixup = new Image::ExifTool::Fixup;
475 my $index;
476 for ($index=0; $index<$numEntries; ++$index) {
477 my $entry = $dirStart + $ifdStart + 8 + $entrySize * $index;
478 my $tagID = Get32u($dataPt, $entry);
479 my $size = Get32u($dataPt, $entry+$entrySize-8);
480 my ($formatSize, $formatStr);
481 if ($entrySize == 16) {
482 $formatSize = Get32u($dataPt, $entry+4);
483 $formatStr = $formatName[$formatSize];
484 unless ($formatStr) {
485 $et->Warn("Possibly invalid $ifdType IFD entry $index",1);
486 delete $$newTags{$tagID}; # make sure we don't try to change this one
487 }
488 } else {
489 # (no format code for SensorCalibration IFD entries)
490 $formatSize = 1;
491 $formatStr = 'undef';
492 }
493 my $valuePtr = $entry + $entrySize - 4;
494 if ($size > 4) {
495 if ($size > 0x7fffffff) {
496 $et->Error("Invalid size for $ifdType IFD entry $index",1);
497 return undef;
498 }
499 $valuePtr = Get32u($dataPt, $valuePtr);
500 if ($valuePtr + $size > $dirLen) {
501 $et->Error(sprintf("Invalid offset 0x%.4x for $ifdType IFD entry $index",$valuePtr),1);
502 return undef;
503 }
504 $valuePtr += $dirStart;
505 }
506 my $value = substr($$dataPt, $valuePtr, $size);
507 my $tagInfo = $$newTags{$tagID} || $$tagTablePtr{$tagID};
508 $tagInfo = $et->GetTagInfo($tagTablePtr, $tagID) if $tagInfo and ref($tagInfo) ne 'HASH';
509 if ($$newTags{$tagID}) {
510 $formatStr = $$tagInfo{Format} if $$tagInfo{Format};
511 my $count = int($size / Image::ExifTool::FormatSize($formatStr));
512 my $val = ReadValue(\$value, 0, $formatStr, $count, $size);
513 my $nvHash = $et->GetNewValueHash($tagInfo);
514 if ($et->IsOverwriting($nvHash, $val)) {
515 my $newVal = $et->GetNewValue($nvHash);
516 # allow count to change for string and undef types only
517 undef $count if $formatStr eq 'string' or $formatStr eq 'undef';
518 my $newValue = WriteValue($newVal, $formatStr, $count);
519 if (defined $newValue) {
520 $value = $newValue;
521 $size = length $newValue;
522 $et->VerboseValue("- $dirName:$$tagInfo{Name}", $val);
523 $et->VerboseValue("+ $dirName:$$tagInfo{Name}", $newVal);
524 ++$$et{CHANGED};
525 }
526 }
527 } elsif ($tagInfo and $$tagInfo{SubDirectory}) {
528 my $subTable = GetTagTable($$tagInfo{SubDirectory}{TagTable});
529 my %subdirInfo = (
530 DirName => $$tagInfo{Name},
531 DataPt => \$value,
532 DataLen => length $value,
533 );
534 my $newValue = $et->WriteDirectory(\%subdirInfo, $subTable);
535 if (defined $newValue and length($newValue)) {
536 $value = $newValue;
537 $size = length $newValue;
538 }
539 } elsif ($$et{DropTags} and (($tagInfo and $$tagInfo{Drop}) or $size > 8192)) {
540 # decrease the number of entries in the directory
541 Set32u(Get32u(\$dirBuff, 0) - 1, \$dirBuff, 0);
542 next; # drop this tag
543 }
544 # add the tagID, possibly format size, and size to this directory entry
545 $dirBuff .= substr($$dataPt, $entry, $entrySize - 8) . Set32u($size);
546
547 # pad value to an even 4-byte boundary just in case
548 $value .= ("\0" x (4 - ($size & 0x03))) if $size & 0x03 or not $size;
549 if ($size <= 4) {
550 # store value in place of the IFD value pointer (already padded to 4 bytes)
551 $dirBuff .= $value;
552 } elsif ($tagInfo and $$tagInfo{PutFirst}) {
553 # store value immediately after header
554 $dirBuff .= Set32u(length $hdrBuff);
555 $hdrBuff .= $value;
556 } else {
557 # store value at end of value buffer
558 $fixup->AddFixup(length $dirBuff);
559 $dirBuff .= Set32u(length $valBuff);
560 $valBuff .= $value;
561 }
562 }
563 # apply necessary fixup to offsets in PhaseOne directory
564 $$fixup{Shift} = length $hdrBuff;
565 $fixup->ApplyFixup(\$dirBuff);
566 # set pointer to PhaseOneIFD in header
567 Set32u(length($hdrBuff) + length($valBuff), \$hdrBuff, 8);
568 return $hdrBuff . $valBuff . $dirBuff;
569}
570
571#------------------------------------------------------------------------------
572# Read Phase One maker notes
573# Inputs: 0) ExifTool object ref, 1) dirInfo ref, 2) tag table ref
574# Returns: 1 on success
575# Notes: This routine processes both the main PhaseOne IFD type (with 16 bytes
576# per entry), and the SensorCalibration IFD type (12 bytes per entry)
577sub ProcessPhaseOne($$$)
578{
579 my ($et, $dirInfo, $tagTablePtr) = @_;
580 my $dataPt = $$dirInfo{DataPt};
581 my $dataPos = ($$dirInfo{DataPos} || 0) + ($$dirInfo{Base} || 0);
582 my $dirStart = $$dirInfo{DirStart} || 0;
583 my $dirLen = $$dirInfo{DirLen} || $$dirInfo{DataLen} - $dirStart;
584 my $binary = $et->Options('Binary');
585 my $verbose = $et->Options('Verbose');
586 my $htmlDump = $$et{HTML_DUMP};
587
588 return 0 if $dirLen < 12;
589 unless ($$tagTablePtr{VARS} and $$tagTablePtr{VARS}{ENTRY_SIZE}) {
590 $et->WarnOnce("No ENTRY_SIZE for $$tagTablePtr{TABLE_NAME}");
591 return undef;
592 }
593 my $entrySize = $$tagTablePtr{VARS}{ENTRY_SIZE};
594 my $ifdType = $$tagTablePtr{TAG_PREFIX} || 'PhaseOne';
595
596 my $hdr = substr($$dataPt, $dirStart, 12);
597 if ($entrySize == 16) {
598 return 0 unless $hdr =~ /^(IIII.waR|MMMMRaw.)/s;
599 } elsif ($hdr !~ /^(IIII\x01\0\0\0|MMMM\0\0\0\x01)/s) {
600 $et->Warn("Unrecognized $ifdType directory version");
601 return 0;
602 }
603 SetByteOrder(substr($hdr, 0, 2));
604 # get offset to start of PhaseOne directory
605 my $ifdStart = Get32u(\$hdr, 8);
606 return 0 if $ifdStart + 8 > $dirLen;
607 # get number of entries in PhaseOne directory
608 my $numEntries = Get32u($dataPt, $dirStart + $ifdStart);
609 my $ifdEnd = $ifdStart + 8 + $entrySize * $numEntries;
610 return 0 if $numEntries < 2 or $numEntries > 300 or $ifdEnd > $dirLen;
611 $et->VerboseDir($ifdType, $numEntries);
612 if ($htmlDump) {
613 $et->HDump($dirStart + $dataPos, 8, "$ifdType header");
614 $et->HDump($dirStart + $dataPos + 8, 4, "$ifdType IFD offset");
615 $et->HDump($dirStart + $dataPos + $ifdStart, 4, "$ifdType entries",
616 "Entry count: $numEntries");
617 $et->HDump($dirStart + $dataPos + $ifdStart + 4, 4, '[unused]');
618 }
619 my $index;
620 for ($index=0; $index<$numEntries; ++$index) {
621 my $entry = $dirStart + $ifdStart + 8 + $entrySize * $index;
622 my $tagID = Get32u($dataPt, $entry);
623 my $size = Get32u($dataPt, $entry+$entrySize-8);
624 my $valuePtr = $entry + $entrySize - 4;
625 my ($formatSize, $formatStr, $value);
626 if ($entrySize == 16) {
627 # (format code only for the 16-byte IFD entry)
628 $formatSize = Get32u($dataPt, $entry+4);
629 $formatStr = $formatName[$formatSize];
630 unless ($formatStr) {
631 $et->WarnOnce("Unrecognized $ifdType format size $formatSize",1);
632 $formatSize = 1;
633 $formatStr = 'undef';
634 }
635 } elsif ($size %4) {
636 $formatSize = 1;
637 $formatStr = 'undef';
638 } else {
639 $formatSize = 4;
640 $formatStr = 'int32s';
641 }
642 if ($size > 4) {
643 if ($size > 0x7fffffff) {
644 $et->Warn("Invalid size for $ifdType IFD entry $index");
645 return 0;
646 }
647 $valuePtr = Get32u($dataPt, $valuePtr);
648 if ($valuePtr + $size > $dirLen) {
649 $et->Warn(sprintf("Invalid offset 0x%.4x for $ifdType IFD entry $index",$valuePtr));
650 return 0;
651 }
652 $valuePtr += $dirStart;
653 }
654 my $tagInfo = $et->GetTagInfo($tagTablePtr, $tagID);
655 if ($tagInfo) {
656 $formatStr = $$tagInfo{Format} if $$tagInfo{Format};
657 } else {
658 next unless $verbose or $htmlDump;
659 }
660 my $count = int($size / Image::ExifTool::FormatSize($formatStr));
661 if ($count > 100000 and not $binary) {
662 $value = \ "Binary data $size bytes";
663 } else {
664 $value = ReadValue($dataPt,$valuePtr,$formatStr,$count,$size);
665 # try to distinguish between the various format types
666 if ($formatStr eq 'int32s') {
667 my ($val) = split ' ', $value;
668 if (defined $val) {
669 # get floating point exponent (has bias of 127)
670 my $exp = ($val & 0x7f800000) >> 23;
671 if ($exp > 120 and $exp < 140) {
672 $formatStr = 'float';
673 $value = ReadValue($dataPt,$valuePtr,$formatStr,$count,$size);
674 }
675 }
676 }
677 }
678 my %parms = (
679 DirName => $ifdType,
680 Index => $index,
681 DataPt => $dataPt,
682 DataPos => $dataPos,
683 Size => $size,
684 Start => $valuePtr,
685 Format => $formatStr,
686 Count => $count
687 );
688 $htmlDump and HtmlDump($et, $tagTablePtr, $tagID, $value, $entry, $entrySize,
689 %parms, Base => $dirStart);
690 $et->HandleTag($tagTablePtr, $tagID, $value, %parms);
691 }
692 return 1;
693}
694
6951; # end
696
697__END__
698
699=head1 NAME
700
701Image::ExifTool::PhaseOne - Phase One maker notes tags
702
703=head1 SYNOPSIS
704
705This module is loaded automatically by Image::ExifTool when required.
706
707=head1 DESCRIPTION
708
709This module contains definitions required by Image::ExifTool to decode Phase
710One maker notes.
711
712=head1 AUTHOR
713
714Copyright 2003-2021, Phil Harvey (philharvey66 at gmail.com)
715
716This library is free software; you can redistribute it and/or modify it
717under the same terms as Perl itself.
718
719=head1 REFERENCES
720
721=over 4
722
723=item L<http://www.cybercom.net/~dcoffin/dcraw/>
724
725=back
726
727=head1 SEE ALSO
728
729L<Image::ExifTool::TagNames/PhaseOne Tags>,
730L<Image::ExifTool(3pm)|Image::ExifTool>
731
732=cut
Note: See TracBrowser for help on using the repository browser.