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

Last change on this file since 28214 was 24107, checked in by sjm84, 13 years ago

Updating the ExifTool perl modules
File size: 250.8 KB
Line 
1#------------------------------------------------------------------------------
2# File: ExifTool.pm
3#
4# Description: Read and write meta information
5#
6# URL: http://owl.phy.queensu.ca/~phil/exiftool/
7#
8# Revisions: Nov. 12/2003 - P. Harvey Created
9# (See html/history.html for revision history)
10#
11# Legal: Copyright (c) 2003-2010, Phil Harvey (phil at owl.phy.queensu.ca)
12# This library is free software; you can redistribute it and/or
13# modify it under the same terms as Perl itself.
14#------------------------------------------------------------------------------
15
16package Image::ExifTool;
17
18use strict;
19require 5.004; # require 5.004 for UNIVERSAL::isa (otherwise 5.002 would do)
20require Exporter;
21use File::RandomAccess;
22
23use vars qw($VERSION $RELEASE @ISA %EXPORT_TAGS $AUTOLOAD @fileTypes %allTables
24 @tableOrder $exifAPP1hdr $xmpAPP1hdr $xmpExtAPP1hdr $psAPP13hdr
25 $psAPP13old @loadAllTables %UserDefined $evalWarning %noWriteFile
26 %magicNumber @langs $defaultLang %langName %charsetName %mimeType
27 $swapBytes $swapWords $currentByteOrder %unpackStd);
28
29$VERSION = '8.57';
30$RELEASE = '';
31@ISA = qw(Exporter);
32%EXPORT_TAGS = (
33 # all public non-object-oriented functions:
34 Public => [qw(
35 ImageInfo GetTagName GetShortcuts GetAllTags GetWritableTags
36 GetAllGroups GetDeleteGroups GetFileType CanWrite CanCreate
37 )],
38 # exports not part of the public API, but used by ExifTool modules:
39 DataAccess => [qw(
40 ReadValue GetByteOrder SetByteOrder ToggleByteOrder Get8u Get8s Get16u
41 Get16s Get32u Get32s Get64u GetFloat GetDouble GetFixed32s Write
42 WriteValue Tell Set8u Set8s Set16u Set32u
43 )],
44 Utils => [qw(GetTagTable TagTableKeys GetTagInfoList)],
45 Vars => [qw(%allTables @tableOrder @fileTypes)],
46);
47# set all of our EXPORT_TAGS in EXPORT_OK
48Exporter::export_ok_tags(keys %EXPORT_TAGS);
49
50# test for problems that can arise if encoding.pm is used
51{ my $t = "\xff"; die "Incompatible encoding!\n" if ord($t) != 0xff; }
52
53# The following functions defined in Image::ExifTool::Writer are declared
54# here so their prototypes will be available. These Writer routines will be
55# autoloaded when any of them is called.
56sub SetNewValue($;$$%);
57sub SetNewValuesFromFile($$;@);
58sub GetNewValues($;$$);
59sub CountNewValues($);
60sub SaveNewValues($);
61sub RestoreNewValues($);
62sub WriteInfo($$;$$);
63sub SetFileModifyDate($$;$);
64sub SetFileName($$;$);
65sub GetAllTags(;$);
66sub GetWritableTags(;$);
67sub GetAllGroups($);
68sub GetNewGroups($);
69sub GetDeleteGroups();
70# non-public routines below
71sub InsertTagValues($$$;$);
72sub IsWritable($);
73sub GetNewFileName($$);
74sub NextTagKey($$);
75sub LoadAllTables();
76sub GetNewTagInfoList($;$);
77sub GetNewTagInfoHash($@);
78sub GetLangInfo($$);
79sub Get64s($$);
80sub Get64u($$);
81sub GetExtended($$);
82sub DecodeBits($$;$);
83sub EncodeBits($$;$$);
84sub HexDump($;$%);
85sub DumpTrailer($$);
86sub DumpUnknownTrailer($$);
87sub VerboseInfo($$$%);
88sub VerboseDir($$;$$);
89sub VerboseValue($$$;$);
90sub VPrint($$@);
91sub Rationalize($;$);
92sub Write($@);
93sub WriteTrailerBuffer($$$);
94sub AddNewTrailers($;@);
95sub Tell($);
96sub WriteValue($$;$$$$);
97sub WriteDirectory($$$;$);
98sub WriteBinaryData($$$);
99sub CheckBinaryData($$$);
100sub WriteTIFF($$$);
101sub PackUTF8(@);
102sub UnpackUTF8($);
103sub SetPreferredByteOrder($);
104sub CopyBlock($$$);
105sub CopyFileAttrs($$);
106
107# other subroutine definitions
108sub DoEscape($$);
109sub ConvertFileSize($);
110sub ParseArguments($;@); #(defined in attempt to avoid mod_perl problem)
111
112# list of main tag tables to load in LoadAllTables() (sub-tables are recursed
113# automatically). Note: They will appear in this order in the documentation
114# unless tweaked in BuildTagLookup::GetTableOrder().
115@loadAllTables = qw(
116 PhotoMechanic Exif GeoTiff CanonRaw KyoceraRaw MinoltaRaw PanasonicRaw
117 SigmaRaw JPEG GIMP Jpeg2000 GIF BMP BMP::OS2 PICT PNG MNG DjVu PGF MIFF PSP
118 PDF PostScript Photoshop::Header FujiFilm::RAF Sony::SRF2 Sony::SR2SubIFD
119 Sony::PMP ITC ID3 Vorbis FLAC APE APE::NewHeader APE::OldHeader MPC
120 MPEG::Audio MPEG::Video MPEG::Xing M2TS QuickTime QuickTime::ImageFile
121 Matroska MXF DV Flash Flash::FLV Real::Media Real::Audio Real::Metafile RIFF
122 AIFF ASF DICOM MIE HTML XMP::SVG EXE EXE::PEVersion EXE::PEString EXE::MachO
123 EXE::PEF EXE::ELF LNK Font RSRC Rawzor ZIP ZIP::GZIP ZIP::RAR RTF OOXML
124 iWork
125);
126
127# alphabetical list of current Lang modules
128@langs = qw(cs de en en_ca en_gb es fr it ja ko nl pl ru sv tr zh_cn zh_tw);
129
130$defaultLang = 'en'; # default language
131
132# language names
133%langName = (
134 cs => 'Czech (Čeština)',
135 de => 'German (Deutsch)',
136 en => 'English',
137 en_ca => 'Canadian English',
138 en_gb => 'British English',
139 es => 'Spanish (Español)',
140 fr => 'French (Français)',
141 it => 'Italian (Italiano)',
142 ja => 'Japanese (日本語)',
143 ko => 'Korean (한국얎)',
144 nl => 'Dutch (Nederlands)',
145 pl => 'Polish (Polski)',
146 ru => 'Russian (РусскОй)',
147 sv => 'Swedish (Svenska)',
148 'tr'=> 'Turkish (TÌrkçe)',
149 zh_cn => 'Simplified Chinese (简䜓䞭文)',
150 zh_tw => 'Traditional Chinese (繁體䞭文)',
151);
152
153# recognized file types, in the order we test unknown files
154# Notes: 1) There is no need to test for like types separately here
155# 2) Put types with weak file signatures at end of list to avoid false matches
156@fileTypes = qw(JPEG CRW TIFF GIF MRW RAF X3F JP2 PNG MIE MIFF PS PDF PSD XMP
157 BMP PPM RIFF AIFF ASF MOV MPEG Real SWF PSP FLV OGG FLAC APE MPC
158 MKV MXF DV PMP IND PGF ICC ITC HTML VRD RTF XCF QTIF FPX PICT
159 ZIP GZIP RAR BZ2 TAR RWZ EXE LNK RAW Font RSRC M2TS MP3 DICM);
160
161# file types that we can write (edit)
162my @writeTypes = qw(JPEG TIFF GIF CRW MRW ORF RAF RAW PNG MIE PSD XMP PPM
163 EPS X3F PS PDF ICC VRD JP2 EXIF AI AIT IND);
164
165# file extensions that we can't write for various base types
166%noWriteFile = (
167 TIFF => [ qw(3FR DCR K25 KDC SRF) ],
168 XMP => [ 'SVG' ],
169);
170
171# file types that we can create from scratch
172# - must update CanCreate() documentation if this list is changed!
173my %createTypes = (XMP=>1, ICC=>1, MIE=>1, VRD=>1, EXIF=>1);
174
175# file type lookup for all recognized file extensions
176my %fileTypeLookup = (
177 '3FR' => ['TIFF', 'Hasselblad RAW format'],
178 '3G2' => ['MOV', '3rd Gen. Partnership Project 2 audio/video'],
179 '3GP' => ['MOV', '3rd Gen. Partnership Project audio/video'],
180 '3GP2'=> '3G2',
181 '3GPP'=> '3GP',
182 ACR => ['DICM', 'American College of Radiology ACR-NEMA'],
183 ACFM => ['Font', 'Adobe Composite Font Metrics'],
184 AFM => ['Font', 'Adobe Font Metrics'],
185 AMFM => ['Font', 'Adobe Multiple Master Font Metrics'],
186 AI => [['PDF','PS'], 'Adobe Illustrator'],
187 AIF => 'AIFF',
188 AIFC => ['AIFF', 'Audio Interchange File Format Compressed'],
189 AIFF => ['AIFF', 'Audio Interchange File Format'],
190 AIT => 'AI',
191 APE => ['APE', "Monkey's Audio format"],
192 ARW => ['TIFF', 'Sony Alpha RAW format'],
193 ASF => ['ASF', 'Microsoft Advanced Systems Format'],
194 AVI => ['RIFF', 'Audio Video Interleaved'],
195 BMP => ['BMP', 'Windows Bitmap'],
196 BTF => ['BTF', 'Big Tagged Image File Format'], #(unofficial)
197 BZ2 => ['BZ2', 'BZIP2 archive'],
198 CIFF => ['CRW', 'Camera Image File Format'],
199 COS => ['COS', 'Capture One Settings'],
200 CR2 => ['TIFF', 'Canon RAW 2 format'],
201 CRW => ['CRW', 'Canon RAW format'],
202 CS1 => ['PSD', 'Sinar CaptureShop 1-Shot RAW'],
203 DC3 => 'DICM',
204 DCM => 'DICM',
205 DCP => ['TIFF', 'DNG Camera Profile'],
206 DCR => ['TIFF', 'Kodak Digital Camera RAW'],
207 DFONT=> ['Font', 'Macintosh Data fork Font'],
208 DIB => ['BMP', 'Device Independent Bitmap'],
209 DIC => 'DICM',
210 DICM => ['DICM', 'Digital Imaging and Communications in Medicine'],
211 DIVX => ['ASF', 'DivX media format'],
212 DJV => 'DJVU',
213 DJVU => ['AIFF', 'DjVu image'],
214 DLL => ['EXE', 'Windows Dynamic Link Library'],
215 DNG => ['TIFF', 'Digital Negative'],
216 DOC => ['FPX', 'Microsoft Word Document'],
217 DOCM => [['ZIP','FPX'], 'Office Open XML Document Macro-enabled'],
218 # Note: I have seen a password-protected DOCX file which was FPX-like, so I assume
219 # that any other MS Office file could be like this too. The only difference is
220 # that the ZIP and FPX formats are checked first, so if this is wrong, no biggie.
221 DOCX => [['ZIP','FPX'], 'Office Open XML Document'],
222 DOT => ['FPX', 'Microsoft Word Template'],
223 DOTM => [['ZIP','FPX'], 'Office Open XML Document Template Macro-enabled'],
224 DOTX => [['ZIP','FPX'], 'Office Open XML Document Template'],
225 DV => ['DV', 'Digital Video'],
226 DVB => ['MOV', 'Digital Video Broadcasting'],
227 DYLIB=> ['EXE', 'Mach-O Dynamic Link Library'],
228 EIP => ['ZIP', 'Capture One Enhanced Image Package'],
229 EPS => ['EPS', 'Encapsulated PostScript Format'],
230 EPS2 => 'EPS',
231 EPS3 => 'EPS',
232 EPSF => 'EPS',
233 ERF => ['TIFF', 'Epson Raw Format'],
234 EXE => ['EXE', 'Windows executable file'],
235 EXIF => ['EXIF', 'Exchangable Image File Metadata'],
236 F4A => ['MOV', 'Adobe Flash Player 9+ Audio'],
237 F4B => ['MOV', 'Adobe Flash Player 9+ audio Book'],
238 F4P => ['MOV', 'Adobe Flash Player 9+ Protected'],
239 F4V => ['MOV', 'Adobe Flash Player 9+ Video'],
240 FLAC => ['FLAC', 'Free Lossless Audio Codec'],
241 FLA => ['FPX', 'Macromedia/Adobe Flash project'],
242 FLV => ['FLV', 'Flash Video'],
243 FPX => ['FPX', 'FlashPix'],
244 GIF => ['GIF', 'Compuserve Graphics Interchange Format'],
245 GZ => 'GZIP',
246 GZIP => ['GZIP', 'GNU ZIP compressed archive'],
247 HDP => ['TIFF', 'Windows HD Photo'],
248 HTM => 'HTML',
249 HTML => ['HTML', 'HyperText Markup Language'],
250 ICC => ['ICC', 'International Color Consortium'],
251 ICM => 'ICC',
252 IIQ => ['TIFF', 'Phase One Intelligent Image Quality RAW'],
253 IND => ['IND', 'Adobe InDesign'],
254 INDD => ['IND', 'Adobe InDesign Document'],
255 INDT => ['IND', 'Adobe InDesign Template'],
256 ITC => ['ITC', 'iTunes Cover Flow'],
257 JNG => ['PNG', 'JPG Network Graphics'],
258 JP2 => ['JP2', 'JPEG 2000 file'],
259 # JP4? - looks like a JPEG but the image data is different
260 JPEG => 'JPG',
261 JPG => ['JPEG', 'Joint Photographic Experts Group'],
262 JPM => ['JP2', 'JPEG 2000 compound image'],
263 JPX => ['JP2', 'JPEG 2000 with extensions'],
264 K25 => ['TIFF', 'Kodak DC25 RAW'],
265 KDC => ['TIFF', 'Kodak Digital Camera RAW'],
266 KEY => ['ZIP', 'Apple Keynote presentation'],
267 KTH => ['ZIP', 'Apple Keynote Theme'],
268 LNK => ['LNK', 'Windows shortcut'],
269 M2T => 'M2TS',
270 M2TS => ['M2TS', 'MPEG-2 Transport Stream'],
271 M2V => ['MPEG', 'MPEG-2 Video'],
272 M4A => ['MOV', 'MPEG-4 Audio'],
273 M4B => ['MOV', 'MPEG-4 audio Book'],
274 M4P => ['MOV', 'MPEG-4 Protected'],
275 M4V => ['MOV', 'MPEG-4 Video'],
276 MEF => ['TIFF', 'Mamiya (RAW) Electronic Format'],
277 MIE => ['MIE', 'Meta Information Encapsulation format'],
278 MIF => 'MIFF',
279 MIFF => ['MIFF', 'Magick Image File Format'],
280 MKA => ['MKV', 'Matroska Audio'],
281 MKS => ['MKV', 'Matroska Subtitle'],
282 MKV => ['MKV', 'Matroska Video'],
283 MNG => ['PNG', 'Multiple-image Network Graphics'],
284 # MODD => ['PLIST','Sony Picture Motion Metadata'],
285 MOS => ['TIFF', 'Creo Leaf Mosaic'],
286 MOV => ['MOV', 'Apple QuickTime movie'],
287 MP3 => ['MP3', 'MPEG-1 Layer 3 audio'],
288 MP4 => ['MOV', 'MPEG-4 video'],
289 MPC => ['MPC', 'Musepack Audio'],
290 MPEG => ['MPEG', 'MPEG-1 or MPEG-2 audio/video'],
291 MPG => 'MPEG',
292 MPO => ['JPEG', 'Extended Multi-Picture format'],
293 MQV => ['MOV', 'Sony Mobile Quicktime Video'],
294 MRW => ['MRW', 'Minolta RAW format'],
295 MTS => ['M2TS', 'MPEG-2 Transport Stream'],
296 MXF => ['MXF', 'Material Exchange Format'],
297 # NDPI => ['TIFF', 'Hamamatsu NanoZoomer Digital Pathology Image'],
298 NEF => ['TIFF', 'Nikon (RAW) Electronic Format'],
299 NEWER => 'COS',
300 NMBTEMPLATE => ['ZIP','Apple Numbers Template'],
301 NRW => ['TIFF', 'Nikon RAW (2)'],
302 NUMBERS => ['ZIP','Apple Numbers spreadsheet'],
303 ODP => ['ZIP', 'Open Document Presentation'],
304 ODS => ['ZIP', 'Open Document Spreadsheet'],
305 ODT => ['ZIP', 'Open Document Text file'],
306 OGG => ['OGG', 'Ogg Vorbis audio file'],
307 ORF => ['ORF', 'Olympus RAW format'],
308 OTF => ['Font', 'Open Type Font'],
309 PAGES => ['ZIP', 'Apple Pages document'],
310 PBM => ['PPM', 'Portable BitMap'],
311 PCT => 'PICT',
312 PDF => ['PDF', 'Adobe Portable Document Format'],
313 PEF => ['TIFF', 'Pentax (RAW) Electronic Format'],
314 PFA => ['Font', 'PostScript Font ASCII'],
315 PFB => ['Font', 'PostScript Font Binary'],
316 PFM => ['Font', 'Printer Font Metrics'],
317 PGF => ['PGF', 'Progressive Graphics File'],
318 PGM => ['PPM', 'Portable Gray Map'],
319 PICT => ['PICT', 'Apple PICTure'],
320 # PLIST=> ['PLIST','Apple Property List'],
321 PMP => ['PMP', 'Sony DSC-F1 Cyber-Shot PMP'], # should stand for Proprietery Metadata Package ;)
322 PNG => ['PNG', 'Portable Network Graphics'],
323 POT => ['FPX', 'Microsoft PowerPoint Template'],
324 POTM => [['ZIP','FPX'], 'Office Open XML Presentation Template Macro-enabled'],
325 POTX => [['ZIP','FPX'], 'Office Open XML Presentation Template'],
326 PPM => ['PPM', 'Portable Pixel Map'],
327 PPS => ['FPX', 'Microsoft PowerPoint Slideshow'],
328 PPSM => [['ZIP','FPX'], 'Office Open XML Presentation Slideshow Macro-enabled'],
329 PPSX => [['ZIP','FPX'], 'Office Open XML Presentation Slideshow'],
330 PPT => ['FPX', 'Microsoft PowerPoint Presentation'],
331 PPTM => [['ZIP','FPX'], 'Office Open XML Presentation Macro-enabled'],
332 PPTX => [['ZIP','FPX'], 'Office Open XML Presentation'],
333 PS => ['PS', 'PostScript'],
334 PS2 => 'PS',
335 PS3 => 'PS',
336 PSB => ['PSD', 'Photoshop Large Document'],
337 PSD => ['PSD', 'Photoshop Drawing'],
338 PSP => ['PSP', 'Paint Shop Pro'],
339 PSPFRAME => 'PSP',
340 PSPIMAGE => 'PSP',
341 PSPSHAPE => 'PSP',
342 PSPTUBE => 'PSP',
343 QIF => 'QTIF',
344 QT => ['MOV', 'QuickTime movie'],
345 QTI => 'QTIF',
346 QTIF => ['QTIF', 'QuickTime Image File'],
347 RA => ['Real', 'Real Audio'],
348 RAF => ['RAF', 'FujiFilm RAW Format'],
349 RAM => ['Real', 'Real Audio Metafile'],
350 RAR => ['RAR', 'RAR Archive'],
351 RAW => [['RAW','TIFF'], 'Kyocera Contax N Digital RAW or Panasonic RAW'],
352 RIF => 'RIFF',
353 RIFF => ['RIFF', 'Resource Interchange File Format'],
354 RM => ['Real', 'Real Media'],
355 RMVB => ['Real', 'Real Media Variable Bitrate'],
356 RPM => ['Real', 'Real Media Plug-in Metafile'],
357 RSRC => ['RSRC', 'Mac OS Resource'],
358 RTF => ['RTF', 'Rich Text Format'],
359 RV => ['Real', 'Real Video'],
360 RW2 => ['TIFF', 'Panasonic RAW 2'],
361 RWL => ['TIFF', 'Leica RAW'],
362 RWZ => ['RWZ', 'Rawzor compressed image'],
363 SO => ['EXE', 'Shared Object file'],
364 SR2 => ['TIFF', 'Sony RAW Format 2'],
365 SRF => ['TIFF', 'Sony RAW Format'],
366 SRW => ['TIFF', 'Samsung RAW format'],
367 SVG => ['XMP', 'Scalable Vector Graphics'],
368 SWF => ['SWF', 'Shockwave Flash'],
369 TAR => ['TAR', 'TAR archive'],
370 THM => ['JPEG', 'Canon Thumbnail'],
371 THMX => [['ZIP','FPX'], 'Office Open XML Theme'],
372 TIF => 'TIFF',
373 TIFF => ['TIFF', 'Tagged Image File Format'],
374 TS => 'M2TS',
375 TTC => ['Font', 'True Type Font Collection'],
376 TTF => ['Font', 'True Type Font'],
377 TUB => 'PSP',
378 VOB => ['MPEG', 'Video Object'],
379 VRD => ['VRD', 'Canon VRD Recipe Data'],
380 VSD => ['FPX', 'Microsoft Visio Drawing'],
381 WAV => ['RIFF', 'WAVeform (Windows digital audio)'],
382 WDP => ['TIFF', 'Windows Media Photo'],
383 WEBM => ['MKV', 'Google Web Movie'],
384 WEBP => ['RIFF', 'Google Web Picture'],
385 WMA => ['ASF', 'Windows Media Audio'],
386 WMV => ['ASF', 'Windows Media Video'],
387 X3F => ['X3F', 'Sigma RAW format'],
388 XCF => ['XCF', 'GIMP native image format'],
389 XHTML=> ['HTML', 'Extensible HyperText Markup Language'],
390 XLA => ['FPX', 'Microsoft Excel Add-in'],
391 XLAM => [['ZIP','FPX'], 'Office Open XML Spreadsheet Add-in Macro-enabled'],
392 XLS => ['FPX', 'Microsoft Excel Spreadsheet'],
393 XLSB => [['ZIP','FPX'], 'Office Open XML Spreadsheet Binary'],
394 XLSM => [['ZIP','FPX'], 'Office Open XML Spreadsheet Macro-enabled'],
395 XLSX => [['ZIP','FPX'], 'Office Open XML Spreadsheet'],
396 XLT => ['FPX', 'Microsoft Excel Template'],
397 XLTM => [['ZIP','FPX'], 'Office Open XML Spreadsheet Template Macro-enabled'],
398 XLTX => [['ZIP','FPX'], 'Office Open XML Spreadsheet Template'],
399 XMP => ['XMP', 'Extensible Metadata Platform'],
400 ZIP => ['ZIP', 'ZIP archive'],
401);
402
403# descriptions for file types not found in above file extension lookup
404my %fileDescription = (
405 DICOM => 'Digital Imaging and Communications in Medicine',
406 PLIST => 'Property List',
407 XML => 'Extensible Markup Language',
408 'DJVU (multi-page)' => 'DjVu multi-page image',
409 'Win32 EXE' => 'Windows 32-bit Executable',
410 'Win32 DLL' => 'Windows 32-bit Dynamic Link Library',
411);
412
413# MIME types for applicable file types above
414# (missing entries default to 'application/unknown', but note that
415# other mime types may be specified by some modules, ie. QuickTime.pm)
416%mimeType = (
417 '3FR' => 'image/x-hasselblad-3fr',
418 AI => 'application/vnd.adobe.illustrator',
419 AIFF => 'audio/x-aiff',
420 APE => 'audio/x-monkeys-audio',
421 ASF => 'video/x-ms-asf',
422 ARW => 'image/x-sony-arw',
423 AVI => 'video/x-msvideo',
424 BMP => 'image/bmp',
425 BTF => 'image/x-tiff-big', #(NC) (ref http://www.asmail.be/msg0055371937.html)
426 BZ2 => 'application/bzip2',
427 'Canon 1D RAW' => 'image/x-raw', # (uses .TIF file extension)
428 CR2 => 'image/x-canon-cr2',
429 CRW => 'image/x-canon-crw',
430 DCR => 'image/x-kodak-dcr',
431 DFONT=> 'application/x-dfont',
432 DICM => 'application/dicom',
433 DIVX => 'video/divx',
434 DJVU => 'image/vnd.djvu',
435 DNG => 'image/x-adobe-dng',
436 DOC => 'application/msword',
437 DOCM => 'application/vnd.ms-word.document.macroEnabled',
438 DOCX => 'application/vnd.openxmlformats-officedocument.wordprocessingml.document',
439 DOT => 'application/msword',
440 DOTM => 'application/vnd.ms-word.template.macroEnabledTemplate',
441 DOTX => 'application/vnd.openxmlformats-officedocument.wordprocessingml.template',
442 DV => 'video/x-dv',
443 EIP => 'application/x-captureone', #(NC)
444 EPS => 'application/postscript',
445 ERF => 'image/x-epson-erf',
446 EXE => 'application/octet-stream',
447 FLA => 'application/vnd.adobe.fla',
448 FLAC => 'audio/flac',
449 FLV => 'video/x-flv',
450 Font => 'application/x-font-type1', # covers PFA, PFB and PFM (not sure about PFM)
451 FPX => 'image/vnd.fpx',
452 GIF => 'image/gif',
453 GZIP => 'application/x-gzip',
454 HDP => 'image/vnd.ms-photo',
455 HTML => 'text/html',
456 ICC => 'application/vnd.iccprofile',
457 IIQ => 'image/x-raw',
458 IND => 'application/x-indesign',
459 ITC => 'application/itunes',
460 JNG => 'image/jng',
461 JP2 => 'image/jp2',
462 JPEG => 'image/jpeg',
463 JPM => 'image/jpm',
464 JPX => 'image/jpx',
465 K25 => 'image/x-kodak-k25',
466 KDC => 'image/x-kodak-kdc',
467 LNK => 'application/octet-stream',
468 M2T => 'video/mpeg',
469 M2TS => 'video/m2ts',
470 MEF => 'image/x-mamiya-mef',
471 MIE => 'application/x-mie',
472 MIFF => 'application/x-magick-image',
473 MKA => 'audio/x-matroska',
474 MKS => 'application/x-matroska',
475 MKV => 'video/x-matroska',
476 MNG => 'video/mng',
477 MOS => 'image/x-raw',
478 MOV => 'video/quicktime',
479 MP3 => 'audio/mpeg',
480 MP4 => 'video/mp4',
481 MPC => 'audio/x-musepack',
482 MPEG => 'video/mpeg',
483 MRW => 'image/x-minolta-mrw',
484 MXF => 'application/mxf',
485 NEF => 'image/x-nikon-nef',
486 NRW => 'image/x-nikon-nrw',
487 ODP => 'application/vnd.oasis.opendocument.presentation',
488 ODS => 'application/vnd.oasis.opendocument.spreadsheet',
489 ODT => 'application/vnd.oasis.opendocument.text',
490 OGG => 'audio/x-ogg',
491 ORF => 'image/x-olympus-orf',
492 OTF => 'application/x-font-otf',
493 PBM => 'image/x-portable-bitmap',
494 PDF => 'application/pdf',
495 PEF => 'image/x-pentax-pef',
496 PGF => 'image/pgf',
497 PGM => 'image/x-portable-graymap',
498 PICT => 'image/pict',
499 PLIST=> 'application/xml',
500 PNG => 'image/png',
501 POT => 'application/vnd.ms-powerpoint',
502 POTM => 'application/vnd.ms-powerpoint.template.macroEnabled',
503 POTX => 'application/vnd.openxmlformats-officedocument.presentationml.template',
504 PPM => 'image/x-portable-pixmap',
505 PPS => 'application/vnd.ms-powerpoint',
506 PPSM => 'application/vnd.ms-powerpoint.slideshow.macroEnabled',
507 PPSX => 'application/vnd.openxmlformats-officedocument.presentationml.slideshow',
508 PPT => 'application/vnd.ms-powerpoint',
509 PPTM => 'application/vnd.ms-powerpoint.presentation.macroEnabled',
510 PPTX => 'application/vnd.openxmlformats-officedocument.presentationml.presentation',
511 PS => 'application/postscript',
512 PSD => 'application/vnd.adobe.photoshop',
513 PSP => 'image/x-paintshoppro', #(NC)
514 QTIF => 'image/x-quicktime',
515 RA => 'audio/x-pn-realaudio',
516 RAF => 'image/x-fujifilm-raf',
517 RAM => 'audio/x-pn-realaudio',
518 RAR => 'application/x-rar-compressed',
519 RAW => 'image/x-raw',
520 RM => 'application/vnd.rn-realmedia',
521 RMVB => 'application/vnd.rn-realmedia-vbr',
522 RPM => 'audio/x-pn-realaudio-plugin',
523 RSRC => 'application/ResEdit',
524 RTF => 'text/rtf',
525 RV => 'video/vnd.rn-realvideo',
526 RW2 => 'image/x-panasonic-rw2',
527 RWL => 'image/x-leica-rwl',
528 RWZ => 'image/x-rawzor', #(duplicated in Rawzor.pm)
529 SR2 => 'image/x-sony-sr2',
530 SRF => 'image/x-sony-srf',
531 SRW => 'image/x-samsung-srw',
532 SVG => 'image/svg+xml',
533 SWF => 'application/x-shockwave-flash',
534 TAR => 'application/x-tar',
535 THMX => 'application/vnd.ms-officetheme',
536 TIFF => 'image/tiff',
537 TTC => 'application/x-font-ttf',
538 TTF => 'application/x-font-ttf',
539 VSD => 'application/x-visio',
540 WAV => 'audio/x-wav',
541 WDP => 'image/vnd.ms-photo',
542 WEBM => 'video/webm',
543 WEBP => 'image/webp',
544 WMA => 'audio/x-ms-wma',
545 WMV => 'video/x-ms-wmv',
546 X3F => 'image/x-sigma-x3f',
547 XCF => 'image/x-xcf',
548 XLA => 'application/vnd.ms-excel',
549 XLAM => 'application/vnd.ms-excel.addin.macroEnabled',
550 XLS => 'application/vnd.ms-excel',
551 XLSB => 'application/vnd.ms-excel.sheet.binary.macroEnabled',
552 XLSM => 'application/vnd.ms-excel.sheet.macroEnabled',
553 XLSX => 'application/vnd.openxmlformats-officedocument.spreadsheetml.sheet',
554 XLT => 'application/vnd.ms-excel',
555 XLTM => 'application/vnd.ms-excel.template.macroEnabled',
556 XLTX => 'application/vnd.openxmlformats-officedocument.spreadsheetml.template',
557 XML => 'application/xml',
558 XMP => 'application/rdf+xml',
559 ZIP => 'application/zip',
560);
561
562# module names for processing routines of each file type
563# - undefined entries default to same module name as file type
564# - module name '' defaults to Image::ExifTool
565# - module name '0' indicates a recognized but unsupported file
566my %moduleName = (
567 BTF => 'BigTIFF',
568 BZ2 => 0,
569 CRW => 'CanonRaw',
570 DICM => 'DICOM',
571 COS => 'CaptureOne',
572 DOCX => 'OOXML',
573 EPS => 'PostScript',
574 EXIF => '',
575 ICC => 'ICC_Profile',
576 IND => 'InDesign',
577 FLV => 'Flash',
578 FPX => 'FlashPix',
579 GZIP => 'ZIP',
580 JP2 => 'Jpeg2000',
581 JPEG => '',
582 # MODD => 'XML',
583 MOV => 'QuickTime',
584 MKV => 'Matroska',
585 MP3 => 'ID3',
586 MRW => 'MinoltaRaw',
587 OGG => 'Vorbis',
588 ORF => 'Olympus',
589 # PLIST=> 'XML',
590 PMP => 'Sony',
591 PS => 'PostScript',
592 PSD => 'Photoshop',
593 QTIF => 'QuickTime',
594 RAF => 'FujiFilm',
595 RAR => 'ZIP',
596 RAW => 'KyoceraRaw',
597 RWZ => 'Rawzor',
598 SWF => 'Flash',
599 TAR => 0,
600 TIFF => '',
601 VRD => 'CanonVRD',
602 X3F => 'SigmaRaw',
603 XCF => 'GIMP',
604);
605
606# quick "magic number" file test used to avoid loading module unnecessarily:
607# - regular expression evaluated on first 1024 bytes of file
608# - must match beginning at first byte in file
609# - this test must not be more stringent than module logic
610%magicNumber = (
611 AIFF => '(FORM....AIF[FC]|AT&TFORM)',
612 APE => '(MAC |APETAGEX|ID3)',
613 ASF => '\x30\x26\xb2\x75\x8e\x66\xcf\x11\xa6\xd9\x00\xaa\x00\x62\xce\x6c',
614 BMP => 'BM',
615 BTF => '(II\x2b\0|MM\0\x2b)',
616 BZ2 => 'BZh[1-9]\x31\x41\x59\x26\x53\x59',
617 CRW => '(II|MM).{4}HEAP(CCDR|JPGM)',
618 DICM => '(.{128}DICM|\0[\x02\x04\x06\x08]\0[\0-\x20]|[\x02\x04\x06\x08]\0[\0-\x20]\0)',
619 DOCX => 'PK\x03\x04',
620 DV => '\x1f\x07\0[\x3f\xbf]', # (not tested if extension recognized)
621 EPS => '(%!PS|%!Ad|\xc5\xd0\xd3\xc6)',
622 EXE => '(MZ|\xca\xfe\xba\xbe|\xfe\xed\xfa[\xce\xcf]|[\xce\xcf]\xfa\xed\xfe|Joy!peff|\x7fELF|#!\s*/\S*bin/|!<arch>\x0a)',
623 EXIF => '(II\x2a\0|MM\0\x2a)',
624 FLAC => '(fLaC|ID3)',
625 FLV => 'FLV\x01',
626 Font => '((\0\x01\0\0|OTTO|true|typ1)[\0\x01]|ttcf\0[\x01\x02]\0\0|\0[\x01\x02]|' .
627 '(.{6})?%!(PS-(AdobeFont-|Bitstream )|FontType1-)|Start(Comp|Master)?FontMetrics)',
628 FPX => '\xd0\xcf\x11\xe0\xa1\xb1\x1a\xe1',
629 GIF => 'GIF8[79]a',
630 GZIP => '\x1f\x8b\x08',
631 HTML => '(?i)<(!DOCTYPE\s+HTML|HTML|\?xml)', # (case insensitive)
632 ICC => '.{12}(scnr|mntr|prtr|link|spac|abst|nmcl|nkpf)(XYZ |Lab |Luv |YCbr|Yxy |RGB |GRAY|HSV |HLS |CMYK|CMY |[2-9A-F]CLR){2}',
633 IND => '\x06\x06\xed\xf5\xd8\x1d\x46\xe5\xbd\x31\xef\xe7\xfe\x74\xb7\x1d',
634 ITC => '.{4}itch',
635 JP2 => '\0\0\0\x0cjP( |\x1a\x1a)\x0d\x0a\x87\x0a',
636 JPEG => '\xff\xd8\xff',
637 LNK => '.{4}\x01\x14\x02\0{5}\xc0\0{6}\x46',
638 M2TS => '(....)?\x47',
639 MIE => '~[\x10\x18]\x04.0MIE',
640 MIFF => 'id=ImageMagick',
641 MKV => '\x1a\x45\xdf\xa3',
642 MOV => '.{4}(free|skip|wide|ftyp|pnot|PICT|pict|moov|mdat|junk|uuid)',
643 # MP3 => difficult to rule out
644 MPC => '(MP\+|ID3)',
645 MPEG => '\0\0\x01[\xb0-\xbf]',
646 MRW => '\0MR[MI]',
647 MXF => '\x06\x0e\x2b\x34\x02\x05\x01\x01\x0d\x01\x02', # (not tested if extension recognized)
648 OGG => '(OggS|ID3)',
649 ORF => '(II|MM)',
650 PDF => '%PDF-\d+\.\d+',
651 PGF => 'PGF',
652 PICT => '(.{10}|.{522})(\x11\x01|\x00\x11)',
653 PMP => '.{8}\0{3}\x7c.{112}\xff\xd8\xff\xdb',
654 PNG => '(\x89P|\x8aM|\x8bJ)NG\r\n\x1a\n',
655 PPM => 'P[1-6]\s+',
656 PS => '(%!PS|%!Ad|\xc5\xd0\xd3\xc6)',
657 PSD => '8BPS\0[\x01\x02]',
658 PSP => 'Paint Shop Pro Image File\x0a\x1a\0{5}',
659 QTIF => '.{4}(idsc|idat|iicc)',
660 RAF => 'FUJIFILM',
661 RAR => 'Rar!\x1a\x07\0',
662 RAW => '(.{25}ARECOYK|II|MM)',
663 Real => '(\.RMF|\.ra\xfd|pnm://|rtsp://|http://)',
664 RIFF => 'RIFF',
665 RSRC => '(....)?\0\0\x01\0',
666 RTF => '[\n\r]*\\{[\n\r]*\\\\rtf',
667 # (don't be too restrictive for RW2/RWL -- how does magic number change for big-endian?)
668 RW2 => '(II|MM)', #(\x55\0\x18\0\0\0\x88\xe7\x74\xd8\xf8\x25\x1d\x4d\x94\x7a\x6e\x77\x82\x2b\x5d\x6a)
669 RWL => '(II|MM)', #(ditto)
670 RWZ => 'rawzor',
671 SWF => '[FC]WS[^\0]',
672 TAR => '.{257}ustar( )?\0', # (this doesn't catch old-style tar files)
673 TIFF => '(II|MM)', # don't test magic number (some raw formats are different)
674 VRD => 'CANON OPTIONAL DATA\0',
675 X3F => 'FOVb',
676 XCF => 'gimp xcf ',
677 XMP => '\0{0,3}(\xfe\xff|\xff\xfe|\xef\xbb\xbf)?\0{0,3}\s*<',
678 ZIP => 'PK\x03\x04',
679);
680
681# lookup for valid character set names (keys are all lower case)
682%charsetName = (
683 # Charset setting alias(es)
684 # ------------------------- --------------------------------------------
685 utf8 => 'UTF8', cp65001 => 'UTF8', 'utf-8' => 'UTF8',
686 latin => 'Latin', cp1252 => 'Latin', latin1 => 'Latin',
687 latin2 => 'Latin2', cp1250 => 'Latin2',
688 cyrillic => 'Cyrillic', cp1251 => 'Cyrillic', russian => 'Cyrillic',
689 greek => 'Greek', cp1253 => 'Greek',
690 turkish => 'Turkish', cp1254 => 'Turkish',
691 hebrew => 'Hebrew', cp1255 => 'Hebrew',
692 arabic => 'Arabic', cp1256 => 'Arabic',
693 baltic => 'Baltic', cp1257 => 'Baltic',
694 vietnam => 'Vietnam', cp1258 => 'Vietnam',
695 thai => 'Thai', cp874 => 'Thai',
696 macroman => 'MacRoman', cp10000 => 'MacRoman', mac => 'MacRoman', roman => 'MacRoman',
697 maclatin2 => 'MacLatin2', cp10029 => 'MacLatin2',
698 maccyrillic => 'MacCyrillic', cp10007 => 'MacCyrillic',
699 macgreek => 'MacGreek', cp10006 => 'MacGreek',
700 macturkish => 'MacTurkish', cp10081 => 'MacTurkish',
701 macromanian => 'MacRomanian', cp10010 => 'MacRomanian',
702 maciceland => 'MacIceland', cp10079 => 'MacIceland',
703 maccroatian => 'MacCroatian', cp10082 => 'MacCroatian',
704);
705
706# default group priority for writing
707my @defaultWriteGroups = qw(EXIF IPTC XMP MakerNotes Photoshop ICC_Profile CanonVRD);
708
709# group hash for ExifTool-generated tags
710my %allGroupsExifTool = ( 0 => 'ExifTool', 1 => 'ExifTool', 2 => 'ExifTool' );
711
712# special tag names (not used for tag info)
713my %specialTags = (
714 TABLE_NAME=>1, SHORT_NAME=>1, PROCESS_PROC=>1, WRITE_PROC=>1, CHECK_PROC=>1,
715 GROUPS=>1, FORMAT=>1, FIRST_ENTRY=>1, TAG_PREFIX=>1, PRINT_CONV=>1,
716 WRITABLE=>1, TABLE_DESC=>1, NOTES=>1, IS_OFFSET=>1, EXTRACT_UNKNOWN=>1,
717 NAMESPACE=>1, PREFERRED=>1, SRC_TABLE=>1, PRIORITY=>1, WRITE_GROUP=>1,
718 LANG_INFO=>1, VARS=>1, DATAMEMBER=>1, IS_SUBDIR=>1, SET_GROUP1=>1,
719);
720
721# headers for various segment types
722$exifAPP1hdr = "Exif\0\0";
723$xmpAPP1hdr = "http://ns.adobe.com/xap/1.0/\0";
724$xmpExtAPP1hdr = "http://ns.adobe.com/xmp/extension/\0";
725$psAPP13hdr = "Photoshop 3.0\0";
726$psAPP13old = 'Adobe_Photoshop2.5:';
727
728sub DummyWriteProc { return 1; }
729
730# lookup for user lenses defined in @Image::ExifTool::UserDefined::Lenses
731%Image::ExifTool::userLens = ( );
732
733# queued plug-in tags to add to lookup
734@Image::ExifTool::pluginTags = ( );
735%Image::ExifTool::pluginTags = ( );
736
737# tag information for preview image -- this should be used for all
738# PreviewImage tags so they are handled properly when reading/writing
739%Image::ExifTool::previewImageTagInfo = (
740 Name => 'PreviewImage',
741 Writable => 'undef',
742 # a value of 'none' is ok...
743 WriteCheck => '$val eq "none" ? undef : $self->CheckImage(\$val)',
744 DataTag => 'PreviewImage',
745 # accept either scalar or scalar reference
746 RawConv => '$self->ValidateImage(ref $val ? $val : \$val, $tag)',
747 # we allow preview image to be set to '', but we don't want a zero-length value
748 # in the IFD, so set it temorarily to 'none'. Note that the length is <= 4,
749 # so this value will fit in the IFD so the preview fixup won't be generated.
750 ValueConvInv => '$val eq "" and $val="none"; $val',
751);
752
753# extra tags that aren't truly EXIF tags, but are generated by the script
754# Note: any tag in this list with a name corresponding to a Group0 name is
755# used to write the entire corresponding directory as a block.
756%Image::ExifTool::Extra = (
757 GROUPS => { 0 => 'File', 1 => 'File', 2 => 'Image' },
758 VARS => { NO_ID => 1 }, # tag ID's aren't meaningful for these tags
759 WRITE_PROC => \&DummyWriteProc,
760 Error => { Priority => 0, Groups => \%allGroupsExifTool },
761 Warning => { Priority => 0, Groups => \%allGroupsExifTool },
762 Comment => {
763 Notes => 'comment embedded in JPEG, GIF89a or PPM/PGM/PBM image',
764 Writable => 1,
765 WriteGroup => 'Comment',
766 Priority => 0, # to preserve order of JPEG COM segments
767 },
768 Directory => {
769 Groups => { 1 => 'System' },
770 Writable => 1,
771 Protected => 1,
772 # translate backslashes in directory names and add trailing '/'
773 ValueConvInv => '$_=$val; tr/\\\\/\//; m{[^/]$} and $_ .= "/"; $_',
774 },
775 FileName => {
776 Groups => { 1 => 'System' },
777 Writable => 1,
778 Protected => 1,
779 Notes => q{
780 may be written with a full path name to set FileName and Directory in one
781 operation. See L<filename.html|../filename.html> for more information on
782 writing the FileName and Directory tags
783 },
784 ValueConvInv => '$val=~tr/\\\\/\//; $val',
785 },
786 FileSize => {
787 Groups => { 1 => 'System' },
788 PrintConv => \&ConvertFileSize,
789 },
790 ResourceForkSize => {
791 Groups => { 1 => 'System' },
792 Notes => q{
793 [Mac OS only] size of the file's resource fork if it contains data. If this
794 tag is generated the ExtractEmbedded option may be used to extract
795 resource-fork information as a sub-document
796 },
797 PrintConv => \&ConvertFileSize,
798 },
799 FileType => { },
800 FileModifyDate => {
801 Description => 'File Modification Date/Time',
802 Notes => 'the filesystem modification time',
803 Groups => { 1 => 'System', 2 => 'Time' },
804 Writable => 1,
805 # all pseudo-tags must be protected so -tagsfromfile fails with
806 # unrecognized files unless a pseudo tag is specified explicitly
807 Protected => 1,
808 Shift => 'Time',
809 ValueConv => 'ConvertUnixTime($val,1)',
810 ValueConvInv => 'GetUnixTime($val,1)',
811 PrintConv => '$self->ConvertDateTime($val)',
812 PrintConvInv => '$self->InverseDateTime($val)',
813 },
814 FilePermissions => {
815 Groups => { 1 => 'System' },
816 Notes => q{
817 r=read, w=write and x=execute permissions for the file owner, group and
818 others. The ValueConv value is an octal number so bit test operations on
819 this value should be done in octal, ie. "oct($filePermissions) & 0200"
820 },
821 ValueConv => 'sprintf("%.3o", $val & 0777)',
822 PrintConv => sub {
823 my ($mask, $str, $val) = (0400, '', oct(shift));
824 while ($mask) {
825 foreach (qw(r w x)) {
826 $str .= $val & $mask ? $_ : '-';
827 $mask >>= 1;
828 }
829 }
830 return $str;
831 },
832 },
833 MIMEType => { },
834 ImageWidth => { },
835 ImageHeight => { },
836 XResolution => { },
837 YResolution => { },
838 MaxVal => { }, # max pixel value in PPM or PGM image
839 EXIF => {
840 Notes => 'the full EXIF data block from JPEG, PNG, JP2, MIE and MIFF images',
841 Groups => { 0 => 'EXIF', 1 => 'EXIF' },
842 Flags => ['Writable' ,'Protected', 'Binary'],
843 WriteCheck => q{
844 return undef if $val =~ /^(II\x2a\0|MM\0\x2a)/;
845 return 'Invalid EXIF data';
846 },
847 },
848 ICC_Profile => {
849 Notes => 'the full ICC_Profile data block',
850 Groups => { 0 => 'ICC_Profile', 1 => 'ICC_Profile' },
851 Flags => ['Writable' ,'Protected', 'Binary'],
852 WriteCheck => q{
853 require Image::ExifTool::ICC_Profile;
854 return Image::ExifTool::ICC_Profile::ValidateICC(\$val);
855 },
856 },
857 XMP => {
858 Notes => 'the full XMP data block',
859 Groups => { 0 => 'XMP', 1 => 'XMP' },
860 Flags => ['Writable', 'Protected', 'Binary'],
861 Priority => 0, # so main xmp (which usually comes first) takes priority
862 WriteCheck => q{
863 require Image::ExifTool::XMP;
864 return Image::ExifTool::XMP::CheckXMP($self, $tagInfo, \$val);
865 },
866 },
867 CanonVRD => {
868 Notes => 'the full Canon DPP VRD trailer block',
869 Groups => { 0 => 'CanonVRD', 1 => 'CanonVRD' },
870 Flags => ['Writable' ,'Protected', 'Binary'],
871 Permanent => 0, # (this is 1 by default for MakerNotes tags)
872 WriteCheck => q{
873 return undef if $val =~ /^CANON OPTIONAL DATA\0/;
874 return 'Invalid CanonVRD data';
875 },
876 },
877 CurrentIPTCDigest => {
878 Notes => q{
879 MD5 digest of existing IPTC data. All zeros if IPTC exists but Digest::MD5
880 is not installed. Only calculated for IPTC in the standard location as
881 specified by the L<MWG|http://www.metadataworkinggroup.org/>. ExifTool
882 automates the handling of this tag in the MWG module -- see the
883 L<MWG Tag Name documentation|MWG.html> for details
884 },
885 ValueConv => 'unpack("H*", $val)',
886 },
887 PreviewImage => {
888 Writable => 1,
889 WriteCheck => '$self->CheckImage(\$val)',
890 # can't delete, so set to empty string and return no error
891 DelCheck => '$val = ""; return undef',
892 # accept either scalar or scalar reference
893 RawConv => '$self->ValidateImage(ref $val ? $val : \$val, $tag)',
894 },
895 PreviewPNG => { Binary => 1 },
896 ExifByteOrder => {
897 Writable => 1,
898 Notes => 'only writable for newly created EXIF segments',
899 PrintConv => {
900 II => 'Little-endian (Intel, II)',
901 MM => 'Big-endian (Motorola, MM)',
902 },
903 },
904 ExifUnicodeByteOrder => {
905 Writable => 1,
906 Notes => q{
907 the EXIF specification is particularly vague about the byte ordering for
908 Unicode text, and different applications use different conventions. By
909 default ExifTool writes Unicode text in EXIF byte order, but this write-only
910 tag may be used to force a specific byte order
911 },
912 PrintConv => {
913 II => 'Little-endian (Intel, II)',
914 MM => 'Big-endian (Motorola, MM)',
915 },
916 },
917 ExifToolVersion => {
918 Description => 'ExifTool Version Number',
919 Groups => \%allGroupsExifTool,
920 },
921 RAFVersion => { },
922 JPEGDigest => {
923 Notes => q{
924 an MD5 digest of the JPEG quantization tables is combined with the component
925 sub-sampling values to generate the value of this tag. The result is
926 compared to known values in an attempt to deduce the originating software
927 based only on the JPEG image data. For performance reasons, this tag is
928 generated only if specifically requested
929 },
930 },
931 Now => {
932 Groups => { 0 => 'ExifTool', 1 => 'ExifTool', 2 => 'Time' },
933 Notes => q{
934 the current date/time. Useful when setting the tag values, ie.
935 C<"-modifydate<now">. Not generated unless specifically requested
936 },
937 ValueConv => sub {
938 my $time = shift;
939 my @tm = localtime $time;
940 my $tz = Image::ExifTool::TimeZoneString(\@tm, $time);
941 sprintf("%4d:%.2d:%.2d %.2d:%.2d:%.2d%s", $tm[5]+1900, $tm[4]+1, $tm[3],
942 $tm[2], $tm[1], $tm[0], $tz);
943 },
944 PrintConv => '$self->ConvertDateTime($val)',
945 },
946 ID3Size => { },
947 Geotag => {
948 Writable => 1,
949 AllowGroup => '(exif|gps|xmp|xmp-exif)',
950 Notes => q{
951 this write-only tag is used to define the GPS track log data or track log
952 file name. Currently supported track log formats are GPX, NMEA RMC/GGA/GLL,
953 KML, IGC, Garmin XML and TCX, and Magellan PMGNTRK. See
954 L<geotag.html|../geotag.html> for details
955 },
956 DelCheck => q{
957 require Image::ExifTool::Geotag;
958 # delete associated tags
959 Image::ExifTool::Geotag::SetGeoValues($self, undef, $wantGroup);
960 },
961 ValueConvInv => q{
962 require Image::ExifTool::Geotag;
963 # always warn because this tag is never set (warning is "\n" on success)
964 my $result = Image::ExifTool::Geotag::LoadTrackLog($self, $val);
965 return '' if not defined $result; # deleting geo tags
966 return $result if ref $result; # geotag data hash reference
967 warn "$result\n"; # error string
968 },
969 },
970 Geotime => {
971 Writable => 1,
972 AllowGroup => '(exif|gps|xmp|xmp-exif)',
973 Notes => q{
974 this write-only tag is used to define a date/time for interpolating a
975 position in the GPS track specified by the Geotag tag. Writing this tag
976 causes the following 8 tags to be written: GPSLatitude, GPSLatitudeRef,
977 GPSLongitude, GPSLongitudeRef, GPSAltitude, GPSAltitudeRef, GPSDateStamp and
978 GPSTimeStamp. The local system timezone is assumed if the date/time value
979 does not contain a timezone. May be deleted to delete associated GPS tags.
980 A group name of 'EXIF' or 'XMP' may be specified to write or delete only
981 EXIF or XMP GPS tags. The value of Geotag must be assigned before this tag
982 },
983 DelCheck => q{
984 require Image::ExifTool::Geotag;
985 # delete associated tags
986 Image::ExifTool::Geotag::SetGeoValues($self, undef, $wantGroup);
987 },
988 ValueConvInv => q{
989 require Image::ExifTool::Geotag;
990 warn Image::ExifTool::Geotag::SetGeoValues($self, $val, $wantGroup) . "\n";
991 return undef;
992 },
993 },
994 Geosync => {
995 Writable => 1,
996 AllowGroup => '(exif|gps|xmp|xmp-exif)',
997 Shift => 'Time', # enables "+=" syntax as well as "=+"
998 Notes => q{
999 this write-only tag specifies a time difference to add to Geotime for
1000 synchronization with the GPS clock. For example, set this to "-12" if the
1001 camera clock is 12 seconds faster than GPS time. Input format is
1002 "[+-][[[DD ]HH:]MM:]SS[.ss]". Must be set before Geotime to be effective.
1003 Additional features allow calculation of time differences and time drifts,
1004 and extraction of synchronization times from image files. See the
1005 L<geotagging documentation|../geotag.html> for details
1006 },
1007 ValueConvInv => q{
1008 require Image::ExifTool::Geotag;
1009 return Image::ExifTool::Geotag::ConvertGeosync($self, $val);
1010 },
1011 },
1012);
1013
1014# YCbCrSubSampling values (used by JPEG SOF, EXIF and XMP)
1015%Image::ExifTool::JPEG::yCbCrSubSampling = (
1016 '1 1' => 'YCbCr4:4:4 (1 1)', #PH
1017 '2 1' => 'YCbCr4:2:2 (2 1)', #14 in Exif.pm
1018 '2 2' => 'YCbCr4:2:0 (2 2)', #14 in Exif.pm
1019 '4 1' => 'YCbCr4:1:1 (4 1)', #14 in Exif.pm
1020 '4 2' => 'YCbCr4:1:0 (4 2)', #PH
1021 '1 2' => 'YCbCr4:4:0 (1 2)', #PH
1022 '1 4' => 'YCbCr4:4:1 (1 4)', #JD
1023 '2 4' => 'YCbCr4:2:1 (2 4)', #JD
1024);
1025
1026# define common JPEG segments here to avoid overhead of loading JPEG module
1027
1028# JPEG SOF (start of frame) tags
1029# (ref http://www.w3.org/Graphics/JPEG/itu-t81.pdf)
1030%Image::ExifTool::JPEG::SOF = (
1031 GROUPS => { 0 => 'File', 1 => 'File', 2 => 'Image' },
1032 NOTES => 'This information is extracted from the JPEG Start Of Frame segment.',
1033 VARS => { NO_ID => 1 }, # tag ID's aren't meaningful for these tags
1034 EncodingProcess => {
1035 PrintHex => 1,
1036 PrintConv => {
1037 0x0 => 'Baseline DCT, Huffman coding',
1038 0x1 => 'Extended sequential DCT, Huffman coding',
1039 0x2 => 'Progressive DCT, Huffman coding',
1040 0x3 => 'Lossless, Huffman coding',
1041 0x5 => 'Sequential DCT, differential Huffman coding',
1042 0x6 => 'Progressive DCT, differential Huffman coding',
1043 0x7 => 'Lossless, Differential Huffman coding',
1044 0x9 => 'Extended sequential DCT, arithmetic coding',
1045 0xa => 'Progressive DCT, arithmetic coding',
1046 0xb => 'Lossless, arithmetic coding',
1047 0xd => 'Sequential DCT, differential arithmetic coding',
1048 0xe => 'Progressive DCT, differential arithmetic coding',
1049 0xf => 'Lossless, differential arithmetic coding',
1050 }
1051 },
1052 BitsPerSample => { },
1053 ImageHeight => { },
1054 ImageWidth => { },
1055 ColorComponents => { },
1056 YCbCrSubSampling => {
1057 Notes => 'calculated from components table',
1058 PrintConv => \%Image::ExifTool::JPEG::yCbCrSubSampling,
1059 },
1060);
1061
1062# JPEG JFIF APP0 definitions
1063%Image::ExifTool::JFIF::Main = (
1064 PROCESS_PROC => \&Image::ExifTool::ProcessBinaryData,
1065 WRITE_PROC => \&Image::ExifTool::WriteBinaryData,
1066 CHECK_PROC => \&Image::ExifTool::CheckBinaryData,
1067 GROUPS => { 0 => 'JFIF', 1 => 'JFIF', 2 => 'Image' },
1068 DATAMEMBER => [ 2, 3, 5 ],
1069 0 => {
1070 Name => 'JFIFVersion',
1071 Format => 'int8u[2]',
1072 PrintConv => 'sprintf("%d.%.2d", split(" ",$val))',
1073 },
1074 2 => {
1075 Name => 'ResolutionUnit',
1076 Writable => 1,
1077 RawConv => '$$self{JFIFResolutionUnit} = $val',
1078 PrintConv => {
1079 0 => 'None',
1080 1 => 'inches',
1081 2 => 'cm',
1082 },
1083 Priority => -1,
1084 },
1085 3 => {
1086 Name => 'XResolution',
1087 Format => 'int16u',
1088 Writable => 1,
1089 Priority => -1,
1090 RawConv => '$$self{JFIFXResolution} = $val',
1091 },
1092 5 => {
1093 Name => 'YResolution',
1094 Format => 'int16u',
1095 Writable => 1,
1096 Priority => -1,
1097 RawConv => '$$self{JFIFYResolution} = $val',
1098 },
1099);
1100%Image::ExifTool::JFIF::Extension = (
1101 GROUPS => { 0 => 'JFIF', 1 => 'JFIF', 2 => 'Image' },
1102 0x10 => {
1103 Name => 'ThumbnailImage',
1104 RawConv => '$self->ValidateImage(\$val,$tag)',
1105 },
1106);
1107
1108# Composite tags (accumulation of all Composite tag tables)
1109%Image::ExifTool::Composite = (
1110 GROUPS => { 0 => 'Composite', 1 => 'Composite' },
1111 TABLE_NAME => 'Image::ExifTool::Composite',
1112 SHORT_NAME => 'Composite',
1113 VARS => { NO_ID => 1 }, # want empty tagID's for Composite tags
1114 WRITE_PROC => \&DummyWriteProc,
1115);
1116
1117# static private ExifTool variables
1118
1119%allTables = ( ); # list of all tables loaded (except Composite tags)
1120@tableOrder = ( ); # order the tables were loaded
1121
1122#------------------------------------------------------------------------------
1123# Warning handler routines (warning string stored in $evalWarning)
1124#
1125# Set warning message
1126# Inputs: 0) warning string (undef to reset warning)
1127sub SetWarning($) { $evalWarning = $_[0]; }
1128
1129# Get warning message
1130sub GetWarning() { return $evalWarning; }
1131
1132# Clean unnecessary information (line number, LF) from warning
1133# Inputs: 0) warning string or undef to use current warning
1134# Returns: cleaned warning
1135sub CleanWarning(;$)
1136{
1137 my $str = shift;
1138 unless (defined $str) {
1139 return undef unless defined $evalWarning;
1140 $str = $evalWarning;
1141 }
1142 $str = $1 if $str =~ /(.*) at /s;
1143 $str =~ s/\s+$//s;
1144 return $str;
1145}
1146
1147#==============================================================================
1148# New - create new ExifTool object
1149# Inputs: 0) reference to exiftool object or ExifTool class name
1150# Returns: blessed ExifTool object ref
1151sub new
1152{
1153 local $_;
1154 my $that = shift;
1155 my $class = ref($that) || $that || 'Image::ExifTool';
1156 my $self = bless {}, $class;
1157
1158 # make sure our main Exif tag table has been loaded
1159 GetTagTable("Image::ExifTool::Exif::Main");
1160
1161 $self->ClearOptions(); # create default options hash
1162 $self->{VALUE} = { }; # must initialize this for warning messages
1163 $self->{DEL_GROUP} = { }; # lookup for groups to delete when writing
1164
1165 # initialize our new groups for writing
1166 $self->SetNewGroups(@defaultWriteGroups);
1167
1168 return $self;
1169}
1170
1171#------------------------------------------------------------------------------
1172# ImageInfo - return specified information from image file
1173# Inputs: 0) [optional] ExifTool object reference
1174# 1) filename, file reference, or scalar data reference
1175# 2-N) list of tag names to find (or tag list reference or options reference)
1176# Returns: reference to hash of tag/value pairs (with "Error" entry on error)
1177# Notes:
1178# - if no tags names are specified, the values of all tags are returned
1179# - tags may be specified with leading '-' to exclude, or trailing '#' for ValueConv
1180# - can pass a reference to list of tags to find, in which case the list will
1181# be updated with the tags found in the proper case and in the specified order.
1182# - can pass reference to hash specifying options
1183# - returned tag values may be scalar references indicating binary data
1184# - see ClearOptions() below for a list of options and their default values
1185# Examples:
1186# use Image::ExifTool 'ImageInfo';
1187# my $info = ImageInfo($file, 'DateTimeOriginal', 'ImageSize');
1188# - or -
1189# my $exifTool = new Image::ExifTool;
1190# my $info = $exifTool->ImageInfo($file, \@tagList, {Sort=>'Group0'} );
1191sub ImageInfo($;@)
1192{
1193 local $_;
1194 # get our ExifTool object ($self) or create one if necessary
1195 my $self;
1196 if (ref $_[0] and UNIVERSAL::isa($_[0],'Image::ExifTool')) {
1197 $self = shift;
1198 } else {
1199 $self = new Image::ExifTool;
1200 }
1201 my %saveOptions = %{$self->{OPTIONS}}; # save original options
1202
1203 # initialize file information
1204 $self->{FILENAME} = $self->{RAF} = undef;
1205
1206 $self->ParseArguments(@_); # parse our function arguments
1207 $self->ExtractInfo(undef); # extract meta information from image
1208 my $info = $self->GetInfo(undef); # get requested information
1209
1210 $self->{OPTIONS} = \%saveOptions; # restore original options
1211
1212 return $info; # return requested information
1213}
1214
1215#------------------------------------------------------------------------------
1216# Get/set ExifTool options
1217# Inputs: 0) ExifTool object reference,
1218# 1) Parameter name, 2) Value to set the option
1219# 3-N) More parameter/value pairs
1220# Returns: original value of last option specified
1221sub Options($$;@)
1222{
1223 local $_;
1224 my $self = shift;
1225 my $options = $$self{OPTIONS};
1226 my $oldVal;
1227
1228 while (@_) {
1229 my $param = shift;
1230 $oldVal = $$options{$param};
1231 last unless @_;
1232 my $newVal = shift;
1233 if ($param eq 'Lang') {
1234 # allow this to be set to undef to select the default language
1235 $newVal = $defaultLang unless defined $newVal;
1236 if ($newVal eq $defaultLang) {
1237 $$options{$param} = $newVal;
1238 delete $$self{CUR_LANG};
1239 # make sure the language is available
1240 } elsif (eval "require Image::ExifTool::Lang::$newVal") {
1241 my $xlat = "Image::ExifTool::Lang::${newVal}::Translate";
1242 no strict 'refs';
1243 if (%$xlat) {
1244 $$self{CUR_LANG} = \%$xlat;
1245 $$options{$param} = $newVal;
1246 }
1247 } # else don't change Lang
1248 } elsif ($param eq 'Exclude' and defined $newVal) {
1249 # clone Exclude list and expand shortcuts
1250 my @exclude;
1251 if (ref $newVal eq 'ARRAY') {
1252 @exclude = @$newVal;
1253 } else {
1254 @exclude = ($newVal);
1255 }
1256 ExpandShortcuts(\@exclude, 1); # (also remove '#' suffix)
1257 $$options{$param} = \@exclude;
1258 } elsif ($param =~ /^Charset/ or $param eq 'IPTCCharset') {
1259 # only allow valid character sets to be set
1260 if ($newVal) {
1261 my $charset = $charsetName{lc $newVal};
1262 if ($charset) {
1263 $$options{$param} = $charset;
1264 # maintain backward-compatibility with old IPTCCharset option
1265 $$options{CharsetIPTC} = $charset if $param eq 'IPTCCharset';
1266 } else {
1267 warn "Invalid Charset $newVal\n";
1268 }
1269 }
1270 } else {
1271 if ($param eq 'Escape') {
1272 # set ESCAPE_PROC
1273 if (defined $newVal and $newVal eq 'XML') {
1274 require Image::ExifTool::XMP;
1275 $$self{ESCAPE_PROC} = \&Image::ExifTool::XMP::EscapeXML;
1276 } elsif (defined $newVal and $newVal eq 'HTML') {
1277 require Image::ExifTool::HTML;
1278 $$self{ESCAPE_PROC} = \&Image::ExifTool::HTML::EscapeHTML;
1279 } else {
1280 delete $$self{ESCAPE_PROC};
1281 }
1282 # must forget saved values since they depend on Escape method
1283 $self->{BOTH} = { };
1284 }
1285 $$options{$param} = $newVal;
1286 }
1287 }
1288 return $oldVal;
1289}
1290
1291#------------------------------------------------------------------------------
1292# ClearOptions - set options to default values
1293# Inputs: 0) ExifTool object reference
1294sub ClearOptions($)
1295{
1296 local $_;
1297 my $self = shift;
1298
1299 # create options hash with default values
1300 # (commented out options don't need initializing)
1301 # +-----------------------------------------------------+
1302 # ! DON'T FORGET!! When adding any new option, must !
1303 # ! decide how it is handled in SetNewValuesFromFile() !
1304 # +-----------------------------------------------------+
1305 $self->{OPTIONS} = {
1306 # Binary => undef, # flag to extract binary values even if tag not specified
1307 # ByteOrder => undef, # default byte order when creating EXIF information
1308 Charset => 'UTF8', # character set for converting Unicode characters
1309 CharsetID3 => 'Latin', # internal ID3v1 character set
1310 CharsetIPTC => 'Latin', # fallback IPTC character set if no CodedCharacterSet
1311 # Compact => undef, # compact XMP and IPTC data
1312 Composite => 1, # flag to calculate Composite tags
1313 # Compress => undef, # flag to write new values as compressed if possible
1314 # CoordFormat => undef, # GPS lat/long coordinate format
1315 # DateFormat => undef, # format for date/time
1316 Duplicates => 1, # flag to save duplicate tag values
1317 # Escape => undef, # escape special characters
1318 # Exclude => undef, # tags to exclude
1319 # ExtractEmbedded =>undef,# flag to extract information from embedded documents
1320 # FastScan => undef, # flag to avoid scanning for trailer
1321 # FixBase => undef, # fix maker notes base offsets
1322 # GeoMaxIntSecs => undef, # geotag maximum interpolation time (secs)
1323 # GeoMaxExtSecs => undef, # geotag maximum extrapolation time (secs)
1324 # GeoMaxHDOP => undef, # geotag maximum HDOP
1325 # GeoMaxPDOP => undef, # geotag maximum PDOP
1326 # GeoMinSats => undef, # geotag minimum satellites
1327 # Group# => undef, # return tags for specified groups in family #
1328 HtmlDump => 0, # HTML dump (0-3, higher # = bigger limit)
1329 # HtmlDumpBase => undef, # base address for HTML dump
1330 # IgnoreMinorErrors => undef, # ignore minor errors when reading/writing
1331 Lang => $defaultLang,# localized language for descriptions etc
1332 # LargeFileSupport => undef, # flag indicating support of 64-bit file offsets
1333 # List => undef, # extract lists of PrintConv values into arrays
1334 ListSep => ', ', # list item separator
1335 # ListSplit => undef, # regex for splitting list-type tag values when writing
1336 # MakerNotes => undef, # extract maker notes as a block
1337 # MissingTagValue =>undef,# value for missing tags when expanded in expressions
1338 # Password => undef, # password for password-protected PDF documents
1339 PrintConv => 1, # flag to enable print conversion
1340 # SavePath => undef, # (undocumented) save family 5 location path
1341 # ScanForXMP => undef, # flag to scan for XMP information in all files
1342 Sort => 'Input', # order to sort found tags (Input, File, Alpha, Group#)
1343 # StrictDate => undef, # flag to return undef for invalid date conversions
1344 # Struct => undef, # return structures as hash references
1345 TextOut => \*STDOUT,# file for Verbose/HtmlDump output
1346 Unknown => 0, # flag to get values of unknown tags (0-2)
1347 Verbose => 0, # print verbose messages (0-5, higher # = more verbose)
1348 };
1349 # keep necessary member variables in sync with options
1350 delete $$self{CUR_LANG};
1351 delete $$self{ESCAPE_PROC};
1352
1353 # load user-defined default options
1354 if (%Image::ExifTool::UserDefined::Options) {
1355 foreach (keys %Image::ExifTool::UserDefined::Options) {
1356 $self->Options($_, $Image::ExifTool::UserDefined::Options{$_});
1357 }
1358 }
1359}
1360
1361#------------------------------------------------------------------------------
1362# Extract meta information from image
1363# Inputs: 0) ExifTool object reference
1364# 1-N) Same as ImageInfo()
1365# Returns: 1 if this was a valid image, 0 otherwise
1366# Notes: pass an undefined value to avoid parsing arguments
1367# Internal 'ReEntry' option allows this routine to be called recursively
1368sub ExtractInfo($;@)
1369{
1370 local $_;
1371 my $self = shift;
1372 my $options = $self->{OPTIONS}; # pointer to current options
1373 my (%saveOptions, $reEntry, $rsize);
1374
1375 # check for internal ReEntry option to allow recursive calls to ExtractInfo
1376 if (ref $_[1] eq 'HASH' and $_[1]{ReEntry} and
1377 (ref $_[0] eq 'SCALAR' or ref $_[0] eq 'GLOB'))
1378 {
1379 # save necessary members for restoring later
1380 $reEntry = {
1381 RAF => $$self{RAF},
1382 PROCESSED => $$self{PROCESSED},
1383 EXIF_DATA => $$self{EXIF_DATA},
1384 EXIF_POS => $$self{EXIF_POS},
1385 FILE_TYPE => $$self{FILE_TYPE},
1386 };
1387 $self->{RAF} = new File::RandomAccess($_[0]);
1388 $$self{PROCESSED} = { };
1389 delete $$self{EXIF_DATA};
1390 delete $$self{EXIF_POS};
1391 } else {
1392 if (defined $_[0] or $options->{HtmlDump}) {
1393 %saveOptions = %$options; # save original options
1394
1395 # require duplicates for html dump
1396 $self->Options(Duplicates => 1) if $options->{HtmlDump};
1397
1398 if (defined $_[0]) {
1399 # only initialize filename if called with arguments
1400 $self->{FILENAME} = undef; # name of file (or '' if we didn't open it)
1401 $self->{RAF} = undef; # RandomAccess object reference
1402
1403 $self->ParseArguments(@_); # initialize from our arguments
1404 }
1405 }
1406 # initialize ExifTool object members
1407 $self->Init();
1408
1409 delete $self->{MAKER_NOTE_FIXUP}; # fixup information for extracted maker notes
1410 delete $self->{MAKER_NOTE_BYTE_ORDER};
1411
1412 # return our version number
1413 $self->FoundTag('ExifToolVersion', "$VERSION$RELEASE");
1414 $self->FoundTag('Now', time()) if $self->{REQ_TAG_LOOKUP}{now} or $self->{TAGS_FROM_FILE};
1415 }
1416 my $filename = $self->{FILENAME}; # image file name ('' if already open)
1417 my $raf = $self->{RAF}; # RandomAccess object
1418
1419 local *EXIFTOOL_FILE; # avoid clashes with global namespace
1420
1421 my $realname = $filename;
1422 unless ($raf) {
1423 # save file name
1424 if (defined $filename and $filename ne '') {
1425 unless ($filename eq '-') {
1426 # extract file name from pipe if necessary
1427 $realname =~ /\|$/ and $realname =~ s/.*?"(.*?)".*/$1/;
1428 my ($dir, $name);
1429 if (eval 'require File::Basename') {
1430 $dir = File::Basename::dirname($realname);
1431 $name = File::Basename::basename($realname);
1432 } else {
1433 ($name = $realname) =~ tr/\\/\//;
1434 # remove path
1435 $dir = length($1) ? $1 : '/' if $name =~ s/(.*)\///;
1436 }
1437 $self->FoundTag('FileName', $name);
1438 $self->FoundTag('Directory', $dir) if defined $dir and length $dir;
1439 # get size of resource fork on Mac OS
1440 $rsize = -s "$filename/rsrc" if $^O eq 'darwin' and not $$self{IN_RESOURCE};
1441 }
1442 # open the file
1443 if (open(EXIFTOOL_FILE, $filename)) {
1444 # create random access file object
1445 $raf = new File::RandomAccess(\*EXIFTOOL_FILE);
1446 # patch to force pipe to be buffered because seek returns success
1447 # in Windows cmd shell pipe even though it really failed
1448 $raf->{TESTED} = -1 if $filename eq '-' or $filename =~ /\|$/;
1449 $self->{RAF} = $raf;
1450 } else {
1451 $self->Error('Error opening file');
1452 }
1453 } else {
1454 $self->Error('No file specified');
1455 }
1456 }
1457
1458 if ($raf) {
1459 if ($reEntry) {
1460 # we already set these tags
1461 } elsif (not $raf->{FILE_PT}) {
1462 # get file size from image in memory
1463 $self->FoundTag('FileSize', length ${$raf->{BUFF_PT}});
1464 } elsif (-f $raf->{FILE_PT}) {
1465 # get file size and last modified time if this is a plain file
1466 my $fileSize = -s _;
1467 my $fileTime = -M _;
1468 my @stat = stat _;
1469 $self->FoundTag('FileSize', $fileSize) if defined $fileSize;
1470 $self->FoundTag('ResourceForkSize', $rsize) if $rsize;
1471 $self->FoundTag('FileModifyDate', $^T - $fileTime*(24*3600)) if defined $fileTime;
1472 $self->FoundTag('FilePermissions', $stat[2]) if defined $stat[2];
1473 }
1474
1475 # get list of file types to check
1476 my ($tiffType, %noMagic);
1477 $self->{FILE_EXT} = GetFileExtension($realname);
1478 my @fileTypeList = GetFileType($realname);
1479 if (@fileTypeList) {
1480 # add remaining types to end of list so we test them all
1481 my $pat = join '|', @fileTypeList;
1482 push @fileTypeList, grep(!/^($pat)$/, @fileTypes);
1483 $tiffType = $self->{FILE_EXT};
1484 $noMagic{MXF} = 1; # don't do magic number test on MXF or DV files
1485 $noMagic{DV} = 1;
1486 } else {
1487 # scan through all recognized file types
1488 @fileTypeList = @fileTypes;
1489 $tiffType = 'TIFF';
1490 }
1491 push @fileTypeList, ''; # end of list marker
1492 # initialize the input file for seeking in binary data
1493 $raf->BinMode(); # set binary mode before we start reading
1494 my $pos = $raf->Tell(); # get file position so we can rewind
1495 my %dirInfo = ( RAF => $raf, Base => $pos );
1496 # loop through list of file types to test
1497 my ($type, $buff, $seekErr);
1498 # read first 1024 bytes of file for testing
1499 $raf->Read($buff, 1024) or $buff = '';
1500 $raf->Seek($pos, 0) or $seekErr = 1;
1501 until ($seekErr) {
1502 $type = shift @fileTypeList;
1503 if ($type) {
1504 # do quick test for this file type to avoid loading module unnecessarily
1505 next if $magicNumber{$type} and $buff !~ /^$magicNumber{$type}/s and
1506 not $noMagic{$type};
1507 } else {
1508 last unless defined $type;
1509 # last ditch effort to scan past unknown header for JPEG/TIFF
1510 next unless $buff =~ /(\xff\xd8\xff|MM\0\x2a|II\x2a\0)/g;
1511 $type = ($1 eq "\xff\xd8\xff") ? 'JPEG' : 'TIFF';
1512 my $skip = pos($buff) - length($1);
1513 $dirInfo{Base} = $pos + $skip;
1514 $raf->Seek($pos + $skip, 0) or $seekErr = 1, last;
1515 $self->Warn("Skipped unknown $skip byte header");
1516 }
1517 # save file type in member variable
1518 $self->{FILE_TYPE} = $self->{PATH}[0] = $type;
1519 $dirInfo{Parent} = ($type eq 'TIFF') ? $tiffType : $type;
1520 my $module = $moduleName{$type};
1521 $module = $type unless defined $module;
1522 my $func = "Process$type";
1523
1524 # load module if necessary
1525 if ($module) {
1526 require "Image/ExifTool/$module.pm";
1527 $func = "Image::ExifTool::${module}::$func";
1528 } elsif ($module eq '0') {
1529 $self->SetFileType();
1530 $self->Warn('Unsupported file type');
1531 last;
1532 }
1533 # process the file
1534 no strict 'refs';
1535 &$func($self, \%dirInfo) and last;
1536 use strict 'refs';
1537
1538 # seek back to try again from the same position in the file
1539 $raf->Seek($pos, 0) or $seekErr = 1, last;
1540 }
1541 if ($seekErr) {
1542 $self->Error('Error seeking in file');
1543 } elsif ($self->Options('ScanForXMP') and (not defined $type or
1544 (not $self->Options('FastScan') and not $$self{FoundXMP})))
1545 {
1546 # scan for XMP
1547 $raf->Seek($pos, 0);
1548 require Image::ExifTool::XMP;
1549 Image::ExifTool::XMP::ScanForXMP($self, $raf) and $type = '';
1550 }
1551 unless (defined $type) {
1552 # if we were given a single image with a known type there
1553 # must be a format error since we couldn't read it, otherwise
1554 # it is likely we don't support images of this type
1555 my $fileType = GetFileType($realname);
1556 my $err;
1557 if (not $fileType) {
1558 $err = 'Unknown file type';
1559 } elsif ($fileType eq 'RAW') {
1560 $err = 'Unsupported RAW file type';
1561 } else {
1562 $err = 'File format error';
1563 }
1564 $self->Error($err);
1565 }
1566 # extract binary EXIF data block only if requested
1567 if (defined $self->{EXIF_DATA} and length $$self{EXIF_DATA} > 16 and
1568 ($self->{REQ_TAG_LOOKUP}{exif} or $self->{OPTIONS}{Binary}))
1569 {
1570 $self->FoundTag('EXIF', $self->{EXIF_DATA});
1571 }
1572 unless ($reEntry) {
1573 $self->{PATH} = [ ]; # reset PATH
1574 # calculate Composite tags
1575 $self->BuildCompositeTags() if $options->{Composite};
1576 # do our HTML dump if requested
1577 if ($self->{HTML_DUMP}) {
1578 $raf->Seek(0, 2); # seek to end of file
1579 $self->{HTML_DUMP}->FinishTiffDump($self, $raf->Tell());
1580 my $pos = $options->{HtmlDumpBase};
1581 $pos = ($self->{FIRST_EXIF_POS} || 0) unless defined $pos;
1582 my $dataPt = defined $self->{EXIF_DATA} ? \$self->{EXIF_DATA} : undef;
1583 undef $dataPt if defined $self->{EXIF_POS} and $pos != $self->{EXIF_POS};
1584 my $success = $self->{HTML_DUMP}->Print($raf, $dataPt, $pos,
1585 $options->{TextOut}, $options->{HtmlDump},
1586 $self->{FILENAME} ? "HTML Dump ($self->{FILENAME})" : 'HTML Dump');
1587 $self->Warn("Error reading $self->{HTML_DUMP}{ERROR}") if $success < 0;
1588 }
1589 }
1590 if ($filename) {
1591 $raf->Close(); # close the file if we opened it
1592 # process the resource fork as an embedded file on Mac filesystems
1593 if ($rsize and $options->{ExtractEmbedded}) {
1594 local *RESOURCE_FILE;
1595 if (open(RESOURCE_FILE, "$filename/rsrc")) {
1596 $$self{DOC_NUM} = $$self{DOC_COUNT} + 1;
1597 $$self{IN_RESOURCE} = 1;
1598 $self->ExtractInfo(\*RESOURCE_FILE, { ReEntry => 1 });
1599 close RESOURCE_FILE;
1600 delete $$self{IN_RESOURCE};
1601 } else {
1602 $self->Warn('Error opening resource fork');
1603 }
1604 }
1605 }
1606 }
1607
1608 # restore original options
1609 %saveOptions and $self->{OPTIONS} = \%saveOptions;
1610
1611 if ($reEntry) {
1612 # restore necessary members when exiting re-entrant code
1613 $$self{$_} = $$reEntry{$_} foreach keys %$reEntry;
1614 }
1615
1616 return exists $self->{VALUE}{Error} ? 0 : 1;
1617}
1618
1619#------------------------------------------------------------------------------
1620# Get hash of extracted meta information
1621# Inputs: 0) ExifTool object reference
1622# 1-N) options hash reference, tag list reference or tag names
1623# Returns: Reference to information hash
1624# Notes: - pass an undefined value to avoid parsing arguments
1625# - If groups are specified, first groups take precedence if duplicate
1626# tags found but Duplicates option not set.
1627# - tag names may end in '#' to extract ValueConv value
1628sub GetInfo($;@)
1629{
1630 local $_;
1631 my $self = shift;
1632 my %saveOptions;
1633
1634 unless (@_ and not defined $_[0]) {
1635 %saveOptions = %{$self->{OPTIONS}}; # save original options
1636 # must set FILENAME so it isn't parsed from the arguments
1637 $self->{FILENAME} = '' unless defined $self->{FILENAME};
1638 $self->ParseArguments(@_);
1639 }
1640
1641 # get reference to list of tags for which we will return info
1642 my ($rtnTags, $byValue) = $self->SetFoundTags();
1643
1644 # build hash of tag information
1645 my (%info, %ignored);
1646 my $conv = $self->{OPTIONS}{PrintConv} ? 'PrintConv' : 'ValueConv';
1647 foreach (@$rtnTags) {
1648 my $val = $self->GetValue($_, $conv);
1649 defined $val or $ignored{$_} = 1, next;
1650 $info{$_} = $val;
1651 }
1652
1653 # override specified tags with ValueConv value if necessary
1654 if (@$byValue and $conv ne 'ValueConv') {
1655 # first determine the number of times each non-ValueConv value is used
1656 my %nonVal;
1657 $nonVal{$_} = ($nonVal{$_} || 0) + 1 foreach @$rtnTags;
1658 --$nonVal{$$rtnTags[$_]} foreach @$byValue;
1659 # loop through ValueConv tags, updating tag keys and returned values
1660 foreach (@$byValue) {
1661 my $tag = $$rtnTags[$_];
1662 my $val = $self->GetValue($tag, 'ValueConv');
1663 next unless defined $val;
1664 my $vtag = $tag;
1665 # generate a new tag key like "Tag #" or "Tag #(1)"
1666 $vtag =~ s/( |$)/ #/;
1667 unless (defined $self->{VALUE}->{$vtag}) {
1668 $self->{VALUE}{$vtag} = $self->{VALUE}{$tag};
1669 $self->{TAG_INFO}{$vtag} = $self->{TAG_INFO}{$tag};
1670 $self->{TAG_EXTRA}{$vtag} = $self->{TAG_EXTRA}{$tag};
1671 $self->{FILE_ORDER}{$vtag} = $self->{FILE_ORDER}{$tag};
1672 # remove existing PrintConv entry unless we are using it too
1673 delete $info{$tag} unless $nonVal{$tag};
1674 }
1675 $$rtnTags[$_] = $vtag; # store ValueConv value with new tag key
1676 $info{$vtag} = $val; # return ValueConv value
1677 }
1678 }
1679
1680 # remove ignored tags from the list
1681 my $reqTags = $self->{REQUESTED_TAGS} || [ ];
1682 if (%ignored and not @$reqTags) {
1683 my @goodTags;
1684 foreach (@$rtnTags) {
1685 push @goodTags, $_ unless $ignored{$_};
1686 }
1687 $rtnTags = $self->{FOUND_TAGS} = \@goodTags;
1688 }
1689
1690 # return sorted tag list if provided with a list reference
1691 if ($self->{IO_TAG_LIST}) {
1692 # use file order by default if no tags specified
1693 # (no such thing as 'Input' order in this case)
1694 my $sortOrder = $self->{OPTIONS}{Sort};
1695 unless (@$reqTags or ($sortOrder and $sortOrder ne 'Input')) {
1696 $sortOrder = 'File';
1697 }
1698 # return tags in specified sort order
1699 @{$self->{IO_TAG_LIST}} = $self->GetTagList($rtnTags, $sortOrder);
1700 }
1701
1702 # restore original options
1703 %saveOptions and $self->{OPTIONS} = \%saveOptions;
1704
1705 return \%info;
1706}
1707
1708#------------------------------------------------------------------------------
1709# Combine information from a list of info hashes
1710# Unless Duplicates is enabled, first entry found takes priority
1711# Inputs: 0) ExifTool object reference, 1-N) list of info hash references
1712# Returns: Combined information hash reference
1713sub CombineInfo($;@)
1714{
1715 local $_;
1716 my $self = shift;
1717 my (%combinedInfo, $info, $tag, %haveInfo);
1718
1719 if ($self->{OPTIONS}{Duplicates}) {
1720 while ($info = shift) {
1721 foreach $tag (keys %$info) {
1722 $combinedInfo{$tag} = $$info{$tag};
1723 }
1724 }
1725 } else {
1726 while ($info = shift) {
1727 foreach $tag (keys %$info) {
1728 my $tagName = GetTagName($tag);
1729 next if $haveInfo{$tagName};
1730 $haveInfo{$tagName} = 1;
1731 $combinedInfo{$tag} = $$info{$tag};
1732 }
1733 }
1734 }
1735 return \%combinedInfo;
1736}
1737
1738#------------------------------------------------------------------------------
1739# Inputs: 0) ExifTool object reference
1740# 1) [optional] reference to info hash or tag list ref (default is found tags)
1741# 2) [optional] sort order ('File', 'Input', ...)
1742# Returns: List of tags in specified order
1743sub GetTagList($;$$)
1744{
1745 local $_;
1746 my ($self, $info, $sortOrder) = @_;
1747
1748 my $foundTags;
1749 if (ref $info eq 'HASH') {
1750 my @tags = keys %$info;
1751 $foundTags = \@tags;
1752 } elsif (ref $info eq 'ARRAY') {
1753 $foundTags = $info;
1754 }
1755 my $fileOrder = $self->{FILE_ORDER};
1756
1757 if ($foundTags) {
1758 # make sure a FILE_ORDER entry exists for all tags
1759 # (note: already generated bogus entries for FOUND_TAGS case below)
1760 foreach (@$foundTags) {
1761 next if defined $$fileOrder{$_};
1762 $$fileOrder{$_} = 999;
1763 }
1764 } else {
1765 $sortOrder = $info if $info and not $sortOrder;
1766 $foundTags = $self->{FOUND_TAGS} || $self->SetFoundTags() or return undef;
1767 }
1768 $sortOrder or $sortOrder = $self->{OPTIONS}{Sort};
1769
1770 # return original list if no sort order specified
1771 return @$foundTags unless $sortOrder and $sortOrder ne 'Input';
1772
1773 if ($sortOrder eq 'Alpha') {
1774 return sort @$foundTags;
1775 } elsif ($sortOrder =~ /^Group(\d*(:\d+)*)/) {
1776 my $family = $1 || 0;
1777 # want to maintain a basic file order with the groups
1778 # ordered in the way they appear in the file
1779 my (%groupCount, %groupOrder);
1780 my $numGroups = 0;
1781 my $tag;
1782 foreach $tag (sort { $$fileOrder{$a} <=> $$fileOrder{$b} } @$foundTags) {
1783 my $group = $self->GetGroup($tag, $family);
1784 my $num = $groupCount{$group};
1785 $num or $num = $groupCount{$group} = ++$numGroups;
1786 $groupOrder{$tag} = $num;
1787 }
1788 return sort { $groupOrder{$a} <=> $groupOrder{$b} or
1789 $$fileOrder{$a} <=> $$fileOrder{$b} } @$foundTags;
1790 } else {
1791 return sort { $$fileOrder{$a} <=> $$fileOrder{$b} } @$foundTags;
1792 }
1793}
1794
1795#------------------------------------------------------------------------------
1796# Get list of found tags in specified sort order
1797# Inputs: 0) ExifTool object reference, 1) sort order ('File', 'Input', ...)
1798# Returns: List of tag keys in specified order
1799# Notes: If not specified, sort order is taken from OPTIONS
1800sub GetFoundTags($;$)
1801{
1802 local $_;
1803 my ($self, $sortOrder) = @_;
1804 my $foundTags = $self->{FOUND_TAGS} || $self->SetFoundTags() or return undef;
1805 return $self->GetTagList($foundTags, $sortOrder);
1806}
1807
1808#------------------------------------------------------------------------------
1809# Get list of requested tags
1810# Inputs: 0) ExifTool object reference
1811# Returns: List of requested tag keys
1812sub GetRequestedTags($)
1813{
1814 local $_;
1815 return @{$_[0]{REQUESTED_TAGS}};
1816}
1817
1818#------------------------------------------------------------------------------
1819# Get tag value
1820# Inputs: 0) ExifTool object reference
1821# 1) tag key (or flattened tagInfo for getting field values, not part of public API)
1822# 2) [optional] Value type: PrintConv, ValueConv, Both or Raw, the default
1823# is PrintConv or ValueConv, depending on the PrintConv option setting
1824# 3) raw field value (not part of public API)
1825# Returns: Scalar context: tag value or undefined
1826# List context: list of values or empty list
1827sub GetValue($$;$)
1828{
1829 local $_;
1830 my ($self, $tag, $type) = @_; # plus: ($fieldValue)
1831 my (@convTypes, $tagInfo, $valueConv, $both);
1832
1833 # figure out what conversions to do
1834 $type or $type = $self->{OPTIONS}{PrintConv} ? 'PrintConv' : 'ValueConv';
1835
1836 # start with the raw value
1837 my $value = $self->{VALUE}{$tag};
1838 if (not defined $value) {
1839 return wantarray ? () : undef unless ref $tag;
1840 # get the value of a structure field
1841 $tagInfo = $tag;
1842 $tag = $$tagInfo{Name};
1843 $value = $_[3];
1844 # (note: type "Both" is not allowed for structure fields)
1845 if ($type ne 'Raw') {
1846 push @convTypes, 'ValueConv';
1847 push @convTypes, 'PrintConv' unless $type eq 'ValueConv';
1848 }
1849 } else {
1850 $tagInfo = $self->{TAG_INFO}{$tag};
1851 if ($$tagInfo{Struct} and ref $value) {
1852 # must load XMPStruct.pl just in case (should already be loaded if
1853 # a structure was extracted, but we could also arrive here if a simple
1854 # list of values was stored incorrectly in a Struct tag)
1855 require 'Image/ExifTool/XMPStruct.pl';
1856 # convert strucure field values
1857 unless ($type eq 'Both') {
1858 # (note: ConvertStruct handles the escape too if necessary)
1859 return Image::ExifTool::XMP::ConvertStruct($self,$tagInfo,$value,$type);
1860 }
1861 $valueConv = Image::ExifTool::XMP::ConvertStruct($self,$tagInfo,$value,'ValueConv');
1862 $value = Image::ExifTool::XMP::ConvertStruct($self,$tagInfo,$value,'PrintConv');
1863 # (must not save these in $$self{BOTH} because the values may have been escaped)
1864 return ($valueConv, $value);
1865 }
1866 if ($type ne 'Raw') {
1867 # use values we calculated already if we stored them
1868 $both = $self->{BOTH}{$tag};
1869 if ($both) {
1870 if ($type eq 'PrintConv') {
1871 $value = $$both[1];
1872 } elsif ($type eq 'ValueConv') {
1873 $value = $$both[0];
1874 $value = $$both[1] unless defined $value;
1875 } else {
1876 ($valueConv, $value) = @$both;
1877 }
1878 } else {
1879 push @convTypes, 'ValueConv';
1880 push @convTypes, 'PrintConv' unless $type eq 'ValueConv';
1881 }
1882 }
1883 }
1884
1885 # do the conversions
1886 my (@val, @prt, @raw, $convType);
1887 foreach $convType (@convTypes) {
1888 # don't convert a scalar reference or structure
1889 last if ref $value eq 'SCALAR';
1890 my $conv = $$tagInfo{$convType};
1891 unless (defined $conv) {
1892 if ($convType eq 'ValueConv') {
1893 next unless $$tagInfo{Binary};
1894 $conv = '\$val'; # return scalar reference for binary values
1895 } else {
1896 # use PRINT_CONV from tag table if PrintConv doesn't exist
1897 next unless defined($conv = $tagInfo->{Table}{PRINT_CONV});
1898 next if exists $$tagInfo{$convType};
1899 }
1900 }
1901 # save old ValueConv value if we want Both
1902 $valueConv = $value if $type eq 'Both' and $convType eq 'PrintConv';
1903 my ($i, $val, $vals, @values, $convList);
1904 # split into list if conversion is an array
1905 if (ref $conv eq 'ARRAY') {
1906 $convList = $conv;
1907 $conv = $$convList[0];
1908 my @valList = split ' ', $value;
1909 # reorganize list if specified (Note: The writer currently doesn't
1910 # relist values, so they may be grouped but the order must not change)
1911 my $relist = $$tagInfo{Relist};
1912 if ($relist) {
1913 my (@newList, $oldIndex);
1914 foreach $oldIndex (@$relist) {
1915 my ($newVal, @join);
1916 if (ref $oldIndex) {
1917 foreach (@$oldIndex) {
1918 push @join, $valList[$_] if defined $valList[$_];
1919 }
1920 $newVal = join(' ', @join) if @join;
1921 } else {
1922 $newVal = $valList[$oldIndex];
1923 }
1924 push @newList, $newVal if defined $newVal;
1925 }
1926 $value = \@newList;
1927 } else {
1928 $value = \@valList;
1929 }
1930 }
1931 # initialize array so we can iterate over values in list
1932 if (ref $value eq 'ARRAY') {
1933 $i = 0;
1934 $vals = $value;
1935 $val = $$vals[0];
1936 } else {
1937 $val = $value;
1938 }
1939 # loop through all values in list
1940 for (;;) {
1941 if (defined $conv) {
1942 # get values of required tags if this is a Composite tag
1943 if (ref $val eq 'HASH' and not @val) {
1944 # disable escape of source values so we don't double escape them
1945 my $oldEscape = $$self{ESCAPE_PROC};
1946 delete $$self{ESCAPE_PROC};
1947 foreach (keys %$val) {
1948 $raw[$_] = $self->{VALUE}{$$val{$_}};
1949 ($val[$_], $prt[$_]) = $self->GetValue($$val{$_}, 'Both');
1950 next if defined $val[$_] or not $tagInfo->{Require}{$_};
1951 $$self{ESCAPE_PROC} = $oldEscape;
1952 return wantarray ? () : undef;
1953 }
1954 $$self{ESCAPE_PROC} = $oldEscape;
1955 # set $val to $val[0], or \@val for a CODE ref conversion
1956 $val = ref $conv eq 'CODE' ? \@val : $val[0];
1957 }
1958 if (ref $conv eq 'HASH') {
1959 # look up converted value in hash
1960 my $lc;
1961 if (defined($value = $$conv{$val})) {
1962 # override with our localized language PrintConv if available
1963 if ($$self{CUR_LANG} and $convType eq 'PrintConv' and
1964 # (no need to check for lang-alt tag names -- they won't have a PrintConv)
1965 ref($lc = $self->{CUR_LANG}{$$tagInfo{Name}}) eq 'HASH' and
1966 ($lc = $$lc{PrintConv}) and ($lc = $$lc{$value}))
1967 {
1968 $value = $self->Decode($lc, 'UTF8');
1969 }
1970 } else {
1971 if ($$conv{BITMASK}) {
1972 $value = DecodeBits($val, $$conv{BITMASK});
1973 # override with localized language strings
1974 if (defined $value and $$self{CUR_LANG} and $convType eq 'PrintConv' and
1975 ref($lc = $self->{CUR_LANG}{$$tagInfo{Name}}) eq 'HASH' and
1976 ($lc = $$lc{PrintConv}))
1977 {
1978 my @vals = split ', ', $value;
1979 foreach (@vals) {
1980 $_ = $$lc{$_} if defined $$lc{$_};
1981 }
1982 $value = join ', ', @vals;
1983 }
1984 } elsif (not $$conv{OTHER} or
1985 # use alternate conversion routine if available
1986 not defined($value = &{$$conv{OTHER}}($val, undef, $conv)))
1987 {
1988 if (($$tagInfo{PrintHex} or
1989 ($$tagInfo{Mask} and not defined $$tagInfo{PrintHex}))
1990 and $val and IsInt($val) and $convType eq 'PrintConv')
1991 {
1992 $val = sprintf('0x%x',$val);
1993 }
1994 $value = "Unknown ($val)";
1995 }
1996 }
1997 } else {
1998 # call subroutine or do eval to convert value
1999 local $SIG{'__WARN__'} = \&SetWarning;
2000 undef $evalWarning;
2001 if (ref $conv eq 'CODE') {
2002 $value = &$conv($val, $self);
2003 } else {
2004 #### eval ValueConv/PrintConv ($val, $self, @val, @prt, @raw)
2005 $value = eval $conv;
2006 $@ and $evalWarning = $@;
2007 }
2008 $self->Warn("$convType $tag: " . CleanWarning()) if $evalWarning;
2009 }
2010 } else {
2011 $value = $val;
2012 }
2013 last unless $vals;
2014 # save this converted value and step to next value in list
2015 push @values, $value if defined $value;
2016 if (++$i >= scalar(@$vals)) {
2017 $value = \@values if @values;
2018 last;
2019 }
2020 $val = $$vals[$i];
2021 $conv = $$convList[$i] if $convList;
2022 }
2023 # return undefined now if no value
2024 return wantarray ? () : undef unless defined $value;
2025 # join back into single value if split for conversion list
2026 if ($convList and ref $value eq 'ARRAY') {
2027 $value = join($convType eq 'PrintConv' ? '; ' : ' ', @$value);
2028 }
2029 }
2030 if ($type eq 'Both') {
2031 # save both (unescaped) values because we often need them again
2032 # (Composite tags need "Both" and often Require one tag for various Composite tags)
2033 $self->{BOTH}{$tag} = [ $valueConv, $value ] unless $both;
2034 # escape values if necessary
2035 if ($$self{ESCAPE_PROC}) {
2036 DoEscape($value, $$self{ESCAPE_PROC});
2037 if (defined $valueConv) {
2038 DoEscape($valueConv, $$self{ESCAPE_PROC});
2039 } else {
2040 $valueConv = $value;
2041 }
2042 } elsif (not defined $valueConv) {
2043 # $valueConv is undefined if there was no print conversion done
2044 $valueConv = $value;
2045 }
2046 # return Both values as a list (ValueConv, PrintConv)
2047 return ($valueConv, $value);
2048 }
2049 # escape value if necessary
2050 DoEscape($value, $$self{ESCAPE_PROC}) if $$self{ESCAPE_PROC};
2051
2052 if (ref $value eq 'ARRAY') {
2053 # return array if requested
2054 return @$value if wantarray;
2055 # return list reference for Raw, ValueConv or if List or not a list of scalars
2056 return $value if $type ne 'PrintConv' or $self->{OPTIONS}{List} or ref $$value[0];
2057 # otherwise join in comma-separated string
2058 $value = join $self->{OPTIONS}{ListSep}, @$value;
2059 }
2060 return $value;
2061}
2062
2063#------------------------------------------------------------------------------
2064# Get tag identification number
2065# Inputs: 0) ExifTool object reference, 1) tag key
2066# Returns: Scalar context: Tag ID if available, otherwise ''
2067# List context: 0) Tag ID (or ''), 1) language code (or undef)
2068sub GetTagID($$)
2069{
2070 my ($self, $tag) = @_;
2071 my $tagInfo = $self->{TAG_INFO}{$tag};
2072 return '' unless $tagInfo and defined $$tagInfo{TagID};
2073 return ($$tagInfo{TagID}, $$tagInfo{LangCode}) if wantarray;
2074 return $$tagInfo{TagID};
2075}
2076
2077#------------------------------------------------------------------------------
2078# Get tag table name
2079# Inputs: 0) ExifTool object reference, 1) tag key
2080# Returns: Table name if available, otherwise ''
2081sub GetTableName($$)
2082{
2083 my ($self, $tag) = @_;
2084 my $tagInfo = $self->{TAG_INFO}{$tag} or return '';
2085 return $tagInfo->{Table}{SHORT_NAME};
2086}
2087
2088#------------------------------------------------------------------------------
2089# Get tag index number
2090# Inputs: 0) ExifTool object reference, 1) tag key
2091# Returns: Table index number, or undefined if this tag isn't indexed
2092sub GetTagIndex($$)
2093{
2094 my ($self, $tag) = @_;
2095 my $tagInfo = $self->{TAG_INFO}{$tag} or return undef;
2096 return $$tagInfo{Index};
2097}
2098
2099#------------------------------------------------------------------------------
2100# Get description for specified tag
2101# Inputs: 0) ExifTool object reference, 1) tag key
2102# Returns: Tag description
2103# Notes: Will always return a defined value, even if description isn't available
2104sub GetDescription($$)
2105{
2106 local $_;
2107 my ($self, $tag) = @_;
2108 my ($desc, $name);
2109 my $tagInfo = $self->{TAG_INFO}{$tag};
2110 # ($tagInfo won't be defined for missing tags extracted with -f)
2111 if ($tagInfo) {
2112 # use alternate language description if available
2113 while ($$self{CUR_LANG}) {
2114 $desc = $self->{CUR_LANG}{$$tagInfo{Name}};
2115 if ($desc) {
2116 # must look up Description if this tag also has a PrintConv
2117 $desc = $$desc{Description} or last if ref $desc;
2118 } else {
2119 # look up default language of lang-alt tag
2120 last unless $$tagInfo{LangCode} and
2121 ($name = $$tagInfo{Name}) =~ s/-$$tagInfo{LangCode}$// and
2122 $desc = $self->{CUR_LANG}{$name};
2123 $desc = $$desc{Description} or last if ref $desc;
2124 $desc .= " ($$tagInfo{LangCode})";
2125 }
2126 # escape description if necessary
2127 DoEscape($desc, $$self{ESCAPE_PROC}) if $$self{ESCAPE_PROC};
2128 # return description in proper Charset
2129 return $self->Decode($desc, 'UTF8');
2130 }
2131 $desc = $$tagInfo{Description};
2132 }
2133 # just make the tag more readable if description doesn't exist
2134 unless ($desc) {
2135 $desc = MakeDescription(GetTagName($tag));
2136 # save description in tag information
2137 $$tagInfo{Description} = $desc if $tagInfo;
2138 }
2139 return $desc;
2140}
2141
2142#------------------------------------------------------------------------------
2143# Get group name for specified tag
2144# Inputs: 0) ExifTool object reference
2145# 1) tag key (or reference to tagInfo hash, not part of the public API)
2146# 2) [optional] group family (-1 to get extended group list)
2147# Returns: Scalar context: Group name (for family 0 if not otherwise specified)
2148# Array context: Group name if family specified, otherwise list of
2149# group names for each family. Returns '' for undefined tag.
2150# Notes: Mutiple families may be specified with ':' in family argument (ie. '1:2')
2151sub GetGroup($$;$)
2152{
2153 local $_;
2154 my ($self, $tag, $family) = @_;
2155 my ($tagInfo, @groups, @families, $simplify, $byTagInfo);
2156 if (ref $tag eq 'HASH') {
2157 $tagInfo = $tag;
2158 $tag = $$tagInfo{Name};
2159 # set flag so we don't get extra information for an extracted tag
2160 $byTagInfo = 1;
2161 } else {
2162 $tagInfo = $self->{TAG_INFO}{$tag} or return '';
2163 }
2164 my $groups = $$tagInfo{Groups};
2165 # fill in default groups unless already done
2166 # (after this, Groups 0-2 in tagInfo are guaranteed to be defined)
2167 unless ($$tagInfo{GotGroups}) {
2168 my $tagTablePtr = $$tagInfo{Table};
2169 if ($tagTablePtr) {
2170 # construct our group list
2171 $groups or $groups = $$tagInfo{Groups} = { };
2172 # fill in default groups
2173 foreach (keys %{$$tagTablePtr{GROUPS}}) {
2174 $$groups{$_} or $$groups{$_} = $tagTablePtr->{GROUPS}{$_};
2175 }
2176 }
2177 # set flag indicating group list was built
2178 $$tagInfo{GotGroups} = 1;
2179 }
2180 if (defined $family and $family ne '-1') {
2181 if ($family =~ /[^\d]/) {
2182 @families = ($family =~ /\d+/g);
2183 return $$groups{0} unless @families;
2184 $simplify = 1 unless $family =~ /^:/;
2185 undef $family;
2186 foreach (0..2) { $groups[$_] = $$groups{$_}; }
2187 } else {
2188 return $$groups{$family} if $family == 0 or $family == 2;
2189 $groups[1] = $$groups{1};
2190 }
2191 } else {
2192 return $$groups{0} unless wantarray;
2193 foreach (0..2) { $groups[$_] = $$groups{$_}; }
2194 }
2195 $groups[3] = 'Main';
2196 $groups[4] = ($tag =~ /\((\d+)\)$/) ? "Copy$1" : '';
2197 # handle dynamic group names if necessary
2198 my $ex = $self->{TAG_EXTRA}{$tag};
2199 if ($ex and not $byTagInfo) {
2200 $groups[0] = $$ex{G0} if $$ex{G0};
2201 $groups[1] = $$ex{G1} =~ /^\+(.*)/ ? "$groups[1]$1" : $$ex{G1} if $$ex{G1};
2202 $groups[3] = 'Doc' . $$ex{G3} if $$ex{G3};
2203 $groups[5] = $$ex{G5} || $groups[1] if defined $$ex{G5};
2204 }
2205 if ($family) {
2206 return $groups[$family] || '' if $family > 0;
2207 # add additional matching group names to list
2208 # ie) for MIE-Doc, also add MIE1, MIE1-Doc, MIE-Doc1 and MIE1-Doc1
2209 # and for MIE2-Doc3, also add MIE2, MIE-Doc3, MIE2-Doc and MIE-Doc
2210 if ($groups[1] =~ /^MIE(\d*)-(.+?)(\d*)$/) {
2211 push @groups, 'MIE' . ($1 || '1');
2212 push @groups, 'MIE' . ($1 ? '' : '1') . "-$2$3";
2213 push @groups, "MIE$1-$2" . ($3 ? '' : '1');
2214 push @groups, 'MIE' . ($1 ? '' : '1') . "-$2" . ($3 ? '' : '1');
2215 }
2216 }
2217 if (@families) {
2218 my @grps;
2219 # create list of group names (without identical adjacent groups if simplifying)
2220 foreach (@families) {
2221 my $grp = $groups[$_] or next;
2222 push @grps, $grp unless $simplify and @grps and $grp eq $grps[-1];
2223 }
2224 # remove leading "Main:" if simplifying
2225 shift @grps if $simplify and @grps > 1 and $grps[0] eq 'Main';
2226 # return colon-separated string of group names
2227 return join ':', @grps;
2228 }
2229 return @groups;
2230}
2231
2232#------------------------------------------------------------------------------
2233# Get group names for specified tags
2234# Inputs: 0) ExifTool object reference
2235# 1) [optional] information hash reference (default all extracted info)
2236# 2) [optional] group family (default 0)
2237# Returns: List of group names in alphabetical order
2238sub GetGroups($;$$)
2239{
2240 local $_;
2241 my $self = shift;
2242 my $info = shift;
2243 my $family;
2244
2245 # figure out our arguments
2246 if (ref $info ne 'HASH') {
2247 $family = $info;
2248 $info = $self->{VALUE};
2249 } else {
2250 $family = shift;
2251 }
2252 $family = 0 unless defined $family;
2253
2254 # get a list of all groups in specified information
2255 my ($tag, %groups);
2256 foreach $tag (keys %$info) {
2257 $groups{ $self->GetGroup($tag, $family) } = 1;
2258 }
2259 return sort keys %groups;
2260}
2261
2262#------------------------------------------------------------------------------
2263# Set priority for group where new values are written
2264# Inputs: 0) ExifTool object reference,
2265# 1-N) group names (reset to default if no groups specified)
2266sub SetNewGroups($;@)
2267{
2268 local $_;
2269 my ($self, @groups) = @_;
2270 @groups or @groups = @defaultWriteGroups;
2271 my $count = @groups;
2272 my %priority;
2273 foreach (@groups) {
2274 $priority{lc($_)} = $count--;
2275 }
2276 $priority{file} = 10; # 'File' group is always written (Comment)
2277 $priority{composite} = 10; # 'Composite' group is always written
2278 # set write priority (higher # is higher priority)
2279 $self->{WRITE_PRIORITY} = \%priority;
2280 $self->{WRITE_GROUPS} = \@groups;
2281}
2282
2283#------------------------------------------------------------------------------
2284# Build Composite tags from Require'd/Desire'd tags
2285# Inputs: 0) ExifTool object reference
2286# Note: Tag values are calculated in alphabetical order unless a tag Require's
2287# or Desire's another Composite tag, in which case the calculation is
2288# deferred until after the other tag is calculated.
2289sub BuildCompositeTags($)
2290{
2291 local $_;
2292 my $self = shift;
2293
2294 $$self{BuildingComposite} = 1;
2295 # first, add user-defined Composite tags if necessary
2296 if (%UserDefined and $UserDefined{'Image::ExifTool::Composite'}) {
2297 AddCompositeTags($UserDefined{'Image::ExifTool::Composite'}, 1);
2298 delete $UserDefined{'Image::ExifTool::Composite'};
2299 }
2300 my @tagList = sort keys %Image::ExifTool::Composite;
2301 my %tagsUsed;
2302
2303 my $rawValue = $self->{VALUE};
2304 for (;;) {
2305 my %notBuilt;
2306 $notBuilt{$_} = 1 foreach @tagList;
2307 my @deferredTags;
2308 my $tag;
2309COMPOSITE_TAG:
2310 foreach $tag (@tagList) {
2311 next if $specialTags{$tag};
2312 my $tagInfo = $self->GetTagInfo(\%Image::ExifTool::Composite, $tag);
2313 next unless $tagInfo;
2314 # put required tags into array and make sure they all exist
2315 my $subDoc = ($$tagInfo{SubDoc} and $$self{DOC_COUNT});
2316 my $require = $$tagInfo{Require} || { };
2317 my $desire = $$tagInfo{Desire} || { };
2318 # loop through sub-documents if necessary
2319 my $doc;
2320 for (;;) {
2321 my (%tagKey, $found, $index);
2322 # save Require'd and Desire'd tag values in list
2323 for ($index=0; ; ++$index) {
2324 my $reqTag = $$require{$index} || $$desire{$index} or last;
2325 # add family 3 group if generating Composite tags for sub-documents
2326 # (unless tag already begins with family 3 group name)
2327 if ($subDoc and $reqTag !~ /^(Main|Doc\d+):/) {
2328 $reqTag = ($doc ? "Doc$doc:" : 'Main:') . $reqTag;
2329 }
2330 # allow tag group to be specified
2331 if ($reqTag =~ /^(.*):(.+)/) {
2332 my ($reqGroup, $name) = ($1, $2);
2333 if ($reqGroup eq 'Composite' and $notBuilt{$name}) {
2334 push @deferredTags, $tag;
2335 next COMPOSITE_TAG;
2336 }
2337 my ($i, $key, @keys);
2338 for ($i=0; ; ++$i) {
2339 $key = $name;
2340 $key .= " ($i)" if $i;
2341 last unless defined $$rawValue{$key};
2342 push @keys, $key;
2343 }
2344 # find first matching tag
2345 $key = $self->GroupMatches($reqGroup, \@keys);
2346 $reqTag = $key if $key;
2347 } elsif ($notBuilt{$reqTag}) {
2348 # calculate this tag later if it relies on another
2349 # Composite tag which hasn't been calculated yet
2350 push @deferredTags, $tag;
2351 next COMPOSITE_TAG;
2352 }
2353 if (defined $$rawValue{$reqTag}) {
2354 $found = 1;
2355 } elsif ($$require{$index}) {
2356 $found = 0;
2357 last; # don't continue since we require this tag
2358 }
2359 $tagKey{$index} = $reqTag;
2360 }
2361 if ($doc) {
2362 if ($found) {
2363 $self->{DOC_NUM} = $doc;
2364 $self->FoundTag($tagInfo, \%tagKey);
2365 delete $self->{DOC_NUM};
2366 }
2367 next if ++$doc <= $self->{DOC_COUNT};
2368 last;
2369 } elsif ($found) {
2370 delete $notBuilt{$tag}; # this tag is OK to build now
2371 # keep track of all Require'd tag keys
2372 foreach (keys %tagKey) {
2373 # only tag keys with same name as a Composite tag
2374 # can be replaced (also eliminates keys with
2375 # instance numbers which can't be replaced either)
2376 next unless $Image::ExifTool::Composite{$tagKey{$_}};
2377 my $keyRef = \$tagKey{$_};
2378 $tagsUsed{$$keyRef} or $tagsUsed{$$keyRef} = [ ];
2379 push @{$tagsUsed{$$keyRef}}, $keyRef;
2380 }
2381 # save reference to tag key lookup as value for Composite tag
2382 my $key = $self->FoundTag($tagInfo, \%tagKey);
2383 # check to see if we just replaced one of the tag keys we Require'd
2384 if (defined $key and $tagsUsed{$key}) {
2385 foreach (@{$tagsUsed{$key}}) {
2386 $$_ = $self->{MOVED_KEY}; # replace with new tag key
2387 }
2388 delete $tagsUsed{$key}; # can't be replaced again
2389 }
2390 } elsif (not defined $found) {
2391 delete $notBuilt{$tag}; # tag can't be built anyway
2392 }
2393 last unless $subDoc;
2394 $doc = 1; # continue to process the 1st sub-document
2395 }
2396 }
2397 last unless @deferredTags;
2398 if (@deferredTags == @tagList) {
2399 # everything was deferred in the last pass,
2400 # must be a circular dependency
2401 warn "Circular dependency in Composite tags\n";
2402 last;
2403 }
2404 @tagList = @deferredTags; # calculate deferred tags now
2405 }
2406 delete $$self{BuildingComposite};
2407}
2408
2409#------------------------------------------------------------------------------
2410# Get tag name (removes copy index)
2411# Inputs: 0) Tag key
2412# Returns: Tag name
2413sub GetTagName($)
2414{
2415 local $_;
2416 $_[0] =~ /^(\S+)/;
2417 return $1;
2418}
2419
2420#------------------------------------------------------------------------------
2421# Get list of shortcuts
2422# Returns: Shortcut list (sorted alphabetically)
2423sub GetShortcuts()
2424{
2425 local $_;
2426 require Image::ExifTool::Shortcuts;
2427 return sort keys %Image::ExifTool::Shortcuts::Main;
2428}
2429
2430#------------------------------------------------------------------------------
2431# Get file type for specified extension
2432# Inputs: 0) file name or extension (case is not significant),
2433# or FileType value if a description is requested
2434# 1) flag to return long description instead of type ('0' to return any recognized type)
2435# Returns: File type (or desc) or undef if extension not supported or if
2436# description is the same as the input FileType. In array
2437# context, may return more than one file type if the file may be
2438# different formats. Returns list of all supported extensions if no
2439# file specified
2440sub GetFileType(;$$)
2441{
2442 local $_;
2443 my ($file, $desc) = @_;
2444 unless (defined $file) {
2445 my @types;
2446 if (defined $desc and $desc eq '0') {
2447 # return all recognized types
2448 @types = sort keys %fileTypeLookup;
2449 } else {
2450 # return all supported types
2451 foreach (sort keys %fileTypeLookup) {
2452 push @types, $_ unless defined $moduleName{$_} and $moduleName{$_} eq '0';
2453 }
2454 }
2455 return @types;
2456 }
2457 my $fileType;
2458 my $fileExt = GetFileExtension($file);
2459 $fileExt = uc($file) unless $fileExt;
2460 $fileExt and $fileType = $fileTypeLookup{$fileExt}; # look up the file type
2461 $fileType = $fileTypeLookup{$fileType} unless ref $fileType or not $fileType;
2462 # return description if specified
2463 # (allow input $file to be a FileType for this purpose)
2464 if ($desc) {
2465 return $fileType ? $$fileType[1] : $fileDescription{$file};
2466 } elsif ($fileType and (not defined $desc or $desc ne '0')) {
2467 # return only supported file types
2468 my $mod = $moduleName{$$fileType[0]};
2469 undef $fileType if defined $mod and $mod eq '0';
2470 }
2471 $fileType or return wantarray ? () : undef;
2472 $fileType = $$fileType[0]; # get file type (or list of types)
2473 if (wantarray) {
2474 return @$fileType if ref $fileType eq 'ARRAY';
2475 } elsif ($fileType) {
2476 $fileType = $fileExt if ref $fileType eq 'ARRAY';
2477 }
2478 return $fileType;
2479}
2480
2481#------------------------------------------------------------------------------
2482# Return true if we can write the specified file type
2483# Inputs: 0) file name or ext
2484# Returns: true if writable, 0 if not writable, undef if unrecognized
2485sub CanWrite($)
2486{
2487 local $_;
2488 my $file = shift or return undef;
2489 my $type = GetFileType($file) or return undef;
2490 if ($noWriteFile{$type}) {
2491 # can't write TIFF files with certain extensions (various RAW formats)
2492 my $ext = GetFileExtension($file) || uc($file);
2493 return grep(/^$ext$/, @{$noWriteFile{$type}}) ? 0 : 1 if $ext;
2494 }
2495 return scalar(grep /^$type$/, @writeTypes);
2496}
2497
2498#------------------------------------------------------------------------------
2499# Return true if we can create the specified file type
2500# Inputs: 0) file name or ext
2501# Returns: true if creatable, 0 if not writable, undef if unrecognized
2502sub CanCreate($)
2503{
2504 local $_;
2505 my $file = shift or return undef;
2506 my $ext = GetFileExtension($file) || uc($file);
2507 my $type = GetFileType($file) or return undef;
2508 return 1 if $createTypes{$ext} or $createTypes{$type};
2509 return 0;
2510}
2511
2512#==============================================================================
2513# Functions below this are not part of the public API
2514
2515# Initialize member variables
2516# Inputs: 0) ExifTool object reference
2517sub Init($)
2518{
2519 local $_;
2520 my $self = shift;
2521 # delete all DataMember variables (lower-case names)
2522 foreach (keys %$self) {
2523 /[a-z]/ and delete $self->{$_};
2524 }
2525 delete $self->{FOUND_TAGS}; # list of found tags
2526 delete $self->{EXIF_DATA}; # the EXIF data block
2527 delete $self->{EXIF_POS}; # EXIF position in file
2528 delete $self->{FIRST_EXIF_POS}; # position of first EXIF in file
2529 delete $self->{HTML_DUMP}; # html dump information
2530 delete $self->{SET_GROUP1}; # group1 name override
2531 delete $self->{DOC_NUM}; # current embedded document number
2532 $self->{DOC_COUNT} = 0; # count of embedded documents processed
2533 $self->{BASE} = 0; # base for offsets from start of file
2534 $self->{FILE_ORDER} = { }; # * hash of tag order in file
2535 $self->{VALUE} = { }; # * hash of raw tag values
2536 $self->{BOTH} = { }; # * hash for Value/PrintConv values of Require'd tags
2537 $self->{TAG_INFO} = { }; # * hash of tag information
2538 $self->{TAG_EXTRA} = { }; # * hash of extra tag information (dynamic group names)
2539 $self->{PRIORITY} = { }; # * priority of current tags
2540 $self->{LIST_TAGS} = { }; # hash of tagInfo refs for active List-type tags
2541 $self->{PROCESSED} = { }; # hash of processed directory start positions
2542 $self->{DIR_COUNT} = { }; # count various types of directories
2543 $self->{DUPL_TAG} = { }; # last-used index for duplicate-tag keys
2544 $self->{WARNED_ONCE}= { }; # WarnOnce() warnings already issued
2545 $self->{PATH} = [ ]; # current subdirectory path in file when reading
2546 $self->{NUM_FOUND} = 0; # total number of tags found (incl. duplicates)
2547 $self->{CHANGED} = 0; # number of tags changed (writer only)
2548 $self->{INDENT} = ' '; # initial indent for verbose messages
2549 $self->{PRIORITY_DIR} = ''; # the priority directory name
2550 $self->{LOW_PRIORITY_DIR} = { PreviewIFD => 1 }; # names of priority 0 directories
2551 $self->{TIFF_TYPE} = ''; # type of TIFF data (APP1, TIFF, NEF, etc...)
2552 $self->{Make} = ''; # camera make
2553 $self->{Model} = ''; # camera model
2554 $self->{CameraType} = ''; # Olympus camera type
2555 if ($self->Options('HtmlDump')) {
2556 require Image::ExifTool::HtmlDump;
2557 $self->{HTML_DUMP} = new Image::ExifTool::HtmlDump;
2558 }
2559 # make sure our TextOut is a file reference
2560 $self->{OPTIONS}{TextOut} = \*STDOUT unless ref $self->{OPTIONS}{TextOut};
2561}
2562
2563#------------------------------------------------------------------------------
2564# Parse function arguments and set member variables accordingly
2565# Inputs: Same as ImageInfo()
2566# - sets REQUESTED_TAGS, REQ_TAG_LOOKUP, IO_TAG_LIST, FILENAME, RAF, OPTIONS
2567sub ParseArguments($;@)
2568{
2569 my $self = shift;
2570 my $options = $self->{OPTIONS};
2571 my @exclude;
2572 my @oldGroupOpts = grep /^Group/, keys %{$self->{OPTIONS}};
2573 my $wasExcludeOpt;
2574
2575 $self->{REQUESTED_TAGS} = [ ];
2576 $self->{REQ_TAG_LOOKUP} = { };
2577 $self->{IO_TAG_LIST} = undef;
2578
2579 # handle our input arguments
2580 while (@_) {
2581 my $arg = shift;
2582 if (ref $arg) {
2583 if (ref $arg eq 'ARRAY') {
2584 $self->{IO_TAG_LIST} = $arg;
2585 foreach (@$arg) {
2586 if (/^-(.*)/) {
2587 push @exclude, $1;
2588 } else {
2589 push @{$self->{REQUESTED_TAGS}}, $_;
2590 }
2591 }
2592 } elsif (ref $arg eq 'HASH') {
2593 my $opt;
2594 foreach $opt (keys %$arg) {
2595 # a single new group option overrides all old group options
2596 if (@oldGroupOpts and $opt =~ /^Group/) {
2597 foreach (@oldGroupOpts) {
2598 delete $options->{$_};
2599 }
2600 undef @oldGroupOpts;
2601 }
2602 $self->Options($opt, $$arg{$opt});
2603 $opt eq 'Exclude' and $wasExcludeOpt = 1;
2604 }
2605 } elsif (ref $arg eq 'SCALAR' or UNIVERSAL::isa($arg,'GLOB')) {
2606 next if defined $self->{RAF};
2607 # convert image data from UTF-8 to character stream if necessary
2608 # (patches RHEL 3 UTF8 LANG problem)
2609 if (ref $arg eq 'SCALAR' and $] >= 5.006 and
2610 (eval 'require Encode; Encode::is_utf8($$arg)' or $@))
2611 {
2612 # repack by hand if Encode isn't available
2613 my $buff = $@ ? pack('C*',unpack('U0C*',$$arg)) : Encode::encode('utf8',$$arg);
2614 $arg = \$buff;
2615 }
2616 $self->{RAF} = new File::RandomAccess($arg);
2617 # set filename to empty string to indicate that
2618 # we have a file but we didn't open it
2619 $self->{FILENAME} = '';
2620 } elsif (UNIVERSAL::isa($arg, 'File::RandomAccess')) {
2621 $self->{RAF} = $arg;
2622 $self->{FILENAME} = '';
2623 } else {
2624 warn "Don't understand ImageInfo argument $arg\n";
2625 }
2626 } elsif (defined $self->{FILENAME}) {
2627 if ($arg =~ /^-(.*)/) {
2628 push @exclude, $1;
2629 } else {
2630 push @{$self->{REQUESTED_TAGS}}, $arg;
2631 }
2632 } else {
2633 $self->{FILENAME} = $arg;
2634 }
2635 }
2636 # expand shortcuts in tag arguments if provided
2637 if (@{$self->{REQUESTED_TAGS}}) {
2638 ExpandShortcuts($self->{REQUESTED_TAGS});
2639 # initialize lookup for requested tags
2640 foreach (@{$self->{REQUESTED_TAGS}}) {
2641 $self->{REQ_TAG_LOOKUP}{lc(/.+:(.+)/ ? $1 : $_)} = 1;
2642 }
2643 }
2644
2645 if (@exclude or $wasExcludeOpt) {
2646 # must add existing excluded tags
2647 if ($options->{Exclude}) {
2648 if (ref $options->{Exclude} eq 'ARRAY') {
2649 push @exclude, @{$options->{Exclude}};
2650 } else {
2651 push @exclude, $options->{Exclude};
2652 }
2653 }
2654 $options->{Exclude} = \@exclude;
2655 # expand shortcuts in new exclude list
2656 ExpandShortcuts($options->{Exclude}, 1); # (also remove '#' suffix)
2657 }
2658}
2659
2660#------------------------------------------------------------------------------
2661# Get list of tags in specified group
2662# Inputs: 0) ExifTool ref, 1) group spec, 2) tag key or reference to list of tag keys
2663# Returns: list of matching tags in list context, or first match in scalar context
2664# Notes: Group spec may contain multiple groups separated by colons, each
2665# possibly with a leading family number
2666sub GroupMatches($$$)
2667{
2668 my ($self, $group, $tagList) = @_;
2669 $tagList = [ $tagList ] unless ref $tagList;
2670 my ($tag, @matches);
2671 if ($group =~ /:/) {
2672 # check each group name individually (ie. "Author:1IPTC")
2673 my @grps = split ':', lc $group;
2674 my (@fmys, $g);
2675 for ($g=0; $g<@grps; ++$g) {
2676 $fmys[$g] = $1 if $grps[$g] =~ s/^(\d+)//;
2677 }
2678 foreach $tag (@$tagList) {
2679 my @groups = $self->GetGroup($tag, -1);
2680 for ($g=0; $g<@grps; ++$g) {
2681 my $grp = $grps[$g];
2682 next if $grp eq '*' or $grp eq 'all';
2683 if (defined $fmys[$g]) {
2684 my $f = $fmys[$g];
2685 last unless $groups[$f] and $grps[$g] eq lc $groups[$f];
2686 } else {
2687 last unless grep /^$grps[$g]$/i, @groups;
2688 }
2689 }
2690 push @matches, $tag if $g == @grps;
2691 }
2692 } else {
2693 my $family = ($group =~ s/^(\d+)//) ? $1 : -1;
2694 foreach $tag (@$tagList) {
2695 my @groups = $self->GetGroup($tag, $family);
2696 push @matches, $tag if grep(/^$group$/i, @groups);
2697 }
2698 }
2699 return wantarray ? @matches : $matches[0];
2700}
2701
2702#------------------------------------------------------------------------------
2703# Set list of found tags from previously requested tags
2704# Inputs: 0) ExifTool object reference
2705# Returns: 0) Reference to list of found tag keys (in order of requested tags)
2706# 1) Reference to list of indices for tags requested by value
2707sub SetFoundTags($)
2708{
2709 my $self = shift;
2710 my $options = $self->{OPTIONS};
2711 my $reqTags = $self->{REQUESTED_TAGS} || [ ];
2712 my $duplicates = $options->{Duplicates};
2713 my $exclude = $options->{Exclude};
2714 my $fileOrder = $self->{FILE_ORDER};
2715 my @groupOptions = sort grep /^Group/, keys %$options;
2716 my $doDups = $duplicates || $exclude || @groupOptions;
2717 my ($tag, $rtnTags, @byValue);
2718
2719 # only return requested tags if specified
2720 if (@$reqTags) {
2721 $rtnTags or $rtnTags = [ ];
2722 # scan through the requested tags and generate a list of tags we found
2723 my $tagHash = $self->{VALUE};
2724 my $reqTag;
2725 foreach $reqTag (@$reqTags) {
2726 my (@matches, $group, $allGrp, $allTag, $byValue);
2727 if ($reqTag =~ /^(.*):(.+)/) {
2728 ($group, $tag) = ($1, $2);
2729 if ($group =~ /^(\*|all)$/i) {
2730 $allGrp = 1;
2731 } elsif ($group !~ /^[-\w:]*$/) {
2732 $self->Warn("Invalid group name '$group'");
2733 $group = 'invalid';
2734 }
2735 } else {
2736 $tag = $reqTag;
2737 }
2738 $byValue = 1 if $tag =~ s/#$//;
2739 if (defined $tagHash->{$reqTag} and not $doDups) {
2740 $matches[0] = $tag;
2741 } elsif ($tag =~ /^(\*|all)$/i) {
2742 # tag name of '*' or 'all' matches all tags
2743 if ($doDups or $allGrp) {
2744 @matches = keys %$tagHash;
2745 } else {
2746 @matches = grep(!/ /, keys %$tagHash);
2747 }
2748 next unless @matches; # don't want entry in list for '*' tag
2749 $allTag = 1;
2750 } elsif ($tag =~ /[*?]/) {
2751 # allow wildcards in tag names
2752 $tag =~ s/\*/[-\\w]*/g;
2753 $tag =~ s/\?/[-\\w]/g;
2754 $tag .= '( .*)?' if $doDups or $allGrp;
2755 @matches = grep(/^$tag$/i, keys %$tagHash);
2756 next unless @matches; # don't want entry in list for wildcard tags
2757 $allTag = 1;
2758 } elsif ($doDups or defined $group) {
2759 # must also look for tags like "Tag (1)"
2760 @matches = grep(/^$tag( |$)/i, keys %$tagHash);
2761 } elsif ($tag =~ /^[-\w]+$/) {
2762 # find first matching value
2763 # (use in list context to return value instead of count)
2764 ($matches[0]) = grep /^$tag$/i, keys %$tagHash;
2765 defined $matches[0] or undef @matches;
2766 } else {
2767 $self->Warn("Invalid tag name '$tag'");
2768 }
2769 if (defined $group and not $allGrp) {
2770 # keep only specified group
2771 @matches = $self->GroupMatches($group, \@matches);
2772 next unless @matches or not $allTag;
2773 }
2774 if (@matches > 1) {
2775 # maintain original file order for multiple tags
2776 @matches = sort { $$fileOrder{$a} <=> $$fileOrder{$b} } @matches;
2777 # return only the highest priority tag unless duplicates wanted
2778 unless ($doDups or $allTag or $allGrp) {
2779 $tag = shift @matches;
2780 my $oldPriority = $self->{PRIORITY}{$tag} || 1;
2781 foreach (@matches) {
2782 my $priority = $self->{PRIORITY}{$_};
2783 $priority = 1 unless defined $priority;
2784 next unless $priority >= $oldPriority;
2785 $tag = $_;
2786 $oldPriority = $priority || 1;
2787 }
2788 @matches = ( $tag );
2789 }
2790 } elsif (not @matches) {
2791 # put entry in return list even without value (value is undef)
2792 $matches[0] = "$tag (0)";
2793 # bogus file order entry to avoid warning if sorting in file order
2794 $self->{FILE_ORDER}{$matches[0]} = 999;
2795 }
2796 # save indices of tags extracted by value
2797 push @byValue, scalar(@$rtnTags) .. (scalar(@$rtnTags)+scalar(@matches)-1) if $byValue;
2798 push @$rtnTags, @matches;
2799 }
2800 } else {
2801 # no requested tags, so we want all tags
2802 my @allTags;
2803 if ($doDups) {
2804 @allTags = keys %{$self->{VALUE}};
2805 } else {
2806 foreach (keys %{$self->{VALUE}}) {
2807 # only include tag if it doesn't end in a copy number
2808 push @allTags, $_ unless / /;
2809 }
2810 }
2811 $rtnTags = \@allTags;
2812 }
2813
2814 # filter excluded tags and group options
2815 while (($exclude or @groupOptions) and @$rtnTags) {
2816 if ($exclude) {
2817 my ($pat, %exclude);
2818 foreach $pat (@$exclude) {
2819 my $group;
2820 if ($pat =~ /^(.*):(.+)/) {
2821 ($group, $tag) = ($1, $2);
2822 if ($group =~ /^(\*|all)$/i) {
2823 undef $group;
2824 } elsif ($group !~ /^[-\w:]*$/) {
2825 $self->Warn("Invalid group name '$group'");
2826 $group = 'invalid';
2827 }
2828 } else {
2829 $tag = $pat;
2830 }
2831 my @matches;
2832 if ($tag =~ /^(\*|all)$/i) {
2833 @matches = @$rtnTags;
2834 } else {
2835 # allow wildcards in tag names
2836 $tag =~ s/\*/[-\\w]*/g;
2837 $tag =~ s/\?/[-\\w]/g;
2838 @matches = grep(/^$tag( |$)/i, @$rtnTags);
2839 }
2840 @matches = $self->GroupMatches($group, \@matches) if $group and @matches;
2841 $exclude{$_} = 1 foreach @matches;
2842 }
2843 if (%exclude) {
2844 my @filteredTags;
2845 $exclude{$_} or push @filteredTags, $_ foreach @$rtnTags;
2846 $rtnTags = \@filteredTags; # use new filtered tag list
2847 last unless @filteredTags; # all done if nothing left
2848 }
2849 last if $duplicates and not @groupOptions;
2850 }
2851 # filter groups if requested, or to remove duplicates
2852 my (%keepTags, %wantGroup, $family, $groupOpt);
2853 my $allGroups = 1;
2854 # build hash of requested/excluded group names for each group family
2855 my $wantOrder = 0;
2856 foreach $groupOpt (@groupOptions) {
2857 $groupOpt =~ /^Group(\d*(:\d+)*)/ or next;
2858 $family = $1 || 0;
2859 $wantGroup{$family} or $wantGroup{$family} = { };
2860 my $groupList;
2861 if (ref $options->{$groupOpt} eq 'ARRAY') {
2862 $groupList = $options->{$groupOpt};
2863 } else {
2864 $groupList = [ $options->{$groupOpt} ];
2865 }
2866 foreach (@$groupList) {
2867 # groups have priority in order they were specified
2868 ++$wantOrder;
2869 my ($groupName, $want);
2870 if (/^-(.*)/) {
2871 # excluded group begins with '-'
2872 $groupName = $1;
2873 $want = 0; # we don't want tags in this group
2874 } else {
2875 $groupName = $_;
2876 $want = $wantOrder; # we want tags in this group
2877 $allGroups = 0; # don't want all groups if we requested one
2878 }
2879 $wantGroup{$family}{$groupName} = $want;
2880 }
2881 }
2882 # loop through all tags and decide which ones we want
2883 my (@tags, %bestTag);
2884GR_TAG: foreach $tag (@$rtnTags) {
2885 my $wantTag = $allGroups; # want tag by default if want all groups
2886 foreach $family (keys %wantGroup) {
2887 my $group = $self->GetGroup($tag, $family);
2888 my $wanted = $wantGroup{$family}{$group};
2889 next unless defined $wanted;
2890 next GR_TAG unless $wanted; # skip tag if group excluded
2891 # take lowest non-zero want flag
2892 next if $wantTag and $wantTag < $wanted;
2893 $wantTag = $wanted;
2894 }
2895 next unless $wantTag;
2896 if ($duplicates) {
2897 push @tags, $tag;
2898 } else {
2899 my $tagName = GetTagName($tag);
2900 my $bestTag = $bestTag{$tagName};
2901 if (defined $bestTag) {
2902 next if $wantTag > $keepTags{$bestTag};
2903 if ($wantTag == $keepTags{$bestTag}) {
2904 # want two tags with the same name -- keep the latest one
2905 if ($tag =~ / \((\d+)\)$/) {
2906 my $tagNum = $1;
2907 next if $bestTag !~ / \((\d+)\)$/ or $1 > $tagNum;
2908 }
2909 }
2910 # this tag is better, so delete old best tag
2911 delete $keepTags{$bestTag};
2912 }
2913 $keepTags{$tag} = $wantTag; # keep this tag (for now...)
2914 $bestTag{$tagName} = $tag; # this is our current best tag
2915 }
2916 }
2917 unless ($duplicates) {
2918 # construct new tag list with no duplicates, preserving order
2919 foreach $tag (@$rtnTags) {
2920 push @tags, $tag if $keepTags{$tag};
2921 }
2922 }
2923 $rtnTags = \@tags;
2924 last;
2925 }
2926 $self->{FOUND_TAGS} = $rtnTags; # save found tags
2927
2928 # return reference to found tag keys (and list of indices of tags to extract by value)
2929 return wantarray ? ($rtnTags, \@byValue) : $rtnTags;
2930}
2931
2932#------------------------------------------------------------------------------
2933# Utility to load our write routines if required (called via AUTOLOAD)
2934# Inputs: 0) autoload function, 1-N) function arguments
2935# Returns: result of function or dies if function not available
2936# To Do: Generalize this routine so it works on systems that don't use '/'
2937# as a path name separator.
2938sub DoAutoLoad(@)
2939{
2940 my $autoload = shift;
2941 my @callInfo = split(/::/, $autoload);
2942 my $file = 'Image/ExifTool/Write';
2943
2944 return if $callInfo[$#callInfo] eq 'DESTROY';
2945 if (@callInfo == 4) {
2946 # load Image/ExifTool/WriteMODULE.pl
2947 $file .= "$callInfo[2].pl";
2948 } else {
2949 # load Image/ExifTool/Writer.pl
2950 $file .= 'r.pl';
2951 }
2952 # attempt to load the package
2953 eval "require '$file'" or die "Error while attempting to call $autoload\n$@\n";
2954 unless (defined &$autoload) {
2955 my @caller = caller(0);
2956 # reproduce Perl's standard 'undefined subroutine' message:
2957 die "Undefined subroutine $autoload called at $caller[1] line $caller[2]\n";
2958 }
2959 no strict 'refs';
2960 return &$autoload(@_); # call the function
2961}
2962
2963#------------------------------------------------------------------------------
2964# AutoLoad our writer routines when necessary
2965#
2966sub AUTOLOAD
2967{
2968 return DoAutoLoad($AUTOLOAD, @_);
2969}
2970
2971#------------------------------------------------------------------------------
2972# Add warning tag
2973# Inputs: 0) ExifTool object reference, 1) warning message, 2) true if minor
2974# Returns: true if warning tag was added
2975sub Warn($$;$)
2976{
2977 my ($self, $str, $ignorable) = @_;
2978 if ($ignorable) {
2979 return 0 if $self->{OPTIONS}{IgnoreMinorErrors};
2980 $str = "[minor] $str";
2981 }
2982 $self->FoundTag('Warning', $str);
2983 return 1;
2984}
2985
2986#------------------------------------------------------------------------------
2987# Add warning tag only once per processed file
2988# Inputs: 0) ExifTool object reference, 1) warning message, 2) true if minor
2989# Returns: true if warning tag was added
2990sub WarnOnce($$;$)
2991{
2992 my ($self, $str, $ignorable) = @_;
2993 return 0 if $ignorable and $self->{OPTIONS}{IgnoreMinorErrors};
2994 unless ($$self{WARNED_ONCE}{$str}) {
2995 $self->Warn($str, $ignorable);
2996 $$self{WARNED_ONCE}{$str} = 1;
2997 }
2998 return 1;
2999}
3000
3001#------------------------------------------------------------------------------
3002# Add error tag
3003# Inputs: 0) ExifTool object reference, 1) error message, 2) true if minor
3004# Returns: true if error tag was added, otherwise warning was added
3005sub Error($$;$)
3006{
3007 my ($self, $str, $ignorable) = @_;
3008 if ($ignorable) {
3009 if ($self->{OPTIONS}{IgnoreMinorErrors}) {
3010 $self->Warn($str);
3011 return 0;
3012 }
3013 $str = "[minor] $str";
3014 }
3015 $self->FoundTag('Error', $str);
3016 return 1;
3017}
3018
3019#------------------------------------------------------------------------------
3020# Expand shortcuts
3021# Inputs: 0) reference to list of tags, 1) set to remove trailing '#'
3022# Notes: Handles leading '-' for excluded tags, trailing '#' for ValueConv,
3023# multiple group names, and redirected tags
3024sub ExpandShortcuts($;$)
3025{
3026 my ($tagList, $removeSuffix) = @_;
3027 return unless $tagList and @$tagList;
3028
3029 require Image::ExifTool::Shortcuts;
3030
3031 # expand shortcuts
3032 my $suffix = $removeSuffix ? '' : '#';
3033 my @expandedTags;
3034 my ($entry, $tag, $excl);
3035 foreach $entry (@$tagList) {
3036 # skip things like options hash references in list
3037 if (ref $entry) {
3038 push @expandedTags, $entry;
3039 next;
3040 }
3041 # remove leading '-'
3042 ($excl, $tag) = $entry =~ /^(-?)(.*)/s;
3043 my ($post, @post, $pre, $v);
3044 # handle redirection
3045 if (not $excl and $tag =~ /(.+?)([-+]?[<>].+)/s) {
3046 ($tag, $post) = ($1, $2);
3047 if ($post =~ /^[-+]?>/ or $post !~ /\$/) {
3048 # expand shortcuts in postfix (rhs of redirection)
3049 my ($op, $p2, $t2) = ($post =~ /([-+]?[<>])(.+:)?(.+)/);
3050 $p2 = '' unless defined $p2;
3051 $v = ($t2 =~ s/#$//) ? $suffix : ''; # ValueConv suffix
3052 my ($match) = grep /^\Q$t2\E$/i, keys %Image::ExifTool::Shortcuts::Main;
3053 if ($match) {
3054 foreach (@{$Image::ExifTool::Shortcuts::Main{$match}}) {
3055 /^-/ and next; # ignore excluded tags
3056 if ($p2 and /(.+:)(.+)/) {
3057 push @post, "$op$_$v";
3058 } else {
3059 push @post, "$op$p2$_$v";
3060 }
3061 }
3062 next unless @post;
3063 $post = shift @post;
3064 }
3065 }
3066 } else {
3067 $post = '';
3068 }
3069 # handle group names
3070 if ($tag =~ /(.+:)(.+)/) {
3071 ($pre, $tag) = ($1, $2);
3072 } else {
3073 $pre = '';
3074 }
3075 $v = ($tag =~ s/#$//) ? $suffix : ''; # ValueConv suffix
3076 # loop over all postfixes
3077 for (;;) {
3078 # expand the tag name
3079 my ($match) = grep /^\Q$tag\E$/i, keys %Image::ExifTool::Shortcuts::Main;
3080 if ($match) {
3081 if ($excl) {
3082 # entry starts with '-', so exclude all tags in this shortcut
3083 foreach (@{$Image::ExifTool::Shortcuts::Main{$match}}) {
3084 /^-/ and next; # ignore excluded exclude tags
3085 # group of expanded tag takes precedence
3086 if ($pre and /(.+:)(.+)/) {
3087 push @expandedTags, "$excl$_";
3088 } else {
3089 push @expandedTags, "$excl$pre$_";
3090 }
3091 }
3092 } elsif (length $pre or length $post or $v) {
3093 foreach (@{$Image::ExifTool::Shortcuts::Main{$match}}) {
3094 /(-?)(.+:)?(.+)/;
3095 if ($2) {
3096 # group from expanded tag takes precedence
3097 push @expandedTags, "$_$v$post";
3098 } else {
3099 push @expandedTags, "$1$pre$3$v$post";
3100 }
3101 }
3102 } else {
3103 push @expandedTags, @{$Image::ExifTool::Shortcuts::Main{$match}};
3104 }
3105 } else {
3106 push @expandedTags, "$excl$pre$tag$v$post";
3107 }
3108 last unless @post;
3109 $post = shift @post;
3110 }
3111 }
3112 @$tagList = @expandedTags;
3113}
3114
3115#------------------------------------------------------------------------------
3116# Add hash of Composite tags to our composites
3117# Inputs: 0) hash reference to table of Composite tags to add or module name,
3118# 1) overwrite existing tag
3119sub AddCompositeTags($;$)
3120{
3121 local $_;
3122 my ($add, $overwrite) = @_;
3123 my $module;
3124 unless (ref $add) {
3125 $module = $add;
3126 $add .= '::Composite';
3127 no strict 'refs';
3128 $add = \%$add;
3129 }
3130 my $defaultGroups = $$add{GROUPS};
3131
3132 # make sure default groups are defined in families 0 and 1
3133 if ($defaultGroups) {
3134 $defaultGroups->{0} or $defaultGroups->{0} = 'Composite';
3135 $defaultGroups->{1} or $defaultGroups->{1} = 'Composite';
3136 $defaultGroups->{2} or $defaultGroups->{2} = 'Other';
3137 } else {
3138 $defaultGroups = $$add{GROUPS} = { 0 => 'Composite', 1 => 'Composite', 2 => 'Other' };
3139 }
3140 SetupTagTable($add); # generate tag Name, etc
3141 my $tagID;
3142 foreach $tagID (sort keys %$add) {
3143 next if $specialTags{$tagID}; # must skip special tags
3144 my $tagInfo = $$add{$tagID};
3145 # tagID's MUST be the exact tag name for logic in BuildCompositeTags()
3146 my $tag = $$tagInfo{Name};
3147 $$tagInfo{Module} = $module if $$tagInfo{Writable};
3148 # allow Composite tags with the same name
3149 my ($t, $n, $type);
3150 while ($Image::ExifTool::Composite{$tag} and not $overwrite) {
3151 $n ? $n += 1 : ($n = 2, $t = $tag);
3152 $tag = "${t}_$n";
3153 $$tagInfo{NewTagID} = $tag; # save new ID so we can use it in TagLookup
3154 }
3155 # convert scalar Require/Desire entries
3156 foreach $type ('Require','Desire') {
3157 my $req = $$tagInfo{$type} or next;
3158 $$tagInfo{$type} = { 0 => $req } if ref($req) ne 'HASH';
3159 }
3160 # add this Composite tag to our main Composite table
3161 $$tagInfo{Table} = \%Image::ExifTool::Composite;
3162 # (use the original TagID, even if we changed it)
3163 # $$tagInfo{TagID} = $tag;
3164 # save new tag ID so we can find entry in Composite table
3165 $Image::ExifTool::Composite{$tag} = $tagInfo;
3166 # set all default groups in tag
3167 my $groups = $$tagInfo{Groups};
3168 $groups or $groups = $$tagInfo{Groups} = { };
3169 # fill in default groups
3170 foreach (keys %$defaultGroups) {
3171 $$groups{$_} or $$groups{$_} = $$defaultGroups{$_};
3172 }
3173 # set flag indicating group list was built
3174 $$tagInfo{GotGroups} = 1;
3175 }
3176}
3177
3178#------------------------------------------------------------------------------
3179# Add tags to TagLookup (used for writing)
3180# Inputs: 0) source hash of tag definitions, 1) name of destination tag table
3181sub AddTagsToLookup($$)
3182{
3183 my ($tagHash, $table) = @_;
3184 if (defined &Image::ExifTool::TagLookup::AddTags) {
3185 Image::ExifTool::TagLookup::AddTags($tagHash, $table);
3186 } elsif (not $Image::ExifTool::pluginTags{$tagHash}) {
3187 # queue these tags until TagLookup is loaded
3188 push @Image::ExifTool::pluginTags, [ $tagHash, $table ];
3189 # set flag so we don't load same tags twice
3190 $Image::ExifTool::pluginTags{$tagHash} = 1;
3191 }
3192}
3193
3194#------------------------------------------------------------------------------
3195# Expand tagInfo Flags
3196# Inputs: 0) tagInfo hash ref
3197# Notes: $$tagInfo{Flags} must be defined to call this routine
3198sub ExpandFlags($)
3199{
3200 my $tagInfo = shift;
3201 my $flags = $$tagInfo{Flags};
3202 if (ref $flags eq 'ARRAY') {
3203 foreach (@$flags) {
3204 $$tagInfo{$_} = 1;
3205 }
3206 } elsif (ref $flags eq 'HASH') {
3207 my $key;
3208 foreach $key (keys %$flags) {
3209 $$tagInfo{$key} = $$flags{$key};
3210 }
3211 } else {
3212 $$tagInfo{$flags} = 1;
3213 }
3214}
3215
3216#------------------------------------------------------------------------------
3217# Set up tag table (must be done once for each tag table used)
3218# Inputs: 0) Reference to tag table
3219# Notes: - generates 'Name' field from key if it doesn't exist
3220# - stores 'Table' pointer and 'TagID' value
3221# - expands 'Flags' for quick lookup
3222sub SetupTagTable($)
3223{
3224 my $tagTablePtr = shift;
3225 my ($tagID, $tagInfo);
3226 foreach $tagID (TagTableKeys($tagTablePtr)) {
3227 my @infoArray = GetTagInfoList($tagTablePtr,$tagID);
3228 # process conditional tagInfo arrays
3229 foreach $tagInfo (@infoArray) {
3230 $$tagInfo{Table} = $tagTablePtr;
3231 $$tagInfo{TagID} = $tagID;
3232 my $tag = $$tagInfo{Name};
3233 unless (defined $tag) {
3234 # generate name equal to tag ID if 'Name' doesn't exist
3235 $tag = $tagID;
3236 $$tagInfo{Name} = ucfirst($tag); # make first char uppercase
3237 }
3238 $$tagInfo{Flags} and ExpandFlags($tagInfo);
3239 }
3240 next unless @infoArray > 1;
3241 # add an "Index" member to each tagInfo in a list
3242 my $index = 0;
3243 foreach $tagInfo (@infoArray) {
3244 $$tagInfo{Index} = $index++;
3245 }
3246 }
3247}
3248
3249#------------------------------------------------------------------------------
3250# Utilities to check for numerical types
3251# Inputs: 0) value; Returns: true if value is a numerical type
3252# Notes: May change commas to decimals in floats for use in other locales
3253sub IsFloat($) {
3254 return 1 if $_[0] =~ /^[+-]?(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/;
3255 # allow comma separators (for other locales)
3256 return 0 unless $_[0] =~ /^[+-]?(?=\d|,\d)\d*(,\d*)?([Ee]([+-]?\d+))?$/;
3257 $_[0] =~ tr/,/./; # but translate ',' to '.'
3258 return 1;
3259}
3260sub IsInt($) { return scalar($_[0] =~ /^[+-]?\d+$/); }
3261sub IsHex($) { return scalar($_[0] =~ /^(0x)?[0-9a-f]{1,8}$/i); }
3262sub IsRational($) { return scalar($_[0] =~ m{^[-+]?\d+/\d+$}); }
3263
3264# round floating point value to specified number of significant digits
3265# Inputs: 0) value, 1) number of sig digits; Returns: rounded number
3266sub RoundFloat($$)
3267{
3268 my ($val, $sig) = @_;
3269 $val == 0 and return 0;
3270 my $sign = $val < 0 ? ($val=-$val, -1) : 1;
3271 my $log = log($val) / log(10);
3272 my $exp = int($log) - $sig + ($log > 0 ? 1 : 0);
3273 return $sign * int(10 ** ($log - $exp) + 0.5) * 10 ** $exp;
3274}
3275
3276# Convert strings to floating point numbers (or undef)
3277# Inputs: 0-N) list of strings (may be undef)
3278# Returns: last value converted
3279sub ToFloat(@)
3280{
3281 local $_;
3282 foreach (@_) {
3283 next unless defined $_;
3284 # (add 0 to convert "0.0" to "0" for tests)
3285 $_ = /((?:[+-]?)(?=\d|\.\d)\d*(?:\.\d*)?(?:[Ee](?:[+-]?\d+))?)/ ? $1 + 0 : undef;
3286 }
3287 return $_[-1];
3288}
3289
3290#------------------------------------------------------------------------------
3291# Utility routines to for reading binary data values from file
3292
3293my %unpackMotorola = ( S => 'n', L => 'N', C => 'C', c => 'c' );
3294my %unpackIntel = ( S => 'v', L => 'V', C => 'C', c => 'c' );
3295my %unpackRev = ( N => 'V', V => 'N', C => 'C', n => 'v', v => 'n', c => 'c' );
3296
3297# the following 4 variables are defined in 'use vars' instead of using 'my'
3298# because mod_perl 5.6.1 apparently has a problem with setting file-scope 'my'
3299# variables from within subroutines (ref communication with Pavel Merdin):
3300# $swapBytes - set if EXIF header is not native byte ordering
3301# $swapWords - swap 32-bit words in doubles (ARM quirk)
3302$currentByteOrder = 'MM'; # current byte ordering ('II' or 'MM')
3303%unpackStd = %unpackMotorola;
3304
3305# Swap bytes in data if necessary
3306# Inputs: 0) data, 1) number of bytes
3307# Returns: swapped data
3308sub SwapBytes($$)
3309{
3310 return $_[0] unless $swapBytes;
3311 my ($val, $bytes) = @_;
3312 my $newVal = '';
3313 $newVal .= substr($val, $bytes, 1) while $bytes--;
3314 return $newVal;
3315}
3316# Swap words. Inputs: 8 bytes of data, Returns: swapped data
3317sub SwapWords($)
3318{
3319 return $_[0] unless $swapWords and length($_[0]) == 8;
3320 return substr($_[0],4,4) . substr($_[0],0,4)
3321}
3322
3323# Unpack value, letting unpack() handle byte swapping
3324# Inputs: 0) unpack template, 1) data reference, 2) offset
3325# Returns: unpacked number
3326# - uses value of %unpackStd to determine the unpack template
3327# - can only be called for 'S' or 'L' templates since these are the only
3328# templates for which you can specify the byte ordering.
3329sub DoUnpackStd(@)
3330{
3331 $_[2] and return unpack("x$_[2] $unpackStd{$_[0]}", ${$_[1]});
3332 return unpack($unpackStd{$_[0]}, ${$_[1]});
3333}
3334# same, but with reversed byte order
3335sub DoUnpackRev(@)
3336{
3337 my $fmt = $unpackRev{$unpackStd{$_[0]}};
3338 $_[2] and return unpack("x$_[2] $fmt", ${$_[1]});
3339 return unpack($fmt, ${$_[1]});
3340}
3341# Pack value
3342# Inputs: 0) template, 1) value, 2) data ref (or undef), 3) offset (if data ref)
3343# Returns: packed value
3344sub DoPackStd(@)
3345{
3346 my $val = pack($unpackStd{$_[0]}, $_[1]);
3347 $_[2] and substr(${$_[2]}, $_[3], length($val)) = $val;
3348 return $val;
3349}
3350# same, but with reversed byte order
3351sub DoPackRev(@)
3352{
3353 my $val = pack($unpackRev{$unpackStd{$_[0]}}, $_[1]);
3354 $_[2] and substr(${$_[2]}, $_[3], length($val)) = $val;
3355 return $val;
3356}
3357
3358# Unpack value, handling the byte swapping manually
3359# Inputs: 0) # bytes, 1) unpack template, 2) data reference, 3) offset
3360# Returns: unpacked number
3361# - uses value of $swapBytes to determine byte ordering
3362sub DoUnpack(@)
3363{
3364 my ($bytes, $template, $dataPt, $pos) = @_;
3365 my $val;
3366 if ($swapBytes) {
3367 $val = '';
3368 $val .= substr($$dataPt,$pos+$bytes,1) while $bytes--;
3369 } else {
3370 $val = substr($$dataPt,$pos,$bytes);
3371 }
3372 defined($val) or return undef;
3373 return unpack($template,$val);
3374}
3375
3376# Unpack double value
3377# Inputs: 0) unpack template, 1) data reference, 2) offset
3378# Returns: unpacked number
3379sub DoUnpackDbl(@)
3380{
3381 my ($template, $dataPt, $pos) = @_;
3382 my $val = substr($$dataPt,$pos,8);
3383 defined($val) or return undef;
3384 # swap bytes and 32-bit words (ARM quirk) if necessary, then unpack value
3385 return unpack($template, SwapWords(SwapBytes($val, 8)));
3386}
3387
3388# Inputs: 0) data reference, 1) offset into data
3389sub Get8s($$) { return DoUnpackStd('c', @_); }
3390sub Get8u($$) { return DoUnpackStd('C', @_); }
3391sub Get16s($$) { return DoUnpack(2, 's', @_); }
3392sub Get16u($$) { return DoUnpackStd('S', @_); }
3393sub Get32s($$) { return DoUnpack(4, 'l', @_); }
3394sub Get32u($$) { return DoUnpackStd('L', @_); }
3395sub GetFloat($$) { return DoUnpack(4, 'f', @_); }
3396sub GetDouble($$) { return DoUnpackDbl('d', @_); }
3397sub Get16uRev($$) { return DoUnpackRev('S', @_); }
3398
3399# rationals may be a floating point number, 'inf' or 'undef'
3400sub GetRational32s($$)
3401{
3402 my ($dataPt, $pos) = @_;
3403 my $numer = Get16s($dataPt,$pos);
3404 my $denom = Get16s($dataPt, $pos + 2) or return $numer ? 'inf' : 'undef';
3405 # round off to a reasonable number of significant figures
3406 return RoundFloat($numer / $denom, 7);
3407}
3408sub GetRational32u($$)
3409{
3410 my ($dataPt, $pos) = @_;
3411 my $numer = Get16u($dataPt,$pos);
3412 my $denom = Get16u($dataPt, $pos + 2) or return $numer ? 'inf' : 'undef';
3413 return RoundFloat($numer / $denom, 7);
3414}
3415sub GetRational64s($$)
3416{
3417 my ($dataPt, $pos) = @_;
3418 my $numer = Get32s($dataPt,$pos);
3419 my $denom = Get32s($dataPt, $pos + 4) or return $numer ? 'inf' : 'undef';
3420 return RoundFloat($numer / $denom, 10);
3421}
3422sub GetRational64u($$)
3423{
3424 my ($dataPt, $pos) = @_;
3425 my $numer = Get32u($dataPt,$pos);
3426 my $denom = Get32u($dataPt, $pos + 4) or return $numer ? 'inf' : 'undef';
3427 return RoundFloat($numer / $denom, 10);
3428}
3429sub GetFixed16s($$)
3430{
3431 my ($dataPt, $pos) = @_;
3432 my $val = Get16s($dataPt, $pos) / 0x100;
3433 return int($val * 1000 + ($val<0 ? -0.5 : 0.5)) / 1000;
3434}
3435sub GetFixed16u($$)
3436{
3437 my ($dataPt, $pos) = @_;
3438 return int((Get16u($dataPt, $pos) / 0x100) * 1000 + 0.5) / 1000;
3439}
3440sub GetFixed32s($$)
3441{
3442 my ($dataPt, $pos) = @_;
3443 my $val = Get32s($dataPt, $pos) / 0x10000;
3444 # remove insignificant digits
3445 return int($val * 1e5 + ($val>0 ? 0.5 : -0.5)) / 1e5;
3446}
3447sub GetFixed32u($$)
3448{
3449 my ($dataPt, $pos) = @_;
3450 # remove insignificant digits
3451 return int((Get32u($dataPt, $pos) / 0x10000) * 1e5 + 0.5) / 1e5;
3452}
3453# Inputs: 0) value, 1) data ref, 2) offset
3454sub Set8s(@) { return DoPackStd('c', @_); }
3455sub Set8u(@) { return DoPackStd('C', @_); }
3456sub Set16u(@) { return DoPackStd('S', @_); }
3457sub Set32u(@) { return DoPackStd('L', @_); }
3458sub Set16uRev(@) { return DoPackRev('S', @_); }
3459
3460#------------------------------------------------------------------------------
3461# Get current byte order ('II' or 'MM')
3462sub GetByteOrder() { return $currentByteOrder; }
3463
3464#------------------------------------------------------------------------------
3465# Set byte ordering
3466# Inputs: 0) 'MM'=motorola, 'II'=intel (will translate 'BigEndian', 'LittleEndian')
3467# Returns: 1 on success
3468sub SetByteOrder($)
3469{
3470 my $order = shift;
3471
3472 if ($order eq 'MM') { # big endian (Motorola)
3473 %unpackStd = %unpackMotorola;
3474 } elsif ($order eq 'II') { # little endian (Intel)
3475 %unpackStd = %unpackIntel;
3476 } elsif ($order =~ /^Big/i) {
3477 $order = 'MM';
3478 %unpackStd = %unpackMotorola;
3479 } elsif ($order =~ /^Little/i) {
3480 $order = 'II';
3481 %unpackStd = %unpackIntel;
3482 } else {
3483 return 0;
3484 }
3485 my $val = unpack('S','A ');
3486 my $nativeOrder;
3487 if ($val == 0x4120) { # big endian
3488 $nativeOrder = 'MM';
3489 } elsif ($val == 0x2041) { # little endian
3490 $nativeOrder = 'II';
3491 } else {
3492 warn sprintf("Unknown native byte order! (pattern %x)\n",$val);
3493 return 0;
3494 }
3495 $currentByteOrder = $order; # save current byte order
3496
3497 # swap bytes if our native CPU byte ordering is not the same as the EXIF
3498 $swapBytes = ($order ne $nativeOrder);
3499
3500 # little-endian ARM has big-endian words for doubles (thanks Riku Voipio)
3501 # (Note: Riku's patch checked for '0ff3', but I think it should be 'f03f' since
3502 # 1 is '000000000000f03f' on an x86 -- so check for both, but which is correct?)
3503 my $pack1d = pack('d', 1);
3504 $swapWords = ($pack1d eq "\0\0\x0f\xf3\0\0\0\0" or
3505 $pack1d eq "\0\0\xf0\x3f\0\0\0\0");
3506 return 1;
3507}
3508
3509#------------------------------------------------------------------------------
3510# Change byte order
3511sub ToggleByteOrder()
3512{
3513 SetByteOrder(GetByteOrder() eq 'II' ? 'MM' : 'II');
3514}
3515
3516#------------------------------------------------------------------------------
3517# hash lookups for reading values from data
3518my %formatSize = (
3519 int8s => 1,
3520 int8u => 1,
3521 int16s => 2,
3522 int16u => 2,
3523 int16uRev => 2,
3524 int32s => 4,
3525 int32u => 4,
3526 int64s => 8,
3527 int64u => 8,
3528 rational32s => 4,
3529 rational32u => 4,
3530 rational64s => 8,
3531 rational64u => 8,
3532 fixed16s => 2,
3533 fixed16u => 2,
3534 fixed32s => 4,
3535 fixed32u => 4,
3536 float => 4,
3537 double => 8,
3538 extended => 10,
3539 unicode => 2,
3540 complex => 8,
3541 string => 1,
3542 binary => 1,
3543 'undef' => 1,
3544 ifd => 4,
3545 ifd64 => 8,
3546);
3547my %readValueProc = (
3548 int8s => \&Get8s,
3549 int8u => \&Get8u,
3550 int16s => \&Get16s,
3551 int16u => \&Get16u,
3552 int16uRev => \&Get16uRev,
3553 int32s => \&Get32s,
3554 int32u => \&Get32u,
3555 int64s => \&Get64s,
3556 int64u => \&Get64u,
3557 rational32s => \&GetRational32s,
3558 rational32u => \&GetRational32u,
3559 rational64s => \&GetRational64s,
3560 rational64u => \&GetRational64u,
3561 fixed16s => \&GetFixed16s,
3562 fixed16u => \&GetFixed16u,
3563 fixed32s => \&GetFixed32s,
3564 fixed32u => \&GetFixed32u,
3565 float => \&GetFloat,
3566 double => \&GetDouble,
3567 extended => \&GetExtended,
3568 ifd => \&Get32u,
3569 ifd64 => \&Get64u,
3570);
3571sub FormatSize($) { return $formatSize{$_[0]}; }
3572
3573#------------------------------------------------------------------------------
3574# Read value from binary data (with current byte ordering)
3575# Inputs: 0) data reference, 1) value offset, 2) format string,
3576# 3) number of values (or undef to use all data)
3577# 4) valid data length relative to offset
3578# Returns: converted value, or undefined if data isn't there
3579# or list of values in list context
3580sub ReadValue($$$$$)
3581{
3582 my ($dataPt, $offset, $format, $count, $size) = @_;
3583
3584 my $len = $formatSize{$format};
3585 unless ($len) {
3586 warn "Unknown format $format";
3587 $len = 1;
3588 }
3589 unless ($count) {
3590 return '' if defined $count or $size < $len;
3591 $count = int($size / $len);
3592 }
3593 # make sure entry is inside data
3594 if ($len * $count > $size) {
3595 $count = int($size / $len); # shorten count if necessary
3596 $count < 1 and return undef; # return undefined if no data
3597 }
3598 my @vals;
3599 my $proc = $readValueProc{$format};
3600 if ($proc) {
3601 for (;;) {
3602 push @vals, &$proc($dataPt, $offset);
3603 last if --$count <= 0;
3604 $offset += $len;
3605 }
3606 } else {
3607 # handle undef/binary/string (also unsupported unicode/complex)
3608 $vals[0] = substr($$dataPt, $offset, $count * $len);
3609 # truncate string at null terminator if necessary
3610 $vals[0] =~ s/\0.*//s if $format eq 'string';
3611 }
3612 return @vals if wantarray;
3613 return join(' ', @vals) if @vals > 1;
3614 return $vals[0];
3615}
3616
3617#------------------------------------------------------------------------------
3618# Decode string with specified encoding
3619# Inputs: 0) ExifTool object ref, 1) string to decode
3620# 2) source character set name (undef for current Charset)
3621# 3) optional source byte order (2-byte and 4-byte fixed-width sets only)
3622# 4) optional destination character set (defaults to Charset setting)
3623# 5) optional destination byte order (2-byte and 4-byte fixed-width only)
3624# Returns: string in destination encoding
3625# Note: ExifTool ref may be undef if character both character sets are provided
3626# (but in this case no warnings will be issued)
3627sub Decode($$$;$$$)
3628{
3629 my ($self, $val, $from, $fromOrder, $to, $toOrder) = @_;
3630 $from or $from = $$self{OPTIONS}{Charset};
3631 $to or $to = $$self{OPTIONS}{Charset};
3632 if ($from ne $to and length $val) {
3633 require Image::ExifTool::Charset;
3634 my $cs1 = $Image::ExifTool::Charset::csType{$from};
3635 my $cs2 = $Image::ExifTool::Charset::csType{$to};
3636 if ($cs1 and $cs2 and not $cs2 & 0x002) {
3637 # treat as straight ASCII if no character will need remapping
3638 if (($cs1 | $cs2) & 0x680 or $val =~ /[\x80-\xff]/) {
3639 my $uni = Image::ExifTool::Charset::Decompose($self, $val, $from, $fromOrder);
3640 $val = Image::ExifTool::Charset::Recompose($self, $uni, $to, $toOrder);
3641 }
3642 } elsif ($self) {
3643 my $set = $cs1 ? $to : $from;
3644 unless ($$self{"DecodeWarn$set"}) {
3645 $self->Warn("Unsupported character set ($set)");
3646 $$self{"DecodeWarn$set"} = 1;
3647 }
3648 }
3649 }
3650 return $val;
3651}
3652
3653#------------------------------------------------------------------------------
3654# Encode string with specified encoding
3655# Inputs: 0) ExifTool object ref, 1) string, 2) destination character set name,
3656# 3) optional destination byte order (2-byte and 4-byte fixed-width sets only)
3657# Returns: string in specified encoding
3658sub Encode($$$;$)
3659{
3660 my ($self, $val, $to, $toOrder) = @_;
3661 return $self->Decode($val, undef, undef, $to, $toOrder);
3662}
3663
3664#------------------------------------------------------------------------------
3665# Decode bit mask
3666# Inputs: 0) value to decode, 1) Reference to hash for decoding (or undef)
3667# 2) optional bits per word (defaults to 32)
3668sub DecodeBits($$;$)
3669{
3670 my ($vals, $lookup, $bits) = @_;
3671 $bits or $bits = 32;
3672 my ($val, $i, @bitList);
3673 my $num = 0;
3674 foreach $val (split ' ', $vals) {
3675 for ($i=0; $i<$bits; ++$i) {
3676 next unless $val & (1 << $i);
3677 my $n = $i + $num;
3678 if (not $lookup) {
3679 push @bitList, $n;
3680 } elsif ($$lookup{$n}) {
3681 push @bitList, $$lookup{$n};
3682 } else {
3683 push @bitList, "[$n]";
3684 }
3685 }
3686 $num += $bits;
3687 }
3688 return '(none)' unless @bitList;
3689 return join($lookup ? ', ' : ',', @bitList);
3690}
3691
3692#------------------------------------------------------------------------------
3693# Validate an extracted image and repair if necessary
3694# Inputs: 0) ExifTool object reference, 1) image reference, 2) tag name or key
3695# Returns: image reference or undef if it wasn't valid
3696# Note: should be called from RawConv, not ValueConv
3697sub ValidateImage($$$)
3698{
3699 my ($self, $imagePt, $tag) = @_;
3700 return undef if $$imagePt eq 'none';
3701 unless ($$imagePt =~ /^(Binary data|\xff\xd8\xff)/ or
3702 # the first byte of the preview of some Minolta cameras is wrong,
3703 # so check for this and set it back to 0xff if necessary
3704 $$imagePt =~ s/^.(\xd8\xff\xdb)/\xff$1/s or
3705 $self->Options('IgnoreMinorErrors'))
3706 {
3707 # issue warning only if the tag was specifically requested
3708 if ($self->{REQ_TAG_LOOKUP}{lc GetTagName($tag)}) {
3709 $self->Warn("$tag is not a valid JPEG image",1);
3710 return undef;
3711 }
3712 }
3713 return $imagePt;
3714}
3715
3716#------------------------------------------------------------------------------
3717# Make description from a tag name
3718# Inputs: 0) tag name 1) optional tagID to add at end of description
3719# Returns: description
3720sub MakeDescription($;$)
3721{
3722 my ($tag, $tagID) = @_;
3723 # start with the tag name and force first letter to be upper case
3724 my $desc = ucfirst($tag);
3725 # translate underlines to spaces
3726 $desc =~ tr/_/ /;
3727 # remove hex TagID from name (to avoid inserting spaces in the number)
3728 $desc =~ s/ (0x[\da-f]+)$//i and $tagID = $1 unless defined $tagID;
3729 # put a space between lower/UPPER case and lower/number combinations
3730 $desc =~ s/([a-z])([A-Z\d])/$1 $2/g;
3731 # put a space between acronyms and words
3732 $desc =~ s/([A-Z])([A-Z][a-z])/$1 $2/g;
3733 # put spaces after numbers (if more than one character following number)
3734 $desc =~ s/(\d)([A-Z]\S)/$1 $2/g;
3735 # add TagID to description
3736 $desc .= ' ' . $tagID if defined $tagID;
3737 return $desc;
3738}
3739
3740#------------------------------------------------------------------------------
3741# Return printable value
3742# Inputs: 0) ExifTool object reference
3743# 1) value to print, 2) line length limit (undef defaults to 60, 0=unlimited)
3744sub Printable($;$)
3745{
3746 my ($self, $outStr, $maxLen) = @_;
3747 return '(undef)' unless defined $outStr;
3748 $outStr =~ tr/\x01-\x1f\x7f-\xff/./;
3749 $outStr =~ s/\x00//g;
3750 if (defined $maxLen) {
3751 # minimum length is 20 (0 is unlimited)
3752 $maxLen = 20 if $maxLen and $maxLen < 20;
3753 } else {
3754 $maxLen = 60; # default length is 60
3755 }
3756 # limit length only if verbose < 4
3757 if ($maxLen and length($outStr) > $maxLen and $self->{OPTIONS}{Verbose} < 4) {
3758 $outStr = substr($outStr,0,$maxLen-6) . '[snip]';
3759 }
3760 return $outStr;
3761}
3762
3763#------------------------------------------------------------------------------
3764# Convert date/time from Exif format
3765# Inputs: 0) ExifTool object reference, 1) Date/time in EXIF format
3766# Returns: Formatted date/time string
3767sub ConvertDateTime($$)
3768{
3769 my ($self, $date) = @_;
3770 my $dateFormat = $self->{OPTIONS}{DateFormat};
3771 # only convert date if a format was specified and the date is recognizable
3772 if ($dateFormat) {
3773 # a few cameras use incorrect date/time formatting:
3774 # - slashes instead of colons in date (RolleiD330, ImpressCam)
3775 # - date/time values separated by colon instead of space (Polariod, Sanyo, Sharp, Vivitar)
3776 # - single-digit seconds with leading space (HP scanners)
3777 $date =~ s/[-+]\d{2}:\d{2}$//; # remove timezone if it exists
3778 my @a = ($date =~ /\d+/g); # be very flexible about date/time format
3779 if (@a and $a[0] > 1900 and $a[0] < 3000 and eval 'require POSIX') {
3780 $date = POSIX::strftime($dateFormat, $a[5]||0, $a[4]||0, $a[3]||0,
3781 $a[2]||1, ($a[1]||1)-1, $a[0]-1900);
3782 } elsif ($self->{OPTIONS}{StrictDate}) {
3783 undef $date;
3784 }
3785 }
3786 return $date;
3787}
3788
3789#------------------------------------------------------------------------------
3790# Print conversion for time span value
3791# Inputs: 0) time ticks, 1) number of seconds per tick (default 1)
3792# Returns: readable time
3793sub ConvertTimeSpan($;$)
3794{
3795 my ($val, $mult) = @_;
3796 if (Image::ExifTool::IsFloat($val) and $val != 0) {
3797 $val *= $mult if $mult;
3798 if ($val < 60) {
3799 $val = "$val seconds";
3800 } elsif ($val < 3600) {
3801 my $fmt = ($mult and $mult >= 60) ? '%d' : '%.1f';
3802 my $s = ($val == 60 and $mult) ? '' : 's';
3803 $val = sprintf("$fmt minute$s", $val / 60);
3804 } elsif ($val < 24 * 3600) {
3805 $val = sprintf("%.1f hours", $val / 3600);
3806 } else {
3807 $val = sprintf("%.1f days", $val / (24 * 3600));
3808 }
3809 }
3810 return $val;
3811}
3812
3813#------------------------------------------------------------------------------
3814# Patched timelocal() that fixes ActivePerl timezone bug
3815# Inputs/Returns: same as timelocal()
3816# Notes: must 'require Time::Local' before calling this routine
3817sub TimeLocal(@)
3818{
3819 my $tm = Time::Local::timelocal(@_);
3820 if ($^O eq 'MSWin32') {
3821 # patch for ActivePerl timezone bug
3822 my @t2 = localtime($tm);
3823 my $t2 = Time::Local::timelocal(@t2);
3824 # adjust timelocal() return value to be consistent with localtime()
3825 $tm += $tm - $t2;
3826 }
3827 return $tm;
3828}
3829
3830#------------------------------------------------------------------------------
3831# Get time zone in minutes
3832# Inputs: 0) localtime array ref, 1) gmtime array ref
3833# Returns: time zone offset in minutes
3834sub GetTimeZone(;$$)
3835{
3836 my ($tm, $gm) = @_;
3837 # compute the number of minutes between localtime and gmtime
3838 my $min = $$tm[2] * 60 + $$tm[1] - ($$gm[2] * 60 + $$gm[1]);
3839 if ($$tm[3] != $$gm[3]) {
3840 # account for case where one date wraps to the first of the next month
3841 $$gm[3] = $$tm[3] - ($$tm[3]==1 ? 1 : -1) if abs($$tm[3]-$$gm[3]) != 1;
3842 # adjust for the +/- one day difference
3843 $min += ($$tm[3] - $$gm[3]) * 24 * 60;
3844 }
3845 return $min;
3846}
3847
3848#------------------------------------------------------------------------------
3849# Get time zone string
3850# Inputs: 0) time zone offset in minutes
3851# or 0) localtime array ref, 1) corresponding time value
3852# Returns: time zone string ("+/-HH:MM")
3853sub TimeZoneString($;$)
3854{
3855 my $min = shift;
3856 if (ref $min) {
3857 my @gm = gmtime(shift);
3858 $min = GetTimeZone($min, \@gm);
3859 }
3860 my $sign = '+';
3861 $min < 0 and $sign = '-', $min = -$min;
3862 my $h = int($min / 60);
3863 return sprintf('%s%.2d:%.2d', $sign, $h, $min - $h * 60);
3864}
3865
3866#------------------------------------------------------------------------------
3867# Convert Unix time to EXIF date/time string
3868# Inputs: 0) Unix time value, 1) non-zero to convert to local time
3869# Returns: EXIF date/time string (with timezone for local times)
3870# Notes: fractional seconds are ignored
3871sub ConvertUnixTime($;$)
3872{
3873 my ($time, $toLocal) = @_;
3874 return '0000:00:00 00:00:00' if $time == 0;
3875 my (@tm, $tz);
3876 if ($toLocal) {
3877 @tm = localtime($time);
3878 $tz = TimeZoneString(\@tm, $time);
3879 } else {
3880 @tm = gmtime($time);
3881 $tz = '';
3882 }
3883 my $str = sprintf("%4d:%.2d:%.2d %.2d:%.2d:%.2d%s",
3884 $tm[5]+1900, $tm[4]+1, $tm[3], $tm[2], $tm[1], $tm[0], $tz);
3885 return $str;
3886}
3887
3888#------------------------------------------------------------------------------
3889# Get Unix time from EXIF-formatted date/time string with optional timezone
3890# Inputs: 0) EXIF date/time string, 1) non-zero if time is local
3891# Returns: Unix time (seconds since 0:00 GMT Jan 1, 1970) or undefined on error
3892sub GetUnixTime($;$)
3893{
3894 my ($timeStr, $isLocal) = @_;
3895 return 0 if $timeStr eq '0000:00:00 00:00:00';
3896 my @tm = ($timeStr =~ /^(\d+):(\d+):(\d+)\s+(\d+):(\d+):(\d+)/);
3897 return undef unless @tm == 6 and eval 'require Time::Local';
3898 my $tzsec = 0;
3899 # use specified timezone offset (if given) instead of local system time
3900 # if we are converting a local time value
3901 if ($isLocal and $timeStr =~ /(?:Z|([-+])(\d+):(\d+))$/i) {
3902 # use specified timezone if one exists
3903 $tzsec = ($2 * 60 + $3) * ($1 eq '-' ? -60 : 60) if $1;
3904 undef $isLocal; # convert using GMT corrected for specified timezone
3905 }
3906 $tm[0] -= 1900; # convert year
3907 $tm[1] -= 1; # convert month
3908 @tm = reverse @tm; # change to order required by timelocal()
3909 return $isLocal ? TimeLocal(@tm) : Time::Local::timegm(@tm) - $tzsec;
3910}
3911
3912#------------------------------------------------------------------------------
3913# Print conversion for file size
3914# Inputs: 0) file size in bytes
3915# Returns: converted file size
3916sub ConvertFileSize($)
3917{
3918 my $val = shift;
3919 $val < 2048 and return "$val bytes";
3920 $val < 10240 and return sprintf('%.1f kB', $val / 1024);
3921 $val < 2097152 and return sprintf('%.0f kB', $val / 1024);
3922 $val < 10485760 and return sprintf('%.1f MB', $val / 1048576);
3923 return sprintf('%.0f MB', $val / 1048576);
3924}
3925
3926#------------------------------------------------------------------------------
3927# Convert seconds to duration string (handles negative durations)
3928# Inputs: 0) floating point seconds
3929# Returns: duration string in form "S.SS s", "MM:SS" or "H:MM:SS"
3930sub ConvertDuration($)
3931{
3932 my $time = shift;
3933 return $time unless IsFloat($time);
3934 return '0 s' if $time == 0;
3935 my $sign = ($time > 0 ? '' : (($time = -$time), '-'));
3936 return sprintf("$sign%.2f s", $time) if $time < 30;
3937 my $h = int($time / 3600);
3938 $time -= $h * 3600;
3939 my $m = int($time / 60);
3940 $time -= $m * 60;
3941 return sprintf("$sign%d:%.2d:%.2d", $h, $m, int($time));
3942}
3943
3944#------------------------------------------------------------------------------
3945# Print conversion for bitrate values
3946# Inputs: 0) bitrate in bits per second
3947# Returns: human-readable bitrate string
3948# Notes: returns input value without formatting if it isn't numerical
3949sub ConvertBitrate($)
3950{
3951 my $bitrate = shift;
3952 IsFloat($bitrate) or return $bitrate;
3953 my @units = ('bps', 'kbps', 'Mbps', 'Gbps');
3954 for (;;) {
3955 my $units = shift @units;
3956 $bitrate >= 1000 and @units and $bitrate /= 1000, next;
3957 my $fmt = $bitrate < 100 ? '%.3g' : '%.0f';
3958 return sprintf("$fmt $units", $bitrate);
3959 }
3960}
3961
3962#------------------------------------------------------------------------------
3963# Save information for HTML dump
3964# Inputs: 0) ExifTool hash ref, 1) start offset, 2) data size
3965# 3) comment string, 4) tool tip (or SAME), 5) flags
3966sub HDump($$$$;$$)
3967{
3968 my $self = shift;
3969 my $pos = shift;
3970 $pos += $$self{BASE} if $$self{BASE};
3971 $$self{HTML_DUMP} and $self->{HTML_DUMP}->Add($pos, @_);
3972}
3973
3974#------------------------------------------------------------------------------
3975# JPEG constants
3976my %jpegMarker = (
3977 0x01 => 'TEM',
3978 0xc0 => 'SOF0', # to SOF15, with a few exceptions below
3979 0xc4 => 'DHT',
3980 0xc8 => 'JPGA',
3981 0xcc => 'DAC',
3982 0xd0 => 'RST0',
3983 0xd8 => 'SOI',
3984 0xd9 => 'EOI',
3985 0xda => 'SOS',
3986 0xdb => 'DQT',
3987 0xdc => 'DNL',
3988 0xdd => 'DRI',
3989 0xde => 'DHP',
3990 0xdf => 'EXP',
3991 0xe0 => 'APP0', # to APP15
3992 0xf0 => 'JPG0',
3993 0xfe => 'COM',
3994);
3995
3996#------------------------------------------------------------------------------
3997# Get JPEG marker name
3998# Inputs: 0) Jpeg number
3999# Returns: marker name
4000sub JpegMarkerName($)
4001{
4002 my $marker = shift;
4003 my $markerName = $jpegMarker{$marker};
4004 unless ($markerName) {
4005 $markerName = $jpegMarker{$marker & 0xf0};
4006 if ($markerName and $markerName =~ /^([A-Z]+)\d+$/) {
4007 $markerName = $1 . ($marker & 0x0f);
4008 } else {
4009 $markerName = sprintf("marker 0x%.2x", $marker);
4010 }
4011 }
4012 return $markerName;
4013}
4014
4015#------------------------------------------------------------------------------
4016# Identify trailer ending at specified offset from end of file
4017# Inputs: 0) RAF reference, 1) offset from end of file (0 by default)
4018# Returns: Trailer info hash (with RAF and DirName set),
4019# or undef if no recognized trailer was found
4020# Notes: leaves file position unchanged
4021sub IdentifyTrailer($;$)
4022{
4023 my $raf = shift;
4024 my $offset = shift || 0;
4025 my $pos = $raf->Tell();
4026 my ($buff, $type, $len);
4027 while ($raf->Seek(-$offset, 2) and ($len = $raf->Tell()) > 0) {
4028 # read up to 64 bytes before specified offset from end of file
4029 $len = 64 if $len > 64;
4030 $raf->Seek(-$len, 1) and $raf->Read($buff, $len) == $len or last;
4031 if ($buff =~ /AXS(!|\*).{8}$/s) {
4032 $type = 'AFCP';
4033 } elsif ($buff =~ /\xa1\xb2\xc3\xd4$/) {
4034 $type = 'FotoStation';
4035 } elsif ($buff =~ /cbipcbbl$/) {
4036 $type = 'PhotoMechanic';
4037 } elsif ($buff =~ /^CANON OPTIONAL DATA\0/) {
4038 $type = 'CanonVRD';
4039 } elsif ($buff =~ /~\0\x04\0zmie~\0\0\x06.{4}[\x10\x18]\x04$/s or
4040 $buff =~ /~\0\x04\0zmie~\0\0\x0a.{8}[\x10\x18]\x08$/s)
4041 {
4042 $type = 'MIE';
4043 }
4044 last;
4045 }
4046 $raf->Seek($pos, 0); # restore original file position
4047 return $type ? { RAF => $raf, DirName => $type } : undef;
4048}
4049
4050#------------------------------------------------------------------------------
4051# Read/rewrite trailer information (including multiple trailers)
4052# Inputs: 0) ExifTool object ref, 1) DirInfo ref:
4053# - requires RAF and DirName
4054# - OutFile is a scalar reference for writing
4055# - scans from current file position if ScanForAFCP is set
4056# Returns: 1 if trailer was processed or couldn't be processed (or written OK)
4057# 0 if trailer was recognized but offsets need fixing (or write error)
4058# - DirName, DirLen, DataPos, Offset, Fixup and OutFile are updated
4059# - preserves current file position and byte order
4060sub ProcessTrailers($$)
4061{
4062 my ($self, $dirInfo) = @_;
4063 my $dirName = $$dirInfo{DirName};
4064 my $outfile = $$dirInfo{OutFile};
4065 my $offset = $$dirInfo{Offset} || 0;
4066 my $fixup = $$dirInfo{Fixup};
4067 my $raf = $$dirInfo{RAF};
4068 my $pos = $raf->Tell();
4069 my $byteOrder = GetByteOrder();
4070 my $success = 1;
4071 my $path = $$self{PATH};
4072
4073 for (;;) { # loop through all trailers
4074 require "Image/ExifTool/$dirName.pm";
4075 my $proc = "Image::ExifTool::${dirName}::Process$dirName";
4076 my $outBuff;
4077 if ($outfile) {
4078 # write to local buffer so we can add trailer in proper order later
4079 $$outfile and $$dirInfo{OutFile} = \$outBuff, $outBuff = '';
4080 # must generate new fixup if necessary so we can shift
4081 # the old fixup separately after we prepend this trailer
4082 delete $$dirInfo{Fixup};
4083 }
4084 delete $$dirInfo{DirLen}; # reset trailer length
4085 $$dirInfo{Offset} = $offset; # set offset from end of file
4086 $$dirInfo{Trailer} = 1; # set Trailer flag in case proc cares
4087 # add trailer and DirName to SubDirectory PATH
4088 push @$path, 'Trailer', $dirName;
4089
4090 # read or write this trailer
4091 # (proc takes Offset as offset from end of trailer to end of file,
4092 # and returns DataPos and DirLen, and Fixup if applicable)
4093 no strict 'refs';
4094 my $result = &$proc($self, $dirInfo);
4095 use strict 'refs';
4096
4097 # restore PATH
4098 pop @$path;
4099 pop @$path;
4100 # check result
4101 if ($outfile) {
4102 if ($result > 0) {
4103 if ($outBuff) {
4104 # write trailers to OutFile in original order
4105 $$outfile = $outBuff . $$outfile;
4106 # must adjust old fixup start if it exists
4107 $$fixup{Start} += length($outBuff) if $fixup;
4108 $outBuff = ''; # free memory
4109 }
4110 if ($fixup) {
4111 # add new fixup information if any
4112 $fixup->AddFixup($$dirInfo{Fixup}) if $$dirInfo{Fixup};
4113 } else {
4114 $fixup = $$dirInfo{Fixup}; # save fixup
4115 }
4116 } else {
4117 $success = 0 if $self->Error("Error rewriting $dirName trailer", 1);
4118 last;
4119 }
4120 } elsif ($result < 0) {
4121 # can't continue if we must scan for this trailer
4122 $success = 0;
4123 last;
4124 }
4125 last unless $result > 0 and $$dirInfo{DirLen};
4126 # look for next trailer
4127 $offset += $$dirInfo{DirLen};
4128 my $nextTrail = IdentifyTrailer($raf, $offset) or last;
4129 $dirName = $$dirInfo{DirName} = $$nextTrail{DirName};
4130 $raf->Seek($pos, 0);
4131 }
4132 SetByteOrder($byteOrder); # restore original byte order
4133 $raf->Seek($pos, 0); # restore original file position
4134 $$dirInfo{OutFile} = $outfile; # restore original outfile
4135 $$dirInfo{Offset} = $offset; # return offset from EOF to start of first trailer
4136 $$dirInfo{Fixup} = $fixup; # return fixup information
4137 return $success;
4138}
4139
4140#------------------------------------------------------------------------------
4141# Extract EXIF information from a jpg image
4142# Inputs: 0) ExifTool object reference, 1) dirInfo ref with RAF set
4143# Returns: 1 on success, 0 if this wasn't a valid JPEG file
4144sub ProcessJPEG($$)
4145{
4146 local $_;
4147 my ($self, $dirInfo) = @_;
4148 my ($ch, $s, $length);
4149 my $verbose = $self->{OPTIONS}{Verbose};
4150 my $out = $self->{OPTIONS}{TextOut};
4151 my $fast = $self->{OPTIONS}{FastScan};
4152 my $raf = $$dirInfo{RAF};
4153 my $htmlDump = $self->{HTML_DUMP};
4154 my %dumpParms = ( Out => $out );
4155 my ($success, $icc_profile, $wantTrailer, $trailInfo, %extendedXMP);
4156 my ($preview, $scalado, @dqt, $subSampling, $dumpEnd);
4157
4158 # check to be sure this is a valid JPG file
4159 return 0 unless $raf->Read($s, 2) == 2 and $s eq "\xff\xd8";
4160 $dumpParms{MaxLen} = 128 if $verbose < 4;
4161 unless ($self->{VALUE}{FileType}) {
4162 $self->SetFileType(); # set FileType tag
4163 $$self{LOW_PRIORITY_DIR}{IFD1} = 1; # lower priority of IFD1 tags
4164 }
4165 if ($htmlDump) {
4166 $dumpEnd = $raf->Tell();
4167 my $pos = $dumpEnd - 2;
4168 $self->HDump(0, $pos, '[unknown header]') if $pos;
4169 $self->HDump($pos, 2, 'JPEG header', 'SOI Marker');
4170 }
4171 my $path = $$self{PATH};
4172 my $pn = scalar @$path;
4173
4174 # set input record separator to 0xff (the JPEG marker) to make reading quicker
4175 local $/ = "\xff";
4176
4177 my ($nextMarker, $nextSegDataPt, $nextSegPos, $combinedSegData);
4178
4179 # read file until we reach an end of image (EOI) or start of scan (SOS)
4180 Marker: for (;;) {
4181 # set marker and data pointer for current segment
4182 my $marker = $nextMarker;
4183 my $segDataPt = $nextSegDataPt;
4184 my $segPos = $nextSegPos;
4185 undef $nextMarker;
4186 undef $nextSegDataPt;
4187#
4188# read ahead to the next segment unless we have reached EOI or SOS
4189#
4190 unless ($marker and ($marker==0xd9 or ($marker==0xda and not $wantTrailer))) {
4191 # read up to next marker (JPEG markers begin with 0xff)
4192 my $buff;
4193 $raf->ReadLine($buff) or last;
4194 # JPEG markers can be padded with unlimited 0xff's
4195 for (;;) {
4196 $raf->Read($ch, 1) or last Marker;
4197 $nextMarker = ord($ch);
4198 last unless $nextMarker == 0xff;
4199 }
4200 # read data for all markers except 0xd9 (EOI) and stand-alone
4201 # markers 0x00, 0x01 and 0xd0-0xd7 (NULL, TEM, RST0-RST7)
4202 if ($nextMarker!=0xd9 and $nextMarker!=0x00 and $nextMarker!=0x01 and
4203 ($nextMarker<0xd0 or $nextMarker>0xd7))
4204 {
4205 # read record length word
4206 last unless $raf->Read($s, 2) == 2;
4207 my $len = unpack('n',$s); # get data length
4208 last unless defined($len) and $len >= 2;
4209 $nextSegPos = $raf->Tell();
4210 $len -= 2; # subtract size of length word
4211 last unless $raf->Read($buff, $len) == $len;
4212 $nextSegDataPt = \$buff; # set pointer to our next data
4213 }
4214 # read second segment too if this was the first
4215 next unless defined $marker;
4216 }
4217 # set some useful variables for the current segment
4218 my $markerName = JpegMarkerName($marker);
4219 $$path[$pn] = $markerName;
4220#
4221# parse the current segment
4222#
4223 # handle SOF markers: SOF0-SOF15, except DHT(0xc4), JPGA(0xc8) and DAC(0xcc)
4224 if (($marker & 0xf0) == 0xc0 and ($marker == 0xc0 or $marker & 0x03)) {
4225 $length = length $$segDataPt;
4226 if ($verbose) {
4227 print $out "JPEG $markerName ($length bytes):\n";
4228 HexDump($segDataPt, undef, %dumpParms, Addr=>$segPos) if $verbose>2;
4229 }
4230 next unless $length >= 6;
4231 # extract some useful information
4232 my ($p, $h, $w, $n) = unpack('Cn2C', $$segDataPt);
4233 my $sof = GetTagTable('Image::ExifTool::JPEG::SOF');
4234 $self->FoundTag($$sof{ImageWidth}, $w);
4235 $self->FoundTag($$sof{ImageHeight}, $h);
4236 $self->FoundTag($$sof{EncodingProcess}, $marker - 0xc0);
4237 $self->FoundTag($$sof{BitsPerSample}, $p);
4238 $self->FoundTag($$sof{ColorComponents}, $n);
4239 next unless $n == 3 and $length >= 15;
4240 my ($i, $hmin, $hmax, $vmin, $vmax);
4241 # loop through all components to determine sampling frequency
4242 $subSampling = '';
4243 for ($i=0; $i<$n; ++$i) {
4244 my $sf = Get8u($segDataPt, 7 + 3 * $i);
4245 $subSampling .= sprintf('%.2x', $sf);
4246 # isolate horizontal and vertical components
4247 my ($hf, $vf) = ($sf >> 4, $sf & 0x0f);
4248 unless ($i) {
4249 $hmin = $hmax = $hf;
4250 $vmin = $vmax = $vf;
4251 next;
4252 }
4253 # determine min/max frequencies
4254 $hmin = $hf if $hf < $hmin;
4255 $hmax = $hf if $hf > $hmax;
4256 $vmin = $vf if $vf < $vmin;
4257 $vmax = $vf if $vf > $vmax;
4258 }
4259 if ($hmin and $vmin) {
4260 my ($hs, $vs) = ($hmax / $hmin, $vmax / $vmin);
4261 $self->FoundTag($$sof{YCbCrSubSampling}, "$hs $vs");
4262 }
4263 next;
4264 } elsif ($marker == 0xd9) { # EOI
4265 pop @$path;
4266 $verbose and print $out "JPEG EOI\n";
4267 my $pos = $raf->Tell();
4268 if ($htmlDump and $dumpEnd) {
4269 $self->HDump($dumpEnd, $pos-2-$dumpEnd, '[JPEG Image Data]', undef, 0x08);
4270 $self->HDump($pos-2, 2, 'JPEG EOI', undef);
4271 $dumpEnd = 0;
4272 }
4273 $success = 1;
4274 # we are here because we are looking for trailer information
4275 if ($wantTrailer) {
4276 my $start = $$self{PreviewImageStart};
4277 if ($start) {
4278 my $buff;
4279 # most previews start right after the JPEG EOI, but the Olympus E-20
4280 # preview is 508 bytes into the trailer, the K-M Maxxum 7D preview is
4281 # 979 bytes in, and Sony previews can start up to 32 kB into the trailer.
4282 # (and Minolta and Sony previews can have a random first byte...)
4283 my $scanLen = $$self{Make} =~ /Sony/i ? 65536 : 1024;
4284 if ($raf->Read($buff, $scanLen) and ($buff =~ /\xff\xd8\xff./g or
4285 ($self->{Make} =~ /(Minolta|Sony)/i and $buff =~ /.\xd8\xff\xdb/g)))
4286 {
4287 # adjust PreviewImageStart to this location
4288 my $actual = $pos + pos($buff) - 4;
4289 if ($start ne $actual and $verbose > 1) {
4290 print $out "(Fixed PreviewImage location: $start -> $actual)\n";
4291 }
4292 # update preview image offsets
4293 $self->{VALUE}{PreviewImageStart} = $actual if $self->{VALUE}{PreviewImageStart};
4294 $$self{PreviewImageStart} = $actual;
4295 # load preview now if we tried and failed earlier
4296 if ($$self{PreviewError} and $$self{PreviewImageLength}) {
4297 if ($raf->Seek($actual, 0) and $raf->Read($buff, $$self{PreviewImageLength})) {
4298 $self->FoundTag('PreviewImage', $buff);
4299 delete $$self{PreviewError};
4300 }
4301 }
4302 }
4303 $raf->Seek($pos, 0);
4304 }
4305 }
4306 # process trailer now or finish processing trailers
4307 # and scan for AFCP if necessary
4308 my $fromEnd = 0;
4309 if ($trailInfo) {
4310 $$trailInfo{ScanForAFCP} = 1; # scan now if necessary
4311 $self->ProcessTrailers($trailInfo);
4312 # save offset from end of file to start of first trailer
4313 $fromEnd = $$trailInfo{Offset};
4314 undef $trailInfo;
4315 }
4316 if ($$self{LeicaTrailer}) {
4317 $raf->Seek(0, 2);
4318 $$self{LeicaTrailer}{TrailPos} = $pos;
4319 $$self{LeicaTrailer}{TrailLen} = $raf->Tell() - $pos - $fromEnd;
4320 Image::ExifTool::Panasonic::ProcessLeicaTrailer($self);
4321 }
4322 # finally, dump remaining information in JPEG trailer
4323 if ($verbose or $htmlDump) {
4324 my $endPos = $$self{LeicaTrailerPos};
4325 unless ($endPos) {
4326 $raf->Seek(0, 2);
4327 $endPos = $raf->Tell() - $fromEnd;
4328 }
4329 $self->DumpUnknownTrailer({
4330 RAF => $raf,
4331 DataPos => $pos,
4332 DirLen => $endPos - $pos
4333 }) if $endPos > $pos;
4334 }
4335 last; # all done parsing file
4336 } elsif ($marker == 0xda) { # SOS
4337 pop @$path;
4338 # all done with meta information unless we have a trailer
4339 $verbose and print $out "JPEG SOS\n";
4340 unless ($fast) {
4341 $trailInfo = IdentifyTrailer($raf);
4342 # process trailer now unless we are doing verbose dump
4343 if ($trailInfo and $verbose < 3 and not $htmlDump) {
4344 # process trailers (keep trailInfo to finish processing later
4345 # only if we can't finish without scanning from end of file)
4346 $self->ProcessTrailers($trailInfo) and undef $trailInfo;
4347 }
4348 if ($wantTrailer) {
4349 # seek ahead and validate preview image
4350 my $buff;
4351 my $curPos = $raf->Tell();
4352 if ($raf->Seek($$self{PreviewImageStart}, 0) and
4353 $raf->Read($buff, 4) == 4 and
4354 $buff =~ /^.\xd8\xff[\xc4\xdb\xe0-\xef]/)
4355 {
4356 undef $wantTrailer;
4357 }
4358 $raf->Seek($curPos, 0) or last;
4359 }
4360 # seek ahead and process Leica trailer
4361 if ($$self{LeicaTrailer}) {
4362 require Image::ExifTool::Panasonic;
4363 Image::ExifTool::Panasonic::ProcessLeicaTrailer($self);
4364 $wantTrailer = 1 if $$self{LeicaTrailer};
4365 }
4366 next if $trailInfo or $wantTrailer or $verbose > 2 or $htmlDump;
4367 }
4368 # nothing interesting to parse after start of scan (SOS)
4369 $success = 1;
4370 last; # all done parsing file
4371 } elsif ($marker==0x00 or $marker==0x01 or ($marker>=0xd0 and $marker<=0xd7)) {
4372 # handle stand-alone markers 0x00, 0x01 and 0xd0-0xd7 (NULL, TEM, RST0-RST7)
4373 $verbose and $marker and print $out "JPEG $markerName:\n";
4374 next;
4375 } elsif ($marker == 0xdb and length($$segDataPt) and # DQT
4376 # save the DQT data only if JPEGDigest has been requested
4377 $self->{REQ_TAG_LOOKUP}->{jpegdigest})
4378 {
4379 my $num = unpack('C',$$segDataPt) & 0x0f; # get table index
4380 $dqt[$num] = $$segDataPt if $num < 4; # save for MD5 calculation
4381 }
4382 # handle all other markers
4383 my $dumpType = '';
4384 $length = length $$segDataPt;
4385 if ($verbose) {
4386 print $out "JPEG $markerName ($length bytes):\n";
4387 if ($verbose > 2) {
4388 my %extraParms = ( Addr => $segPos );
4389 $extraParms{MaxLen} = 128 if $verbose == 4;
4390 HexDump($segDataPt, undef, %dumpParms, %extraParms);
4391 }
4392 }
4393 if ($marker == 0xe0) { # APP0 (JFIF, JFXX, CIFF, AVI1, Ocad)
4394 if ($$segDataPt =~ /^JFIF\0/) {
4395 $dumpType = 'JFIF';
4396 my %dirInfo = (
4397 DataPt => $segDataPt,
4398 DataPos => $segPos,
4399 DirStart => 5,
4400 DirLen => $length - 5,
4401 );
4402 SetByteOrder('MM');
4403 my $tagTablePtr = GetTagTable('Image::ExifTool::JFIF::Main');
4404 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
4405 } elsif ($$segDataPt =~ /^JFXX\0\x10/) {
4406 $dumpType = 'JFXX';
4407 my $tagTablePtr = GetTagTable('Image::ExifTool::JFIF::Extension');
4408 my $tagInfo = $self->GetTagInfo($tagTablePtr, 0x10);
4409 $self->FoundTag($tagInfo, substr($$segDataPt, 6));
4410 } elsif ($$segDataPt =~ /^(II|MM).{4}HEAPJPGM/s) {
4411 next if $fast and $fast > 1; # skip processing for very fast
4412 $dumpType = 'CIFF';
4413 my %dirInfo = (
4414 RAF => new File::RandomAccess($segDataPt),
4415 );
4416 $self->{SET_GROUP1} = 'CIFF';
4417 require Image::ExifTool::CanonRaw;
4418 Image::ExifTool::CanonRaw::ProcessCRW($self, \%dirInfo);
4419 delete $self->{SET_GROUP1};
4420 } elsif ($$segDataPt =~ /^(AVI1|Ocad)/) {
4421 $dumpType = $1;
4422 SetByteOrder('MM');
4423 my $tagTablePtr = GetTagTable("Image::ExifTool::JPEG::$dumpType");
4424 my %dirInfo = (
4425 DataPt => $segDataPt,
4426 DataPos => $segPos,
4427 DirStart => 4,
4428 DirLen => $length - 4,
4429 );
4430 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
4431 }
4432 } elsif ($marker == 0xe1) { # APP1 (EXIF, XMP, QVCI)
4433 if ($$segDataPt =~ /^Exif\0/) { # (some Kodak cameras don't put a second \0)
4434 undef $dumpType; # (will be dumped here)
4435 # this is EXIF data --
4436 # get the data block (into a common variable)
4437 my $hdrLen = length($exifAPP1hdr);
4438 my %dirInfo = (
4439 Parent => $markerName,
4440 DataPt => $segDataPt,
4441 DataPos => $segPos,
4442 DirStart => $hdrLen,
4443 Base => $segPos + $hdrLen,
4444 );
4445 if ($htmlDump) {
4446 $self->HDump($segPos-4, 4, 'APP1 header', "Data size: $length bytes");
4447 $self->HDump($segPos, $hdrLen, 'Exif header', 'APP1 data type: Exif');
4448 $dumpEnd = $segPos + $length;
4449 }
4450 # extract the EXIF information (it is in standard TIFF format)
4451 $self->ProcessTIFF(\%dirInfo);
4452 # avoid looking for preview unless necessary because it really slows
4453 # us down -- only look for it if we found pointer, and preview is
4454 # outside EXIF, and PreviewImage is specifically requested
4455 my $start = $self->GetValue('PreviewImageStart');
4456 my $length = $self->GetValue('PreviewImageLength');
4457 if (not $start or not $length and $$self{PreviewError}) {
4458 $start = $$self{PreviewImageStart};
4459 $length = $$self{PreviewImageLength};
4460 }
4461 if ($start and $length and
4462 $start + $length > $self->{EXIF_POS} + length($self->{EXIF_DATA}) and
4463 $self->{REQ_TAG_LOOKUP}{previewimage})
4464 {
4465 $$self{PreviewImageStart} = $start;
4466 $$self{PreviewImageLength} = $length;
4467 $wantTrailer = 1;
4468 }
4469 } elsif ($$segDataPt =~ /^$xmpExtAPP1hdr/) {
4470 # off len -- extended XMP header (75 bytes total):
4471 # 0 35 bytes - signature
4472 # 35 32 bytes - GUID (MD5 hash of full extended XMP data in ASCII)
4473 # 67 4 bytes - total size of extended XMP data
4474 # 71 4 bytes - offset for this XMP data portion
4475 $dumpType = 'Extended XMP';
4476 if (length $$segDataPt > 75) {
4477 my ($size, $off) = unpack('x67N2', $$segDataPt);
4478 my $guid = substr($$segDataPt, 35, 32);
4479 my $extXMP = $extendedXMP{$guid};
4480 $extXMP or $extXMP = $extendedXMP{$guid} = { };
4481 $$extXMP{Size} = $size;
4482 $$extXMP{$off} = substr($$segDataPt, 75);
4483 # process extended XMP if complete
4484 my @offsets;
4485 for ($off=0; $off<$size; ) {
4486 last unless defined $$extXMP{$off};
4487 push @offsets, $off;
4488 $off += length $$extXMP{$off};
4489 }
4490 if ($off == $size) {
4491 my $buff = '';
4492 # assemble XMP all together
4493 $buff .= $$extXMP{$_} foreach @offsets;
4494 $dumpType = 'Extended XMP';
4495 my $tagTablePtr = GetTagTable('Image::ExifTool::XMP::Main');
4496 my %dirInfo = (
4497 DataPt => \$buff,
4498 Parent => $markerName,
4499 );
4500 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
4501 delete $extendedXMP{$guid};
4502 }
4503 } else {
4504 $self->Warn('Invalid extended XMP segment');
4505 }
4506 } elsif ($$segDataPt =~ /^QVCI\0/) {
4507 $dumpType = 'QVCI';
4508 my $tagTablePtr = GetTagTable('Image::ExifTool::Casio::QVCI');
4509 my %dirInfo = (
4510 Base => 0,
4511 DataPt => $segDataPt,
4512 DataPos => $segPos,
4513 DataLen => $length,
4514 DirStart => 0,
4515 DirLen => $length,
4516 Parent => $markerName,
4517 );
4518 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
4519 } else {
4520 # Hmmm. Could be XMP, let's see
4521 my $processed;
4522 if ($$segDataPt =~ /^http/ or $$segDataPt =~ /<exif:/) {
4523 $dumpType = 'XMP';
4524 # also try to parse XMP with a non-standard header
4525 # (note: this non-standard XMP is ignored when writing)
4526 my $start = ($$segDataPt =~ /^$xmpAPP1hdr/) ? length($xmpAPP1hdr) : 0;
4527 my $tagTablePtr = GetTagTable('Image::ExifTool::XMP::Main');
4528 my %dirInfo = (
4529 Base => 0,
4530 DataPt => $segDataPt,
4531 DataPos => $segPos,
4532 DataLen => $length,
4533 DirStart => $start,
4534 DirLen => $length - $start,
4535 Parent => $markerName,
4536 );
4537 $processed = $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
4538 if ($processed and not $start) {
4539 $self->Warn('Non-standard header for APP1 XMP segment');
4540 }
4541 }
4542 if ($verbose and not $processed) {
4543 $self->Warn("Ignored EXIF block length $length (bad header)");
4544 }
4545 }
4546 } elsif ($marker == 0xe2) { # APP2 (ICC Profile, FPXR, MPF, PreviewImage)
4547 if ($$segDataPt =~ /^ICC_PROFILE\0/) {
4548 $dumpType = 'ICC_Profile';
4549 # must concatenate blocks of profile
4550 my $block_num = Get8u($segDataPt, 12);
4551 my $blocks_tot = Get8u($segDataPt, 13);
4552 $icc_profile = '' if $block_num == 1;
4553 if (defined $icc_profile) {
4554 $icc_profile .= substr($$segDataPt, 14);
4555 if ($block_num == $blocks_tot) {
4556 my $tagTablePtr = GetTagTable('Image::ExifTool::ICC_Profile::Main');
4557 my %dirInfo = (
4558 DataPt => \$icc_profile,
4559 DataPos => $segPos + 14,
4560 DataLen => length($icc_profile),
4561 DirStart => 0,
4562 DirLen => length($icc_profile),
4563 Parent => $markerName,
4564 );
4565 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
4566 undef $icc_profile;
4567 }
4568 }
4569 } elsif ($$segDataPt =~ /^FPXR\0/) {
4570 next if $fast and $fast > 1; # skip processing for very fast
4571 $dumpType = 'FPXR';
4572 my $tagTablePtr = GetTagTable('Image::ExifTool::FlashPix::Main');
4573 my %dirInfo = (
4574 DataPt => $segDataPt,
4575 DataPos => $segPos,
4576 DataLen => $length,
4577 DirStart => 0,
4578 DirLen => $length,
4579 Parent => $markerName,
4580 # set flag if this is the last FPXR segment
4581 LastFPXR => not ($nextMarker==$marker and $$nextSegDataPt=~/^FPXR\0/),
4582 );
4583 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
4584 } elsif ($$segDataPt =~ /^MPF\0/) {
4585 undef $dumpType; # (will be dumped here)
4586 my %dirInfo = (
4587 Parent => $markerName,
4588 DataPt => $segDataPt,
4589 DataPos => $segPos,
4590 DirStart => 4,
4591 Base => $segPos + 4,
4592 Multi => 1, # the MP Attribute IFD will be MPF1
4593 );
4594 if ($htmlDump) {
4595 $self->HDump($segPos-4, 4, 'APP2 header', "Data size: $length bytes");
4596 $self->HDump($segPos, 4, 'MPF header', 'APP2 data type: MPF');
4597 $dumpEnd = $segPos + $length;
4598 }
4599 # extract the MPF information (it is in standard TIFF format)
4600 my $tagTablePtr = GetTagTable('Image::ExifTool::MPF::Main');
4601 $self->ProcessTIFF(\%dirInfo, $tagTablePtr);
4602 } elsif ($$segDataPt =~ /^\xff\xd8\xff\xdb/) {
4603 $preview = $$segDataPt;
4604 $dumpType = 'Samsung Preview';
4605 } elsif ($preview) {
4606 $preview .= $$segDataPt;
4607 $dumpType = 'Samsung Preview';
4608 }
4609 if ($preview and $nextMarker ne $marker) {
4610 $self->FoundTag('PreviewImage', $preview);
4611 undef $preview;
4612 }
4613 } elsif ($marker == 0xe3) { # APP3 (Kodak "Meta", Stim)
4614 if ($$segDataPt =~ /^(Meta|META|Exif)\0\0/) {
4615 undef $dumpType; # (will be dumped here)
4616 my %dirInfo = (
4617 Parent => $markerName,
4618 DataPt => $segDataPt,
4619 DataPos => $segPos,
4620 DirStart => 6,
4621 Base => $segPos + 6,
4622 );
4623 if ($htmlDump) {
4624 $self->HDump($segPos-4, 10, 'APP3 Meta header');
4625 $dumpEnd = $segPos + $length;
4626 }
4627 my $tagTablePtr = GetTagTable('Image::ExifTool::Kodak::Meta');
4628 $self->ProcessTIFF(\%dirInfo, $tagTablePtr);
4629 } elsif ($$segDataPt =~ /^Stim\0/) {
4630 undef $dumpType; # (will be dumped here)
4631 my %dirInfo = (
4632 Parent => $markerName,
4633 DataPt => $segDataPt,
4634 DataPos => $segPos,
4635 DirStart => 6,
4636 Base => $segPos + 6,
4637 );
4638 if ($htmlDump) {
4639 $self->HDump($segPos-4, 4, 'APP3 header', "Data size: $length bytes");
4640 $self->HDump($segPos, 5, 'Stim header', 'APP3 data type: Stim');
4641 $dumpEnd = $segPos + $length;
4642 }
4643 # extract the Stim information (it is in standard TIFF format)
4644 my $tagTablePtr = GetTagTable('Image::ExifTool::Stim::Main');
4645 $self->ProcessTIFF(\%dirInfo, $tagTablePtr);
4646 } elsif ($$segDataPt =~ /^\xff\xd8\xff\xdb/) {
4647 $preview = $$segDataPt;
4648 $dumpType = 'Samsung/HP Preview';
4649 }
4650 # Samsung continues the preview in APP4
4651 if ($preview and $nextMarker ne 0xe4) {
4652 $self->FoundTag('PreviewImage', $preview);
4653 undef $preview;
4654 }
4655 } elsif ($marker == 0xe4) { # APP4 ("SCALADO", FPXR, PreviewImage)
4656 if ($$segDataPt =~ /^SCALADO\0/ and $length >= 16) {
4657 $dumpType = 'SCALADO';
4658 my ($num, $idx, $len) = unpack('x8n2N', $$segDataPt);
4659 # assume that the segments are in order and just concatinate them
4660 $scalado = '' unless defined $scalado;
4661 $scalado .= substr($$segDataPt, 16);
4662 if ($idx == $num - 1) {
4663 if ($len != length $scalado) {
4664 $self->Warn('Possibly corrupted APP4 SCALADO data', 1);
4665 }
4666 my %dirInfo = (
4667 Parent => $markerName,
4668 DataPt => \$scalado,
4669 );
4670 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::Scalado');
4671 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
4672 undef $scalado;
4673 }
4674 } elsif ($$segDataPt =~ /^FPXR\0/) {
4675 next if $fast and $fast > 1; # skip processing for very fast
4676 $dumpType = 'FPXR';
4677 my $tagTablePtr = GetTagTable('Image::ExifTool::FlashPix::Main');
4678 my %dirInfo = (
4679 DataPt => $segDataPt,
4680 DataPos => $segPos,
4681 DataLen => $length,
4682 DirStart => 0,
4683 DirLen => $length,
4684 Parent => $markerName,
4685 # set flag if this is the last FPXR segment
4686 LastFPXR => not ($nextMarker==$marker and $$nextSegDataPt=~/^FPXR\0/),
4687 );
4688 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
4689 } elsif ($preview) {
4690 # continued Samsung S1060 preview from APP3
4691 $preview .= $$segDataPt;
4692 # (not sure if next part would be APP5 or APP4 again, but assume APP4)
4693 if ($nextMarker ne $marker) {
4694 $self->FoundTag('PreviewImage', $preview);
4695 undef $preview;
4696 }
4697 }
4698 } elsif ($marker == 0xe5) { # APP5 (Ricoh "RMETA")
4699 if ($$segDataPt =~ /^RMETA\0/) {
4700 $dumpType = 'Ricoh RMETA';
4701 my %dirInfo = (
4702 Parent => $markerName,
4703 DataPt => $segDataPt,
4704 DataPos => $segPos,
4705 DirStart => 6,
4706 Base => $segPos + 6,
4707 );
4708 my $tagTablePtr = GetTagTable('Image::ExifTool::Ricoh::RMETA');
4709 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
4710 }
4711 } elsif ($marker == 0xe6) { # APP6 (Toshiba EPPIM, NITF, HP_TDHD)
4712 if ($$segDataPt =~ /^EPPIM\0/) {
4713 undef $dumpType; # (will be dumped here)
4714 my %dirInfo = (
4715 Parent => $markerName,
4716 DataPt => $segDataPt,
4717 DataPos => $segPos,
4718 DirStart => 6,
4719 Base => $segPos + 6,
4720 );
4721 if ($htmlDump) {
4722 $self->HDump($segPos-4, 10, 'APP6 EPPIM header');
4723 $dumpEnd = $segPos + $length;
4724 }
4725 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::EPPIM');
4726 $self->ProcessTIFF(\%dirInfo, $tagTablePtr);
4727 } elsif ($$segDataPt =~ /^NITF\0/) {
4728 $dumpType = 'NITF';
4729 SetByteOrder('MM');
4730 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::NITF');
4731 my %dirInfo = (
4732 DataPt => $segDataPt,
4733 DataPos => $segPos,
4734 DirStart => 5,
4735 DirLen => $length - 5,
4736 );
4737 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
4738 } elsif ($$segDataPt =~ /^TDHD\x01\0\0\0/ and $length > 12) {
4739 # HP Photosmart R837 APP6 "TDHD" segment
4740 $dumpType = 'TDHD';
4741 my $tagTablePtr = GetTagTable('Image::ExifTool::HP::TDHD');
4742 my %dirInfo = (
4743 DataPt => $segDataPt,
4744 DataPos => $segPos,
4745 DirStart => 12, # (ignore first TDHD element because size includes 12-byte tag header)
4746 DirLen => $length - 12,
4747 );
4748 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
4749 }
4750 } elsif ($marker == 0xe8) { # APP8 (SPIFF)
4751 # my sample SPIFF has 32 bytes of data, but spec states 30
4752 if ($$segDataPt =~ /^SPIFF\0/ and $length == 32) {
4753 $dumpType = 'SPIFF';
4754 my %dirInfo = (
4755 DataPt => $segDataPt,
4756 DataPos => $segPos,
4757 DirStart => 6,
4758 DirLen => $length - 6,
4759 );
4760 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::SPIFF');
4761 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
4762 }
4763 } elsif ($marker == 0xea) { # APP10 (PhotoStudio Unicode comments)
4764 if ($$segDataPt =~ /^UNICODE\0/) {
4765 $dumpType = 'PhotoStudio';
4766 my $comment = $self->Decode(substr($$segDataPt,8), 'UCS2', 'MM');
4767 $self->FoundTag('Comment', $comment);
4768 }
4769 } elsif ($marker == 0xec) { # APP12 (Ducky, Picture Info)
4770 if ($$segDataPt =~ /^Ducky/) {
4771 $dumpType = 'Ducky';
4772 my %dirInfo = (
4773 DataPt => $segDataPt,
4774 DataPos => $segPos,
4775 DirStart => 5,
4776 DirLen => $length - 5,
4777 );
4778 my $tagTablePtr = GetTagTable('Image::ExifTool::APP12::Ducky');
4779 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
4780 } else {
4781 my %dirInfo = ( DataPt => $segDataPt );
4782 my $tagTablePtr = GetTagTable('Image::ExifTool::APP12::PictureInfo');
4783 $self->ProcessDirectory(\%dirInfo, $tagTablePtr) and $dumpType = 'Picture Info';
4784 }
4785 } elsif ($marker == 0xed) { # APP13 (Photoshop, Adobe_CM)
4786 my $isOld;
4787 if ($$segDataPt =~ /^$psAPP13hdr/ or ($$segDataPt =~ /^$psAPP13old/ and $isOld=1)) {
4788 $dumpType = 'Photoshop';
4789 # add this data to the combined data if it exists
4790 my $dataPt = $segDataPt;
4791 if (defined $combinedSegData) {
4792 $combinedSegData .= substr($$segDataPt,length($psAPP13hdr));
4793 $dataPt = \$combinedSegData;
4794 }
4795 # peek ahead to see if the next segment is photoshop data too
4796 if ($nextMarker == $marker and $$nextSegDataPt =~ /^$psAPP13hdr/) {
4797 # initialize combined data if necessary
4798 $combinedSegData = $$segDataPt unless defined $combinedSegData;
4799 # (will handle the Photoshop data the next time around)
4800 } else {
4801 my $hdrlen = $isOld ? 27 : 14;
4802 # process APP13 Photoshop record
4803 my $tagTablePtr = GetTagTable('Image::ExifTool::Photoshop::Main');
4804 my %dirInfo = (
4805 DataPt => $dataPt,
4806 DataPos => $segPos,
4807 DataLen => length $$dataPt,
4808 DirStart => $hdrlen, # directory starts after identifier
4809 DirLen => length($$dataPt) - $hdrlen,
4810 Parent => $markerName,
4811 );
4812 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
4813 undef $combinedSegData;
4814 }
4815 } elsif ($$segDataPt =~ /^Adobe_CM/) {
4816 $dumpType = 'Adobe_CM';
4817 SetByteOrder('MM');
4818 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::AdobeCM');
4819 my %dirInfo = (
4820 DataPt => $segDataPt,
4821 DataPos => $segPos,
4822 DirStart => 8,
4823 DirLen => $length - 8,
4824 );
4825 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
4826 }
4827 } elsif ($marker == 0xee) { # APP14 (Adobe)
4828 if ($$segDataPt =~ /^Adobe/) {
4829 $dumpType = 'Adobe';
4830 SetByteOrder('MM');
4831 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::Adobe');
4832 my %dirInfo = (
4833 DataPt => $segDataPt,
4834 DataPos => $segPos,
4835 DirStart => 5,
4836 DirLen => $length - 5,
4837 );
4838 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
4839 }
4840 } elsif ($marker == 0xef) { # APP15 (GraphicConverter)
4841 if ($$segDataPt =~ /^Q\s*(\d+)/ and $length == 4) {
4842 $dumpType = 'GraphicConverter';
4843 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::GraphConv');
4844 $self->HandleTag($tagTablePtr, 'Q', $1);
4845 }
4846 } elsif ($marker == 0xfe) { # COM (JPEG comment)
4847 $dumpType = 'Comment';
4848 $$segDataPt =~ s/\0+$//; # some dumb softwares add null terminators
4849 $self->FoundTag('Comment', $$segDataPt);
4850 } elsif (($marker & 0xf0) != 0xe0) {
4851 undef $dumpType; # only dump unknown APP segments
4852 }
4853 if (defined $dumpType) {
4854 if (not $dumpType and $self->{OPTIONS}{Unknown}) {
4855 $self->Warn("Unknown $markerName segment", 1);
4856 }
4857 if ($htmlDump) {
4858 my $desc = $markerName . ($dumpType ? " $dumpType" : '') . ' segment';
4859 $self->HDump($segPos-4, $length+4, $desc, undef, 0x08);
4860 $dumpEnd = $segPos + $length;
4861 }
4862 }
4863 undef $$segDataPt;
4864 }
4865 # calculate JPEGDigest if requested
4866 if (@dqt and $subSampling) {
4867 require Image::ExifTool::JPEGDigest;
4868 Image::ExifTool::JPEGDigest::Calculate($self, \@dqt, $subSampling);
4869 }
4870 $self->Warn('Error reading PreviewImage', 1) if $$self{PreviewError};
4871 $self->Warn('Invalid extended XMP') if %extendedXMP;
4872 $success or $self->Warn('JPEG format error');
4873 pop @$path if @$path > $pn;
4874 return 1;
4875}
4876
4877#------------------------------------------------------------------------------
4878# Process EXIF file
4879# Inputs/Returns: same as ProcessTIFF
4880sub ProcessEXIF($$;$)
4881{
4882 my ($self, $dirInfo, $tagTablePtr) = @_;
4883 return $self->ProcessTIFF($dirInfo, $tagTablePtr);
4884}
4885
4886#------------------------------------------------------------------------------
4887# Process TIFF data (wrapper for DoProcessTIFF to allow re-entry)
4888# Inputs: 0) ExifTool object ref, 1) dirInfo ref, 2) optional tag table ref
4889# Returns: 1 if this looked like a valid EXIF block, 0 otherwise, or -1 on write error
4890sub ProcessTIFF($$;$)
4891{
4892 my ($self, $dirInfo, $tagTablePtr) = @_;
4893 my $exifData = $$self{EXIF_DATA};
4894 my $exifPos = $$self{EXIF_POS};
4895 my $rtnVal = $self->DoProcessTIFF($dirInfo, $tagTablePtr);
4896 # restore original EXIF information (in case ProcessTIFF is nested)
4897 if (defined $exifData) {
4898 $$self{EXIF_DATA} = $exifData;
4899 $$self{EXIF_POS} = $exifPos;
4900 }
4901 return $rtnVal;
4902}
4903
4904#------------------------------------------------------------------------------
4905# Process TIFF data
4906# Inputs: 0) ExifTool object ref, 1) dirInfo ref, 2) optional tag table ref
4907# Returns: 1 if this looked like a valid EXIF block, 0 otherwise, or -1 on write error
4908sub DoProcessTIFF($$;$)
4909{
4910 my ($self, $dirInfo, $tagTablePtr) = @_;
4911 my $dataPt = $$dirInfo{DataPt};
4912 my $fileType = $$dirInfo{Parent} || '';
4913 my $raf = $$dirInfo{RAF};
4914 my $base = $$dirInfo{Base} || 0;
4915 my $outfile = $$dirInfo{OutFile};
4916 my ($err, $canonSig, $otherSig);
4917
4918 # attempt to read TIFF header
4919 $self->{EXIF_DATA} = '';
4920 if ($raf) {
4921 if ($outfile) {
4922 $raf->Seek(0, 0) or return 0;
4923 if ($base) {
4924 $raf->Read($$dataPt, $base) == $base or return 0;
4925 Write($outfile, $$dataPt) or $err = 1;
4926 }
4927 } else {
4928 $raf->Seek($base, 0) or return 0;
4929 }
4930 # extract full EXIF block (for block copy) from EXIF file
4931 my $amount = $fileType eq 'EXIF' ? 65536 * 8 : 8;
4932 my $n = $raf->Read($self->{EXIF_DATA}, $amount);
4933 if ($n < 8) {
4934 return 0 if $n or not $outfile or $fileType ne 'EXIF';
4935 # create EXIF file from scratch
4936 delete $self->{EXIF_DATA};
4937 undef $raf;
4938 }
4939 if ($n > 8) {
4940 $raf->Seek(8, 0);
4941 if ($n == $amount) {
4942 $self->{EXIF_DATA} = substr($self->{EXIF_DATA}, 0, 8);
4943 $self->Warn('EXIF too large to extract as a block'); #(shouldn't happen)
4944 }
4945 }
4946 } elsif ($dataPt and length $$dataPt) {
4947 # save a copy of the EXIF data
4948 my $dirStart = $$dirInfo{DirStart} || 0;
4949 my $dirLen = $$dirInfo{DirLen} || (length($$dataPt) - $dirStart);
4950 $self->{EXIF_DATA} = substr($$dataPt, $dirStart, $dirLen);
4951 $self->VerboseDir('TIFF') if $self->{OPTIONS}{Verbose} and length($$self{INDENT}) > 2;
4952 } elsif ($outfile) {
4953 delete $self->{EXIF_DATA}; # create from scratch
4954 } else {
4955 $self->{EXIF_DATA} = '';
4956 }
4957 unless (defined $self->{EXIF_DATA}) {
4958 # create TIFF information from scratch
4959 if ($self->SetPreferredByteOrder() eq 'MM') {
4960 $self->{EXIF_DATA} = "MM\0\x2a\0\0\0\x08";
4961 } else {
4962 $self->{EXIF_DATA} = "II\x2a\0\x08\0\0\0";
4963 }
4964 }
4965 $$self{FIRST_EXIF_POS} = $base + $$self{BASE} unless defined $$self{FIRST_EXIF_POS};
4966 $$self{EXIF_POS} = $base + $$self{BASE};
4967 $dataPt = \$self->{EXIF_DATA};
4968
4969 # set byte ordering
4970 my $byteOrder = substr($$dataPt,0,2);
4971 SetByteOrder($byteOrder) or return 0;
4972
4973 # verify the byte ordering
4974 my $identifier = Get16u($dataPt, 2);
4975 # identifier is 0x2a for TIFF (but 0x4f52, 0x5352 or ?? for ORF)
4976 # no longer do this because various files use different values
4977 # (TIFF=0x2a, RW2/RWL=0x55, HDP=0xbc, BTF=0x2b, ORF=0x4f52/0x5352/0x????)
4978 # return 0 unless $identifier == 0x2a;
4979
4980 # get offset to IFD0
4981 my $offset = Get32u($dataPt, 4);
4982 $offset >= 8 or return 0;
4983
4984 if ($raf) {
4985 # Canon CR2 images usually have an offset of 16, but it may be
4986 # greater if edited by PhotoMechanic, so check the 4-byte signature
4987 if ($identifier == 0x2a and $offset >= 16) {
4988 $raf->Read($canonSig, 8) == 8 or return 0;
4989 $$dataPt .= $canonSig;
4990 if ($canonSig =~ /^(CR\x02\0|\xba\xb0\xac\xbb)/) {
4991 $fileType = $canonSig =~ /^CR/ ? 'CR2' : 'Canon 1D RAW';
4992 $self->HDump($base+8, 8, "[$fileType header]") if $self->{HTML_DUMP};
4993 } else {
4994 undef $canonSig;
4995 }
4996 } elsif ($identifier == 0x55 and $fileType =~ /^(RAW|RW2|RWL|TIFF)$/) {
4997 # panasonic RAW, RW2 or RWL file
4998 my $magic;
4999 # test for RW2/RWL magic number
5000 if ($offset >= 0x18 and $raf->Read($magic, 16) and
5001 $magic eq "\x88\xe7\x74\xd8\xf8\x25\x1d\x4d\x94\x7a\x6e\x77\x82\x2b\x5d\x6a")
5002 {
5003 $fileType = 'RW2' unless $fileType eq 'RWL';
5004 $self->HDump($base + 8, 16, '[RW2/RWL header]') if $$self{HTML_DUMP};
5005 $otherSig = $magic; # save signature for writing
5006 } else {
5007 $fileType = 'RAW';
5008 }
5009 $tagTablePtr = GetTagTable('Image::ExifTool::PanasonicRaw::Main');
5010 } elsif ($identifier == 0x2b and $fileType eq 'TIFF') {
5011 # this looks like a BigTIFF image
5012 $raf->Seek(0);
5013 require Image::ExifTool::BigTIFF;
5014 return 1 if Image::ExifTool::BigTIFF::ProcessBTF($self, $dirInfo);
5015 } elsif (Get8u($dataPt, 2) == 0xbc and $byteOrder eq 'II' and $fileType eq 'TIFF') {
5016 $fileType = 'HDP'; # Windows HD Photo file
5017 # check version number
5018 my $ver = Get8u($dataPt, 3);
5019 if ($ver > 1) {
5020 $self->Error("Windows HD Photo version $ver files not yet supported");
5021 return 1;
5022 }
5023 } elsif ($identifier == 0x4352 and $fileType eq 'TIFF') {
5024 $fileType = 'DCP';
5025 }
5026 # we have a valid TIFF (or whatever) file
5027 if ($fileType and not $self->{VALUE}{FileType}) {
5028 my $lookup = $fileTypeLookup{$fileType};
5029 $lookup = $fileTypeLookup{$lookup} unless ref $lookup or not $lookup;
5030 # use file extension to pre-determine type if extension is TIFF-based or type is RAW
5031 my $t = (($lookup and $$lookup[0] eq 'TIFF') or $fileType =~ /RAW/) ? $fileType : undef;
5032 $self->SetFileType($t);
5033 }
5034 }
5035 my $ifdName = 'IFD0';
5036 if (not $tagTablePtr or $$tagTablePtr{GROUPS}{0} eq 'EXIF') {
5037 $self->FoundTag('ExifByteOrder', $byteOrder);
5038 } else {
5039 $ifdName = $$tagTablePtr{GROUPS}{1};
5040 }
5041 if ($self->{HTML_DUMP}) {
5042 my $tip = sprintf("Byte order: %s endian\nIdentifier: 0x%.4x\n$ifdName offset: 0x%.4x",
5043 ($byteOrder eq 'II') ? 'Little' : 'Big', $identifier, $offset);
5044 $self->HDump($base, 8, 'TIFF header', $tip, 0);
5045 }
5046 # remember where we found the TIFF data (APP1, APP3, TIFF, NEF, etc...)
5047 $self->{TIFF_TYPE} = $fileType;
5048
5049 # get reference to the main EXIF table
5050 $tagTablePtr or $tagTablePtr = GetTagTable('Image::ExifTool::Exif::Main');
5051
5052 # build directory information hash
5053 my %dirInfo = (
5054 Base => $base,
5055 DataPt => $dataPt,
5056 DataLen => length $$dataPt,
5057 DataPos => 0,
5058 DirStart => $offset,
5059 DirLen => length($$dataPt) - $offset,
5060 RAF => $raf,
5061 DirName => $ifdName,
5062 Parent => $fileType,
5063 ImageData=> 'Main', # set flag to get information to copy main image data later
5064 Multi => $$dirInfo{Multi},
5065 );
5066
5067 # extract information from the image
5068 unless ($outfile) {
5069 # process the directory
5070 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
5071 # process GeoTiff information if available
5072 if ($self->{VALUE}{GeoTiffDirectory}) {
5073 require Image::ExifTool::GeoTiff;
5074 Image::ExifTool::GeoTiff::ProcessGeoTiff($self);
5075 }
5076 # process information in recognized trailers
5077 if ($raf) {
5078 my $trailInfo = IdentifyTrailer($raf);
5079 if ($trailInfo) {
5080 $$trailInfo{ScanForAFCP} = 1; # scan to find AFCP if necessary
5081 $self->ProcessTrailers($trailInfo);
5082 }
5083 # dump any other known trailer (ie. A100 RAW Data)
5084 if ($$self{HTML_DUMP} and $$self{KnownTrailer}) {
5085 my $known = $$self{KnownTrailer};
5086 $raf->Seek(0, 2);
5087 my $len = $raf->Tell() - $$known{Start};
5088 $len -= $$trailInfo{Offset} if $trailInfo; # account for other trailers
5089 $self->HDump($$known{Start}, $len, "[$$known{Name}]") if $len > 0;
5090 }
5091 }
5092 # update FileType if necessary now that we know more about the file
5093 if ($$self{DNGVersion} and $self->{VALUE}{FileType} ne 'DNG') {
5094 # override whatever FileType we set since we now know it is DNG
5095 $self->OverrideFileType('DNG');
5096 }
5097 return 1;
5098 }
5099#
5100# rewrite the image
5101#
5102 if ($$dirInfo{NoTiffEnd}) {
5103 delete $self->{TIFF_END};
5104 } else {
5105 # initialize TIFF_END so it will be updated by WriteExif()
5106 $self->{TIFF_END} = 0;
5107 }
5108 if ($canonSig) {
5109 # write Canon CR2 specially because it has a header we want to preserve,
5110 # and possibly trailers added by the Canon utilities and/or PhotoMechanic
5111 $dirInfo{OutFile} = $outfile;
5112 require Image::ExifTool::CanonRaw;
5113 Image::ExifTool::CanonRaw::WriteCR2($self, \%dirInfo, $tagTablePtr) or $err = 1;
5114 } else {
5115 # write TIFF header (8 bytes [plus optional signature] followed by IFD)
5116 $otherSig = '' unless defined $otherSig;
5117 my $offset = 8 + length($otherSig);
5118 # construct tiff header
5119 my $header = substr($$dataPt, 0, 4) . Set32u($offset) . $otherSig;
5120 $dirInfo{NewDataPos} = $offset;
5121 $dirInfo{HeaderPtr} = \$header;
5122 # preserve padding between image data blocks in ORF images
5123 # (otherwise dcraw has problems because it assumes fixed block spacing)
5124 $dirInfo{PreserveImagePadding} = 1 if $fileType eq 'ORF' or $identifier != 0x2a;
5125 my $newData = $self->WriteDirectory(\%dirInfo, $tagTablePtr);
5126 if (not defined $newData) {
5127 $err = 1;
5128 } elsif (length($newData)) {
5129 # update header length in case more was added
5130 my $hdrLen = length $header;
5131 if ($hdrLen != 8) {
5132 Set32u($hdrLen, \$header, 4);
5133 # also update preview fixup if necessary
5134 my $pi = $$self{PREVIEW_INFO};
5135 $$pi{Fixup}{Start} += $hdrLen - 8 if $pi and $$pi{Fixup};
5136 }
5137 if ($$self{TIFF_TYPE} eq 'ARW' and not $err) {
5138 # write any required ARW trailer and patch other ARW quirks
5139 require Image::ExifTool::Sony;
5140 my $errStr = Image::ExifTool::Sony::FinishARW($self, $dirInfo, \$newData,
5141 $dirInfo{ImageData});
5142 $errStr and $self->Error($errStr);
5143 delete $dirInfo{ImageData}; # (was copied by FinishARW)
5144 } else {
5145 Write($outfile, $header, $newData) or $err = 1;
5146 }
5147 undef $newData; # free memory
5148 }
5149 # copy over image data now if necessary
5150 if (ref $dirInfo{ImageData} and not $err) {
5151 $self->CopyImageData($dirInfo{ImageData}, $outfile) or $err = 1;
5152 delete $dirInfo{ImageData};
5153 }
5154 }
5155 # make local copy of TIFF_END now (it may be reset when processing trailers)
5156 my $tiffEnd = $self->{TIFF_END};
5157 delete $self->{TIFF_END};
5158
5159 # rewrite trailers if they exist
5160 if ($raf and $tiffEnd and not $err) {
5161 my ($buf, $trailInfo);
5162 $raf->Seek(0, 2) or $err = 1;
5163 my $extra = $raf->Tell() - $tiffEnd;
5164 # check for trailer and process if possible
5165 for (;;) {
5166 last unless $extra > 12;
5167 $raf->Seek($tiffEnd); # seek back to end of image
5168 $trailInfo = IdentifyTrailer($raf);
5169 last unless $trailInfo;
5170 my $tbuf = '';
5171 $$trailInfo{OutFile} = \$tbuf; # rewrite trailer(s)
5172 $$trailInfo{ScanForAFCP} = 1; # scan for AFCP if necessary
5173 # rewrite all trailers to buffer
5174 unless ($self->ProcessTrailers($trailInfo)) {
5175 undef $trailInfo;
5176 $err = 1;
5177 last;
5178 }
5179 # calculate unused bytes before trailer
5180 $extra = $$trailInfo{DataPos} - $tiffEnd;
5181 last; # yes, the 'for' loop was just a cheap 'goto'
5182 }
5183 # ignore a single zero byte if used for padding
5184 if ($extra > 0 and $tiffEnd & 0x01) {
5185 $raf->Seek($tiffEnd, 0) or $err = 1;
5186 $raf->Read($buf, 1) or $err = 1;
5187 defined $buf and $buf eq "\0" and --$extra, ++$tiffEnd;
5188 }
5189 if ($extra > 0) {
5190 my $known = $$self{KnownTrailer};
5191 if ($self->{DEL_GROUP}{Trailer} and not $known) {
5192 $self->VPrint(0, " Deleting unknown trailer ($extra bytes)\n");
5193 ++$self->{CHANGED};
5194 } elsif ($known) {
5195 $self->VPrint(0, " Copying $$known{Name} ($extra bytes)\n");
5196 $raf->Seek($tiffEnd, 0) or $err = 1;
5197 CopyBlock($raf, $outfile, $extra) or $err = 1;
5198 } else {
5199 $raf->Seek($tiffEnd, 0) or $err = 1;
5200 # preserve unknown trailer only if it contains non-null data
5201 # (Photoshop CS adds a trailer with 2 null bytes)
5202 my $size = $extra;
5203 for (;;) {
5204 my $n = $size > 65536 ? 65536 : $size;
5205 $raf->Read($buf, $n) == $n or $err = 1, last;
5206 if ($buf =~ /[^\0]/) {
5207 $self->VPrint(0, " Preserving unknown trailer ($extra bytes)\n");
5208 # copy the trailer since it contains non-null data
5209 Write($outfile, "\0"x($extra-$size)) or $err = 1, last if $size != $extra;
5210 Write($outfile, $buf) or $err = 1, last;
5211 CopyBlock($raf, $outfile, $size-$n) or $err = 1 if $size > $n;
5212 last;
5213 }
5214 $size -= $n;
5215 next if $size > 0;
5216 $self->VPrint(0, " Deleting blank trailer ($extra bytes)\n");
5217 last;
5218 }
5219 }
5220 }
5221 # write trailer buffer if necessary
5222 $self->WriteTrailerBuffer($trailInfo, $outfile) or $err = 1 if $trailInfo;
5223 # add any new trailers we are creating
5224 my $trailPt = $self->AddNewTrailers();
5225 Write($outfile, $$trailPt) or $err = 1 if $trailPt;
5226 }
5227 # check DNG version
5228 if ($$self{DNGVersion}) {
5229 my $ver = $$self{DNGVersion};
5230 # currently support up to DNG version 1.2
5231 unless ($ver =~ /^(\d+) (\d+)/ and "$1.$2" <= 1.3) {
5232 $ver =~ tr/ /./;
5233 $self->Error("DNG Version $ver not yet supported", 1);
5234 }
5235 }
5236 return $err ? -1 : 1;
5237}
5238
5239#------------------------------------------------------------------------------
5240# Return list of tag table keys (ignoring special keys)
5241# Inputs: 0) reference to tag table
5242# Returns: List of table keys (unsorted)
5243sub TagTableKeys($)
5244{
5245 local $_;
5246 my $tagTablePtr = shift;
5247 my @keyList;
5248 foreach (keys %$tagTablePtr) {
5249 push(@keyList, $_) unless $specialTags{$_};
5250 }
5251 return @keyList;
5252}
5253
5254#------------------------------------------------------------------------------
5255# GetTagTable
5256# Inputs: 0) table name
5257# Returns: tag table reference, or undefined if not found
5258# Notes: Always use this function instead of requiring module and using table
5259# directly since this function also does the following the first time the table
5260# is loaded:
5261# - requires new module if necessary
5262# - generates default GROUPS hash and Group 0 name from module name
5263# - registers Composite tags if Composite table found
5264# - saves descriptions for tags in specified table
5265# - generates default TAG_PREFIX to be used for unknown tags
5266sub GetTagTable($)
5267{
5268 my $tableName = shift or return undef;
5269 my $table = $allTables{$tableName};
5270
5271 unless ($table) {
5272 no strict 'refs';
5273 unless (%$tableName) {
5274 # try to load module for this table
5275 if ($tableName =~ /(.*)::/) {
5276 my $module = $1;
5277 if (eval "require $module") {
5278 # load additional XMP modules if required
5279 if (not %$tableName and $module eq 'Image::ExifTool::XMP') {
5280 require 'Image/ExifTool/XMP2.pl';
5281 }
5282 } else {
5283 $@ and warn $@;
5284 }
5285 }
5286 unless (%$tableName) {
5287 warn "Can't find table $tableName\n";
5288 return undef;
5289 }
5290 }
5291 no strict 'refs';
5292 $table = \%$tableName;
5293 use strict 'refs';
5294 $$table{TABLE_NAME} = $tableName; # set table name
5295 ($$table{SHORT_NAME} = $tableName) =~ s/^Image::ExifTool:://;
5296 # set default group 0 and 1 from module name unless already specified
5297 my $defaultGroups = $$table{GROUPS};
5298 $defaultGroups or $defaultGroups = $$table{GROUPS} = { };
5299 unless ($$defaultGroups{0} and $$defaultGroups{1}) {
5300 if ($tableName =~ /Image::.*?::([^:]*)/) {
5301 $$defaultGroups{0} = $1 unless $$defaultGroups{0};
5302 $$defaultGroups{1} = $1 unless $$defaultGroups{1};
5303 } else {
5304 $$defaultGroups{0} = $tableName unless $$defaultGroups{0};
5305 $$defaultGroups{1} = $tableName unless $$defaultGroups{1};
5306 }
5307 }
5308 $$defaultGroups{2} = 'Other' unless $$defaultGroups{2};
5309 if ($$defaultGroups{0} eq 'XMP' or $$table{NAMESPACE}) {
5310 # initialize some XMP table defaults
5311 require Image::ExifTool::XMP;
5312 Image::ExifTool::XMP::RegisterNamespace($table); # register all table namespaces
5313 # set default write/check procs
5314 $$table{WRITE_PROC} = \&Image::ExifTool::XMP::WriteXMP unless $$table{WRITE_PROC};
5315 $$table{CHECK_PROC} = \&Image::ExifTool::XMP::CheckXMP unless $$table{CHECK_PROC};
5316 $$table{LANG_INFO} = \&Image::ExifTool::XMP::GetLangInfo unless $$table{LANG_INFO};
5317 }
5318 # generate a tag prefix for unknown tags if necessary
5319 unless ($$table{TAG_PREFIX}) {
5320 my $tagPrefix;
5321 if ($tableName =~ /Image::.*?::(.*)::Main/ || $tableName =~ /Image::.*?::(.*)/) {
5322 ($tagPrefix = $1) =~ s/::/_/g;
5323 } else {
5324 $tagPrefix = $tableName;
5325 }
5326 $$table{TAG_PREFIX} = $tagPrefix;
5327 }
5328 # set up the new table
5329 SetupTagTable($table);
5330 # add any user-defined tags
5331 if (%UserDefined and $UserDefined{$tableName}) {
5332 my $tagID;
5333 foreach $tagID (TagTableKeys($UserDefined{$tableName})) {
5334 my $tagInfo = $UserDefined{$tableName}{$tagID};
5335 if (ref $tagInfo eq 'HASH') {
5336 $$tagInfo{Name} or $$tagInfo{Name} = ucfirst($tagID);
5337 } else {
5338 $tagInfo = { Name => $tagInfo };
5339 }
5340 if ($$table{WRITABLE} and not defined $$tagInfo{Writable} and
5341 not $$tagInfo{SubDirectory})
5342 {
5343 $$tagInfo{Writable} = $$table{WRITABLE};
5344 }
5345 delete $$table{$tagID}; # replace any existing entry
5346 AddTagToTable($table, $tagID, $tagInfo);
5347 }
5348 }
5349 # remember order we loaded the tables in
5350 push @tableOrder, $tableName;
5351 # insert newly loaded table into list
5352 $allTables{$tableName} = $table;
5353 }
5354 return $table;
5355}
5356
5357#------------------------------------------------------------------------------
5358# Process an image directory
5359# Inputs: 0) ExifTool object reference, 1) directory information reference
5360# 2) tag table reference, 3) optional reference to processing procedure
5361# Returns: Result from processing (1=success)
5362sub ProcessDirectory($$$;$)
5363{
5364 my ($self, $dirInfo, $tagTablePtr, $proc) = @_;
5365
5366 return 0 unless $tagTablePtr and $dirInfo;
5367 # use default proc from tag table or EXIF proc as fallback if no proc specified
5368 $proc or $proc = $$tagTablePtr{PROCESS_PROC} || \&Image::ExifTool::Exif::ProcessExif;
5369 # set directory name from default group0 name if not done already
5370 $$dirInfo{DirName} or $$dirInfo{DirName} = $tagTablePtr->{GROUPS}{0};
5371 # guard against cyclical recursion into the same directory
5372 if (defined $$dirInfo{DirStart} and defined $$dirInfo{DataPos}) {
5373 my $addr = $$dirInfo{DirStart} + $$dirInfo{DataPos} + ($$dirInfo{Base}||0);
5374 if ($self->{PROCESSED}{$addr}) {
5375 $self->Warn("$$dirInfo{DirName} pointer references previous $self->{PROCESSED}{$addr} directory");
5376 return 0;
5377 }
5378 $self->{PROCESSED}{$addr} = $$dirInfo{DirName};
5379 }
5380 my $oldOrder = GetByteOrder();
5381 my $oldIndent = $self->{INDENT};
5382 my $oldDir = $self->{DIR_NAME};
5383 $self->{LIST_TAGS} = { }; # don't build lists across different directories
5384 $self->{INDENT} .= '| ';
5385 $self->{DIR_NAME} = $$dirInfo{DirName};
5386 push @{$self->{PATH}}, $$dirInfo{DirName};
5387
5388 # process the directory
5389 my $rtnVal = &$proc($self, $dirInfo, $tagTablePtr);
5390
5391 pop @{$self->{PATH}};
5392 $self->{INDENT} = $oldIndent;
5393 $self->{DIR_NAME} = $oldDir;
5394 SetByteOrder($oldOrder);
5395 return $rtnVal;
5396}
5397
5398#------------------------------------------------------------------------------
5399# Get Metadata path
5400# Inputs: 0) Exiftool object ref
5401# Return: Metadata path string
5402sub MetadataPath($)
5403{
5404 my $self = shift;
5405 return join '-', @{$$self{PATH}}
5406}
5407
5408#------------------------------------------------------------------------------
5409# Get standardized file extension
5410# Inputs: 0) file name
5411# Returns: standardized extension (all uppercase), or undefined if no extension
5412sub GetFileExtension($)
5413{
5414 my $filename = shift;
5415 my $fileExt;
5416 if ($filename and $filename =~ /.*\.(.+)$/) {
5417 $fileExt = uc($1); # change extension to upper case
5418 # convert TIF extension to TIFF because we use the
5419 # extension for the file type tag of TIFF images
5420 $fileExt eq 'TIF' and $fileExt = 'TIFF';
5421 }
5422 return $fileExt;
5423}
5424
5425#------------------------------------------------------------------------------
5426# Get list of tag information hashes for given tag ID
5427# Inputs: 0) Tag table reference, 1) tag ID
5428# Returns: Array of tag information references
5429# Notes: Generates tagInfo hash if necessary
5430sub GetTagInfoList($$)
5431{
5432 my ($tagTablePtr, $tagID) = @_;
5433 my $tagInfo = $$tagTablePtr{$tagID};
5434
5435 if (ref $tagInfo eq 'HASH') {
5436 return ($tagInfo);
5437 } elsif (ref $tagInfo eq 'ARRAY') {
5438 return @$tagInfo;
5439 } elsif ($tagInfo) {
5440 # create hash with name
5441 $tagInfo = $$tagTablePtr{$tagID} = { Name => $tagInfo };
5442 return ($tagInfo);
5443 }
5444 return ();
5445}
5446
5447#------------------------------------------------------------------------------
5448# Find tag information, processing conditional tags
5449# Inputs: 0) ExifTool object reference, 1) tagTable pointer, 2) tag ID
5450# 3) optional value reference, 4) optional format type, 5) optional value count
5451# Returns: pointer to tagInfo hash, undefined if none found, or '' if $valPt needed
5452# Notes: You should always call this routine to find a tag in a table because
5453# this routine will evaluate conditional tags.
5454# Arguments 3-5 are only required if the information type allows $valPt, $format and/or
5455# $count in a Condition, and if not given when needed this routine returns ''.
5456sub GetTagInfo($$$;$$$)
5457{
5458 my ($self, $tagTablePtr, $tagID) = @_;
5459 my ($valPt, $format, $count);
5460
5461 my @infoArray = GetTagInfoList($tagTablePtr, $tagID);
5462 # evaluate condition
5463 my $tagInfo;
5464 foreach $tagInfo (@infoArray) {
5465 my $condition = $$tagInfo{Condition};
5466 if ($condition) {
5467 ($valPt, $format, $count) = splice(@_, 3) if @_ > 3;
5468 return '' if $condition =~ /\$(valPt|format|count)\b/ and not defined $valPt;
5469 # set old value for use in condition if needed
5470 local $SIG{'__WARN__'} = \&SetWarning;
5471 undef $evalWarning;
5472 #### eval Condition ($self, [$valPt, $format, $count])
5473 unless (eval $condition) {
5474 $@ and $evalWarning = $@;
5475 $self->Warn("Condition $$tagInfo{Name}: " . CleanWarning()) if $evalWarning;
5476 next;
5477 }
5478 }
5479 if ($$tagInfo{Unknown} and not $$self{OPTIONS}{Unknown} and not $$self{OPTIONS}{Verbose}) {
5480 # don't return Unknown tags unless that option is set
5481 return undef;
5482 }
5483 # return the tag information we found
5484 return $tagInfo;
5485 }
5486 # generate information for unknown tags (numerical only) if required
5487 if (not $tagInfo and ($$self{OPTIONS}{Unknown} or $$self{OPTIONS}{Verbose}) and
5488 $tagID =~ /^\d+$/ and not $$self{NO_UNKNOWN})
5489 {
5490 my $printConv;
5491 if (defined $$tagTablePtr{PRINT_CONV}) {
5492 $printConv = $$tagTablePtr{PRINT_CONV};
5493 } else {
5494 # limit length of printout (can be very long)
5495 $printConv = 'length($val) > 60 ? substr($val,0,55) . "[...]" : $val';
5496 }
5497 my $hex = sprintf("0x%.4x", $tagID);
5498 my $prefix = $$tagTablePtr{TAG_PREFIX};
5499 $tagInfo = {
5500 Name => "${prefix}_$hex",
5501 Description => MakeDescription($prefix, $hex),
5502 Unknown => 1,
5503 Writable => 0, # can't write unknown tags
5504 PrintConv => $printConv,
5505 };
5506 # add tag information to table
5507 AddTagToTable($tagTablePtr, $tagID, $tagInfo);
5508 } else {
5509 undef $tagInfo;
5510 }
5511 return $tagInfo;
5512}
5513
5514#------------------------------------------------------------------------------
5515# Add new tag to table (must use this routine to add new tags to a table)
5516# Inputs: 0) reference to tag table, 1) tag ID
5517# 2) [optional] reference to tag information hash
5518# Notes: - will not overwrite existing entry in table
5519# - info need contain no entries when this routine is called
5520sub AddTagToTable($$;$)
5521{
5522 my ($tagTablePtr, $tagID, $tagInfo) = @_;
5523 $tagInfo or $tagInfo = { };
5524
5525 # define necessary entries in information hash
5526 if ($$tagInfo{Groups}) {
5527 # fill in default groups from table GROUPS
5528 foreach (keys %{$$tagTablePtr{GROUPS}}) {
5529 next if $tagInfo->{Groups}{$_};
5530 $tagInfo->{Groups}{$_} = $tagTablePtr->{GROUPS}{$_};
5531 }
5532 } else {
5533 $$tagInfo{Groups} = { %{$$tagTablePtr{GROUPS}} };
5534 }
5535 $$tagInfo{Flags} and ExpandFlags($tagInfo);
5536 $$tagInfo{GotGroups} = 1,
5537 $$tagInfo{Table} = $tagTablePtr;
5538 $$tagInfo{TagID} = $tagID;
5539
5540 my $name = $$tagInfo{Name};
5541 if (defined $name) {
5542 $name =~ tr/-_a-zA-Z0-9//dc; # remove illegal characters
5543 } else {
5544 # construct a name from the tag ID
5545 $name = $tagID;
5546 $name =~ tr/-_a-zA-Z0-9//dc; # remove illegal characters
5547 $name = ucfirst $name; # start with uppercase
5548 # make sure name is a reasonable length
5549 my $prefix = $$tagTablePtr{TAG_PREFIX};
5550 if ($prefix) {
5551 # make description to prevent tagID from getting mangled by MakeDescription()
5552 $$tagInfo{Description} = MakeDescription($prefix, $name);
5553 $name = "${prefix}_$name";
5554 }
5555 }
5556 # tag names must be at least 2 characters long and begin with a letter
5557 $name = "Tag$name" if length($name) <= 1 or $name !~ /^[A-Z]/i;
5558 $$tagInfo{Name} = $name;
5559 # add tag to table, but never overwrite existing entries (could potentially happen
5560 # if someone thinks there isn't any tagInfo because a condition wasn't satisfied)
5561 $$tagTablePtr{$tagID} = $tagInfo unless defined $$tagTablePtr{$tagID};
5562}
5563
5564#------------------------------------------------------------------------------
5565# Handle simple extraction of new tag information
5566# Inputs: 0) ExifTool object ref, 1) tag table reference, 2) tagID, 3) value,
5567# 4-N) parameters hash: Index, DataPt, DataPos, Start, Size, Parent,
5568# TagInfo, ProcessProc, RAF
5569# Returns: tag key or undef if tag not found
5570# Notes: if value is not defined, it is extracted from DataPt using TagInfo
5571# Format and Count if provided
5572sub HandleTag($$$$;%)
5573{
5574 my ($self, $tagTablePtr, $tag, $val, %parms) = @_;
5575 my $verbose = $self->{OPTIONS}{Verbose};
5576 my $tagInfo = $parms{TagInfo} || $self->GetTagInfo($tagTablePtr, $tag, \$val);
5577 my $dataPt = $parms{DataPt};
5578 my ($subdir, $format, $count, $size, $noTagInfo);
5579
5580 if ($tagInfo) {
5581 $subdir = $$tagInfo{SubDirectory}
5582 } else {
5583 return undef unless $verbose;
5584 $tagInfo = { Name => "tag $tag" }; # create temporary tagInfo hash
5585 $noTagInfo = 1;
5586 }
5587 # read value if not done already (not necessary for subdir)
5588 unless (defined $val or ($subdir and not $$tagInfo{Writable})) {
5589 my $start = $parms{Start} || 0;
5590 my $size = $parms{Size} || 0;
5591 # read from data in memory if possible
5592 if ($dataPt and $start >= 0 and $start + $size <= length($$dataPt)) {
5593 $format = $$tagInfo{Format} || $$tagTablePtr{FORMAT};
5594 if ($format) {
5595 $val = ReadValue($dataPt, $start, $format, $$tagInfo{Count}, $size);
5596 } else {
5597 $val = substr($$dataPt, $start, $size);
5598 }
5599 } else {
5600 $self->Warn("Error extracting value for $$tagInfo{Name}");
5601 return undef;
5602 }
5603 }
5604 # do verbose print if necessary
5605 if ($verbose) {
5606 undef $tagInfo if $noTagInfo;
5607 $parms{Value} = $val;
5608 $parms{Table} = $tagTablePtr;
5609 if ($format) {
5610 $count or $count = int(($parms{Size} || 0) / ($formatSize{$format} || 1));
5611 $parms{Format} = $format . "[$count]";
5612 }
5613 $self->VerboseInfo($tag, $tagInfo, %parms);
5614 }
5615 if ($tagInfo) {
5616 if ($subdir) {
5617 my $subdirStart = $parms{Start};
5618 my $subdirLen = $parms{Size};
5619 if ($$subdir{Start}) {
5620 my $valuePtr = 0;
5621 #### eval Start ($valuePtr)
5622 my $off = eval $$subdir{Start};
5623 $subdirStart += $off;
5624 $subdirLen -= $off;
5625 }
5626 $dataPt or $dataPt = \$val;
5627 # process subdirectory information
5628 my %dirInfo = (
5629 DirName => $$subdir{DirName} || $$tagInfo{Name},
5630 DataPt => $dataPt,
5631 DataLen => length $$dataPt,
5632 DataPos => $parms{DataPos},
5633 DirStart => $subdirStart,
5634 DirLen => $subdirLen,
5635 Parent => $parms{Parent},
5636 Base => $parms{Base},
5637 Multi => $$subdir{Multi},
5638 TagInfo => $tagInfo,
5639 RAF => $parms{RAF},
5640 );
5641 my $oldOrder = GetByteOrder();
5642 SetByteOrder($$subdir{ByteOrder}) if $$subdir{ByteOrder};
5643 my $subTablePtr = GetTagTable($$subdir{TagTable}) || $tagTablePtr;
5644 $self->ProcessDirectory(\%dirInfo, $subTablePtr, $$subdir{ProcessProc} || $parms{ProcessProc});
5645 SetByteOrder($oldOrder);
5646 # return now unless directory is writable as a block
5647 return undef unless $$tagInfo{Writable};
5648 }
5649 return $self->FoundTag($tagInfo, $val);
5650 }
5651 return undef;
5652}
5653
5654#------------------------------------------------------------------------------
5655# Add tag to hash of extracted information
5656# Inputs: 0) ExifTool object reference
5657# 1) reference to tagInfo hash or tag name
5658# 2) data value (or reference to require hash if Composite)
5659# Returns: tag key or undef if no value
5660sub FoundTag($$$)
5661{
5662 local $_;
5663 my ($self, $tagInfo, $value) = @_;
5664 my $tag;
5665
5666 if (ref $tagInfo eq 'HASH') {
5667 $tag = $$tagInfo{Name} or warn("No tag name\n"), return undef;
5668 } else {
5669 $tag = $tagInfo;
5670 # look for tag in Extra
5671 $tagInfo = $self->GetTagInfo(GetTagTable('Image::ExifTool::Extra'), $tag);
5672 # make temporary hash if tag doesn't exist in Extra
5673 # (not advised to do this since the tag won't show in list)
5674 $tagInfo or $tagInfo = { Name => $tag, Groups => \%allGroupsExifTool };
5675 $self->{OPTIONS}{Verbose} and $self->VerboseInfo(undef, $tagInfo, Value => $value);
5676 }
5677 my $rawValueHash = $self->{VALUE};
5678 if ($$tagInfo{RawConv}) {
5679 # initialize @val for use in Composite RawConv expressions
5680 my @val;
5681 if (ref $value eq 'HASH') {
5682 foreach (keys %$value) { $val[$_] = $$rawValueHash{$$value{$_}}; }
5683 }
5684 my $conv = $$tagInfo{RawConv};
5685 local $SIG{'__WARN__'} = \&SetWarning;
5686 undef $evalWarning;
5687 if (ref $conv eq 'CODE') {
5688 $value = &$conv($value, $self);
5689 } else {
5690 my $val = $value; # must do this in case eval references $val
5691 # NOTE: RawConv is also evaluated in Writer.pl
5692 #### eval RawConv ($self, $val, $tag, $tagInfo)
5693 $value = eval $conv;
5694 $@ and $evalWarning = $@;
5695 }
5696 $self->Warn("RawConv $tag: " . CleanWarning()) if $evalWarning;
5697 return undef unless defined $value;
5698 }
5699 # get tag priority
5700 my $priority = $$tagInfo{Priority};
5701 defined $priority or $priority = $tagInfo->{Table}{PRIORITY};
5702 # handle duplicate tag names
5703 if (defined $$rawValueHash{$tag}) {
5704 # add to list if there is an active list for this tag
5705 if ($self->{LIST_TAGS}{$tagInfo}) {
5706 $tag = $self->{LIST_TAGS}{$tagInfo}; # use key from previous list tag
5707 if (ref $$rawValueHash{$tag} ne 'ARRAY') {
5708 $$rawValueHash{$tag} = [ $$rawValueHash{$tag} ];
5709 }
5710 push @{$$rawValueHash{$tag}}, $value;
5711 return $tag; # return without creating a new entry
5712 }
5713 # get next available tag key
5714 my $nextInd = $self->{DUPL_TAG}{$tag} = ($self->{DUPL_TAG}{$tag} || 0) + 1;
5715 my $nextTag = "$tag ($nextInd)";
5716#
5717# take tag with highest priority
5718#
5719 # promote existing 0-priority tag so it takes precedence over a new 0-tag
5720 # (unless old tag was a sub-document and new tag isn't)
5721 my $oldPriority = $self->{PRIORITY}{$tag};
5722 unless ($oldPriority) {
5723 if ($self->{DOC_NUM} or not $self->{TAG_EXTRA}{$tag} or
5724 not $self->{TAG_EXTRA}{$tag}{G3})
5725 {
5726 $oldPriority = 1;
5727 } else {
5728 $oldPriority = 0; # don't promote sub-document tag over main document
5729 }
5730 }
5731 # set priority for this tag
5732 if (defined $priority) {
5733 # increase 0-priority tags if this is the priority directory
5734 $priority = 1 if not $priority and $$self{DIR_NAME} and
5735 $$self{DIR_NAME} eq $$self{PRIORITY_DIR};
5736 } elsif ($$self{DIR_NAME} and $$self{LOW_PRIORITY_DIR}{$$self{DIR_NAME}}) {
5737 $priority = 0; # default is 0 for a LOW_PRIORITY_DIR
5738 } else {
5739 $priority = 1; # the normal default
5740 }
5741 if ($priority >= $oldPriority and not $self->{DOC_NUM}) {
5742 # move existing tag out of the way since this tag is higher priority
5743 $self->{MOVED_KEY} = $nextTag; # used in BuildCompositeTags()
5744 $self->{PRIORITY}{$nextTag} = $self->{PRIORITY}{$tag};
5745 $$rawValueHash{$nextTag} = $$rawValueHash{$tag};
5746 $self->{FILE_ORDER}{$nextTag} = $self->{FILE_ORDER}{$tag};
5747 my $oldInfo = $self->{TAG_INFO}{$nextTag} = $self->{TAG_INFO}{$tag};
5748 if ($self->{TAG_EXTRA}{$tag}) {
5749 $self->{TAG_EXTRA}{$nextTag} = $self->{TAG_EXTRA}{$tag};
5750 delete $self->{TAG_EXTRA}{$tag};
5751 }
5752 # update tag key for list if necessary
5753 $self->{LIST_TAGS}{$oldInfo} = $nextTag if $self->{LIST_TAGS}{$oldInfo};
5754 } else {
5755 $tag = $nextTag; # don't override the existing tag
5756 }
5757 $self->{PRIORITY}{$tag} = $priority;
5758 } elsif ($priority) {
5759 # set tag priority (only if exists and non-zero)
5760 $self->{PRIORITY}{$tag} = $priority;
5761 }
5762
5763 # save the raw value, file order, tagInfo ref, group1 name,
5764 # and tag key for lists if necessary
5765 $$rawValueHash{$tag} = $value;
5766 $self->{FILE_ORDER}{$tag} = ++$self->{NUM_FOUND};
5767 $self->{TAG_INFO}{$tag} = $tagInfo;
5768 # set dynamic groups 1 and 3 if necessary
5769 $self->{TAG_EXTRA}{$tag}{G1} = $self->{SET_GROUP1} if $self->{SET_GROUP1};
5770 if ($self->{DOC_NUM}) {
5771 $self->{TAG_EXTRA}{$tag}{G3} = $self->{DOC_NUM};
5772 if ($self->{DOC_NUM} =~ /^(\d+)/) {
5773 # keep track of maximum 1st-level sub-document number
5774 $self->{DOC_COUNT} = $1 unless $self->{DOC_COUNT} >= $1;
5775 }
5776 }
5777 # save path if requested
5778 $self->{TAG_EXTRA}{$tag}{G5} = $self->MetadataPath() if $self->{OPTIONS}{SavePath};
5779
5780 # remember this tagInfo if we will be accumulating values in a list
5781 $self->{LIST_TAGS}{$tagInfo} = $tag if $$tagInfo{List} and not $$self{NO_LIST};
5782
5783 return $tag;
5784}
5785
5786#------------------------------------------------------------------------------
5787# Make current directory the priority directory if not set already
5788# Inputs: 0) ExifTool object reference
5789sub SetPriorityDir($)
5790{
5791 my $self = shift;
5792 $self->{PRIORITY_DIR} = $self->{DIR_NAME} unless $self->{PRIORITY_DIR};
5793}
5794
5795#------------------------------------------------------------------------------
5796# Set family 0 or 1 group name specific to this tag instance
5797# Inputs: 0) ExifTool ref, 1) tag key, 2) group name, 3) family (default 1)
5798sub SetGroup($$$;$)
5799{
5800 my ($self, $tagKey, $extra, $fam) = @_;
5801 $self->{TAG_EXTRA}{$tagKey}{defined $fam ? "G$fam" : 'G1'} = $extra;
5802}
5803
5804#------------------------------------------------------------------------------
5805# Delete specified tag
5806# Inputs: 0) ExifTool object ref, 1) tag key
5807sub DeleteTag($$)
5808{
5809 my ($self, $tag) = @_;
5810 delete $self->{VALUE}{$tag};
5811 delete $self->{FILE_ORDER}{$tag};
5812 delete $self->{TAG_INFO}{$tag};
5813 delete $self->{TAG_EXTRA}{$tag};
5814}
5815
5816#------------------------------------------------------------------------------
5817# Escape all elements of a value
5818# Inputs: 0) value, 1) escape proc
5819sub DoEscape($$)
5820{
5821 my ($val, $key);
5822 if (not ref $_[0]) {
5823 $_[0] = &{$_[1]}($_[0]);
5824 } elsif (ref $_[0] eq 'ARRAY') {
5825 foreach $val (@{$_[0]}) {
5826 DoEscape($val, $_[1]);
5827 }
5828 } elsif (ref $_[0] eq 'HASH') {
5829 foreach $key (keys %{$_[0]}) {
5830 DoEscape($_[0]{$key}, $_[1]);
5831 }
5832 }
5833}
5834
5835#------------------------------------------------------------------------------
5836# Set the FileType and MIMEType tags
5837# Inputs: 0) ExifTool object reference
5838# 1) Optional file type (uses FILE_TYPE if not specified)
5839# 2) Optional MIME type (uses our lookup if not specified)
5840# Notes: Will NOT set file type twice (subsequent calls ignored)
5841sub SetFileType($;$$)
5842{
5843 my ($self, $fileType, $mimeType) = @_;
5844 unless ($self->{VALUE}{FileType}) {
5845 my $baseType = $self->{FILE_TYPE};
5846 $fileType or $fileType = $baseType;
5847 $mimeType or $mimeType = $mimeType{$fileType};
5848 # use base file type if necessary (except if 'TIFF', which is a special case)
5849 $mimeType = $mimeType{$baseType} unless $mimeType or $baseType eq 'TIFF';
5850 $self->FoundTag('FileType', $fileType);
5851 $self->FoundTag('MIMEType', $mimeType || 'application/unknown');
5852 }
5853}
5854
5855#------------------------------------------------------------------------------
5856# Override the FileType and MIMEType tags
5857# Inputs: 0) ExifTool object ref, 1) file type
5858# Notes: does nothing if FileType was not previously defined (ie. when writing)
5859sub OverrideFileType($$)
5860{
5861 my ($self, $fileType) = @_;
5862 if (defined $$self{VALUE}{FileType} and $fileType ne $$self{VALUE}{FileType}) {
5863 $$self{VALUE}{FileType} = $fileType;
5864 $$self{VALUE}{MIMEType} = $mimeType{$fileType} || 'application/unknown';
5865 if ($$self{OPTIONS}{Verbose}) {
5866 $self->VPrint(0,"$$self{INDENT}FileType [override] = $fileType\n");
5867 $self->VPrint(0,"$$self{INDENT}MIMEType [override] = $$self{VALUE}{MIMEType}\n");
5868 }
5869 }
5870}
5871
5872#------------------------------------------------------------------------------
5873# Modify the value of the MIMEType tag
5874# Inputs: 0) ExifTool object reference, 1) file or MIME type
5875# Notes: combines existing type with new type: ie) a/b + c/d => c/b-d
5876sub ModifyMimeType($;$)
5877{
5878 my ($self, $mime) = @_;
5879 $mime =~ m{/} or $mime = $mimeType{$mime} or return;
5880 my $old = $self->{VALUE}{MIMEType};
5881 if (defined $old) {
5882 my ($a, $b) = split '/', $old;
5883 my ($c, $d) = split '/', $mime;
5884 $d =~ s/^x-//;
5885 $self->{VALUE}{MIMEType} = "$c/$b-$d";
5886 $self->VPrint(0, " Modified MIMEType = $c/$b-$d\n");
5887 } else {
5888 $self->FoundTag('MIMEType', $mime);
5889 }
5890}
5891
5892#------------------------------------------------------------------------------
5893# Print verbose output
5894# Inputs: 0) ExifTool ref, 1) verbose level (prints if level > this), 2-N) print args
5895sub VPrint($$@)
5896{
5897 my $self = shift;
5898 my $level = shift;
5899 if ($self->{OPTIONS}{Verbose} and $self->{OPTIONS}{Verbose} > $level) {
5900 my $out = $self->{OPTIONS}{TextOut};
5901 print $out @_;
5902 }
5903}
5904
5905#------------------------------------------------------------------------------
5906# Verbose dump
5907# Inputs: 0) ExifTool ref, 1) data ref, 2-N) HexDump options
5908sub VerboseDump($$;%)
5909{
5910 my $self = shift;
5911 my $dataPt = shift;
5912 if ($self->{OPTIONS}{Verbose} and $self->{OPTIONS}{Verbose} > 2) {
5913 my %parms = (
5914 Prefix => $self->{INDENT},
5915 Out => $self->{OPTIONS}{TextOut},
5916 MaxLen => $self->{OPTIONS}{Verbose} < 4 ? 96 : undef,
5917 );
5918 HexDump($dataPt, undef, %parms, @_);
5919 }
5920}
5921
5922#------------------------------------------------------------------------------
5923# Extract binary data from file
5924# 0) ExifTool object reference, 1) offset, 2) length, 3) tag name if conditional
5925# Returns: binary data, or undef on error
5926# Notes: Returns "Binary data #### bytes" instead of data unless tag is
5927# specifically requested or the Binary option is set
5928sub ExtractBinary($$$;$)
5929{
5930 my ($self, $offset, $length, $tag) = @_;
5931 my ($isPreview, $buff);
5932
5933 if ($tag and $tag eq 'PreviewImage') {
5934 # save PreviewImage start/length in case we want to dump trailer
5935 $$self{PreviewImageStart} = $offset;
5936 $$self{PreviewImageLength} = $length;
5937 $isPreview = 1;
5938 }
5939 if ($tag and not $self->{OPTIONS}{Binary} and not $self->{OPTIONS}{Verbose} and
5940 not $self->{REQ_TAG_LOOKUP}{lc($tag)})
5941 {
5942 return "Binary data $length bytes";
5943 }
5944 unless ($self->{RAF}->Seek($offset,0)
5945 and $self->{RAF}->Read($buff, $length) == $length)
5946 {
5947 $tag or $tag = 'binary data';
5948 if ($isPreview and not $$self{BuildingComposite}) {
5949 $$self{PreviewError} = 1;
5950 } else {
5951 $self->Warn("Error reading $tag from file", $isPreview);
5952 }
5953 return undef;
5954 }
5955 return $buff;
5956}
5957
5958#------------------------------------------------------------------------------
5959# Process binary data
5960# Inputs: 0) ExifTool object ref, 1) directory information ref, 2) tag table ref
5961# Returns: 1 on success
5962# Notes: dirInfo may contain VarFormatData (reference to empty list) to return
5963# details about any variable-length-format tags in the table (used when writing)
5964sub ProcessBinaryData($$$)
5965{
5966 my ($self, $dirInfo, $tagTablePtr) = @_;
5967 my $dataPt = $$dirInfo{DataPt};
5968 my $offset = $$dirInfo{DirStart} || 0;
5969 my $size = $$dirInfo{DirLen} || (length($$dataPt) - $offset);
5970 my $base = $$dirInfo{Base} || 0;
5971 my $verbose = $self->{OPTIONS}{Verbose};
5972 my $unknown = $self->{OPTIONS}{Unknown};
5973 my $dataPos = $$dirInfo{DataPos} || 0;
5974
5975 # get default format ('int8u' unless specified)
5976 my $defaultFormat = $$tagTablePtr{FORMAT} || 'int8u';
5977 my $increment = $formatSize{$defaultFormat};
5978 unless ($increment) {
5979 warn "Unknown format $defaultFormat\n";
5980 $defaultFormat = 'int8u';
5981 $increment = $formatSize{$defaultFormat};
5982 }
5983 # prepare list of tag numbers to extract
5984 my @tags;
5985 if ($unknown > 1 and defined $$tagTablePtr{FIRST_ENTRY}) {
5986 # scan through entire binary table
5987 @tags = ($$tagTablePtr{FIRST_ENTRY}..(int($size/$increment) - 1));
5988 # add in floating point tag ID's if they exist
5989 my @ftags = grep /\./, TagTableKeys($tagTablePtr);
5990 @tags = sort { $a <=> $b } @tags, @ftags if @ftags;
5991 } elsif ($$dirInfo{DataMember}) {
5992 @tags = @{$$dirInfo{DataMember}};
5993 $verbose = 0; # no verbose output of extracted values when writing
5994 } else {
5995 # extract known tags in numerical order
5996 @tags = sort { $a <=> $b } TagTableKeys($tagTablePtr);
5997 }
5998 $self->VerboseDir('BinaryData', undef, $size) if $verbose;
5999 # avoid creating unknown tags for tags that fail condition if Unknown is 1
6000 $$self{NO_UNKNOWN} = 1 if $unknown < 2;
6001 my ($index, %val);
6002 my $nextIndex = 0;
6003 my $varSize = 0;
6004 foreach $index (@tags) {
6005 my ($tagInfo, $val, $saveNextIndex, $len, $mask, $wasVar);
6006 if ($$tagTablePtr{$index}) {
6007 $tagInfo = $self->GetTagInfo($tagTablePtr, $index);
6008 unless ($tagInfo) {
6009 next unless defined $tagInfo;
6010 my $entry = int($index) * $increment + $varSize;
6011 next if $entry >= $size;
6012 my $more = $size - $entry;
6013 $more = 128 if $more > 128;
6014 my $v = substr($$dataPt, $entry+$offset, $more);
6015 $tagInfo = $self->GetTagInfo($tagTablePtr, $index, \$v);
6016 next unless $tagInfo;
6017 }
6018 next if $$tagInfo{Unknown} and
6019 ($$tagInfo{Unknown} > $unknown or $index < $nextIndex);
6020 } else {
6021 # don't generate unknown tags in binary tables unless Unknown > 1
6022 next unless $unknown > 1;
6023 next if $index < $nextIndex; # skip if data already used
6024 $tagInfo = $self->GetTagInfo($tagTablePtr, $index) or next;
6025 $$tagInfo{Unknown} = 2; # set unknown to 2 for binary unknowns
6026 }
6027 # get relative offset of this entry
6028 my $entry = int($index) * $increment + $varSize;
6029 my $more = $size - $entry;
6030 last if $more <= 0; # all done if we have reached the end of data
6031 my $count = 1;
6032 my $format = $$tagInfo{Format};
6033 if (not $format) {
6034 $format = $defaultFormat;
6035 } elsif ($format eq 'string') {
6036 # string with no specified count runs to end of block
6037 $count = $more;
6038 } elsif ($format eq 'pstring') {
6039 $format = 'string';
6040 $count = Get8u($dataPt, ($entry++)+$offset);
6041 --$more;
6042 } elsif (not $formatSize{$format}) {
6043 if ($format =~ /(.*)\[(.*)\]/) {
6044 # handle format count field
6045 $format = $1;
6046 $count = $2;
6047 # evaluate count to allow count to be based on previous values
6048 #### eval Format size (%val, $size, $self)
6049 $count = eval $count;
6050 $@ and warn("Format $$tagInfo{Name}: $@"), next;
6051 next if $count < 0;
6052 # allow a variable-length of any format type (with base $count = 1)
6053 if ($format =~ s/^var_//) {
6054 $varSize += ($count - 1) * ($formatSize{$format} || 1);
6055 # save variable size data if required for writing
6056 if ($$dirInfo{VarFormatData}) {
6057 push @{$$dirInfo{VarFormatData}}, $index, $varSize;
6058 }
6059 }
6060 } elsif ($format =~ /^var_/) {
6061 # handle variable-length string formats
6062 $format = substr($format, 4);
6063 pos($$dataPt) = $entry + $offset;
6064 undef $count;
6065 if ($format eq 'ustring') {
6066 $count = pos($$dataPt) - ($entry+$offset) if $$dataPt =~ /\G(..)*?\0\0/sg;
6067 $varSize -= 2; # ($count includes base size of 2 bytes)
6068 } elsif ($format eq 'pstring') {
6069 $count = Get8u($dataPt, ($entry++)+$offset);
6070 --$more;
6071 } elsif ($format eq 'pstr32') {
6072 last if $more < 4;
6073 $count = Get32u($dataPt, $entry + $offset);
6074 $entry += 4;
6075 $more -= 4;
6076 } elsif ($format eq 'int16u') {
6077 # int16u size of binary data to follow
6078 last if $more < 2;
6079 $count = Get16u($dataPt, $entry + $offset) + 2;
6080 $varSize -= 2; # ($count includes size word)
6081 $format = 'undef';
6082 } elsif ($$dataPt =~ /\0/g) {
6083 $count = pos($$dataPt) - ($entry+$offset);
6084 --$varSize; # ($count includes base size of 1 byte)
6085 }
6086 $count = $more if not defined $count or $count > $more;
6087 $varSize += $count; # shift subsequent indices
6088 $val = substr($$dataPt, $entry+$offset, $count);
6089 $val = $self->Decode($val, 'UCS2') if $format eq 'ustring';
6090 $val =~ s/\0.*//s unless $format eq 'undef'; # truncate at null
6091 $wasVar = 1;
6092 # save variable size data if required for writing
6093 if ($$dirInfo{VarFormatData}) {
6094 push @{$$dirInfo{VarFormatData}}, $index, $varSize;
6095 }
6096 }
6097 }
6098 # hook to allow format, etc to be set dynamically
6099 if (defined $$tagInfo{Hook}) {
6100 #### eval Hook ($format, $varSize)
6101 eval $$tagInfo{Hook};
6102 # save variable size data if required for writing (in case changed by Hook)
6103 if ($$dirInfo{VarFormatData}) {
6104 $#{$$dirInfo{VarFormatData}} -= 2 if $wasVar; # remove previous entries for this tag
6105 push @{$$dirInfo{VarFormatData}}, $index, $varSize;
6106 }
6107 }
6108 if ($unknown > 1) {
6109 # calculate next valid index for unknown tag
6110 my $ni = int $index;
6111 $ni += (($formatSize{$format} || 1) * $count) / $increment unless $wasVar;
6112 $saveNextIndex = $nextIndex;
6113 $nextIndex = $ni unless $nextIndex > $ni;
6114 }
6115 # read value now if necessary
6116 unless (defined $val and not $$tagInfo{SubDirectory}) {
6117 $val = ReadValue($dataPt, $entry+$offset, $format, $count, $more);
6118 $mask = $$tagInfo{Mask};
6119 $val &= $mask if $mask;
6120 }
6121 if ($verbose and not $$tagInfo{Hidden}) {
6122 if (not $$tagInfo{SubDirectory} or $$tagInfo{Format}) {
6123 $len = $count * ($formatSize{$format} || 1);
6124 $len = $more if $len > $more;
6125 } else {
6126 $len = $more;
6127 }
6128 $self->VerboseInfo($index, $tagInfo,
6129 Table => $tagTablePtr,
6130 Value => $val,
6131 DataPt => $dataPt,
6132 Size => $len,
6133 Start => $entry+$offset,
6134 Addr => $entry+$offset+$base+$dataPos,
6135 Format => $format,
6136 Count => $count,
6137 Extra => $mask ? sprintf(', mask 0x%.2x',$mask) : undef,
6138 );
6139 }
6140 # parse nested BinaryData directories
6141 if ($$tagInfo{SubDirectory}) {
6142 my $subTablePtr = GetTagTable($tagInfo->{SubDirectory}{TagTable});
6143 # use specified subdirectory length if given
6144 if ($$tagInfo{Format} and $formatSize{$format}) {
6145 $len = $count * $formatSize{$format};
6146 $len = $more if $len > $more;
6147 } else {
6148 $len = $more;
6149 if ($$subTablePtr{PROCESS_PROC} and
6150 $$subTablePtr{PROCESS_PROC} eq \&ProcessBinaryData)
6151 {
6152 # the rest of the data will be printed in the subdirectory
6153 $nextIndex = $size / $increment;
6154 }
6155 }
6156 my %subdirInfo = (
6157 DataPt => $dataPt,
6158 DataPos => $dataPos,
6159 DirStart => $entry + $offset,
6160 DirLen => $len,
6161 Base => $base,
6162 );
6163 $self->ProcessDirectory(\%subdirInfo, $subTablePtr);
6164 next;
6165 }
6166 if ($$tagInfo{IsOffset} and $$tagInfo{IsOffset} ne '3') {
6167 my $exifTool = $self;
6168 #### eval IsOffset ($val, $exifTool)
6169 $val += $base + $$self{BASE} if eval $$tagInfo{IsOffset};
6170 }
6171 $val{$index} = $val;
6172 unless ($self->FoundTag($tagInfo,$val)) {
6173 # don't increment nextIndex if we didn't extract a tag
6174 $nextIndex = $saveNextIndex if defined $saveNextIndex;
6175 }
6176 }
6177 delete $$self{NO_UNKNOWN};
6178 return 1;
6179}
6180
6181#..............................................................................
6182# Load .ExifTool_config file from user's home directory
6183# (use of noConfig is now deprecated, use configFile = '' instead)
6184until ($Image::ExifTool::noConfig) {
6185 my $file = $Image::ExifTool::configFile;
6186 if (not defined $file) {
6187 my $config = '.ExifTool_config';
6188 # get our home directory (HOMEDRIVE and HOMEPATH are used in Windows cmd shell)
6189 my $home = $ENV{EXIFTOOL_HOME} || $ENV{HOME} ||
6190 ($ENV{HOMEDRIVE} || '') . ($ENV{HOMEPATH} || '') || '.';
6191 # look for the config file in 1) the home directory, 2) the program dir
6192 $file = "$home/$config";
6193 -r $file or $file = ($0 =~ /(.*[\\\/])/ ? $1 : './') . $config;
6194 -r $file or last;
6195 } else {
6196 length $file or last; # filename of "" disables configuration
6197 -r $file or warn("Config file not found\n"), last;
6198 }
6199 eval "require '$file'"; # load the config file
6200 # print warning (minus "Compilation failed" part)
6201 $@ and $_=$@, s/Compilation failed.*//s, warn $_;
6202 if (@Image::ExifTool::UserDefined::Lenses) {
6203 foreach (@Image::ExifTool::UserDefined::Lenses) {
6204 $Image::ExifTool::userLens{$_} = 1;
6205 }
6206 }
6207 last;
6208}
6209
6210#------------------------------------------------------------------------------
62111; # end
Note: See TracBrowser for help on using the repository browser.