File Coverage

blib/lib/Image/ExifTool.pm
Criterion Covered Total %
statement 2827 3735 75.6
branch 1765 2842 62.1
condition 771 1400 55.0
subroutine 154 166 92.7
pod 22 149 14.7
total 5539 8292 66.8


line stmt bran cond sub pod time code
1             #------------------------------------------------------------------------------
2             # File: ExifTool.pm
3             #
4             # Description: Read and write meta information
5             #
6             # URL: https://exiftool.org/
7             #
8             # Revisions: Nov. 12/2003 - P. Harvey Created
9             # (See html/history.html for revision history)
10             #
11             # Legal: Copyright (c) 2003-2022, Phil Harvey (philharvey66 at gmail.com)
12             # This library is free software; you can redistribute it and/or
13             # modify it under the same terms as Perl itself.
14             #------------------------------------------------------------------------------
15              
16             package Image::ExifTool;
17              
18 104     104   201845 use strict;
  104         758  
  104         3585  
19             require 5.004; # require 5.004 for UNIVERSAL::isa (otherwise 5.002 would do)
20             require Exporter;
21 104     104   39258 use File::RandomAccess;
  104         283  
  104         4986  
22 104     104   103064 use overload;
  104         140904  
  104         864  
23              
24 104         569973 use vars qw($VERSION $RELEASE @ISA @EXPORT_OK %EXPORT_TAGS $AUTOLOAD @fileTypes
25             %allTables @tableOrder $exifAPP1hdr $xmpAPP1hdr $xmpExtAPP1hdr
26             $psAPP13hdr $psAPP13old @loadAllTables %UserDefined $evalWarning
27             %noWriteFile %magicNumber @langs $defaultLang %langName %charsetName
28             %mimeType $swapBytes $swapWords $currentByteOrder %unpackStd
29             %jpegMarker %specialTags %fileTypeLookup $testLen $exeDir
30 104     104   7978 %static_vars);
  104         1444  
31              
32             $VERSION = '12.42';
33             $RELEASE = '';
34             @ISA = qw(Exporter);
35             %EXPORT_TAGS = (
36             # all public non-object-oriented functions:
37             Public => [qw(
38             ImageInfo GetTagName GetShortcuts GetAllTags GetWritableTags
39             GetAllGroups GetDeleteGroups GetFileType CanWrite CanCreate
40             AddUserDefinedTags
41             )],
42             # exports not part of the public API, but used by ExifTool modules:
43             DataAccess => [qw(
44             ReadValue GetByteOrder SetByteOrder ToggleByteOrder Get8u Get8s Get16u
45             Get16s Get32u Get32s Get64u GetFloat GetDouble GetFixed32s Write
46             WriteValue Tell Set8u Set8s Set16u Set32u Set64u Set64s
47             )],
48             Utils => [qw(GetTagTable TagTableKeys GetTagInfoList AddTagToTable HexDump)],
49             Vars => [qw(%allTables @tableOrder @fileTypes)],
50             );
51              
52             # set all of our EXPORT_TAGS in EXPORT_OK
53             Exporter::export_ok_tags(keys %EXPORT_TAGS);
54              
55             # test for problems that can arise if encoding.pm is used
56             { my $t = "\xff"; die "Incompatible encoding!\n" if ord($t) != 0xff; }
57              
58             # The following functions defined in Image::ExifTool::Writer.pl are declared
59             # here so their prototypes will be available. These Writer routines will be
60             # autoloaded when any of them is called.
61             sub SetNewValue($;$$%);
62             sub SetNewValuesFromFile($$;@);
63             sub GetNewValue($$;$);
64             sub GetNewValues($$;$);
65             sub CountNewValues($);
66             sub SaveNewValues($);
67             sub RestoreNewValues($);
68             sub WriteInfo($$;$$);
69             sub SetFileModifyDate($$;$$$);
70             sub SetFileName($$;$$$);
71             sub SetSystemTags($$);
72             sub GetAllTags(;$);
73             sub GetWritableTags(;$);
74             sub GetAllGroups($;$);
75             sub GetNewGroups($);
76             sub GetDeleteGroups();
77             sub AddUserDefinedTags($%);
78             # non-public routines below
79             sub InsertTagValues($$$;$$$);
80             sub IsWritable($);
81             sub IsSameFile($$$);
82             sub IsRawType($);
83             sub GetNewFileName($$);
84             sub LoadAllTables();
85             sub GetNewTagInfoList($;$);
86             sub GetNewTagInfoHash($@);
87             sub GetLangInfo($$);
88             sub Get64s($$);
89             sub Get64u($$);
90             sub GetFixed64s($$);
91             sub GetExtended($$);
92             sub Set64u(@);
93             sub Set64s(@);
94             sub DecodeBits($$;$);
95             sub EncodeBits($$;$$);
96             sub Filter($$$);
97             sub HexDump($;$%);
98             sub DumpTrailer($$);
99             sub DumpUnknownTrailer($$);
100             sub VerboseInfo($$$%);
101             sub VerboseValue($$$;$);
102             sub VPrint($$@);
103             sub Rationalize($;$);
104             sub Write($@);
105             sub WriteTrailerBuffer($$$);
106             sub AddNewTrailers($;@);
107             sub Tell($);
108             sub WriteValue($$;$$$$);
109             sub WriteDirectory($$$;$);
110             sub WriteBinaryData($$$);
111             sub CheckBinaryData($$$);
112             sub WriteTIFF($$$);
113             sub PackUTF8(@);
114             sub UnpackUTF8($);
115             sub SetPreferredByteOrder($;$);
116             sub CopyBlock($$$);
117             sub CopyFileAttrs($$$);
118             sub TimeNow(;$$);
119             sub NewGUID();
120             sub MakeTiffHeader($$$$;$$);
121              
122             # other subroutine definitions
123             sub SplitFileName($);
124             sub EncodeFileName($$;$);
125             sub Open($*$;$);
126             sub Exists($$);
127             sub IsDirectory($$);
128             sub Rename($$$);
129             sub Unlink($@);
130             sub SetFileTime($$;$$$$);
131             sub DoEscape($$);
132             sub ConvertFileSize($);
133             sub ParseArguments($;@); #(defined in attempt to avoid mod_perl problem)
134             sub ReadValue($$$;$$$);
135              
136             # list of main tag tables to load in LoadAllTables() (sub-tables are recursed
137             # automatically). Note: They will appear in this order in the documentation
138             # unless tweaked in BuildTagLookup::GetTableOrder().
139             @loadAllTables = qw(
140             PhotoMechanic Exif GeoTiff CanonRaw KyoceraRaw Lytro MinoltaRaw PanasonicRaw
141             SigmaRaw JPEG GIMP Jpeg2000 GIF BMP BMP::OS2 BMP::Extra BPG BPG::Extensions
142             PICT PNG MNG FLIF DjVu DPX OpenEXR ZISRAW MRC LIF MRC::FEI12 MIFF PCX PGF
143             PSP PhotoCD Radiance Other::PFM PDF PostScript Photoshop::Header
144             Photoshop::Layers Photoshop::ImageData FujiFilm::RAF FujiFilm::IFD
145             Samsung::Trailer Sony::SRF2 Sony::SR2SubIFD Sony::PMP ITC ID3 ID3::Lyrics3
146             FLAC Ogg Vorbis APE APE::NewHeader APE::OldHeader Audible MPC MPEG::Audio
147             MPEG::Video MPEG::Xing M2TS QuickTime QuickTime::ImageFile QuickTime::Stream
148             QuickTime::Tags360Fly Matroska MOI MXF DV Flash Flash::FLV Real::Media
149             Real::Audio Real::Metafile Red RIFF AIFF ASF WTV DICOM FITS MIE JSON HTML
150             XMP::SVG Palm Palm::MOBI Palm::EXTH Torrent EXE EXE::PEVersion EXE::PEString
151             EXE::MachO EXE::PEF EXE::ELF EXE::AR EXE::CHM LNK Font VCard Text
152             VCard::VCalendar RSRC Rawzor ZIP ZIP::GZIP ZIP::RAR RTF OOXML iWork ISO
153             FLIR::AFF FLIR::FPF MacOS MacOS::MDItem FlashPix::DocTable
154             );
155              
156             # alphabetical list of current Lang modules
157             @langs = qw(cs de en en_ca en_gb es fi fr it ja ko nl pl ru sv tr zh_cn zh_tw);
158              
159             $defaultLang = 'en'; # default language
160              
161             # language names
162             %langName = (
163             cs => 'Czech (Čeština)',
164             de => 'German (Deutsch)',
165             en => 'English',
166             en_ca => 'Canadian English',
167             en_gb => 'British English',
168             es => 'Spanish (Español)',
169             fi => 'Finnish (Suomi)',
170             fr => 'French (Français)',
171             it => 'Italian (Italiano)',
172             ja => 'Japanese (日本語)',
173             ko => 'Korean (한국어)',
174             nl => 'Dutch (Nederlands)',
175             pl => 'Polish (Polski)',
176             ru => 'Russian (Русский)',
177             sv => 'Swedish (Svenska)',
178             'tr'=> 'Turkish (Türkçe)',
179             zh_cn => 'Simplified Chinese (简体中文)',
180             zh_tw => 'Traditional Chinese (繁體中文)',
181             );
182              
183             # recognized file types, in the order we test unknown files
184             # Notes: 1) There is no need to test for like types separately here
185             # 2) Put types with weak file signatures at end of list to avoid false matches
186             # 3) PLIST must be in this list for the binary PLIST format, although it may
187             # cause a file to be checked twice for XML
188             @fileTypes = qw(JPEG EXV CRW DR4 TIFF GIF MRW RAF X3F JP2 PNG MIE MIFF PS PDF
189             PSD XMP BMP BPG PPM RIFF AIFF ASF MOV MPEG Real SWF PSP FLV OGG
190             FLAC APE MPC MKV MXF DV PMP IND PGF ICC ITC FLIR FLIF FPF LFP
191             HTML VRD RTF FITS XCF DSS QTIF FPX PICT ZIP GZIP PLIST RAR BZ2
192             CZI TAR EXE EXR HDR CHM LNK WMF AVC DEX DPX RAW Font RSRC M2TS
193             MacOS PHP PCX DCX DWF DWG DXF WTV Torrent VCard LRI R3D AA PDB
194             PFM2 MRC LIF JXL MOI ISO ALIAS JSON MP3 DICOM PCD TXT);
195              
196             # file types that we can write (edit)
197             my @writeTypes = qw(JPEG TIFF GIF CRW MRW ORF RAF RAW PNG MIE PSD XMP PPM EPS
198             X3F PS PDF ICC VRD DR4 JP2 JXL EXIF AI AIT IND MOV EXV FLIF);
199             my %writeTypes; # lookup for writable file types (hash filled if required)
200              
201             # file extensions that we can't write for various base types
202             %noWriteFile = (
203             TIFF => [ qw(3FR DCR K25 KDC SRF) ],
204             XMP => [ qw(SVG INX) ],
205             JP2 => [ qw(J2C JPC) ],
206             MOV => [ qw(INSV) ],
207             );
208              
209             # file types that we can create from scratch
210             # - must update CanCreate() documentation if this list is changed!
211             my %createTypes = map { $_ => 1 } qw(XMP ICC MIE VRD DR4 EXIF EXV);
212              
213             # file type lookup for all recognized file extensions (upper case)
214             # (if extension may be more than one type, the type is a list where
215             # the writable type should come first if it exists)
216             %fileTypeLookup = (
217             '360' => ['MOV', 'GoPro 360 video'],
218             '3FR' => ['TIFF', 'Hasselblad RAW format'],
219             '3G2' => ['MOV', '3rd Gen. Partnership Project 2 audio/video'],
220             '3GP' => ['MOV', '3rd Gen. Partnership Project audio/video'],
221             '3GP2'=> '3G2',
222             '3GPP'=> '3GP',
223             A => ['EXE', 'Static library'],
224             AA => ['AA', 'Audible Audiobook'],
225             AAE => ['PLIST','Apple edit information'],
226             AAX => ['MOV', 'Audible Enhanced Audiobook'],
227             ACR => ['DICOM','American College of Radiology ACR-NEMA'],
228             ACFM => ['Font', 'Adobe Composite Font Metrics'],
229             AFM => ['Font', 'Adobe Font Metrics'],
230             AMFM => ['Font', 'Adobe Multiple Master Font Metrics'],
231             AI => [['PDF','PS'], 'Adobe Illustrator'],
232             AIF => 'AIFF',
233             AIFC => ['AIFF', 'Audio Interchange File Format Compressed'],
234             AIFF => ['AIFF', 'Audio Interchange File Format'],
235             AIT => 'AI',
236             ALIAS=> ['ALIAS','MacOS file alias'],
237             APE => ['APE', "Monkey's Audio format"],
238             APNG => ['PNG', 'Animated Portable Network Graphics'],
239             ARW => ['TIFF', 'Sony Alpha RAW format'],
240             ARQ => ['TIFF', 'Sony Alpha Pixel-Shift RAW format'],
241             ASF => ['ASF', 'Microsoft Advanced Systems Format'],
242             AVC => ['AVC', 'Advanced Video Connection'], # (extensions are actually _AU,_AD,_IM,_ID)
243             AVI => ['RIFF', 'Audio Video Interleaved'],
244             AVIF => ['MOV', 'AV1 Image File Format'],
245             AZW => 'MOBI', # (see http://wiki.mobileread.com/wiki/AZW)
246             AZW3 => 'MOBI',
247             BMP => ['BMP', 'Windows Bitmap'],
248             BPG => ['BPG', 'Better Portable Graphics'],
249             BTF => ['BTF', 'Big Tagged Image File Format'], #(unofficial)
250             BZ2 => ['BZ2', 'BZIP2 archive'],
251             CHM => ['CHM', 'Microsoft Compiled HTML format'],
252             CIFF => ['CRW', 'Camera Image File Format'],
253             COS => ['COS', 'Capture One Settings'],
254             CR2 => ['TIFF', 'Canon RAW 2 format'],
255             CR3 => ['MOV', 'Canon RAW 3 format'],
256             CRM => ['MOV', 'Canon RAW Movie'],
257             CRW => ['CRW', 'Canon RAW format'],
258             CS1 => ['PSD', 'Sinar CaptureShop 1-Shot RAW'],
259             CSV => ['TXT', 'Comma-Separated Values'],
260             CZI => ['CZI', 'Zeiss Integrated Software RAW'],
261             DC3 => 'DICM',
262             DCM => 'DICM',
263             DCP => ['TIFF', 'DNG Camera Profile'],
264             DCR => ['TIFF', 'Kodak Digital Camera RAW'],
265             DCX => ['DCX', 'Multi-page PC Paintbrush'],
266             DEX => ['DEX', 'Dalvik Executable format'],
267             DFONT=> ['Font', 'Macintosh Data fork Font'],
268             DIB => ['BMP', 'Device Independent Bitmap'],
269             DIC => 'DICM',
270             DICM => ['DICOM','Digital Imaging and Communications in Medicine'],
271             DIR => ['DIR', 'Directory'],
272             DIVX => ['ASF', 'DivX media format'],
273             DJV => 'DJVU',
274             DJVU => ['AIFF', 'DjVu image'],
275             DLL => ['EXE', 'Windows Dynamic Link Library'],
276             DNG => ['TIFF', 'Digital Negative'],
277             DOC => ['FPX', 'Microsoft Word Document'],
278             DOCM => [['ZIP','FPX'], 'Office Open XML Document Macro-enabled'],
279             # Note: I have seen a password-protected DOCX file which was FPX-like, so I assume
280             # that any other MS Office file could be like this too. The only difference is
281             # that the ZIP and FPX formats are checked first, so if this is wrong, no biggie.
282             DOCX => [['ZIP','FPX'], 'Office Open XML Document'],
283             DOT => ['FPX', 'Microsoft Word Template'],
284             DOTM => [['ZIP','FPX'], 'Office Open XML Document Template Macro-enabled'],
285             DOTX => [['ZIP','FPX'], 'Office Open XML Document Template'],
286             DPX => ['DPX', 'Digital Picture Exchange' ],
287             DR4 => ['DR4', 'Canon VRD version 4 Recipe'],
288             DS2 => ['DSS', 'Digital Speech Standard 2'],
289             DSS => ['DSS', 'Digital Speech Standard'],
290             DV => ['DV', 'Digital Video'],
291             DVB => ['MOV', 'Digital Video Broadcasting'],
292             'DVR-MS'=>['ASF', 'Microsoft Digital Video recording'],
293             DWF => ['DWF', 'Autodesk drawing (Design Web Format)'],
294             DWG => ['DWG', 'AutoCAD Drawing'],
295             DYLIB=> ['EXE', 'Mach-O Dynamic Link Library'],
296             DXF => ['DXF', 'AutoCAD Drawing Exchange Format'],
297             EIP => ['ZIP', 'Capture One Enhanced Image Package'],
298             EPS => ['EPS', 'Encapsulated PostScript Format'],
299             EPS2 => 'EPS',
300             EPS3 => 'EPS',
301             EPSF => 'EPS',
302             EPUB => ['ZIP', 'Electronic Publication'],
303             ERF => ['TIFF', 'Epson Raw Format'],
304             EXE => ['EXE', 'Windows executable file'],
305             EXR => ['EXR', 'Open EXR'],
306             EXIF => ['EXIF', 'Exchangable Image File Metadata'],
307             EXV => ['EXV', 'Exiv2 metadata'],
308             F4A => ['MOV', 'Adobe Flash Player 9+ Audio'],
309             F4B => ['MOV', 'Adobe Flash Player 9+ audio Book'],
310             F4P => ['MOV', 'Adobe Flash Player 9+ Protected'],
311             F4V => ['MOV', 'Adobe Flash Player 9+ Video'],
312             FFF => [['TIFF','FLIR'], 'Hasselblad Flexible File Format'],
313             FIT => 'FITS',
314             FITS => ['FITS', 'Flexible Image Transport System'],
315             FLAC => ['FLAC', 'Free Lossless Audio Codec'],
316             FLA => ['FPX', 'Macromedia/Adobe Flash project'],
317             FLIF => ['FLIF', 'Free Lossless Image Format'],
318             FLIR => ['FLIR', 'FLIR File Format'], # (not an actual extension)
319             FLV => ['FLV', 'Flash Video'],
320             FPF => ['FPF', 'FLIR Public image Format'],
321             FPX => ['FPX', 'FlashPix'],
322             GIF => ['GIF', 'Compuserve Graphics Interchange Format'],
323             GPR => ['TIFF', 'General Purpose RAW'], # https://gopro.github.io/gpr/
324             GZ => 'GZIP',
325             GZIP => ['GZIP', 'GNU ZIP compressed archive'],
326             HDP => ['TIFF', 'Windows HD Photo'],
327             HDR => ['HDR', 'Radiance RGBE High Dynamic Range'],
328             HEIC => ['MOV', 'High Efficiency Image Format still image'],
329             HEIF => ['MOV', 'High Efficiency Image Format'],
330             HIF => 'HEIF',
331             HTM => 'HTML',
332             HTML => ['HTML', 'HyperText Markup Language'],
333             ICAL => 'ICS',
334             ICC => ['ICC', 'International Color Consortium'],
335             ICM => 'ICC',
336             ICS => ['VCard','iCalendar Schedule'],
337             IDML => ['ZIP', 'Adobe InDesign Markup Language'],
338             IIQ => ['TIFF', 'Phase One Intelligent Image Quality RAW'],
339             IND => ['IND', 'Adobe InDesign'],
340             INDD => ['IND', 'Adobe InDesign Document'],
341             INDT => ['IND', 'Adobe InDesign Template'],
342             INSV => ['MOV', 'Insta360 Video'],
343             INSP => ['JPEG', 'Insta360 Picture'],
344             INX => ['XMP', 'Adobe InDesign Interchange'],
345             ISO => ['ISO', 'ISO 9660 disk image'],
346             ITC => ['ITC', 'iTunes Cover Flow'],
347             J2C => ['JP2', 'JPEG 2000 codestream'],
348             J2K => 'J2C',
349             JNG => ['PNG', 'JPG Network Graphics'],
350             JP2 => ['JP2', 'JPEG 2000 file'],
351             # JP4? - looks like a JPEG but the image data is different
352             JPC => 'J2C',
353             JPE => 'JPEG',
354             JPEG => ['JPEG', 'Joint Photographic Experts Group'],
355             JPF => 'JP2',
356             JPG => 'JPEG',
357             JPM => ['JP2', 'JPEG 2000 compound image'],
358             JPS => ['JPEG', 'JPEG Stereo image'],
359             JPX => ['JP2', 'JPEG 2000 with extensions'],
360             JSON => ['JSON', 'JavaScript Object Notation'],
361             JXL => ['JXL', 'JPEG XL'],
362             JXR => ['TIFF', 'JPEG XR'],
363             K25 => ['TIFF', 'Kodak DC25 RAW'],
364             KDC => ['TIFF', 'Kodak Digital Camera RAW'],
365             KEY => ['ZIP', 'Apple Keynote presentation'],
366             KTH => ['ZIP', 'Apple Keynote Theme'],
367             LA => ['RIFF', 'Lossless Audio'],
368             LFP => ['LFP', 'Lytro Light Field Picture'],
369             LFR => 'LFP', # (Light Field RAW)
370             LIF => ['LIF', 'Leica Image File'],
371             LNK => ['LNK', 'Windows shortcut'],
372             LRI => ['LRI', 'Light RAW'],
373             LRV => ['MOV', 'Low-Resolution Video'],
374             M2T => 'M2TS',
375             M2TS => ['M2TS', 'MPEG-2 Transport Stream'],
376             M2V => ['MPEG', 'MPEG-2 Video'],
377             M4A => ['MOV', 'MPEG-4 Audio'],
378             M4B => ['MOV', 'MPEG-4 audio Book'],
379             M4P => ['MOV', 'MPEG-4 Protected'],
380             M4V => ['MOV', 'MPEG-4 Video'],
381             MAX => ['FPX', '3D Studio MAX'],
382             MEF => ['TIFF', 'Mamiya (RAW) Electronic Format'],
383             MIE => ['MIE', 'Meta Information Encapsulation format'],
384             MIF => 'MIFF',
385             MIFF => ['MIFF', 'Magick Image File Format'],
386             MKA => ['MKV', 'Matroska Audio'],
387             MKS => ['MKV', 'Matroska Subtitle'],
388             MKV => ['MKV', 'Matroska Video'],
389             MNG => ['PNG', 'Multiple-image Network Graphics'],
390             MOBI => ['PDB', 'Mobipocket electronic book'],
391             MODD => ['PLIST','Sony Picture Motion metadata'],
392             MOI => ['MOI', 'MOD Information file'],
393             MOS => ['TIFF', 'Creo Leaf Mosaic'],
394             MOV => ['MOV', 'Apple QuickTime movie'],
395             MP3 => ['MP3', 'MPEG-1 Layer 3 audio'],
396             MP4 => ['MOV', 'MPEG-4 video'],
397             MPC => ['MPC', 'Musepack Audio'],
398             MPEG => ['MPEG', 'MPEG-1 or MPEG-2 audio/video'],
399             MPG => 'MPEG',
400             MPO => ['JPEG', 'Extended Multi-Picture format'],
401             MQV => ['MOV', 'Sony Mobile Quicktime Video'],
402             MRC => ['MRC', 'Medical Research Council image'],
403             MRW => ['MRW', 'Minolta RAW format'],
404             MTS => 'M2TS',
405             MXF => ['MXF', 'Material Exchange Format'],
406             # NDPI => ['TIFF', 'Hamamatsu NanoZoomer Digital Pathology Image'],
407             NEF => ['TIFF', 'Nikon (RAW) Electronic Format'],
408             NEWER => 'COS',
409             NKSC => ['XMP', 'Nikon Sidecar'],
410              
411             NMBTEMPLATE => ['ZIP','Apple Numbers Template'],
412             NRW => ['TIFF', 'Nikon RAW (2)'],
413             NUMBERS => ['ZIP','Apple Numbers spreadsheet'],
414             O => ['EXE', 'Relocatable Object'],
415             ODB => ['ZIP', 'Open Document Database'],
416             ODC => ['ZIP', 'Open Document Chart'],
417             ODF => ['ZIP', 'Open Document Formula'],
418             ODG => ['ZIP', 'Open Document Graphics'],
419             ODI => ['ZIP', 'Open Document Image'],
420             ODP => ['ZIP', 'Open Document Presentation'],
421             ODS => ['ZIP', 'Open Document Spreadsheet'],
422             ODT => ['ZIP', 'Open Document Text file'],
423             OFR => ['RIFF', 'OptimFROG audio'],
424             OGG => ['OGG', 'Ogg Vorbis audio file'],
425             OGV => ['OGG', 'Ogg Video file'],
426             ONP => ['JSON', 'ON1 Presets'],
427             OPUS => ['OGG', 'Ogg Opus audio file'],
428             ORF => ['ORF', 'Olympus RAW format'],
429             ORI => 'ORF',
430             OTF => ['Font', 'Open Type Font'],
431             PAC => ['RIFF', 'Lossless Predictive Audio Compression'],
432             PAGES => ['ZIP', 'Apple Pages document'],
433             PBM => ['PPM', 'Portable BitMap'],
434             PCD => ['PCD', 'Kodak Photo CD Image Pac'],
435             PCT => 'PICT',
436             PCX => ['PCX', 'PC Paintbrush'],
437             PDB => ['PDB', 'Palm Database'],
438             PDF => ['PDF', 'Adobe Portable Document Format'],
439             PEF => ['TIFF', 'Pentax (RAW) Electronic Format'],
440             PFA => ['Font', 'PostScript Font ASCII'],
441             PFB => ['Font', 'PostScript Font Binary'],
442             PFM => [['Font','PFM2'], 'Printer Font Metrics'], # (description is overridden for Portable FloatMap images)
443             PGF => ['PGF', 'Progressive Graphics File'],
444             PGM => ['PPM', 'Portable Gray Map'],
445             PHP => ['PHP', 'PHP Hypertext Preprocessor'],
446             PHP3 => 'PHP',
447             PHP4 => 'PHP',
448             PHP5 => 'PHP',
449             PHPS => 'PHP',
450             PHTML=> 'PHP',
451             PICT => ['PICT', 'Apple PICTure'],
452             PLIST=> ['PLIST','Apple Property List'],
453             PMP => ['PMP', 'Sony DSC-F1 Cyber-Shot PMP'], # should stand for Proprietery Metadata Package ;)
454             PNG => ['PNG', 'Portable Network Graphics'],
455             POT => ['FPX', 'Microsoft PowerPoint Template'],
456             POTM => [['ZIP','FPX'], 'Office Open XML Presentation Template Macro-enabled'],
457             POTX => [['ZIP','FPX'], 'Office Open XML Presentation Template'],
458             PPAM => [['ZIP','FPX'], 'Office Open XML Presentation Addin Macro-enabled'],
459             PPAX => [['ZIP','FPX'], 'Office Open XML Presentation Addin'],
460             PPM => ['PPM', 'Portable Pixel Map'],
461             PPS => ['FPX', 'Microsoft PowerPoint Slideshow'],
462             PPSM => [['ZIP','FPX'], 'Office Open XML Presentation Slideshow Macro-enabled'],
463             PPSX => [['ZIP','FPX'], 'Office Open XML Presentation Slideshow'],
464             PPT => ['FPX', 'Microsoft PowerPoint Presentation'],
465             PPTM => [['ZIP','FPX'], 'Office Open XML Presentation Macro-enabled'],
466             PPTX => [['ZIP','FPX'], 'Office Open XML Presentation'],
467             PRC => ['PDB', 'Palm Database'],
468             PS => ['PS', 'PostScript'],
469             PS2 => 'PS',
470             PS3 => 'PS',
471             PSB => ['PSD', 'Photoshop Large Document'],
472             PSD => ['PSD', 'Photoshop Document'],
473             PSDT => ['PSD', 'Photoshop Document Template'],
474             PSP => ['PSP', 'Paint Shop Pro'],
475             PSPFRAME => 'PSP',
476             PSPIMAGE => 'PSP',
477             PSPSHAPE => 'PSP',
478             PSPTUBE => 'PSP',
479             QIF => 'QTIF',
480             QT => 'MOV',
481             QTI => 'QTIF',
482             QTIF => ['QTIF', 'QuickTime Image File'],
483             R3D => ['R3D', 'Redcode RAW Video'],
484             RA => ['Real', 'Real Audio'],
485             RAF => ['RAF', 'FujiFilm RAW Format'],
486             RAM => ['Real', 'Real Audio Metafile'],
487             RAR => ['RAR', 'RAR Archive'],
488             RAW => [['RAW','TIFF'], 'Kyocera Contax N Digital RAW or Panasonic RAW'],
489             RIF => 'RIFF',
490             RIFF => ['RIFF', 'Resource Interchange File Format'],
491             RM => ['Real', 'Real Media'],
492             RMVB => ['Real', 'Real Media Variable Bitrate'],
493             RPM => ['Real', 'Real Media Plug-in Metafile'],
494             RSRC => ['RSRC', 'Mac OS Resource'],
495             RTF => ['RTF', 'Rich Text Format'],
496             RV => ['Real', 'Real Video'],
497             RW2 => ['TIFF', 'Panasonic RAW 2'],
498             RWL => ['TIFF', 'Leica RAW'],
499             RWZ => ['RWZ', 'Rawzor compressed image'],
500             SEQ => ['FLIR', 'FLIR image Sequence'],
501             SKETCH => ['ZIP', 'Sketch design file'],
502             SO => ['EXE', 'Shared Object file'],
503             SR2 => ['TIFF', 'Sony RAW Format 2'],
504             SRF => ['TIFF', 'Sony RAW Format'],
505             SRW => ['TIFF', 'Samsung RAW format'],
506             SVG => ['XMP', 'Scalable Vector Graphics'],
507             SWF => ['SWF', 'Shockwave Flash'],
508             TAR => ['TAR', 'TAR archive'],
509             THM => ['JPEG', 'Thumbnail'],
510             THMX => [['ZIP','FPX'], 'Office Open XML Theme'],
511             TIF => 'TIFF',
512             TIFF => ['TIFF', 'Tagged Image File Format'],
513             TORRENT => ['Torrent', 'BitTorrent description file'],
514             TS => 'M2TS',
515             TTC => ['Font', 'True Type Font Collection'],
516             TTF => ['Font', 'True Type Font'],
517             TUB => 'PSP',
518             TXT => ['TXT', 'Text file'],
519             VCARD=> ['VCard','Virtual Card'],
520             VCF => 'VCARD',
521             VOB => ['MPEG', 'Video Object'],
522             VRD => ['VRD', 'Canon VRD Recipe Data'],
523             VSD => ['FPX', 'Microsoft Visio Drawing'],
524             WAV => ['RIFF', 'WAVeform (Windows digital audio)'],
525             WDP => ['TIFF', 'Windows Media Photo'],
526             WEBM => ['MKV', 'Google Web Movie'],
527             WEBP => ['RIFF', 'Google Web Picture'],
528             WMA => ['ASF', 'Windows Media Audio'],
529             WMF => ['WMF', 'Windows Metafile Format'],
530             WMV => ['ASF', 'Windows Media Video'],
531             WV => ['RIFF', 'WavePack lossless audio'],
532             X3F => ['X3F', 'Sigma RAW format'],
533             MACOS=> ['MacOS','MacOS ._ sidecar file'],
534             XCF => ['XCF', 'GIMP native image format'],
535             XHTML=> ['HTML', 'Extensible HyperText Markup Language'],
536             XLA => ['FPX', 'Microsoft Excel Add-in'],
537             XLAM => [['ZIP','FPX'], 'Office Open XML Spreadsheet Add-in Macro-enabled'],
538             XLS => ['FPX', 'Microsoft Excel Spreadsheet'],
539             XLSB => [['ZIP','FPX'], 'Office Open XML Spreadsheet Binary'],
540             XLSM => [['ZIP','FPX'], 'Office Open XML Spreadsheet Macro-enabled'],
541             XLSX => [['ZIP','FPX'], 'Office Open XML Spreadsheet'],
542             XLT => ['FPX', 'Microsoft Excel Template'],
543             XLTM => [['ZIP','FPX'], 'Office Open XML Spreadsheet Template Macro-enabled'],
544             XLTX => [['ZIP','FPX'], 'Office Open XML Spreadsheet Template'],
545             XMP => ['XMP', 'Extensible Metadata Platform'],
546             WOFF => ['Font', 'Web Open Font Format'],
547             WOFF2=> ['Font', 'Web Open Font Format2'],
548             WTV => ['WTV', 'Windows recorded TV show'],
549             ZIP => ['ZIP', 'ZIP archive'],
550             );
551              
552             # typical extension for each file type (if different than FileType)
553             # - case is not significant
554             my %fileTypeExt = (
555             'Canon 1D RAW' => 'tif',
556             DICOM => 'dcm',
557             FLIR => 'fff',
558             GZIP => 'gz',
559             JPEG => 'jpg',
560             M2TS => 'mts',
561             MPEG => 'mpg',
562             TIFF => 'tif',
563             VCard => 'vcf',
564             );
565              
566             # descriptions for file types not found in above file extension lookup
567             my %fileDescription = (
568             DICOM => 'Digital Imaging and Communications in Medicine',
569             XML => 'Extensible Markup Language',
570             'Win32 EXE' => 'Windows 32-bit Executable',
571             'Win32 DLL' => 'Windows 32-bit Dynamic Link Library',
572             'Win64 EXE' => 'Windows 64-bit Executable',
573             'Win64 DLL' => 'Windows 64-bit Dynamic Link Library',
574             );
575              
576             # MIME types for applicable file types above
577             # (missing entries default to 'application/unknown', but note that other MIME
578             # types may be specified by some modules, eg. QuickTime.pm and RIFF.pm)
579             %mimeType = (
580             '3FR' => 'image/x-hasselblad-3fr',
581             AA => 'audio/audible',
582             AAE => 'application/vnd.apple.photos',
583             AI => 'application/vnd.adobe.illustrator',
584             AIFF => 'audio/x-aiff',
585             ALIAS=> 'application/x-macos',
586             APE => 'audio/x-monkeys-audio',
587             APNG => 'image/apng',
588             ASF => 'video/x-ms-asf',
589             ARW => 'image/x-sony-arw',
590             BMP => 'image/bmp',
591             BPG => 'image/bpg',
592             BTF => 'image/x-tiff-big', #(NC) (ref http://www.asmail.be/msg0055371937.html)
593             BZ2 => 'application/bzip2',
594             'Canon 1D RAW' => 'image/x-raw', # (uses .TIF file extension)
595             CHM => 'application/x-chm',
596             COS => 'application/octet-stream', #PH (NC)
597             CR2 => 'image/x-canon-cr2',
598             CR3 => 'image/x-canon-cr3',
599             CRM => 'video/x-canon-crm',
600             CRW => 'image/x-canon-crw',
601             CSV => 'text/csv',
602             CZI => 'image/x-zeiss-czi', #PH (NC)
603             DCP => 'application/octet-stream', #PH (NC)
604             DCR => 'image/x-kodak-dcr',
605             DCX => 'image/dcx',
606             DEX => 'application/octet-stream',
607             DFONT=> 'application/x-dfont',
608             DICOM=> 'application/dicom',
609             DIVX => 'video/divx',
610             DJVU => 'image/vnd.djvu',
611             DNG => 'image/x-adobe-dng',
612             DOC => 'application/msword',
613             DOCM => 'application/vnd.ms-word.document.macroEnabled.12',
614             DOCX => 'application/vnd.openxmlformats-officedocument.wordprocessingml.document',
615             DOT => 'application/msword',
616             DOTM => 'application/vnd.ms-word.template.macroEnabledTemplate',
617             DOTX => 'application/vnd.openxmlformats-officedocument.wordprocessingml.template',
618             DPX => 'image/x-dpx',
619             DR4 => 'application/octet-stream', #PH (NC)
620             DS2 => 'audio/x-ds2',
621             DSS => 'audio/x-dss',
622             DV => 'video/x-dv',
623             'DVR-MS' => 'video/x-ms-dvr',
624             DWF => 'model/vnd.dwf',
625             DWG => 'image/vnd.dwg',
626             DXF => 'application/dxf',
627             EIP => 'application/x-captureone', #(NC)
628             EPS => 'application/postscript',
629             ERF => 'image/x-epson-erf',
630             EXE => 'application/octet-stream',
631             EXR => 'image/x-exr',
632             EXV => 'image/x-exv',
633             FFF => 'image/x-hasselblad-fff',
634             FITS => 'image/fits',
635             FLA => 'application/vnd.adobe.fla',
636             FLAC => 'audio/flac',
637             FLIF => 'image/flif',
638             FLIR => 'image/x-flir-fff', #PH (NC)
639             FLV => 'video/x-flv',
640             Font => 'application/x-font-type1', # covers PFA, PFB and PFM (not sure about PFM)
641             FPF => 'image/x-flir-fpf', #PH (NC)
642             FPX => 'image/vnd.fpx',
643             GIF => 'image/gif',
644             GPR => 'image/x-gopro-gpr',
645             GZIP => 'application/x-gzip',
646             HDP => 'image/vnd.ms-photo',
647             HDR => 'image/vnd.radiance',
648             HTML => 'text/html',
649             ICC => 'application/vnd.iccprofile',
650             ICS => 'text/calendar',
651             IDML => 'application/vnd.adobe.indesign-idml-package',
652             IIQ => 'image/x-raw',
653             IND => 'application/x-indesign',
654             INX => 'application/x-indesign-interchange', #PH (NC)
655             ISO => 'application/x-iso9660-image',
656             ITC => 'application/itunes',
657             J2C => 'image/x-j2c', #PH (NC)
658             JNG => 'image/jng',
659             JP2 => 'image/jp2',
660             JPEG => 'image/jpeg',
661             JPM => 'image/jpm',
662             JPS => 'image/x-jps',
663             JPX => 'image/jpx',
664             JSON => 'application/json',
665             JXL => 'image/jxl', #PH (NC)
666             JXR => 'image/jxr',
667             K25 => 'image/x-kodak-k25',
668             KDC => 'image/x-kodak-kdc',
669             KEY => 'application/x-iwork-keynote-sffkey',
670             LFP => 'image/x-lytro-lfp', #PH (NC)
671             LIF => 'image/x-lif',
672             LNK => 'application/octet-stream',
673             LRI => 'image/x-light-lri',
674             M2T => 'video/mpeg',
675             M2TS => 'video/m2ts',
676             MAX => 'application/x-3ds',
677             MEF => 'image/x-mamiya-mef',
678             MIE => 'application/x-mie',
679             MIFF => 'application/x-magick-image',
680             MKA => 'audio/x-matroska',
681             MKS => 'application/x-matroska',
682             MKV => 'video/x-matroska',
683             MNG => 'video/mng',
684             MOBI => 'application/x-mobipocket-ebook',
685             MOI => 'application/octet-stream', #PH (NC)
686             MOS => 'image/x-raw',
687             MOV => 'video/quicktime',
688             MP3 => 'audio/mpeg',
689             MP4 => 'video/mp4',
690             MPC => 'audio/x-musepack',
691             MPEG => 'video/mpeg',
692             MRC => 'image/x-mrc',
693             MRW => 'image/x-minolta-mrw',
694             MXF => 'application/mxf',
695             NEF => 'image/x-nikon-nef',
696             NKSC => 'application/x-nikon-nxstudio',
697             NRW => 'image/x-nikon-nrw',
698             NUMBERS => 'application/x-iwork-numbers-sffnumbers',
699             ODB => 'application/vnd.oasis.opendocument.database',
700             ODC => 'application/vnd.oasis.opendocument.chart',
701             ODF => 'application/vnd.oasis.opendocument.formula',
702             ODG => 'application/vnd.oasis.opendocument.graphics',
703             ODI => 'application/vnd.oasis.opendocument.image',
704             ODP => 'application/vnd.oasis.opendocument.presentation',
705             ODS => 'application/vnd.oasis.opendocument.spreadsheet',
706             ODT => 'application/vnd.oasis.opendocument.text',
707             OGG => 'audio/ogg',
708             OGV => 'video/ogg',
709             ONP => 'application/on1',
710             ORF => 'image/x-olympus-orf',
711             OTF => 'application/x-font-otf',
712             PAGES=> 'application/x-iwork-pages-sffpages',
713             PBM => 'image/x-portable-bitmap',
714             PCD => 'image/x-photo-cd',
715             PCX => 'image/pcx',
716             PDB => 'application/vnd.palm',
717             PDF => 'application/pdf',
718             PEF => 'image/x-pentax-pef',
719             PFA => 'application/x-font-type1', # (needed if handled by PostScript module)
720             PGF => 'image/pgf',
721             PGM => 'image/x-portable-graymap',
722             PHP => 'application/x-httpd-php',
723             PICT => 'image/pict',
724             PLIST=> 'application/xml', # (binary PLIST format is 'application/x-plist', recognized at run time)
725             PMP => 'image/x-sony-pmp', #PH (NC)
726             PNG => 'image/png',
727             POT => 'application/vnd.ms-powerpoint',
728             POTM => 'application/vnd.ms-powerpoint.template.macroEnabled.12',
729             POTX => 'application/vnd.openxmlformats-officedocument.presentationml.template',
730             PPAM => 'application/vnd.ms-powerpoint.addin.macroEnabled.12',
731             PPAX => 'application/vnd.openxmlformats-officedocument.presentationml.addin', # (NC, PH invented)
732             PPM => 'image/x-portable-pixmap',
733             PPS => 'application/vnd.ms-powerpoint',
734             PPSM => 'application/vnd.ms-powerpoint.slideshow.macroEnabled.12',
735             PPSX => 'application/vnd.openxmlformats-officedocument.presentationml.slideshow',
736             PPT => 'application/vnd.ms-powerpoint',
737             PPTM => 'application/vnd.ms-powerpoint.presentation.macroEnabled.12',
738             PPTX => 'application/vnd.openxmlformats-officedocument.presentationml.presentation',
739             PS => 'application/postscript',
740             PSD => 'application/vnd.adobe.photoshop',
741             PSP => 'image/x-paintshoppro', #(NC)
742             QTIF => 'image/x-quicktime',
743             R3D => 'video/x-red-r3d', #PH (invented)
744             RA => 'audio/x-pn-realaudio',
745             RAF => 'image/x-fujifilm-raf',
746             RAM => 'audio/x-pn-realaudio',
747             RAR => 'application/x-rar-compressed',
748             RAW => 'image/x-raw',
749             RM => 'application/vnd.rn-realmedia',
750             RMVB => 'application/vnd.rn-realmedia-vbr',
751             RPM => 'audio/x-pn-realaudio-plugin',
752             RSRC => 'application/ResEdit',
753             RTF => 'text/rtf',
754             RV => 'video/vnd.rn-realvideo',
755             RW2 => 'image/x-panasonic-rw2',
756             RWL => 'image/x-leica-rwl',
757             RWZ => 'image/x-rawzor', #(duplicated in Rawzor.pm)
758             SEQ => 'image/x-flir-seq', #PH (NC)
759             SKETCH => 'application/sketch',
760             SR2 => 'image/x-sony-sr2',
761             SRF => 'image/x-sony-srf',
762             SRW => 'image/x-samsung-srw',
763             SVG => 'image/svg+xml',
764             SWF => 'application/x-shockwave-flash',
765             TAR => 'application/x-tar',
766             THMX => 'application/vnd.ms-officetheme',
767             TIFF => 'image/tiff',
768             Torrent => 'application/x-bittorrent',
769             TTC => 'application/x-font-ttf',
770             TTF => 'application/x-font-ttf',
771             TXT => 'text/plain',
772             VCard=> 'text/vcard',
773             VRD => 'application/octet-stream', #PH (NC)
774             VSD => 'application/x-visio',
775             WDP => 'image/vnd.ms-photo',
776             WEBM => 'video/webm',
777             WMA => 'audio/x-ms-wma',
778             WMF => 'application/x-wmf',
779             WMV => 'video/x-ms-wmv',
780             WTV => 'video/x-ms-wtv',
781             X3F => 'image/x-sigma-x3f',
782             XCF => 'image/x-xcf',
783             XLA => 'application/vnd.ms-excel',
784             XLAM => 'application/vnd.ms-excel.addin.macroEnabled.12',
785             XLS => 'application/vnd.ms-excel',
786             XLSB => 'application/vnd.ms-excel.sheet.binary.macroEnabled.12',
787             XLSM => 'application/vnd.ms-excel.sheet.macroEnabled.12',
788             XLSX => 'application/vnd.openxmlformats-officedocument.spreadsheetml.sheet',
789             XLT => 'application/vnd.ms-excel',
790             XLTM => 'application/vnd.ms-excel.template.macroEnabled.12',
791             XLTX => 'application/vnd.openxmlformats-officedocument.spreadsheetml.template',
792             XML => 'application/xml',
793             XMP => 'application/rdf+xml',
794             ZIP => 'application/zip',
795             );
796              
797             # module names for processing routines of each file type
798             # - undefined entries default to same module name as file type
799             # - module name '' defaults to Image::ExifTool
800             # - module name '0' indicates a recognized but unsupported file
801             my %moduleName = (
802             AA => 'Audible',
803             ALIAS=> 0,
804             AVC => 0,
805             BTF => 'BigTIFF',
806             BZ2 => 0,
807             CRW => 'CanonRaw',
808             CHM => 'EXE',
809             COS => 'CaptureOne',
810             CZI => 'ZISRAW',
811             DEX => 0,
812             DOCX => 'OOXML',
813             DCX => 0,
814             DIR => 0,
815             DR4 => 'CanonVRD',
816             DSS => 'Olympus',
817             DWF => 0,
818             DWG => 0,
819             DXF => 0,
820             EPS => 'PostScript',
821             EXIF => '',
822             EXR => 'OpenEXR',
823             EXV => '',
824             ICC => 'ICC_Profile',
825             IND => 'InDesign',
826             FLV => 'Flash',
827             FPF => 'FLIR',
828             FPX => 'FlashPix',
829             GZIP => 'ZIP',
830             HDR => 'Radiance',
831             JP2 => 'Jpeg2000',
832             JPEG => '',
833             JXL => 'Jpeg2000',
834             LFP => 'Lytro',
835             LRI => 0,
836             MOV => 'QuickTime',
837             MKV => 'Matroska',
838             MP3 => 'ID3',
839             MRW => 'MinoltaRaw',
840             OGG => 'Ogg',
841             ORF => 'Olympus',
842             PDB => 'Palm',
843             PCD => 'PhotoCD',
844             PFM2 => 'Other',
845             PHP => 0,
846             PMP => 'Sony',
847             PS => 'PostScript',
848             PSD => 'Photoshop',
849             QTIF => 'QuickTime',
850             R3D => 'Red',
851             RAF => 'FujiFilm',
852             RAR => 'ZIP',
853             RAW => 'KyoceraRaw',
854             RWZ => 'Rawzor',
855             SWF => 'Flash',
856             TAR => 0,
857             TIFF => '',
858             TXT => 'Text',
859             VRD => 'CanonVRD',
860             WMF => 0,
861             X3F => 'SigmaRaw',
862             XCF => 'GIMP',
863             );
864              
865             $testLen = 1024; # number of bytes to read when testing for magic number
866              
867             # quick "magic number" file test used to avoid loading module unnecessarily:
868             # - regular expression evaluated on first $testLen bytes of file
869             # - must match beginning at first byte in file
870             # - this test must not be more stringent than module logic
871             %magicNumber = (
872             AA => '.{4}\x57\x90\x75\x36',
873             AIFF => '(FORM....AIF[FC]|AT&TFORM)',
874             ALIAS=> "book\0\0\0\0mark\0\0\0\0",
875             APE => '(MAC |APETAGEX|ID3)',
876             ASF => '\x30\x26\xb2\x75\x8e\x66\xcf\x11\xa6\xd9\x00\xaa\x00\x62\xce\x6c',
877             AVC => '\+A\+V\+C\+',
878             Torrent => 'd\d+:\w+',
879             BMP => 'BM',
880             BPG => "BPG\xfb",
881             BTF => '(II\x2b\0|MM\0\x2b)',
882             BZ2 => 'BZh[1-9]\x31\x41\x59\x26\x53\x59',
883             CHM => 'ITSF.{20}\x10\xfd\x01\x7c\xaa\x7b\xd0\x11\x9e\x0c\0\xa0\xc9\x22\xe6\xec',
884             CRW => '(II|MM).{4}HEAP(CCDR|JPGM)',
885             CZI => 'ZISRAWFILE\0{6}',
886             DCX => '\xb1\x68\xde\x3a',
887             DEX => "dex\n035\0",
888             DICOM=> '(.{128}DICM|\0[\x02\x04\x06\x08]\0[\0-\x20]|[\x02\x04\x06\x08]\0[\0-\x20]\0)',
889             DOCX => 'PK\x03\x04',
890             DPX => '(SDPX|XPDS)',
891             DR4 => 'IIII\x04\0\x04\0',
892             DSS => '(\x02dss|\x03ds2)',
893             DV => '\x1f\x07\0[\x3f\xbf]', # (not tested if extension recognized)
894             DWF => '\(DWF V\d',
895             DWG => 'AC10\d{2}\0',
896             DXF => '\s*0\s+\0?\s*SECTION\s+2\s+HEADER',
897             EPS => '(%!PS|%!Ad|\xc5\xd0\xd3\xc6)',
898             EXE => '(MZ|\xca\xfe\xba\xbe|\xfe\xed\xfa[\xce\xcf]|[\xce\xcf]\xfa\xed\xfe|Joy!peff|\x7fELF|#!\s*/\S*bin/|!\x0a)',
899             EXIF => '(II\x2a\0|MM\0\x2a)',
900             EXR => '\x76\x2f\x31\x01',
901             EXV => '\xff\x01Exiv2',
902             FITS => 'SIMPLE = {20}T',
903             FLAC => '(fLaC|ID3)',
904             FLIF => 'FLIF[0-\x6f][0-2]',
905             FLIR => '[AF]FF\0',
906             FLV => 'FLV\x01',
907             Font => '((\0\x01\0\0|OTTO|true|typ1)[\0\x01]|ttcf\0[\x01\x02]\0\0|\0[\x01\x02]|' .
908             '(.{6})?%!(PS-(AdobeFont-|Bitstream )|FontType1-)|Start(Comp|Master)?FontMetrics|wOF[F2])',
909             FPF => 'FPF Public Image Format\0',
910             FPX => '\xd0\xcf\x11\xe0\xa1\xb1\x1a\xe1',
911             GIF => 'GIF8[79]a',
912             GZIP => '\x1f\x8b\x08',
913             HDR => '#\?(RADIANCE|RGBE)\x0a',
914             HTML => '(\xef\xbb\xbf)?\s*(?i)<(!DOCTYPE\s+HTML|HTML|\?xml)', # (case insensitive)
915             ICC => '.{12}(scnr|mntr|prtr|link|spac|abst|nmcl|nkpf|cenc|mid |mlnk|mvis)(XYZ |Lab |Luv |YCbr|Yxy |RGB |GRAY|HSV |HLS |CMYK|CMY |[2-9A-F]CLR|nc..|\0{4}){2}',
916             IND => '\x06\x06\xed\xf5\xd8\x1d\x46\xe5\xbd\x31\xef\xe7\xfe\x74\xb7\x1d',
917             # ISO => signature is at byte 32768
918             ITC => '.{4}itch',
919             JP2 => '(\0\0\0\x0cjP( |\x1a\x1a)\x0d\x0a\x87\x0a|\xff\x4f\xff\x51\0)',
920             JPEG => '\xff\xd8\xff',
921             JSON => '(\xef\xbb\xbf)?\s*(\[\s*)?\{\s*"[^"]*"\s*:',
922             JXL => '\xff\x0a|\0\0\0\x0cJXL \x0d\x0a......ftypjxl ',
923             LFP => '\x89LFP\x0d\x0a\x1a\x0a',
924             LIF => '\x70\0{3}.{4}\x2a.{4}<\0',
925             LNK => '.{4}\x01\x14\x02\0{5}\xc0\0{6}\x46',
926             LRI => 'LELR \0',
927             M2TS => '(....)?\x47',
928             MIE => '~[\x10\x18]\x04.0MIE',
929             MIFF => 'id=ImageMagick',
930             MKV => '\x1a\x45\xdf\xa3',
931             MOV => '.{4}(free|skip|wide|ftyp|pnot|PICT|pict|moov|mdat|junk|uuid)', # (duplicated in WriteQuickTime.pl !!)
932             # MP3 => difficult to rule out
933             MPC => '(MP\+|ID3)',
934             MOI => 'V6',
935             MPEG => '\0\0\x01[\xb0-\xbf]',
936             MRC => '.{64}[\x01\x02\x03]\0\0\0[\x01\x02\x03]\0\0\0[\x01\x02\x03]\0\0\0.{132}MAP[\0 ](\x44\x44|\x44\x41|\x11\x11)\0\0',
937             MRW => '\0MR[MI]',
938             MXF => '\x06\x0e\x2b\x34\x02\x05\x01\x01\x0d\x01\x02', # (not tested if extension recognized)
939             OGG => '(OggS|ID3)',
940             ORF => '(II|MM)',
941             # PCD => signature is at byte 2048
942             PCX => '\x0a[\0-\x05]\x01[\x01\x02\x04\x08].{64}[\0-\x02]',
943             PDB => '.{60}(\.pdfADBE|TEXtREAd|BVokBDIC|DB99DBOS|PNRdPPrs|DataPPrs|vIMGView|PmDBPmDB|InfoINDB|ToGoToGo|SDocSilX|JbDbJBas|JfDbJFil|DATALSdb|Mdb1Mdb1|BOOKMOBI|DataPlkr|DataSprd|SM01SMem|TEXtTlDc|InfoTlIf|DataTlMl|DataTlPt|dataTDBP|TdatTide|ToRaTRPW|zTXTGPlm|BDOCWrdS)',
944             PDF => '\s*%PDF-\d+\.\d+',
945             PFM => 'P[Ff]\x0a\d+ \d+\x0a[-+0-9.]+\x0a',
946             PGF => 'PGF',
947             PHP => '<\?php\s',
948             PICT => '(.{10}|.{522})(\x11\x01|\x00\x11)',
949             PLIST=> '(bplist0|\s*<|\xfe\xff\x00)',
950             PMP => '.{8}\0{3}\x7c.{112}\xff\xd8\xff\xdb',
951             PNG => '(\x89P|\x8aM|\x8bJ)NG\r\n\x1a\n',
952             PPM => 'P[1-6]\s+',
953             PS => '(%!PS|%!Ad|\xc5\xd0\xd3\xc6)',
954             PSD => '8BPS\0[\x01\x02]',
955             PSP => 'Paint Shop Pro Image File\x0a\x1a\0{5}',
956             QTIF => '.{4}(idsc|idat|iicc)',
957             R3D => '\0\0..RED(1|2)',
958             RAF => 'FUJIFILM',
959             RAR => 'Rar!\x1a\x07\0',
960             RAW => '(.{25}ARECOYK|II|MM)',
961             Real => '(\.RMF|\.ra\xfd|pnm://|rtsp://|http://)',
962             RIFF => '(RIFF|LA0[234]|OFR |LPAC|wvpk|RF64)', # RIFF plus other variants
963             RSRC => '(....)?\0\0\x01\0',
964             RTF => '[\n\r]*\\{[\n\r]*\\\\rtf',
965             RWZ => 'rawzor',
966             SWF => '[FC]WS[^\0]',
967             TAR => '.{257}ustar( )?\0', # (this doesn't catch old-style tar files)
968             TXT => '(\xff\xfe|(\0\0)?\xfe\xff|(\xef\xbb\xbf)?[\x07-\x0d\x20-\x7e\x80-\xfe]*$)',
969             TIFF => '(II|MM)', # don't test magic number (some raw formats are different)
970             VCard=> '(?i)BEGIN:(VCARD|VCALENDAR)\r\n',
971             VRD => 'CANON OPTIONAL DATA\0',
972             WMF => '(\xd7\xcd\xc6\x9a\0\0|\x01\0\x09\0\0\x03)',
973             WTV => '\xb7\xd8\x00\x20\x37\x49\xda\x11\xa6\x4e\x00\x07\xe9\x5e\xad\x8d',
974             X3F => 'FOVb',
975             MacOS=> '\0\x05\x16\x07\0.\0\0Mac OS X ',
976             XCF => 'gimp xcf ',
977             XMP => '\0{0,3}(\xfe\xff|\xff\xfe|\xef\xbb\xbf)?\0{0,3}\s*<',
978             ZIP => 'PK\x03\x04',
979             );
980              
981             # file types with weak magic number recognition
982             my %weakMagic = ( MP3 => 1 );
983              
984             # file types that are determined by the process proc when FastScan == 3
985             # (when done, the process proc must exit after SetFileType if FastScan is 3)
986             my %processType = map { $_ => 1 } qw(JPEG TIFF XMP AIFF EXE Font PS Real VCard TXT);
987              
988             # Compact/XMPShorthand option settings
989             my %compactOpt = (
990             nopadding => 'NoPadding', noindent => 'NoIndent', nonewline => 'NoNewline',
991             shorthand => 'Shorthand', onedesc => 'OneDesc',
992             all => ['NoPadding','NoIndent','NoNewline','Shorthand','OneDesc'],
993             allspace => ['NoPadding','NoIndent','NoNewline'], allformat => ['Shorthand','OneDesc'],
994             # aliases to cover anticipated user typos
995             nonewlines => 'NoNewline', nospace => 'NoIndent', nospaces => 'NoIndent',
996             nopad => 'NoPadding', onedescr => 'OneDesc',
997             # allow numerical settings for backward compatibility
998             0 => 'None',
999             1 => 'NoPadding',
1000             2 => ['NoPadding','NoIndent'],
1001             3 => ['NoPadding','NoIndent','OneDesc'],
1002             4 => ['NoPadding','NoIndent','OneDesc','NoNewline'],
1003             5 => ['NoPadding','NoIndent','OneDesc','NoNewline','Shorthand'],
1004             );
1005             my %xmpShorthandOpt = ( 0 => 'None', 1 => 'Shorthand', 2 => ['Shorthand','OneDesc'] );
1006              
1007             # lookup for valid character set names (keys are all lower case)
1008             %charsetName = (
1009             # Charset setting alias(es)
1010             # ------------------------- --------------------------------------------
1011             utf8 => 'UTF8', cp65001 => 'UTF8', 'utf-8' => 'UTF8',
1012             latin => 'Latin', cp1252 => 'Latin', latin1 => 'Latin',
1013             latin2 => 'Latin2', cp1250 => 'Latin2',
1014             cyrillic => 'Cyrillic', cp1251 => 'Cyrillic', russian => 'Cyrillic',
1015             greek => 'Greek', cp1253 => 'Greek',
1016             turkish => 'Turkish', cp1254 => 'Turkish',
1017             hebrew => 'Hebrew', cp1255 => 'Hebrew',
1018             arabic => 'Arabic', cp1256 => 'Arabic',
1019             baltic => 'Baltic', cp1257 => 'Baltic',
1020             vietnam => 'Vietnam', cp1258 => 'Vietnam',
1021             thai => 'Thai', cp874 => 'Thai',
1022             doslatinus => 'DOSLatinUS', cp437 => 'DOSLatinUS',
1023             doslatin1 => 'DOSLatin1', cp850 => 'DOSLatin1',
1024             doscyrillic => 'DOSCyrillic', cp866 => 'DOSCyrillic',
1025             macroman => 'MacRoman', cp10000 => 'MacRoman', mac => 'MacRoman', roman => 'MacRoman',
1026             maclatin2 => 'MacLatin2', cp10029 => 'MacLatin2',
1027             maccyrillic => 'MacCyrillic', cp10007 => 'MacCyrillic',
1028             macgreek => 'MacGreek', cp10006 => 'MacGreek',
1029             macturkish => 'MacTurkish', cp10081 => 'MacTurkish',
1030             macromanian => 'MacRomanian', cp10010 => 'MacRomanian',
1031             maciceland => 'MacIceland', cp10079 => 'MacIceland',
1032             maccroatian => 'MacCroatian', cp10082 => 'MacCroatian',
1033             );
1034              
1035             # default family 0 group priority for writing
1036             # (NOTE: tags in groups not specified here will not be written unless
1037             # overridden by the module or specified when writing)
1038             my @defaultWriteGroups = qw(
1039             EXIF IPTC XMP MakerNotes QuickTime Photoshop ICC_Profile CanonVRD Adobe
1040             );
1041              
1042             # group hash for ExifTool-generated tags
1043             my %allGroupsExifTool = ( 0 => 'ExifTool', 1 => 'ExifTool', 2 => 'ExifTool' );
1044              
1045             # special tag names (not used for tag info)
1046             %specialTags = map { $_ => 1 } qw(
1047             TABLE_NAME SHORT_NAME PROCESS_PROC WRITE_PROC CHECK_PROC
1048             GROUPS FORMAT FIRST_ENTRY TAG_PREFIX PRINT_CONV
1049             WRITABLE TABLE_DESC NOTES IS_OFFSET IS_SUBDIR
1050             EXTRACT_UNKNOWN NAMESPACE PREFERRED SRC_TABLE PRIORITY
1051             AVOID WRITE_GROUP LANG_INFO VARS DATAMEMBER
1052             SET_GROUP1 PERMANENT INIT_TABLE
1053             );
1054              
1055             # headers for various segment types
1056             $exifAPP1hdr = "Exif\0\0";
1057             $xmpAPP1hdr = "http://ns.adobe.com/xap/1.0/\0";
1058             $xmpExtAPP1hdr = "http://ns.adobe.com/xmp/extension/\0";
1059             $psAPP13hdr = "Photoshop 3.0\0";
1060             $psAPP13old = 'Adobe_Photoshop2.5:';
1061              
1062 730     730 0 2169 sub DummyWriteProc { return 1; }
1063              
1064             # lookup for user lenses defined in @Image::ExifTool::UserDefined::Lenses
1065             %Image::ExifTool::userLens = ( );
1066              
1067             # queued plug-in tags to add to lookup
1068             @Image::ExifTool::pluginTags = ( );
1069             %Image::ExifTool::pluginTags = ( );
1070              
1071             my %systemTagsNotes = (
1072             Notes => q{
1073             extracted only if specifically requested or the L or L API
1074             option is set
1075             },
1076             );
1077              
1078             # tag information for preview image -- this should be used for all
1079             # PreviewImage tags so they are handled properly when reading/writing
1080             %Image::ExifTool::previewImageTagInfo = (
1081             Name => 'PreviewImage',
1082             Writable => 'undef',
1083             # a value of 'none' is ok...
1084             WriteCheck => '$val eq "none" ? undef : $self->CheckImage(\$val)',
1085             DataTag => 'PreviewImage',
1086             # accept either scalar or scalar reference
1087             RawConv => '$self->ValidateImage(ref $val ? $val : \$val, $tag)',
1088             # we allow preview image to be set to '', but we don't want a zero-length value
1089             # in the IFD, so set it temporarily to 'none'. Note that the length is <= 4,
1090             # so this value will fit in the IFD so the preview fixup won't be generated.
1091             ValueConvInv => '$val eq "" and $val="none"; $val',
1092             );
1093              
1094             # extra tags that aren't truly EXIF tags, but are generated by the script
1095             # Note: any tag in this list with a name corresponding to a Group0 name is
1096             # used to write the entire corresponding directory as a block.
1097             %Image::ExifTool::Extra = (
1098             GROUPS => { 0 => 'File', 1 => 'File', 2 => 'Image' },
1099             VARS => { NO_ID => 1 }, # tag ID's aren't meaningful for these tags
1100             WRITE_PROC => \&DummyWriteProc,
1101             Error => {
1102             Priority => 0,
1103             Groups => \%allGroupsExifTool,
1104             Notes => q{
1105             returns errors that may have occurred while reading or writing a file. Any
1106             Error will prevent the file from being processed. Minor errors may be
1107             downgraded to warnings with the -m or L option
1108             },
1109             },
1110             Warning => {
1111             Priority => 0,
1112             Groups => \%allGroupsExifTool,
1113             Notes => q{
1114             returns warnings that may have occurred while reading or writing a file.
1115             Use the -a or L option to see all warnings if more than one
1116             occurred. Minor warnings may be ignored with the -m or L
1117             option. Minor warnings with a capital "M" in the "[Minor]" designation
1118             indicate that the processing is affected by ignoring the warning
1119             },
1120             },
1121             Comment => {
1122             Notes => 'comment embedded in JPEG, GIF89a or PPM/PGM/PBM image',
1123             Writable => 1,
1124             WriteGroup => 'Comment',
1125             Priority => 0, # to preserve order of JPEG COM segments
1126             },
1127             Directory => {
1128             Groups => { 1 => 'System', 2 => 'Other' },
1129             Notes => q{
1130             the directory of the file as specified in the call to ExifTool, or "." if no
1131             directory was specified. May be written to move the file to another
1132             directory that will be created if doesn't already exist
1133             },
1134             Writable => 1,
1135             WritePseudo => 1,
1136             DelCheck => q{"Can't delete"},
1137             Protected => 1,
1138             RawConv => '$self->ConvertFileName($val)',
1139             # translate backslashes in directory names and add trailing '/'
1140             ValueConvInv => '$_ = $self->InverseFileName($val); m{[^/]$} and $_ .= "/"; $_',
1141             },
1142             FileName => {
1143             Groups => { 1 => 'System', 2 => 'Other' },
1144             Writable => 1,
1145             WritePseudo => 1,
1146             DelCheck => q{"Can't delete"},
1147             Protected => 1,
1148             Notes => q{
1149             may be written with a full path name to set FileName and Directory in one
1150             operation. This is such a powerful feature that a TestName tag is provided
1151             to allow dry-run tests before actually writing the file name. See
1152             L for more information on writing the
1153             FileName, Directory and TestName tags
1154             },
1155             RawConv => '$self->ConvertFileName($val)',
1156             ValueConvInv => '$self->InverseFileName($val)',
1157             },
1158             BaseName => {
1159             Groups => { 1 => 'System', 2 => 'Other' },
1160             Notes => q{
1161             file name without extension. Not generated unless specifically requested or
1162             the API L option is set
1163             },
1164             },
1165             FilePath => {
1166             Groups => { 1 => 'System', 2 => 'Other' },
1167             Notes => q{
1168             absolute path of source file. Not generated unless specifically requested or
1169             the API L option is set. Does not support Windows Unicode file
1170             names
1171             },
1172             },
1173             TestName => {
1174             Writable => 1,
1175             WritePseudo => 1,
1176             DelCheck => q{"Can't delete"},
1177             Protected => 1,
1178             WriteOnly => 1,
1179             Notes => q{
1180             this write-only tag may be used instead of FileName for dry-run tests of the
1181             file renaming feature. Writing this tag prints the old and new file names
1182             to the console, but does not affect the file itself
1183             },
1184             ValueConvInv => '$self->InverseFileName($val)',
1185             },
1186             FileSequence => {
1187             Groups => { 0 => 'ExifTool', 1 => 'ExifTool', 2 => 'Other' },
1188             Notes => q{
1189             sequence number for each source file when extracting or copying information,
1190             including files that fail the -if condition of the command-line application,
1191             beginning at 0 for the first file. Not generated unless specifically
1192             requested or the API L option is set
1193             },
1194             },
1195             FileSize => {
1196             Groups => { 1 => 'System', 2 => 'Other' },
1197             Notes => q{
1198             note that the print conversion for this tag uses historic prefixes: 1 kB =
1199             1024 bytes, etc.
1200             },
1201             PrintConv => \&ConvertFileSize,
1202             },
1203             ResourceForkSize => {
1204             Groups => { 1 => 'System', 2 => 'Other' },
1205             Notes => q{
1206             size of the file's resource fork if it contains data. Mac OS only. If this
1207             tag is generated the L option may be used to extract
1208             resource-fork information as a sub-document. When writing, the resource
1209             fork is preserved by default, but it may be deleted with C<-rsrc:all=> on
1210             the command line
1211             },
1212             PrintConv => \&ConvertFileSize,
1213             },
1214             ZoneIdentifier => {
1215             Groups => { 1 => 'System', 2 => 'Other' },
1216             Notes => q{
1217             Windows only. Existence indicates that the file has a Zone.Identifier
1218             alternate data stream, which is used by some Windows browsers to mark
1219             downloaded files as possibly unsafe to run. May be deleted to remove this
1220             stream. Requires Win32API::File
1221             },
1222             Writable => 1,
1223             WritePseudo => 1,
1224             Protected => 1,
1225             },
1226             FileType => {
1227             Groups => { 2 => 'Other' },
1228             Notes => q{
1229             a short description of the file type. For many file types this is the just
1230             the uppercase file extension
1231             },
1232             },
1233             FileTypeExtension => {
1234             Groups => { 2 => 'Other' },
1235             Notes => q{
1236             a common lowercase extension for this file type, or uppercase with the -n
1237             option
1238             },
1239             PrintConv => 'lc $val',
1240             },
1241             FileModifyDate => {
1242             Description => 'File Modification Date/Time',
1243             Notes => q{
1244             the filesystem modification date/time. Note that ExifTool may not be able
1245             to handle filesystem dates before 1970 depending on the limitations of the
1246             system's standard libraries
1247             },
1248             Groups => { 1 => 'System', 2 => 'Time' },
1249             Writable => 1,
1250             WritePseudo => 1,
1251             DelCheck => q{"Can't delete"},
1252             # all writable pseudo-tags must be protected so -tagsfromfile fails with
1253             # unrecognized files unless a pseudo tag is specified explicitly
1254             Protected => 1,
1255             Shift => 'Time',
1256             ValueConv => 'ConvertUnixTime($val,1)',
1257             ValueConvInv => 'GetUnixTime($val,1)',
1258             PrintConv => '$self->ConvertDateTime($val)',
1259             PrintConvInv => '$self->InverseDateTime($val)',
1260             },
1261             FileAccessDate => {
1262             Description => 'File Access Date/Time',
1263             Notes => q{
1264             the date/time of last access of the file. Note that this access time is
1265             updated whenever any software, including ExifTool, reads the file
1266             },
1267             Groups => { 1 => 'System', 2 => 'Time' },
1268             ValueConv => 'ConvertUnixTime($val,1)',
1269             PrintConv => '$self->ConvertDateTime($val)',
1270             },
1271             FileCreateDate => {
1272             Description => 'File Creation Date/Time',
1273             Notes => q{
1274             the filesystem creation date/time. Windows/Mac only. In Windows, the file
1275             creation date/time is preserved by default when writing if Win32API::File
1276             and Win32::API are available. On Mac, this tag is extracted only if it or
1277             the MacOS group is specifically requested or the API L option is
1278             set to 2 or higher. Requires "setfile" for writing on Mac, which may be
1279             installed by typing C in the Terminal
1280             },
1281             Groups => { 1 => 'System', 2 => 'Time' },
1282             Writable => 1,
1283             WritePseudo => 1,
1284             DelCheck => q{"Can't delete"},
1285             Protected => 1, # all writable pseudo-tags must be protected!
1286             Shift => 'Time',
1287             ValueConv => '$^O eq "darwin" ? $val : ConvertUnixTime($val,1)',
1288             ValueConvInv => q{
1289             return GetUnixTime($val,1) if $^O eq 'MSWin32';
1290             return $val if $^O eq 'darwin';
1291             warn "This tag is Windows/Mac only\n";
1292             return undef;
1293             },
1294             PrintConv => '$self->ConvertDateTime($val)',
1295             PrintConvInv => '$self->InverseDateTime($val)',
1296             },
1297             FileInodeChangeDate => {
1298             Description => 'File Inode Change Date/Time',
1299             Notes => q{
1300             the date/time when the file's directory information was last changed.
1301             Non-Windows systems only
1302             },
1303             Groups => { 1 => 'System', 2 => 'Time' },
1304             ValueConv => 'ConvertUnixTime($val,1)',
1305             PrintConv => '$self->ConvertDateTime($val)',
1306             },
1307             FilePermissions => {
1308             Groups => { 1 => 'System', 2 => 'Other' },
1309             Notes => q{
1310             r=read, w=write and x=execute permissions for the file owner, group and
1311             others. The ValueConv value is an octal number so bit test operations on
1312             this value should be done in octal, eg. 'oct($filePermissions#) & 0200'
1313             },
1314             Writable => 1,
1315             WritePseudo => 1,
1316             DelCheck => q{"Can't delete"},
1317             Protected => 1, # all writable pseudo-tags must be protected!
1318             ValueConv => 'sprintf("%.3o", $val)',
1319             ValueConvInv => 'oct($val & 07777)',
1320             PrintConv => sub {
1321             my ($mask, $val) = (0400, oct(shift));
1322             my %types = (
1323             0010000 => 'p',
1324             0020000 => 'c',
1325             0040000 => 'd',
1326             0060000 => 'b',
1327             0120000 => 'l',
1328             0140000 => 's',
1329             );
1330             my $str = $types{$val & 0170000} || '-';
1331             while ($mask) {
1332             foreach (qw(r w x)) {
1333             $str .= $val & $mask ? $_ : '-';
1334             $mask >>= 1;
1335             }
1336             }
1337             return $str;
1338             },
1339             PrintConvInv => sub {
1340             my ($bit, $val, $str) = (8, 0, shift);
1341             $str = substr($str, 1) if length($str) == 10;
1342             return undef if length($str) != 9;
1343             while ($bit >= 0) {
1344             foreach (qw(r w x)) {
1345             $val |= (1 << $bit) if substr($str, 8-$bit, 1) eq $_;
1346             --$bit;
1347             }
1348             }
1349             return sprintf('%.3o', $val);
1350             },
1351             },
1352             FileAttributes => {
1353             Groups => { 1 => 'System', 2 => 'Other' },
1354             Notes => q{
1355             extracted only if specifically requested or the L or L API
1356             option is set. 2 or 3 values: 0. File type, 1. Attribute bits, 2. Windows
1357             attribute bits if Win32API::File is available
1358             },
1359             PrintHex => 1,
1360             PrintConvColumns => 2,
1361             PrintConv => [{ # stat device types (bitmask 0xf000)
1362             0x0000 => 'Unknown',
1363             0x1000 => 'FIFO',
1364             0x2000 => 'Character',
1365             0x3000 => 'Mux Character',
1366             0x4000 => 'Directory',
1367             0x5000 => 'XENIX Named',
1368             0x6000 => 'Block',
1369             0x7000 => 'Mux Block',
1370             0x8000 => 'Regular',
1371             0x9000 => 'VxFS Compressed',
1372             0xa000 => 'Symbolic Link',
1373             0xb000 => 'Solaris Shadow Inode',
1374             0xc000 => 'Socket',
1375             0xd000 => 'Solaris Door',
1376             0xe000 => 'BSD Whiteout',
1377             },{ BITMASK => { # stat attribute bits (bitmask 0x0e00)
1378             9 => 'Sticky',
1379             10 => 'Set Group ID',
1380             11 => 'Set User ID',
1381             }},{ BITMASK => { # Windows attribute bits
1382             0 => 'Read Only',
1383             1 => 'Hidden',
1384             2 => 'System',
1385             3 => 'Volume Label',
1386             4 => 'Directory',
1387             5 => 'Archive',
1388             6 => 'Device',
1389             7 => 'Normal',
1390             8 => 'Temporary',
1391             9 => 'Sparse File',
1392             10 => 'Reparse Point',
1393             11 => 'Compressed',
1394             12 => 'Offline',
1395             13 => 'Not Content Indexed',
1396             14 => 'Encrypted',
1397             }}],
1398             },
1399             FileDeviceID => {
1400             Groups => { 1 => 'System', 2 => 'Other' },
1401             %systemTagsNotes,
1402             PrintConv => '(($val >> 24) & 0xff) . "." . ($val & 0xffffff)', # (major.minor)
1403             },
1404             FileDeviceNumber => { Groups => { 1 => 'System', 2 => 'Other' }, %systemTagsNotes },
1405             FileInodeNumber => { Groups => { 1 => 'System', 2 => 'Other' }, %systemTagsNotes },
1406             FileHardLinks => { Groups => { 1 => 'System', 2 => 'Other' }, %systemTagsNotes },
1407             FileUserID => {
1408             Groups => { 1 => 'System', 2 => 'Other' },
1409             Notes => q{
1410             extracted only if specifically requested or the L or L API
1411             option is set. Returns user ID number with the -n option, or name
1412             otherwise. May be written with either user name or number
1413             },
1414             Writable => 1,
1415             WritePseudo => 1,
1416             DelCheck => q{"Can't delete"},
1417             Protected => 1, # all writable pseudo-tags must be protected!
1418             PrintConv => 'eval { getpwuid($val) } || $val',
1419             PrintConvInv => 'eval { getpwnam($val) } || ($val=~/[^0-9]/ ? undef : $val)',
1420             },
1421             FileGroupID => {
1422             Groups => { 1 => 'System', 2 => 'Other' },
1423             Notes => q{
1424             extracted only if specifically requested or the L or L API
1425             option is set. Returns group ID number with the -n option, or name
1426             otherwise. May be written with either group name or number
1427             },
1428             Writable => 1,
1429             WritePseudo => 1,
1430             DelCheck => q{"Can't delete"},
1431             Protected => 1, # all writable pseudo-tags must be protected!
1432             PrintConv => 'eval { getgrgid($val) } || $val',
1433             PrintConvInv => 'eval { getgrnam($val) } || ($val=~/[^0-9]/ ? undef : $val)',
1434             },
1435             FileBlockSize => { Groups => { 1 => 'System', 2 => 'Other' }, %systemTagsNotes },
1436             FileBlockCount => { Groups => { 1 => 'System', 2 => 'Other' }, %systemTagsNotes },
1437             HardLink => {
1438             Writable => 1,
1439             DelCheck => q{"Can't delete"},
1440             WriteOnly => 1,
1441             WritePseudo => 1,
1442             Protected => 1,
1443             Notes => q{
1444             this write-only tag is used to create a hard link with the specified name to
1445             the source file. If the source file is edited, copied, renamed or moved in
1446             the same operation as writing HardLink, then the link is made to the updated
1447             file. Note that subsequent editing of either hard-linked file by exiftool
1448             will break the link unless the -overwrite_original_in_place option is used
1449             },
1450             ValueConvInv => '$val=~tr/\\\\/\//; $val',
1451             },
1452             SymLink => {
1453             Writable => 1,
1454             DelCheck => q{"Can't delete"},
1455             WriteOnly => 1,
1456             WritePseudo => 1,
1457             Protected => 1,
1458             Notes => q{
1459             this write-only tag is used to create a symbolic link with the specified
1460             name to the source file. If the source file is edited, copied, renamed or
1461             moved in the same operation as writing SymLink, then the link is made to the
1462             updated file. The link uses an absolute path unless it is created in the
1463             current working directory. Valid only for file systems that support
1464             symbolic links. Note that subsequent editing of the file via the symbolic
1465             link by exiftool will cause the link to be replaced by the edited file
1466             without changing the original unless the -overwrite_original_in_place option
1467             is used
1468             },
1469             ValueConvInv => '$val=~tr/\\\\/\//; $val',
1470             },
1471             MIMEType => { Notes => 'the MIME type of the source file', Groups => { 2 => 'Other' } },
1472             ImageWidth => { Notes => 'the width of the image in number of pixels' },
1473             ImageHeight => { Notes => 'the height of the image in number of pixels' },
1474             XResolution => { Notes => 'the horizontal pixel resolution' },
1475             YResolution => { Notes => 'the vertical pixel resolution' },
1476             MaxVal => { Notes => 'maximum pixel value in PPM or PGM image' },
1477             EXIF => {
1478             Notes => q{
1479             the full EXIF data block from JPEG, PNG, JP2, MIE and MIFF images. This tag
1480             is generated only if specifically requested
1481             },
1482             Groups => { 0 => 'EXIF', 1 => 'EXIF' },
1483             Flags => ['Writable' ,'Protected', 'Binary', 'DelGroup'],
1484             WriteCheck => q{
1485             return undef if $val =~ /^(II\x2a\0|MM\0\x2a)/;
1486             return 'Invalid EXIF data';
1487             },
1488             },
1489             IPTC => {
1490             Notes => q{
1491             the full IPTC data block. This tag is generated only if specifically
1492             requested
1493             },
1494             Groups => { 0 => 'IPTC', 1 => 'IPTC' },
1495             Flags => ['Writable', 'Protected', 'Binary', 'DelGroup'],
1496             Priority => 0, # so main IPTC (which hopefully comes first) takes priority
1497             WriteCheck => q{
1498             return undef if $val =~ /^(\x1c|\0+$)/;
1499             return 'Invalid IPTC data';
1500             },
1501             },
1502             XMP => {
1503             Notes => q{
1504             the XMP data block, but note that extended XMP in JPEG images may be split
1505             into multiple blocks. This tag is generated only if specifically requested
1506             },
1507             Groups => { 0 => 'XMP', 1 => 'XMP' },
1508             Flags => ['Writable', 'Protected', 'Binary', 'DelGroup'],
1509             Priority => 0, # so main xmp (which usually comes first) takes priority
1510             WriteCheck => q{
1511             require Image::ExifTool::XMP;
1512             return Image::ExifTool::XMP::CheckXMP($self, $tagInfo, \$val);
1513             },
1514             },
1515             XML => {
1516             Notes => 'the XML data block, extracted for some file types',
1517             Groups => { 0 => 'XML', 1 => 'XML' },
1518             Binary => 1,
1519             },
1520             ICC_Profile => {
1521             Notes => q{
1522             the full ICC_Profile data block. This tag is generated only if specifically
1523             requested
1524             },
1525             Groups => { 0 => 'ICC_Profile', 1 => 'ICC_Profile' },
1526             Flags => ['Writable' ,'Protected', 'Binary', 'DelGroup'],
1527             WriteCheck => q{
1528             require Image::ExifTool::ICC_Profile;
1529             return Image::ExifTool::ICC_Profile::ValidateICC(\$val);
1530             },
1531             },
1532             CanonVRD => {
1533             Notes => q{
1534             the full Canon DPP VRD trailer block. This tag is generated only if
1535             specifically requested
1536             },
1537             Groups => { 0 => 'CanonVRD', 1 => 'CanonVRD' },
1538             Flags => ['Writable' ,'Protected', 'Binary', 'DelGroup'],
1539             Permanent => 0, # (this is 1 by default for MakerNotes tags)
1540             WriteCheck => q{
1541             return undef if $val =~ /^CANON OPTIONAL DATA\0/;
1542             return 'Invalid CanonVRD data';
1543             },
1544             },
1545             CanonDR4 => {
1546             Notes => q{
1547             the full Canon DPP version 4 DR4 block. This tag is generated only if
1548             specifically requested
1549             },
1550             Groups => { 0 => 'CanonVRD', 1 => 'CanonVRD' },
1551             Flags => ['Writable' ,'Protected', 'Binary'],
1552             Permanent => 0, # (this is 1 by default for MakerNotes tags)
1553             WriteCheck => q{
1554             return undef if $val =~ /^IIII\x04\0\x04\0/;
1555             return 'Invalid CanonDR4 data';
1556             },
1557             },
1558             Adobe => {
1559             Notes => q{
1560             the JPEG APP14 Adobe segment. Extracted only if specified. See the
1561             L for more information
1562             },
1563             Groups => { 0 => 'APP14', 1 => 'Adobe' },
1564             WriteGroup => 'Adobe',
1565             Flags => ['Writable' ,'Protected', 'Binary'],
1566             },
1567             CurrentIPTCDigest => {
1568             Notes => q{
1569             MD5 digest of existing IPTC data. All zeros if IPTC exists but Digest::MD5
1570             is not installed. Only calculated for IPTC in the standard location as
1571             specified by the L. ExifTool
1572             automates the handling of this tag in the MWG module -- see the
1573             L for details
1574             },
1575             ValueConv => 'unpack("H*", $val)',
1576             },
1577             PreviewImage => {
1578             Notes => 'JPEG-format embedded preview image',
1579             Groups => { 2 => 'Preview' },
1580             Writable => 1,
1581             WriteCheck => '$self->CheckImage(\$val)',
1582             WriteGroup => 'All',
1583             # can't delete, so set to empty string and return no error
1584             DelCheck => '$val = ""; return undef',
1585             # accept either scalar or scalar reference
1586             RawConv => '$self->ValidateImage(ref $val ? $val : \$val, $tag)',
1587             },
1588             ThumbnailImage => {
1589             Groups => { 2 => 'Preview' },
1590             Notes => 'JPEG-format embedded thumbnail image',
1591             RawConv => '$self->ValidateImage(ref $val ? $val : \$val, $tag)',
1592             },
1593             OtherImage => {
1594             Groups => { 2 => 'Preview' },
1595             Notes => 'other JPEG-format embedded image',
1596             RawConv => '$self->ValidateImage(ref $val ? $val : \$val, $tag)',
1597             },
1598             PreviewPNG => {
1599             Groups => { 2 => 'Preview' },
1600             Notes => 'PNG-format embedded preview image',
1601             Binary => 1,
1602             },
1603             PreviewWMF => {
1604             Groups => { 2 => 'Preview' },
1605             Notes => 'WMF-format embedded preview image',
1606             Binary => 1,
1607             },
1608             PreviewTIFF => {
1609             Groups => { 2 => 'Preview' },
1610             Notes => 'TIFF-format embedded preview image',
1611             Binary => 1,
1612             },
1613             PreviewPDF => {
1614             Groups => { 2 => 'Preview' },
1615             Notes => 'PDF-format embedded preview image',
1616             Binary => 1,
1617             },
1618             ExifByteOrder => {
1619             Writable => 1,
1620             DelCheck => q{"Can't delete"},
1621             Notes => q{
1622             represents the byte order of EXIF information. May be written to set the
1623             byte order only for newly created EXIF segments
1624             },
1625             PrintConv => {
1626             II => 'Little-endian (Intel, II)',
1627             MM => 'Big-endian (Motorola, MM)',
1628             },
1629             },
1630             ExifUnicodeByteOrder => {
1631             Writable => 1,
1632             WriteOnly => 1,
1633             DelCheck => q{"Can't delete"},
1634             Notes => q{
1635             specifies the byte order to use when writing EXIF Unicode text. The EXIF
1636             specification is particularly vague about this byte ordering, and different
1637             applications use different conventions. By default ExifTool writes Unicode
1638             text in EXIF byte order, but this write-only tag may be used to force a
1639             specific order. Applies to the EXIF UserComment tag when writing special
1640             characters
1641             },
1642             PrintConv => {
1643             II => 'Little-endian (Intel, II)',
1644             MM => 'Big-endian (Motorola, MM)',
1645             },
1646             },
1647             ExifToolVersion => {
1648             Description => 'ExifTool Version Number',
1649             Groups => \%allGroupsExifTool,
1650             Notes => 'the version of ExifTool currently running',
1651             },
1652             ProcessingTime => {
1653             Groups => { 0 => 'ExifTool', 1 => 'ExifTool', 2 => 'Other' },
1654             Notes => q{
1655             the clock time in seconds taken by ExifTool to extract information from this
1656             file. Not generated unless specifically requested or the L API
1657             option is set. Requires Time::HiRes
1658             },
1659             PrintConv => 'sprintf("%.3g s", $val)',
1660             },
1661             RAFVersion => { Notes => 'RAF file version number' },
1662             JPEGDigest => {
1663             Notes => q{
1664             an MD5 digest of the JPEG quantization tables is combined with the component
1665             sub-sampling values to generate the value of this tag. The result is
1666             compared to known values in an attempt to deduce the originating software
1667             based only on the JPEG image data. For performance reasons, this tag is
1668             generated only if specifically requested or the API L option is set
1669             to 3 or higher
1670             },
1671             },
1672             JPEGQualityEstimate => {
1673             Notes => q{
1674             an estimate of the IJG JPEG quality setting for the image, calculated from
1675             the quantization tables. For performance reasons, this tag is generated
1676             only if specifically requested or the API L option is set to 3 or
1677             higher
1678             },
1679             },
1680             JPEGImageLength => {
1681             Notes => q{
1682             byte length of JPEG image without metadata. For performance reasons, this
1683             tag is generated only if specifically requested or the API L option
1684             is set to 3 or higher
1685             },
1686             },
1687             # Validate (added from Validate.pm)
1688             Now => {
1689             Groups => { 0 => 'ExifTool', 1 => 'ExifTool', 2 => 'Time' },
1690             Notes => q{
1691             the current date/time. Useful when setting the tag values, eg.
1692             C<"-modifydate. Not generated unless specifically requested or the
1693             API L option is set
1694             },
1695             PrintConv => '$self->ConvertDateTime($val)',
1696             },
1697             NewGUID => {
1698             Groups => { 0 => 'ExifTool', 1 => 'ExifTool', 2 => 'Other' },
1699             Notes => q{
1700             generates a new, random GUID with format
1701             YYYYmmdd-HHMM-SSNN-PPPP-RRRRRRRRRRRR, where Y=year, m=month, d=day, H=hour,
1702             M=minute, S=second, N=file sequence number in hex, P=process ID in hex, and
1703             R=random hex number; without dashes with the -n option. Not generated
1704             unless specifically requested or the API L option is set
1705             },
1706             PrintConv => '$val =~ s/(.{8})(.{4})(.{4})(.{4})/$1-$2-$3-$4-/; $val',
1707             },
1708             ID3Size => { Notes => 'size of the ID3 data block' },
1709             Geotag => {
1710             Writable => 1,
1711             WriteOnly => 1,
1712             WriteNothing => 1,
1713             AllowGroup => '(exif|gps|xmp|xmp-exif)',
1714             Notes => q{
1715             this write-only tag is used to define the GPS track log data or track log
1716             file name. Currently supported track log formats are GPX, NMEA RMC/GGA/GLL,
1717             KML, IGC, Garmin XML and TCX, Magellan PMGNTRK, Honeywell PTNTHPR, Winplus
1718             Beacon text, and Bramor gEO log files. May be set to the special value of
1719             "DATETIMEONLY" (all caps) to set GPS date/time tags if no input track points
1720             are available. See L for details
1721             },
1722             DelCheck => q{
1723             require Image::ExifTool::Geotag;
1724             # delete associated tags
1725             Image::ExifTool::Geotag::SetGeoValues($self, undef, $wantGroup);
1726             },
1727             ValueConvInv => q{
1728             require Image::ExifTool::Geotag;
1729             # always warn because this tag is never set (warning is "\n" on success)
1730             my $result = Image::ExifTool::Geotag::LoadTrackLog($self, $val);
1731             return '' if not defined $result; # deleting geo tags
1732             return $result if ref $result; # geotag data hash reference
1733             warn "$result\n"; # error string
1734             },
1735             },
1736             Geotime => {
1737             Writable => 1,
1738             WriteOnly => 1,
1739             AllowGroup => '(exif|gps|xmp|xmp-exif)',
1740             Notes => q{
1741             this write-only tag is used to define a date/time for interpolating a
1742             position in the GPS track specified by the Geotag tag. Writing this tag
1743             causes GPS information to be written into the EXIF or XMP of the target
1744             files. The local system timezone is assumed if the date/time value does not
1745             contain a timezone. May be deleted to delete associated GPS tags. A group
1746             name of "EXIF" or "XMP" may be specified to write or delete only EXIF or XMP
1747             GPS tags
1748             },
1749             DelCheck => q{
1750             require Image::ExifTool::Geotag;
1751             # delete associated tags
1752             Image::ExifTool::Geotag::SetGeoValues($self, undef, $wantGroup);
1753             },
1754             ValueConvInv => q{
1755             require Image::ExifTool::Geotag;
1756             warn Image::ExifTool::Geotag::SetGeoValues($self, $val, $wantGroup) . "\n";
1757             return undef;
1758             },
1759             },
1760             Geosync => {
1761             Writable => 1,
1762             WriteOnly => 1,
1763             WriteNothing => 1,
1764             AllowGroup => '(exif|gps|xmp|xmp-exif)',
1765             Shift => 'Time', # enables "+=" syntax as well as "=+"
1766             Notes => q{
1767             this write-only tag specifies a time difference to add to Geotime for
1768             synchronization with the GPS clock. For example, set this to "-12" if the
1769             camera clock is 12 seconds faster than GPS time. Input format is
1770             "[+-][[[DD ]HH:]MM:]SS[.ss]". Additional features allow calculation of time
1771             differences and time drifts, and extraction of synchronization times from
1772             image files. See the L for details
1773             },
1774             ValueConvInv => q{
1775             require Image::ExifTool::Geotag;
1776             return Image::ExifTool::Geotag::ConvertGeosync($self, $val);
1777             },
1778             },
1779             ForceWrite => {
1780             Groups => { 0 => '*', 1 => '*', 2 => '*' },
1781             Writable => 1,
1782             WriteOnly => 1,
1783             Notes => q{
1784             write-only tag used to force metadata in a file to be rewritten even if no
1785             tag values are changed. May be set to "EXIF", "IPTC", "XMP" or "PNG" to
1786             force the corresponding metadata type to be rewritten, "FixBase" to cause
1787             EXIF to be rewritten only if the MakerNotes offset base was fixed, or "All"
1788             to rewrite all of these metadata types. Values are case insensitive, and
1789             multiple values may be separated with commas, eg. C<-ForceWrite=exif,xmp>
1790             },
1791             },
1792             EmbeddedVideo => { Groups => { 0 => 'Trailer', 2 => 'Video' } },
1793             Trailer => {
1794             Groups => { 0 => 'Trailer' },
1795             Notes => q{
1796             the full JPEG trailer data block. Extracted only if specifically requested
1797             or the API RequestAll option is set to 3 or higher
1798             },
1799             Writable => 1,
1800             Protected => 1,
1801             },
1802             PageCount => { Notes => 'the number of pages in a multi-page TIFF document' },
1803             );
1804              
1805             # tags defined by UserParam option (added at runtime)
1806             %Image::ExifTool::UserParam = (
1807             GROUPS => { 0 => 'UserParam', 1 => 'UserParam', 2 => 'Other' },
1808             PRIORITY => 0,
1809             );
1810              
1811             # YCbCrSubSampling values (used by JPEG SOF, EXIF and XMP)
1812             %Image::ExifTool::JPEG::yCbCrSubSampling = (
1813             '1 1' => 'YCbCr4:4:4 (1 1)', #PH
1814             '2 1' => 'YCbCr4:2:2 (2 1)', #14 in Exif.pm
1815             '2 2' => 'YCbCr4:2:0 (2 2)', #14 in Exif.pm
1816             '4 1' => 'YCbCr4:1:1 (4 1)', #14 in Exif.pm
1817             '4 2' => 'YCbCr4:1:0 (4 2)', #PH
1818             '1 2' => 'YCbCr4:4:0 (1 2)', #PH
1819             '1 4' => 'YCbCr4:4:1 (1 4)', #JD
1820             '2 4' => 'YCbCr4:2:1 (2 4)', #JD
1821             );
1822              
1823             # define common JPEG segments here to avoid overhead of loading JPEG module
1824              
1825             # JPEG SOF (start of frame) tags
1826             # (ref http://www.w3.org/Graphics/JPEG/itu-t81.pdf)
1827             %Image::ExifTool::JPEG::SOF = (
1828             GROUPS => { 0 => 'File', 1 => 'File', 2 => 'Image' },
1829             NOTES => 'This information is extracted from the JPEG Start Of Frame segment.',
1830             VARS => { NO_ID => 1 }, # tag ID's aren't meaningful for these tags
1831             EncodingProcess => {
1832             PrintHex => 1,
1833             PrintConv => {
1834             0x0 => 'Baseline DCT, Huffman coding',
1835             0x1 => 'Extended sequential DCT, Huffman coding',
1836             0x2 => 'Progressive DCT, Huffman coding',
1837             0x3 => 'Lossless, Huffman coding',
1838             0x5 => 'Sequential DCT, differential Huffman coding',
1839             0x6 => 'Progressive DCT, differential Huffman coding',
1840             0x7 => 'Lossless, Differential Huffman coding',
1841             0x9 => 'Extended sequential DCT, arithmetic coding',
1842             0xa => 'Progressive DCT, arithmetic coding',
1843             0xb => 'Lossless, arithmetic coding',
1844             0xd => 'Sequential DCT, differential arithmetic coding',
1845             0xe => 'Progressive DCT, differential arithmetic coding',
1846             0xf => 'Lossless, differential arithmetic coding',
1847             }
1848             },
1849             BitsPerSample => { },
1850             ImageHeight => { },
1851             ImageWidth => { },
1852             ColorComponents => { },
1853             YCbCrSubSampling => {
1854             Notes => 'calculated from components table',
1855             PrintConv => \%Image::ExifTool::JPEG::yCbCrSubSampling,
1856             },
1857             );
1858              
1859             # JPEG JFIF APP0 definitions
1860             %Image::ExifTool::JFIF::Main = (
1861             PROCESS_PROC => \&Image::ExifTool::ProcessBinaryData,
1862             WRITE_PROC => \&Image::ExifTool::WriteBinaryData,
1863             CHECK_PROC => \&Image::ExifTool::CheckBinaryData,
1864             GROUPS => { 0 => 'JFIF', 1 => 'JFIF', 2 => 'Image' },
1865             DATAMEMBER => [ 2, 3, 5 ],
1866             0 => {
1867             Name => 'JFIFVersion',
1868             Format => 'int8u[2]',
1869             PrintConv => 'sprintf("%d.%.2d", split(" ",$val))',
1870             Mandatory => 1,
1871             },
1872             2 => {
1873             Name => 'ResolutionUnit',
1874             Writable => 1,
1875             RawConv => '$$self{JFIFResolutionUnit} = $val',
1876             PrintConv => {
1877             0 => 'None',
1878             1 => 'inches',
1879             2 => 'cm',
1880             },
1881             Priority => -1,
1882             Mandatory => 1,
1883             },
1884             3 => {
1885             Name => 'XResolution',
1886             Format => 'int16u',
1887             Writable => 1,
1888             Priority => -1,
1889             RawConv => '$$self{JFIFXResolution} = $val',
1890             Mandatory => 1,
1891             },
1892             5 => {
1893             Name => 'YResolution',
1894             Format => 'int16u',
1895             Writable => 1,
1896             Priority => -1,
1897             RawConv => '$$self{JFIFYResolution} = $val',
1898             Mandatory => 1,
1899             },
1900             7 => {
1901             Name => 'ThumbnailWidth',
1902             RawConv => '$val ? $$self{JFIFThumbnailWidth} = $val : undef',
1903             },
1904             8 => {
1905             Name => 'ThumbnailHeight',
1906             RawConv => '$val ? $$self{JFIFThumbnailHeight} = $val : undef',
1907             },
1908             9 => {
1909             Name => 'ThumbnailTIFF',
1910             Groups => { 2 => 'Preview' },
1911             Format => 'undef[3*($val{7}||0)*($val{8}||0)]',
1912             Notes => 'raw RGB thumbnail data, extracted as a TIFF image',
1913             RawConv => 'length($val) ? $val : undef',
1914             ValueConv => sub {
1915             my ($val, $et) = @_;
1916             my $len = length $val;
1917             return \ "Binary data $len bytes" unless $et->Options('Binary');
1918             my $img = MakeTiffHeader($$et{JFIFThumbnailWidth},$$et{JFIFThumbnailHeight},3,8) . $val;
1919             return \$img;
1920             },
1921             },
1922             );
1923             %Image::ExifTool::JFIF::Extension = (
1924             GROUPS => { 0 => 'JFIF', 1 => 'JFXX', 2 => 'Image' },
1925             NOTES => 'Thumbnail images extracted from the JFXX segment.',
1926             0x10 => {
1927             Name => 'ThumbnailImage',
1928             Groups => { 2 => 'Preview' },
1929             Notes => 'JPEG-format thumbnail image',
1930             RawConv => '$self->ValidateImage(\$val,$tag)',
1931             },
1932             0x11 => { # (untested)
1933             Name => 'ThumbnailTIFF',
1934             Groups => { 2 => 'Preview' },
1935             Notes => 'raw palette-color thumbnail data, extracted as a TIFF image',
1936             RawConv => '(length $val > 770 and $val !~ /^\0\0/) ? $val : undef',
1937             ValueConv => sub {
1938             my ($val, $et) = @_;
1939             my $len = length $val;
1940             return \ "Binary data $len bytes" unless $et->Options('Binary');
1941             my ($w, $h) = unpack('CC', $val);
1942             my $img = MakeTiffHeader($w,$h,1,8,undef,substr($val,2,768)) . substr($val,770);
1943             return \$img;
1944             },
1945             },
1946             0x13 => {
1947             Name => 'ThumbnailTIFF',
1948             Groups => { 2 => 'Preview' },
1949             Notes => 'raw RGB thumbnail data, extracted as a TIFF image',
1950             RawConv => '(length $val > 2 and $val !~ /^\0\0/) ? $val : undef',
1951             ValueConv => sub {
1952             my ($val, $et) = @_;
1953             my $len = length $val;
1954             return \ "Binary data $len bytes" unless $et->Options('Binary');
1955             my ($w, $h) = unpack('CC', $val);
1956             my $img = MakeTiffHeader($w,$h,3,8) . substr($val,2);
1957             return \$img;
1958             },
1959             },
1960             # Apple may add "AMPF" to the end of the JFIF record,
1961             # possibly indicating the existence of MPF images (ref forum12677)
1962             );
1963              
1964             # Composite tags (accumulation of all Composite tag tables)
1965             %Image::ExifTool::Composite = (
1966             GROUPS => { 0 => 'Composite', 1 => 'Composite' },
1967             TABLE_NAME => 'Image::ExifTool::Composite',
1968             SHORT_NAME => 'Composite',
1969             VARS => { NO_ID => 1 }, # want empty tagID's for Composite tags
1970             WRITE_PROC => \&DummyWriteProc,
1971             );
1972              
1973             my %compositeID; # lookup for new ID's of Composite tags based on original ID
1974              
1975             # static private ExifTool variables
1976              
1977             %allTables = ( ); # list of all tables loaded (except Composite tags)
1978             @tableOrder = ( ); # order the tables were loaded
1979              
1980             #------------------------------------------------------------------------------
1981             # Warning handler routines (warning string stored in $evalWarning)
1982             #
1983             # Set warning message
1984             # Inputs: 0) warning string (undef to reset warning)
1985 38     38 0 476 sub SetWarning($) { $evalWarning = $_[0]; }
1986              
1987             # Get warning message
1988 17     17 0 61 sub GetWarning() { return $evalWarning; }
1989              
1990             # Clean unnecessary information (line number, LF) from warning
1991             # Inputs: 0) warning string or undef to use $evalWarning
1992             # Returns: cleaned warning
1993             sub CleanWarning(;$)
1994             {
1995 223     223 0 358 my $str = shift;
1996 223 50       579 unless (defined $str) {
1997 223 50       478 return undef unless defined $evalWarning;
1998 223         345 $str = $evalWarning;
1999             }
2000 223 100       1215 $str = $1 if $str =~ /(.*) at /s;
2001 223         777 $str =~ s/\s+$//s;
2002 223         826 return $str;
2003             }
2004              
2005             #==============================================================================
2006             # New - create new ExifTool object
2007             # Inputs: 0) reference to exiftool object or ExifTool class name
2008             # Returns: blessed ExifTool object ref
2009             sub new
2010             {
2011 471     471 1 103541 local $_;
2012 471         1086 my $that = shift;
2013 471   50     3030 my $class = ref($that) || $that || 'Image::ExifTool';
2014 471         1425 my $self = bless {}, $class;
2015              
2016             # make sure our main Exif tag table has been loaded
2017 471         1692 GetTagTable("Image::ExifTool::Exif::Main");
2018              
2019 471         2350 $self->ClearOptions(); # create default options hash
2020 471         1114 $$self{VALUE} = { }; # must initialize this for warning messages
2021 471         1280 $$self{PATH} = [ ]; # (this too)
2022 471         1141 $$self{DEL_GROUP} = { }; # lookup for groups to delete when writing
2023 471         1072 $$self{SAVE_COUNT} = 0; # count calls to SaveNewValues()
2024 471         1000 $$self{FILE_SEQUENCE} = 0; # sequence number for files when reading
2025              
2026             # initialize our new groups for writing
2027 471         2338 $self->SetNewGroups(@defaultWriteGroups);
2028              
2029 471         1938 return $self;
2030             }
2031              
2032             #------------------------------------------------------------------------------
2033             # ImageInfo - return specified information from image file
2034             # Inputs: 0) [optional] ExifTool object reference
2035             # 1) filename, file reference, or scalar data reference
2036             # 2-N) list of tag names to find (or tag list reference or options reference)
2037             # Returns: reference to hash of tag/value pairs (with "Error" entry on error)
2038             # Notes:
2039             # - if no tags names are specified, the values of all tags are returned
2040             # - tags may be specified with leading '-' to exclude, or trailing '#' for ValueConv
2041             # - can pass a reference to list of tags to find, in which case the list will
2042             # be updated with the tags found in the proper case and in the specified order.
2043             # - can pass reference to hash specifying options
2044             # - returned tag values may be scalar references indicating binary data
2045             # - see ClearOptions() below for a list of options and their default values
2046             # Examples:
2047             # use Image::ExifTool 'ImageInfo';
2048             # my $info = ImageInfo($file, 'DateTimeOriginal', 'ImageSize');
2049             # - or -
2050             # my $et = new Image::ExifTool;
2051             # my $info = $et->ImageInfo($file, \@tagList, {Sort=>'Group0'} );
2052             sub ImageInfo($;@)
2053             {
2054 506     506 1 22217 local $_;
2055             # get our ExifTool object ($self) or create one if necessary
2056 506         1045 my $self;
2057 506 100 100     4536 if (ref $_[0] and UNIVERSAL::isa($_[0],'Image::ExifTool')) {
2058 497         1177 $self = shift;
2059             } else {
2060 9         61 $self = new Image::ExifTool;
2061             }
2062 506         917 my %saveOptions = %{$$self{OPTIONS}}; # save original options
  506         18705  
2063              
2064             # initialize file information
2065 506         3191 $$self{FILENAME} = $$self{RAF} = undef;
2066              
2067 506         2283 $self->ParseArguments(@_); # parse our function arguments
2068 506         2237 $self->ExtractInfo(undef); # extract meta information from image
2069 506         2128 my $info = $self->GetInfo(undef); # get requested information
2070              
2071 506         6540 $$self{OPTIONS} = \%saveOptions; # restore original options
2072              
2073 506         2680 return $info; # return requested information
2074             }
2075              
2076             #------------------------------------------------------------------------------
2077             # Get/set ExifTool options
2078             # Inputs: 0) ExifTool object reference,
2079             # 1) Parameter name (case insensitive), 2) Value to set the option
2080             # 3-N) More parameter/value pairs
2081             # Returns: original value of last option specified
2082             sub Options($$;@)
2083             {
2084 17747     17747 1 46998 local $_;
2085 17747         22124 my $self = shift;
2086 17747         23853 my $options = $$self{OPTIONS};
2087 17747         20407 my $oldVal;
2088              
2089 17747         32851 while (@_) {
2090 20395         27103 my $param = shift;
2091             # fix parameter case if necessary
2092 20395 100       38430 unless (exists $$options{$param}) {
2093 372         18328 my ($fixed) = grep /^$param$/i, keys %$options;
2094 372 50       1959 if ($fixed) {
2095 0         0 $param = $fixed;
2096             } else {
2097 372         1306 $param =~ s/^Group(\d*)$/Group$1/i;
2098             }
2099             }
2100 20395         27695 $oldVal = $$options{$param};
2101 20395 50 33     35822 if (ref $oldVal eq 'HASH' and ($param eq 'Compact' or $param eq 'XMPShorthand')) {
      66        
2102             # get previous Compact/XMPShorthand setting
2103 0         0 $oldVal = $$oldVal{$param};
2104             }
2105 20395 100       36204 last unless @_;
2106 4780         5776 my $newVal = shift;
2107 4780 100 66     30015 if ($param eq 'Lang') {
    100 100        
    100 66        
    100          
    100          
    100          
    100          
    100          
2108             # allow this to be set to undef to select the default language
2109 76 50       282 $newVal = $defaultLang unless defined $newVal;
2110 76 100       259 if ($newVal eq $defaultLang) {
2111 58         139 $$options{$param} = $newVal;
2112 58         154 delete $$self{CUR_LANG};
2113             # make sure the language is available
2114             } else {
2115 18         84 my %langs = map { $_ => 1 } @langs;
  324         838  
2116 18 50 33     2377 if ($langs{$newVal} and eval "require Image::ExifTool::Lang::$newVal") {
2117 18         172 my $xlat = "Image::ExifTool::Lang::${newVal}::Translate";
2118 104     104   1079 no strict 'refs';
  104         232  
  104         333944  
2119 18 50       217 if (%$xlat) {
2120 18         141 $$self{CUR_LANG} = \%$xlat;
2121 18         392 $$options{$param} = $newVal;
2122             }
2123             }
2124             } # else don't change Lang
2125             } elsif ($param eq 'Exclude' and defined $newVal) {
2126             # clone Exclude list and expand shortcuts
2127 7         24 my @exclude;
2128 7 100       33 if (ref $newVal eq 'ARRAY') {
2129 6         21 @exclude = @$newVal;
2130             } else {
2131 1         3 @exclude = ($newVal);
2132             }
2133 7         29 ExpandShortcuts(\@exclude, 1); # (also remove '#' suffix)
2134 7         30 $$options{$param} = \@exclude;
2135             } elsif ($param =~ /^Charset/ or $param eq 'IPTCCharset') {
2136             # only allow valid character sets to be set
2137 358 100 66     1137 if ($newVal) {
    50 33        
    0          
2138 241         539 my $charset = $charsetName{lc $newVal};
2139 241 50       430 if ($charset) {
2140 241         406 $$options{$param} = $charset;
2141             # maintain backward-compatibility with old IPTCCharset option
2142 241 100       762 $$options{CharsetIPTC} = $charset if $param eq 'IPTCCharset';
2143             } else {
2144 0         0 warn "Invalid Charset $newVal\n";
2145             }
2146             } elsif ($param eq 'CharsetEXIF' or $param eq 'CharsetFileName' or $param eq 'CharsetRIFF') {
2147 117         304 $$options{$param} = $newVal; # only these may be set to a false value
2148             } elsif ($param eq 'CharsetQuickTime') {
2149 0         0 $$options{$param} = 'MacRoman'; # QuickTime defaults to MacRoman
2150             } else {
2151 0         0 $$options{$param} = 'Latin'; # all others default to Latin
2152             }
2153             } elsif ($param eq 'UserParam') {
2154             # clear options if $newVal is undef
2155 58 50       208 defined $newVal or $$options{$param} = {}, next;
2156 58         187 my $table = GetTagTable('Image::ExifTool::UserParam');
2157             # allow initialization of entire UserParam hash
2158 58 50       257 if (ref $newVal eq 'HASH') {
2159 58         119 my %newParams;
2160 58         284 foreach (sort keys %$newVal) {
2161 0         0 my $lcTag = lc $_;
2162 0         0 $newParams{$lcTag} = $$newVal{$_};
2163 0         0 delete $$table{$lcTag};
2164 0         0 AddTagToTable($table, $lcTag, $_);
2165             }
2166 58         156 $$options{$param} = \%newParams;
2167 58         183 next;
2168             }
2169 0         0 my ($force, $paramName);
2170             # set/reset single UserParam parameter
2171 0 0       0 if ($newVal =~ /(.*?)=(.*)/s) {
2172 0         0 $paramName = $1;
2173 0         0 $newVal = $2;
2174 0 0       0 $force = 1 if $paramName =~ s/\^$//;
2175 0         0 $paramName =~ tr/-_a-zA-Z0-9#//dc;
2176 0         0 $param = lc $paramName;
2177             } else {
2178 0         0 ($param = lc $newVal) =~ tr/-_a-zA-Z0-9#//dc;
2179 0         0 undef $newVal;
2180             }
2181 0         0 delete $$table{$param};
2182 0         0 $oldVal = $$options{UserParam}{$param};
2183 0 0       0 if (defined $newVal) {
2184 0 0 0     0 if (length $newVal or $force) {
2185 0         0 $$options{UserParam}{$param} = $newVal;
2186 0         0 AddTagToTable($table, $param, $paramName);
2187             } else {
2188 0         0 delete $$options{UserParam}{$param};
2189             }
2190             }
2191             # remove alternate version of tag
2192 0 0       0 $param .= '#' unless $param =~ s/#$//;
2193 0         0 delete $$table{$param};
2194 0         0 delete $$options{UserParam}{$param};
2195             } elsif ($param eq 'RequestTags') {
2196 100 100       305 if (defined $newVal) {
2197             # parse list from delimited string if necessary
2198 42 50       234 my @reqList = (ref $newVal eq 'ARRAY') ? @$newVal : ($newVal =~ /[-\w?*:]+/g);
2199 42         164 ExpandShortcuts(\@reqList);
2200             # add to existing list
2201 42 50       214 $$options{$param} or $$options{$param} = [ ];
2202 42         137 foreach (@reqList) {
2203 56 50       336 /^(.*:)?([-\w?*]*)#?$/ or next;
2204 56 50       413 push @{$$options{$param}}, lc($2) if $2;
  56         205  
2205 56 50       260 next unless $1;
2206             # add requested groups with trailing colon
2207 0         0 push @{$$options{$param}}, lc($_).':' foreach split /:/, $1;
  0         0  
2208             }
2209             } else {
2210 58         164 $$options{$param} = undef; # clear the list
2211             }
2212             } elsif ($param eq 'ListJoin') {
2213 10         30 $$options{$param} = $newVal;
2214             # set the old List and ListSep options for backward compatibility
2215 10 100       31 if (defined $newVal) {
2216 4         13 $$options{List} = 0;
2217 4         13 $$options{ListSep} = $newVal;
2218             } else {
2219 6         20 $$options{List} = 1;
2220             # (ListSep must be defined)
2221             }
2222             } elsif ($param eq 'List') {
2223 77         183 $$options{$param} = $newVal;
2224             # set the new ListJoin option for forward compatibility
2225 77 50       322 $$options{ListJoin} = $newVal ? undef : $$options{ListSep};
2226             } elsif ($param eq 'Compact' or $param eq 'XMPShorthand') {
2227             # set Compact and XMPShorthand options, preserving backward compatibility
2228 1         3 my ($p, %compact);
2229 1         4 foreach $p ('Compact','XMPShorthand') {
2230 2 100       7 my $val = $param eq $p ? $newVal : $$options{Compact}{$p};
2231 2 100       5 if (defined $val) {
2232 1         7 my @v = ($val =~ /\w+/g);
2233 1 50       4 my $opt = ($p eq 'Compact') ? \%compactOpt : \%xmpShorthandOpt;
2234 1         3 foreach (@v) {
2235 1 50       6 my $set = $$opt{lc $_} or warn("Invalid $p setting '${_}'\n"), return $oldVal;
2236 1 50       6 ref $set or $compact{$set} = 1, next;
2237 0         0 $compact{$_} = 1 foreach @$set;
2238             }
2239             }
2240 2         6 $compact{$p} = $val; # preserve most recent setting
2241             }
2242 1         5 $$options{Compact} = $$options{XMPShorthand} = \%compact;
2243             } else {
2244 4093 100 66     13326 if ($param eq 'Escape') {
    100 33        
    50          
    100          
2245             # set ESCAPE_PROC
2246 64 50 66     507 if (defined $newVal and $newVal eq 'XML') {
    100 66        
2247 0         0 require Image::ExifTool::XMP;
2248 0         0 $$self{ESCAPE_PROC} = \&Image::ExifTool::XMP::EscapeXML;
2249             } elsif (defined $newVal and $newVal eq 'HTML') {
2250 5         1237 require Image::ExifTool::HTML;
2251 5         20 $$self{ESCAPE_PROC} = \&Image::ExifTool::HTML::EscapeHTML;
2252             } else {
2253 59         143 delete $$self{ESCAPE_PROC};
2254             }
2255             # must forget saved values since they depend on Escape method
2256 64         304 $$self{BOTH} = { };
2257             } elsif ($param eq 'GlobalTimeShift') {
2258 59         150 delete $$self{GLOBAL_TIME_OFFSET}; # reset our calculated offset
2259             } elsif ($param eq 'TimeZone' and defined $newVal and length $newVal) {
2260 0         0 $ENV{TZ} = $newVal;
2261 0         0 eval { require POSIX; POSIX::tzset() };
  0         0  
  0         0  
2262             } elsif ($param eq 'Validate') {
2263             # load Validate module if Validate option enabled
2264 59 100       906 $newVal and require Image::ExifTool::Validate;
2265             }
2266 4093         8624 $$options{$param} = $newVal;
2267             }
2268             }
2269 17747         43670 return $oldVal;
2270             }
2271              
2272             #------------------------------------------------------------------------------
2273             # ClearOptions - set options to default values
2274             # Inputs: 0) ExifTool object reference
2275             sub ClearOptions($)
2276             {
2277 471     471 1 955 local $_;
2278 471         827 my $self = shift;
2279              
2280             # create options hash with default values
2281             # +-----------------------------------------------------+
2282             # ! DON'T FORGET!! When adding any new option, must !
2283             # ! decide how it is handled in SetNewValuesFromFile() !
2284             # +-----------------------------------------------------+
2285             # (Note: All options must exist in this lookup, even if undefined,
2286             # to facilitate case-insensitive options. 'Group#' is handled specially)
2287             $$self{OPTIONS} = {
2288 471         32176 Binary => undef, # flag to extract binary values even if tag not specified
2289             ByteOrder => undef, # default byte order when creating EXIF information
2290             Charset => 'UTF8', # character set for converting Unicode characters
2291             CharsetEXIF => undef, # internal EXIF "ASCII" string encoding
2292             CharsetFileName => undef, # external encoding for file names
2293             CharsetID3 => 'Latin', # internal ID3v1 character set
2294             CharsetIPTC => 'Latin', # fallback IPTC character set if no CodedCharacterSet
2295             CharsetPhotoshop => 'Latin', # internal encoding for Photoshop resource names
2296             CharsetQuickTime => 'MacRoman', # internal QuickTime string encoding
2297             CharsetRIFF => 0, # internal RIFF string encoding (0=default to Latin)
2298             Compact => { }, # write compact XMP
2299             Composite => 1, # flag to calculate Composite tags
2300             Compress => undef, # flag to write new values as compressed if possible
2301             CoordFormat => undef, # GPS lat/long coordinate format
2302             DateFormat => undef, # format for date/time
2303             Duplicates => 1, # flag to save duplicate tag values
2304             Escape => undef, # escape special characters
2305             Exclude => undef, # tags to exclude
2306             ExtendedXMP => 1, # strategy for reading extended XMP
2307             ExtractEmbedded =>undef,# flag to extract information from embedded documents
2308             FastScan => undef, # flag to avoid scanning for trailer
2309             Filter => undef, # output filter for all tag values
2310             FilterW => undef, # input filter when writing tag values
2311             FixBase => undef, # fix maker notes base offsets
2312             GeoMaxIntSecs => 1800, # geotag maximum interpolation time (secs)
2313             GeoMaxExtSecs => 1800, # geotag maximum extrapolation time (secs)
2314             GeoMaxHDOP => undef, # geotag maximum HDOP
2315             GeoMaxPDOP => undef, # geotag maximum PDOP
2316             GeoMinSats => undef, # geotag minimum satellites
2317             GeoSpeedRef => undef, # geotag GPSSpeedRef
2318             GlobalTimeShift => undef, # apply time shift to all extracted date/time values
2319             # Group# => undef, # return tags for specified groups in family #
2320             HexTagIDs => 0, # use hex tag ID's in family 7 group names
2321             HtmlDump => 0, # HTML dump (0-3, higher # = bigger limit)
2322             HtmlDumpBase => undef, # base address for HTML dump
2323             IgnoreMinorErrors => undef, # ignore minor errors when reading/writing
2324             Lang => $defaultLang,# localized language for descriptions etc
2325             LargeFileSupport => undef, # flag indicating support of 64-bit file offsets
2326             List => undef, # extract lists of PrintConv values into arrays [no longer documented]
2327             ListItem => undef, # used to return a specific item from lists
2328             ListJoin => ', ', # join lists together with this separator
2329             ListSep => ', ', # list item separator [no longer documented]
2330             ListSplit => undef, # regex for splitting list-type tag values when writing
2331             MakerNotes => undef, # extract maker notes as a block
2332             MDItemTags => undef, # extract MacOS metadata item tags
2333             MissingTagValue =>undef,# value for missing tags when expanded in expressions
2334             NoMultiExif => undef, # raise error when writing multi-segment EXIF
2335             NoPDFList => undef, # flag to avoid splitting PDF List-type tag values
2336             Password => undef, # password for password-protected PDF documents
2337             PrintConv => 1, # flag to enable print conversion
2338             QuickTimeHandler => 1, # flag to add mdir Handler to newly created Meta box
2339             QuickTimePad=> undef, # flag to preserve padding of QuickTime CR3 tags
2340             QuickTimeUTC=> undef, # assume that QuickTime date/time tags are stored as UTC
2341             RequestAll => undef, # extract all tags that must be specifically requested
2342             RequestTags => undef, # extra tags to request (on top of those in the tag list)
2343             SaveFormat => undef, # save family 6 tag TIFF format
2344             SavePath => undef, # save family 5 location path
2345             ScanForXMP => undef, # flag to scan for XMP information in all files
2346             Sort => 'Input', # order to sort found tags (Input, File, Tag, Descr, Group#)
2347             Sort2 => 'File', # secondary sort order for tags in a group (File, Tag, Descr)
2348             StrictDate => undef, # flag to return undef for invalid date conversions
2349             Struct => undef, # return structures as hash references
2350             SystemTags => undef, # extract additional File System tags
2351             TextOut => \*STDOUT,# file for Verbose/HtmlDump output
2352             TimeZone => undef, # local time zone
2353             Unknown => 0, # flag to get values of unknown tags (0-2)
2354             UserParam => { }, # user parameters for additional user-defined tag values
2355             Validate => undef, # perform additional validation
2356             Verbose => 0, # print verbose messages (0-5, higher # = more verbose)
2357             WriteMode => 'wcg', # enable all write modes by default
2358             XAttrTags => undef, # extract MacOS extended attribute tags
2359             XMPAutoConv => 1, # automatic conversion of unknown XMP tag values
2360             XMPShorthand=> 0, # (unused, but needed for backward compatibility)
2361             };
2362             # keep necessary member variables in sync with options
2363 471         1339 delete $$self{CUR_LANG};
2364 471         897 delete $$self{ESCAPE_PROC};
2365              
2366             # load user-defined default options
2367 471 50       1752 if (%Image::ExifTool::UserDefined::Options) {
2368 0         0 foreach (keys %Image::ExifTool::UserDefined::Options) {
2369 0         0 $self->Options($_, $Image::ExifTool::UserDefined::Options{$_});
2370             }
2371             }
2372             }
2373              
2374             #------------------------------------------------------------------------------
2375             # Extract meta information from image
2376             # Inputs: 0) ExifTool object reference
2377             # 1-N) Same as ImageInfo()
2378             # Returns: 1 if this was a valid image, 0 otherwise
2379             # Notes: pass an undefined value to avoid parsing arguments
2380             # Internal 'ReEntry' option allows this routine to be called recursively
2381             sub ExtractInfo($;@)
2382             {
2383 513     513 1 1027 local $_;
2384 513         964 my $self = shift;
2385 513         1094 my $options = $$self{OPTIONS}; # pointer to current options
2386 513   100     2281 my $fast = $$options{FastScan} || 0;
2387 513         1061 my $req = $$self{REQ_TAG_LOOKUP};
2388 513   100     1950 my $reqAll = $$options{RequestAll} || 0;
2389 513         1134 my (%saveOptions, $reEntry, $rsize, $zid, $type, @startTime, $saveOrder, $isDir);
2390              
2391             # check for internal ReEntry option to allow recursive calls to ExtractInfo
2392 513 100 100     2282 if (ref $_[1] eq 'HASH' and $_[1]{ReEntry} and
      33        
      66        
2393             (ref $_[0] eq 'SCALAR' or ref $_[0] eq 'GLOB'))
2394             {
2395             # save necessary members for restoring later
2396             $reEntry = {
2397             RAF => $$self{RAF},
2398             PROCESSED => $$self{PROCESSED},
2399             EXIF_DATA => $$self{EXIF_DATA},
2400             EXIF_POS => $$self{EXIF_POS},
2401             FILE_TYPE => $$self{FILE_TYPE},
2402 2         17 };
2403             $saveOrder = GetByteOrder(),
2404 2         7 $$self{RAF} = new File::RandomAccess($_[0]);
2405 2         6 $$self{PROCESSED} = { };
2406 2         4 delete $$self{EXIF_DATA};
2407 2         4 delete $$self{EXIF_POS};
2408             } else {
2409 511 100 66     4204 if (defined $_[0] or $$options{HtmlDump} or $$req{validate}) {
      66        
2410 6         157 %saveOptions = %$options; # save original options
2411              
2412             # require duplicates for html dump
2413 6 50       33 $self->Options(Duplicates => 1) if $$options{HtmlDump};
2414             # enable Validate option if Validate tag is requested
2415 6 100       22 $self->Options(Validate => 1) if $$req{validate};
2416              
2417 6 100       17 if (defined $_[0]) {
2418             # only initialize filename if called with arguments
2419 5         12 $$self{FILENAME} = undef; # name of file (or '' if we didn't open it)
2420 5         10 $$self{RAF} = undef; # RandomAccess object reference
2421              
2422 5         19 $self->ParseArguments(@_); # initialize from our arguments
2423             }
2424             }
2425             # initialize ExifTool object members
2426 511         1954 $self->Init();
2427              
2428 511         1121 delete $$self{MAKER_NOTE_FIXUP}; # fixup information for extracted maker notes
2429 511         873 delete $$self{MAKER_NOTE_BYTE_ORDER};
2430              
2431             # return our version number
2432 511         2735 $self->FoundTag('ExifToolVersion', "$VERSION$RELEASE");
2433 511 100 66     3151 $self->FoundTag('Now', $self->TimeNow()) if $$req{now} or $reqAll;
2434 511 100 66     2873 $self->FoundTag('NewGUID', NewGUID()) if $$req{newguid} or $reqAll;
2435             # generate sequence number if necessary
2436 511 100 66     2581 $self->FoundTag('FileSequence', $$self{FILE_SEQUENCE}) if $$req{filesequence} or $reqAll;
2437              
2438 511 100 66     2498 if ($$req{processingtime} or $reqAll) {
2439 58         143 eval { require Time::HiRes; @startTime = Time::HiRes::gettimeofday() };
  58         7901  
  58         19213  
2440 58 0 33     233 if (not @startTime and $$req{processingtime}) {
2441 0         0 $self->WarnOnce('Install Time::HiRes to generate ProcessingTime');
2442             }
2443             }
2444              
2445 511         1061 ++$$self{FILE_SEQUENCE}; # count files read
2446             }
2447              
2448 513         1203 my $filename = $$self{FILENAME}; # image file name ('' if already open)
2449 513         1023 my $raf = $$self{RAF}; # RandomAccess object
2450              
2451 513         1541 local *EXIFTOOL_FILE; # avoid clashes with global namespace
2452              
2453 513         1029 my $realname = $filename;
2454 513 100       1359 unless ($raf) {
2455             # save file name
2456 469 50 33     2313 if (defined $filename and $filename ne '') {
2457 469 50       1496 unless ($filename eq '-') {
2458             # extract file name from pipe if necessary
2459 469 50       1783 $realname =~ /\|$/ and $realname =~ s/^.*?"(.*?)".*/$1/s;
2460 469         1747 my ($dir, $name) = SplitFileName($realname);
2461 469         1756 $self->FoundTag('FileName', $name);
2462 469 100 66     3157 if ($$req{basename} or
      66        
2463             ($reqAll and not $$self{EXCL_TAG_LOOKUP}{basename}))
2464             {
2465 58 50       480 $self->FoundTag('BaseName', $name =~ /(.*)\./ ? $1 : $name);
2466             }
2467 469 50 33     3261 $self->FoundTag('Directory', $dir) if defined $dir and length $dir;
2468 469 100 66     3625 if ($$req{filepath} or
      66        
2469             ($reqAll and not $$self{EXCL_TAG_LOOKUP}{filepath}))
2470             {
2471 58         286 local $SIG{'__WARN__'} = \&SetWarning;
2472 58 50       141 if (eval { require Cwd }) {
  58 0       397  
2473 58         134 my $path = eval { Cwd::abs_path($filename) };
  58         2360  
2474 58 50       384 $self->FoundTag('FilePath', $path) if defined $path;
2475             } elsif ($$req{filepath}) {
2476 0         0 $self->WarnOnce('The Perl Cwd module must be installed to use FilePath');
2477             }
2478             }
2479             # get size of resource fork on Mac OS
2480 469 50 33     2565 $rsize = -s "$filename/..namedfork/rsrc" if $^O eq 'darwin' and not $$self{IN_RESOURCE};
2481             # check to see if Zone.Identifier file exists in Windows
2482 469 50 33     1883 if ($^O eq 'MSWin32' and eval { require Win32API::File }) {
  0         0  
2483 0         0 my $wattr;
2484 0         0 my $zfile = "${filename}:Zone.Identifier";
2485 0 0       0 if ($self->EncodeFileName($zfile)) {
2486 0         0 $wattr = eval { Win32API::File::GetFileAttributesW($zfile) };
  0         0  
2487             } else {
2488 0         0 $wattr = eval { Win32API::File::GetFileAttributes($zfile) };
  0         0  
2489             }
2490 0 0       0 $zid = 1 unless $wattr == Win32API::File::INVALID_FILE_ATTRIBUTES();
2491             }
2492             }
2493             # open the file
2494 469 50       2280 if ($self->Open(\*EXIFTOOL_FILE, $filename)) {
    0          
2495             # create random access file object
2496 469         4726 $raf = new File::RandomAccess(\*EXIFTOOL_FILE);
2497             # patch to force pipe to be buffered because seek returns success
2498             # in Windows cmd shell pipe even though it really failed
2499 469 50 33     3262 $$raf{TESTED} = -1 if $filename eq '-' or $filename =~ /\|$/;
2500 469         1360 $$self{RAF} = $raf;
2501             } elsif ($self->IsDirectory($filename)) {
2502 0         0 $isDir = 1;
2503             } else {
2504 0         0 $self->Error('Error opening file');
2505             }
2506             } else {
2507 0         0 $self->Error('No file specified');
2508             }
2509             }
2510              
2511 513   33     1896 while ($raf or $isDir) {
2512 513         1114 my (@stat, $plainFile);
2513 513 100       6970 if ($reEntry) {
    50          
    100          
    50          
2514             # we already set these tags
2515             } elsif (not $raf) {
2516 0         0 @stat = stat $filename;
2517             } elsif (not $$raf{FILE_PT}) {
2518             # get file size from image in memory
2519 22         48 $self->FoundTag('FileSize', length ${$$raf{BUFF_PT}});
  22         99  
2520             } elsif (-f $$raf{FILE_PT}) {
2521             # get file tags if this is a plain file
2522 489         2307 @stat = stat _;
2523 489         1025 $plainFile = 1;
2524             # hack to patch Windows daylight savings time bug
2525 489 50       1936 @stat[8,9,10] = $self->GetFileTime($$raf{FILE_PT}) if $^O eq 'MSWin32';
2526             } else {
2527             # (note that Windows directories will still show the
2528             # daylight savings time bug -- should fix this sometime)
2529 0         0 @stat = stat $$raf{FILE_PT};
2530             }
2531 513         1112 my $fileSize = $stat[7];
2532 513 100       2639 $self->FoundTag('FileSize', $stat[7]) if defined $stat[7];
2533 513 50       1693 $self->FoundTag('ResourceForkSize', $rsize) if $rsize;
2534 513 50       1442 $self->FoundTag('ZoneIdentifier', 'Exists') if $zid;
2535 513 100       2171 $self->FoundTag('FileModifyDate', $stat[9]) if defined $stat[9];
2536 513 100       2333 $self->FoundTag('FileAccessDate', $stat[8]) if defined $stat[8];
2537 513 50       2076 my $cTag = $^O eq 'MSWin32' ? 'FileCreateDate' : 'FileInodeChangeDate';
2538 513 100       2266 $self->FoundTag($cTag, $stat[10]) if defined $stat[10];
2539 513 100       2467 $self->FoundTag('FilePermissions', $stat[2]) if defined $stat[2];
2540             # extract more system info if SystemTags option is set
2541 513 100       1721 if (@stat) {
2542 489   66     2790 my $sys = $$options{SystemTags} || ($reqAll and not defined $$options{SystemTags});
2543 489 100 66     2893 if ($sys or $$req{fileattributes}) {
2544 58         203 my @attr = ($stat[2] & 0xf000, $stat[2] & 0x0e00);
2545             # add Windows file attributes if available
2546 58 0 33     273 if ($^O eq 'MSWin32' and defined $filename and $filename ne '' and $filename ne '-') {
      33        
      0        
2547 0         0 local $SIG{'__WARN__'} = \&SetWarning;
2548 0 0       0 if (eval { require Win32API::File }) {
  0         0  
2549 0         0 my $wattr;
2550 0         0 my $file = $filename;
2551 0 0       0 if ($self->EncodeFileName($file)) {
2552 0         0 $wattr = eval { Win32API::File::GetFileAttributesW($file) };
  0         0  
2553             } else {
2554 0         0 $wattr = eval { Win32API::File::GetFileAttributes($file) };
  0         0  
2555             }
2556 0 0 0     0 push @attr, $wattr if defined $wattr and $wattr != 0xffffffff;
2557             }
2558             }
2559 58         332 $self->FoundTag('FileAttributes', "@attr");
2560             }
2561 489 100 66     2431 $self->FoundTag('FileDeviceNumber', $stat[0]) if $sys or $$req{filedevicenumber};
2562 489 100 66     2458 $self->FoundTag('FileInodeNumber', $stat[1]) if $sys or $$req{fileinodenumber};
2563 489 100 66     2429 $self->FoundTag('FileHardLinks', $stat[3]) if $sys or $$req{filehardlinks};
2564 489 100 66     2305 $self->FoundTag('FileUserID', $stat[4]) if $sys or $$req{fileuserid};
2565 489 100 66     2371 $self->FoundTag('FileGroupID', $stat[5]) if $sys or $$req{filegroupid};
2566 489 100 66     2279 $self->FoundTag('FileDeviceID', $stat[6]) if $sys or $$req{filedeviceid};
2567 489 100 66     2568 $self->FoundTag('FileBlockSize', $stat[11]) if $sys or $$req{fileblocksize};
2568 489 100 66     2292 $self->FoundTag('FileBlockCount', $stat[12]) if $sys or $$req{fileblockcount};
2569             }
2570             # extract MDItem tags if requested (only on plain files)
2571 513 0 33     2071 if ($^O eq 'darwin' and defined $filename and $filename ne '' and defined $fileSize) {
      33        
      0        
2572 0   0     0 my $reqMacOS = ($reqAll > 1 or $$req{'macos:'});
2573 0   0     0 my $crDate = ($reqMacOS || $$req{filecreatedate});
2574 0   0     0 my $mdItem = ($reqMacOS || $$options{MDItemTags} || grep /^mditem/, keys %$req);
2575 0   0     0 my $xattr = ($reqMacOS || $$options{XAttrTags} || grep /^xattr/, keys %$req);
2576 0 0 0     0 if ($crDate or $mdItem or $xattr) {
      0        
2577 0         0 require Image::ExifTool::MacOS;
2578 0 0       0 Image::ExifTool::MacOS::GetFileCreateDate($self, $filename) if $crDate;
2579 0 0 0     0 Image::ExifTool::MacOS::ExtractMDItemTags($self, $filename) if $mdItem and $plainFile;
2580 0 0       0 Image::ExifTool::MacOS::ExtractXAttrTags($self, $filename) if $xattr;
2581             }
2582             }
2583             # do whatever else we can with directories, then return
2584 513 50 66     3481 if ($isDir or (defined $stat[2] and ($stat[2] & 0170000) == 0040000)) {
      33        
2585 0         0 $self->FoundTag('FileType', 'DIR');
2586 0         0 $self->FoundTag('FileTypeExtension', '');
2587 0 0       0 $self->BuildCompositeTags() if $$options{Composite};
2588 0 0       0 $raf->Close() if $raf;
2589 0         0 return 1;
2590             }
2591             # get list of file types to check
2592 513         1112 my ($tiffType, %noMagic, $recognizedExt);
2593 513         2322 my $ext = $$self{FILE_EXT} = GetFileExtension($realname);
2594             # set $recognizedExt if this file type is recognized by extension only
2595             $recognizedExt = $ext if defined $ext and not defined $magicNumber{$ext} and
2596 513 50 100     4757 defined $moduleName{$ext} and not $moduleName{$ext};
      100        
      66        
2597 513         1818 my @fileTypeList = GetFileType($realname);
2598 513 50       1713 if ($fast >= 4) {
2599 0 0       0 if (@fileTypeList) {
2600 0         0 $type = shift @fileTypeList;
2601 0         0 $self->SetFileType($$self{FILE_TYPE} = $type);
2602             } else {
2603 0         0 $self->Error('Unknown file type');
2604             }
2605 0 0 0     0 $self->BuildCompositeTags() if $fast == 4 and $$options{Composite};
2606 0         0 last; # don't read the file
2607             }
2608 513 100       1437 if (@fileTypeList) {
2609             # add remaining types to end of list so we test them all
2610 466         1576 my $pat = join '|', @fileTypeList;
2611 466         33946 push @fileTypeList, grep(!/^($pat)$/, @fileTypes);
2612 466         1510 $tiffType = $$self{FILE_EXT};
2613 466 100       1586 unless ($fast == 3) {
2614 465         1286 $noMagic{MXF} = 1; # don't do magic number test on MXF or DV files
2615 465         1280 $noMagic{DV} = 1;
2616             }
2617             } else {
2618             # scan through all recognized file types
2619 47         668 @fileTypeList = @fileTypes;
2620 47         117 $tiffType = 'TIFF';
2621             }
2622 513         1206 push @fileTypeList, ''; # end of list marker
2623             # initialize the input file for seeking in binary data
2624 513         2549 $raf->BinMode(); # set binary mode before we start reading
2625 513         1624 my $pos = $raf->Tell(); # get file position so we can rewind
2626             # loop through list of file types to test
2627 513         1029 my ($buff, $seekErr);
2628 513         2488 my %dirInfo = ( RAF => $raf, Base => $pos, TestBuff => \$buff );
2629             # read start of file for testing
2630 513 50       2110 $raf->Read($buff, $testLen) or $buff = '';
2631 513 50       2147 $raf->Seek($pos, 0) or $seekErr = 1;
2632 513         1803 until ($seekErr) {
2633 1900         2913 my $unkHeader;
2634 1900         2841 $type = shift @fileTypeList;
2635 1900 50       3232 if ($type) {
    0          
    0          
2636 1900 100       3956 if ($magicNumber{$type}) {
2637             # do quick test for this file type to avoid loading module unnecessarily
2638 1864 100 100     30478 next if $buff !~ /^$magicNumber{$type}/s and not $noMagic{$type};
2639             } else {
2640             # keep checking for other types if we recognize this file only by extension
2641 36 50 66     190 next if defined $moduleName{$type} and not $moduleName{$type};
2642 36 50       84 next if $fast > 2; # keep checking if we aren't processing the file
2643             }
2644 553 50 66     2526 next if $weakMagic{$type} and defined $recognizedExt;
2645             } elsif (not defined $type) {
2646 0         0 last;
2647             } elsif ($recognizedExt) {
2648 0         0 $type = $recognizedExt; # set type from recognized file extension only
2649             } else {
2650             # last ditch effort to scan past unknown header for JPEG/TIFF
2651 0 0       0 next unless $buff =~ /(\xff\xd8\xff|MM\0\x2a|II\x2a\0)/g;
2652 0 0       0 $type = ($1 eq "\xff\xd8\xff") ? 'JPEG' : 'TIFF';
2653 0         0 my $skip = pos($buff) - length($1);
2654 0         0 $dirInfo{Base} = $pos + $skip;
2655 0 0       0 $raf->Seek($pos + $skip, 0) or $seekErr = 1, last;
2656 0         0 $self->Warn("Processing $type-like data after unknown $skip-byte header");
2657 0 0       0 $unkHeader = 1 unless $$self{DOC_NUM};
2658             }
2659             # save file type in member variable
2660 553         1387 $$self{FILE_TYPE} = $type;
2661 553 100       2139 $dirInfo{Parent} = ($type eq 'TIFF') ? $tiffType : $type;
2662             # don't process the file when FastScan == 3
2663 553 50 66     2044 if ($fast == 3 and not $processType{$type}) {
2664 0 0 0     0 unless ($weakMagic{$type} and (not $ext or $ext ne $type)) {
      0        
2665 0         0 $self->SetFileType($dirInfo{Parent});
2666             }
2667 0         0 last;
2668             }
2669 553         1149 my $module = $moduleName{$type};
2670 553 100       1484 $module = $type unless defined $module;
2671 553         1337 my $func = "Process$type";
2672              
2673             # load module if necessary
2674 553 100       1612 if ($module) {
    50          
2675 301         19263 require "Image/ExifTool/$module.pm";
2676 301         1042 $func = "Image::ExifTool::${module}::$func";
2677             } elsif ($module eq '0') {
2678 0         0 $self->SetFileType();
2679 0         0 $self->Warn('Unsupported file type');
2680 0         0 last;
2681             }
2682 553         893 push @{$$self{PATH}}, $type; # save file type in metadata PATH
  553         1719  
2683              
2684             # process the file
2685 104     104   964 no strict 'refs';
  104         206  
  104         6421  
2686 553         3752 my $result = &$func($self, \%dirInfo);
2687 104     104   593 use strict 'refs';
  104         187  
  104         1202470  
2688              
2689 553         1168 pop @{$$self{PATH}};
  553         1599  
2690              
2691 553 100       1603 if ($result) { # all done if successful
2692 513 50       1303 if ($unkHeader) {
2693 0         0 $self->DeleteTag('FileType');
2694 0         0 $self->DeleteTag('FileTypeExtension');
2695 0         0 $self->DeleteTag('MIMEType');
2696 0         0 $self->VPrint(0,"Reset file type due to unknown header\n");
2697             }
2698 513         1111 last;
2699             }
2700             # seek back to try again from the same position in the file
2701 40 50       110 $raf->Seek($pos, 0) or $seekErr = 1, last;
2702             }
2703 513 0 33     1569 if (not defined $type and not $$self{DOC_NUM}) {
2704             # if we were given a single image with a known type there
2705             # must be a format error since we couldn't read it, otherwise
2706             # it is likely we don't support images of this type
2707 0   0     0 my $fileType = GetFileType($realname) || '';
2708 0         0 my $err;
2709 0 0       0 if (not length $buff) {
2710 0         0 $err = 'File is empty';
2711             } else {
2712 0         0 my $ch = substr($buff, 0, 1);
2713 0 0 0     0 if (length $buff < 16 or $buff =~ /[^\Q$ch\E]/) {
2714 0 0       0 if ($fileType eq 'RAW') {
    0          
2715 0         0 $err = 'Unsupported RAW file type';
2716             } elsif ($fileType) {
2717 0         0 $err = 'File format error';
2718             } else {
2719 0         0 $err = 'Unknown file type';
2720             }
2721             } else {
2722             # provide some insight into the content of some corrupted files
2723 0 0       0 if ($$self{OPTIONS}{FastScan}) {
2724 0         0 $err = 'File header is all';
2725             } else {
2726 0         0 my $num = 0;
2727 0         0 for (;;) {
2728 0 0       0 $raf->Read($buff, 65536) or undef($num), last;
2729 0 0       0 $buff =~ /[^\Q$ch\E]/g and $num += pos($buff) - 1, last;
2730 0         0 $num += length($buff);
2731             }
2732 0 0       0 if ($num) {
2733 0         0 $err = 'First ' . ConvertFileSize($num) . ' of file is';
2734             } else {
2735 0         0 $err = 'Entire file is';
2736             }
2737             }
2738 0 0       0 if ($ch eq "\0") {
    0          
    0          
2739 0         0 $err .= ' binary zeros';
2740             } elsif ($ch eq ' ') {
2741 0         0 $err .= ' ASCII spaces';
2742             } elsif ($ch =~ /[a-zA-Z0-9]/) {
2743 0         0 $err .= " ASCII '${ch}' characters";
2744             } else {
2745 0         0 $err .= sprintf(" binary 0x%.2x's", ord $ch);
2746             }
2747             }
2748             }
2749 0         0 $self->Error($err);
2750             }
2751 513 50 0     2255 if ($seekErr) {
    50 33        
2752 0         0 $self->Error('Error seeking in file');
2753             } elsif ($self->Options('ScanForXMP') and (not defined $type or
2754             (not $fast and not $$self{FoundXMP})))
2755             {
2756             # scan for XMP
2757 0         0 $raf->Seek($pos, 0);
2758 0         0 require Image::ExifTool::XMP;
2759 0 0       0 Image::ExifTool::XMP::ScanForXMP($self, $raf) and $type = '';
2760             }
2761             # extract binary EXIF data block only if requested
2762 513 100 100     3874 if (defined $$self{EXIF_DATA} and length $$self{EXIF_DATA} > 16 and
      100        
      100        
2763             ($$req{exif} or
2764             # (not extracted normally, so check TAGS_FROM_FILE)
2765             ($$self{TAGS_FROM_FILE} and not $$self{EXCL_TAG_LOOKUP}{exif})))
2766             {
2767 36         141 $self->FoundTag('EXIF', $$self{EXIF_DATA});
2768             }
2769 513 100       1443 unless ($reEntry) {
2770 511         1518 $$self{PATH} = [ ]; # reset PATH
2771             # calculate Composite tags
2772 511 100       2981 $self->BuildCompositeTags() if $$options{Composite};
2773             # do our HTML dump if requested
2774 511 50       1886 if ($$self{HTML_DUMP}) {
2775 0         0 $raf->Seek(0, 2); # seek to end of file
2776 0         0 $$self{HTML_DUMP}->FinishTiffDump($self, $raf->Tell());
2777 0         0 my $pos = $$options{HtmlDumpBase};
2778 0 0 0     0 $pos = ($$self{FIRST_EXIF_POS} || 0) unless defined $pos;
2779 0 0       0 my $dataPt = defined $$self{EXIF_DATA} ? \$$self{EXIF_DATA} : undef;
2780 0 0 0     0 undef $dataPt if defined $$self{EXIF_POS} and $pos != $$self{EXIF_POS};
2781 0 0       0 undef $dataPt if $$self{ExtendedEXIF}; # can't use EXIF block if not contiguous
2782             my $success = $$self{HTML_DUMP}->Print($raf, $dataPt, $pos,
2783             $$options{TextOut}, $$options{HtmlDump},
2784 0 0       0 $$self{FILENAME} ? "HTML Dump ($$self{FILENAME})" : 'HTML Dump');
2785 0 0       0 $self->Warn("Error reading $$self{HTML_DUMP}{ERROR}") if $success < 0;
2786             }
2787             }
2788 513 100       1673 if ($filename) {
2789 471         2762 $raf->Close(); # close the file if we opened it
2790             # process the resource fork as an embedded file on Mac filesystems
2791 471 0 33     1603 if ($rsize and $$options{ExtractEmbedded}) {
2792 0         0 local *RESOURCE_FILE;
2793 0 0       0 if ($self->Open(\*RESOURCE_FILE, "$filename/..namedfork/rsrc")) {
2794 0         0 $$self{DOC_NUM} = $$self{DOC_COUNT} + 1;
2795 0         0 $$self{IN_RESOURCE} = 1;
2796 0         0 $self->ExtractInfo(\*RESOURCE_FILE, { ReEntry => 1 });
2797 0         0 close RESOURCE_FILE;
2798 0         0 delete $$self{IN_RESOURCE};
2799             } else {
2800 0         0 $self->Warn('Error opening resource fork');
2801             }
2802             }
2803             }
2804 513         7490 last; # (loop was a cheap "goto")
2805             }
2806              
2807             # generate Validate tag if requested
2808 513 100 66     2021 if ($$options{Validate} and not $reEntry) {
2809 1         9 Image::ExifTool::Validate::FinishValidate($self, $$req{validate});
2810             }
2811              
2812 513 100       1877 @startTime and $self->FoundTag('ProcessingTime', Time::HiRes::tv_interval(\@startTime));
2813              
2814             # add user-defined parameters that ended with '!'
2815 513 50       935 if (%{$$options{UserParam}}) {
  513         1936  
2816 0         0 my $doMsg = $$options{Verbose};
2817 0         0 my $table = GetTagTable('Image::ExifTool::UserParam');
2818 0         0 foreach (sort keys %{$$options{UserParam}}) {
  0         0  
2819 0 0       0 next unless /#$/;
2820 0 0       0 if ($doMsg) {
2821 0         0 $self->VPrint(0, "UserParam tags:\n");
2822 0         0 undef $doMsg;
2823             }
2824 0         0 $self->HandleTag($table, $_, $$options{UserParam}{$_});
2825             }
2826             }
2827              
2828             # restore original options
2829 513 100       1405 %saveOptions and $$self{OPTIONS} = \%saveOptions;
2830              
2831 513 100       1339 if ($reEntry) {
2832             # restore necessary members when exiting re-entrant code
2833 2         17 $$self{$_} = $$reEntry{$_} foreach keys %$reEntry;
2834 2         15 SetByteOrder($saveOrder);
2835             }
2836              
2837             # ($type may be undef without an Error when processing sub-documents)
2838 513 50 33     3286 return 0 if not defined $type or exists $$self{VALUE}{Error};
2839 513         2404 return 1;
2840             }
2841              
2842             #------------------------------------------------------------------------------
2843             # Get hash of extracted meta information
2844             # Inputs: 0) ExifTool object reference
2845             # 1-N) options hash reference, tag list reference or tag names
2846             # Returns: Reference to information hash
2847             # Notes: - pass an undefined value to avoid parsing arguments
2848             # - If groups are specified, first groups take precedence if duplicate
2849             # tags found but Duplicates option not set.
2850             # - tag names may end in '#' to extract ValueConv value
2851             sub GetInfo($;@)
2852             {
2853 683     683 1 2748 local $_;
2854 683         1198 my $self = shift;
2855 683         1112 my %saveOptions;
2856              
2857 683 100 66     3357 unless (@_ and not defined $_[0]) {
2858 177         370 %saveOptions = %{$$self{OPTIONS}}; # save original options
  177         8451  
2859             # must set FILENAME so it isn't parsed from the arguments
2860 177 100       1250 $$self{FILENAME} = '' unless defined $$self{FILENAME};
2861 177         777 $self->ParseArguments(@_);
2862             }
2863              
2864             # get reference to list of tags for which we will return info
2865 683         3134 my ($rtnTags, $byValue, $wildTags) = $self->SetFoundTags();
2866              
2867             # build hash of tag information
2868 683         1257 my (%info, %ignored);
2869 683 100       2353 my $conv = $$self{OPTIONS}{PrintConv} ? 'PrintConv' : 'ValueConv';
2870 683         1661 foreach (@$rtnTags) {
2871 35002         55659 my $val = $self->GetValue($_, $conv);
2872 35002 100       55874 defined $val or $ignored{$_} = 1, next;
2873 34057         65074 $info{$_} = $val;
2874             }
2875              
2876             # override specified tags with ValueConv value if necessary
2877 683 100       2415 if (@$byValue) {
2878             # first determine the number of times each non-ValueConv value is used
2879 4         7 my %nonVal;
2880 4   100     63 $nonVal{$_} = ($nonVal{$_} || 0) + 1 foreach @$rtnTags;
2881 4         22 --$nonVal{$$rtnTags[$_]} foreach @$byValue;
2882             # loop through ValueConv tags, updating tag keys and returned values
2883 4         9 foreach (@$byValue) {
2884 25         30 my $tag = $$rtnTags[$_];
2885 25         42 my $val = $self->GetValue($tag, 'ValueConv');
2886 25 100       44 next unless defined $val;
2887 16         22 my $vtag = $tag;
2888             # generate a new tag key like "Tag #" or "Tag #(1)"
2889 16         75 $vtag =~ s/( |$)/ #/;
2890 16 50       42 unless (defined $$self{VALUE}{$vtag}) {
2891 16         31 $$self{VALUE}{$vtag} = $$self{VALUE}{$tag};
2892 16         35 $$self{TAG_INFO}{$vtag} = $$self{TAG_INFO}{$tag};
2893 16         35 $$self{TAG_EXTRA}{$vtag} = $$self{TAG_EXTRA}{$tag};
2894 16         28 $$self{FILE_ORDER}{$vtag} = $$self{FILE_ORDER}{$tag};
2895             # remove existing PrintConv entry unless we are using it too
2896 16 100       38 delete $info{$tag} unless $nonVal{$tag};
2897             }
2898 16         23 $$rtnTags[$_] = $vtag; # store ValueConv value with new tag key
2899 16         40 $info{$vtag} = $val; # return ValueConv value
2900             }
2901             }
2902              
2903             # remove ignored tags from the list
2904 683   50     2284 my $reqTags = $$self{REQUESTED_TAGS} || [ ];
2905 683 100       1810 if (%ignored) {
2906 401 100       1407 if (not @$reqTags) {
    100          
2907 188         341 my @goodTags;
2908 188         509 foreach (@$rtnTags) {
2909 22434 100       36419 push @goodTags, $_ unless $ignored{$_};
2910             }
2911 188         1345 $rtnTags = $$self{FOUND_TAGS} = \@goodTags;
2912             } elsif (@$wildTags) {
2913             # only remove tags specified by wildcard
2914 41         59 my @goodTags;
2915 41         59 my $i = 0;
2916 41         72 foreach (@$rtnTags) {
2917 356 100 100     698 if (@$wildTags and $i == $$wildTags[0]) {
2918 197         217 shift @$wildTags;
2919 197 50       355 push @goodTags, $_ unless $ignored{$_};
2920             } else {
2921 159         216 push @goodTags, $_;
2922             }
2923 356         392 ++$i;
2924             }
2925 41         139 $rtnTags = $$self{FOUND_TAGS} = \@goodTags;
2926             }
2927             }
2928              
2929             # return sorted tag list if provided with a list reference
2930 683 100       2251 if ($$self{IO_TAG_LIST}) {
2931             # use file order by default if no tags specified
2932             # (no such thing as 'Input' order in this case)
2933 4         8 my $sort = $$self{OPTIONS}{Sort};
2934 4 50 33     22 $sort = 'File' unless @$reqTags or ($sort and $sort ne 'Input');
      66        
2935             # return tags in specified sort order
2936 4         18 @{$$self{IO_TAG_LIST}} = $self->GetTagList($rtnTags, $sort, $$self{OPTIONS}{Sort2});
  4         22  
2937             }
2938              
2939             # restore original options
2940 683 100       2923 %saveOptions and $$self{OPTIONS} = \%saveOptions;
2941              
2942 683         2873 return \%info;
2943             }
2944              
2945             #------------------------------------------------------------------------------
2946             # Inputs: 0) ExifTool object reference
2947             # 1) [optional] reference to info hash or tag list ref (default is found tags)
2948             # 2) [optional] sort order ('File', 'Input', ...)
2949             # 3) [optional] secondary sort order
2950             # Returns: List of tags in specified order
2951             sub GetTagList($;$$$)
2952             {
2953 425     425 1 65912 local $_;
2954 425         1432 my ($self, $info, $sort, $sort2) = @_;
2955              
2956 425         744 my $foundTags;
2957 425 100       1806 if (ref $info eq 'HASH') {
    50          
2958 420         5140 my @tags = keys %$info;
2959 420         1274 $foundTags = \@tags;
2960             } elsif (ref $info eq 'ARRAY') {
2961 5         8 $foundTags = $info;
2962             }
2963 425         1276 my $fileOrder = $$self{FILE_ORDER};
2964              
2965 425 50       1134 if ($foundTags) {
2966             # make sure a FILE_ORDER entry exists for all tags
2967             # (note: already generated bogus entries for FOUND_TAGS case below)
2968 425         1196 foreach (@$foundTags) {
2969 23843 50       37427 next if defined $$fileOrder{$_};
2970 0         0 $$fileOrder{$_} = 999;
2971             }
2972             } else {
2973 0 0 0     0 $sort = $info if $info and not $sort;
2974 0 0 0     0 $foundTags = $$self{FOUND_TAGS} || $self->SetFoundTags() or return undef;
2975             }
2976 425 100       1431 $sort or $sort = $$self{OPTIONS}{Sort};
2977              
2978             # return original list if no sort order specified
2979 425 100 66     2616 return @$foundTags unless $sort and $sort ne 'Input';
2980              
2981 407 50 33     4788 if ($sort eq 'Tag' or $sort eq 'Alpha') {
    100          
    50          
2982 0         0 return sort @$foundTags;
2983             } elsif ($sort =~ /^Group(\d*(:\d+)*)/) {
2984 405   50     2140 my $family = $1 || 0;
2985             # want to maintain a basic file order with the groups
2986             # ordered in the way they appear in the file
2987 405         844 my (%groupCount, %groupOrder);
2988 405         733 my $numGroups = 0;
2989 405         697 my $tag;
2990 405         2213 foreach $tag (sort { $$fileOrder{$a} <=> $$fileOrder{$b} } @$foundTags) {
  129571         143319  
2991 23134         32860 my $group = $self->GetGroup($tag, $family);
2992 23134         31186 my $num = $groupCount{$group};
2993 23134 100       32921 $num or $num = $groupCount{$group} = ++$numGroups;
2994 23134         37265 $groupOrder{$tag} = $num;
2995             }
2996 405 50       1963 $sort2 or $sort2 = $$self{OPTIONS}{Sort2};
2997 405 50       1386 if ($sort2) {
2998 405 50 33     2587 if ($sort2 eq 'Tag' or $sort2 eq 'Alpha') {
    50          
2999 0 0       0 return sort { $groupOrder{$a} <=> $groupOrder{$b} or $a cmp $b } @$foundTags;
  0         0  
3000             } elsif ($sort2 eq 'Descr') {
3001 0         0 my $desc = $self->GetDescriptions($foundTags);
3002 0         0 return sort { $groupOrder{$a} <=> $groupOrder{$b} or
3003 0 0       0 $$desc{$a} cmp $$desc{$b} } @$foundTags;
3004             }
3005             }
3006 405         1982 return sort { $groupOrder{$a} <=> $groupOrder{$b} or
3007 129472 50       192817 $$fileOrder{$a} <=> $$fileOrder{$b} } @$foundTags;
3008             } elsif ($sort eq 'Descr') {
3009 0         0 my $desc = $self->GetDescriptions($foundTags);
3010 0         0 return sort { $$desc{$a} cmp $$desc{$b} } @$foundTags;
  0         0  
3011             } else {
3012 2         14 return sort { $$fileOrder{$a} <=> $$fileOrder{$b} } @$foundTags;
  3718         4217  
3013             }
3014             }
3015              
3016             #------------------------------------------------------------------------------
3017             # Get list of found tags in specified sort order
3018             # Inputs: 0) ExifTool object reference, 1) sort order ('File', 'Input', ...)
3019             # 2) secondary sort order
3020             # Returns: List of tag keys in specified order
3021             # Notes: If not specified, sort order is taken from OPTIONS
3022             sub GetFoundTags($;$$)
3023             {
3024 1     1 1 175 local $_;
3025 1         4 my ($self, $sort, $sort2) = @_;
3026 1 50 33     5 my $foundTags = $$self{FOUND_TAGS} || $self->SetFoundTags() or return undef;
3027 1         6 return $self->GetTagList($foundTags, $sort, $sort2);
3028             }
3029              
3030             #------------------------------------------------------------------------------
3031             # Get list of requested tags
3032             # Inputs: 0) ExifTool object reference
3033             # Returns: List of requested tag keys
3034             sub GetRequestedTags($)
3035             {
3036 2     2 1 4 local $_;
3037 2         4 return @{$_[0]{REQUESTED_TAGS}};
  2         9  
3038             }
3039              
3040             #------------------------------------------------------------------------------
3041             # Get tag value
3042             # Inputs: 0) ExifTool object reference
3043             # 1) tag key or tag name with optional group names (case sensitive)
3044             # (or flattened tagInfo for getting field values, not part of public API)
3045             # 2) [optional] Value type: PrintConv, ValueConv, Both, Raw or Rational, the default
3046             # is PrintConv or ValueConv, depending on the PrintConv option setting
3047             # 3) raw field value (not part of public API)
3048             # Returns: Scalar context: tag value or undefined
3049             # List context: list of values or empty list
3050             sub GetValue($$;$)
3051             {
3052 52529     52529 1 57634 local $_;
3053 52529         76370 my ($self, $tag, $type) = @_; # plus: ($fieldValue)
3054 52529         59294 my (@convTypes, $tagInfo, $valueConv, $both);
3055 52529         62707 my $rawValue = $$self{VALUE};
3056              
3057             # get specific tag key if tag has a group name
3058 52529 50       91872 if ($tag =~ /^(.*):(.+)/) {
3059 0         0 my ($gp, $tg) = ($1, $2);
3060 0         0 my ($i, $key, @keys);
3061             # build list of tag keys in the order of priority (no index
3062             # is top priority, otherwise higher index is higher priority)
3063 0   0     0 for ($key=$tg, $i=$$self{DUPL_TAG}{$tg} || 0; ; --$i) {
3064 0 0       0 push @keys, $key if defined $$rawValue{$key};
3065 0 0       0 last if $i <= 0;
3066 0         0 $key = "$tg ($i)";
3067             }
3068 0 0       0 if (@keys) {
3069 0         0 $key = $self->GroupMatches($gp, \@keys);
3070 0 0       0 $tag = $key if $key;
3071             }
3072             }
3073             # figure out what conversions to do
3074 52529 100       69515 if ($type) {
3075 52514 50       74969 return $$self{RATIONAL}{$tag} if $type eq 'Rational';
3076             } else {
3077 15 50       101 $type = $$self{OPTIONS}{PrintConv} ? 'PrintConv' : 'ValueConv';
3078             }
3079              
3080             # start with the raw value
3081 52529         77938 my $value = $$rawValue{$tag};
3082 52529 100       71359 if (not defined $value) {
3083 9972 100       22903 return () unless ref $tag;
3084             # get the value of a structure field
3085 194         257 $tagInfo = $tag;
3086 194         286 $tag = $$tagInfo{Name};
3087 194         256 $value = $_[3];
3088             # (note: type "Both" is not allowed for structure fields)
3089 194 50       326 if ($type ne 'Raw') {
3090 194         266 push @convTypes, 'ValueConv';
3091 194 100       373 push @convTypes, 'PrintConv' unless $type eq 'ValueConv';
3092             }
3093             } else {
3094 42557         63321 $tagInfo = $$self{TAG_INFO}{$tag};
3095 42557 100 66     78453 if ($$tagInfo{Struct} and ref $value) {
3096             # must load XMPStruct.pl just in case (should already be loaded if
3097             # a structure was extracted, but we could also arrive here if a simple
3098             # list of values was stored incorrectly in a Struct tag)
3099 53         1090 require 'Image/ExifTool/XMPStruct.pl';
3100             # convert strucure field values
3101 53 100       135 unless ($type eq 'Both') {
3102             # (note: ConvertStruct handles the filtering and escaping too if necessary)
3103 48         188 return Image::ExifTool::XMP::ConvertStruct($self,$tagInfo,$value,$type);
3104             }
3105 5         18 $valueConv = Image::ExifTool::XMP::ConvertStruct($self,$tagInfo,$value,'ValueConv');
3106 5         17 $value = Image::ExifTool::XMP::ConvertStruct($self,$tagInfo,$value,'PrintConv');
3107             # (must not save these in $$self{BOTH} because the values may have been escaped)
3108 5         23 return ($valueConv, $value);
3109             }
3110 42504 50       62681 if ($type ne 'Raw') {
3111             # use values we calculated already if we stored them
3112 42504         54531 $both = $$self{BOTH}{$tag};
3113 42504 100       54654 if ($both) {
3114 6331 100       10939 if ($type eq 'PrintConv') {
    100          
3115 2136         3854 $value = $$both[1];
3116             } elsif ($type eq 'ValueConv') {
3117 94         154 $value = $$both[0];
3118 94 100       186 $value = $$both[1] unless defined $value;
3119             } else {
3120 4101         6729 ($valueConv, $value) = @$both;
3121             }
3122             } else {
3123 36173         47217 push @convTypes, 'ValueConv';
3124 36173 100       60579 push @convTypes, 'PrintConv' unless $type eq 'ValueConv';
3125             }
3126             }
3127             }
3128              
3129             # do the conversions
3130 42698         50062 my (@val, @prt, @raw, $convType);
3131 42698         53923 foreach $convType (@convTypes) {
3132             # don't convert a scalar reference or structure
3133 69978 100 66     112071 last if ref $value eq 'SCALAR' and not $$tagInfo{ConvertBinary};
3134 69332         100514 my $conv = $$tagInfo{$convType};
3135 69332 100       98493 unless (defined $conv) {
3136 45369 100       59464 if ($convType eq 'ValueConv') {
3137 28823 100       52528 next unless $$tagInfo{Binary};
3138 400         801 $conv = '\$val'; # return scalar reference for binary values
3139             } else {
3140             # use PRINT_CONV from tag table if PrintConv doesn't exist
3141 16546 100       38727 next unless defined($conv = $$tagInfo{Table}{PRINT_CONV});
3142 201 100       472 next if exists $$tagInfo{$convType};
3143             }
3144             }
3145             # save old ValueConv value if we want Both
3146 24515 100 100     45101 $valueConv = $value if $type eq 'Both' and $convType eq 'PrintConv';
3147 24515         29869 my ($i, $val, $vals, @values, $convList);
3148             # split into list if conversion is an array
3149 24515 100       38360 if (ref $conv eq 'ARRAY') {
3150 124         300 $convList = $conv;
3151 124         299 $conv = $$convList[0];
3152 124 50       579 my @valList = (ref $value eq 'ARRAY') ? @$value : split ' ', $value;
3153             # reorganize list if specified (Note: The writer currently doesn't
3154             # relist values, so they may be grouped but the order must not change)
3155 124         246 my $relist = $$tagInfo{Relist};
3156 124 100       284 if ($relist) {
3157 7         19 my (@newList, $oldIndex);
3158 7         35 foreach $oldIndex (@$relist) {
3159 14         23 my ($newVal, @join);
3160 14 100       32 if (ref $oldIndex) {
3161 7         21 foreach (@$oldIndex) {
3162 16 50       49 push @join, $valList[$_] if defined $valList[$_];
3163             }
3164 7 50       34 $newVal = join(' ', @join) if @join;
3165             } else {
3166 7         15 $newVal = $valList[$oldIndex];
3167             }
3168 14 100       44 push @newList, $newVal if defined $newVal;
3169             }
3170 7         18 $value = \@newList;
3171             } else {
3172 117         253 $value = \@valList;
3173             }
3174 124 50       381 return () unless @$value;
3175             }
3176             # initialize array so we can iterate over values in list
3177 24515 100       34680 if (ref $value eq 'ARRAY') {
3178 155 100       408 if (defined $$tagInfo{RawJoin}) {
3179 7         30 $val = join ' ', @$value;
3180             } else {
3181 148         248 $i = 0;
3182 148         227 $vals = $value;
3183 148         270 $val = $$vals[0];
3184             }
3185             } else {
3186 24360         29509 $val = $value;
3187             }
3188             # loop through all values in list
3189 24515         26717 for (;;) {
3190 24728 100       32802 if (defined $conv) {
3191             # get values of required tags if this is a Composite tag
3192 24709 100 66     46175 if (ref $val eq 'HASH' and not @val) {
3193             # disable escape of source values so we don't double escape them
3194 2861         4107 my $oldEscape = $$self{ESCAPE_PROC};
3195 2861         3903 delete $$self{ESCAPE_PROC};
3196             # temporarily delete filter so it isn't applied to the Require'd values
3197 2861         3832 my $oldFilter = $$self{OPTIONS}{Filter};
3198 2861         3857 delete $$self{OPTIONS}{Filter};
3199 2861         9022 foreach (keys %$val) {
3200 16778 50       27303 next unless defined $$val{$_};
3201 16778         33114 $raw[$_] = $$rawValue{$$val{$_}};
3202 16778         28139 ($val[$_], $prt[$_]) = $self->GetValue($$val{$_}, 'Both');
3203 16778 100 100     42995 next if defined $val[$_] or not $$tagInfo{Require}{$_};
3204 378 50       886 $$self{OPTIONS}{Filter} = $oldFilter if defined $oldFilter;
3205 378         601 $$self{ESCAPE_PROC} = $oldEscape;
3206 378         1302 return ();
3207             }
3208 2483 100       5521 $$self{OPTIONS}{Filter} = $oldFilter if defined $oldFilter;
3209 2483         4150 $$self{ESCAPE_PROC} = $oldEscape;
3210             # set $val to $val[0], or \@val for a CODE ref conversion
3211 2483 50       5495 $val = ref $conv eq 'CODE' ? \@val : $val[0];
3212             }
3213 24331 100       34474 if (ref $conv eq 'HASH') {
3214             # look up converted value in hash
3215 7542 100       23475 if (not defined($value = $$conv{$val})) {
3216 435 100       1233 if ($$conv{BITMASK}) {
3217 121         578 $value = DecodeBits($val, $$conv{BITMASK}, $$tagInfo{BitsPerWord});
3218             } else {
3219             # use alternate conversion routine if available
3220 314 100       921 if ($$conv{OTHER}) {
3221 243         1016 local $SIG{'__WARN__'} = \&SetWarning;
3222 243         501 undef $evalWarning;
3223 243         458 $value = &{$$conv{OTHER}}($val, undef, $conv);
  243         975  
3224 243 50       858 $self->Warn("$convType $tag: " . CleanWarning()) if $evalWarning;
3225             }
3226 314 100       842 if (not defined $value) {
3227 71 50 66     295 if ($$tagInfo{PrintHex} and $val and IsInt($val) and
      66        
      33        
3228             $convType eq 'PrintConv')
3229             {
3230 0         0 $value = sprintf('Unknown (0x%x)',$val);
3231             } else {
3232 71         204 $value = "Unknown ($val)";
3233             }
3234             }
3235             }
3236             }
3237             # override with our localized language PrintConv if available
3238 7542         8646 my $tmp;
3239 7542 100 66     16362 if ($$self{CUR_LANG} and $convType eq 'PrintConv' and
      100        
      66        
3240             # (no need to check for lang-alt tag names -- they won't have a PrintConv)
3241             ref($tmp = $$self{CUR_LANG}{$$tagInfo{Name}}) eq 'HASH' and
3242             ($tmp = $$tmp{PrintConv}))
3243             {
3244 244 50 33     1056 if ($$conv{BITMASK} and not defined $$conv{$val}) {
    100          
3245 0         0 my @vals = split ', ', $value;
3246 0         0 foreach (@vals) {
3247 0 0       0 $_ = $$tmp{$_} if defined $$tmp{$_};
3248             }
3249 0         0 $value = join ', ', @vals;
3250             } elsif (defined($tmp = $$tmp{$value})) {
3251 200         511 $value = $self->Decode($tmp, 'UTF8');
3252             }
3253             }
3254             } else {
3255             # call subroutine or do eval to convert value
3256 16789         53616 local $SIG{'__WARN__'} = \&SetWarning;
3257 16789         24850 undef $evalWarning;
3258 16789 100       24397 if (ref $conv eq 'CODE') {
3259 829         2900 $value = &$conv($val, $self);
3260             } else {
3261             #### eval ValueConv/PrintConv ($val, $self, @val, @prt, @raw)
3262 15960         833270 $value = eval $conv;
3263 15960 50       52282 $@ and $evalWarning = $@;
3264             }
3265 16789 50       46258 $self->Warn("$convType $tag: " . CleanWarning()) if $evalWarning;
3266             }
3267             } else {
3268 19         32 $value = $val;
3269             }
3270 24350 100       41247 last unless $vals;
3271             # must store a separate copy of each binary data value in the list
3272 361 100       824 if (ref $value eq 'SCALAR') {
3273 3         4 my $tval = $$value;
3274 3         5 $value = \$tval;
3275             }
3276             # save this converted value and step to next value in list
3277 361 50       768 push @values, $value if defined $value;
3278 361 100       792 if (++$i >= scalar(@$vals)) {
3279 148 50       443 $value = \@values if @values;
3280 148         243 last;
3281             }
3282 213         349 $val = $$vals[$i];
3283 213 100       447 if ($convList) {
3284 132         236 my $nextConv = $$convList[$i];
3285 132 50 66     581 if ($nextConv and $nextConv eq 'REPEAT') {
3286 0         0 undef $convList;
3287             } else {
3288 132         232 $conv = $nextConv;
3289             }
3290             }
3291             }
3292             # return undefined now if no value
3293 24137 100       39270 return () unless defined $value;
3294             # join back into single value if split for conversion list
3295 23579 100 66     50222 if ($convList and ref $value eq 'ARRAY') {
3296 124 100       685 $value = join($convType eq 'PrintConv' ? '; ' : ' ', @$value);
3297             }
3298             }
3299 41762 100       63733 if ($type eq 'Both') {
3300             # save both (unescaped) values because we often need them again
3301             # (Composite tags need "Both" and often Require one tag for various Composite tags)
3302 7364 100       17337 $$self{BOTH}{$tag} = [ $valueConv, $value ] unless $both;
3303             # escape values if necessary
3304 7364 50       15952 if ($$self{ESCAPE_PROC}) {
    100          
3305 0         0 DoEscape($value, $$self{ESCAPE_PROC});
3306 0 0       0 if (defined $valueConv) {
3307 0         0 DoEscape($valueConv, $$self{ESCAPE_PROC});
3308             } else {
3309 0         0 $valueConv = $value;
3310             }
3311             } elsif (not defined $valueConv) {
3312             # $valueConv is undefined if there was no print conversion done
3313 3718         4543 $valueConv = $value;
3314             }
3315 7364         22327 $self->Filter($$self{OPTIONS}{Filter}, \$value);
3316             # return Both values as a list (ValueConv, PrintConv)
3317 7364         24447 return ($valueConv, $value);
3318             }
3319             # escape value if necessary
3320 34398 100       53591 DoEscape($value, $$self{ESCAPE_PROC}) if $$self{ESCAPE_PROC};
3321              
3322             # filter if necessary
3323 34398 100 100     60276 $self->Filter($$self{OPTIONS}{Filter}, \$value) if $$self{OPTIONS}{Filter} and $type eq 'PrintConv';
3324              
3325 34398 100       49525 if (ref $value eq 'ARRAY') {
3326 289 100 100     2417 if (defined $$self{OPTIONS}{ListItem}) {
    100 100        
    100          
3327 3         8 $value = $$value[$$self{OPTIONS}{ListItem}];
3328             } elsif (wantarray) {
3329             # return array if requested
3330 1         6 return @$value;
3331             } elsif ($type eq 'PrintConv' and not $$self{OPTIONS}{List} and not ref $$value[0]) {
3332             # join PrintConv values in comma-separated string if List option not used
3333             # and list contains simple scalars (otherwise return ARRAY ref)
3334 162         648 $value = join $$self{OPTIONS}{ListSep}, @$value;
3335             }
3336             }
3337 34397         70020 return $value;
3338             }
3339              
3340             #------------------------------------------------------------------------------
3341             # Get tag identification number
3342             # Inputs: 0) ExifTool object reference, 1) tag key
3343             # Returns: Scalar context: tag ID if available, otherwise ''
3344             # List context: 0) tag ID (or ''), 1) language code (or undef)
3345             sub GetTagID($$)
3346             {
3347 23147     23147 1 110677 my ($self, $tag) = @_;
3348 23147         32203 my $tagInfo = $$self{TAG_INFO}{$tag};
3349 23147 100 66     61239 return '' unless $tagInfo and defined $$tagInfo{TagID};
3350 23145   100     50015 my $id = $$tagInfo{KeysID} || $$tagInfo{TagID};
3351 23145 50       34822 return ($id, $$tagInfo{LangCode}) if wantarray;
3352 23145         39170 return $id;
3353             }
3354              
3355             #------------------------------------------------------------------------------
3356             # Get description for specified tag
3357             # Inputs: 0) ExifTool object reference, 1) tag key
3358             # Returns: Tag description
3359             # Notes: Will always return a defined value, even if description isn't available
3360             sub GetDescription($$)
3361             {
3362 23147     23147 1 54309 local $_;
3363 23147         30665 my ($self, $tag) = @_;
3364 23147         26847 my ($desc, $name);
3365 23147         29627 my $tagInfo = $$self{TAG_INFO}{$tag};
3366             # ($tagInfo won't be defined for missing tags extracted with -f)
3367 23147 50       35701 if ($tagInfo) {
3368             # use alternate language description if available
3369 23147         37119 while ($$self{CUR_LANG}) {
3370 800         2316 $desc = $$self{CUR_LANG}{$$tagInfo{Name}};
3371 800 100       1284 if ($desc) {
3372             # must look up Description if this tag also has a PrintConv
3373 671 100 100     1737 $desc = $$desc{Description} or last if ref $desc;
3374             } else {
3375             # look up default language of lang-alt tag
3376             last unless $$tagInfo{LangCode} and
3377             ($name = $$tagInfo{Name}) =~ s/-$$tagInfo{LangCode}$// and
3378 129 50 66     388 $desc = $$self{CUR_LANG}{$name};
      66        
3379 1 50 0     4 $desc = $$desc{Description} or last if ref $desc;
3380 1         14 $desc .= " ($$tagInfo{LangCode})";
3381             }
3382             # escape description if necessary
3383 663 50       1160 DoEscape($desc, $$self{ESCAPE_PROC}) if $$self{ESCAPE_PROC};
3384             # return description in proper Charset
3385 663         1238 return $self->Decode($desc, 'UTF8');
3386             }
3387 22484         33230 $desc = $$tagInfo{Description};
3388             }
3389             # just make the tag more readable if description doesn't exist
3390 22484 100       34027 unless ($desc) {
3391 9371         14038 $desc = MakeDescription(GetTagName($tag));
3392             # save description in tag information
3393 9371 50       22626 $$tagInfo{Description} = $desc if $tagInfo;
3394             }
3395 22484         39194 return $desc;
3396             }
3397              
3398             #------------------------------------------------------------------------------
3399             # Get group name for specified tag
3400             # Inputs: 0) ExifTool object reference
3401             # 1) tag key (or reference to tagInfo hash, not part of the public API)
3402             # 2) [optional] group family (-1 to get extended group list, or multiple
3403             # families separated by colons to return multiple groups as a string)
3404             # Returns: Scalar context: group name (for family 0 if not otherwise specified)
3405             # List context: group name if family specified, otherwise list of
3406             # group names for each family. Returns '' for undefined tag.
3407             # Notes: Multiple families may be specified with ':' in family argument (eg. '1:2')
3408             sub GetGroup($$;$)
3409             {
3410 189505     189505 1 549242 local $_;
3411 189505         266087 my ($self, $tag, $family) = @_;
3412 189505         220354 my ($tagInfo, @groups, @families, $simplify, $byTagInfo, $ex, $noID);
3413 189505 100       283709 if (ref $tag eq 'HASH') {
3414 119867         137659 $tagInfo = $tag;
3415 119867         173608 $tag = $$tagInfo{Name};
3416             # set flag so we don't get extra information for an extracted tag
3417 119867         133369 $byTagInfo = 1;
3418             } else {
3419 69638   50     137942 $tagInfo = $$self{TAG_INFO}{$tag} || { };
3420 69638         93079 $ex = $$self{TAG_EXTRA}{$tag};
3421             }
3422 189505         275943 my $groups = $$tagInfo{Groups};
3423             # fill in default groups unless already done
3424             # (after this, Groups 0-2 in tagInfo are guaranteed to be defined)
3425 189505 100       315810 unless ($$tagInfo{GotGroups}) {
3426 35451   50     56799 my $tagTablePtr = $$tagInfo{Table} || { GROUPS => { } };
3427             # construct our group list
3428 35451 100       70507 $groups or $groups = $$tagInfo{Groups} = { };
3429             # fill in default groups
3430 35451         54210 foreach (0..2) {
3431 106353 100 50     302458 $$groups{$_} = $$tagTablePtr{GROUPS}{$_} || '' unless $$groups{$_};
3432             }
3433             # set flag indicating group list was built
3434 35451         57187 $$tagInfo{GotGroups} = 1;
3435             }
3436 189505 100 100     415998 if (defined $family and $family ne '-1') {
3437 98337 100       178703 if ($family =~ /[^\d]/) {
3438 2736         7314 @families = ($family =~ /\d+/g);
3439 2736 50 0     4638 return(($ex && $$ex{G0}) || $$groups{0}) unless @families;
3440 2736 50       4966 $simplify = 1 unless $family =~ /^:/;
3441 2736         3095 undef $family;
3442 2736         4016 foreach (0..2) { $groups[$_] = $$groups{$_}; }
  8208         12868  
3443 2736 50 33     4573 $noID = 1 if @families == 1 and $families[0] != 7;
3444             } else {
3445 95601 100 66     391728 return(($ex && $$ex{"G$family"}) || $$groups{$family}) if $family == 0 or $family == 2;
      100        
3446 28377         63988 $groups[1] = $$groups{1};
3447             }
3448             } else {
3449 91168 100 33     137954 return(($ex && $$ex{G0}) || $$groups{0}) unless wantarray;
3450 90787         128215 foreach (0..2) { $groups[$_] = $$groups{$_}; }
  272361         474433  
3451             }
3452 121900         159125 $groups[3] = 'Main';
3453 121900 100       235390 $groups[4] = ($tag =~ /\((\d+)\)$/) ? "Copy$1" : '';
3454             # handle dynamic group names if necessary
3455 121900 100       188011 unless ($byTagInfo) {
3456 44208 100       62585 if ($ex) {
3457 17218 100       30112 $groups[0] = $$ex{G0} if $$ex{G0};
3458 17218 100       41302 $groups[1] = $$ex{G1} =~ /^\+(.*)/ ? "$groups[1]$1" : $$ex{G1} if $$ex{G1};
    100          
3459 17218 100       27216 $groups[3] = 'Doc' . $$ex{G3} if $$ex{G3};
3460 17218 100 66     26616 $groups[5] = $$ex{G5} || $groups[1] if defined $$ex{G5};
3461 17218 50       26089 if (defined $$ex{G6}) {
3462 0 0       0 $groups[5] = '' unless defined $groups[5]; # (can't leave a hole in the array)
3463 0         0 $groups[6] = $$ex{G6};
3464             }
3465             }
3466             # generate tag ID group names unless obviously not needed
3467 44208 50       61468 unless ($noID) {
3468 44208   100     117624 my $id = $$tagInfo{KeysID} || $$tagInfo{TagID};
3469 44208 100       113577 if (not defined $id) {
    100          
3470 2         3 $id = ''; # (just to be safe)
3471             } elsif ($id =~ /^\d+$/) {
3472 27872 50       51729 $id = sprintf('0x%x', $id) if $$self{OPTIONS}{HexTagIDs};
3473             } else {
3474 16334         29492 $id =~ s/([^-_A-Za-z0-9])/sprintf('%.2x',ord $1)/ge;
  1268         4970  
3475             }
3476 44208         73185 $groups[7] = 'ID-' . $id;
3477 44208   100     126881 defined $groups[$_] or $groups[$_] = '' foreach (5,6);
3478             }
3479             }
3480 121900 100       186867 if ($family) {
3481 43522 100 50     139752 return $groups[$family] || '' if $family > 0;
3482             # add additional matching group names to list
3483             # eg) for MIE-Doc, also add MIE1, MIE1-Doc, MIE-Doc1 and MIE1-Doc1
3484             # and for MIE2-Doc3, also add MIE2, MIE-Doc3, MIE2-Doc and MIE-Doc
3485 15145 100       24736 if ($groups[1] =~ /^MIE(\d*)-(.+?)(\d*)$/) {
3486 31   50     196 push @groups, 'MIE' . ($1 || '1');
3487 31 50       152 push @groups, 'MIE' . ($1 ? '' : '1') . "-$2$3";
3488 31 50       132 push @groups, "MIE$1-$2" . ($3 ? '' : '1');
3489 31 50       153 push @groups, 'MIE' . ($1 ? '' : '1') . "-$2" . ($3 ? '' : '1');
    50          
3490             }
3491             }
3492 93523 100       146139 if (@families) {
3493 2736         2894 my @grps;
3494             # create list of group names (without identical adjacent groups if simplifying)
3495 2736         3488 foreach (@families) {
3496 5472         7658 my $grp = $groups[$_];
3497 5472 50       7364 unless ($grp) {
3498 0 0       0 next if $simplify;
3499 0         0 $grp = '';
3500             }
3501 5472 100 66     18388 push @grps, $grp unless $simplify and @grps and $grp eq $grps[-1];
      100        
3502             }
3503             # remove leading "Main:" if simplifying
3504 2736 50 66     8955 shift @grps if $simplify and @grps > 1 and $grps[0] eq 'Main';
      66        
3505             # return colon-separated string of group names
3506 2736         8169 return join ':', @grps;
3507             }
3508 90787         285595 return @groups;
3509             }
3510              
3511             #------------------------------------------------------------------------------
3512             # Get group names for specified tags
3513             # Inputs: 0) ExifTool object reference
3514             # 1) [optional] information hash reference (default all extracted info)
3515             # 2) [optional] group family (default 0)
3516             # Returns: List of group names in alphabetical order
3517             sub GetGroups($;$$)
3518             {
3519 3     3 1 16 local $_;
3520 3         5 my $self = shift;
3521 3         4 my $info = shift;
3522 3         4 my $family;
3523              
3524             # figure out our arguments
3525 3 100       9 if (ref $info ne 'HASH') {
3526 2         3 $family = $info;
3527 2         4 $info = $$self{VALUE};
3528             } else {
3529 1         2 $family = shift;
3530             }
3531 3 50       6 $family = 0 unless defined $family;
3532              
3533             # get a list of all groups in specified information
3534 3         5 my ($tag, %groups);
3535 3         46 foreach $tag (keys %$info) {
3536 383         602 $groups{ $self->GetGroup($tag, $family) } = 1;
3537             }
3538 3         43 return sort keys %groups;
3539             }
3540              
3541             #------------------------------------------------------------------------------
3542             # Set priority for group where new values are written
3543             # Inputs: 0) ExifTool object reference,
3544             # 1-N) group names (reset to default if no groups specified)
3545             # - used when new tag values are set (ie. before files are written)
3546             sub SetNewGroups($;@)
3547             {
3548 471     471 1 779 local $_;
3549 471         1944 my ($self, @groups) = @_;
3550 471 50       1401 @groups or @groups = @defaultWriteGroups;
3551 471         1159 my $count = @groups * 10;
3552 471         802 my %priority;
3553 471         1133 foreach (@groups) {
3554 4239         7215 $priority{lc($_)} = $count;
3555 4239         5102 $count -= 10;
3556             }
3557 471         1226 $priority{file} = 500; # 'File' group is always written (Comment)
3558 471         1289 $priority{composite} = 500; # 'Composite' group is always written
3559             # set write priority (higher # is higher priority)
3560 471         1096 $$self{WRITE_PRIORITY} = \%priority;
3561 471         1493 $$self{WRITE_GROUPS} = \@groups;
3562             }
3563              
3564             #------------------------------------------------------------------------------
3565             # Build Composite tags from Require'd/Desire'd tags
3566             # Inputs: 0) ExifTool object reference
3567             # Note: Tag values are calculated in alphabetical order unless a tag Require's
3568             # or Desire's another Composite tag, in which case the calculation is
3569             # deferred until after the other tag is calculated.
3570             sub BuildCompositeTags($)
3571             {
3572 502     502 1 823 local $_;
3573 502         955 my $self = shift;
3574              
3575 502         1167 $$self{BuildingComposite} = 1;
3576              
3577 502         1332 my $compTable = GetTagTable('Image::ExifTool::Composite');
3578 502         25851 my @tagList = sort keys %$compTable;
3579 502         2330 my $rawValue = $$self{VALUE};
3580 502         1107 my $compKeys = $$self{COMP_KEYS};
3581 502         1260 my (%cache, $allBuilt);
3582              
3583 502         807 for (;;) {
3584 2195         3299 my (%notBuilt, $tag, @deferredTags);
3585 2195         4012 foreach (@tagList) {
3586 42788 100       106983 $notBuilt{$$compTable{$_}{Name}} = 1 unless $specialTags{$_};
3587             }
3588             COMPOSITE_TAG:
3589 2195         3670 foreach $tag (@tagList) {
3590 42788 100       71580 next if $specialTags{$tag};
3591 39776         68882 my $tagInfo = $self->GetTagInfo($compTable, $tag);
3592 39776 100       62863 next unless $tagInfo;
3593 39527         55799 my $tagName = $$compTable{$tag}{Name};
3594             # put required tags into array and make sure they all exist
3595 39527   100     67593 my $subDoc = ($$tagInfo{SubDoc} and $$self{DOC_COUNT});
3596 39527   100     76858 my $require = $$tagInfo{Require} || { };
3597 39527   100     82791 my $desire = $$tagInfo{Desire} || { };
3598 39527   100     82766 my $inhibit = $$tagInfo{Inhibit} || { };
3599             # loop through sub-documents if necessary
3600 39527         44576 my $docNum = 0;
3601 39527         41991 for (;;) {
3602 39527         46423 my (%tagKey, $found, $index);
3603             # save Require'd and Desire'd tag values in list
3604 39527         46845 for ($index=0; ; ++$index) {
3605 94204   100     247177 my $reqTag = $$require{$index} || $$desire{$index} || $$inhibit{$index};
3606 94204 100       131525 unless ($reqTag) {
3607             # allow Composite with no Require'd or Desire'd tags
3608 8808 50       13994 $found = 1 if $index == 0;
3609 8808         11583 last;
3610             }
3611 85396 100 66     245019 if ($subDoc) {
    100          
    100          
3612             # handle SubDoc tags specially to cache tag keys for faster
3613             # processing when there are a large number of sub-documents
3614             # - get document number from the tag groups if specified,
3615             # otherwise we are looping through all documents for this tag
3616 285 50 0     659 my $doc = $reqTag =~ s/\b(Main|Doc(\d+)):// ? ($2 || 0) : $docNum;
3617             # make fast lookup for keys of this tag with specified groups other than doc group
3618             # (similar to code in InsertTagValues(), but this is case-sensitive)
3619 285         407 my $cacheTag = $cache{$reqTag};
3620 285 50       468 unless ($cacheTag) {
3621 285         656 $cacheTag = $cache{$reqTag} = [ ];
3622 285         353 my $reqGroup;
3623 285 50       1218 $reqTag =~ s/^(.*):// and $reqGroup = $1;
3624 285         445 my ($i, $key, @keys);
3625             # build list of tag keys in order of precedence
3626 285   50     940 for ($key=$reqTag, $i=$$self{DUPL_TAG}{$reqTag} || 0; ; --$i) {
3627 285 50       569 push @keys, $key if defined $$rawValue{$key};
3628 285 50       511 last if $i <= 0;
3629 0         0 $key = "$reqTag ($i)";
3630             }
3631 285 50       703 @keys = $self->GroupMatches($reqGroup, \@keys) if defined $reqGroup;
3632 285 50       559 if (@keys) {
3633 0         0 my $ex = $$self{TAG_EXTRA};
3634             # loop through tags in reverse order of precedence so the higher
3635             # priority tag will win in the case of duplicates within a doc
3636 0 0 0     0 $$cacheTag[$$ex{$_} ? $$ex{$_}{G3} || 0 : 0] = $_ foreach reverse @keys;
3637             }
3638             }
3639             # (set $reqTag to a bogus key if not found)
3640 285   33     878 $reqTag = $$cacheTag[$doc] || "$reqTag (0)";
3641             } elsif ($reqTag =~ /^(.*):(.+)/) {
3642 26525         59264 my ($reqGroup, $name) = ($1, $2);
3643 26525 100 100     48131 if ($reqGroup eq 'Composite' and $notBuilt{$name}) {
3644             # defer only until all other tags are built if
3645             # we are inhibiting based on another Composite tag
3646 2076 100 100     7030 unless ($$inhibit{$index} and $allBuilt) {
3647 1640         2776 push @deferredTags, $tag;
3648 1640         5149 next COMPOSITE_TAG;
3649             }
3650             }
3651             # (CAREFUL! keys may not be sequential if one was deleted)
3652 24885         29012 my ($i, $key, @keys);
3653 24885   100     66784 for ($key=$name, $i=$$self{DUPL_TAG}{$name} || 0; ; --$i) {
3654 25524 100       48474 push @keys, $key if defined $$rawValue{$key};
3655 25524 100       41098 last if $i <= 0;
3656 639         1629 $key = "$name ($i)";
3657             }
3658             # find first matching tag
3659 24885         46518 $key = $self->GroupMatches($reqGroup, \@keys);
3660 24885   66     69226 $reqTag = $key || "$name (0)";
3661             } elsif ($notBuilt{$reqTag} and not $$inhibit{$index}) {
3662             # calculate this tag later if it relies on another
3663             # Composite tag which hasn't been calculated yet
3664 4883         7280 push @deferredTags, $tag;
3665 4883         10547 next COMPOSITE_TAG;
3666             }
3667 78873 100       151737 if (defined $$rawValue{$reqTag}) {
    100          
3668 15739 100       21507 if ($$inhibit{$index}) {
3669 66         158 $found = 0;
3670 66         126 last;
3671             } else {
3672 15673         18062 $found = 1;
3673             }
3674             } elsif ($$require{$index}) {
3675 24130         28220 $found = 0;
3676 24130         29229 last; # don't continue since we require this tag
3677             }
3678 54677         92449 $tagKey{$index} = $reqTag;
3679             }
3680 33004 50       65172 if ($docNum) {
    100          
    100          
3681 0 0       0 if ($found) {
3682 0         0 $$self{DOC_NUM} = $docNum;
3683             # save pointers to all used tag keys
3684 0         0 foreach (keys %tagKey) {
3685 0 0       0 $$compKeys{$_} or $$compKeys{$_} = [ ];
3686 0         0 push @{$$compKeys{$tagKey{$_}}}, [ \%tagKey, $_ ];
  0         0  
3687             }
3688 0         0 $self->FoundTag($tagInfo, \%tagKey);
3689 0         0 delete $$self{DOC_NUM};
3690             }
3691 0 0       0 next if ++$docNum <= $$self{DOC_COUNT};
3692 0         0 last;
3693             } elsif ($found) {
3694 5119         9031 delete $notBuilt{$tagName}; # this tag is OK to build now
3695             # keep track of all Require'd tag keys
3696 5119         15512 foreach (keys %tagKey) {
3697             # only tag keys with same name as a Composite tag
3698             # can be replaced (also eliminates keys with
3699             # instance numbers which can't be replaced either)
3700 22715 100       41745 next unless $compositeID{$tagKey{$_}};
3701             }
3702             # save pointers to all used tag keys
3703 5119         10225 foreach (keys %tagKey) {
3704 22715 100       40877 $$compKeys{$_} or $$compKeys{$_} = [ ];
3705 22715         23770 push @{$$compKeys{$tagKey{$_}}}, [ \%tagKey, $_ ];
  22715         68022  
3706             }
3707             # save reference to tag key lookup as value for Composite tag
3708 5119         12600 my $key = $self->FoundTag($tagInfo, \%tagKey);
3709             } elsif (not defined $found) {
3710 3689         6757 delete $notBuilt{$tagName}; # tag can't be built anyway
3711             }
3712 33004 100       77657 last unless $subDoc;
3713             # don't process sub-documents if there is no chance to build this tag
3714             # (can be very time-consuming if there are many docs)
3715 195 100       343 if (%$require) {
3716 165         420 foreach (keys %$require) {
3717 165         295 my $reqTag = $$require{$_};
3718 165         492 $reqTag =~ s/.*://;
3719 165 50       612 next COMPOSITE_TAG unless defined $$rawValue{$reqTag};
3720             }
3721 0         0 $docNum = 1; # go ahead and process the 1st sub-document
3722             } else {
3723 30 50       110 my @try = ref $$tagInfo{SubDoc} ? @{$$tagInfo{SubDoc}} : keys %$desire;
  30         95  
3724             # at least one of the specified desire tags must exist
3725 30         2861 foreach (@try) {
3726 60 50       187 my $desTag = $$desire{$_} or next;
3727 60         224 $desTag =~ s/.*://;
3728 60 50       176 defined $$rawValue{$desTag} and $docNum = 1, last;
3729             }
3730 30 50       154 last unless $docNum;
3731             }
3732             }
3733             }
3734 2195 100       5277 last unless @deferredTags;
3735 1693 100       4200 if (@deferredTags == @tagList) {
3736 436 50       1248 if ($allBuilt) {
3737             # everything was deferred in the last pass,
3738             # must be a circular dependency
3739 0         0 warn "Circular dependency in Composite tags\n";
3740 0         0 last;
3741             }
3742 436         861 $allBuilt = 1; # try once more, ignoring Composite Inhibit tags
3743             }
3744 1693         10030 @tagList = @deferredTags; # calculate deferred tags now
3745             }
3746 502         1842 delete $$self{BuildingComposite};
3747             }
3748              
3749             #------------------------------------------------------------------------------
3750             # Get reference to Composite tag info hash
3751             # Inputs: 0) case-sensitive Composite tag name
3752             # Returns: tagInfo hash or undef
3753             sub GetCompositeTagInfo($)
3754             {
3755 11     11 0 25 my $tag = shift;
3756 11 50       52 return undef unless $compositeID{$tag};
3757 11         50 return $Image::ExifTool::Composite{$compositeID{$tag}[0]};
3758             }
3759              
3760             #------------------------------------------------------------------------------
3761             # Get tag name (removes copy index)
3762             # Inputs: 0) Tag key
3763             # Returns: Tag name
3764             sub GetTagName($)
3765             {
3766 16704     16704 1 19760 local $_;
3767 16704         33251 $_[0] =~ /^(\S+)/;
3768 16704         38929 return $1;
3769             }
3770              
3771             #------------------------------------------------------------------------------
3772             # Get list of shortcuts
3773             # Returns: Shortcut list (sorted alphabetically)
3774             sub GetShortcuts()
3775             {
3776 0     0 1 0 local $_;
3777 0         0 require Image::ExifTool::Shortcuts;
3778 0         0 return sort keys %Image::ExifTool::Shortcuts::Main;
3779             }
3780              
3781             #------------------------------------------------------------------------------
3782             # Get file type for specified extension
3783             # Inputs: 0) file name or extension (case is not significant),
3784             # or FileType value if a description is requested
3785             # 1) flag to return long description instead of type ('0' to return any recognized type)
3786             # Returns: File type (or desc) or undef if extension not supported or if
3787             # description is the same as the input FileType. In list context,
3788             # may return more than one file type if the file may be different formats.
3789             # Returns list of all supported extensions if no file specified
3790             sub GetFileType(;$$)
3791             {
3792 943     943 1 1493 local $_;
3793 943         2135 my ($file, $desc) = @_;
3794 943 50       2281 unless (defined $file) {
3795 0         0 my @types;
3796 0 0 0     0 if (defined $desc and $desc eq '0') {
3797             # return all recognized types
3798 0         0 @types = sort keys %fileTypeLookup;
3799             } else {
3800             # return all supported types
3801 0         0 foreach (sort keys %fileTypeLookup) {
3802 0         0 my $module = $moduleName{$_};
3803 0 0       0 $module = $moduleName{$fileTypeLookup{$_}} unless defined $module;
3804 0 0 0     0 push @types, $_ unless defined $module and $module eq '0';
3805             }
3806             }
3807 0         0 return @types;
3808             }
3809 943         1715 my ($fileType, $subType);
3810 943         1816 my $fileExt = GetFileExtension($file);
3811 943 100       2495 unless ($fileExt) {
3812 66 50       231 if ($file =~ s/ \((.*)\)$//) {
3813 0         0 $subType = $1;
3814 0         0 $fileExt = GetFileExtension($file);
3815             }
3816 66 50       225 $fileExt = uc($file) unless $fileExt;
3817             }
3818 943 100       3103 $fileExt and $fileType = $fileTypeLookup{$fileExt}; # look up the file type
3819 943   100     5874 $fileType = $fileTypeLookup{$fileType} while $fileType and not ref $fileType;
3820             # return description if specified
3821             # (allow input $file to be a FileType for this purpose)
3822 943 50 33     5126 if ($desc) {
    100 66        
3823 0 0       0 if ($fileType) {
3824 0 0 0     0 if ($static_vars{OverrideFileDescription} and $static_vars{OverrideFileDescription}{$fileExt}) {
3825 0         0 $desc = $static_vars{OverrideFileDescription}{$fileExt};
3826             } else {
3827 0         0 $desc = $$fileType[1];
3828             }
3829             } else {
3830 0         0 $desc = $fileDescription{$file};
3831             }
3832 0 0       0 $desc .= ", $subType" if $subType;
3833 0         0 return $desc;
3834             } elsif ($fileType and (not defined $desc or $desc ne '0')) {
3835             # return only supported file types
3836 894         2537 my $mod = $moduleName{$$fileType[0]};
3837 894 50 66     3369 undef $fileType if defined $mod and $mod eq '0';
3838             }
3839 943 100       2237 $fileType or return ();
3840 894         1581 $fileType = $$fileType[0]; # get file type (or list of types)
3841 894 100       2263 if (wantarray) {
    50          
3842 668 100       1830 return @$fileType if ref $fileType eq 'ARRAY';
3843             } elsif ($fileType) {
3844 226 50       702 $fileType = $fileExt if ref $fileType eq 'ARRAY';
3845             }
3846 890         2377 return $fileType;
3847             }
3848              
3849             #------------------------------------------------------------------------------
3850             # Return true if we can write the specified file type
3851             # Inputs: 0) file name or ext
3852             # Returns: true if writable, 0 if not writable, undef if unrecognized
3853             sub CanWrite($)
3854             {
3855 0     0 1 0 local $_;
3856 0 0       0 my $file = shift or return undef;
3857 0 0       0 my ($type) = GetFileType($file) or return undef;
3858 0 0       0 if ($noWriteFile{$type}) {
3859             # can't write TIFF files with certain extensions (various RAW formats)
3860 0   0     0 my $ext = GetFileExtension($file) || uc($file);
3861 0 0       0 return grep(/^$ext$/, @{$noWriteFile{$type}}) ? 0 : 1 if $ext;
  0 0       0  
3862             }
3863 0 0       0 unless (%writeTypes) {
3864 0         0 $writeTypes{$_} = 1 foreach @writeTypes;
3865             }
3866 0         0 return $writeTypes{$type};
3867             }
3868              
3869             #------------------------------------------------------------------------------
3870             # Return true if we can create the specified file type
3871             # Inputs: 0) file name or ext
3872             # Returns: true if creatable, 0 if not writable, undef if unrecognized
3873             sub CanCreate($)
3874             {
3875 23     23 1 49 local $_;
3876 23 50       77 my $file = shift or return undef;
3877 23   33     112 my $ext = GetFileExtension($file) || uc($file);
3878 23 50       96 my $type = GetFileType($file) or return undef;
3879 23 50 33     172 return 1 if $createTypes{$ext} or $createTypes{$type};
3880 0         0 return 0;
3881             }
3882              
3883             #==============================================================================
3884             # Functions below this are not part of the public API
3885              
3886             # Initialize member variables for reading or writing a new file
3887             # Inputs: 0) ExifTool object reference
3888             sub Init($)
3889             {
3890 763     763 0 1393 local $_;
3891 763         1469 my $self = shift;
3892             # delete all DataMember variables (lower-case names)
3893 763         5863 foreach (keys %$self) {
3894 22952 100       41258 /[a-z]/ and delete $$self{$_};
3895             }
3896 763         2716 undef %static_vars; # clear all static variables
3897 763         1928 delete $$self{FOUND_TAGS}; # list of found tags
3898 763         1424 delete $$self{EXIF_DATA}; # the EXIF data block
3899 763         1482 delete $$self{EXIF_POS}; # EXIF position in file
3900 763         1521 delete $$self{FIRST_EXIF_POS}; # position of first EXIF in file
3901 763         1288 delete $$self{HTML_DUMP}; # html dump information
3902 763         1197 delete $$self{SET_GROUP0}; # group0 name override
3903 763         1212 delete $$self{SET_GROUP1}; # group1 name override
3904 763         1241 delete $$self{DOC_NUM}; # current embedded document number
3905 763         1724 $$self{DOC_COUNT} = 0; # count of embedded documents processed
3906 763         1650 $$self{BASE} = 0; # base for offsets from start of file
3907 763         3287 $$self{FILE_ORDER} = { }; # * hash of tag order in file ('*' = based on tag key)
3908 763         4162 $$self{VALUE} = { }; # * hash of raw tag values
3909 763         2252 $$self{BOTH} = { }; # * hash for Value/PrintConv values of Require'd tags
3910 763         2161 $$self{RATIONAL} = { }; # * hash of original rational components
3911 763         3505 $$self{TAG_INFO} = { }; # * hash of tag information
3912 763         3795 $$self{TAG_EXTRA} = { }; # * hash of extra tag information (dynamic group names)
3913 763         2102 $$self{PRIORITY} = { }; # * priority of current tags
3914 763         1749 $$self{LIST_TAGS} = { }; # hash of tagInfo refs for active List-type tags
3915 763         2132 $$self{PROCESSED} = { }; # hash of processed directory start positions
3916 763         1656 $$self{DIR_COUNT} = { }; # count various types of directories
3917 763         1670 $$self{DUPL_TAG} = { }; # last-used index for duplicate-tag keys
3918 763         1491 $$self{WARNED_ONCE}= { }; # WarnOnce() warnings already issued
3919 763         1539 $$self{WRITTEN} = { }; # list of tags written (selected tags only)
3920 763         1585 $$self{FORCE_WRITE}= { }; # ForceWrite lookup (set from ForceWrite tag)
3921 763         1816 $$self{FOUND_DIR} = { }; # hash of directory names found in file
3922 763         5660 $$self{COMP_KEYS} = { }; # lookup for tag keys used in Composite tags
3923 763         1727 $$self{PATH} = [ ]; # current subdirectory path in file when reading
3924 763         1737 $$self{NUM_FOUND} = 0; # total number of tags found (incl. duplicates)
3925 763         1439 $$self{CHANGED} = 0; # number of tags changed (writer only)
3926 763         1494 $$self{INDENT} = ' '; # initial indent for verbose messages
3927 763         1439 $$self{PRIORITY_DIR} = ''; # the priority directory name
3928 763         2282 $$self{LOW_PRIORITY_DIR} = { PreviewIFD => 1 }; # names of priority 0 directories
3929 763         1714 $$self{TIFF_TYPE} = ''; # type of TIFF data (APP1, TIFF, NEF, etc...)
3930 763         1561 $$self{FMT_EXPR} = undef; # current advanced formatting expression
3931 763         1517 $$self{Make} = ''; # camera make
3932 763         1459 $$self{Model} = ''; # camera model
3933 763         1447 $$self{CameraType} = ''; # Olympus camera type
3934 763         1484 $$self{FileType} = ''; # identified file type
3935 763 50       2325 if ($self->Options('HtmlDump')) {
3936 0         0 require Image::ExifTool::HtmlDump;
3937 0         0 $$self{HTML_DUMP} = new Image::ExifTool::HtmlDump;
3938             }
3939             # make sure our TextOut is a file reference
3940 763 50       2961 $$self{OPTIONS}{TextOut} = \*STDOUT unless ref $$self{OPTIONS}{TextOut};
3941             }
3942              
3943             #------------------------------------------------------------------------------
3944             # Combine information from a list of info hashes
3945             # Unless Duplicates is enabled, first entry found takes priority
3946             # Inputs: 0) ExifTool object reference, 1-N) list of info hash references
3947             # Returns: Combined information hash reference
3948             sub CombineInfo($;@)
3949             {
3950 2     2 0 933 local $_;
3951 2         4 my $self = shift;
3952 2         3 my (%combinedInfo, $info, $tag, %haveInfo);
3953              
3954 2 50       6 if ($$self{OPTIONS}{Duplicates}) {
3955 0         0 while ($info = shift) {
3956 0         0 foreach $tag (keys %$info) {
3957 0         0 $combinedInfo{$tag} = $$info{$tag};
3958             }
3959             }
3960             } else {
3961 2         8 while ($info = shift) {
3962 4         35 foreach $tag (keys %$info) {
3963 266         339 my $tagName = GetTagName($tag);
3964 266 100       412 next if $haveInfo{$tagName};
3965 252         312 $haveInfo{$tagName} = 1;
3966 252         371 $combinedInfo{$tag} = $$info{$tag};
3967             }
3968             }
3969             }
3970 2         28 return \%combinedInfo;
3971             }
3972              
3973             #------------------------------------------------------------------------------
3974             # Get tag table name
3975             # Inputs: 0) ExifTool object reference, 1) tag key
3976             # Returns: Table name if available, otherwise ''
3977             sub GetTableName($$)
3978             {
3979 0     0 0 0 my ($self, $tag) = @_;
3980 0 0       0 my $tagInfo = $$self{TAG_INFO}{$tag} or return '';
3981 0         0 return $$tagInfo{Table}{SHORT_NAME};
3982             }
3983              
3984             #------------------------------------------------------------------------------
3985             # Get tag index number
3986             # Inputs: 0) ExifTool object reference, 1) tag key
3987             # Returns: Table index number, or undefined if this tag isn't indexed
3988             sub GetTagIndex($$)
3989             {
3990 0     0 0 0 my ($self, $tag) = @_;
3991 0 0       0 my $tagInfo = $$self{TAG_INFO}{$tag} or return undef;
3992 0         0 return $$tagInfo{Index};
3993             }
3994              
3995             #------------------------------------------------------------------------------
3996             # Find value for specified tag
3997             # Inputs: 0) ExifTool ref, 1) tag name, 2) tag group (family 1)
3998             # Returns: value or undef
3999             sub FindValue($$$)
4000             {
4001 72     72 0 131 my ($et, $tag, $grp) = @_;
4002 72         91 my ($i, $val);
4003 72         102 my $value = $$et{VALUE};
4004 72         97 for ($i=0; ; ++$i) {
4005 144 100       339 my $key = $tag . ($i ? " ($i)" : '');
4006 144 100       283 last unless defined $$value{$key};
4007 142 100       225 if ($et->GetGroup($key, 1) eq $grp) {
4008 70         117 $val = $$value{$key};
4009 70         89 last;
4010             }
4011             }
4012 72         156 return $val;
4013             }
4014              
4015             #------------------------------------------------------------------------------
4016             # Get tag key for next existing tag
4017             # Inputs: 0) ExifTool ref, 1) tag key or case-sensitive tag name
4018             # Returns: Key of next existing tag, or undef if no more
4019             # Notes: This routine is provided for iterating through duplicate tags in the
4020             # ValueConv of Composite tags.
4021             sub NextTagKey($$)
4022             {
4023 18     18 0 62 my ($self, $tag) = @_;
4024 18 50       75 my $i = ($tag =~ s/ \((\d+)\)$//) ? $1 + 1 : 1;
4025 18         69 $tag = "$tag ($i)";
4026 18 50       60 return $tag if defined $$self{VALUE}{$tag};
4027 18         328 return undef;
4028             }
4029              
4030             #------------------------------------------------------------------------------
4031             # Split file name into directory and name parts
4032             # Inptus: 0) file name
4033             # Returns: 0) directory, 1) filename
4034             sub SplitFileName($)
4035             {
4036 469     469 0 955 my $file = shift;
4037 469         980 my ($dir, $name);
4038 469 50       943 if (eval { require File::Basename }) {
  469         3803  
4039 469         22945 $dir = File::Basename::dirname($file);
4040 469         9938 $name = File::Basename::basename($file);
4041             } else {
4042 0         0 ($name = $file) =~ tr/\\/\//;
4043             # remove path
4044 0 0       0 $dir = length($1) ? $1 : '/' if $name =~ s/(.*)\///;
    0          
4045             }
4046 469         1680 return ($dir, $name);
4047             }
4048              
4049             #------------------------------------------------------------------------------
4050             # Encode file name for calls to system i/o routines
4051             # Inputs: 0) ExifTool ref, 1) file name in CharSetFileName, 2) flag to force conversion
4052             # Returns: true if Windows Unicode routines should be used (in which case
4053             # the file name will be encoded as a null-terminated UTF-16LE string)
4054             sub EncodeFileName($$;$)
4055             {
4056 1123     1123 0 2419 my ($self, $file, $force) = @_;
4057 1123         2159 my $enc = $$self{OPTIONS}{CharsetFileName};
4058 1123 50 33     5267 if ($enc) {
    50 33        
4059 0 0 0     0 if ($file =~ /[\x80-\xff]/ or $force) {
4060             # encode for use in Windows Unicode functions if necessary
4061 0 0       0 if ($^O eq 'MSWin32') {
4062 0         0 local $SIG{'__WARN__'} = \&SetWarning;
4063 0 0       0 if (eval { require Win32API::File }) {
  0         0  
4064             # recode as UTF-16LE and add null terminator
4065 0         0 $_[1] = $self->Decode($file, $enc, undef, 'UTF16', 'II') . "\0\0";
4066 0         0 return 1;
4067             }
4068 0         0 $self->WarnOnce('Install Win32API::File for Windows Unicode file support');
4069             } else {
4070             # recode as UTF-8 for other platforms if necessary
4071 0 0       0 $_[1] = $self->Decode($file, $enc, undef, 'UTF8') unless $enc eq 'UTF8';
4072             }
4073             }
4074             } elsif ($^O eq 'MSWin32' and $file =~ /[\x80-\xff]/ and not defined $enc) {
4075 0         0 require Image::ExifTool::XMP;
4076 0 0       0 if (Image::ExifTool::XMP::IsUTF8(\$file) < 0) {
4077 0         0 $self->WarnOnce('FileName encoding not specified');
4078             }
4079             }
4080 1123         2885 return 0;
4081             }
4082              
4083             #------------------------------------------------------------------------------
4084             # Modified perl open() routine to properly handle special characters in file names
4085             # Inputs: 0) ExifTool ref, 1) filehandle, 2) filename,
4086             # 3) mode: '<' or undef = read, '>' = write, '+<' = update
4087             # Returns: true on success
4088             # Note: Must call like "$et->Open(\*FH,$file)", not "$et->Open(FH,$file)" to avoid
4089             # "unopened filehandle" errors due to a change in scope of the filehandle
4090             sub Open($*$;$)
4091             {
4092 898     898 0 2746 my ($self, $fh, $file, $mode) = @_;
4093              
4094 898         2910 $file =~ s/^([\s&])/.\/$1/; # protect leading whitespace or ampersand
4095             # default to read mode ('<') unless input is a trusted pipe
4096 898 50 33     4245 $mode = (($file =~ /\|$/ and $$self{TRUST_PIPE}) ? '' : '<') unless $mode;
    100          
4097 898         1817 delete $$self{TRUST_PIPE};
4098 898 50       2125 if ($mode) {
4099 898 50       2505 if ($self->EncodeFileName($file)) {
4100             # handle Windows Unicode file name
4101 0         0 local $SIG{'__WARN__'} = \&SetWarning;
4102 0         0 my ($access, $create);
4103 0 0       0 if ($mode eq '>') {
4104 0         0 eval {
4105 0         0 $access = Win32API::File::GENERIC_WRITE();
4106 0         0 $create = Win32API::File::CREATE_ALWAYS();
4107             }
4108             } else {
4109 0         0 eval {
4110 0         0 $access = Win32API::File::GENERIC_READ();
4111 0 0       0 $access |= Win32API::File::GENERIC_WRITE() if $mode eq '+<'; # update
4112 0         0 $create = Win32API::File::OPEN_EXISTING();
4113             }
4114             }
4115 0         0 my $share = 0;
4116 0         0 eval {
4117 0 0       0 unless ($access & Win32API::File::GENERIC_WRITE()) {
4118 0         0 $share = Win32API::File::FILE_SHARE_READ() | Win32API::File::FILE_SHARE_WRITE();
4119             }
4120             };
4121 0         0 my $wh = eval { Win32API::File::CreateFileW($file, $access, $share, [], $create, 0, []) };
  0         0  
4122 0 0       0 return undef unless $wh;
4123 0         0 my $fd = eval { Win32API::File::OsFHandleOpenFd($wh, 0) };
  0         0  
4124 0 0 0     0 if (not defined $fd or $fd < 0) {
4125 0         0 eval { Win32API::File::CloseHandle($wh) };
  0         0  
4126 0         0 return undef;
4127             }
4128 0         0 $file = "&=$fd"; # specify file by descriptor
4129             } else {
4130             # add leading space to protect against leading characters like '>'
4131             # in file name, and trailing "\0" to protect trailing spaces
4132 898         2391 $file = " $file\0";
4133             }
4134             }
4135 898         52801 return open $fh, "$mode$file";
4136             }
4137              
4138             #------------------------------------------------------------------------------
4139             # Check to see if a file exists (with Windows Unicode support)
4140             # Inputs: 0) ExifTool ref, 1) file name
4141             # Returns: true if file exists
4142             sub Exists($$)
4143             {
4144 218     218 0 620 my ($self, $file) = @_;
4145              
4146 218 50       689 if ($self->EncodeFileName($file)) {
4147 0         0 local $SIG{'__WARN__'} = \&SetWarning;
4148 0         0 my $wh = eval { Win32API::File::CreateFileW($file,
  0         0  
4149             Win32API::File::GENERIC_READ(),
4150             Win32API::File::FILE_SHARE_READ(), [],
4151             Win32API::File::OPEN_EXISTING(), 0, []) };
4152 0 0       0 return 0 unless $wh;
4153 0         0 eval { Win32API::File::CloseHandle($wh) };
  0         0  
4154             } else {
4155             # (named pipes already exist, but we pretend that they don't
4156             # so we will be able to write them, so test with for pipe -p)
4157 218   33     4091 return(-e $file and not -p $file);
4158             }
4159 0         0 return 1;
4160             }
4161              
4162             #------------------------------------------------------------------------------
4163             # Return true if file is a directory (with Windows Unicode support)
4164             # Inputs: 0) ExifTool ref, 1) file name
4165             # Returns: true if file is a directory (false if file isn't, or doesn't exist)
4166             sub IsDirectory($$)
4167             {
4168 1     1 0 3 my ($et, $file) = @_;
4169 1 50       5 if ($et->EncodeFileName($file)) {
4170 0         0 local $SIG{'__WARN__'} = \&SetWarning;
4171 0         0 my $attrs = eval { Win32API::File::GetFileAttributesW($file) };
  0         0  
4172 0   0     0 my $dirBit = eval { Win32API::File::FILE_ATTRIBUTE_DIRECTORY() } || 0;
4173 0 0 0     0 return 1 if $attrs and $attrs != 0xffffffff and $attrs & $dirBit;
      0        
4174             } else {
4175 1         18 return -d $file;
4176             }
4177 0         0 return 0;
4178             }
4179              
4180             #------------------------------------------------------------------------------
4181             # Get file times (Unix seconds since the epoch)
4182             # Inputs: 0) ExifTool ref, 1) file name or ref
4183             # Returns: 0) access time, 1) modification time, 2) creation time (or undefs on error)
4184             my $k32GetFileTime;
4185             sub GetFileTime($$)
4186             {
4187 0     0 0 0 my ($self, $file) = @_;
4188              
4189             # open file by name if necessary
4190 0 0       0 unless (ref $file) {
4191 0         0 local *FH;
4192 0 0       0 unless ($self->Open(\*FH, $file)) {
4193 0 0       0 if ($self->IsDirectory($file)) {
4194 0         0 my @rtn = (stat $file)[8, 9, 10];
4195 0 0       0 return @rtn if defined $rtn[0];
4196             }
4197 0         0 $self->Warn("GetFileTime error for '${file}'");
4198 0         0 return ();
4199             }
4200 0         0 $file = *FH; # (not \*FH, so *FH will be kept open until $file goes out of scope)
4201             }
4202             # on Windows, try to work around incorrect file times when daylight saving time is in effect
4203 0 0       0 if ($^O eq 'MSWin32') {
4204 0 0       0 if (not eval { require Win32::API }) {
  0 0       0  
4205 0         0 $self->WarnOnce('Install Win32::API for proper handling of Windows file times');
4206 0         0 } elsif (not eval { require Win32API::File }) {
4207 0         0 $self->WarnOnce('Install Win32API::File for proper handling of Windows file times');
4208             } else {
4209             # get Win32 handle, needed for GetFileTime
4210 0         0 my $win32Handle = eval { Win32API::File::GetOsFHandle($file) };
  0         0  
4211 0 0       0 unless ($win32Handle) {
4212 0         0 $self->Warn("Win32API::File::GetOsFHandle returned invalid handle");
4213 0         0 return ();
4214             }
4215             # get FILETIME structs
4216 0         0 my ($atime, $mtime, $ctime, $time);
4217 0         0 $atime = $mtime = $ctime = pack 'LL', 0, 0;
4218 0 0       0 unless ($k32GetFileTime) {
4219 0 0       0 return () if defined $k32GetFileTime;
4220 0         0 $k32GetFileTime = new Win32::API('KERNEL32', 'GetFileTime', 'NPPP', 'I');
4221 0 0       0 unless ($k32GetFileTime) {
4222 0         0 $self->Warn('Error calling Win32::API::GetFileTime');
4223 0         0 $k32GetFileTime = 0;
4224 0         0 return ();
4225             }
4226             }
4227 0 0       0 unless ($k32GetFileTime->Call($win32Handle, $ctime, $atime, $mtime)) {
4228 0         0 $self->Warn("Win32::API::GetFileTime returned " . Win32::GetLastError());
4229 0         0 return ();
4230             }
4231             # convert FILETIME structs to Unix seconds
4232 0         0 foreach $time ($atime, $mtime, $ctime) {
4233 0         0 my ($lo, $hi) = unpack 'LL', $time; # unpack FILETIME struct
4234             # FILETIME is in 100 ns intervals since 0:00 UTC Jan 1, 1601
4235             # (89 leap years between 1601 and 1970)
4236 0         0 $time = ($hi * 4294967296 + $lo) * 1e-7 - (((1970-1601)*365+89)*24*3600);
4237             }
4238 0         0 return ($atime, $mtime, $ctime);
4239             }
4240             }
4241             # other os (or Windows fallback)
4242 0         0 return (stat $file)[8, 9, 10];
4243             }
4244              
4245             #------------------------------------------------------------------------------
4246             # Parse function arguments and set member variables accordingly
4247             # Inputs: Same as ImageInfo()
4248             # - sets REQUESTED_TAGS, REQ_TAG_LOOKUP, IO_TAG_LIST, FILENAME, RAF, OPTIONS
4249             sub ParseArguments($;@)
4250             {
4251 688     688 0 1249 my $self = shift;
4252 688         1415 my $options = $$self{OPTIONS};
4253 688         1277 my @oldGroupOpts = grep /^Group/, keys %{$$self{OPTIONS}};
  688         11158  
4254 688         2678 my (@exclude, $wasExcludeOpt);
4255              
4256 688         1919 $$self{REQUESTED_TAGS} = [ ];
4257 688         1848 $$self{REQ_TAG_LOOKUP} = { };
4258 688         1646 $$self{EXCL_TAG_LOOKUP} = { };
4259 688         1477 $$self{IO_TAG_LIST} = undef;
4260 688         1354 delete $$self{EXCL_XMP_LOOKUP};
4261              
4262             # handle our input arguments
4263 688         2137 while (@_) {
4264 1486         2345 my $arg = shift;
4265 1486 100 66     5274 if (ref $arg and not overload::Method($arg, q[""])) {
    100          
4266 153 100 100     5582 if (ref $arg eq 'ARRAY') {
    100          
    100          
    50          
4267 4         11 $$self{IO_TAG_LIST} = $arg;
4268 4         12 foreach (@$arg) {
4269 12 100       25 if (/^-(.*)/) {
4270 2         7 push @exclude, $1;
4271             } else {
4272 10         11 push @{$$self{REQUESTED_TAGS}}, $_;
  10         20  
4273             }
4274             }
4275             } elsif (ref $arg eq 'HASH') {
4276 107         189 my $opt;
4277 107         375 foreach $opt (keys %$arg) {
4278             # a single new group option overrides all old group options
4279 171 50 33     520 if (@oldGroupOpts and $opt =~ /^Group/) {
4280 0         0 foreach (@oldGroupOpts) {
4281 0         0 delete $$options{$_};
4282             }
4283 0         0 undef @oldGroupOpts;
4284             }
4285 171         545 $self->Options($opt, $$arg{$opt});
4286 171 50       578 $opt eq 'Exclude' and $wasExcludeOpt = 1;
4287             }
4288             } elsif (ref $arg eq 'SCALAR' or UNIVERSAL::isa($arg,'GLOB')) {
4289 23 50       84 next if defined $$self{RAF};
4290             # convert image data from UTF-8 to character stream if necessary
4291             # (patches RHEL 3 UTF8 LANG problem)
4292 23 50 66     157 if (ref $arg eq 'SCALAR' and $] >= 5.006 and
      33        
      66        
4293             (eval { require Encode; Encode::is_utf8($$arg) } or $@))
4294             {
4295             # repack by hand if Encode isn't available
4296 0 0       0 my $buff = $@ ? pack('C*',unpack($] < 5.010000 ? 'U0C*' : 'C0C*',$$arg)) : Encode::encode('utf8',$$arg);
    0          
4297 0         0 $arg = \$buff;
4298             }
4299 23         143 $$self{RAF} = new File::RandomAccess($arg);
4300             # set filename to empty string to indicate that
4301             # we have a file but we didn't open it
4302 23         79 $$self{FILENAME} = '';
4303             } elsif (UNIVERSAL::isa($arg, 'File::RandomAccess')) {
4304 19         38 $$self{RAF} = $arg;
4305 19         45 $$self{FILENAME} = '';
4306             } else {
4307 0         0 warn "Don't understand ImageInfo argument $arg\n";
4308             }
4309             } elsif (defined $$self{FILENAME}) {
4310 864 100       1859 if ($arg =~ /^-(.*)/) {
4311 54         240 push @exclude, $1;
4312             } else {
4313 810         1105 push @{$$self{REQUESTED_TAGS}}, $arg;
  810         2231  
4314             }
4315             } else {
4316 469         1433 $$self{FILENAME} = $arg;
4317             }
4318             }
4319             # add additional requested tags to lookup
4320 688 100       2046 if ($$options{RequestTags}) {
4321 42         99 $$self{REQ_TAG_LOOKUP}{$_} = 1 foreach @{$$options{RequestTags}};
  42         218  
4322             }
4323             # expand shortcuts in tag arguments if provided
4324 688 100       1075 if (@{$$self{REQUESTED_TAGS}}) {
  688         2036  
4325 353         1409 ExpandShortcuts($$self{REQUESTED_TAGS});
4326             # initialize lookup for requested tags
4327 353         595 foreach (@{$$self{REQUESTED_TAGS}}) {
  353         1010  
4328 863 50       3610 /^(.*:)?([-\w?*]*)#?$/ or next;
4329 863 50       3326 $$self{REQ_TAG_LOOKUP}{lc($2)} = 1 if $2;
4330 863 100       2044 next unless $1;
4331 234         1116 $$self{REQ_TAG_LOOKUP}{lc($_).':'} = 1 foreach split /:/, $1;
4332             }
4333             }
4334 688 100 66     3362 if (@exclude or $wasExcludeOpt) {
4335             # must add existing excluded tags
4336 41 100       159 push @exclude, @{$$options{Exclude}} if $$options{Exclude};
  1         3  
4337 41         114 $$options{Exclude} = \@exclude;
4338             # expand shortcuts in new exclude list
4339 41         150 ExpandShortcuts($$options{Exclude}, 1); # (also remove '#' suffix)
4340             }
4341             # generate lookup for excluded tags
4342 688 100       2518 if ($$options{Exclude}) {
4343 47         101 foreach (@{$$options{Exclude}}) {
  47         939  
4344 64 100       552 /([-\w]+)#?$/ and $$self{EXCL_TAG_LOOKUP}{lc $1} = 1;
4345 64 50       262 if (/(xmp-.*:[-\w]+)#?/i) {
4346 0 0       0 $$self{EXCL_XMP_LOOKUP} or $$self{EXCL_XMP_LOOKUP} = { };
4347 0         0 $$self{EXCL_XMP_LOOKUP}{lc $1} = 1;
4348             }
4349             }
4350             # exclude list is used only for EXCL_TAG_LOOKUP when TAGS_FROM_FILE is set
4351 47 100       210 undef $$options{Exclude} if $$self{TAGS_FROM_FILE};
4352             }
4353             }
4354              
4355             #------------------------------------------------------------------------------
4356             # Does group name match the tag ID?
4357             # Inputs: 0) tag ID, 1) group name (with "ID-" removed)
4358             # Returns: true on success
4359             sub IsSameID($$)
4360             {
4361 2     2 0 6 my ($id, $grp) = @_;
4362 2 100       8 return 1 if $grp eq $id; # decimal ID's or raw ID's
4363 1 50       5 if ($id =~ /^\d+$/) { # numerical numerical ID's may be in hex
4364 0 0 0     0 return 1 if $grp =~ s/^0x0*// and $grp eq sprintf('%x', $id);
4365             } else { # other ID's may conform to ExifTool group name conventions
4366 1 50 33     7 return 1 if $id =~ s/([^-_A-Za-z0-9])/sprintf('%.2x',ord $1)/ge and $grp eq $id;
  1         13  
4367             }
4368 1         4 return 0;
4369             }
4370              
4371             #------------------------------------------------------------------------------
4372             # Get list of tags in specified group
4373             # Inputs: 0) ExifTool ref, 1) group spec, 2) tag key or reference to list of tag keys
4374             # Returns: list of matching tags in list context, or first match in scalar context
4375             # Notes: Group spec may contain multiple groups separated by colons, each
4376             # possibly with a leading family number
4377             sub GroupMatches($$$)
4378             {
4379 25437     25437 0 38011 my ($self, $group, $tagList) = @_;
4380 25437 50       41670 $tagList = [ $tagList ] unless ref $tagList;
4381 25437         29262 my ($tag, @matches);
4382             # check each group name individually (eg. "Author:1IPTC")
4383 25437         48900 my @grps = split ':', $group;
4384 25437         31609 my (@fmys, $g);
4385 25437         44884 for ($g=0; $g<@grps; ++$g) {
4386 26006 50       90546 if ($grps[$g] =~ s/^(\d*)(id-)?//i) {
4387 26006 100       49981 $fmys[$g] = $1 if length $1;
4388 26006 50       42697 if ($2) {
4389 0         0 $fmys[$g] = 7;
4390 0         0 next; # (don't convert tag ID's to lower case)
4391             }
4392             }
4393 26006         41420 $grps[$g] = lc $grps[$g];
4394 26006 50       57610 $grps[$g] = '' if $grps[$g] eq 'copy0'; # accept 'Copy0' for primary tag
4395             }
4396 25437         40337 foreach $tag (@$tagList) {
4397 15145         27404 my @groups = $self->GetGroup($tag, -1);
4398 15145         29135 for ($g=0; $g<@grps; ++$g) {
4399 15610         20533 my $grp = $grps[$g];
4400 15610 50 33     38847 next if $grp eq '*' or $grp eq 'all';
4401 15610         16701 my $f;
4402 15610 100       22747 if (defined($f = $fmys[$g])) {
4403 3 50       7 last unless defined $groups[$f];
4404 3 50       8 if ($f == 7) {
4405 0 0       0 next if IsSameID($self->GetTagID($tag), $grp);
4406             } else {
4407 3 100       8 next if $grp eq lc $groups[$f];
4408             }
4409 1         2 last;
4410             } else {
4411 15607 100       125289 last unless grep /^$grp$/i, @groups;
4412             }
4413             }
4414 15145 100       34627 if ($g == @grps) {
4415 4368 100       10538 return $tag unless wantarray;
4416 2407         4996 push @matches, $tag;
4417             }
4418             }
4419 23476 100       50506 return wantarray ? @matches : $matches[0];
4420             }
4421              
4422             #------------------------------------------------------------------------------
4423             # Remove specified tags from returned tag list, updating indices in other lists
4424             # Inputs: 0) tag list ref, 1) index list ref, 2) index list ref, 3) hash ref,
4425             # 4) true to include tags from hash instead of excluding
4426             # Returns: nothing, but updates input lists
4427             sub RemoveTagsFromList($$$$;$)
4428             {
4429 69     69 0 108 local $_;
4430 69         162 my ($tags, $list1, $list2, $exclude, $inv) = @_;
4431 69         109 my @filteredTags;
4432              
4433 69 100 100     367 if (@$list1 or @$list2) {
4434 6         24 while (@$tags) {
4435 233         273 my $tag = pop @$tags;
4436 233         256 my $i = @$tags;
4437 233 100 50     510 if ($$exclude{$tag} xor $inv) {
4438             # remove index of excluded tag from each list
4439 154 100       184 @$list1 = map { $_ < $i ? $_ : $_ == $i ? () : $_ - 1 } @$list1;
  12 100       26  
4440 154 100       191 @$list2 = map { $_ < $i ? $_ : $_ == $i ? () : $_ - 1 } @$list2;
  8245 100       10414  
4441             } else {
4442 79         179 unshift @filteredTags, $tag;
4443             }
4444             }
4445             } else {
4446 63         147 foreach (@$tags) {
4447 6865 100 100     16136 push @filteredTags, $_ unless $$exclude{$_} xor $inv;
4448             }
4449             }
4450 69         484 $_[0] = \@filteredTags; # update tag list
4451             }
4452              
4453             #------------------------------------------------------------------------------
4454             # Set list of found tags from previously requested tags
4455             # Inputs: 0) ExifTool object reference
4456             # Returns: 0) Reference to list of found tag keys (in order of requested tags)
4457             # 1) Reference to list of indices for tags requested by value
4458             # 2) Reference to list of indices for tags specified by wildcard or "all"
4459             # Notes: index lists are returned in increasing order
4460             sub SetFoundTags($)
4461             {
4462 683     683 0 1187 my $self = shift;
4463 683         1329 my $options = $$self{OPTIONS};
4464 683   50     2624 my $reqTags = $$self{REQUESTED_TAGS} || [ ];
4465 683         1334 my $duplicates = $$options{Duplicates};
4466 683         1367 my $exclude = $$options{Exclude};
4467 683         1206 my $fileOrder = $$self{FILE_ORDER};
4468 683         14840 my @groupOptions = sort grep /^Group/, keys %$options;
4469 683   100     3802 my $doDups = $duplicates || $exclude || @groupOptions;
4470 683         1319 my ($tag, $rtnTags, @byValue, @wildTags);
4471              
4472             # only return requested tags if specified
4473 683 100       2031 if (@$reqTags) {
4474 353 50       1078 $rtnTags or $rtnTags = [ ];
4475             # scan through the requested tags and generate a list of tags we found
4476 353         725 my $tagHash = $$self{VALUE};
4477 353         551 my $reqTag;
4478 353         852 foreach $reqTag (@$reqTags) {
4479 863         1358 my (@matches, $group, $allGrp, $allTag, $byValue);
4480 863 100       2635 if ($reqTag =~ /^(.*):(.+)/) {
4481 234         860 ($group, $tag) = ($1, $2);
4482 234 50       1412 if ($group =~ /^(\*|all)$/i) {
    50          
4483 0         0 $allGrp = 1;
4484             } elsif ($group !~ /^[-\w:]*$/) {
4485 0         0 $self->Warn("Invalid group name '${group}'");
4486 0         0 $group = 'invalid';
4487             }
4488             } else {
4489 629         1023 $tag = $reqTag;
4490             }
4491 863 50 66     2180 $byValue = 1 if $tag =~ s/#$// and $$options{PrintConv};
4492 863 50 66     5553 if (defined $$tagHash{$reqTag} and not $doDups) {
    100 66        
    100          
    50          
    0          
4493 0         0 $matches[0] = $tag;
4494             } elsif ($tag =~ /^(\*|all)$/i) {
4495             # tag name of '*' or 'all' matches all tags
4496 138 100 66     518 if ($doDups or $allGrp) {
4497 137         4320 @matches = grep(!/#/, keys %$tagHash);
4498             } else {
4499 1         53 @matches = grep(!/ /, keys %$tagHash);
4500             }
4501 138 50       697 next unless @matches; # don't want entry in list for '*' tag
4502 138         254 $allTag = 1;
4503             } elsif ($tag =~ /[*?]/) {
4504             # allow wildcards in tag names
4505 3         8 $tag =~ s/\*/[-\\w]*/g;
4506 3         9 $tag =~ s/\?/[-\\w]/g;
4507 3 50 33     22 $tag .= '( \\(.*)?' if $doDups or $allGrp;
4508 3         569 @matches = grep(/^$tag$/i, keys %$tagHash);
4509 3 50       29 next unless @matches; # don't want entry in list for wildcard tags
4510 3         6 $allTag = 1;
4511             } elsif ($doDups or defined $group) {
4512             # must also look for tags like "Tag (1)"
4513             # (but be sure not to match temporary ValueConv entries like "Tag #")
4514 722         41998 @matches = grep(/^$tag( \(|$)/i, keys %$tagHash);
4515             } elsif ($tag =~ /^[-\w]+$/) {
4516             # find first matching value
4517             # (use in list context to return value instead of count)
4518 0         0 ($matches[0]) = grep /^$tag$/i, keys %$tagHash;
4519 0 0       0 defined $matches[0] or undef @matches;
4520             } else {
4521 0         0 $self->Warn("Invalid tag name '${tag}'");
4522             }
4523 863 100 66     4392 if (defined $group and not $allGrp) {
4524             # keep only specified group
4525 234         672 @matches = $self->GroupMatches($group, \@matches);
4526 234 100 100     907 next unless @matches or not $allTag;
4527             }
4528 848 100       2533 if (@matches > 1) {
    100          
4529             # maintain original file order for multiple tags
4530 143         773 @matches = sort { $$fileOrder{$a} <=> $$fileOrder{$b} } @matches;
  7714         9848  
4531             # return only the highest priority tag unless duplicates wanted
4532 143 50 66     582 unless ($doDups or $allTag or $allGrp) {
      33        
4533 0         0 $tag = shift @matches;
4534 0   0     0 my $oldPriority = $$self{PRIORITY}{$tag} || 1;
4535 0         0 foreach (@matches) {
4536 0         0 my $priority = $$self{PRIORITY}{$_};
4537 0 0       0 $priority = 1 unless defined $priority;
4538 0 0       0 next unless $priority >= $oldPriority;
4539 0         0 $tag = $_;
4540 0   0     0 $oldPriority = $priority || 1;
4541             }
4542 0         0 @matches = ( $tag );
4543             }
4544             } elsif (not @matches) {
4545             # put entry in return list even without value (value is undef)
4546 437 100       1213 $matches[0] = $byValue ? "$tag #(0)" : "$tag (0)";
4547             # bogus file order entry to avoid warning if sorting in file order
4548 437         1195 $$self{FILE_ORDER}{$matches[0]} = 9999;
4549             }
4550             # save indices of tags extracted by value
4551 848 100       1721 push @byValue, scalar(@$rtnTags) .. (scalar(@$rtnTags)+scalar(@matches)-1) if $byValue;
4552             # save indices of wildcard tags
4553 848 100       2321 push @wildTags, scalar(@$rtnTags) .. (scalar(@$rtnTags)+scalar(@matches)-1) if $allTag;
4554 848         2724 push @$rtnTags, @matches;
4555             }
4556             } else {
4557             # no requested tags, so we want all tags
4558 330         537 my @allTags;
4559 330 50       799 if ($doDups) {
4560 330         577 @allTags = keys %{$$self{VALUE}};
  330         7172  
4561             } else {
4562             # only include tag if it doesn't end in a copy number
4563 0         0 @allTags = grep(!/ /, keys %{$$self{VALUE}});
  0         0  
4564             }
4565 330         996 $rtnTags = \@allTags;
4566             }
4567              
4568             # filter excluded tags and group options
4569 683   100     3935 while (($exclude or @groupOptions) and @$rtnTags) {
      66        
4570 68 100       193 if ($exclude) {
4571 41         85 my ($pat, %exclude);
4572 41         118 foreach $pat (@$exclude) {
4573 57         193 my $group;
4574 57 100       291 if ($pat =~ /^(.*):(.+)/) {
4575 30         141 ($group, $tag) = ($1, $2);
4576 30 50       246 if ($group =~ /^(\*|all)$/i) {
    50          
4577 0         0 undef $group;
4578             } elsif ($group !~ /^[-\w:]*$/) {
4579 0         0 $self->Warn("Invalid group name '${group}'");
4580 0         0 $group = 'invalid';
4581             }
4582             } else {
4583 27         73 $tag = $pat;
4584             }
4585 57         101 my @matches;
4586 57 100       244 if ($tag =~ /^(\*|all)$/i) {
4587 30         165 @matches = @$rtnTags;
4588             } else {
4589             # allow wildcards in tag names
4590 27         60 $tag =~ s/\*/[-\\w]*/g;
4591 27         47 $tag =~ s/\?/[-\\w]/g;
4592 27         2100 @matches = grep(/^$tag( |$)/i, @$rtnTags);
4593             }
4594 57 100 66     320 @matches = $self->GroupMatches($group, \@matches) if $group and @matches;
4595 57         401 $exclude{$_} = 1 foreach @matches;
4596             }
4597 41 50       157 if (%exclude) {
4598             # remove excluded tags from return list(s)
4599 41         217 RemoveTagsFromList($rtnTags, \@byValue, \@wildTags, \%exclude);
4600 41 50       130 last unless @$rtnTags; # all done if nothing left
4601             }
4602 41 100 66     280 last if $duplicates and not @groupOptions;
4603             }
4604             # filter groups if requested, or to remove duplicates
4605 28         53 my (%keepTags, %wantGroup, $family, $groupOpt);
4606 28         42 my $allGroups = 1;
4607             # build hash of requested/excluded group names for each group family
4608 28         35 my $wantOrder = 0;
4609 28         55 foreach $groupOpt (@groupOptions) {
4610 29 50       141 $groupOpt =~ /^Group(\d*(:\d+)*)/ or next;
4611 29   100     108 $family = $1 || 0;
4612 29 50       86 $wantGroup{$family} or $wantGroup{$family} = { };
4613 29         46 my $groupList;
4614 29 100       82 if (ref $$options{$groupOpt} eq 'ARRAY') {
4615 4         7 $groupList = $$options{$groupOpt};
4616             } else {
4617 25         54 $groupList = [ $$options{$groupOpt} ];
4618             }
4619 29         60 foreach (@$groupList) {
4620             # groups have priority in order they were specified
4621 33         44 ++$wantOrder;
4622 33         47 my ($groupName, $want);
4623 33 100       71 if (/^-(.*)/) {
4624             # excluded group begins with '-'
4625 2         5 $groupName = $1;
4626 2         3 $want = 0; # we don't want tags in this group
4627             } else {
4628 31         50 $groupName = $_;
4629 31         35 $want = $wantOrder; # we want tags in this group
4630 31         42 $allGroups = 0; # don't want all groups if we requested one
4631             }
4632 33         103 $wantGroup{$family}{$groupName} = $want;
4633             }
4634             }
4635             # loop through all tags and decide which ones we want
4636 28         41 my (@tags, %bestTag);
4637 28         47 GR_TAG: foreach $tag (@$rtnTags) {
4638 4505         4709 my $wantTag = $allGroups; # want tag by default if want all groups
4639 4505         6741 foreach $family (keys %wantGroup) {
4640 4591         6710 my $group = $self->GetGroup($tag, $family);
4641 4591         6836 my $wanted = $wantGroup{$family}{$group};
4642 4591 100       7299 next unless defined $wanted;
4643 1153 100       1590 next GR_TAG unless $wanted; # skip tag if group excluded
4644             # take lowest non-zero want flag
4645 976 50 33     1452 next if $wantTag and $wantTag < $wanted;
4646 976         1268 $wantTag = $wanted;
4647             }
4648 4328 100       7090 next unless $wantTag;
4649 1047 100       1994 $duplicates and $keepTags{$tag} = 1, next;
4650             # determine which tag we want to keep
4651 665         874 my $tagName = GetTagName($tag);
4652 665         892 my $bestTag = $bestTag{$tagName};
4653 665 100       951 if (defined $bestTag) {
4654 28 100       60 next if $wantTag > $keepTags{$bestTag};
4655 12 50       23 if ($wantTag == $keepTags{$bestTag}) {
4656             # want two tags with the same name -- keep the latest one
4657 0 0       0 if ($tag =~ / \((\d+)\)$/) {
4658 0         0 my $tagNum = $1;
4659 0 0 0     0 next if $bestTag !~ / \((\d+)\)$/ or $1 > $tagNum;
4660             }
4661             }
4662             # this tag is better, so delete old best tag
4663 12         21 delete $keepTags{$bestTag};
4664             }
4665 649         926 $keepTags{$tag} = $wantTag; # keep this tag (for now...)
4666 649         981 $bestTag{$tagName} = $tag; # this is our current best tag
4667             }
4668             # include only tags we want to keep in return lists
4669 28         128 RemoveTagsFromList($rtnTags, \@byValue, \@wildTags, \%keepTags, 1);
4670 28         173 last;
4671             }
4672 683         1941 $$self{FOUND_TAGS} = $rtnTags; # save found tags
4673              
4674             # return reference to found tag keys (and list of indices of tags to extract by value)
4675 683 50       3788 return wantarray ? ($rtnTags, \@byValue, \@wildTags) : $rtnTags;
4676             }
4677              
4678             #------------------------------------------------------------------------------
4679             # Utility to load our write routines if required (called via AUTOLOAD)
4680             # Inputs: 0) autoload function, 1-N) function arguments
4681             # Returns: result of function or dies if function not available
4682             sub DoAutoLoad(@)
4683             {
4684 713     713 0 2366 my $autoload = shift;
4685 713         3287 my @callInfo = split(/::/, $autoload);
4686 713         1662 my $file = 'Image/ExifTool/Write';
4687              
4688 713 100       120243 return if $callInfo[$#callInfo] eq 'DESTROY';
4689 242 100       981 if (@callInfo == 4) {
    100          
4690             # load Image/ExifTool/WriteMODULE.pl
4691 184         530 $file .= "$callInfo[2].pl";
4692             } elsif ($callInfo[-1] eq 'ShiftTime') {
4693 1         2 $file = 'Image/ExifTool/Shift.pl'; # load Shift.pl
4694             } else {
4695             # load Image/ExifTool/Writer.pl
4696 57         169 $file .= 'r.pl';
4697             }
4698             # attempt to load the package
4699 242 50       533 eval { require $file } or die "Error while attempting to call $autoload\n$@\n";
  242         196285  
4700 242 50       1569 unless (defined &$autoload) {
4701 0         0 my @caller = caller(0);
4702             # reproduce Perl's standard 'undefined subroutine' message:
4703 0         0 die "Undefined subroutine $autoload called at $caller[1] line $caller[2]\n";
4704             }
4705 104     104   1139 no strict 'refs';
  104         230  
  104         108311  
4706 242         1434 return &$autoload(@_); # call the function
4707             }
4708              
4709             #------------------------------------------------------------------------------
4710             # AutoLoad our writer routines when necessary
4711             #
4712             sub AUTOLOAD
4713             {
4714 529     529   313322 return DoAutoLoad($AUTOLOAD, @_);
4715             }
4716              
4717             #------------------------------------------------------------------------------
4718             # Add warning tag
4719             # Inputs: 0) ExifTool object reference, 1) warning message
4720             # 2) true if minor (2 if behaviour changes when warning is ignored,
4721             # or 3 if warning shouldn't be issued when Validate option is used)
4722             # Returns: true if warning tag was added
4723             sub Warn($$;$)
4724             {
4725 87     87 0 226 my ($self, $str, $ignorable) = @_;
4726 87 100       301 if ($ignorable) {
4727 32 100       190 return 0 if $$self{OPTIONS}{IgnoreMinorErrors};
4728 31 50 66     145 return 0 if $ignorable eq '3' and $$self{OPTIONS}{Validate};
4729 31 100       117 $str = $ignorable eq '2' ? "[Minor] $str" : "[minor] $str";
4730             }
4731 86         339 $self->FoundTag('Warning', $str);
4732 86         256 return 1;
4733             }
4734              
4735             #------------------------------------------------------------------------------
4736             # Add warning tag only once per processed file
4737             # Inputs: 0) ExifTool object reference, 1) warning message, 2) true if minor
4738             # Returns: true if warning tag was added
4739             sub WarnOnce($$;$)
4740             {
4741 48     48 0 134 my ($self, $str, $ignorable) = @_;
4742 48 50 66     151 return 0 if $ignorable and $$self{OPTIONS}{IgnoreMinorErrors};
4743 48 100       142 unless ($$self{WARNED_ONCE}{$str}) {
4744 41         192 $self->Warn($str, $ignorable);
4745 41         145 $$self{WARNED_ONCE}{$str} = 1;
4746             }
4747 48         123 return 1;
4748             }
4749              
4750             #------------------------------------------------------------------------------
4751             # Add error tag
4752             # Inputs: 0) ExifTool object reference, 1) error message, 2) true if minor
4753             # Returns: true if error tag was added, otherwise warning was added
4754             sub Error($$;$)
4755             {
4756 1     1 0 4 my ($self, $str, $ignorable) = @_;
4757 1 50       12 if ($$self{DemoteErrors}) {
    50          
4758 0 0       0 $self->Warn($str) and ++$$self{DemoteErrors};
4759 0         0 return 1;
4760             } elsif ($ignorable) {
4761 1 50       10 $$self{OPTIONS}{IgnoreMinorErrors} and $self->Warn($str), return 0;
4762 0         0 $str = "[minor] $str";
4763             }
4764 0         0 $self->FoundTag('Error', $str);
4765 0         0 return 1;
4766             }
4767              
4768             #------------------------------------------------------------------------------
4769             # Expand shortcuts
4770             # Inputs: 0) reference to list of tags, 1) set to remove trailing '#'
4771             # Notes: Handles leading '-' for excluded tags, trailing '#' for ValueConv,
4772             # multiple group names, and redirected tags
4773             sub ExpandShortcuts($;$)
4774             {
4775 501     501 0 1143 my ($tagList, $removeSuffix) = @_;
4776 501 50 33     2264 return unless $tagList and @$tagList;
4777              
4778 501         24330 require Image::ExifTool::Shortcuts;
4779              
4780             # expand shortcuts
4781 501 100       1517 my $suffix = $removeSuffix ? '' : '#';
4782 501         752 my @expandedTags;
4783 501         975 my ($entry, $tag, $excl);
4784 501         1101 foreach $entry (@$tagList) {
4785             # skip things like options hash references in list
4786 1019 100       2049 if (ref $entry) {
4787 1         3 push @expandedTags, $entry;
4788 1         2 next;
4789             }
4790             # remove leading '-'
4791 1018         4571 ($excl, $tag) = $entry =~ /^(-?)(.*)/s;
4792 1018         2024 my ($post, @post, $pre, $v);
4793             # handle redirection
4794 1018 100 100     8736 if (not $excl and $tag =~ /(.+?)([-+]?[<>].+)/s) {
4795 23         84 ($tag, $post) = ($1, $2);
4796 23 100 100     154 if ($post =~ /^[-+]?>/ or $post !~ /\$/) {
4797             # expand shortcuts in postfix (rhs of redirection)
4798 18         102 my ($op, $p2, $t2) = ($post =~ /([-+]?[<>])(.+:)?(.+)/);
4799 18 100       75 $p2 = '' unless defined $p2;
4800 18 50       78 $v = ($t2 =~ s/#$//) ? $suffix : ''; # ValueConv suffix
4801 18         324 my ($match) = grep /^\Q$t2\E$/i, keys %Image::ExifTool::Shortcuts::Main;
4802 18 50       80 if ($match) {
4803 0         0 foreach (@{$Image::ExifTool::Shortcuts::Main{$match}}) {
  0         0  
4804 0 0       0 /^-/ and next; # ignore excluded tags
4805 0 0 0     0 if ($p2 and /(.+:)(.+)/) {
4806 0         0 push @post, "$op$_$v";
4807             } else {
4808 0         0 push @post, "$op$p2$_$v";
4809             }
4810             }
4811 0 0       0 next unless @post;
4812 0         0 $post = shift @post;
4813             }
4814             }
4815             } else {
4816 995         1680 $post = '';
4817             }
4818             # handle group names
4819 1018 100       2653 if ($tag =~ /(.+:)(.+)/) {
4820 298         1027 ($pre, $tag) = ($1, $2);
4821             } else {
4822 720         970 $pre = '';
4823             }
4824 1018 100       2199 $v = ($tag =~ s/#$//) ? $suffix : ''; # ValueConv suffix
4825             # loop over all postfixes
4826 1018         1463 for (;;) {
4827             # expand the tag name
4828 1018         17179 my ($match) = grep /^\Q$tag\E$/i, keys %Image::ExifTool::Shortcuts::Main;
4829 1018 100       2765 if ($match) {
4830 17 50 66     110 if ($excl) {
    100 66        
4831             # entry starts with '-', so exclude all tags in this shortcut
4832 0         0 foreach (@{$Image::ExifTool::Shortcuts::Main{$match}}) {
  0         0  
4833 0 0       0 /^-/ and next; # ignore excluded exclude tags
4834             # group of expanded tag takes precedence
4835 0 0 0     0 if ($pre and /(.+:)(.+)/) {
4836 0         0 push @expandedTags, "$excl$_";
4837             } else {
4838 0         0 push @expandedTags, "$excl$pre$_";
4839             }
4840             }
4841             } elsif (length $pre or length $post or $v) {
4842 1         3 foreach (@{$Image::ExifTool::Shortcuts::Main{$match}}) {
  1         4  
4843 12         36 /(-?)(.+:)?(.+)/;
4844 12 50       18 if ($2) {
4845             # group from expanded tag takes precedence
4846 0         0 push @expandedTags, "$_$v$post";
4847             } else {
4848 12         30 push @expandedTags, "$1$pre$3$v$post";
4849             }
4850             }
4851             } else {
4852 16         25 push @expandedTags, @{$Image::ExifTool::Shortcuts::Main{$match}};
  16         41  
4853             }
4854             } else {
4855 1001         2735 push @expandedTags, "$excl$pre$tag$v$post";
4856             }
4857 1018 50       2866 last unless @post;
4858 0         0 $post = shift @post;
4859             }
4860             }
4861 501         1666 @$tagList = @expandedTags;
4862             }
4863              
4864             #------------------------------------------------------------------------------
4865             # Add hash of Composite tags to our composites
4866             # Inputs: 0) hash reference to table of Composite tags to add or module name,
4867             # 1) override existing tag definition
4868             sub AddCompositeTags($;$)
4869             {
4870 585     585 0 1460 local $_;
4871 585         1853 my ($add, $override) = @_;
4872 585         1205 my ($module, $prefix, $tagID);
4873 585 50       2175 unless (ref $add) {
4874 585         5827 ($prefix = $add) =~ s/.*:://;
4875 585         1313 $module = $add;
4876 585         1686 $add .= '::Composite';
4877 104     104   759 no strict 'refs';
  104         262  
  104         761653  
4878 585         2844 $add = \%$add;
4879 585         1382 $prefix .= '-';
4880             } else {
4881 0         0 $prefix = 'UserDefined-';
4882             }
4883 585         1610 my $defaultGroups = $$add{GROUPS};
4884 585         2143 my $compTable = GetTagTable('Image::ExifTool::Composite');
4885              
4886             # make sure default groups are defined in families 0 and 1
4887 585 100       1514 if ($defaultGroups) {
4888 489 100       1821 $$defaultGroups{0} or $$defaultGroups{0} = 'Composite';
4889 489 100       1523 $$defaultGroups{1} or $$defaultGroups{1} = 'Composite';
4890 489 50       1532 $$defaultGroups{2} or $$defaultGroups{2} = 'Other';
4891             } else {
4892 96         504 $defaultGroups = $$add{GROUPS} = { 0 => 'Composite', 1 => 'Composite', 2 => 'Other' };
4893             }
4894 585         1935 SetupTagTable($add); # generate Name, TagID, etc
4895 585         4428 foreach $tagID (sort keys %$add) {
4896 5651 100       9955 next if $specialTags{$tagID}; # must skip special tags
4897 5063         6159 my $tagInfo = $$add{$tagID};
4898 5063         8712 my $new = $prefix . $tagID; # new tag ID for Composite table
4899 5063 100       8602 $$tagInfo{Module} = $module if $$tagInfo{Writable};
4900 5063 50 33     8019 $$tagInfo{Override} = 1 if $override and not defined $$tagInfo{Override};
4901 5063         7533 $$tagInfo{IsComposite} = 1;
4902             # handle Composite tags with the same name
4903 5063 100       8833 if ($compositeID{$tagID}) {
4904             # determine if we want to override this tag
4905             # (=0 keep both, >0 override, <0 keep existing)
4906 336   50     2745 my $over = ($$tagInfo{Override} || 0) - ($$compTable{$compositeID{$tagID}[0]}{Override} || 0);
      50        
4907 336 50       949 next if $over < 0;
4908 336 50       871 if ($over) {
4909             # remove existing tags with this ID
4910 0         0 delete $$compTable{$_} foreach @{$compositeID{$tagID}};
  0         0  
4911 0         0 delete $compositeID{$tagID};
4912             }
4913             }
4914             # make sure new TagID is unique by adding index if necessary
4915             # (could only happen for UserDefined tags now that module name is added to tag ID)
4916 5063         5754 my $n = 0;
4917 5063         8977 while ($$compTable{$new}) {
4918 0 0       0 $new =~ s/-\d+$// if $n++;
4919 0         0 $new .= "-$n";
4920             }
4921             # use new ID and save it so we can use it in TagLookup
4922 5063 50       10391 $$tagInfo{NewTagID} = $new unless $tagID eq $new;
4923              
4924             # add new ID to lookup of Composite tag ID's
4925 5063 100       11169 $compositeID{$tagID} = [ ] unless $compositeID{$tagID};
4926 5063         6003 unshift @{$compositeID{$tagID}}, $new; # (most recent one first)
  5063         10286  
4927              
4928             # convert scalar Require/Desire/Inhibit entries
4929 5063         6706 my ($type, @hashes, @scalars, %used);
4930 5063         6637 foreach $type ('Require','Desire','Inhibit') {
4931 15189 100       26061 my $req = $$tagInfo{$type} or next;
4932 6529 100       6913 push @{ref($req) eq 'HASH' ? \@hashes : \@scalars}, $type;
  6529         14379  
4933             }
4934 5063 100       8004 if (@scalars) {
4935             # make lookup for indices that are used
4936 943         1489 foreach $type (@hashes) {
4937 104         264 $used{$_} = 1 foreach keys %{$$tagInfo{$type}};
  104         1188  
4938             }
4939 943         1238 my $next = 0;
4940 943         1318 foreach $type (@scalars) {
4941 943         1989 ++$next while $used{$next};
4942 943         2795 $$tagInfo{$type} = { $next++ => $$tagInfo{$type} };
4943             }
4944             }
4945             # add this Composite tag to our main Composite table
4946 5063         6608 $$tagInfo{Table} = $compTable;
4947             # (use the original TagID, even if we changed it, so don't do this:)
4948 5063         6133 $$tagInfo{TagID} = $new;
4949             # save tag under new ID in Composite table
4950 5063         10026 $$compTable{$new} = $tagInfo;
4951             # set all default groups in tag
4952 5063         6017 my $groups = $$tagInfo{Groups};
4953 5063 100       9121 $groups or $groups = $$tagInfo{Groups} = { };
4954             # fill in default groups
4955 5063         10006 foreach (keys %$defaultGroups) {
4956 15189 100       27265 $$groups{$_} or $$groups{$_} = $$defaultGroups{$_};
4957             }
4958             # set flag indicating group list was built
4959 5063         11376 $$tagInfo{GotGroups} = 1;
4960             }
4961             }
4962              
4963             #------------------------------------------------------------------------------
4964             # Add tags to TagLookup (used for writing)
4965             # Inputs: 0) source hash of tag definitions, 1) name of destination tag table
4966             sub AddTagsToLookup($$)
4967             {
4968 1     1 0 3 my ($tagHash, $table) = @_;
4969 1 50       9 if (defined &Image::ExifTool::TagLookup::AddTags) {
    50          
4970 0         0 Image::ExifTool::TagLookup::AddTags($tagHash, $table);
4971             } elsif (not $Image::ExifTool::pluginTags{$tagHash}) {
4972             # queue these tags until TagLookup is loaded
4973 1         3 push @Image::ExifTool::pluginTags, [ $tagHash, $table ];
4974             # set flag so we don't load same tags twice
4975 1         4 $Image::ExifTool::pluginTags{$tagHash} = 1;
4976             }
4977             }
4978              
4979             #------------------------------------------------------------------------------
4980             # Expand tagInfo Flags
4981             # Inputs: 0) tagInfo hash ref
4982             # Notes: $$tagInfo{Flags} must be defined to call this routine
4983             sub ExpandFlags($)
4984             {
4985 4634     4634 0 5799 my $tagInfo = shift;
4986 4634         5882 my $flags = $$tagInfo{Flags};
4987 4634 100       8649 if (ref $flags eq 'ARRAY') {
    50          
4988 2339         4232 foreach (@$flags) {
4989 6209         11361 $$tagInfo{$_} = 1;
4990             }
4991             } elsif (ref $flags eq 'HASH') {
4992 0         0 my $key;
4993 0         0 foreach $key (keys %$flags) {
4994 0         0 $$tagInfo{$key} = $$flags{$key};
4995             }
4996             } else {
4997 2295         4573 $$tagInfo{$flags} = 1;
4998             }
4999             }
5000              
5001             #------------------------------------------------------------------------------
5002             # Set up tag table (must be done once for each tag table used)
5003             # Inputs: 0) Reference to tag table
5004             # Notes: - generates 'Name' field from key if it doesn't exist
5005             # - stores 'Table' pointer and 'TagID' value
5006             # - expands 'Flags' for quick lookup
5007             sub SetupTagTable($)
5008             {
5009 5073     5073 0 7299 my $tagTablePtr = shift;
5010 5073         7634 my $avoid = $$tagTablePtr{AVOID};
5011 5073         7306 my ($tagID, $tagInfo);
5012 5073         10163 foreach $tagID (TagTableKeys($tagTablePtr)) {
5013 201452         253704 my @infoArray = GetTagInfoList($tagTablePtr,$tagID);
5014             # process conditional tagInfo arrays
5015 201452         236325 foreach $tagInfo (@infoArray) {
5016 221583         311016 $$tagInfo{Table} = $tagTablePtr;
5017 221583         279927 $$tagInfo{TagID} = $tagID;
5018 221583 100       342592 $$tagInfo{Name} or $$tagInfo{Name} = MakeTagName($tagID);
5019 221583 100       307466 $$tagInfo{Flags} and ExpandFlags($tagInfo);
5020 221583 100       294107 $$tagInfo{Avoid} = $avoid if defined $avoid;
5021             # calculate BitShift from Mask if necessary
5022 221583 100 100     354300 if ($$tagInfo{Mask} and not defined $$tagInfo{BitShift}) {
5023 3024         4236 my ($mask, $bitShift) = ($$tagInfo{Mask}, 0);
5024 3024         7613 ++$bitShift until $mask & (1 << $bitShift);
5025 3024         4582 $$tagInfo{BitShift} = $bitShift;
5026             }
5027             }
5028 201452 100       330416 next unless @infoArray > 1;
5029             # add an "Index" member to each tagInfo in a list
5030 3634         4793 my $index = 0;
5031 3634         4760 foreach $tagInfo (@infoArray) {
5032 23765         31513 $$tagInfo{Index} = $index++;
5033             }
5034             }
5035             }
5036              
5037             #------------------------------------------------------------------------------
5038             # Utilities to check for numerical types
5039             # Inputs: 0) value; Returns: true if value is a numerical type
5040             # Notes: May change commas to decimals in floats for use in other locales
5041             sub IsFloat($) {
5042 7737 100   7737 0 67197 return 1 if $_[0] =~ /^[+-]?(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/;
5043             # allow comma separators (for other locales)
5044 2181 50       13666 return 0 unless $_[0] =~ /^[+-]?(?=\d|,\d)\d*(,\d*)?([Ee]([+-]?\d+))?$/;
5045 0         0 $_[0] =~ tr/,/./; # but translate ',' to '.'
5046 0         0 return 1;
5047             }
5048 19659     19659 0 76294 sub IsInt($) { return scalar($_[0] =~ /^[+-]?\d+$/); }
5049 3045     3045 0 10801 sub IsHex($) { return scalar($_[0] =~ /^(0x)?[0-9a-f]{1,8}$/i); }
5050 16     16 0 117 sub IsRational($) { return scalar($_[0] =~ m{^[-+]?\d+/\d+$}); }
5051              
5052             # round floating point value to specified number of significant digits
5053             # Inputs: 0) value, 1) number of sig digits; Returns: rounded number
5054             sub RoundFloat($$)
5055             {
5056 3358     3358 0 5867 my ($val, $sig) = @_;
5057 3358         21081 return sprintf("%.${sig}g", $val);
5058             }
5059              
5060             # Convert strings to floating point numbers (or undef)
5061             # Inputs: 0-N) list of strings (may be undef)
5062             # Returns: last value converted
5063             sub ToFloat(@)
5064             {
5065 960     960 0 1589 local $_;
5066 960         2102 foreach (@_) {
5067 10335 100       15539 next unless defined $_;
5068             # (add 0 to convert "0.0" to "0" for tests)
5069 3878 100       18482 $_ = /((?:[+-]?)(?=\d|\.\d)\d*(?:\.\d*)?(?:[Ee](?:[+-]?\d+))?)/ ? $1 + 0 : undef;
5070             }
5071 960         7900 return $_[-1];
5072             }
5073              
5074             #------------------------------------------------------------------------------
5075             # Utility routines to for reading binary data values from file
5076              
5077             my %unpackMotorola = ( S => 'n', L => 'N', C => 'C', c => 'c' );
5078             my %unpackIntel = ( S => 'v', L => 'V', C => 'C', c => 'c' );
5079             my %unpackRev = ( N => 'V', V => 'N', C => 'C', n => 'v', v => 'n', c => 'c' );
5080              
5081             # the following 4 variables are defined in 'use vars' instead of using 'my'
5082             # because mod_perl 5.6.1 apparently has a problem with setting file-scope 'my'
5083             # variables from within subroutines (ref communication with Pavel Merdin):
5084             # $swapBytes - set if EXIF header is not native byte ordering
5085             # $swapWords - swap 32-bit words in doubles (ARM quirk)
5086             $currentByteOrder = 'MM'; # current byte ordering ('II' or 'MM')
5087             %unpackStd = %unpackMotorola;
5088              
5089             # Swap bytes in data if necessary
5090             # Inputs: 0) data, 1) number of bytes
5091             # Returns: swapped data
5092             sub SwapBytes($$)
5093             {
5094 1358 100   1358 0 3039 return $_[0] unless $swapBytes;
5095 204         387 my ($val, $bytes) = @_;
5096 204         309 my $newVal = '';
5097 204         1195 $newVal .= substr($val, $bytes, 1) while $bytes--;
5098 204         479 return $newVal;
5099             }
5100             # Swap words. Inputs: 8 bytes of data, Returns: swapped data
5101             sub SwapWords($)
5102             {
5103 1298 50 33 1298 0 4225 return $_[0] unless $swapWords and length($_[0]) == 8;
5104 0         0 return substr($_[0],4,4) . substr($_[0],0,4)
5105             }
5106              
5107             # Unpack value, letting unpack() handle byte swapping
5108             # Inputs: 0) unpack template, 1) data reference, 2) offset
5109             # Returns: unpacked number
5110             # - uses value of %unpackStd to determine the unpack template
5111             # - can only be called for 'S' or 'L' templates since these are the only
5112             # templates for which you can specify the byte ordering.
5113             sub DoUnpackStd(@)
5114             {
5115 154694 100   154694 0 312744 $_[2] and return unpack("x$_[2] $unpackStd{$_[0]}", ${$_[1]});
  150329         320840  
5116 4365         6463 return unpack($unpackStd{$_[0]}, ${$_[1]});
  4365         11143  
5117             }
5118             # same, but with reversed byte order
5119             sub DoUnpackRev(@)
5120             {
5121 12     12 0 23 my $fmt = $unpackRev{$unpackStd{$_[0]}};
5122 12 50       26 $_[2] and return unpack("x$_[2] $fmt", ${$_[1]});
  12         86  
5123 0         0 return unpack($fmt, ${$_[1]});
  0         0  
5124             }
5125             # Pack value
5126             # Inputs: 0) template, 1) value, 2) data ref (or undef), 3) offset (if data ref)
5127             # Returns: packed value
5128             sub DoPackStd(@)
5129             {
5130 31883     31883 0 52915 my $val = pack($unpackStd{$_[0]}, $_[1]);
5131 31883 100       46313 $_[2] and substr(${$_[2]}, $_[3], length($val)) = $val;
  7713         10887  
5132 31883         63579 return $val;
5133             }
5134             # same, but with reversed byte order
5135             sub DoPackRev(@)
5136             {
5137 0     0 0 0 my $val = pack($unpackRev{$unpackStd{$_[0]}}, $_[1]);
5138 0 0       0 $_[2] and substr(${$_[2]}, $_[3], length($val)) = $val;
  0         0  
5139 0         0 return $val;
5140             }
5141              
5142             # Unpack value, handling the byte swapping manually
5143             # Inputs: 0) # bytes, 1) unpack template, 2) data reference, 3) offset
5144             # Returns: unpacked number
5145             # - uses value of $swapBytes to determine byte ordering
5146             sub DoUnpack(@)
5147             {
5148 27162     27162 0 38294 my ($bytes, $template, $dataPt, $pos) = @_;
5149 27162         28899 my $val;
5150 27162 100       35840 if ($swapBytes) {
5151 5396         6156 $val = '';
5152 5396         18816 $val .= substr($$dataPt,$pos+$bytes,1) while $bytes--;
5153             } else {
5154 21766         30468 $val = substr($$dataPt,$pos,$bytes);
5155             }
5156 27162 50       39549 defined($val) or return undef;
5157 27162         50934 return unpack($template,$val);
5158             }
5159              
5160             # Unpack double value
5161             # Inputs: 0) unpack template, 1) data reference, 2) offset
5162             # Returns: unpacked number
5163             sub DoUnpackDbl(@)
5164             {
5165 1236     1236 0 1884 my ($template, $dataPt, $pos) = @_;
5166 1236         1885 my $val = substr($$dataPt,$pos,8);
5167 1236 50       1913 defined($val) or return undef;
5168             # swap bytes and 32-bit words (ARM quirk) if necessary, then unpack value
5169 1236         1875 return unpack($template, SwapWords(SwapBytes($val, 8)));
5170             }
5171              
5172             # Inputs: 0) data reference, 1) offset into data
5173 129     129 0 323 sub Get8s($$) { return DoUnpackStd('c', @_); }
5174 7680     7680 0 12066 sub Get8u($$) { return DoUnpackStd('C', @_); }
5175 14499     14499 0 20729 sub Get16s($$) { return DoUnpack(2, 's', @_); }
5176 73902     73902 0 107384 sub Get16u($$) { return DoUnpackStd('S', @_); }
5177 12020     12020 0 17884 sub Get32s($$) { return DoUnpack(4, 'l', @_); }
5178 72983     72983 0 103534 sub Get32u($$) { return DoUnpackStd('L', @_); }
5179 643     643 0 1304 sub GetFloat($$) { return DoUnpack(4, 'f', @_); }
5180 1236     1236 0 2049 sub GetDouble($$) { return DoUnpackDbl('d', @_); }
5181 12     12 0 27 sub Get16uRev($$) { return DoUnpackRev('S', @_); }
5182 0     0 0 0 sub Get32uRev($$) { return DoUnpackRev('L', @_); }
5183              
5184             # rationals may be a floating point number, 'inf' or 'undef'
5185             my ($ratNumer, $ratDenom);
5186             sub GetRational32s($$)
5187             {
5188 12     12 0 21 my ($dataPt, $pos) = @_;
5189 12         21 $ratNumer = Get16s($dataPt,$pos);
5190 12 0       23 $ratDenom = Get16s($dataPt, $pos + 2) or return $ratNumer ? 'inf' : 'undef';
    50          
5191             # round off to a reasonable number of significant figures
5192 12         28 return RoundFloat($ratNumer / $ratDenom, 7);
5193             }
5194             sub GetRational32u($$)
5195             {
5196 12     12 0 23 my ($dataPt, $pos) = @_;
5197 12         23 $ratNumer = Get16u($dataPt,$pos);
5198 12 0       28 $ratDenom = Get16u($dataPt, $pos + 2) or return $ratNumer ? 'inf' : 'undef';
    50          
5199 12         37 return RoundFloat($ratNumer / $ratDenom, 7);
5200             }
5201             sub GetRational64s($$)
5202             {
5203 654     654 0 1351 my ($dataPt, $pos) = @_;
5204 654         1265 $ratNumer = Get32s($dataPt,$pos);
5205 654 0       1477 $ratDenom = Get32s($dataPt, $pos + 4) or return $ratNumer ? 'inf' : 'undef';
    50          
5206 654         1582 return RoundFloat($ratNumer / $ratDenom, 10);
5207             }
5208             sub GetRational64u($$)
5209             {
5210 2697     2697 0 4415 my ($dataPt, $pos) = @_;
5211 2697         4350 $ratNumer = Get32u($dataPt,$pos);
5212 2697 50       5355 $ratDenom = Get32u($dataPt, $pos + 4) or return $ratNumer ? 'inf' : 'undef';
    100          
5213 2680         7064 return RoundFloat($ratNumer / $ratDenom, 10);
5214             }
5215             sub GetFixed16s($$)
5216             {
5217 13     13 0 49 my ($dataPt, $pos) = @_;
5218 13         42 my $val = Get16s($dataPt, $pos) / 0x100;
5219 13 50       73 return int($val * 1000 + ($val<0 ? -0.5 : 0.5)) / 1000;
5220             }
5221             sub GetFixed16u($$)
5222             {
5223 0     0 0 0 my ($dataPt, $pos) = @_;
5224 0         0 return int((Get16u($dataPt, $pos) / 0x100) * 1000 + 0.5) / 1000;
5225             }
5226             sub GetFixed32s($$)
5227             {
5228 1754     1754 0 2408 my ($dataPt, $pos) = @_;
5229 1754         2362 my $val = Get32s($dataPt, $pos) / 0x10000;
5230             # remove insignificant digits
5231 1754 100       4191 return int($val * 1e5 + ($val>0 ? 0.5 : -0.5)) / 1e5;
5232             }
5233             sub GetFixed32u($$)
5234             {
5235 156     156 0 290 my ($dataPt, $pos) = @_;
5236             # remove insignificant digits
5237 156         264 return int((Get32u($dataPt, $pos) / 0x10000) * 1e5 + 0.5) / 1e5;
5238             }
5239             # Inputs: 0) value, 1) data ref, 2) offset
5240 5     5 0 14 sub Set8s(@) { return DoPackStd('c', @_); }
5241 275     275 0 474 sub Set8u(@) { return DoPackStd('C', @_); }
5242 12834     12834 0 18359 sub Set16u(@) { return DoPackStd('S', @_); }
5243 18769     18769 0 26769 sub Set32u(@) { return DoPackStd('L', @_); }
5244 0     0 0 0 sub Set16uRev(@) { return DoPackRev('S', @_); }
5245              
5246             #------------------------------------------------------------------------------
5247             # Get current byte order ('II' or 'MM')
5248 13928     13928 0 30947 sub GetByteOrder() { return $currentByteOrder; }
5249              
5250             #------------------------------------------------------------------------------
5251             # Set byte ordering
5252             # Inputs: 0) 'MM'=motorola, 'II'=intel (will translate 'BigEndian', 'LittleEndian')
5253             # Returns: 1 on success
5254             sub SetByteOrder($)
5255             {
5256 15068     15068 0 23319 my $order = shift;
5257              
5258 15068 100       30210 if ($order eq 'MM') { # big endian (Motorola)
    100          
    100          
    100          
5259 7816         29432 %unpackStd = %unpackMotorola;
5260             } elsif ($order eq 'II') { # little endian (Intel)
5261 7061         28422 %unpackStd = %unpackIntel;
5262             } elsif ($order =~ /^Big/i) {
5263 15         31 $order = 'MM';
5264 15         93 %unpackStd = %unpackMotorola;
5265             } elsif ($order =~ /^Little/i) {
5266 11         22 $order = 'II';
5267 11         70 %unpackStd = %unpackIntel;
5268             } else {
5269 165         519 return 0;
5270             }
5271 14903         32027 my $val = unpack('S','A ');
5272 14903         18399 my $nativeOrder;
5273 14903 50       29754 if ($val == 0x4120) { # big endian
    50          
5274 0         0 $nativeOrder = 'MM';
5275             } elsif ($val == 0x2041) { # little endian
5276 14903         19402 $nativeOrder = 'II';
5277             } else {
5278 0         0 warn sprintf("Unknown native byte order! (pattern %x)\n",$val);
5279 0         0 return 0;
5280             }
5281 14903         18740 $currentByteOrder = $order; # save current byte order
5282              
5283             # swap bytes if our native CPU byte ordering is not the same as the EXIF
5284 14903         21275 $swapBytes = ($order ne $nativeOrder);
5285              
5286             # little-endian ARM has big-endian words for doubles (thanks Riku Voipio)
5287             # (Note: Riku's patch checked for '0ff3', but I think it should be 'f03f' since
5288             # 1 is '000000000000f03f' on an x86 -- so check for both, but which is correct?)
5289 14903         18487 my $pack1d = pack('d', 1);
5290 14903   33     39528 $swapWords = ($pack1d eq "\0\0\x0f\xf3\0\0\0\0" or
5291             $pack1d eq "\0\0\xf0\x3f\0\0\0\0");
5292 14903         26065 return 1;
5293             }
5294              
5295             #------------------------------------------------------------------------------
5296             # Change byte order
5297             sub ToggleByteOrder()
5298             {
5299 39 100   39 0 123 SetByteOrder(GetByteOrder() eq 'II' ? 'MM' : 'II');
5300             }
5301              
5302             #------------------------------------------------------------------------------
5303             # hash lookups for reading values from data
5304             my %formatSize = (
5305             int8s => 1,
5306             int8u => 1,
5307             int16s => 2,
5308             int16u => 2,
5309             int16uRev => 2,
5310             int32s => 4,
5311             int32u => 4,
5312             int32uRev => 4,
5313             int64s => 8,
5314             int64u => 8,
5315             rational32s => 4,
5316             rational32u => 4,
5317             rational64s => 8,
5318             rational64u => 8,
5319             fixed16s => 2,
5320             fixed16u => 2,
5321             fixed32s => 4,
5322             fixed32u => 4,
5323             fixed64s => 8,
5324             float => 4,
5325             double => 8,
5326             extended => 10,
5327             unicode => 2,
5328             complex => 8,
5329             string => 1,
5330             binary => 1,
5331             'undef' => 1,
5332             ifd => 4,
5333             ifd64 => 8,
5334             ue7 => 1,
5335             );
5336             my %readValueProc = (
5337             int8s => \&Get8s,
5338             int8u => \&Get8u,
5339             int16s => \&Get16s,
5340             int16u => \&Get16u,
5341             int16uRev => \&Get16uRev,
5342             int32s => \&Get32s,
5343             int32u => \&Get32u,
5344             int32uRev => \&Get32uRev,
5345             int64s => \&Get64s,
5346             int64u => \&Get64u,
5347             rational32s => \&GetRational32s,
5348             rational32u => \&GetRational32u,
5349             rational64s => \&GetRational64s,
5350             rational64u => \&GetRational64u,
5351             fixed16s => \&GetFixed16s,
5352             fixed16u => \&GetFixed16u,
5353             fixed32s => \&GetFixed32s,
5354             fixed32u => \&GetFixed32u,
5355             fixed64s => \&GetFixed64s,
5356             float => \&GetFloat,
5357             double => \&GetDouble,
5358             extended => \&GetExtended,
5359             ifd => \&Get32u,
5360             ifd64 => \&Get64u,
5361             );
5362             # lookup for all rational types
5363             my %isRational = (
5364             rational32u => 1,
5365             rational32s => 1,
5366             rational64u => 1,
5367             rational64s => 1,
5368             );
5369 1515     1515 0 3561 sub FormatSize($) { return $formatSize{$_[0]}; }
5370              
5371             #------------------------------------------------------------------------------
5372             # Read value from binary data (with current byte ordering)
5373             # Inputs: 0) data reference, 1) value offset, 2) format string,
5374             # 3) number of values (or undef to use all data),
5375             # 4) valid data length relative to offset (or undef to use all data),
5376             # 5) optional pointer to returned rational
5377             # Returns: converted value, or undefined if data isn't there
5378             # or list of values in list context
5379             sub ReadValue($$$;$$$)
5380             {
5381 35324     35324 0 64664 my ($dataPt, $offset, $format, $count, $size, $ratPt) = @_;
5382              
5383 35324         53088 my $len = $formatSize{$format};
5384 35324 50       56734 unless ($len) {
5385 0         0 warn "Unknown format $format";
5386 0         0 $len = 1;
5387             }
5388 35324 50       52963 $size = length($$dataPt) - $offset unless defined $size;
5389 35324 100       50646 unless ($count) {
5390 1358 100 100     4431 return '' if defined $count or $size < $len;
5391 1329         2393 $count = int($size / $len);
5392             }
5393             # make sure entry is inside data
5394 35295 100       58248 if ($len * $count > $size) {
5395 3         9 $count = int($size / $len); # shorten count if necessary
5396 3 50       15 $count < 1 and return undef; # return undefined if no data
5397             }
5398 35292         40592 my @vals;
5399 35292         48173 my $proc = $readValueProc{$format};
5400 35292 100 100     86213 if (not $proc) {
    100          
5401             # handle undef/binary/string (also unsupported unicode/complex)
5402 6150         16159 $vals[0] = substr($$dataPt, $offset, $count * $len);
5403             # truncate string at null terminator if necessary
5404 6150 100       23935 $vals[0] =~ s/\0.*//s if $format eq 'string';
5405             } elsif ($isRational{$format} and $ratPt) {
5406             # store rationals separately as string fractions
5407 2988         3719 my @rat;
5408 2988         3652 for (;;) {
5409 3287         7160 push @vals, &$proc($dataPt, $offset);
5410 3287         8089 push @rat, "$ratNumer/$ratDenom";
5411 3287 100       6872 last if --$count <= 0;
5412 299         397 $offset += $len;
5413             }
5414 2988         6868 $$ratPt = join(' ',@rat);
5415             } else {
5416 26154         30404 for (;;) {
5417 48343         71242 push @vals, &$proc($dataPt, $offset);
5418 48343 100       83713 last if --$count <= 0;
5419 22189         24600 $offset += $len;
5420             }
5421             }
5422 35292 100       58100 return @vals if wantarray;
5423 34880 100       73752 return join(' ', @vals) if @vals > 1;
5424 31324         62538 return $vals[0];
5425             }
5426              
5427             #------------------------------------------------------------------------------
5428             # Decode string with specified encoding
5429             # Inputs: 0) ExifTool object ref, 1) string to decode
5430             # 2) source character set name (undef for current Charset)
5431             # 3) optional source byte order (2-byte and 4-byte fixed-width sets only)
5432             # 4) optional destination character set (defaults to Charset setting)
5433             # 5) optional destination byte order (2-byte and 4-byte fixed-width only)
5434             # Returns: string in destination encoding
5435             # Note: ExifTool ref may be undef if character both character sets are provided
5436             # (but in this case no warnings will be issued)
5437             sub Decode($$$;$$$)
5438             {
5439 6158     6158 0 11534 my ($self, $val, $from, $fromOrder, $to, $toOrder) = @_;
5440 6158 100       10384 $from or $from = $$self{OPTIONS}{Charset};
5441 6158 100       12869 $to or $to = $$self{OPTIONS}{Charset};
5442 6158 100 100     13519 if ($from ne $to and length $val) {
5443 1089         22720 require Image::ExifTool::Charset;
5444 1089         1932 my $cs1 = $Image::ExifTool::Charset::csType{$from};
5445 1089         1468 my $cs2 = $Image::ExifTool::Charset::csType{$to};
5446 1089 50 33     4580 if ($cs1 and $cs2 and not $cs2 & 0x002) {
    0 33        
5447             # treat as straight ASCII if no character will need remapping
5448 1089 100 100     3291 if (($cs1 | $cs2) & 0x680 or $val =~ /[\x80-\xff]/) {
5449 776         1981 my $uni = Image::ExifTool::Charset::Decompose($self, $val, $from, $fromOrder);
5450 776         1723 $val = Image::ExifTool::Charset::Recompose($self, $uni, $to, $toOrder);
5451             }
5452             } elsif ($self) {
5453 0 0       0 my $set = $cs1 ? $to : $from;
5454 0 0       0 unless ($$self{"DecodeWarn$set"}) {
5455 0         0 $self->Warn("Unsupported character set ($set)");
5456 0         0 $$self{"DecodeWarn$set"} = 1;
5457             }
5458             }
5459             }
5460 6158         13299 return $val;
5461             }
5462              
5463             #------------------------------------------------------------------------------
5464             # Encode string with specified encoding
5465             # Inputs: 0) ExifTool object ref, 1) string, 2) destination character set name,
5466             # 3) optional destination byte order (2-byte and 4-byte fixed-width sets only)
5467             # Returns: string in specified encoding
5468             sub Encode($$$;$)
5469             {
5470 59     59 0 161 my ($self, $val, $to, $toOrder) = @_;
5471 59         198 return $self->Decode($val, undef, undef, $to, $toOrder);
5472             }
5473              
5474             #------------------------------------------------------------------------------
5475             # Decode bit mask
5476             # Inputs: 0) value to decode, 1) Reference to hash for decoding (or undef)
5477             # 2) optional bits per word (defaults to 32)
5478             sub DecodeBits($$;$)
5479             {
5480 169     169 0 639 my ($vals, $lookup, $bits) = @_;
5481 169 100       495 $bits or $bits = 32;
5482 169         295 my ($val, $i, @bitList);
5483 169         282 my $num = 0;
5484 169         534 foreach $val (split ' ', $vals) {
5485 237         639 for ($i=0; $i<$bits; ++$i) {
5486 5888 100       10200 next unless $val & (1 << $i);
5487 134         221 my $n = $i + $num;
5488 134 100       408 if (not $lookup) {
    100          
5489 19         54 push @bitList, $n;
5490             } elsif ($$lookup{$n}) {
5491 109         273 push @bitList, $$lookup{$n};
5492             } else {
5493 6         18 push @bitList, "[$n]";
5494             }
5495             }
5496 237         558 $num += $bits;
5497             }
5498 169 100       664 return '(none)' unless @bitList;
5499 93 100       614 return join($lookup ? ', ' : ',', @bitList);
5500             }
5501              
5502             #------------------------------------------------------------------------------
5503             # Validate an extracted image and repair if necessary
5504             # Inputs: 0) ExifTool object reference, 1) image reference, 2) tag name or key
5505             # Returns: image reference or undef if it wasn't valid
5506             # Note: should be called from RawConv, not ValueConv
5507             sub ValidateImage($$$)
5508             {
5509 199     199 0 644 my ($self, $imagePt, $tag) = @_;
5510 199 50       616 return undef if $$imagePt eq 'none';
5511 199 100 66     1623 unless ($$imagePt =~ /^(Binary data|\xff\xd8\xff)/ or
      100        
5512             # the first byte of the preview of some Minolta cameras is wrong,
5513             # so check for this and set it back to 0xff if necessary
5514             $$imagePt =~ s/^.(\xd8\xff\xdb)/\xff$1/s or
5515             $self->Options('IgnoreMinorErrors'))
5516             {
5517             # issue warning only if the tag was specifically requested
5518 113 50       485 if ($$self{REQ_TAG_LOOKUP}{lc GetTagName($tag)}) {
5519 0         0 $self->Warn("$tag is not a valid JPEG image",1);
5520 0         0 return undef;
5521             }
5522             }
5523 199         1828 return $imagePt;
5524             }
5525              
5526             #------------------------------------------------------------------------------
5527             # Validate a tag name argument (including group name and wildcards, etc)
5528             # Inputs: 0) tag name
5529             # Returns: true if tag name is valid
5530             # - a tag name may contain [-_A-Za-z0-9], but may not start with [-0-9]
5531             # - tag names may contain wildcards [?*], and end with a hash [#]
5532             # - may have group name prefixes (which may have family number prefix), separated by colons
5533             # - a group name may be zero or more characters
5534             sub ValidTagName($)
5535             {
5536 41     41 0 71 my $tag = shift;
5537 41         288 return $tag =~ /^(([-\w]*|\d*\*):)*[_a-zA-Z?*][-\w?*]*#?$/;
5538             }
5539              
5540             #------------------------------------------------------------------------------
5541             # Generate a valid tag name based on the tag ID or name
5542             # Inputs: 0) tag ID or name
5543             # Returns: valid tag name
5544             sub MakeTagName($)
5545             {
5546 33611     33611 0 37665 my $name = shift;
5547 33611         49163 $name =~ tr/-_a-zA-Z0-9//dc; # remove illegal characters
5548 33611         44630 $name = ucfirst $name; # capitalize first letter
5549 33611 50       48910 $name = "Tag$name" if length($name) < 2; # must at least 2 characters long
5550 33611         51552 return $name;
5551             }
5552              
5553             #------------------------------------------------------------------------------
5554             # Make description from a tag name
5555             # Inputs: 0) tag name 1) optional tagID to add at end of description
5556             # Returns: description
5557             sub MakeDescription($;$)
5558             {
5559 10175     10175 0 15419 my ($tag, $tagID) = @_;
5560             # start with the tag name and force first letter to be upper case
5561 10175         15812 my $desc = ucfirst($tag);
5562             # translate underlines to spaces
5563 10175         14235 $desc =~ tr/_/ /;
5564             # remove hex TagID from name (to avoid inserting spaces in the number)
5565 10175 100 66     24906 $desc =~ s/ (0x[\da-f]+)$//i and $tagID = $1 unless defined $tagID;
5566             # put a space between lower/UPPER case and lower/number combinations
5567 10175         50488 $desc =~ s/([a-z])([A-Z\d])/$1 $2/g;
5568             # put a space between acronyms and words
5569 10175         22307 $desc =~ s/([A-Z])([A-Z][a-z])/$1 $2/g;
5570             # put spaces after numbers (if more than one character follows the number)
5571 10175         13919 $desc =~ s/(\d)([A-Z]\S)/$1 $2/g;
5572             # add TagID to description
5573 10175 100       16182 $desc .= ' ' . $tagID if defined $tagID;
5574 10175         21827 return $desc;
5575             }
5576              
5577             #------------------------------------------------------------------------------
5578             # Get descriptions for all tags in an array
5579             # Inputs: 0) ExifTool ref, 1) reference to list of tag keys
5580             # Returns: reference to hash lookup for descriptions
5581             # Note: Returned descriptions are NOT escaped by ESCAPE_PROC
5582             sub GetDescriptions($$)
5583             {
5584 0     0 0 0 local $_;
5585 0         0 my ($self, $tags) = @_;
5586 0         0 my %desc;
5587 0         0 my $oldEscape = $$self{ESCAPE_PROC};
5588 0         0 delete $$self{ESCAPE_PROC};
5589 0         0 $desc{$_} = $self->GetDescription($_) foreach @$tags;
5590 0         0 $$self{ESCAPE_PROC} = $oldEscape;
5591 0         0 return \%desc;
5592             }
5593              
5594             #------------------------------------------------------------------------------
5595             # Apply filter to value(s) if necessary
5596             # Inputs: 0) ExifTool ref, 1) filter expression, 2) reference to value to filter
5597             # Returns: true unless a filter returned undef; changes value if necessary
5598             sub Filter($$$)
5599             {
5600 12951     12951 1 16547 local $_;
5601 12951         23838 my ($self, $filter, $valPt) = @_;
5602 12951 100 66     35540 return 1 unless defined $filter and defined $$valPt;
5603 463         576 my $rtnVal;
5604 463 100       820 if (not ref $$valPt) {
    100          
    50          
    0          
5605 447         649 $_ = $$valPt;
5606             #### eval Filter ($_, $self)
5607 447         19523 eval $filter;
5608 447 50       1370 if (defined $_) {
5609 447         721 $$valPt = $_;
5610 447         615 $rtnVal = 1;
5611             }
5612             } elsif (ref $$valPt eq 'SCALAR') {
5613 12         22 my $val = $$$valPt; # make a copy to avoid filtering twice
5614 12         32 $rtnVal = $self->Filter($filter, \$val);
5615 12         30 $$valPt = \$val;
5616             } elsif (ref $$valPt eq 'ARRAY') {
5617 4         7 my @val = @{$$valPt}; # make a copy to avoid filtering twice
  4         15  
5618 4   50     15 $self->Filter($filter, \$_) and $rtnVal = 1 foreach @val;
5619 4         10 $$valPt = \@val;
5620             } elsif (ref $$valPt eq 'HASH') {
5621 0         0 my %val = %{$$valPt}; # make a copy to avoid filtering twice
  0         0  
5622 0   0     0 $self->Filter($filter, \$val{$_}) and $rtnVal = 1 foreach keys %val;
5623 0         0 $$valPt = \%val;
5624             } else {
5625 0         0 $rtnVal = 1;
5626             }
5627 463         666 return $rtnVal;
5628             }
5629              
5630             #------------------------------------------------------------------------------
5631             # Return printable value
5632             # Inputs: 0) ExifTool object reference
5633             # 1) value to print, 2) line length limit (undef defaults to 60, 0=unlimited)
5634             sub Printable($;$)
5635             {
5636 593     593 0 910 my ($self, $outStr, $maxLen) = @_;
5637 593 50       997 return '(undef)' unless defined $outStr;
5638 593         1018 $outStr =~ tr/\x01-\x1f\x7f-\xff/./;
5639 593         1346 $outStr =~ s/\x00//g;
5640 593         861 my $verbose = $$self{OPTIONS}{Verbose};
5641 593 50       962 if ($verbose < 4) {
5642 593 100       852 if ($maxLen) {
    50          
5643 592 50       973 $maxLen = 20 if $maxLen < 20; # minimum length is 20
5644             } elsif (defined $maxLen) {
5645 1         3 $maxLen = length $outStr; # 0 is unlimited
5646             } else {
5647 0         0 $maxLen = 60; # default maximum is 60
5648             }
5649             } else {
5650 0         0 $maxLen = length $outStr;
5651             # limit to 2048 characters if verbose < 5
5652 0 0 0     0 $maxLen = 2048 if $maxLen > 2048 and $verbose < 5;
5653             }
5654              
5655             # limit length if necessary
5656 593 100       985 $outStr = substr($outStr,0,$maxLen-6) . '[snip]' if length($outStr) > $maxLen;
5657 593         1436 return $outStr;
5658             }
5659              
5660             #------------------------------------------------------------------------------
5661             # Convert date/time from Exif format
5662             # Inputs: 0) ExifTool object reference, 1) Date/time in EXIF format
5663             # Returns: Formatted date/time string
5664             sub ConvertDateTime($$)
5665             {
5666 1767     1767 0 3960 my ($self, $date) = @_;
5667 1767         3649 my $fmt = $$self{OPTIONS}{DateFormat};
5668 1767         2732 my $shift = $$self{OPTIONS}{GlobalTimeShift};
5669 1767 100       3928 if ($shift) {
5670 8 50 33     59 my $dir = ($shift =~ s/^([-+])// and $1 eq '-') ? -1 : 1;
5671 8         18 my $offset = $$self{GLOBAL_TIME_OFFSET};
5672 8 100       17 $offset or $offset = $$self{GLOBAL_TIME_OFFSET} = { };
5673 8         27 ShiftTime($date, $shift, $dir, $offset);
5674             }
5675             # only convert date if a format was specified and the date is recognizable
5676 1767 100       3369 if ($fmt) {
5677             # separate time zone if it exists
5678 5         9 my $tz;
5679 5 100       28 $date =~ s/([-+]\d{2}:\d{2}|Z)$// and $tz = $1;
5680             # a few cameras use incorrect date/time formatting:
5681             # - slashes instead of colons in date (RolleiD330, ImpressCam)
5682             # - date/time values separated by colon instead of space (Polariod, Sanyo, Sharp, Vivitar)
5683             # - single-digit seconds with leading space (HP scanners)
5684 5         30 my @a = reverse ($date =~ /\d+/g); # be very flexible about date/time format
5685 5 50 33     39 if (@a and $a[-1] >= 1000 and $a[-1] < 3000 and eval { require POSIX }) {
  5 0 33     28  
      33        
5686 5         13 shift @a while @a > 6; # remove superfluous entries
5687 5         13 unshift @a, 1 while @a < 3; # add month and day if necessary
5688 5         11 unshift @a, 0 while @a < 6; # add h,m,s if necessary
5689 5         10 $a[4] -= 1; # base month is 1
5690             # parse our %f fractional seconds first (and round up seconds if necessary)
5691             # - if there are multiple %f codes, they all get the same number of digits as the first
5692 5 50       22 if ($fmt =~ /%\.?(\d*)f/) {
5693 0         0 my $dig = $1;
5694 0 0       0 my $frac = $date =~ /(\.\d+)/ ? $1 : '';
5695 0 0       0 if (not $frac) {
    0          
5696 0 0       0 $frac = '.' . ('0' x $dig) if $dig;
5697             } elsif (length $dig) {
5698 0 0       0 if ($dig+1 > length($frac)) {
    0          
5699 0         0 $frac .= '0' x ($dig+1-length($frac));
5700             } elsif ($dig+1 < length($frac)) {
5701 0         0 $frac = sprintf("%.${dig}f", $frac);
5702 0   0     0 while ($frac =~ s/^(\d)// and $1 ne '0') {
5703             # this is a pain, but we must round up to the next second
5704 0 0       0 ++$a[0] < 60 and last;
5705 0         0 $a[0] = 0;
5706 0 0       0 ++$a[1] < 60 and last;
5707 0         0 $a[1] = 0;
5708 0 0       0 ++$a[2] < 24 and last;
5709 0         0 $a[2] = 0;
5710 0         0 require 'Image/ExifTool/Shift.pl';
5711 0 0       0 ++$a[3] <= DaysInMonth($a[4]+1, $a[5]) and last;
5712 0         0 $a[3] = 1;
5713 0 0       0 ++$a[4] < 12 and last;
5714 0         0 $a[4] = 0;
5715 0         0 ++$a[5];
5716 0         0 last; # (this was a goto)
5717             }
5718             }
5719             }
5720 0         0 $fmt =~ s/(^|[^%])((%%)*)%\.?\d*f/$1$2$frac/g;
5721             }
5722             # parse %z and %s ourself (to handle time zones properly)
5723 5 50       16 if ($fmt =~ /%[sz]/) {
5724             # use system time zone unless otherwise specified
5725 0 0 0     0 $tz = TimeZoneString(\@a, TimeLocal(@a)) if not $tz and eval { require Time::Local };
  0         0  
5726             # remove colon, setting to UTC if time zone is not numeric
5727 0 0 0     0 $tz = ($tz and $tz=~/^([-+]\d{2}):(\d{2})$/) ? "$1$2" : '+0000';
5728 0         0 $fmt =~ s/(^|[^%])((%%)*)%z/$1$2$tz/g; # convert '%z' format codes
5729 0 0 0     0 if ($fmt =~ /%s/ and eval { require Time::Local }) {
  0         0  
5730             # calculate seconds since the Epoch, UTC
5731 0         0 my $s = Time::Local::timegm(@a) - 60 * ($tz - int($tz/100) * 40);
5732 0         0 $fmt =~ s/(^|[^%])((%%)*)%s/$1$2$s/g; # convert '%s' format codes
5733             }
5734             }
5735 5         7 $a[5] -= 1900; # strftime year starts from 1900
5736 5         170 $date = POSIX::strftime($fmt, @a); # generate the formatted date/time
5737             } elsif ($$self{OPTIONS}{StrictDate}) {
5738 0         0 undef $date;
5739             }
5740             }
5741 1767         9361 return $date;
5742             }
5743              
5744             #------------------------------------------------------------------------------
5745             # Print conversion for time span value
5746             # Inputs: 0) time ticks, 1) number of seconds per tick (default 1)
5747             # Returns: readable time
5748             sub ConvertTimeSpan($;$)
5749             {
5750 3     3 0 10 my ($val, $mult) = @_;
5751 3 50 33     39 if (Image::ExifTool::IsFloat($val) and $val != 0) {
5752 3 100       10 $val *= $mult if $mult;
5753 3 50       13 if ($val < 60) {
    50          
    0          
5754 0         0 $val = "$val seconds";
5755             } elsif ($val < 3600) {
5756 3 100 66     15 my $fmt = ($mult and $mult >= 60) ? '%d' : '%.1f';
5757 3 100 66     13 my $s = ($val == 60 and $mult) ? '' : 's';
5758 3         24 $val = sprintf("$fmt minute$s", $val / 60);
5759             } elsif ($val < 24 * 3600) {
5760 0         0 $val = sprintf("%.1f hours", $val / 3600);
5761             } else {
5762 0         0 $val = sprintf("%.1f days", $val / (24 * 3600));
5763             }
5764             }
5765 3         21 return $val;
5766             }
5767              
5768             #------------------------------------------------------------------------------
5769             # Patched timelocal() that fixes ActivePerl timezone bug
5770             # Inputs/Returns: same as timelocal()
5771             # Notes: must 'require Time::Local' before calling this routine
5772             sub TimeLocal(@)
5773             {
5774 36     36 0 1328 my $tm = Time::Local::timelocal(@_);
5775 36 50       2348 if ($^O eq 'MSWin32') {
5776             # patch for ActivePerl timezone bug
5777 0         0 my @t2 = localtime($tm);
5778 0         0 my $t2 = Time::Local::timelocal(@t2);
5779             # adjust timelocal() return value to be consistent with localtime()
5780 0         0 $tm += $tm - $t2;
5781             }
5782 36         98 return $tm;
5783             }
5784              
5785             #------------------------------------------------------------------------------
5786             # Get time zone in minutes
5787             # Inputs: 0) localtime array ref, 1) gmtime array ref
5788             # Returns: time zone offset in minutes
5789             sub GetTimeZone($$)
5790             {
5791 918     918 0 3083 my ($tm, $gm) = @_;
5792             # compute the number of minutes between localtime and gmtime
5793 918         2906 my $min = $$tm[2] * 60 + $$tm[1] - ($$gm[2] * 60 + $$gm[1]);
5794 918 50       2114 if ($$tm[3] != $$gm[3]) {
5795             # account for case where one date wraps to the first of the next month
5796 0 0       0 $$gm[3] = $$tm[3] - ($$tm[3]==1 ? 1 : -1) if abs($$tm[3]-$$gm[3]) != 1;
    0          
5797             # adjust for the +/- one day difference
5798 0         0 $min += ($$tm[3] - $$gm[3]) * 24 * 60;
5799             }
5800             # MirBSD patch to round to the nearest 30 minutes because
5801             # it includes leap seconds in localtime but not gmtime
5802 918 0       3075 $min = int($min / 30 + ($min > 0 ? 0.5 : -0.5)) * 30 if $^O eq 'mirbsd';
    50          
5803 918         2290 return $min;
5804             }
5805              
5806             #------------------------------------------------------------------------------
5807             # Get time zone string
5808             # Inputs: 0) time zone offset in minutes
5809             # or 0) localtime array ref, 1) corresponding time value
5810             # Returns: time zone string ("+/-HH:MM")
5811             sub TimeZoneString($;$)
5812             {
5813 959     959 0 1843 my $min = shift;
5814 959 100       2721 if (ref $min) {
5815 918         4400 my @gm = gmtime(shift);
5816 918         2490 $min = GetTimeZone($min, \@gm);
5817             }
5818 959         2150 my $sign = '+';
5819 959 100       2302 $min < 0 and $sign = '-', $min = -$min;
5820 959         2230 $min = int($min + 0.5); # round off to nearest minute
5821 959         1813 my $h = int($min / 60);
5822 959         4813 return sprintf('%s%.2d:%.2d', $sign, $h, $min - $h * 60);
5823             }
5824              
5825             #------------------------------------------------------------------------------
5826             # Convert Unix time to EXIF date/time string
5827             # Inputs: 0) Unix time value, 1) non-zero to convert to local time,
5828             # 2) number of digits after the decimal for fractional seconds
5829             # Returns: EXIF date/time string (with timezone for local times)
5830             sub ConvertUnixTime($;$$)
5831             {
5832 1024     1024 0 2544 my ($time, $toLocal, $dec) = @_;
5833 1024 100       2402 return '0000:00:00 00:00:00' if $time == 0;
5834 1023         1621 my (@tm, $tz);
5835 1023 50       1954 if ($dec) {
5836 0         0 my $frac = $time - int($time);
5837 0         0 $time = int($time);
5838 0 0       0 $frac < 0 and $frac += 1, $time -= 1;
5839 0         0 $dec = sprintf('%.*f', $dec, $frac);
5840             # remove number before decimal and increment integer time if it was rounded up
5841 0 0 0     0 $dec =~ s/^(\d)// and $1 eq '1' and $time += 1;
5842             } else {
5843 1023 100       2293 $time = int($time + 1e-6) if $time != int($time); # avoid round-off errors
5844 1023         1572 $dec = '';
5845             }
5846 1023 100       2235 if ($toLocal) {
5847 859         26004 @tm = localtime($time);
5848 859         3539 $tz = TimeZoneString(\@tm, $time);
5849             } else {
5850 164         893 @tm = gmtime($time);
5851 164         279 $tz = '';
5852             }
5853 1023         6212 my $str = sprintf("%4d:%.2d:%.2d %.2d:%.2d:%.2d$dec%s",
5854             $tm[5]+1900, $tm[4]+1, $tm[3], $tm[2], $tm[1], $tm[0], $tz);
5855 1023         7402 return $str;
5856             }
5857              
5858             #------------------------------------------------------------------------------
5859             # Get Unix time from EXIF-formatted date/time string with optional timezone
5860             # Inputs: 0) EXIF date/time string, 1) non-zero if time is local, or 2 to assume UTC
5861             # Returns: Unix time (seconds since 0:00 GMT Jan 1, 1970) or undefined on error
5862             sub GetUnixTime($;$)
5863             {
5864 162     162 0 28343 my ($timeStr, $isLocal) = @_;
5865 162 50       409 return 0 if $timeStr eq '0000:00:00 00:00:00';
5866 162         844 my @tm = ($timeStr =~ /^(\d+):(\d+):(\d+)\s+(\d+):(\d+):(\d+)(.*)/);
5867 162 50       507 return undef unless @tm == 7;
5868 162 50       255 unless (eval { require Time::Local }) {
  162         4607  
5869 0         0 warn "Time::Local is not installed\n";
5870 0         0 return undef;
5871             }
5872 162         16187 my ($tzStr, $tzSec) = (pop(@tm), 0);
5873             # use specified timezone offset (if given) instead of local system time
5874             # if we are converting a local time value
5875 162 100       343 if ($isLocal) {
5876 113 50       348 if ($tzStr =~ /(?:Z|([-+])(\d+):(\d+))/i) {
    0          
5877             # use specified timezone if one exists
5878 113 100       435 $tzSec = ($2 * 60 + $3) * ($1 eq '-' ? -60 : 60) if $1;
    100          
5879 113         166 undef $isLocal; # convert using GMT corrected for specified timezone
5880             } elsif ($isLocal eq '2') {
5881 0         0 undef $isLocal;
5882             }
5883             }
5884 162         306 $tm[1] -= 1; # convert month
5885 162         250 @tm = reverse @tm; # change to order required by timelocal()
5886 162 50       548 my $val = $isLocal ? TimeLocal(@tm) : Time::Local::timegm(@tm) - $tzSec;
5887             # handle fractional seconds
5888 160 100 100     4498 $val += $1 if $tzStr and $tzStr =~ /^(\.\d+)/;
5889 160         1065 return $val;
5890             }
5891              
5892             #------------------------------------------------------------------------------
5893             # Print conversion for file size
5894             # Inputs: 0) file size in bytes
5895             # Returns: converted file size
5896             sub ConvertFileSize($)
5897             {
5898 295     295 0 666 my $val = shift;
5899 295 100       1134 $val < 2000 and return "$val bytes";
5900 190 100       1519 $val < 10000 and return sprintf('%.1f kB', $val / 1000);
5901 50 100       385 $val < 2000000 and return sprintf('%.0f kB', $val / 1000);
5902 4 100       37 $val < 10000000 and return sprintf('%.1f MB', $val / 1000000);
5903 1 50       10 $val < 2000000000 and return sprintf('%.0f MB', $val / 1000000);
5904 0 0       0 $val < 10000000000 and return sprintf('%.1f GB', $val / 1000000000);
5905 0         0 return sprintf('%.0f GB', $val / 1000000000);
5906             }
5907              
5908             #------------------------------------------------------------------------------
5909             # Convert seconds to duration string (handles negative durations)
5910             # Inputs: 0) floating point seconds
5911             # Returns: duration string in form "S.SS s", "H:MM:SS" or "DD days HH:MM:SS"
5912             sub ConvertDuration($)
5913             {
5914 130     130 0 260 my $time = shift;
5915 130 50       285 return $time unless IsFloat($time);
5916 130 100       633 return '0 s' if $time == 0;
5917 61 50       199 my $sign = ($time > 0 ? '' : (($time = -$time), '-'));
5918 61 100       706 return sprintf("$sign%.2f s", $time) if $time < 30;
5919 4         7 $time += 0.5; # to round off to nearest second
5920 4         12 my $h = int($time / 3600);
5921 4         10 $time -= $h * 3600;
5922 4         8 my $m = int($time / 60);
5923 4         8 $time -= $m * 60;
5924 4 50       21 if ($h > 24) {
5925 0         0 my $d = int($h / 24);
5926 0         0 $h -= $d * 24;
5927 0         0 $sign = "$sign$d days ";
5928             }
5929 4         42 return sprintf("$sign%d:%.2d:%.2d", $h, $m, int($time));
5930             }
5931              
5932             #------------------------------------------------------------------------------
5933             # Print conversion for bitrate values
5934             # Inputs: 0) bitrate in bits per second
5935             # Returns: human-readable bitrate string
5936             # Notes: returns input value without formatting if it isn't numerical
5937             sub ConvertBitrate($)
5938             {
5939 20     20 0 43 my $bitrate = shift;
5940 20 50       58 IsFloat($bitrate) or return $bitrate;
5941 20         74 my @units = ('bps', 'kbps', 'Mbps', 'Gbps');
5942 20         33 for (;;) {
5943 38         58 my $units = shift @units;
5944 38 100 66     144 $bitrate >= 1000 and @units and $bitrate /= 1000, next;
5945 20 100       58 my $fmt = $bitrate < 100 ? '%.3g' : '%.0f';
5946 20         235 return sprintf("$fmt $units", $bitrate);
5947             }
5948             }
5949              
5950             #------------------------------------------------------------------------------
5951             # Convert file name for printing
5952             # Inputs: 0) ExifTool ref, 1) file name in CharsetFileName character set
5953             # Returns: converted file name in external character set
5954             sub ConvertFileName($$)
5955             {
5956 938     938 0 2672 my ($self, $val) = @_;
5957 938         2028 my $enc = $$self{OPTIONS}{CharsetFileName};
5958 938 50       2157 $val = $self->Decode($val, $enc) if $enc;
5959 938         6227 return $val;
5960             }
5961              
5962             #------------------------------------------------------------------------------
5963             # Inverse conversion for file name (encode in CharsetFileName)
5964             # Inputs: 0) ExifTool ref, 1) file name in external character set
5965             # Returns: file name in CharsetFileName character set
5966             sub InverseFileName($$)
5967             {
5968 1     1 0 4 my ($self, $val) = @_;
5969 1         3 my $enc = $$self{OPTIONS}{CharsetFileName};
5970 1 50       5 $val = $self->Encode($val, $enc) if $enc;
5971 1         4 $val =~ tr/\\/\//; # make sure we are using forward slashes
5972 1         7 return $val;
5973             }
5974              
5975             #------------------------------------------------------------------------------
5976             # Save information for HTML dump
5977             # Inputs: 0) ExifTool hash ref, 1) start offset, 2) data size
5978             # 3) comment string, 4) tool tip (or SAME), 5) flags, 6) IFD name
5979             sub HDump($$$$;$$$)
5980             {
5981 0     0 0 0 my $self = shift;
5982 0 0       0 $$self{HTML_DUMP} or return;
5983 0         0 my ($pos, $len, $com, $tip, $flg, $ifd) = @_;
5984 0 0       0 $pos += $$self{BASE} if $$self{BASE};
5985             # skip structural data blocks which have been removed from the middle of this dump
5986             # (SkipData list contains ordered [start,end+1] offsets to skip)
5987 0 0       0 if ($$self{SkipData}) {
5988 0         0 my $end = $pos + $len;
5989 0         0 my $skip;
5990 0         0 foreach $skip (@{$$self{SkipData}}) {
  0         0  
5991 0 0       0 $end <= $$skip[0] and last;
5992 0 0       0 $pos >= $$skip[1] and $pos += $$skip[1] - $$skip[0], next;
5993 0 0       0 if ($pos != $$skip[0]) {
5994 0         0 $$self{HTML_DUMP}->Add($pos, $$skip[0]-$pos, $com, $tip, $flg, $ifd);
5995 0         0 $len -= $$skip[0] - $pos;
5996 0         0 $tip = 'SAME';
5997             }
5998 0         0 $pos = $$skip[1];
5999             }
6000             }
6001 0         0 $$self{HTML_DUMP}->Add($pos, $len, $com, $tip, $flg, $ifd);
6002             }
6003              
6004             #------------------------------------------------------------------------------
6005             # Identify trailer ending at specified offset from end of file
6006             # Inputs: 0) RAF reference, 1) offset from end of file (0 by default)
6007             # Returns: Trailer info hash (with RAF and DirName set),
6008             # or undef if no recognized trailer was found
6009             # Notes: leaves file position unchanged
6010             sub IdentifyTrailer($;$)
6011             {
6012 566     566 0 1219 my $raf = shift;
6013 566   100     1790 my $offset = shift || 0;
6014 566         2025 my $pos = $raf->Tell();
6015 566         1173 my ($buff, $type, $len);
6016 566   33     1952 while ($raf->Seek(-$offset, 2) and ($len = $raf->Tell()) > 0) {
6017             # read up to 64 bytes before specified offset from end of file
6018 566 50       1670 $len = 64 if $len > 64;
6019 566 50 33     1577 $raf->Seek(-$len, 1) and $raf->Read($buff, $len) == $len or last;
6020 566 100 66     9647 if ($buff =~ /AXS(!|\*).{8}$/s) {
    100          
    100          
    100          
    100          
    100          
    50          
    50          
6021 29         68 $type = 'AFCP';
6022             } elsif ($buff =~ /\xa1\xb2\xc3\xd4$/) {
6023 29         78 $type = 'FotoStation';
6024             } elsif ($buff =~ /cbipcbbl$/) {
6025 34         76 $type = 'PhotoMechanic';
6026             } elsif ($buff =~ /^CANON OPTIONAL DATA\0/) {
6027 41         105 $type = 'CanonVRD';
6028             } elsif ($buff =~ /~\0\x04\0zmie~\0\0\x06.{4}[\x10\x18]\x04$/s or
6029             $buff =~ /~\0\x04\0zmie~\0\0\x0a.{8}[\x10\x18]\x08$/s)
6030             {
6031 26         57 $type = 'MIE';
6032             } elsif ($buff =~ /\0\0(QDIOBS|SEFT)$/) {
6033 26         60 $type = 'Samsung';
6034             } elsif ($buff =~ /8db42d694ccc418790edff439fe026bf$/s) {
6035 0         0 $type = 'Insta360';
6036             } elsif ($buff =~ m(\0{6}/NIKON APP$)) {
6037 0         0 $type = 'NikonApp';
6038             }
6039 566         1080 last;
6040             }
6041 566         1828 $raf->Seek($pos, 0); # restore original file position
6042 566 100       2647 return $type ? { RAF => $raf, DirName => $type } : undef;
6043             }
6044              
6045             #------------------------------------------------------------------------------
6046             # Read/rewrite trailer information (including multiple trailers)
6047             # Inputs: 0) ExifTool object ref, 1) DirInfo ref:
6048             # - requires RAF and DirName
6049             # - OutFile is a scalar reference for writing
6050             # - scans from current file position if ScanForAFCP is set
6051             # Returns: 1 if trailer was processed or couldn't be processed (or written OK)
6052             # 0 if trailer was recognized but offsets need fixing (or write error)
6053             # - DirName, DirLen, DataPos, Offset, Fixup and OutFile are updated
6054             # - preserves current file position and byte order
6055             sub ProcessTrailers($$)
6056             {
6057 57     57 0 165 my ($self, $dirInfo) = @_;
6058 57         139 my $dirName = $$dirInfo{DirName};
6059 57         114 my $outfile = $$dirInfo{OutFile};
6060 57   50     260 my $offset = $$dirInfo{Offset} || 0;
6061 57         119 my $fixup = $$dirInfo{Fixup};
6062 57         115 my $raf = $$dirInfo{RAF};
6063 57         170 my $pos = $raf->Tell();
6064 57         183 my $byteOrder = GetByteOrder();
6065 57         123 my $success = 1;
6066 57         113 my $path = $$self{PATH};
6067              
6068 57         125 for (;;) { # loop through all trailers
6069 185         319 my ($proc, $outBuff);
6070 185 50       622 if ($dirName eq 'Insta360') {
    50          
6071 0         0 require 'Image/ExifTool/QuickTimeStream.pl';
6072 0         0 $proc = 'Image::ExifTool::QuickTime::ProcessInsta360';
6073             } elsif ($dirName eq 'NikonApp') {
6074 0         0 require Image::ExifTool::Nikon;
6075 0         0 $proc = 'Image::ExifTool::Nikon::ProcessNikonApp';
6076             } else {
6077 185         14520 require "Image/ExifTool/$dirName.pm";
6078 185         542 $proc = "Image::ExifTool::${dirName}::Process$dirName";
6079             }
6080 185 100       486 if ($outfile) {
6081             # write to local buffer so we can add trailer in proper order later
6082 50 100       147 $$outfile and $$dirInfo{OutFile} = \$outBuff, $outBuff = '';
6083             # must generate new fixup if necessary so we can shift
6084             # the old fixup separately after we prepend this trailer
6085 50         86 delete $$dirInfo{Fixup};
6086             }
6087 185         313 delete $$dirInfo{DirLen}; # reset trailer length
6088 185         373 $$dirInfo{Offset} = $offset; # set offset from end of file
6089 185         319 $$dirInfo{Trailer} = 1; # set Trailer flag in case proc cares
6090             # add trailer and DirName to SubDirectory PATH
6091 185         416 push @$path, 'Trailer', $dirName;
6092              
6093             # read or write this trailer
6094             # (proc takes Offset as positive offset from end of trailer to end of file,
6095             # and returns DataPos and DirLen, and Fixup if applicable, and updates
6096             # OutFile when writing)
6097 104     104   1136 no strict 'refs';
  104         226  
  104         4949  
6098 185         1461 my $result = &$proc($self, $dirInfo);
6099 104     104   593 use strict 'refs';
  104         223  
  104         1119533  
6100              
6101             # restore PATH (pop last 2 items)
6102 185         492 splice @$path, -2;
6103              
6104             # check result
6105 185 100       585 if ($outfile) {
    50          
6106 50 50       108 if ($result > 0) {
6107 50 100       135 if ($outBuff) {
6108             # write trailers to OutFile in original order
6109 33         239 $$outfile = $outBuff . $$outfile;
6110             # must adjust old fixup start if it exists
6111 33 50       101 $$fixup{Start} += length($outBuff) if $fixup;
6112 33         52 $outBuff = ''; # free memory
6113             }
6114 50 100       130 if ($$dirInfo{Fixup}) {
6115 15 100       57 if ($fixup) {
6116             # add fixup for subsequent trailers to the fixup for this trailer
6117             # (but first we must adjust for the new start position)
6118 7         18 $$fixup{Shift} += $$dirInfo{Fixup}{Start};
6119 7         18 $$fixup{Start} -= $$dirInfo{Fixup}{Start};
6120 7         25 $$dirInfo{Fixup}->AddFixup($fixup);
6121             }
6122 15         34 $fixup = $$dirInfo{Fixup}; # save fixup
6123             }
6124             } else {
6125 0 0       0 $success = 0 if $self->Error("Error rewriting $dirName trailer", 2);
6126 0         0 last;
6127             }
6128             } elsif ($result < 0) {
6129             # can't continue if we must scan for this trailer
6130 0         0 $success = 0;
6131 0         0 last;
6132             }
6133 185 50 33     850 last unless $result > 0 and $$dirInfo{DirLen};
6134             # look for next trailer
6135 185         377 $offset += $$dirInfo{DirLen};
6136 185 100       436 my $nextTrail = IdentifyTrailer($raf, $offset) or last;
6137 128         333 $dirName = $$dirInfo{DirName} = $$nextTrail{DirName};
6138 128         344 $raf->Seek($pos, 0);
6139             }
6140 57         235 SetByteOrder($byteOrder); # restore original byte order
6141 57         257 $raf->Seek($pos, 0); # restore original file position
6142 57         210 $$dirInfo{OutFile} = $outfile; # restore original outfile
6143 57         138 $$dirInfo{Offset} = $offset; # return offset from EOF to start of first trailer
6144 57         185 $$dirInfo{Fixup} = $fixup; # return fixup information
6145 57         296 return $success;
6146             }
6147              
6148             #------------------------------------------------------------------------------
6149             # JPEG constants
6150              
6151             # JPEG marker names
6152             %jpegMarker = (
6153             0x00 => 'NULL',
6154             0x01 => 'TEM',
6155             0xc0 => 'SOF0', # to SOF15, with a few exceptions below
6156             0xc4 => 'DHT',
6157             0xc8 => 'JPGA',
6158             0xcc => 'DAC',
6159             0xd0 => 'RST0', # to RST7
6160             0xd8 => 'SOI',
6161             0xd9 => 'EOI',
6162             0xda => 'SOS',
6163             0xdb => 'DQT',
6164             0xdc => 'DNL',
6165             0xdd => 'DRI',
6166             0xde => 'DHP',
6167             0xdf => 'EXP',
6168             0xe0 => 'APP0', # to APP15
6169             0xf0 => 'JPG0',
6170             0xfe => 'COM',
6171             );
6172              
6173             # lookup for size of JPEG marker length word
6174             # (2 bytes assumed unless specified here)
6175             my %markerLenBytes = (
6176             0x00 => 0, 0x01 => 0,
6177             0xd0 => 0, 0xd1 => 0, 0xd2 => 0, 0xd3 => 0, 0xd4 => 0, 0xd5 => 0, 0xd6 => 0, 0xd7 => 0,
6178             0xd8 => 0, 0xd9 => 0, 0xda => 0,
6179             # J2C
6180             0x30 => 0, 0x31 => 0, 0x32 => 0, 0x33 => 0, 0x34 => 0, 0x35 => 0, 0x36 => 0, 0x37 => 0,
6181             0x38 => 0, 0x39 => 0, 0x3a => 0, 0x3b => 0, 0x3c => 0, 0x3d => 0, 0x3e => 0, 0x3f => 0,
6182             0x4f => 0,
6183             0x92 => 0, 0x93 => 0,
6184             # J2C extensions
6185             0x74 => 4, 0x75 => 4, 0x77 => 4,
6186             );
6187              
6188             #------------------------------------------------------------------------------
6189             # Get JPEG marker name
6190             # Inputs: 0) Jpeg number
6191             # Returns: marker name
6192             sub JpegMarkerName($)
6193             {
6194 3055     3055 0 4513 my $marker = shift;
6195 3055         5875 my $markerName = $jpegMarker{$marker};
6196 3055 100       5338 unless ($markerName) {
6197 1157         2769 $markerName = $jpegMarker{$marker & 0xf0};
6198 1157 50 33     7707 if ($markerName and $markerName =~ /^([A-Z]+)\d+$/) {
6199 1157         3682 $markerName = $1 . ($marker & 0x0f);
6200             } else {
6201 0         0 $markerName = sprintf("marker 0x%.2x", $marker);
6202             }
6203             }
6204 3055         5908 return $markerName;
6205             }
6206              
6207             #------------------------------------------------------------------------------
6208             # Adjust directory start position
6209             # Inputs: 0) dirInfo ref, 1) start offset
6210             # 2) Base for offsets (relative to DataPos, defaults to absolute Base of 0)
6211             sub DirStart($$;$)
6212             {
6213 560     560 0 1300 my ($dirInfo, $start, $base) = @_;
6214 560         1006 $$dirInfo{DirStart} = $start;
6215 560         960 $$dirInfo{DirLen} -= $start;
6216 560 100       1437 if (defined $base) {
6217 263         590 $$dirInfo{Base} = $$dirInfo{DataPos} + $base;
6218 263         654 $$dirInfo{DataPos} = -$base; # (relative to Base!)
6219             }
6220             }
6221              
6222             #------------------------------------------------------------------------------
6223             # Extract metadata from a jpg image
6224             # Inputs: 0) ExifTool object reference, 1) dirInfo ref with RAF set
6225             # Returns: 1 on success, 0 if this wasn't a valid JPEG file
6226             sub ProcessJPEG($$)
6227             {
6228 233     233 0 590 local $_;
6229 233         592 my ($self, $dirInfo) = @_;
6230 233         464 my ($ch, $s, $length);
6231 233         539 my $options = $$self{OPTIONS};
6232 233         486 my $verbose = $$options{Verbose};
6233 233         518 my $out = $$options{TextOut};
6234 233   100     1179 my $fast = $$options{FastScan} || 0;
6235 233         493 my $raf = $$dirInfo{RAF};
6236 233         446 my $req = $$self{REQ_TAG_LOOKUP};
6237 233         449 my $htmlDump = $$self{HTML_DUMP};
6238 233         701 my %dumpParms = ( Out => $out );
6239 233         1197 my ($success, $wantTrailer, $trailInfo, $foundSOS, %jumbfChunk);
6240 233         0 my (@iccChunk, $iccChunkCount, $iccChunksTotal, @flirChunk, $flirCount, $flirTotal);
6241 233         0 my ($preview, $scalado, @dqt, $subSampling, $dumpEnd, %extendedXMP);
6242              
6243             # check to be sure this is a valid JPG (or J2C, or EXV) file
6244 233 50 33     855 return 0 unless $raf->Read($s, 2) == 2 and $s =~ /^\xff[\xd8\x4f\x01]/;
6245 233 100       876 if ($s eq "\xff\x01") {
6246 2 50 33     10 return 0 unless $raf->Read($s, 5) == 5 and $s eq 'Exiv2';
6247 2         5 $$self{FILE_TYPE} = 'EXV';
6248             }
6249 233         471 my $appBytes = 0;
6250 233         523 my $calcImageLen = $$req{jpegimagelength};
6251 233 50 66     1021 if ($$options{RequestAll} and $$options{RequestAll} > 2) {
6252 0         0 $calcImageLen = 1;
6253             }
6254 233 100 66     1036 if (not $$self{VALUE}{FileType} or ($$self{DOC_NUM} and $$options{ExtractEmbedded})) {
      66        
6255 225         1112 $self->SetFileType(); # set FileType tag
6256 225 100       986 return 1 if $fast == 3; # don't process file when FastScan == 3
6257 224         735 $$self{LOW_PRIORITY_DIR}{IFD1} = 1; # lower priority of IFD1 tags
6258             }
6259 232 100       744 $$raf{NoBuffer} = 1 if $self->Options('FastScan'); # disable buffering in FastScan mode
6260              
6261 232 50       1056 $dumpParms{MaxLen} = 128 if $verbose < 4;
6262 232 50       660 if ($htmlDump) {
6263 0         0 $dumpEnd = $raf->Tell();
6264 0 0       0 my ($n, $t, $m) = $s eq 'Exiv2' ? (7,'EXV','TEM') : (2,'JPEG','SOI');
6265 0         0 my $pos = $dumpEnd - $n;
6266 0 0       0 $self->HDump(0, $pos, '[unknown header]') if $pos;
6267 0         0 $self->HDump($pos, $n, "$t header", "$m Marker");
6268             }
6269 232         499 my $path = $$self{PATH};
6270 232         507 my $pn = scalar @$path;
6271              
6272             # set input record separator to 0xff (the JPEG marker) to make reading quicker
6273 232         1177 local $/ = "\xff";
6274              
6275 232         642 my ($nextMarker, $nextSegDataPt, $nextSegPos, $combinedSegData, $firstSegPos, @skipData);
6276              
6277             # read file until we reach an end of image (EOI) or start of scan (SOS)
6278 232         387 Marker: for (;;) {
6279             # set marker and data pointer for current segment
6280 2053         3239 my $marker = $nextMarker;
6281 2053         2521 my $segDataPt = $nextSegDataPt;
6282 2053         2566 my $segPos = $nextSegPos;
6283 2053         2454 my $skipped;
6284 2053         2651 undef $nextMarker;
6285 2053         2801 undef $nextSegDataPt;
6286             #
6287             # read ahead to the next segment unless we have reached EOI, SOS or SOD
6288             #
6289 2053 100 100     11961 unless ($marker and ($marker==0xd9 or ($marker==0xda and not $wantTrailer) or $marker==0x93)) {
      100        
6290             # read up to next marker (JPEG markers begin with 0xff)
6291 1820         2452 my $buff;
6292 1820 50       6713 $raf->ReadLine($buff) or last;
6293 1820         3052 $skipped = length($buff) - 1;
6294             # JPEG markers can be padded with unlimited 0xff's
6295 1820         2508 for (;;) {
6296 1820 50       4146 $raf->Read($ch, 1) or last Marker;
6297 1820         3148 $nextMarker = ord($ch);
6298 1820 50       4085 last unless $nextMarker == 0xff;
6299 0         0 ++$skipped;
6300             }
6301             # read segment data if it exists
6302 1820 100       5406 if (not defined $markerLenBytes{$nextMarker}) {
    50          
6303             # read record length word
6304 1587 50       4382 last unless $raf->Read($s, 2) == 2;
6305 1587         4087 my $len = unpack('n',$s); # get data length
6306 1587 50 33     5905 last unless defined($len) and $len >= 2;
6307 1587         3725 $nextSegPos = $raf->Tell();
6308 1587         2408 $len -= 2; # subtract size of length word
6309 1587 50       3114 last unless $raf->Read($buff, $len) == $len;
6310 1587         2697 $nextSegDataPt = \$buff; # set pointer to our next data
6311             } elsif ($markerLenBytes{$nextMarker} == 4) {
6312             # handle J2C extensions with 4-byte length word
6313 0 0       0 last unless $raf->Read($s, 4) == 4;
6314 0         0 my $len = unpack('N',$s); # get data length
6315 0 0 0     0 last unless defined($len) and $len >= 4;
6316 0         0 $nextSegPos = $raf->Tell();
6317 0         0 $len -= 4; # subtract size of length word
6318 0 0       0 last unless $raf->Seek($len, 1);
6319             }
6320             # read second segment too if this was the first
6321 1820 100       4044 next unless defined $marker;
6322             }
6323             # set some useful variables for the current segment
6324 1820         3800 my $markerName = JpegMarkerName($marker);
6325 1820         3368 $$path[$pn] = $markerName;
6326             # issue warning if we skipped some garbage
6327 1820 0 33     4024 if ($skipped and not $foundSOS and $markerName ne 'SOS') {
      33        
6328 0         0 $self->Warn("Skipped unknown $skipped bytes after JPEG $markerName segment", 1);
6329 0 0       0 if ($htmlDump) {
6330 0         0 $self->HDump($nextSegPos-4-$skipped, $skipped, "[unknown $skipped bytes]", undef, 0x08);
6331 0         0 $dumpEnd = $nextSegPos - 4;
6332             }
6333             }
6334             #
6335             # parse the current segment
6336             #
6337             # handle SOF markers: SOF0-SOF15, except DHT(0xc4), JPGA(0xc8) and DAC(0xcc)
6338 1820 100 66     14756 if (($marker & 0xf0) == 0xc0 and ($marker == 0xc0 or $marker & 0x03)) {
    100 100        
    100 66        
    100 33        
    50 66        
    100          
6339 229         424 $length = length $$segDataPt;
6340 229 100       900 if ($verbose) {
    50          
6341 2         8 print $out "JPEG $markerName ($length bytes):\n";
6342 2 100       13 HexDump($segDataPt, undef, %dumpParms, Addr=>$segPos) if $verbose>2;
6343             } elsif ($htmlDump) {
6344 0         0 $self->HDump($segPos-4, $length+4, "[JPEG $markerName]", undef, 0x08);
6345 0         0 $dumpEnd = $segPos + $length;
6346             }
6347 229 50       656 next unless $length >= 6;
6348             # extract some useful information
6349 229         930 my ($p, $h, $w, $n) = unpack('Cn2C', $$segDataPt);
6350 229         784 my $sof = GetTagTable('Image::ExifTool::JPEG::SOF');
6351 229         1090 $self->HandleTag($sof, 'ImageWidth', $w);
6352 229         782 $self->HandleTag($sof, 'ImageHeight', $h);
6353 229         982 $self->HandleTag($sof, 'EncodingProcess', $marker - 0xc0);
6354 229         836 $self->HandleTag($sof, 'BitsPerSample', $p);
6355 229         917 $self->HandleTag($sof, 'ColorComponents', $n);
6356 229 50 33     1408 next unless $n == 3 and $length >= 15;
6357 229         585 my ($i, $hmin, $hmax, $vmin, $vmax);
6358             # loop through all components to determine sampling frequency
6359 229         540 $subSampling = '';
6360 229         900 for ($i=0; $i<$n; ++$i) {
6361 687         1536 my $sf = Get8u($segDataPt, 7 + 3 * $i);
6362 687         2196 $subSampling .= sprintf('%.2x', $sf);
6363             # isolate horizontal and vertical components
6364 687         1356 my ($hf, $vf) = ($sf >> 4, $sf & 0x0f);
6365 687 100       1344 unless ($i) {
6366 229         472 $hmin = $hmax = $hf;
6367 229         411 $vmin = $vmax = $vf;
6368 229         561 next;
6369             }
6370             # determine min/max frequencies
6371 458 100       1064 $hmin = $hf if $hf < $hmin;
6372 458 50       929 $hmax = $hf if $hf > $hmax;
6373 458 100       1016 $vmin = $vf if $vf < $vmin;
6374 458 50       1249 $vmax = $vf if $vf > $vmax;
6375             }
6376 229 50 33     1170 if ($hmin and $vmin) {
6377 229         763 my ($hs, $vs) = ($hmax / $hmin, $vmax / $vmin);
6378 229         2024 $self->HandleTag($sof, 'YCbCrSubSampling', "$hs $vs");
6379             }
6380 229         635 next;
6381             } elsif ($marker == 0xd9) { # EOI
6382 3         10 pop @$path;
6383 3 100       13 $verbose and print $out "JPEG EOI\n";
6384 3         12 my $pos = $raf->Tell();
6385 3 50 33     16 if ($htmlDump and $dumpEnd) {
6386 0         0 $self->HDump($dumpEnd, $pos-2-$dumpEnd, '[JPEG Image Data]', undef, 0x08);
6387 0         0 $self->HDump($pos-2, 2, 'JPEG EOI', undef);
6388 0         0 $dumpEnd = 0;
6389             }
6390 3 50 66     20 if ($foundSOS or $$self{FILE_TYPE} eq 'EXV') {
6391 3         8 $success = 1;
6392             } else {
6393 0         0 $self->Warn('Missing JPEG SOS');
6394             }
6395 3 50       13 if ($$req{trailer}) {
6396             # read entire trailer into memory
6397 0 0       0 if ($raf->Seek(0,2)) {
6398 0         0 my $len = $raf->Tell() - $pos;
6399 0 0       0 if ($len) {
6400 0         0 my $buff;
6401 0         0 $raf->Seek($pos, 0);
6402 0 0       0 $self->FoundTag(Trailer => \$buff) if $raf->Read($buff,$len) == $len;
6403 0         0 $raf->Seek($pos, 0);
6404             }
6405             } else {
6406 0         0 $self->Warn('Error seeking in file');
6407             }
6408             }
6409             # we are here because we are looking for trailer information
6410 3 50       10 if ($wantTrailer) {
6411 0         0 my $start = $$self{PreviewImageStart};
6412 0 0 0     0 if ($start or $$options{ExtractEmbedded}) {
6413 0         0 my $buff;
6414             # most previews start right after the JPEG EOI, but the Olympus E-20
6415             # preview is 508 bytes into the trailer, the K-M Maxxum 7D preview is
6416             # 979 bytes in, and Sony previews can start up to 32 kB into the trailer.
6417             # (and Minolta and Sony previews can have a random first byte...)
6418 0 0       0 my $scanLen = $$self{Make} =~ /Sony/i ? 65536 : 1024;
6419 0 0       0 if ($raf->Read($buff, $scanLen)) {
6420 0 0 0     0 if ($buff =~ /^.{4}ftyp/s) {
    0 0        
6421 0         0 my $val;
6422 0 0       0 if ($raf->Seek(0,2)) {
6423 0         0 my $len = $raf->Tell() - $pos;
6424 0 0       0 if ($$options{Binary}) {
6425 0 0 0     0 $val = \$buff if $raf->Seek($pos,0) and $raf->Read($buff,$len)==$len;
6426             } else {
6427 0         0 $val = \ "Binary data $len bytes";
6428             }
6429 0 0       0 if ($val) {
6430 0         0 $self->FoundTag('EmbeddedVideo', $val);
6431             } else {
6432 0         0 $self->Warn('Error reading trailer');
6433             }
6434             } else {
6435 0         0 $self->Warn('Error seeking to end of file');
6436             }
6437             } elsif ($buff =~ /\xff\xd8\xff./g or
6438             ($$self{Make} =~ /(Minolta|Sony)/i and $buff =~ /.\xd8\xff\xdb/g))
6439             {
6440             # adjust PreviewImageStart to this location
6441 0         0 my $actual = $pos + pos($buff) - 4;
6442 0 0 0     0 if ($start and $start ne $actual and $verbose > 1) {
      0        
6443 0         0 print $out "(Fixed PreviewImage location: $start -> $actual)\n";
6444             }
6445             # update preview image offsets
6446 0 0       0 if ($start) {
6447 0 0       0 $$self{VALUE}{PreviewImageStart} = $actual if $$self{VALUE}{PreviewImageStart};
6448 0         0 $$self{PreviewImageStart} = $actual;
6449             }
6450             # load preview now if we tried and failed earlier
6451 0 0 0     0 if ($$self{PreviewError} and $$self{PreviewImageLength}) {
6452 0 0 0     0 if ($raf->Seek($actual, 0) and $raf->Read($buff, $$self{PreviewImageLength})) {
6453 0         0 $self->FoundTag('PreviewImage', $buff);
6454 0         0 delete $$self{PreviewError};
6455             }
6456             }
6457             }
6458             }
6459 0         0 $raf->Seek($pos, 0);
6460             }
6461             }
6462             # process trailer now or finish processing trailers
6463             # and scan for AFCP if necessary
6464 3         9 my $fromEnd = 0;
6465 3 50       12 if ($trailInfo) {
6466 0         0 $$trailInfo{ScanForAFCP} = 1; # scan now if necessary
6467 0         0 $self->ProcessTrailers($trailInfo);
6468             # save offset from end of file to start of first trailer
6469 0         0 $fromEnd = $$trailInfo{Offset};
6470 0         0 undef $trailInfo;
6471             }
6472 3 50       12 if ($$self{LeicaTrailer}) {
6473 0         0 $raf->Seek(0, 2);
6474 0         0 $$self{LeicaTrailer}{TrailPos} = $pos;
6475 0         0 $$self{LeicaTrailer}{TrailLen} = $raf->Tell() - $pos - $fromEnd;
6476 0         0 Image::ExifTool::Panasonic::ProcessLeicaTrailer($self);
6477             }
6478             # finally, dump remaining information in JPEG trailer
6479 3 100 66     20 if ($verbose or $htmlDump) {
6480 1         2 my $endPos = $$self{LeicaTrailerPos};
6481 1 50       4 unless ($endPos) {
6482 1         8 $raf->Seek(0, 2);
6483 1         5 $endPos = $raf->Tell() - $fromEnd;
6484             }
6485             $self->DumpUnknownTrailer({
6486 1 50       3 RAF => $raf,
6487             DataPos => $pos,
6488             DirLen => $endPos - $pos
6489             }) if $endPos > $pos;
6490             }
6491 3 50       12 $self->FoundTag('JPEGImageLength', $pos - $appBytes) if $calcImageLen;
6492 3         10 last; # all done parsing file
6493             } elsif ($marker == 0xda) { # SOS
6494 229         545 pop @$path;
6495 229         459 $foundSOS = 1;
6496             # all done with meta information unless we have a trailer
6497 229 100       642 $verbose and print $out "JPEG SOS\n";
6498 229 100       704 unless ($fast) {
6499 228         779 $trailInfo = IdentifyTrailer($raf);
6500             # process trailer now unless we are doing verbose dump
6501 228 50 66     1100 if ($trailInfo and $verbose < 3 and not $htmlDump) {
      66        
6502             # process trailers (keep trailInfo to finish processing later
6503             # only if we can't finish without scanning from end of file)
6504 28 50       124 $self->ProcessTrailers($trailInfo) and undef $trailInfo;
6505             }
6506 228 0 33     683 if ($wantTrailer and $$self{PreviewImageStart}) {
6507             # seek ahead and validate preview image
6508 0         0 my $buff;
6509 0         0 my $curPos = $raf->Tell();
6510 0 0 0     0 if ($raf->Seek($$self{PreviewImageStart}, 0) and
      0        
6511             $raf->Read($buff, 4) == 4 and
6512             $buff =~ /^.\xd8\xff[\xc4\xdb\xe0-\xef]/)
6513             {
6514 0         0 undef $wantTrailer;
6515             }
6516 0 0       0 $raf->Seek($curPos, 0) or last;
6517             }
6518             # seek ahead and process Leica trailer
6519 228 50       795 if ($$self{LeicaTrailer}) {
6520 0         0 require Image::ExifTool::Panasonic;
6521 0         0 Image::ExifTool::Panasonic::ProcessLeicaTrailer($self);
6522 0 0       0 $wantTrailer = 1 if $$self{LeicaTrailer};
6523             } else {
6524 228 50       713 $wantTrailer = 1 if $$options{ExtractEmbedded};
6525             }
6526 228 100 33     2029 next if $trailInfo or $wantTrailer or $verbose > 2 or $htmlDump;
      66        
      66        
6527             }
6528             # must scan to EOI if Validate or JpegCompressionFactor used
6529 228 50 33     1617 next if $$options{Validate} or $calcImageLen or $$req{trailer};
      33        
6530             # nothing interesting to parse after start of scan (SOS)
6531 228         496 $success = 1;
6532 228         473 last; # all done parsing file
6533             } elsif ($marker == 0x93) {
6534 1         2 pop @$path;
6535 1 50       3 $verbose and print $out "JPEG SOD\n";
6536 1         2 $success = 1;
6537 1 50 33     5 next if $verbose > 2 or $htmlDump;
6538 1         3 last; # all done parsing file
6539             } elsif (defined $markerLenBytes{$marker}) {
6540             # handle other stand-alone markers and segments we skipped over
6541 0 0 0     0 $verbose and $marker and print $out "JPEG $markerName\n";
6542 0         0 next;
6543             } elsif ($marker == 0xdb and length($$segDataPt) and # DQT
6544             # save the DQT data only if JPEGDigest has been requested
6545             # (Note: since we aren't checking the API RequestAll option here, the application
6546             # must use the RequestTags option to generate these tags if they have not been
6547             # specifically requested. The reason is that there is too much overhead involved
6548             # in the calculation of this tag to make this worth the CPU time.)
6549             ($$req{jpegdigest} or $$req{jpegqualityestimate}
6550             or ($$options{RequestAll} and $$options{RequestAll} > 2)))
6551             {
6552 1         4 my $num = unpack('C',$$segDataPt) & 0x0f; # get table index
6553 1 50       5 $dqt[$num] = $$segDataPt if $num < 4; # save for MD5 calculation
6554             }
6555             # handle all other markers
6556 1358         2094 my $dumpType = '';
6557 1358         2875 my ($desc, $tip, $xtra);
6558 1358         2105 $length = length $$segDataPt;
6559 1358 100       3040 $appBytes += $length + 4 if ($marker & 0xf0) == 0xe0; # total size of APP segments
6560 1358 100       2575 if ($verbose) {
6561 6         23 print $out "JPEG $markerName ($length bytes):\n";
6562 6 100       16 if ($verbose > 2) {
6563 3         10 my %extraParms = ( Addr => $segPos );
6564 3 50       8 $extraParms{MaxLen} = 128 if $verbose == 4;
6565 3         16 HexDump($segDataPt, undef, %dumpParms, %extraParms);
6566             }
6567             }
6568             # prepare dirInfo hash for processing this information
6569 1358         6593 my %dirInfo = (
6570             Parent => $markerName,
6571             DataPt => $segDataPt,
6572             DataPos => $segPos,
6573             DataLen => $length,
6574             DirStart => 0,
6575             DirLen => $length,
6576             Base => 0,
6577             );
6578 1358 100       12717 if ($marker == 0xe0) { # APP0 (JFIF, JFXX, CIFF, AVI1, Ocad)
    100          
    100          
    100          
    50          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
6579 106 100       944 if ($$segDataPt =~ /^JFIF\0/) {
    100          
    100          
    50          
6580 49         102 $dumpType = 'JFIF';
6581 49         176 DirStart(\%dirInfo, 5); # start at byte 5
6582 49         163 SetByteOrder('MM');
6583 49         162 my $tagTablePtr = GetTagTable('Image::ExifTool::JFIF::Main');
6584 49         186 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
6585             } elsif ($$segDataPt =~ /^JFXX\0(\x10|\x11|\x13)/) {
6586 19         57 my $tag = ord $1;
6587 19         44 $dumpType = 'JFXX';
6588 19         60 my $tagTablePtr = GetTagTable('Image::ExifTool::JFIF::Extension');
6589 19         71 my $tagInfo = $self->GetTagInfo($tagTablePtr, $tag);
6590 19         94 $self->FoundTag($tagInfo, substr($$segDataPt, 6));
6591             } elsif ($$segDataPt =~ /^(II|MM).{4}HEAPJPGM/s) {
6592 19 50       87 next if $fast > 1; # skip processing for very fast
6593 19         49 $dumpType = 'CIFF';
6594 19         100 my %dirInfo = ( RAF => new File::RandomAccess($segDataPt) );
6595 19         67 $$self{SET_GROUP1} = 'CIFF';
6596 19         40 push @{$$self{PATH}}, 'CIFF';
  19         63  
6597 19         1369 require Image::ExifTool::CanonRaw;
6598 19         122 Image::ExifTool::CanonRaw::ProcessCRW($self, \%dirInfo);
6599 19         40 pop @{$$self{PATH}};
  19         55  
6600 19         97 delete $$self{SET_GROUP1};
6601             } elsif ($$segDataPt =~ /^(AVI1|Ocad)/) {
6602 19         67 $dumpType = $1;
6603 19         67 SetByteOrder('MM');
6604 19         107 my $tagTablePtr = GetTagTable("Image::ExifTool::JPEG::$dumpType");
6605 19         88 DirStart(\%dirInfo, 4);
6606 19         76 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
6607             }
6608             } elsif ($marker == 0xe1) { # APP1 (EXIF, XMP, QVCI, PARROT)
6609             # (some Kodak cameras don't put a second "\0", and I have seen an
6610             # example where there was a second 4-byte APP1 segment header)
6611 259 100 66     2478 if ($$segDataPt =~ /^(.{0,4})Exif\0/is) {
    100          
    100          
    100          
    50          
6612 187         409 undef $dumpType; # (will be dumped here)
6613             # this is EXIF data --
6614             # get the data block (into a common variable)
6615 187         401 my $hdrLen = length($exifAPP1hdr);
6616 187 50       1226 if (length $1) {
    50          
6617 0         0 $hdrLen += length $1;
6618 0         0 $self->Warn('Unknown garbage at start of EXIF segment',1);
6619             } elsif ($$segDataPt !~ /^Exif\0/) {
6620 0         0 $self->Warn('Incorrect EXIF segment identifier',1);
6621             }
6622 187 50       596 if ($htmlDump) {
6623 0         0 $self->HDump($segPos-4, 4, 'APP1 header', "Data size: $length bytes");
6624 0         0 $self->HDump($segPos, $hdrLen, 'Exif header', 'APP1 data type: Exif');
6625 0         0 $dumpEnd = $segPos + $length;
6626             }
6627 187         441 my $dataPt = $segDataPt;
6628 187 50       590 if (defined $combinedSegData) {
6629 0         0 push @skipData, [ $segPos-4, $segPos+$hdrLen ];
6630 0         0 $combinedSegData .= substr($$segDataPt,$hdrLen);
6631 0         0 undef $$segDataPt;
6632 0         0 $dataPt = \$combinedSegData;
6633 0         0 $segPos = $firstSegPos;
6634             }
6635             # peek ahead to see if the next segment is extended EXIF
6636 187 50 66     1161 if ($nextMarker == $marker and
6637             $$nextSegDataPt =~ /^$exifAPP1hdr(?!(MM\0\x2a|II\x2a\0))/)
6638             {
6639             # initialize combined data if necessary
6640 0 0       0 unless (defined $combinedSegData) {
6641 0         0 $combinedSegData = $$segDataPt;
6642 0         0 undef $$segDataPt;
6643 0         0 $firstSegPos = $segPos;
6644 0         0 $self->Warn('File contains multi-segment EXIF',1);
6645 0         0 $$self{ExtendedEXIF} = 1;
6646             }
6647 0         0 next;
6648             }
6649 187         486 $dirInfo{DataPt} = $dataPt;
6650 187         391 $dirInfo{DataPos} = $segPos;
6651 187         519 $dirInfo{DataLen} = $dirInfo{DirLen} = length $$dataPt;
6652 187         791 DirStart(\%dirInfo, $hdrLen, $hdrLen);
6653 187 50       603 $$self{SkipData} = \@skipData if @skipData;
6654             # extract the EXIF information (it is in standard TIFF format)
6655 187 50       847 $self->ProcessTIFF(\%dirInfo) or $self->Warn('Malformed APP1 EXIF segment');
6656             # avoid looking for preview unless necessary because it really slows
6657             # us down -- only look for it if we found pointer, and preview is
6658             # outside EXIF, and PreviewImage is specifically requested
6659 187         857 my $start = $self->GetValue('PreviewImageStart', 'ValueConv');
6660 187         596 my $plen = $self->GetValue('PreviewImageLength', 'ValueConv');
6661 187 100 66     920 if (not $start or not $plen and $$self{PreviewError}) {
      66        
6662 171         370 $start = $$self{PreviewImageStart};
6663 171         375 $plen = $$self{PreviewImageLength};
6664             }
6665 187 0 100     779 if ($start and $plen and IsInt($start) and IsInt($plen) and
      66        
      66        
      33        
      0        
      33        
6666             $start + $plen > $$self{EXIF_POS} + length($$self{EXIF_DATA}) and
6667             ($$req{previewimage} or
6668             # (extracted normally, so check Binary option)
6669             ($$options{Binary} and not $$self{EXCL_TAG_LOOKUP}{previewimage})))
6670             {
6671 0         0 $$self{PreviewImageStart} = $start;
6672 0         0 $$self{PreviewImageLength} = $plen;
6673 0         0 $wantTrailer = 1;
6674             }
6675 187 50       561 if (@skipData) {
6676 0         0 undef @skipData;
6677 0         0 delete $$self{SkipData};
6678             }
6679 187         510 undef $$dataPt;
6680 187         796 next;
6681             } elsif ($$segDataPt =~ /^$xmpExtAPP1hdr/) {
6682             # off len -- extended XMP header (75 bytes total):
6683             # 0 35 bytes - signature
6684             # 35 32 bytes - GUID (MD5 hash of full extended XMP data in ASCII)
6685             # 67 4 bytes - total size of extended XMP data
6686             # 71 4 bytes - offset for this XMP data portion
6687 2         5 $dumpType = 'Extended XMP';
6688 2 50       6 if ($length > 75) {
6689 2         8 my ($size, $off) = unpack('x67N2', $$segDataPt);
6690 2         5 my $guid = substr($$segDataPt, 35, 32);
6691 2 50       8 if ($guid =~ /[^A-Za-z0-9]/) { # (technically, should be uppercase)
6692 0         0 $self->WarnOnce($tip = 'Invalid extended XMP GUID');
6693             } else {
6694 2         5 my $extXMP = $extendedXMP{$guid};
6695 2 100       9 if (not $extXMP) {
    50          
6696 1         4 $extXMP = $extendedXMP{$guid} = { };
6697             } elsif ($size != $$extXMP{Size}) {
6698 0         0 $self->WarnOnce('Inconsistent extended XMP size');
6699             }
6700 2         6 $$extXMP{Size} = $size;
6701 2         8 $$extXMP{$off} = substr($$segDataPt, 75);
6702 2         11 $tip = "Full length: $size\nChunk offset: $off\nChunk length: " .
6703             ($length - 75) . "\nGUID: $guid";
6704             # (delay processing extended XMP until after reading all segments)
6705             }
6706             } else {
6707 0         0 $self->WarnOnce($tip = 'Invalid extended XMP segment');
6708             }
6709             } elsif ($$segDataPt =~ /^QVCI\0/) {
6710 1         2 $dumpType = 'QVCI';
6711 1         4 my $tagTablePtr = GetTagTable('Image::ExifTool::Casio::QVCI');
6712 1         4 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
6713             } elsif ($$segDataPt =~ /^FLIR\0/ and $length >= 8) {
6714 1         2 $dumpType = 'FLIR';
6715             # must concatenate FLIR chunks (note: handle the case where
6716             # some software erroneously writes zeros for the chunk counts)
6717 1         11 my $chunkNum = Get8u($segDataPt, 6);
6718 1         3 my $chunksTot = Get8u($segDataPt, 7) + 1; # (note the "+ 1"!)
6719 1 50       4 $verbose and printf $out "$$self{INDENT}FLIR chunk %d of %d\n",
6720             $chunkNum + 1, $chunksTot;
6721 1 50       4 if (defined $flirTotal) {
6722             # abort parsing FLIR if the total chunk count is inconsistent
6723 0 0       0 undef $flirCount if $chunksTot != $flirTotal;
6724             } else {
6725 1         2 $flirCount = 0;
6726 1         2 $flirTotal = $chunksTot;
6727             }
6728 1 50       11 if (defined $flirCount) {
6729 1 50       3 if (defined $flirChunk[$chunkNum]) {
6730 0         0 $self->WarnOnce('Duplicate FLIR chunk number(s)');
6731 0         0 $flirChunk[$chunkNum] .= substr($$segDataPt, 8);
6732             } else {
6733 1         10 $flirChunk[$chunkNum] = substr($$segDataPt, 8);
6734             }
6735             # process the FLIR information if we have all of the chunks
6736 1 50       4 if (++$flirCount >= $flirTotal) {
6737 1         2 my $flir = '';
6738 1   33     11 defined $_ and $flir .= $_ foreach @flirChunk;
6739 1         3 undef @flirChunk; # free memory
6740 1         4 my $tagTablePtr = GetTagTable('Image::ExifTool::FLIR::FFF');
6741 1         4 my %dirInfo = (
6742             DataPt => \$flir,
6743             Parent => $markerName,
6744             DirName => 'FLIR',
6745             );
6746 1         4 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
6747 1         4 undef $flirCount; # prevent reprocessing
6748             }
6749             } else {
6750 0         0 $self->WarnOnce('Invalid or extraneous FLIR chunk(s)');
6751             }
6752             } elsif ($$segDataPt =~ /^PARROT\0(II\x2a\0|MM\0\x2a)/) {
6753             # (don't know if this could span multiple segments)
6754 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::Main');
6755 0         0 $self->HandleTag($tagTablePtr, 'APP1', $$segDataPt);
6756 0         0 $dumpType = 'Parrot';
6757             } else {
6758             # Hmmm. Could be XMP, let's see
6759 68         164 my $processed;
6760 68 50 33     477 if ($$segDataPt =~ /^(http|XMP\0)/ or $$segDataPt =~ /<(exif:|\?xpacket)/) {
6761 68         162 $dumpType = 'XMP';
6762             # also try to parse XMP with a non-standard header
6763             # (note: this non-standard XMP is ignored when writing)
6764 68 50       575 my $start = ($$segDataPt =~ /^$xmpAPP1hdr/) ? length($xmpAPP1hdr) : 0;
6765 68         248 my $tagTablePtr = GetTagTable('Image::ExifTool::XMP::Main');
6766 68         280 DirStart(\%dirInfo, $start);
6767 68 50       449 $dirInfo{DirName} = $start ? 'XMP' : 'XML',
6768             $processed = $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
6769 68 50 33     451 if ($processed and not $start) {
6770 0         0 $self->Warn('Non-standard header for APP1 XMP segment');
6771             }
6772             }
6773 68 50 33     304 if ($verbose and not $processed) {
6774 0         0 $self->Warn("Ignored APP1 segment length $length (unknown header)");
6775             }
6776             }
6777             } elsif ($marker == 0xe2) { # APP2 (ICC Profile, FPXR, MPF, PreviewImage)
6778 120 100 66     784 if ($$segDataPt =~ /^ICC_PROFILE\0/ and $length >= 14) {
    100          
    50          
    0          
    0          
6779 34         78 $dumpType = 'ICC_Profile';
6780             # must concatenate profile chunks (note: handle the case where
6781             # some software erroneously writes zeros for the chunk counts)
6782 34         120 my $chunkNum = Get8u($segDataPt, 12);
6783 34         101 my $chunksTot = Get8u($segDataPt, 13);
6784 34 50       107 $verbose and print $out "$$self{INDENT}ICC_Profile chunk $chunkNum of $chunksTot\n";
6785 34 50       108 if (defined $iccChunksTotal) {
6786             # abort parsing ICC_Profile if the total chunk count is inconsistent
6787 0 0       0 undef $iccChunkCount if $chunksTot != $iccChunksTotal;
6788             } else {
6789 34         66 $iccChunkCount = 0;
6790 34         56 $iccChunksTotal = $chunksTot;
6791 34 50       99 $self->Warn('ICC_Profile chunk count is zero') if !$chunksTot;
6792             }
6793 34 50       94 if (defined $iccChunkCount) {
6794 34 50       107 if (defined $iccChunk[$chunkNum]) {
6795 0         0 $self->WarnOnce('Duplicate ICC_Profile chunk number(s)');
6796 0         0 $iccChunk[$chunkNum] .= substr($$segDataPt, 14);
6797             } else {
6798 34         173 $iccChunk[$chunkNum] = substr($$segDataPt, 14);
6799             }
6800             # process profile if we have all of the chunks
6801 34 50       119 if (++$iccChunkCount >= $iccChunksTotal) {
6802 34         75 my $icc_profile = '';
6803 34   66     250 defined $_ and $icc_profile .= $_ foreach @iccChunk;
6804 34         85 undef @iccChunk; # free memory
6805 34         103 my $tagTablePtr = GetTagTable('Image::ExifTool::ICC_Profile::Main');
6806 34         208 my %dirInfo = (
6807             DataPt => \$icc_profile,
6808             DataPos => $segPos + 14,
6809             DataLen => length($icc_profile),
6810             DirStart => 0,
6811             DirLen => length($icc_profile),
6812             Parent => $markerName,
6813             );
6814 34         162 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
6815 34         185 undef $iccChunkCount; # prevent reprocessing
6816             }
6817             } else {
6818 0         0 $self->WarnOnce('Invalid or extraneous ICC_Profile chunk(s)');
6819             }
6820             } elsif ($$segDataPt =~ /^FPXR\0/) {
6821 67 50       174 next if $fast > 1; # skip processing for very fast
6822 67         116 $dumpType = 'FPXR';
6823 67         179 my $tagTablePtr = GetTagTable('Image::ExifTool::FlashPix::Main');
6824             # set flag if this is the last FPXR segment
6825 67   100     548 $dirInfo{LastFPXR} = not ($nextMarker==$marker and $$nextSegDataPt=~/^FPXR\0/),
6826             $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
6827             } elsif ($$segDataPt =~ /^MPF\0/) {
6828 19         52 undef $dumpType; # (will be dumped here)
6829 19         81 DirStart(\%dirInfo, 4, 4);
6830 19         65 $dirInfo{Multi} = 1; # the MP Attribute IFD will be MPF1
6831 19 50       57 if ($htmlDump) {
6832 0         0 $self->HDump($segPos-4, 4, 'APP2 header', "Data size: $length bytes");
6833 0         0 $self->HDump($segPos, 4, 'MPF header', 'APP2 data type: MPF');
6834 0         0 $dumpEnd = $segPos + $length;
6835             }
6836             # extract the MPF information (it is in standard TIFF format)
6837 19         55 my $tagTablePtr = GetTagTable('Image::ExifTool::MPF::Main');
6838 19         86 $self->ProcessTIFF(\%dirInfo, $tagTablePtr);
6839             } elsif ($$segDataPt =~ /^(|QVGA\0|BGTH)\xff\xd8\xff[\xdb\xe0\xe1]/) {
6840             # Samsung/GE/GoPro="", BenQ DC C1220/Pentacon/Polaroid="QVGA\0",
6841             # Digilife DDC-690/Rollei="BGTH"
6842 0         0 $dumpType = 'Preview Image';
6843 0         0 $preview = substr($$segDataPt, length($1));
6844             } elsif ($preview) {
6845 0         0 $dumpType = 'Preview Image';
6846 0         0 $preview .= $$segDataPt;
6847             }
6848 120 50 33     421 if ($preview and $nextMarker ne $marker) {
6849 0         0 $self->FoundTag('PreviewImage', $preview);
6850 0         0 undef $preview;
6851             }
6852             } elsif ($marker == 0xe3) { # APP3 (Kodak "Meta", Stim)
6853 20 100       149 if ($$segDataPt =~ /^(Meta|META|Exif)\0\0/) {
    50          
    50          
    0          
    0          
6854 19         45 undef $dumpType; # (will be dumped here)
6855 19         72 DirStart(\%dirInfo, 6, 6);
6856 19 50       60 if ($htmlDump) {
6857 0         0 $self->HDump($segPos-4, 10, 'APP3 Meta header');
6858 0         0 $dumpEnd = $segPos + $length;
6859             }
6860 19         58 my $tagTablePtr = GetTagTable('Image::ExifTool::Kodak::Meta');
6861 19         82 $self->ProcessTIFF(\%dirInfo, $tagTablePtr);
6862             } elsif ($$segDataPt =~ /^Stim\0/) {
6863 0         0 undef $dumpType; # (will be dumped here)
6864 0         0 DirStart(\%dirInfo, 6, 6);
6865 0 0       0 if ($htmlDump) {
6866 0         0 $self->HDump($segPos-4, 4, 'APP3 header', "Data size: $length bytes");
6867 0         0 $self->HDump($segPos, 5, 'Stim header', 'APP3 data type: Stim');
6868 0         0 $dumpEnd = $segPos + $length;
6869             }
6870             # extract the Stim information (it is in standard TIFF format)
6871 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::Stim::Main');
6872 0         0 $self->ProcessTIFF(\%dirInfo, $tagTablePtr);
6873             } elsif ($$segDataPt =~ /^_JPSJPS_/) {
6874 1         5 $dumpType = 'JPS';
6875 1 50       7 $self->OverrideFileType('JPS') if $$self{FILE_TYPE} eq 'JPEG';
6876 1         5 SetByteOrder('MM');
6877 1         4 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::JPS');
6878 1         5 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
6879             } elsif ($$self{Make} eq 'DJI') {
6880 0         0 $dumpType = 'DJI ThermalData';
6881             # add this data to the combined data if it exists
6882 0         0 my $dataPt = $segDataPt;
6883 0 0       0 if (defined $combinedSegData) {
6884 0         0 $combinedSegData .= $$segDataPt;
6885 0         0 $dataPt = \$combinedSegData;
6886             }
6887 0 0       0 if ($nextMarker == $marker) {
6888 0 0       0 $combinedSegData = $$segDataPt unless defined $combinedSegData;
6889             } else {
6890             # process DJI FLIR thermal data
6891 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::Main');
6892 0         0 $self->HandleTag($tagTablePtr, 'APP3', $$dataPt);
6893 0         0 undef $combinedSegData;
6894             }
6895             } elsif ($$segDataPt =~ /^\xff\xd8\xff\xdb/) {
6896 0         0 $dumpType = 'PreviewImage'; # (Samsung, HP, BenQ)
6897 0         0 $preview = $$segDataPt;
6898             }
6899 20 50 33     92 if ($preview and $nextMarker ne 0xe4) { # this preview continues in APP4
6900 0         0 $self->FoundTag('PreviewImage', $preview);
6901 0         0 undef $preview;
6902             }
6903             } elsif ($marker == 0xe4) { # APP4 ("SCALADO", FPXR, PreviewImage)
6904 0 0 0     0 if ($$segDataPt =~ /^SCALADO\0/ and $length >= 16) {
    0 0        
    0          
    0          
6905 0         0 $dumpType = 'SCALADO';
6906 0         0 my ($num, $idx, $len) = unpack('x8n2N', $$segDataPt);
6907             # assume that the segments are in order and just concatinate them
6908 0 0       0 $scalado = '' unless defined $scalado;
6909 0         0 $scalado .= substr($$segDataPt, 16);
6910 0 0       0 if ($idx == $num - 1) {
6911 0 0       0 if ($len != length $scalado) {
6912 0         0 $self->Warn('Possibly corrupted APP4 SCALADO data', 1);
6913             }
6914 0         0 my %dirInfo = (
6915             Parent => $markerName,
6916             DataPt => \$scalado,
6917             );
6918 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::Scalado::Main');
6919 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
6920 0         0 undef $scalado;
6921             }
6922             } elsif ($$segDataPt =~ /^FPXR\0/) {
6923 0 0       0 next if $fast > 1; # skip processing for very fast
6924 0         0 $dumpType = 'FPXR';
6925 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::FlashPix::Main');
6926             # set flag if this is the last FPXR segment
6927 0   0     0 $dirInfo{LastFPXR} = not ($nextMarker==$marker and $$nextSegDataPt=~/^FPXR\0/),
6928             $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
6929             } elsif ($$self{Make} eq 'DJI' and $$segDataPt =~ /^\xaa\x55\x12\x06/) {
6930 0         0 $dumpType = 'DJI ThermalParams';
6931 0         0 DirStart(\%dirInfo, 0, 0);
6932 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::DJI::ThermalParams');
6933 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
6934             } elsif ($preview) {
6935             # continued Samsung S1060 preview from APP3
6936 0         0 $dumpType = 'PreviewImage';
6937 0         0 $preview .= $$segDataPt;
6938             }
6939             # (also seen "QTI Debug Metadata\0" segment in some newer Samsung images)
6940             # BenQ DC E1050 continues preview in APP5
6941 0 0 0     0 if ($preview and $nextMarker ne 0xe5) {
6942 0         0 $self->FoundTag('PreviewImage', $preview);
6943 0         0 undef $preview;
6944             }
6945             } elsif ($marker == 0xe5) { # APP5 (Ricoh "RMETA")
6946 20 50       119 if ($$segDataPt =~ /^RMETA\0/) {
    0          
    0          
    0          
6947             # (NOTE: apparently these may span multiple segments, but I haven't seen
6948             # a sample like this, so multi-segment support hasn't yet been implemented)
6949 20         46 $dumpType = 'Ricoh RMETA';
6950 20         77 DirStart(\%dirInfo, 6, 6);
6951 20         65 my $tagTablePtr = GetTagTable('Image::ExifTool::Ricoh::RMETA');
6952 20         84 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
6953             } elsif ($$segDataPt =~ /^ssuniqueid\0/) {
6954 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::Samsung::APP5');
6955 0         0 $self->HandleTag($tagTablePtr, 'ssuniqueid', substr($$segDataPt, 11));
6956             } elsif ($$self{Make} eq 'DJI') {
6957 0         0 $dumpType = 'DJI ThermalCal';
6958 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::Main');
6959 0         0 $self->HandleTag($tagTablePtr, 'APP5', $$segDataPt);
6960             } elsif ($preview) {
6961 0         0 $dumpType = 'PreviewImage';
6962 0         0 $preview .= $$segDataPt;
6963 0         0 $self->FoundTag('PreviewImage', $preview);
6964 0         0 undef $preview;
6965             }
6966             } elsif ($marker == 0xe6) { # APP6 (Toshiba EPPIM, NITF, HP_TDHD)
6967 37 100 33     237 if ($$segDataPt =~ /^EPPIM\0/) {
    100          
    50          
    50          
    0          
6968 18         38 undef $dumpType; # (will be dumped here)
6969 18         64 DirStart(\%dirInfo, 6, 6);
6970 18 50       60 if ($htmlDump) {
6971 0         0 $self->HDump($segPos-4, 10, 'APP6 EPPIM header');
6972 0         0 $dumpEnd = $segPos + $length;
6973             }
6974 18         58 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::EPPIM');
6975 18         78 $self->ProcessTIFF(\%dirInfo, $tagTablePtr);
6976             } elsif ($$segDataPt =~ /^NITF\0/) {
6977 18         44 $dumpType = 'NITF';
6978 18         56 SetByteOrder('MM');
6979 18         83 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::NITF');
6980 18         84 DirStart(\%dirInfo, 5);
6981 18         68 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
6982             } elsif ($$segDataPt =~ /^TDHD\x01\0\0\0/ and $length > 12) {
6983             # HP Photosmart R837 APP6 "TDHD" segment
6984 0         0 $dumpType = 'TDHD';
6985 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::HP::TDHD');
6986             # (ignore first TDHD element because size includes 12-byte tag header)
6987 0         0 DirStart(\%dirInfo, 12);
6988 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
6989             } elsif ($$segDataPt =~ /^GoPro\0/) {
6990             # GoPro segment
6991 1         3 $dumpType = 'GoPro';
6992 1         3 my $tagTablePtr = GetTagTable('Image::ExifTool::GoPro::GPMF');
6993 1         4 DirStart(\%dirInfo, 6);
6994 1         5 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
6995             } elsif ($$segDataPt =~ /^DTAT\0\0.\{/s) {
6996 0         0 $dumpType = 'DJI_DTAT';
6997 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::Main');
6998 0         0 $self->HandleTag($tagTablePtr, 'APP6', $$segDataPt);
6999             }
7000             } elsif ($marker == 0xe7) { # APP7 (Pentax, Huawei, Qualcomm)
7001 19 50       245 if ($$segDataPt =~ /^PENTAX \0(II|MM)/) {
    50          
    50          
7002             # found in K-3 images (is this multi-segment??)
7003 0         0 SetByteOrder($1);
7004 0         0 undef $dumpType; # (dump this ourself)
7005 0         0 my $hdrLen = 10;
7006 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::Pentax::Main');
7007 0         0 DirStart(\%dirInfo, $hdrLen, 0);
7008 0         0 $dirInfo{DirName} = 'Pentax APP7';
7009 0 0       0 if ($htmlDump) {
7010 0         0 $self->HDump($segPos-4, 4, 'APP7 header', "Data size: $length bytes");
7011 0         0 $self->HDump($segPos, $hdrLen, 'Pentax header', 'APP7 data type: Pentax');
7012 0         0 $dumpEnd = $segPos + $length;
7013             }
7014 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7015             } elsif ($$segDataPt =~ /^HUAWEI\0\0(II|MM)/) {
7016 0         0 SetByteOrder($1);
7017 0         0 undef $dumpType; # (dump this ourself)
7018 0         0 my $hdrLen = 16;
7019 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::Unknown::Main');
7020 0         0 DirStart(\%dirInfo, $hdrLen, 8);
7021 0         0 $dirInfo{DirName} = 'Huawei APP7';
7022 0 0       0 if ($htmlDump) {
7023 0         0 $self->HDump($segPos-4, 4, 'APP7 header', "Data size: $length bytes");
7024 0         0 $self->HDump($segPos, $hdrLen, 'Huawei header', 'APP7 data type: Huawei');
7025 0         0 $dumpEnd = $segPos + $length;
7026             }
7027 0         0 $$self{SET_GROUP0} = 'APP7';
7028 0         0 $$self{SET_GROUP1} = 'Huawei';
7029 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7030 0         0 delete $$self{SET_GROUP0};
7031 0         0 delete $$self{SET_GROUP1};
7032             } elsif ($$segDataPt =~ /^\x1aQualcomm Camera Attributes/) {
7033             # found in HP iPAQ_VoiceMessenger
7034 19         47 $dumpType = 'Qualcomm';
7035 19         63 my $tagTablePtr = GetTagTable('Image::ExifTool::Qualcomm::Main');
7036 19         99 DirStart(\%dirInfo, 27);
7037 19         64 $dirInfo{DirName} = 'Qualcomm';
7038 19         80 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7039             }
7040             } elsif ($marker == 0xe8) { # APP8 (SPIFF)
7041             # my sample SPIFF has 32 bytes of data, but spec states 30
7042 19 50 33     138 if ($$segDataPt =~ /^SPIFF\0/ and $length == 32) {
7043 19         49 $dumpType = 'SPIFF';
7044 19         61 DirStart(\%dirInfo, 6);
7045 19         79 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::SPIFF');
7046 19         82 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7047             }
7048             } elsif ($marker == 0xe9) { # APP9 (Media Jukebox)
7049 19 50 33     164 if ($$segDataPt =~ /^Media Jukebox\0/ and $length > 22) {
7050 19         51 $dumpType = 'MediaJukebox';
7051             # (start parsing after the "")
7052 19         68 DirStart(\%dirInfo, 22);
7053 19         100 $dirInfo{DirName} = 'MediaJukebox';
7054 19         193 require Image::ExifTool::XMP;
7055 19         89 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::MediaJukebox');
7056 19         86 $self->ProcessDirectory(\%dirInfo, $tagTablePtr, \&Image::ExifTool::XMP::ProcessXMP);
7057             }
7058             } elsif ($marker == 0xea) { # APP10 (PhotoStudio Unicode comments)
7059 19 50 0     92 if ($$segDataPt =~ /^UNICODE\0/) {
    0          
7060 19         44 $dumpType = 'PhotoStudio';
7061 19         91 my $comment = $self->Decode(substr($$segDataPt,8), 'UCS2', 'MM');
7062 19         74 $self->FoundTag('Comment', $comment);
7063             } elsif ($$segDataPt =~ /^AROT\0/ and $length > 10) {
7064             # iPhone "AROT" segment containing integrated intensity per 16 scan lines
7065             # (with number of elements N = ImageHeight / 16 - 1, ref PH/NealKrawetz)
7066 0         0 $xtra = 'segment (N=' . unpack('x6N', $$segDataPt) . ')';
7067             }
7068             } elsif ($marker == 0xeb) { # APP11 (JPEG-HDR, JUMBF)
7069 38 100 33     291 if ($$segDataPt =~ /^HDR_RI /) {
    50          
7070 19         43 $dumpType = 'JPEG-HDR';
7071 19         40 my $dataPt = $segDataPt;
7072 19 50       58 if (defined $combinedSegData) {
7073 0 0       0 if ($$segDataPt =~ /~\0/g) {
7074 0         0 $combinedSegData .= substr($$segDataPt,pos($$segDataPt));
7075             } else {
7076 0         0 $self->Warn('Invalid format for JPEG-HDR extended segment');
7077             }
7078 0         0 $dataPt = \$combinedSegData;
7079             }
7080 19 50 33     122 if ($nextMarker == $marker and $$nextSegDataPt =~ /^HDR_RI /) {
7081 0 0       0 $combinedSegData = $$segDataPt unless defined $combinedSegData;
7082             } else {
7083 19         60 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::HDR');
7084 19         65 my %dirInfo = ( DataPt => $dataPt );
7085 19         72 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7086 19         47 undef $combinedSegData;
7087             }
7088             } elsif ($$segDataPt =~ /^(JP..)/s and length($$segDataPt) >= 16) {
7089             # JUMBF extension marker
7090 19         52 my $hdr = $1;
7091 19         37 $dumpType = 'JUMBF';
7092 19         58 SetByteOrder('MM');
7093 19         83 my $seq = Get32u($segDataPt, 4) - 1; # (start from 0)
7094 19         57 my $len = Get32u($segDataPt, 8);
7095 19         58 my $type = substr($$segDataPt, 12, 4);
7096 19         45 my $hdrLen;
7097 19 50 33     73 if ($len == 1 and length($$segDataPt) >= 24) {
7098 0         0 $len = Get64u($$segDataPt, 16);
7099 0         0 $hdrLen = 16;
7100             } else {
7101 19         41 $hdrLen = 8;
7102             }
7103 19 50       83 $jumbfChunk{$type} or $jumbfChunk{$type} = [ ];
7104 19 50       119 if ($len < $hdrLen) {
    50          
    50          
7105 0         0 $self->Warn('Invalid JUMBF segment');
7106             } elsif ($seq < 0) {
7107 0         0 $self->Warn('Invalid JUMBF sequence number');
7108             } elsif (defined $jumbfChunk{$type}[$seq]) {
7109 0         0 $self->Warn('Duplicate JUMBF sequence number');
7110             } else {
7111             # add to list of JUMBF chunks
7112 19         75 $jumbfChunk{$type}[$seq] = substr($$segDataPt, 8 + $hdrLen);
7113             # check to see if we have a complete JUMBF box
7114 19         35 my $size = $hdrLen;
7115 19         39 foreach (@{$jumbfChunk{$type}}) {
  19         61  
7116 19 50       52 defined $_ or $size = 0, last;
7117 19         96 $size += length $_;
7118             }
7119 19 50       68 if ($size == $len) {
7120 19         52 my $buff = join '', substr($$segDataPt,8,$hdrLen), @{$jumbfChunk{$type}};
  19         73  
7121 19         47 $dirInfo{DataPt} = \$buff;
7122 19         48 $dirInfo{DataPos} = $segPos + 8; # (shows correct offsets for single-segment JUMBF)
7123 19         47 $dirInfo{DataLen} = $dirInfo{DirLen} = $size;
7124 19         57 my $tagTablePtr = GetTagTable('Image::ExifTool::Jpeg2000::Main');
7125 19         90 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7126 19         86 delete $jumbfChunk{$type};
7127             }
7128             }
7129             }
7130             } elsif ($marker == 0xec) { # APP12 (Ducky, Picture Info)
7131 40 100       168 if ($$segDataPt =~ /^Ducky/) {
7132 21         57 $dumpType = 'Ducky';
7133 21         89 DirStart(\%dirInfo, 5);
7134 21         80 my $tagTablePtr = GetTagTable('Image::ExifTool::APP12::Ducky');
7135 21         88 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7136             } else {
7137 19         57 my $tagTablePtr = GetTagTable('Image::ExifTool::APP12::PictureInfo');
7138 19 50       79 $self->ProcessDirectory(\%dirInfo, $tagTablePtr) and $dumpType = 'Picture Info';
7139             }
7140             } elsif ($marker == 0xed) { # APP13 (Photoshop, Adobe_CM)
7141 82         163 my $isOld;
7142 82 100 50     1078 if ($$segDataPt =~ /^$psAPP13hdr/ or ($$segDataPt =~ /^$psAPP13old/ and $isOld=1)) {
    50 66        
7143 63         243 $dumpType = 'Photoshop';
7144             # add this data to the combined data if it exists
7145 63         117 my $dataPt = $segDataPt;
7146 63 50       285 if (defined $combinedSegData) {
7147 0         0 $combinedSegData .= substr($$segDataPt,length($psAPP13hdr));
7148 0         0 $dataPt = \$combinedSegData;
7149             }
7150             # peek ahead to see if the next segment is photoshop data too
7151 63 50 66     398 if ($nextMarker == $marker and $$nextSegDataPt =~ /^$psAPP13hdr/) {
7152             # initialize combined data if necessary
7153 0 0       0 $combinedSegData = $$segDataPt unless defined $combinedSegData;
7154             # (will handle the Photoshop data the next time around)
7155             } else {
7156 63 50       209 my $hdrLen = $isOld ? 27 : 14;
7157             # process APP13 Photoshop record
7158 63         191 my $tagTablePtr = GetTagTable('Image::ExifTool::Photoshop::Main');
7159 63         419 my %dirInfo = (
7160             DataPt => $dataPt,
7161             DataPos => $segPos,
7162             DataLen => length $$dataPt,
7163             DirStart => $hdrLen, # directory starts after identifier
7164             DirLen => length($$dataPt) - $hdrLen,
7165             Parent => $markerName,
7166             );
7167 63         250 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7168 63         256 undef $combinedSegData;
7169             }
7170             } elsif ($$segDataPt =~ /^Adobe_CM/) {
7171 19         47 $dumpType = 'Adobe_CM';
7172 19         67 SetByteOrder('MM');
7173 19         78 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::AdobeCM');
7174 19         83 DirStart(\%dirInfo, 8);
7175 19         74 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7176             }
7177             } elsif ($marker == 0xee) { # APP14 (Adobe)
7178 45 50       230 if ($$segDataPt =~ /^Adobe/) {
7179             # extract as a block if requested, or if copying tags from file
7180 45 100 66     358 if ($$req{adobe} or
      66        
7181             # (not extracted normally, so check TAGS_FROM_FILE)
7182             ($$self{TAGS_FROM_FILE} and not $$self{EXCL_TAG_LOOKUP}{adobe}))
7183             {
7184 16         70 $self->FoundTag('Adobe', $$segDataPt);
7185             }
7186 45         101 $dumpType = 'Adobe';
7187 45         161 SetByteOrder('MM');
7188 45         156 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::Adobe');
7189 45         169 DirStart(\%dirInfo, 5);
7190 45         161 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7191             }
7192             } elsif ($marker == 0xef) { # APP15 (GraphicConverter)
7193 19 50 33     154 if ($$segDataPt =~ /^Q\s*(\d+)/ and $length == 4) {
7194 19         45 $dumpType = 'GraphicConverter';
7195 19         59 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::GraphConv');
7196 19         98 $self->HandleTag($tagTablePtr, 'Q', $1);
7197             }
7198             } elsif ($marker == 0xfe) { # COM (JPEG comment)
7199 27         65 $dumpType = 'Comment';
7200 27         101 $$segDataPt =~ s/\0+$//; # some dumb softwares add null terminators
7201 27         88 $self->FoundTag('Comment', $$segDataPt);
7202             } elsif ($marker == 0x64) { # CME (J2C comment and extension)
7203 2         3 $dumpType = 'Comment';
7204 2 50       5 if ($length > 2) {
7205 2         4 my $reg = unpack('n', $$segDataPt); # get registration value
7206 2         5 my $val = substr($$segDataPt, 2);
7207 2 50       7 $val = $self->Decode($val, 'Latin') if $reg == 1;
7208             # (actually an extension for $reg==65535, but store as binary comment)
7209 2 50 33     23 $self->FoundTag('Comment', ($reg==0 or $reg==65535) ? \$val : $val);
7210             }
7211             } elsif ($marker == 0x51) { # SIZ (J2C)
7212 1         3 my ($w, $h) = unpack('x2N2', $$segDataPt);
7213 1         3 $self->FoundTag('ImageWidth', $w);
7214 1         2 $self->FoundTag('ImageHeight', $h);
7215             } elsif (($marker & 0xf0) != 0xe0) {
7216 466         970 $dumpType = "$markerName segment";
7217 466         1035 $desc = "[JPEG $markerName]"; # (other known JPEG segments)
7218             }
7219 1171 100       2689 if (defined $dumpType) {
7220 1115 50 33     2544 if (not $dumpType and ($$options{Unknown} or $$options{Validate})) {
      66        
7221 0 0       0 my $str = ($$segDataPt =~ /^([\x20-\x7e]{1,20})\0/) ? " '${1}'" : '';
7222 0 0       0 $xtra = 'segment' unless $xtra;
7223 0         0 $self->Warn("Unknown $markerName$str $xtra", 1);
7224             }
7225 1115 50       2278 if ($htmlDump) {
7226 0 0       0 $desc or $desc = $markerName . ($dumpType ? " $dumpType" : '') . ' segment';
    0          
7227 0         0 $self->HDump($segPos-4, $length+4, $desc, $tip, 0x08);
7228 0         0 $dumpEnd = $segPos + $length;
7229             }
7230             }
7231 1171         3787 undef $$segDataPt;
7232             }
7233             # process extended XMP now if it existed
7234 232 100       724 if (%extendedXMP) {
7235 1         5 my $guid;
7236             # GUID indicated by the last main XMP segment
7237 1   50     5 my $goodGuid = $$self{VALUE}{HasExtendedXMP} || '';
7238             # GUID of the extended XMP that we will process ('2' for all)
7239 1   50     4 my $readGuid = $$options{ExtendedXMP} || 0;
7240 1 50       5 $readGuid = $goodGuid if $readGuid eq '1';
7241 1         6 foreach $guid (sort keys %extendedXMP) {
7242 1 50       5 next unless length $guid == 32; # ignore other (internal) keys
7243 1         3 my $extXMP = $extendedXMP{$guid};
7244 1         2 my ($off, @offsets, $warn);
7245             # make sure we have all chunks, and create a list of sorted offsets
7246 1         5 for ($off=0; $off<$$extXMP{Size}; ) {
7247 2 50       5 last unless defined $$extXMP{$off};
7248 2         5 push @offsets, $off;
7249 2         5 $off += length $$extXMP{$off};
7250             }
7251 1 50       4 unless ($off == $$extXMP{Size}) {
7252 0         0 $self->Warn("Incomplete extended XMP (GUID $guid)");
7253 0         0 next;
7254             }
7255 1 50 33     5 if ($guid eq $readGuid or $readGuid eq '2') {
7256 1 50       5 $warn = 'Reading non-' if $guid ne $goodGuid;
7257 1         2 my $buff = '';
7258             # assemble XMP all together
7259 1         6 $buff .= $$extXMP{$_} foreach @offsets;
7260 1         4 my $tagTablePtr = GetTagTable('Image::ExifTool::XMP::Main');
7261 1         5 my %dirInfo = (
7262             DataPt => \$buff,
7263             Parent => 'APP1',
7264             IsExtended => 1,
7265             );
7266 1         3 $$path[$pn] = 'APP1';
7267 1         4 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7268 1         5 pop @$path;
7269             } else {
7270 0         0 $warn = 'Ignored ';
7271 0 0       0 $warn .= 'non-' if $guid ne $goodGuid;
7272             }
7273 1 50       5 $self->Warn("${warn}standard extended XMP (GUID $guid)") if $warn;
7274 1         8 delete $extendedXMP{$guid};
7275             }
7276             }
7277             # calculate JPEGDigest if requested
7278 232 100       736 if (@dqt) {
7279 1         1290 require Image::ExifTool::JPEGDigest;
7280 1         9 Image::ExifTool::JPEGDigest::Calculate($self, \@dqt, $subSampling);
7281             }
7282             # issue necessary warnings
7283 232 50       610 $self->Warn('Invalid JUMBF size or missing JUMBF chunk') if %jumbfChunk;
7284 232 50       638 $self->Warn('Incomplete ICC_Profile record', 1) if defined $iccChunkCount;
7285 232 50       624 $self->Warn('Incomplete FLIR record', 1) if defined $flirCount;
7286 232 50       714 $self->Warn('Error reading PreviewImage', 1) if $$self{PreviewError};
7287 232 50       616 $success or $self->Warn('JPEG format error');
7288 232 50       734 pop @$path if @$path > $pn;
7289 232         1756 return 1;
7290             }
7291              
7292             #------------------------------------------------------------------------------
7293             # Extract metadata from an Exiv2 EXV file
7294             # Inputs: 0) ExifTool object reference, 1) dirInfo ref with RAF set
7295             # Returns: 1 on success, 0 if this wasn't a valid JPEG file
7296             sub ProcessEXV($$)
7297             {
7298 2     2 0 9 my ($self, $dirInfo) = @_;
7299 2         10 return $self->ProcessJPEG($dirInfo);
7300             }
7301              
7302             #------------------------------------------------------------------------------
7303             # Process EXIF file
7304             # Inputs/Returns: same as ProcessTIFF
7305             sub ProcessEXIF($$;$)
7306             {
7307 2     2 0 7 my ($self, $dirInfo, $tagTablePtr) = @_;
7308 2         10 return $self->ProcessTIFF($dirInfo, $tagTablePtr);
7309             }
7310              
7311             #------------------------------------------------------------------------------
7312             # Process TIFF data (wrapper for DoProcessTIFF to allow re-entry)
7313             # Inputs: 0) ExifTool object ref, 1) dirInfo ref, 2) optional tag table ref
7314             # Returns: 1 if this looked like a valid EXIF block, 0 otherwise, or -1 on write error
7315             sub ProcessTIFF($$;$)
7316             {
7317 478     478 0 1358 my ($self, $dirInfo, $tagTablePtr) = @_;
7318 478         967 my $exifData = $$self{EXIF_DATA};
7319 478         918 my $exifPos = $$self{EXIF_POS};
7320 478         1743 my $rtnVal = $self->DoProcessTIFF($dirInfo, $tagTablePtr);
7321             # restore original EXIF information (in case ProcessTIFF is nested)
7322 478 100       1467 if (defined $exifData) {
7323 108         239 $$self{EXIF_DATA} = $exifData;
7324 108         212 $$self{EXIF_POS} = $exifPos;
7325             }
7326 478         1614 return $rtnVal;
7327             }
7328              
7329             #------------------------------------------------------------------------------
7330             # Process TIFF data
7331             # Inputs: 0) ExifTool object ref, 1) dirInfo ref, 2) optional tag table ref
7332             # Returns: 1 if this looked like a valid EXIF block, 0 otherwise, or -1 on write error
7333             sub DoProcessTIFF($$;$)
7334             {
7335 478     478 0 1094 my ($self, $dirInfo, $tagTablePtr) = @_;
7336 478         945 my $dataPt = $$dirInfo{DataPt};
7337 478   100     1578 my $fileType = $$dirInfo{Parent} || '';
7338 478         940 my $raf = $$dirInfo{RAF};
7339 478   100     2213 my $base = $$dirInfo{Base} || 0;
7340 478         831 my $outfile = $$dirInfo{OutFile};
7341 478         1614 my ($err, $sig, $canonSig, $otherSig);
7342              
7343             # attempt to read TIFF header
7344 478         1099 $$self{EXIF_DATA} = '';
7345 478 100 100     2625 if ($raf) {
    100          
    50          
7346 47 100       130 if ($outfile) {
7347 14 50       59 $raf->Seek(0, 0) or return 0;
7348 14 50       59 if ($base) {
7349 0 0       0 $raf->Read($$dataPt, $base) == $base or return 0;
7350 0 0       0 Write($outfile, $$dataPt) or $err = 1;
7351             }
7352             } else {
7353 33 50       121 $raf->Seek($base, 0) or return 0;
7354             }
7355             # extract full EXIF block (for block copy) from EXIF file
7356 47 100       502 my $amount = $fileType eq 'EXIF' ? 65536 * 8 : 8;
7357 47         189 my $n = $raf->Read($$self{EXIF_DATA}, $amount);
7358 47 100       200 if ($n < 8) {
7359 1 50 33     13 return 0 if $n or not $outfile or $fileType ne 'EXIF';
      33        
7360             # create EXIF file from scratch
7361 1         3 delete $$self{EXIF_DATA};
7362 1         3 undef $raf;
7363             }
7364 47 100       164 if ($n > 8) {
7365 2         10 $raf->Seek(8, 0);
7366 2 50       12 if ($n == $amount) {
7367 0         0 $$self{EXIF_DATA} = substr($$self{EXIF_DATA}, 0, 8);
7368 0         0 $self->Warn('EXIF too large to extract as a block'); #(shouldn't happen)
7369             }
7370             }
7371             } elsif ($dataPt and length $$dataPt) {
7372             # save a copy of the EXIF data
7373 390   100     1123 my $dirStart = $$dirInfo{DirStart} || 0;
7374 390   66     1937 my $dirLen = $$dirInfo{DirLen} || (length($$dataPt) - $dirStart);
7375 390         1949 $$self{EXIF_DATA} = substr($$dataPt, $dirStart, $dirLen);
7376 390 50 66     1553 $self->VerboseDir('TIFF') if $$self{OPTIONS}{Verbose} and length($$self{INDENT}) > 2;
7377             } elsif ($outfile) {
7378 41         125 delete $$self{EXIF_DATA}; # create from scratch
7379             } else {
7380 0         0 $$self{EXIF_DATA} = '';
7381             }
7382 478 100       1462 unless (defined $$self{EXIF_DATA}) {
7383             # set default byte order for creating new GPS in CR3 images
7384 42         85 my $defaultByteOrder;
7385 42 50 33     293 if ($$dirInfo{DirName} and $$dirInfo{DirName} eq 'GPS') {
7386 0         0 $defaultByteOrder = $$self{SaveExifByteOrder};
7387             }
7388             # create TIFF information from scratch
7389 42 100       256 if ($self->SetPreferredByteOrder($defaultByteOrder) eq 'MM') {
7390 33         105 $$self{EXIF_DATA} = "MM\0\x2a\0\0\0\x08";
7391             } else {
7392 9         35 $$self{EXIF_DATA} = "II\x2a\0\x08\0\0\0";
7393             }
7394             }
7395 478         1392 $$self{EXIF_POS} = $base + $$self{BASE};
7396 478 100       1741 $$self{FIRST_EXIF_POS} = $$self{EXIF_POS} unless defined $$self{FIRST_EXIF_POS};
7397 478         1045 $dataPt = \$$self{EXIF_DATA};
7398              
7399             # set byte ordering
7400 478         1204 my $byteOrder = substr($$dataPt,0,2);
7401 478 100       1520 SetByteOrder($byteOrder) or return 0;
7402              
7403             # verify the byte ordering
7404 472         1426 my $identifier = Get16u($dataPt, 2);
7405             # identifier is 0x2a for TIFF (but 0x4f52, 0x5352 or ?? for ORF)
7406             # no longer do this because various files use different values
7407             # (TIFF=0x2a, RW2/RWL=0x55, HDP=0xbc, BTF=0x2b, ORF=0x4f52/0x5352/0x????)
7408             # return 0 unless $identifier == 0x2a;
7409 472 50 66     2208 $self->Warn('Invalid magic number in EXIF TIFF header') if $fileType eq 'APP1' and $identifier != 0x2a;
7410              
7411             # get offset to IFD0
7412 472 50       1280 return 0 if length $$dataPt < 8;
7413 472         1394 my $offset = Get32u($dataPt, 4);
7414 472 50       1467 $offset >= 8 or return 0;
7415              
7416 472 100       1246 if ($raf) {
7417             # check for canon or EXIF signature
7418             # (Canon CR2 images should have an offset of 16, but it may be
7419             # greater if edited by PhotoMechanic)
7420 40 100 100     328 if ($identifier == 0x2a and $offset >= 16) {
    100 66        
    100          
7421 17 50       73 $raf->Read($sig, 8) == 8 or return 0;
7422 17         43 $$dataPt .= $sig;
7423 17 100       100 if ($sig =~ /^(CR\x02\0|\xba\xb0\xac\xbb|ExifMeta)/) {
7424 10 100       36 if ($sig eq 'ExifMeta') {
7425 1         7 $self->SetFileType($fileType = 'EXIF');
7426 1         2 $otherSig = $sig;
7427             } else {
7428 9 50       44 $fileType = $sig =~ /^CR/ ? 'CR2' : 'Canon 1D RAW';
7429 9         18 $canonSig = $sig;
7430             }
7431 10 50       37 $self->HDump($base+8, 8, "[$fileType header]") if $$self{HTML_DUMP};
7432             }
7433             } elsif ($identifier == 0x55 and $fileType =~ /^(RAW|RW2|RWL|TIFF)$/) {
7434             # panasonic RAW, RW2 or RWL file
7435 3         8 my $magic;
7436             # test for RW2/RWL magic number
7437 3 50 33     22 if ($offset >= 0x18 and $raf->Read($magic, 16) and
      33        
7438             $magic eq "\x88\xe7\x74\xd8\xf8\x25\x1d\x4d\x94\x7a\x6e\x77\x82\x2b\x5d\x6a")
7439             {
7440 3 50       15 $fileType = 'RW2' unless $fileType eq 'RWL';
7441 3 50       14 $self->HDump($base + 8, 16, '[RW2/RWL header]') if $$self{HTML_DUMP};
7442 3         9 $otherSig = $magic; # save signature for writing
7443             } else {
7444 0         0 $fileType = 'RAW';
7445             }
7446 3         15 $tagTablePtr = GetTagTable('Image::ExifTool::PanasonicRaw::Main');
7447             } elsif ($fileType eq 'TIFF') {
7448 13 50 33     113 if ($identifier == 0x2b) {
    50 33        
    50          
    50          
7449             # this looks like a BigTIFF image
7450 0         0 $raf->Seek(0);
7451 0         0 require Image::ExifTool::BigTIFF;
7452 0         0 my $result = Image::ExifTool::BigTIFF::ProcessBTF($self, $dirInfo);
7453 0 0       0 if ($result) {
7454 0 0       0 $self->FoundTag(PageCount => $$self{PageCount}) if $$self{MultiPage};
7455 0         0 return 1;
7456             }
7457             } elsif ($identifier == 0x4f52 or $identifier == 0x5352) {
7458             # Olympus ORF image (set FileType now because base type is 'ORF')
7459 0         0 $self->SetFileType($fileType = 'ORF');
7460             } elsif ($identifier == 0x4352) {
7461 0         0 $fileType = 'DCP';
7462             } elsif ($byteOrder eq 'II' and ($identifier & 0xff) == 0xbc) {
7463 0         0 $fileType = 'HDP'; # Windows HD Photo file
7464             # check version number
7465 0         0 my $ver = Get8u($dataPt, 3);
7466 0 0       0 if ($ver > 1) {
7467 0         0 $self->Error("Windows HD Photo version $ver files not yet supported");
7468 0         0 return 1;
7469             }
7470             }
7471             }
7472             # we have a valid TIFF (or whatever) file
7473 40 100 66     251 if ($fileType and not $$self{VALUE}{FileType}) {
7474 38         100 my $lookup = $fileTypeLookup{$fileType};
7475 38 50 33     173 $lookup = $fileTypeLookup{$lookup} unless ref $lookup or not $lookup;
7476             # use file extension to pre-determine type if extension is TIFF-based or type is RAW
7477 38 50       200 my $baseType = $lookup ? (ref $$lookup[0] ? $$lookup[0][0] : $$lookup[0]) : '';
    50          
7478 38 100 66     183 my $t = ($baseType eq 'TIFF' or $fileType =~ /RAW/) ? $fileType : undef;
7479 38         165 $self->SetFileType($t);
7480             }
7481             # don't process file if FastScan == 3
7482 40 50 66     311 return 1 if not $outfile and $$self{OPTIONS}{FastScan} and $$self{OPTIONS}{FastScan} == 3;
      33        
7483             }
7484             # (accommodate CR3 images which have a TIFF directory with ExifIFD at the top level)
7485 472 100 100     2975 my $ifdName = ($$dirInfo{DirName} and $$dirInfo{DirName} =~ /^(ExifIFD|GPS)$/) ? $1 : 'IFD0';
7486 472 100 100     2978 if (not $tagTablePtr or $$tagTablePtr{GROUPS}{0} eq 'EXIF') {
    100          
7487 396 100       1394 $self->FoundTag('ExifByteOrder', $byteOrder) unless $outfile;
7488             } elsif ($$tagTablePtr{GROUPS}{0} eq 'MakerNotes') { # (for writing CR3 maker notes)
7489 19         50 $ifdName = $$tagTablePtr{GROUPS}{0};
7490             } else {
7491 57         139 $ifdName = $$tagTablePtr{GROUPS}{1};
7492             }
7493 472 50       1566 if ($$self{HTML_DUMP}) {
7494 0 0       0 my $tip = sprintf("Byte order: %s endian\nIdentifier: 0x%.4x\n$ifdName offset: 0x%.4x",
7495             ($byteOrder eq 'II') ? 'Little' : 'Big', $identifier, $offset);
7496 0         0 $self->HDump($base, 8, 'TIFF header', $tip, 0);
7497             }
7498             # remember where we found the TIFF data (APP1, APP3, TIFF, NEF, etc...)
7499 472         1064 $$self{TIFF_TYPE} = $fileType;
7500              
7501             # get reference to the main EXIF table
7502 472 100       1468 $tagTablePtr or $tagTablePtr = GetTagTable('Image::ExifTool::Exif::Main');
7503              
7504             # build directory information hash
7505             my %dirInfo = (
7506             Base => $base,
7507             DataPt => $dataPt,
7508             DataLen => length $$dataPt,
7509             DataPos => 0,
7510             DirStart => $offset,
7511             DirLen => length($$dataPt) - $offset,
7512             RAF => $raf,
7513             DirName => $ifdName,
7514             Parent => $fileType,
7515             ImageData=> 'Main', # set flag to get information to copy main image data later
7516             Multi => $$dirInfo{Multi},
7517 472         4304 );
7518              
7519             # extract information from the image
7520 472 100       1355 unless ($outfile) {
7521             # process the directory
7522 350         1414 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7523             # process GeoTiff information if available
7524 350 100       1526 if ($$self{VALUE}{GeoTiffDirectory}) {
7525 7         749 require Image::ExifTool::GeoTiff;
7526 7         32 Image::ExifTool::GeoTiff::ProcessGeoTiff($self);
7527             }
7528             # process information in recognized trailers
7529 350 100       1040 if ($raf) {
7530 27         116 my $trailInfo = IdentifyTrailer($raf);
7531 27 100       189 if ($trailInfo) {
7532 3         10 $$trailInfo{ScanForAFCP} = 1; # scan to find AFCP if necessary
7533 3         12 $self->ProcessTrailers($trailInfo);
7534             }
7535             # dump any other known trailer (eg. A100 RAW Data)
7536 27 0 33     130 if ($$self{HTML_DUMP} and $$self{KnownTrailer}) {
7537 0         0 my $known = $$self{KnownTrailer};
7538 0         0 $raf->Seek(0, 2);
7539 0         0 my $len = $raf->Tell() - $$known{Start};
7540 0 0       0 $len -= $$trailInfo{Offset} if $trailInfo; # account for other trailers
7541 0 0       0 $self->HDump($$known{Start}, $len, "[$$known{Name}]") if $len > 0;
7542             }
7543             }
7544             # update FileType if necessary now that we know more about the file
7545 350 50 66     1302 if ($$self{DNGVersion} and $$self{VALUE}{FileType} !~ /^(DNG|GPR)$/) {
7546             # override whatever FileType we set since we now know it is DNG
7547 0         0 $self->OverrideFileType($$self{TIFF_TYPE} = 'DNG');
7548             }
7549 350 100       1121 if ($$self{TIFF_TYPE} eq 'TIFF') {
7550 10 50       31 $self->FoundTag(PageCount => $$self{PageCount}) if $$self{MultiPage};
7551             }
7552 350         1757 return 1;
7553             }
7554             #
7555             # rewrite the image
7556             #
7557 122 100       685 if ($$dirInfo{NoTiffEnd}) {
7558 1         2 delete $$self{TIFF_END};
7559             } else {
7560             # initialize TIFF_END so it will be updated by WriteExif()
7561 121         340 $$self{TIFF_END} = 0;
7562             }
7563 122 100       341 if ($canonSig) {
7564             # write Canon CR2 specially because it has a header we want to preserve,
7565             # and possibly trailers added by the Canon utilities and/or PhotoMechanic
7566 3         8 $dirInfo{OutFile} = $outfile;
7567 3         20 require Image::ExifTool::CanonRaw;
7568 3 50       16 Image::ExifTool::CanonRaw::WriteCR2($self, \%dirInfo, $tagTablePtr) or $err = 1;
7569             } else {
7570             # write TIFF header (8 bytes [plus optional signature] followed by IFD)
7571 119 100       615 if ($fileType eq 'EXIF') {
    100          
7572 1         3 $otherSig = 'ExifMeta'; # force this signature for all EXIF files
7573             } elsif (not defined $otherSig) {
7574 117         249 $otherSig = '';
7575             }
7576 119         373 my $offset = 8 + length($otherSig);
7577             # construct tiff header
7578 119         863 my $header = substr($$dataPt, 0, 4) . Set32u($offset) . $otherSig;
7579 119         346 $dirInfo{NewDataPos} = $offset;
7580 119         328 $dirInfo{HeaderPtr} = \$header;
7581             # preserve padding between image data blocks in ORF images
7582             # (otherwise dcraw has problems because it assumes fixed block spacing)
7583 119 100 66     698 $dirInfo{PreserveImagePadding} = 1 if $fileType eq 'ORF' or $identifier != 0x2a;
7584 119         833 my $newData = $self->WriteDirectory(\%dirInfo, $tagTablePtr);
7585 119 50       663 if (not defined $newData) {
    100          
7586 0         0 $err = 1;
7587             } elsif (length($newData)) {
7588             # update header length in case more was added
7589 113         252 my $hdrLen = length $header;
7590 113 100       432 if ($hdrLen != 8) {
7591 3         14 Set32u($hdrLen, \$header, 4);
7592             # also update preview fixup if necessary
7593 3         8 my $pi = $$self{PREVIEW_INFO};
7594 3 0 33     13 $$pi{Fixup}{Start} += $hdrLen - 8 if $pi and $$pi{Fixup};
7595             }
7596 113 50 33     536 if ($$self{TIFF_TYPE} eq 'ARW' and not $err) {
7597             # write any required ARW trailer and patch other ARW quirks
7598 0         0 require Image::ExifTool::Sony;
7599             my $errStr = Image::ExifTool::Sony::FinishARW($self, $dirInfo, \$newData,
7600 0         0 $dirInfo{ImageData});
7601 0 0       0 $errStr and $self->Error($errStr);
7602 0         0 delete $dirInfo{ImageData}; # (was copied by FinishARW)
7603             } else {
7604 113 50       468 Write($outfile, $header, $newData) or $err = 1;
7605             }
7606 113         358 undef $newData; # free memory
7607             }
7608             # copy over image data now if necessary
7609 119 100 66     628 if (ref $dirInfo{ImageData} and not $err) {
7610 10 50       72 $self->CopyImageData($dirInfo{ImageData}, $outfile) or $err = 1;
7611 10         46 delete $dirInfo{ImageData};
7612             }
7613             }
7614             # make local copy of TIFF_END now (it may be reset when processing trailers)
7615 122         312 my $tiffEnd = $$self{TIFF_END};
7616 122         253 delete $$self{TIFF_END};
7617              
7618             # rewrite trailers if they exist
7619 122 100 100     540 if ($raf and $tiffEnd and not $err) {
      66        
7620 12         27 my ($buf, $trailInfo);
7621 12 50       41 $raf->Seek(0, 2) or $err = 1;
7622 12         50 my $extra = $raf->Tell() - $tiffEnd;
7623             # check for trailer and process if possible
7624 12         24 for (;;) {
7625 12 100       40 last unless $extra > 12;
7626 3         9 $raf->Seek($tiffEnd); # seek back to end of image
7627 3         12 $trailInfo = IdentifyTrailer($raf);
7628 3 50       13 last unless $trailInfo;
7629 0         0 my $tbuf = '';
7630 0         0 $$trailInfo{OutFile} = \$tbuf; # rewrite trailer(s)
7631 0         0 $$trailInfo{ScanForAFCP} = 1; # scan for AFCP if necessary
7632             # rewrite all trailers to buffer
7633 0 0       0 unless ($self->ProcessTrailers($trailInfo)) {
7634 0         0 undef $trailInfo;
7635 0         0 $err = 1;
7636 0         0 last;
7637             }
7638             # calculate unused bytes before trailer
7639 0         0 $extra = $$trailInfo{DataPos} - $tiffEnd;
7640 0         0 last; # yes, the 'for' loop was just a cheap 'goto'
7641             }
7642             # ignore a single zero byte if used for padding
7643 12 100 100     60 if ($extra > 0 and $tiffEnd & 0x01) {
7644 1 50       3 $raf->Seek($tiffEnd, 0) or $err = 1;
7645 1 50       3 $raf->Read($buf, 1) or $err = 1;
7646 1 50 33     6 defined $buf and $buf eq "\0" and --$extra, ++$tiffEnd;
7647             }
7648 12 100       42 if ($extra > 0) {
7649 3         7 my $known = $$self{KnownTrailer};
7650 3 50 33     18 if ($$self{DEL_GROUP}{Trailer} and not $known) {
    50          
7651 0         0 $self->VPrint(0, " Deleting unknown trailer ($extra bytes)\n");
7652 0         0 ++$$self{CHANGED};
7653             } elsif ($known) {
7654 0         0 $self->VPrint(0, " Copying $$known{Name} ($extra bytes)\n");
7655 0 0       0 $raf->Seek($tiffEnd, 0) or $err = 1;
7656 0 0       0 CopyBlock($raf, $outfile, $extra) or $err = 1;
7657             } else {
7658 3 50       11 $raf->Seek($tiffEnd, 0) or $err = 1;
7659             # preserve unknown trailer only if it contains non-null data
7660             # (Photoshop CS adds a trailer with 2 null bytes)
7661 3         12 my $size = $extra;
7662 3         7 for (;;) {
7663 3 50       7 my $n = $size > 65536 ? 65536 : $size;
7664 3 50       10 $raf->Read($buf, $n) == $n or $err = 1, last;
7665 3 50       17 if ($buf =~ /[^\0]/) {
7666 3         19 $self->VPrint(0, " Preserving unknown trailer ($extra bytes)\n");
7667             # copy the trailer since it contains non-null data
7668 3 50 0     10 Write($outfile, "\0"x($extra-$size)) or $err = 1, last if $size != $extra;
7669 3 50       9 Write($outfile, $buf) or $err = 1, last;
7670 3 50 0     11 CopyBlock($raf, $outfile, $size-$n) or $err = 1 if $size > $n;
7671 3         6 last;
7672             }
7673 0         0 $size -= $n;
7674 0 0       0 next if $size > 0;
7675 0         0 $self->VPrint(0, " Deleting blank trailer ($extra bytes)\n");
7676 0         0 last;
7677             }
7678             }
7679             }
7680             # write trailer buffer if necessary
7681 12 50 0     41 $self->WriteTrailerBuffer($trailInfo, $outfile) or $err = 1 if $trailInfo;
7682             # add any new trailers we are creating
7683 12         62 my $trailPt = $self->AddNewTrailers();
7684 12 100 50     50 Write($outfile, $$trailPt) or $err = 1 if $trailPt;
7685             }
7686             # check DNG version
7687 122 100       429 if ($$self{DNGVersion}) {
7688 1         2 my $ver = $$self{DNGVersion};
7689             # currently support up to DNG version 1.6
7690 1 50 33     31 unless ($ver =~ /^(\d+) (\d+)/ and "$1.$2" <= 1.6) {
7691 0         0 $ver =~ tr/ /./;
7692 0         0 $self->Error("DNG Version $ver not yet tested", 1);
7693             }
7694             }
7695 122 50       832 return $err ? -1 : 1;
7696             }
7697              
7698             #------------------------------------------------------------------------------
7699             # Return list of tag table keys (ignoring special keys)
7700             # Inputs: 0) reference to tag table
7701             # Returns: List of table keys (unsorted)
7702             sub TagTableKeys($)
7703             {
7704 7562     7562 0 10289 local $_;
7705 7562         10100 my $tagTablePtr = shift;
7706 7562         10022 my @keyList;
7707 7562         93751 foreach (keys %$tagTablePtr) {
7708 445654 100       672439 push(@keyList, $_) unless $specialTags{$_};
7709             }
7710 7562         62835 return @keyList;
7711             }
7712              
7713             #------------------------------------------------------------------------------
7714             # GetTagTable
7715             # Inputs: 0) table name
7716             # Returns: tag table reference, or undefined if not found
7717             # Notes: Always use this function instead of requiring module and using table
7718             # directly since this function also does the following the first time the table
7719             # is loaded:
7720             # - requires new module if necessary
7721             # - generates default GROUPS hash and Group 0 name from module name
7722             # - registers Composite tags if Composite table found
7723             # - saves descriptions for tags in specified table
7724             # - generates default TAG_PREFIX to be used for unknown tags
7725             sub GetTagTable($)
7726             {
7727 88885 100   88885 0 154275 my $tableName = shift or return undef;
7728 88881         146968 my $table = $allTables{$tableName};
7729              
7730 88881 100       135133 unless ($table) {
7731 104     104   1214 no strict 'refs';
  104         229  
  104         16454  
7732 4488 100       24102 unless (%$tableName) {
7733             # try to load module for this table
7734 864 50       5825 if ($tableName =~ /(.*)::/) {
7735 864         2703 my $module = $1;
7736 864 50       58671 if (eval "require $module") {
7737             # load additional modules if required
7738 864 100       6059 if (not %$tableName) {
7739 28 50       137 if ($module eq 'Image::ExifTool::XMP') {
    0          
7740 28         19420 require 'Image/ExifTool/XMP2.pl';
7741             } elsif ($tableName eq 'Image::ExifTool::QuickTime::Stream') {
7742 0         0 require 'Image/ExifTool/QuickTimeStream.pl';
7743             }
7744             }
7745             } else {
7746 0 0       0 $@ and warn $@;
7747             }
7748             }
7749 864 50       4489 unless (%$tableName) {
7750 0         0 warn "Can't find table $tableName\n";
7751 0         0 return undef;
7752             }
7753             }
7754 104     104   673 no strict 'refs';
  104         180  
  104         3784  
7755 4488         9696 $table = \%$tableName;
7756 104     104   530 use strict 'refs';
  104         219  
  104         76436  
7757 4488 100       11314 &{$$table{INIT_TABLE}}($table) if $$table{INIT_TABLE};
  12         162  
7758 4488         9129 $$table{TABLE_NAME} = $tableName; # set table name
7759 4488         23297 ($$table{SHORT_NAME} = $tableName) =~ s/^Image::ExifTool:://;
7760             # set default group 0 and 1 from module name unless already specified
7761 4488         9756 my $defaultGroups = $$table{GROUPS};
7762 4488 100       9128 $defaultGroups or $defaultGroups = $$table{GROUPS} = { };
7763 4488 100 100     16672 unless ($$defaultGroups{0} and $$defaultGroups{1}) {
7764 3585 50       18089 if ($tableName =~ /Image::.*?::([^:]*)/) {
7765 3585 100       10181 $$defaultGroups{0} = $1 unless $$defaultGroups{0};
7766 3585 100       11333 $$defaultGroups{1} = $1 unless $$defaultGroups{1};
7767             } else {
7768 0 0       0 $$defaultGroups{0} = $tableName unless $$defaultGroups{0};
7769 0 0       0 $$defaultGroups{1} = $tableName unless $$defaultGroups{1};
7770             }
7771             }
7772 4488 100       9828 $$defaultGroups{2} = 'Other' unless $$defaultGroups{2};
7773 4488 100 100     15949 if ($$defaultGroups{0} eq 'XMP' or $$table{NAMESPACE}) {
7774             # initialize some XMP table defaults
7775 507         2836 require Image::ExifTool::XMP;
7776 507         2021 Image::ExifTool::XMP::RegisterNamespace($table); # register all table namespaces
7777             # set default write/check procs
7778 507 100       1377 $$table{WRITE_PROC} = \&Image::ExifTool::XMP::WriteXMP unless $$table{WRITE_PROC};
7779 507 100       1341 $$table{CHECK_PROC} = \&Image::ExifTool::XMP::CheckXMP unless $$table{CHECK_PROC};
7780 507 100       1270 $$table{LANG_INFO} = \&Image::ExifTool::XMP::GetLangInfo unless $$table{LANG_INFO};
7781             }
7782             # generate a tag prefix for unknown tags if necessary
7783 4488 100       9316 unless (defined $$table{TAG_PREFIX}) {
7784 4388         5566 my $tagPrefix;
7785 4388 50 66     22691 if ($tableName =~ /Image::.*?::(.*)::Main/ || $tableName =~ /Image::.*?::(.*)/) {
7786 4388         15885 ($tagPrefix = $1) =~ s/::/_/g;
7787             } else {
7788 0         0 $tagPrefix = $tableName;
7789             }
7790 4388         10785 $$table{TAG_PREFIX} = $tagPrefix;
7791             }
7792             # set up the new table
7793 4488         11666 SetupTagTable($table);
7794             # add any user-defined tags (except Composite tags, which are handled specially)
7795 4488 100 100     18002 if (%UserDefined and $UserDefined{$tableName} and $table ne \%Image::ExifTool::Composite) {
      66        
7796 2         3 my $tagID;
7797 2         6 foreach $tagID (TagTableKeys($UserDefined{$tableName})) {
7798 3 50       9 next if $specialTags{$tagID};
7799 3         5 delete $$table{$tagID}; # replace any existing entry
7800 3         12 AddTagToTable($table, $tagID, $UserDefined{$tableName}{$tagID}, 1);
7801             }
7802             }
7803             # remember order we loaded the tables in
7804 4488         8463 push @tableOrder, $tableName;
7805             # insert newly loaded table into list
7806 4488         11966 $allTables{$tableName} = $table;
7807             }
7808             # must check each time to add UserDefined Composite tags because the Composite table
7809             # may be loaded before the UserDefined tags are available
7810 88881 50 66     201901 if ($table eq \%Image::ExifTool::Composite and not $$table{VARS}{LOADED_USERDEFINED} and
      100        
      66        
7811             %UserDefined and $UserDefined{$tableName})
7812             {
7813 0         0 my $userComp = $UserDefined{$tableName};
7814 0         0 delete $UserDefined{$tableName}; # (must delete first to avoid infinite recursion)
7815 0         0 AddCompositeTags($userComp, 1);
7816 0         0 $UserDefined{$tableName} = $userComp; # (add back again for adding writable tags later)
7817 0         0 $$table{VARS}{LOADED_USERDEFINED} = 1; # set flag to avoid doing this again
7818             }
7819 88881         167091 return $table;
7820             }
7821              
7822             #------------------------------------------------------------------------------
7823             # Process an image directory
7824             # Inputs: 0) ExifTool object reference, 1) directory information reference
7825             # 2) tag table reference, 3) optional reference to processing procedure
7826             # Returns: Result from processing (1=success)
7827             sub ProcessDirectory($$$;$)
7828             {
7829 4862     4862 0 12287 my ($self, $dirInfo, $tagTablePtr, $proc) = @_;
7830              
7831 4862 50 33     16821 return 0 unless $tagTablePtr and $dirInfo;
7832             # use default proc from tag table or EXIF proc as fallback if no proc specified
7833 4862 100 100     16591 $proc or $proc = $$tagTablePtr{PROCESS_PROC} || \&Image::ExifTool::Exif::ProcessExif;
7834             # set directory name from default group0 name if not done already
7835 4862         7834 my $dirName = $$dirInfo{DirName};
7836 4862 100       8871 unless ($dirName) {
7837 701         1958 $dirName = $$tagTablePtr{GROUPS}{0};
7838 701 100       2417 $dirName = $$tagTablePtr{GROUPS}{1} if $dirName =~ /^APP\d+$/; # (use specific APP name)
7839 701         1496 $$dirInfo{DirName} = $dirName;
7840             }
7841              
7842             # guard against cyclical recursion into the same directory
7843 4862 100 100     23028 if (defined $$dirInfo{DirStart} and defined $$dirInfo{DataPos} and
      100        
      100        
7844             # directories don't overlap if the length is zero
7845             ($$dirInfo{DirLen} or not defined $$dirInfo{DirLen}))
7846             {
7847 4057   100     12377 my $addr = $$dirInfo{DirStart} + $$dirInfo{DataPos} + ($$dirInfo{Base}||0) + $$self{BASE};
7848 4057 50       10299 if ($$self{PROCESSED}{$addr}) {
7849 0         0 $self->Warn("$dirName pointer references previous $$self{PROCESSED}{$addr} directory");
7850             # patch for bug in Windows phone 7.5 O/S that writes incorrect InteropIFD pointer
7851 0 0 0     0 return 0 unless $dirName eq 'GPS' and $$self{PROCESSED}{$addr} eq 'InteropIFD';
7852             }
7853 4057         10380 $$self{PROCESSED}{$addr} = $dirName;
7854             }
7855 4862         10245 my $oldOrder = GetByteOrder();
7856 4862         15858 my @save = @$self{'INDENT','DIR_NAME','Compression','SubfileType'};
7857 4862         11637 $$self{LIST_TAGS} = { }; # don't build lists across different directories
7858 4862         8766 $$self{INDENT} .= '| ';
7859 4862         7331 $$self{DIR_NAME} = $dirName;
7860 4862         6084 push @{$$self{PATH}}, $dirName;
  4862         9868  
7861 4862         11013 $$self{FOUND_DIR}{$dirName} = 1;
7862              
7863             # process the directory
7864 104     104   745 no strict 'refs';
  104         245  
  104         4328  
7865 4862         19119 my $rtnVal = &$proc($self, $dirInfo, $tagTablePtr);
7866 104     104   603 use strict 'refs';
  104         233  
  104         665544  
7867              
7868 4862         6760 pop @{$$self{PATH}};
  4862         9558  
7869 4862         15530 @$self{'INDENT','DIR_NAME','Compression','SubfileType'} = @save;
7870 4862         11879 SetByteOrder($oldOrder);
7871 4862         15861 return $rtnVal;
7872             }
7873              
7874             #------------------------------------------------------------------------------
7875             # Get Metadata path
7876             # Inputs: 0) ExifTool object ref
7877             # Return: Metadata path string
7878             sub MetadataPath($)
7879             {
7880 720     720 0 1142 my $self = shift;
7881 720         979 return join '-', @{$$self{PATH}}
  720         2862  
7882             }
7883              
7884             #------------------------------------------------------------------------------
7885             # Get standardized file extension
7886             # Inputs: 0) file name
7887             # Returns: standardized extension (all uppercase), or undefined if no extension
7888             sub GetFileExtension($)
7889             {
7890 1907     1907 0 2929 my $filename = shift;
7891 1907         2459 my $fileExt;
7892 1907 100 100     9916 if ($filename and $filename =~ /^.*\.([^.]+)$/s) {
7893 1776         4808 $fileExt = uc($1); # change extension to upper case
7894             # convert TIF extension to TIFF because we use the
7895             # extension for the file type tag of TIFF images
7896 1776 100       3661 $fileExt eq 'TIF' and $fileExt = 'TIFF';
7897             }
7898 1907         5080 return $fileExt;
7899             }
7900              
7901             #------------------------------------------------------------------------------
7902             # Get list of tag information hashes for given tag ID
7903             # Inputs: 0) Tag table reference, 1) tag ID
7904             # Returns: Array of tag information references
7905             # Notes: Generates tagInfo hash if necessary
7906             sub GetTagInfoList($$)
7907             {
7908 526513     526513 0 686123 my ($tagTablePtr, $tagID) = @_;
7909 526513         741598 my $tagInfo = $$tagTablePtr{$tagID};
7910              
7911 526513 50       927940 if ($specialTags{$tagID}) {
    100          
    100          
    100          
7912             # (hopefully this won't happen)
7913 0         0 warn "Tag $tagID conflicts with internal ExifTool variable in $$tagTablePtr{TABLE_NAME}\n";
7914             } elsif (ref $tagInfo eq 'HASH') {
7915 482658         801226 return ($tagInfo);
7916             } elsif (ref $tagInfo eq 'ARRAY') {
7917 10897         34151 return @$tagInfo;
7918             } elsif ($tagInfo) {
7919             # create hash with name
7920 28518         52042 $tagInfo = $$tagTablePtr{$tagID} = { Name => $tagInfo };
7921 28518         46551 return ($tagInfo);
7922             }
7923 4440         6749 return ();
7924             }
7925              
7926             #------------------------------------------------------------------------------
7927             # Find tag information, processing conditional tags
7928             # Inputs: 0) ExifTool object reference, 1) tagTable pointer, 2) tag ID
7929             # 3) optional value reference, 4) optional format type, 5) optional value count
7930             # Returns: pointer to tagInfo hash, undefined if none found, or '' if $valPt needed
7931             # Notes: You should always call this routine to find a tag in a table because
7932             # this routine will evaluate conditional tags.
7933             # Arguments 3-5 are only required if the information type allows $valPt, $format and/or
7934             # $count in a Condition, and if not given when needed this routine returns ''.
7935             sub GetTagInfo($$$;$$$)
7936             {
7937 106161     106161 0 160926 my ($self, $tagTablePtr, $tagID) = @_;
7938 106161         123152 my ($valPt, $format, $count);
7939              
7940 106161         160596 my @infoArray = GetTagInfoList($tagTablePtr, $tagID);
7941             # evaluate condition
7942 106161         119819 my $tagInfo;
7943 106161         146160 foreach $tagInfo (@infoArray) {
7944 110516         174621 my $condition = $$tagInfo{Condition};
7945 110516 100       170991 if ($condition) {
7946 12594 100       24138 ($valPt, $format, $count) = splice(@_, 3) if @_ > 3;
7947 12594 100 100     57781 return '' if $condition =~ /\$(valPt|format|count)\b/ and not defined $valPt;
7948             # set old value for use in condition if needed
7949 11932         42783 local $SIG{'__WARN__'} = \&SetWarning;
7950 11932         18141 undef $evalWarning;
7951             #### eval Condition ($self, [$valPt, $format, $count])
7952 11932 100       723778 unless (eval $condition) {
7953 9521 50       19200 $@ and $evalWarning = $@;
7954 9521 50       14922 $self->Warn("Condition $$tagInfo{Name}: " . CleanWarning()) if $evalWarning;
7955 9521         35062 next;
7956             }
7957             }
7958 100333 100 100     199364 if ($$tagInfo{Unknown} and not $$self{OPTIONS}{Unknown} and
      100        
      100        
      66        
7959             not $$self{OPTIONS}{Verbose} and not $$self{OPTIONS}{Validate} and
7960             not $$self{HTML_DUMP})
7961             {
7962             # don't return Unknown tags unless that option is set
7963 2061         4508 return undef;
7964             }
7965             # return the tag information we found
7966 98272         187323 return $tagInfo;
7967             }
7968             # generate information for unknown tags (numerical only) if required
7969 5166 100 100     28403 if (not $tagInfo and ($$self{OPTIONS}{Unknown} or $$self{OPTIONS}{Verbose}) and
      66        
      100        
      100        
7970             $tagID =~ /^\d+$/ and not $$self{NO_UNKNOWN})
7971             {
7972 600         883 my $printConv;
7973 600 100       1055 if (defined $$tagTablePtr{PRINT_CONV}) {
7974 155         263 $printConv = $$tagTablePtr{PRINT_CONV};
7975             } else {
7976             # limit length of printout (can be very long)
7977 445         613 $printConv = 'length($val) > 60 ? substr($val,0,55) . "[...]" : $val';
7978             }
7979 600         1737 my $hex = sprintf("0x%.4x", $tagID);
7980 600         978 my $prefix = $$tagTablePtr{TAG_PREFIX};
7981 600         1492 $tagInfo = {
7982             Name => "${prefix}_$hex",
7983             Description => MakeDescription($prefix, $hex),
7984             Unknown => 1,
7985             Writable => 0, # can't write unknown tags
7986             PrintConv => $printConv,
7987             };
7988             # add tag information to table
7989 600         1326 AddTagToTable($tagTablePtr, $tagID, $tagInfo);
7990             } else {
7991 4566         5878 undef $tagInfo;
7992             }
7993 5166         9980 return $tagInfo;
7994             }
7995              
7996             #------------------------------------------------------------------------------
7997             # Add new tag to table (must use this routine to add new tags to a table)
7998             # Inputs: 0) reference to tag table, 1) tag ID
7999             # 2) [optional] tag name or reference to tag information hash
8000             # 3) [optional] flag to avoid adding prefix when generating tag name
8001             # Returns: tagInfo ref
8002             # Notes: - will not override existing entry in table
8003             # - info need contain no entries when this routine is called
8004             # - tag name is cleaned if necessary
8005             sub AddTagToTable($$;$$)
8006             {
8007 6033     6033 0 9972 my ($tagTablePtr, $tagID, $tagInfo, $noPrefix) = @_;
8008              
8009             # generate tag info hash if necessary
8010 6033 0       10812 $tagInfo = $tagInfo ? { Name => $tagInfo } : { } unless ref $tagInfo eq 'HASH';
    50          
8011              
8012             # define necessary entries in information hash
8013 6033 100       9573 if ($$tagInfo{Groups}) {
8014             # fill in default groups from table GROUPS
8015 432         571 foreach (keys %{$$tagTablePtr{GROUPS}}) {
  432         1188  
8016 1296 100       2324 next if $$tagInfo{Groups}{$_};
8017 558         1047 $$tagInfo{Groups}{$_} = $$tagTablePtr{GROUPS}{$_};
8018             }
8019             } else {
8020 5601         6363 $$tagInfo{Groups} = { %{$$tagTablePtr{GROUPS}} };
  5601         21207  
8021             }
8022 6033 100       11991 $$tagInfo{Flags} and ExpandFlags($tagInfo);
8023             $$tagInfo{GotGroups} = 1,
8024 6033         10837 $$tagInfo{Table} = $tagTablePtr;
8025 6033         9541 $$tagInfo{TagID} = $tagID;
8026 6033 100 100     13918 if (defined $$tagTablePtr{AVOID} and not defined $$tagInfo{Avoid}) {
8027 1442         2382 $$tagInfo{Avoid} = $$tagTablePtr{AVOID};
8028             }
8029              
8030 6033         7394 my $name = $$tagInfo{Name};
8031 6033 100       9276 $name = $tagID unless defined $name;
8032 6033         10688 $name =~ tr/-_a-zA-Z0-9//dc; # remove illegal characters
8033 6033         8792 $name = ucfirst $name; # capitalize first letter
8034             # add tag-name prefix if specified and tag name not provided
8035 6033 100 100     11630 unless (defined $$tagInfo{Name} or $noPrefix or not $$tagTablePtr{TAG_PREFIX}) {
      66        
8036             # make description to prevent tagID from getting mangled by MakeDescription()
8037 22         49 $$tagInfo{Description} = MakeDescription($$tagTablePtr{TAG_PREFIX}, $name);
8038 22         48 $name = "$$tagTablePtr{TAG_PREFIX}_$name";
8039             }
8040             # tag names must be at least 2 characters long and prefer them to start with a letter
8041 6033 100 100     23271 $name = "Tag$name" if length($name) < 2 or $name !~ /^[A-Z]/i;
8042 6033         9002 $$tagInfo{Name} = $name;
8043             # add tag to table, but never override existing entries (could potentially happen
8044             # if someone thinks there isn't any tagInfo because a condition wasn't satisfied)
8045 6033 50 66     17661 unless (defined $$tagTablePtr{$tagID} or $specialTags{$tagID}) {
8046 5950         13492 $$tagTablePtr{$tagID} = $tagInfo;
8047             }
8048 6033         11280 return $tagInfo;
8049             }
8050              
8051             #------------------------------------------------------------------------------
8052             # Handle simple extraction of new tag information
8053             # Inputs: 0) ExifTool object ref, 1) tag table reference, 2) tagID, 3) value,
8054             # 4-N) parameters hash: Index, DataPt, DataPos, Base, Start, Size, Parent,
8055             # TagInfo, ProcessProc, RAF, Format, Count
8056             # Returns: tag key or undef if tag not found
8057             # Notes: if value is not defined, it is extracted from DataPt using TagInfo
8058             # Format and Count if provided
8059             sub HandleTag($$$$;%)
8060             {
8061 9343     9343 0 29863 my ($self, $tagTablePtr, $tag, $val, %parms) = @_;
8062 9343         15065 my $verbose = $$self{OPTIONS}{Verbose};
8063 9343         11536 my $pfmt = $parms{Format};
8064 9343   100     27845 my $tagInfo = $parms{TagInfo} || $self->GetTagInfo($tagTablePtr, $tag, \$val, $pfmt, $parms{Count});
8065 9343         15289 my $dataPt = $parms{DataPt};
8066 9343         12676 my ($subdir, $format, $noTagInfo, $rational);
8067              
8068 9343 100       13819 if ($tagInfo) {
8069 7236         10474 $subdir = $$tagInfo{SubDirectory};
8070             } else {
8071 2107 50       6049 return undef unless $verbose;
8072 0         0 $tagInfo = { Name => "tag $tag" }; # create temporary tagInfo hash
8073 0         0 $noTagInfo = 1;
8074             }
8075             # read value if not done already (not necessary for subdir)
8076 7236 50 66     16030 unless (defined $val or ($subdir and not $$tagInfo{Writable} and not $$tagInfo{RawConv})) {
      66        
      100        
8077 873   100     1861 my $start = $parms{Start} || 0;
8078 873 50       1652 my $dLen = $dataPt ? length($$dataPt) : -1;
8079 873         1192 my $size = $parms{Size};
8080 873 100       1560 $size = $dLen unless defined $size;
8081             # read from data in memory if possible
8082 873 50 33     2480 if ($start >= 0 and $start + $size <= $dLen) {
8083 873   100     2307 $format = $$tagInfo{Format} || $$tagTablePtr{FORMAT};
8084 873 50 100     3350 $format = $pfmt if not $format and $pfmt and $formatSize{$pfmt};
      66        
8085 873 100       1607 if ($format) {
8086 421         1238 $val = ReadValue($dataPt, $start, $format, $$tagInfo{Count}, $size, \$rational);
8087             } else {
8088 452         1033 $val = substr($$dataPt, $start, $size);
8089             }
8090             } else {
8091 0         0 $self->Warn("Error extracting value for $$tagInfo{Name}");
8092 0         0 return undef;
8093             }
8094             }
8095             # do verbose print if necessary
8096 7236 100       12137 if ($verbose) {
8097 51 50       86 undef $tagInfo if $noTagInfo;
8098 51         74 $parms{Value} = $val;
8099 51 50       80 $parms{Value} .= " ($rational)" if defined $rational;
8100 51         67 $parms{Table} = $tagTablePtr;
8101 51 50       78 if ($format) {
8102 0   0     0 my $count = int(($parms{Size} || 0) / ($formatSize{$format} || 1));
      0        
8103 0         0 $parms{Format} = $format . "[$count]";
8104             }
8105 51         169 $self->VerboseInfo($tag, $tagInfo, %parms);
8106             }
8107 7236 50       11806 if ($tagInfo) {
8108 7236 100       11735 if ($subdir) {
8109 729         1177 my $subdirStart = $parms{Start};
8110 729         1119 my $subdirLen = $parms{Size};
8111 729 100 66     2105 if ($$tagInfo{RawConv} and not $$tagInfo{Writable}) {
8112 1         2 my $conv = $$tagInfo{RawConv};
8113 1         5 local $SIG{'__WARN__'} = \&SetWarning;
8114 1         2 undef $evalWarning;
8115 1 50       4 if (ref $conv eq 'CODE') {
8116 0         0 $val = &$conv($val, $self);
8117             } else {
8118 1         1 my ($priority, @grps);
8119             # NOTE: RawConv is evaluated in Writer.pl and twice in ExifTool.pm
8120             #### eval RawConv ($self, $val, $tag, $tagInfo, $priority, @grps)
8121 1         69 $val = eval $conv;
8122 1 50       4 $@ and $evalWarning = $@;
8123             }
8124 1 50       3 $self->Warn("RawConv $tag: " . CleanWarning()) if $evalWarning;
8125 1 50       3 return undef unless defined $val;
8126 1 50       4 $val = $$val if ref $val eq 'SCALAR';
8127 1         2 $dataPt = \$val;
8128 1         2 $subdirStart = 0;
8129 1         3 $subdirLen = length $val;
8130             }
8131 729 100       1589 if ($$subdir{Start}) {
8132 8         17 my $valuePtr = 0;
8133             #### eval Start ($valuePtr)
8134 8         329 my $off = eval $$subdir{Start};
8135 8         24 $subdirStart += $off;
8136 8         18 $subdirLen -= $off;
8137             }
8138 729 100       1433 $dataPt or $dataPt = \$val;
8139             # process subdirectory information
8140             my %dirInfo = (
8141             DirName => $$subdir{DirName} || $$tagInfo{Name},
8142             DataPt => $dataPt,
8143             DataLen => length $$dataPt,
8144             DataPos => $parms{DataPos},
8145             DirStart => $subdirStart,
8146             DirLen => $subdirLen,
8147             Parent => $parms{Parent},
8148             Base => $parms{Base},
8149             Multi => $$subdir{Multi},
8150             TagInfo => $tagInfo,
8151             RAF => $parms{RAF},
8152 729   66     5628 );
8153 729         1678 my $oldOrder = GetByteOrder();
8154 729 100       1634 if ($$subdir{ByteOrder}) {
8155 3 100       11 if ($$subdir{ByteOrder} eq 'Unknown') {
8156 1 50       4 if ($subdirStart + 2 <= $subdirLen) {
8157             # attempt to determine the byte ordering of an IFD-style subdirectory
8158 1         4 my $num = Get16u($dataPt, $subdirStart);
8159 1 50 33     9 ToggleByteOrder if $num & 0xff00 and ($num>>8) > ($num&0xff);
8160             }
8161             } else {
8162 2         6 SetByteOrder($$subdir{ByteOrder});
8163             }
8164             }
8165 729   33     1740 my $subTablePtr = GetTagTable($$subdir{TagTable}) || $tagTablePtr;
8166 729   100     3874 $self->ProcessDirectory(\%dirInfo, $subTablePtr, $$subdir{ProcessProc} || $parms{ProcessProc});
8167 729         1703 SetByteOrder($oldOrder);
8168             # return now unless directory is writable as a block
8169 729 50       4655 return undef unless $$tagInfo{Writable};
8170             }
8171 6507         12104 my $key = $self->FoundTag($tagInfo, $val);
8172             # save original components of rational numbers
8173 6507 100 66     13985 $$self{RATIONAL}{$key} = $rational if defined $rational and defined $key;
8174 6507         17734 return $key;
8175             }
8176 0         0 return undef;
8177             }
8178              
8179             #------------------------------------------------------------------------------
8180             # Add tag to hash of extracted information
8181             # Inputs: 0) ExifTool object reference
8182             # 1) reference to tagInfo hash or tag name
8183             # 2) data value (or reference to require hash if Composite)
8184             # 3) optional family 0 group, 4) optional family 1 group
8185             # Returns: tag key or undef if no value
8186             sub FoundTag($$$;@)
8187             {
8188 58021     58021 0 74492 local $_;
8189 58021         92060 my ($self, $tagInfo, $value, @grps) = @_;
8190 58021         69098 my ($tag, $noListDel);
8191 58021         81453 my $options = $$self{OPTIONS};
8192              
8193 58021 100       99181 if (ref $tagInfo eq 'HASH') {
8194 50765 50       108972 $tag = $$tagInfo{Name} or warn("No tag name\n"), return undef;
8195             } else {
8196 7256         8850 $tag = $tagInfo;
8197             # look for tag in Extra
8198 7256         12112 $tagInfo = $self->GetTagInfo(GetTagTable('Image::ExifTool::Extra'), $tag);
8199             # make temporary hash if tag doesn't exist in Extra
8200             # (not advised to do this since the tag won't show in list)
8201 7256 100       12874 $tagInfo or $tagInfo = { Name => $tag, Groups => \%allGroupsExifTool };
8202 7256 100       13290 $$options{Verbose} and $self->VerboseInfo(undef, $tagInfo, Value => $value);
8203             }
8204             # get tag priority
8205 58021         73340 my $priority = $$tagInfo{Priority};
8206 58021 100       93476 unless (defined $priority) {
8207 53687         79357 $priority = $$tagInfo{Table}{PRIORITY};
8208 53687 100 100     151443 $priority = 0 if not defined $priority and $$tagInfo{Avoid};
8209             }
8210 58021 100       106247 $grps[0] or $grps[0] = $$self{SET_GROUP0};
8211 58021 100       96366 $grps[1] or $grps[1] = $$self{SET_GROUP1};
8212 58021         74478 my $valueHash = $$self{VALUE};
8213              
8214 58021 100       91768 if ($$tagInfo{RawConv}) {
8215             # initialize @val for use in Composite RawConv expressions
8216 8944         11123 my @val;
8217 8944 50 66     19868 if (ref $value eq 'HASH' and $$tagInfo{IsComposite}) {
8218 1729         3876 foreach (keys %$value) { $val[$_] = $$valueHash{$$value{$_}}; }
  5810         11915  
8219             }
8220 8944         13610 my $conv = $$tagInfo{RawConv};
8221 8944         36611 local $SIG{'__WARN__'} = \&SetWarning;
8222 8944         14552 undef $evalWarning;
8223 8944 100       15807 if (ref $conv eq 'CODE') {
8224 217         832 $value = &$conv($value, $self);
8225 217 50       893 $$self{grps} and @grps = @{$$self{grps}}, delete $$self{grps};
  0         0  
8226             } else {
8227 8727         11855 my $val = $value; # do this so eval can use $val
8228             # NOTE: RawConv is also evaluated in Writer.pl
8229             #### eval RawConv ($self, $val, $tag, $tagInfo, $priority, @grps)
8230 8727         655474 $value = eval $conv;
8231 8727 50       32371 $@ and $evalWarning = $@;
8232             }
8233 8944 50       17227 $self->Warn("RawConv $tag: " . CleanWarning()) if $evalWarning;
8234 8944 100       32451 return undef unless defined $value;
8235             }
8236             # handle duplicate tag names
8237 55511 100       120019 if (defined $$valueHash{$tag}) {
    100          
8238             # add to list if there is an active list for this tag
8239 6588 100       15667 if ($$self{LIST_TAGS}{$tagInfo}) {
8240 642         1198 $tag = $$self{LIST_TAGS}{$tagInfo}; # use key from previous list tag
8241 642 100       1318 if (defined $$self{NO_LIST}) {
8242             # accumulate list in TAG_EXTRA "NoList" element
8243 65 100       178 if (defined $$self{TAG_EXTRA}{$tag}{NoList}) {
8244 31         66 push @{$$self{TAG_EXTRA}{$tag}{NoList}}, $value;
  31         112  
8245             } else {
8246 34         122 $$self{TAG_EXTRA}{$tag}{NoList} = [ $$valueHash{$tag}, $value ];
8247             }
8248 65         120 $noListDel = 1; # set flag to delete this tag if re-listed
8249             } else {
8250 577 100       1385 if (ref $$valueHash{$tag} ne 'ARRAY') {
8251 298         828 $$valueHash{$tag} = [ $$valueHash{$tag} ];
8252             }
8253 577         773 push @{$$valueHash{$tag}}, $value;
  577         1518  
8254 577         1741 return $tag; # return without creating a new entry
8255             }
8256             }
8257             # get next available tag key
8258 6011   100     22315 my $nextInd = $$self{DUPL_TAG}{$tag} = ($$self{DUPL_TAG}{$tag} || 0) + 1;
8259 6011         13130 my $nextTag = "$tag ($nextInd)";
8260             #
8261             # take tag with highest priority
8262             #
8263             # promote existing 0-priority tag so it takes precedence over a new 0-tag
8264             # (unless old tag was a sub-document and new tag isn't. Also, never override
8265             # a Warning tag because they may be added by ValueConv, which could be confusing)
8266 6011         9837 my $oldPriority = $$self{PRIORITY}{$tag};
8267 6011 100       10265 unless ($oldPriority) {
8268 5103 100 100     25067 if ($$self{DOC_NUM} or not $$self{TAG_EXTRA}{$tag} or $tag eq 'Warning' or
      66        
      100        
8269             not $$self{TAG_EXTRA}{$tag}{G3})
8270             {
8271 5068         7094 $oldPriority = 1;
8272             } else {
8273 35         57 $oldPriority = 0; # don't promote sub-document tag over main document
8274             }
8275             }
8276             # set priority for this tag
8277 6011 100 100     22726 if (defined $priority) {
    100 33        
8278             # increase 0-priority tags if this is the priority directory
8279             $priority = 1 if not $priority and $$self{DIR_NAME} and
8280 1978 100 100     9274 $$self{DIR_NAME} eq $$self{PRIORITY_DIR};
      100        
8281             } elsif ($$self{LOW_PRIORITY_DIR}{'*'} or
8282             ($$self{DIR_NAME} and $$self{LOW_PRIORITY_DIR}{$$self{DIR_NAME}}))
8283             {
8284 411         555 $priority = 0; # default is 0 for a LOW_PRIORITY_DIR
8285             } else {
8286 3622         4632 $priority = 1; # the normal default
8287             }
8288 6011 100 100     23825 if ($priority >= $oldPriority and (not $$self{DOC_NUM} or
      100        
      100        
8289             ($$self{TAG_EXTRA}{$tag} and $$self{TAG_EXTRA}{$tag}{G3} and
8290             $$self{DOC_NUM} eq $$self{TAG_EXTRA}{$tag}{G3})) and not $noListDel)
8291             {
8292             # move existing tag out of the way since this tag is higher priority
8293             # (NOTE: any new members added here must also be added to DeleteTag())
8294 2728         7100 $$self{PRIORITY}{$nextTag} = $$self{PRIORITY}{$tag};
8295 2728         5856 $$valueHash{$nextTag} = $$valueHash{$tag};
8296 2728         5219 $$self{FILE_ORDER}{$nextTag} = $$self{FILE_ORDER}{$tag};
8297 2728         5820 my $oldInfo = $$self{TAG_INFO}{$nextTag} = $$self{TAG_INFO}{$tag};
8298 2728         4691 foreach ('TAG_EXTRA','RATIONAL') {
8299 5456 100       11787 if ($$self{$_}{$tag}) {
8300 1880         3740 $$self{$_}{$nextTag} = $$self{$_}{$tag};
8301 1880         3697 delete $$self{$_}{$tag};
8302             }
8303             }
8304 2728         4066 delete $$self{BOTH}{$tag};
8305             # update tag key for list if necessary
8306 2728 100       5838 $$self{LIST_TAGS}{$oldInfo} = $nextTag if $$self{LIST_TAGS}{$oldInfo};
8307             # update this key if used in a Composite tag
8308 2728 100       6461 if ($$self{COMP_KEYS}{$tag}) {
8309 86         128 $$_[0]{$$_[1]} = $nextTag foreach @{$$self{COMP_KEYS}{$tag}};
  86         367  
8310 86         225 $$self{COMP_KEYS}{$nextTag} = $$self{COMP_KEYS}{$tag};
8311 86         178 delete $$self{COMP_KEYS}{$tag};
8312             }
8313             } else {
8314 3283         4647 $tag = $nextTag; # don't override the existing tag
8315             }
8316 6011         12382 $$self{PRIORITY}{$tag} = $priority;
8317 6011 100       11454 $$self{TAG_EXTRA}{$tag}{NoListDel} = 1 if $noListDel;
8318             } elsif ($priority) {
8319             # set tag priority (only if exists and is non-zero)
8320 209         637 $$self{PRIORITY}{$tag} = $priority;
8321             }
8322              
8323             # save the raw value, file order, tagInfo ref, group1 name,
8324             # and tag key for lists if necessary
8325 54934         118614 $$valueHash{$tag} = $value;
8326 54934         101046 $$self{FILE_ORDER}{$tag} = ++$$self{NUM_FOUND};
8327 54934         88529 $$self{TAG_INFO}{$tag} = $tagInfo;
8328             # set dynamic groups 0, 1 and 3 if necessary
8329 54934 100       83958 $$self{TAG_EXTRA}{$tag}{G0} = $grps[0] if $grps[0];
8330 54934 100       89550 $$self{TAG_EXTRA}{$tag}{G1} = $grps[1] if $grps[1];
8331 54934 100       89185 if ($$self{DOC_NUM}) {
8332 1749         3888 $$self{TAG_EXTRA}{$tag}{G3} = $$self{DOC_NUM};
8333 1749 50       5746 if ($$self{DOC_NUM} =~ /^(\d+)/) {
8334             # keep track of maximum 1st-level sub-document number
8335 1749 100       4597 $$self{DOC_COUNT} = $1 unless $$self{DOC_COUNT} >= $1;
8336             }
8337             }
8338             # save path if requested
8339 54934 100       90889 $$self{TAG_EXTRA}{$tag}{G5} = $self->MetadataPath() if $$options{SavePath};
8340              
8341             # remember this tagInfo if we will be accumulating values in a list
8342             # (but don't override earlier list if this may be deleted by NoListDel flag)
8343 54934 100 100     101056 if ($$tagInfo{List} and not $$self{NO_LIST} and not $noListDel) {
      100        
8344 1106         3355 $$self{LIST_TAGS}{$tagInfo} = $tag;
8345             }
8346              
8347             # validate tag if requested (but only for simple values -- could result
8348             # in infinite recursion if called for a Composite tag (HASH ref value)
8349             # because FoundTag is called in the middle of building Composite tags
8350 54934 100 100     95727 if ($$options{Validate} and not ref $value) {
8351 213         526 Image::ExifTool::Validate::ValidateRaw($self, $tag, $value);
8352             }
8353              
8354 54934         120615 return $tag;
8355             }
8356              
8357             #------------------------------------------------------------------------------
8358             # Make current directory the priority directory if not set already
8359             # Inputs: 0) ExifTool object reference
8360             sub SetPriorityDir($)
8361             {
8362 22     22 0 55 my $self = shift;
8363 22 50       424 $$self{PRIORITY_DIR} = $$self{DIR_NAME} unless $$self{PRIORITY_DIR};
8364             }
8365              
8366             #------------------------------------------------------------------------------
8367             # Set family 0 or 1 group name specific to this tag instance
8368             # Inputs: 0) ExifTool ref, 1) tag key, 2) group name, 3) family (default 1)
8369             sub SetGroup($$$;$)
8370             {
8371 13200     13200 0 23182 my ($self, $tagKey, $extra, $fam) = @_;
8372 13200 50       46151 $$self{TAG_EXTRA}{$tagKey}{defined $fam ? "G$fam" : 'G1'} = $extra;
8373             }
8374              
8375             #------------------------------------------------------------------------------
8376             # Delete specified tag
8377             # Inputs: 0) ExifTool object ref, 1) tag key
8378             sub DeleteTag($$)
8379             {
8380 224     224 0 356 my ($self, $tag) = @_;
8381 224         352 delete $$self{VALUE}{$tag};
8382 224         293 delete $$self{FILE_ORDER}{$tag};
8383 224         315 delete $$self{TAG_INFO}{$tag};
8384 224         381 delete $$self{TAG_EXTRA}{$tag};
8385 224         292 delete $$self{PRIORITY}{$tag};
8386 224         285 delete $$self{RATIONAL}{$tag};
8387 224         620 delete $$self{BOTH}{$tag};
8388             }
8389              
8390             #------------------------------------------------------------------------------
8391             # Escape all elements of a value
8392             # Inputs: 0) value, 1) escape proc
8393             sub DoEscape($$)
8394             {
8395 173     173 0 208 my ($val, $key);
8396 173 100       259 if (not ref $_[0]) {
    100          
    50          
8397 167         203 $_[0] = &{$_[1]}($_[0]);
  167         312  
8398             } elsif (ref $_[0] eq 'ARRAY') {
8399 4         7 foreach $val (@{$_[0]}) {
  4         11  
8400 10         24 DoEscape($val, $_[1]);
8401             }
8402             } elsif (ref $_[0] eq 'HASH') {
8403 0         0 foreach $key (keys %{$_[0]}) {
  0         0  
8404 0         0 DoEscape($_[0]{$key}, $_[1]);
8405             }
8406             }
8407             }
8408              
8409             #------------------------------------------------------------------------------
8410             # Set the FileType and MIMEType tags
8411             # Inputs: 0) ExifTool object reference
8412             # 1) Optional file type (uses FILE_TYPE if not specified)
8413             # 2) Optional MIME type (uses our lookup if not specified)
8414             # 3) Optional recommended extension (converted to lower case; uses FileType if undef)
8415             # Notes: Will NOT set file type twice (subsequent calls ignored)
8416             sub SetFileType($;$$$)
8417             {
8418 634     634 0 1824 my ($self, $fileType, $mimeType, $normExt) = @_;
8419 634 100 66     2993 unless ($$self{VALUE}{FileType} and not $$self{DOC_NUM}) {
8420 586         1261 my $baseType = $$self{FILE_TYPE};
8421 586         1176 my $ext = $$self{FILE_EXT};
8422 586 100       1630 $fileType or $fileType = $baseType;
8423             # handle sub-types which are identified by extension
8424 586 100 100     4436 if (defined $ext and $ext ne $fileType and not $$self{DOC_NUM}) {
      66        
8425 257         907 my ($f,$e) = @fileTypeLookup{$fileType,$ext};
8426 257 100 100     1639 if (ref $f eq 'ARRAY' and ref $e eq 'ARRAY' and $$f[0] eq $$e[0]) {
      100        
8427             # make sure $fileType was a root type and not another sub-type
8428 10 100 66     68 $fileType = $ext if $$f[0] eq $fileType or not $fileTypeLookup{$$f[0]};
8429             }
8430             }
8431 586 100       2289 $mimeType or $mimeType = $mimeType{$fileType};
8432             # use base file type if necessary (except if 'TIFF', which is a special case)
8433 586 100 66     1871 $mimeType = $mimeType{$baseType} unless $mimeType or $baseType eq 'TIFF';
8434 586 100       1585 unless (defined $normExt) {
8435 576         1412 $normExt = $fileTypeExt{$fileType};
8436 576 100       1474 $normExt = $fileType unless defined $normExt;
8437             }
8438 586         1303 $$self{FileType} = $fileType;
8439 586         1894 $self->FoundTag('FileType', $fileType);
8440 586         3022 $self->FoundTag('FileTypeExtension', uc $normExt);
8441 586   100     2470 $self->FoundTag('MIMEType', $mimeType || 'application/unknown');
8442             }
8443             }
8444              
8445             #------------------------------------------------------------------------------
8446             # Override the FileType and MIMEType tags
8447             # Inputs: 0) ExifTool object ref, 1) file type, 2) MIME type, 3) normal extension
8448             # Notes: does nothing if FileType was not previously defined (ie. when writing)
8449             sub OverrideFileType($$;$$)
8450             {
8451 14     14 0 50 my ($self, $fileType, $mimeType, $normExt) = @_;
8452 14 100 66     100 if (defined $$self{VALUE}{FileType} and $fileType ne $$self{VALUE}{FileType}) {
8453 8         21 $$self{FileType} = $fileType;
8454 8         14 $$self{VALUE}{FileType} = $fileType;
8455 8 100       24 unless (defined $normExt) {
8456 5         13 $normExt = $fileTypeExt{$fileType};
8457 5 50       18 $normExt = $fileType unless defined $normExt;
8458             }
8459 8         21 $$self{VALUE}{FileTypeExtension} = uc $normExt;
8460 8 50       32 $mimeType or $mimeType = $mimeType{$fileType};
8461 8 100       23 $$self{VALUE}{MIMEType} = $mimeType if $mimeType;
8462 8 50       90 if ($$self{OPTIONS}{Verbose}) {
8463 0         0 $self->VPrint(0,"$$self{INDENT}FileType [override] = $fileType\n");
8464 0         0 $self->VPrint(0,"$$self{INDENT}FileTypeExtension [override] = $$self{VALUE}{FileTypeExtension}\n");
8465 0 0       0 $self->VPrint(0,"$$self{INDENT}MIMEType [override] = $mimeType\n") if $mimeType;
8466             }
8467             }
8468             }
8469              
8470             #------------------------------------------------------------------------------
8471             # Modify the value of the MIMEType tag
8472             # Inputs: 0) ExifTool object reference, 1) file or MIME type
8473             # Notes: combines existing type with new type: ie) a/b + c/d => c/b-d
8474             sub ModifyMimeType($;$)
8475             {
8476 8     8 0 31 my ($self, $mime) = @_;
8477 8 50 33     49 $mime =~ m{/} or $mime = $mimeType{$mime} or return;
8478 8         29 my $old = $$self{VALUE}{MIMEType};
8479 8 50       34 if (defined $old) {
8480 8         47 my ($a, $b) = split '/', $old;
8481 8         34 my ($c, $d) = split '/', $mime;
8482 8         23 $d =~ s/^x-//;
8483 8         33 $$self{VALUE}{MIMEType} = "$c/$b-$d";
8484 8         65 $self->VPrint(0, " Modified MIMEType = $c/$b-$d\n");
8485             } else {
8486 0         0 $self->FoundTag('MIMEType', $mime);
8487             }
8488             }
8489              
8490             #------------------------------------------------------------------------------
8491             # Print verbose output
8492             # Inputs: 0) ExifTool ref, 1) verbose level (prints if level > this), 2-N) print args
8493             sub VPrint($$@)
8494             {
8495 9115     9115 0 13266 my $self = shift;
8496 9115         10806 my $level = shift;
8497 9115 100 66     26443 if ($$self{OPTIONS}{Verbose} and $$self{OPTIONS}{Verbose} > $level) {
8498 4         9 my $out = $$self{OPTIONS}{TextOut};
8499 4         19 print $out @_;
8500 4 50       22 print $out "\n" unless $_[-1] =~ /\n$/;
8501             }
8502             }
8503              
8504             #------------------------------------------------------------------------------
8505             # Print verbose directory information
8506             # Inputs: 0) ExifTool object reference, 1) directory name or dirInfo ref
8507             # 2) number of entries in directory (or 0 if unknown)
8508             # 3) optional size of directory in bytes
8509             sub VerboseDir($$;$$)
8510             {
8511 449     449 0 987 my ($self, $name, $entries, $size) = @_;
8512 449 100       1309 return unless $$self{OPTIONS}{Verbose};
8513 44 50       92 if (ref $name eq 'HASH') {
8514 0 0       0 $size = $$name{DirLen} unless $size;
8515 0   0     0 $name = $$name{Name} || $$name{DirName};
8516             }
8517 44         102 my $indent = substr($$self{INDENT}, 0, -2);
8518 44         71 my $out = $$self{OPTIONS}{TextOut};
8519 44 100 66     177 my $str = ($entries or defined $entries and not $size) ? " with $entries entries" : '';
8520 44 100       103 $str .= ", $size bytes" if $size;
8521 44         152 print $out "$indent+ [$name directory$str]\n";
8522             }
8523              
8524             #------------------------------------------------------------------------------
8525             # Verbose dump
8526             # Inputs: 0) ExifTool ref, 1) data ref, 2-N) HexDump options
8527             sub VerboseDump($$;%)
8528             {
8529 128     128 0 188 my $self = shift;
8530 128         153 my $dataPt = shift;
8531 128         195 my $verbose = $$self{OPTIONS}{Verbose};
8532 128 50 33     394 if ($verbose and $verbose > 2) {
8533             my %parms = (
8534             Prefix => $$self{INDENT},
8535             Out => $$self{OPTIONS}{TextOut},
8536 0 0       0 MaxLen => $verbose < 4 ? 96 : $verbose < 5 ? 2048 : undef,
    0          
8537             );
8538 0         0 HexDump($dataPt, undef, %parms, @_);
8539             }
8540             }
8541              
8542             #------------------------------------------------------------------------------
8543             # Print data in hex
8544             # Inputs: 0) data
8545             # Returns: hex string
8546             # (this is a convenience function for use in debugging PrintConv statements)
8547             sub PrintHex($)
8548             {
8549 0     0 0 0 my $val = shift;
8550 0         0 return join(' ', unpack('H2' x length($val), $val));
8551             }
8552              
8553             #------------------------------------------------------------------------------
8554             # Extract binary data from file
8555             # 0) ExifTool object reference, 1) offset, 2) length, 3) tag name if conditional
8556             # Returns: binary data, or undef on error
8557             # Notes: Returns "Binary data #### bytes" instead of data unless tag is
8558             # specifically requested or the Binary option is set
8559             sub ExtractBinary($$$;$)
8560             {
8561 47     47 0 142 my ($self, $offset, $length, $tag) = @_;
8562 47         84 my ($isPreview, $buff);
8563              
8564 47 100       123 if ($tag) {
8565 43 100       121 if ($tag eq 'PreviewImage') {
8566             # save PreviewImage start/length in case we want to dump trailer
8567 29         89 $$self{PreviewImageStart} = $offset;
8568 29         67 $$self{PreviewImageLength} = $length;
8569 29         67 $isPreview = 1;
8570             }
8571 43         108 my $lcTag = lc $tag;
8572 43 50 66     416 if ((not $$self{OPTIONS}{Binary} or $$self{EXCL_TAG_LOOKUP}{$lcTag}) and
      66        
      66        
8573             not $$self{OPTIONS}{Verbose} and not $$self{REQ_TAG_LOOKUP}{$lcTag})
8574             {
8575 34         159 return "Binary data $length bytes";
8576             }
8577             }
8578 13 100 66     83 unless ($$self{RAF}->Seek($offset,0)
8579             and $$self{RAF}->Read($buff, $length) == $length)
8580             {
8581 5 50       17 $tag or $tag = 'binary data';
8582 5 50 33     37 if ($isPreview and not $$self{BuildingComposite}) {
8583 0         0 $$self{PreviewError} = 1;
8584             } else {
8585 5         26 $self->Warn("Error reading $tag from file", $isPreview);
8586             }
8587 5         21 return undef;
8588             }
8589 8         30 return $buff;
8590             }
8591              
8592             #------------------------------------------------------------------------------
8593             # Process binary data
8594             # Inputs: 0) ExifTool object ref, 1) directory information ref, 2) tag table ref
8595             # Returns: 1 on success
8596             # Notes: dirInfo may contain VarFormatData (reference to empty list) to return
8597             # details about any variable-length-format tags in the table (used when writing)
8598             sub ProcessBinaryData($$$)
8599             {
8600 2055     2055 0 3860 my ($self, $dirInfo, $tagTablePtr) = @_;
8601 2055         3444 my $dataPt = $$dirInfo{DataPt};
8602 2055   100     5127 my $offset = $$dirInfo{DirStart} || 0;
8603 2055   66     4385 my $size = $$dirInfo{DirLen} || (length($$dataPt) - $offset);
8604 2055   100     5099 my $base = $$dirInfo{Base} || 0;
8605 2055         3785 my $verbose = $$self{OPTIONS}{Verbose};
8606 2055         3210 my $unknown = $$self{OPTIONS}{Unknown};
8607 2055   100     5175 my $dataPos = $$dirInfo{DataPos} || 0;
8608              
8609             # get default format ('int8u' unless specified)
8610 2055   100     6655 my $defaultFormat = $$tagTablePtr{FORMAT} || 'int8u';
8611 2055         3689 my $increment = $formatSize{$defaultFormat};
8612 2055 50       4033 unless ($increment) {
8613 0         0 warn "Unknown format $defaultFormat\n";
8614 0         0 $defaultFormat = 'int8u';
8615 0         0 $increment = $formatSize{$defaultFormat};
8616             }
8617             # prepare list of tag numbers to extract
8618 2055         3379 my (@tags, $topIndex);
8619 2055 50 33     7752 if ($unknown > 1 and defined $$tagTablePtr{FIRST_ENTRY}) {
    100          
    100          
8620             # don't create a stupid number of tags if data is huge
8621 0 0       0 my $sizeLimit = $size < 65536 ? $size : 65536;
8622             # scan through entire binary table
8623 0         0 $topIndex = int($sizeLimit/$increment);
8624 0         0 @tags = ($$tagTablePtr{FIRST_ENTRY}..($topIndex - 1));
8625             # add in floating point tag ID's if they exist
8626 0         0 my @ftags = grep /\./, TagTableKeys($tagTablePtr);
8627 0 0       0 @tags = sort { $a <=> $b } @tags, @ftags if @ftags;
  0         0  
8628             } elsif ($$dirInfo{DataMember}) {
8629 189         289 @tags = @{$$dirInfo{DataMember}};
  189         527  
8630 189         371 $verbose = 0; # no verbose output of extracted values when writing
8631             } elsif ($$dirInfo{MixedTags}) {
8632             # process sorted integer-ID tags only
8633 38         105 @tags = sort { $a <=> $b } grep /^\d+$/, TagTableKeys($tagTablePtr);
  407         595  
8634             } else {
8635             # extract known tags in numerical order
8636 1828 50       4074 @tags = sort { ($a < 0 ? $a + 1e9 : $a) <=> ($b < 0 ? $b + 1e9 : $b) } TagTableKeys($tagTablePtr);
  54108 50       85237  
8637             }
8638 2055 100       5789 $self->VerboseDir('BinaryData', undef, $size) if $verbose;
8639             # avoid creating unknown tags for tags that fail condition if Unknown is 1
8640 2055 50       5685 $$self{NO_UNKNOWN} = 1 if $unknown < 2;
8641 2055         2939 my ($index, %val);
8642 2055         2732 my $nextIndex = 0;
8643 2055         2733 my $varSize = 0;
8644 2055         3334 foreach $index (@tags) {
8645 17157         23092 my ($tagInfo, $val, $saveNextIndex, $len, $mask, $wasVar, $rational);
8646 17157 50 0     31740 if ($$tagTablePtr{$index}) {
    0          
8647 17157         30927 $tagInfo = $self->GetTagInfo($tagTablePtr, $index);
8648 17157 100       29251 unless ($tagInfo) {
8649 687 100       1454 next unless defined $tagInfo;
8650 44         102 my $entry = int($index) * $increment + $varSize;
8651 44 50       156 if ($entry < 0) {
8652 0         0 $entry += $size;
8653 0 0       0 next if $entry < 0;
8654             }
8655 44 100       165 next if $entry >= $size;
8656 4         10 my $more = $size - $entry;
8657 4 50       13 $more = 128 if $more > 128;
8658 4         14 my $v = substr($$dataPt, $entry+$offset, $more);
8659 4         11 $tagInfo = $self->GetTagInfo($tagTablePtr, $index, \$v);
8660 4 50       16 next unless $tagInfo;
8661             }
8662             next if $$tagInfo{Unknown} and
8663 16474 100 66     29417 ($$tagInfo{Unknown} > $unknown or $index < $nextIndex);
      66        
8664             } elsif ($topIndex and $$tagTablePtr{$index - $topIndex}) {
8665 0 0       0 $tagInfo = $self->GetTagInfo($tagTablePtr, $index - $topIndex) or next;
8666             } else {
8667             # don't generate unknown tags in binary tables unless Unknown > 1
8668 0 0       0 next unless $unknown > 1;
8669 0 0       0 next if $index < $nextIndex; # skip if data already used
8670 0 0       0 $tagInfo = $self->GetTagInfo($tagTablePtr, $index) or next;
8671 0         0 $$tagInfo{Unknown} = 2; # set unknown to 2 for binary unknowns
8672             }
8673             # get relative offset of this entry
8674 16473         24373 my $entry = int($index) * $increment + $varSize;
8675             # allow negative indices to represent bytes from end
8676 16473 50       25711 if ($entry < 0) {
8677 0         0 $entry += $size;
8678 0 0       0 next if $entry < 0;
8679             }
8680 16473         20065 my $more = $size - $entry;
8681 16473 100       25814 last if $more <= 0; # all done if we have reached the end of data
8682 16214         19128 my $count = 1;
8683 16214         23982 my $format = $$tagInfo{Format};
8684 16214 100       34878 if (not $format) {
    100          
    50          
    100          
8685 9366         12729 $format = $defaultFormat;
8686             } elsif ($format eq 'string') {
8687             # string with no specified count runs to end of block
8688 104         185 $count = $more;
8689             } elsif ($format eq 'pstring') {
8690 0         0 $format = 'string';
8691 0         0 $count = Get8u($dataPt, ($entry++)+$offset);
8692 0         0 --$more;
8693             } elsif (not $formatSize{$format}) {
8694 3120 100       13439 if ($format =~ /(.*)\[(.*)\]/) {
    50          
8695             # handle format count field
8696 2935         6525 $format = $1;
8697 2935         4538 $count = $2;
8698             # evaluate count to allow count to be based on previous values
8699             #### eval Format size (%val, $size, $self)
8700 2935         106918 $count = eval $count;
8701 2935 50       9576 $@ and warn("Format $$tagInfo{Name}: $@"), next;
8702 2935 50       5921 next if $count < 0;
8703             # allow a variable-length value of any format
8704             # (note: the next incremental index points to data immediately after
8705             # this value, regardless of the size of this value, even if it is zero)
8706 2935 50       6016 if ($format =~ s/^var_//) {
8707 0   0     0 $varSize += $count * ($formatSize{$format} || 1) - $increment;
8708 0         0 $wasVar = 1;
8709             # save variable size data if required for writing
8710 0 0       0 if ($$dirInfo{VarFormatData}) {
8711 0         0 push @{$$dirInfo{VarFormatData}}, [ $index, $varSize, $format ];
  0         0  
8712             }
8713             # don't extract value if large and we wanted it just to get
8714             # the variable-format information when writing
8715 0 0 0     0 next if $$tagInfo{LargeTag} and $$dirInfo{VarFormatData};
8716             }
8717             } elsif ($format =~ /^var_/) {
8718             # handle variable-length string formats
8719 185         400 $format = substr($format, 4);
8720 185         511 pos($$dataPt) = $entry + $offset;
8721 185         356 undef $count;
8722 185 50 100     911 if ($format eq 'ustring') {
    50          
    100          
    100          
    100          
    50          
8723 0 0       0 $count = pos($$dataPt) - ($entry+$offset) if $$dataPt =~ /\G(..)*?\0\0/sg;
8724 0         0 $varSize -= 2; # ($count includes base size of 2 bytes)
8725             } elsif ($format eq 'pstring') {
8726 0         0 $count = Get8u($dataPt, ($entry++)+$offset);
8727 0         0 --$more;
8728             } elsif ($format eq 'pstr32' or $format eq 'ustr32') {
8729 170 50       335 last if $more < 4;
8730 170         356 $count = Get32u($dataPt, $entry + $offset);
8731 170 100       451 $count *= 2 if $format eq 'ustr32';
8732 170         253 $entry += 4;
8733 170         232 $more -= 4;
8734 170         345 $nextIndex += 4 / $increment; # (increment next index for int32u)
8735             } elsif ($format eq 'int16u') {
8736             # int16u size of binary data to follow
8737 10 50       25 last if $more < 2;
8738 10         23 $count = Get16u($dataPt, $entry + $offset) + 2;
8739 10         15 $varSize -= 2; # ($count includes size word)
8740 10         20 $format = 'undef';
8741             } elsif ($format eq 'ue7') {
8742 3         14 require Image::ExifTool::BPG;
8743 3         10 ($val, $count) = Image::ExifTool::BPG::Get_ue7($dataPt, $entry + $offset);
8744 3 50       7 last unless defined $val;
8745 3         4 --$varSize; # ($count includes base size of 1 byte)
8746             } elsif ($$dataPt =~ /\0/g) {
8747 2         5 $count = pos($$dataPt) - ($entry+$offset);
8748 2         2 --$varSize; # ($count includes base size of 1 byte)
8749             }
8750 185 50 33     647 $count = $more if not defined $count or $count > $more;
8751 185         252 $varSize += $count; # shift subsequent indices
8752 185 100       360 unless (defined $val) {
8753 182         395 $val = substr($$dataPt, $entry+$offset, $count);
8754 182 100 66     789 $val = $self->Decode($val, 'UCS2') if $format eq 'ustring' or $format eq 'ustr32';
8755 182 100       491 $val =~ s/\0.*//s unless $format eq 'undef'; # truncate at null
8756             }
8757 185         258 $wasVar = 1;
8758             # save variable size data if required for writing
8759 185 100       420 if ($$dirInfo{VarFormatData}) {
8760 5         8 push @{$$dirInfo{VarFormatData}}, [ $index, $varSize, $format ];
  5         18  
8761             }
8762             }
8763             }
8764             # hook to allow format, etc to be set dynamically
8765 16214 100       27432 if (defined $$tagInfo{Hook}) {
8766 540         725 my $oldVarSize = $varSize;
8767 540         685 my $pos = $entry + $offset;
8768             #### eval Hook ($format, $varSize, $size, $dataPt, $pos)
8769 540         28011 eval $$tagInfo{Hook};
8770             # save variable size data if required for writing (in case changed by Hook)
8771 540 100 66     2391 if ($$dirInfo{VarFormatData}) {
    50          
8772 247 50       481 $#{$$dirInfo{VarFormatData}} -= 1 if $wasVar; # remove previous entry for this tag
  0         0  
8773 247         315 push @{$$dirInfo{VarFormatData}}, [ $index, $varSize, $format ];
  247         845  
8774             } elsif ($varSize != $oldVarSize and $verbose > 2) {
8775 0         0 my ($tmp, $sign) = ($varSize, '+');
8776 0 0       0 $tmp < 0 and $tmp = -$tmp, $sign = '-';
8777 0         0 $self->VPrint(2, sprintf("$$self{INDENT}\[offsets adjusted by ${sign}0x%.4x after 0x%.4x $$tagInfo{Name}]\n", $tmp, $index));
8778             }
8779             }
8780 16214 50       25524 if ($unknown > 1) {
8781             # calculate next valid index for unknown tag
8782 0         0 my $ni = int $index;
8783 0 0 0     0 $ni += (($formatSize{$format} || 1) * $count) / $increment unless $wasVar;
8784 0         0 $saveNextIndex = $nextIndex;
8785 0 0       0 $nextIndex = $ni unless $nextIndex > $ni;
8786             }
8787             # allow large tags to be excluded from extraction
8788             # (provides a work-around for some tight memory situations)
8789 16214 50 33     29238 next if $$tagInfo{LargeTag} and $$self{EXCL_TAG_LOOKUP}{lc $$tagInfo{Name}};
8790             # read value now if necessary
8791 16214 100 66     28748 unless (defined $val and not $$tagInfo{SubDirectory}) {
8792 16029         31276 $val = ReadValue($dataPt, $entry+$offset, $format, $count, $more, \$rational);
8793 16029 50       26692 next unless defined $val;
8794 16029         22172 $mask = $$tagInfo{Mask};
8795 16029 100       25609 $val = ($val & $mask) >> $$tagInfo{BitShift} if $mask;
8796             }
8797 16214 100 66     27356 if ($verbose and not $$tagInfo{Hidden}) {
8798 198 50 33     1589 if (not $$tagInfo{SubDirectory} or $$tagInfo{Format}) {
8799 198   50     385 $len = $count * ($formatSize{$format} || 1);
8800 198 50       326 $len = $more if $len > $more;
8801             } else {
8802 0         0 $len = $more;
8803             }
8804 198 50       704 $self->VerboseInfo($index, $tagInfo,
8805             Table => $tagTablePtr,
8806             Value => $val,
8807             DataPt => $dataPt,
8808             Size => $len,
8809             Start => $entry+$offset,
8810             Addr => $entry+$offset+$base+$dataPos,
8811             Format => $format,
8812             Count => $count,
8813             Extra => $mask ? sprintf(', mask 0x%.2x',$mask) : undef,
8814             );
8815             }
8816             # parse nested BinaryData directories
8817 16214 100       27070 if ($$tagInfo{SubDirectory}) {
8818 14         38 my $subdir = $$tagInfo{SubDirectory};
8819 14         47 my $subTablePtr = GetTagTable($$subdir{TagTable});
8820             # use specified subdirectory length if given
8821 14 100 66     124 if ($$tagInfo{Format} and $formatSize{$format}) {
8822 12         30 $len = $count * $formatSize{$format};
8823 12 50       40 $len = $more if $len > $more;
8824             } else {
8825 2         4 $len = $more; # directory size is all of remaining data
8826 2 50 33     14 if ($$subTablePtr{PROCESS_PROC} and
8827             $$subTablePtr{PROCESS_PROC} eq \&ProcessBinaryData)
8828             {
8829             # the rest of the data will be printed in the subdirectory
8830 2         7 $nextIndex = $size / $increment;
8831             }
8832             }
8833 14         26 my $subdirBase = $base;
8834 14 50       43 if (defined $$subdir{Base}) {
8835             #### eval Base ($start,$base)
8836 0         0 my $start = $entry + $offset + $dataPos;
8837 0         0 $subdirBase = eval($$subdir{Base}) + $base;
8838             }
8839 14   50     72 my $start = $$subdir{Start} || 0;
8840 14         96 my %subdirInfo = (
8841             DataPt => $dataPt,
8842             DataPos => $dataPos,
8843             DataLen => length $$dataPt,
8844             DirStart => $entry + $offset + $start,
8845             DirLen => $len - $start,
8846             Base => $subdirBase,
8847             );
8848 14         36 delete $$self{NO_UNKNOWN};
8849 14         117 $self->ProcessDirectory(\%subdirInfo, $subTablePtr, $$subdir{ProcessProc});
8850 14 50       75 $$self{NO_UNKNOWN} = 1 if $unknown < 2;
8851 14         54 next;
8852             }
8853 16200 100 66     28860 if ($$tagInfo{IsOffset} and $$tagInfo{IsOffset} ne '3') {
8854 38         62 my $et = $self;
8855             #### eval IsOffset ($val, $et)
8856 38 100       2165 $val += $base + $$self{BASE} if eval $$tagInfo{IsOffset};
8857             }
8858 16200         28013 $val{$index} = $val;
8859 16200         17520 my $oldBase;
8860 16200 50       25901 if ($$tagInfo{SetBase}) {
8861 0         0 $oldBase = $$self{BASE};
8862 0         0 $$self{BASE} += $base;
8863             }
8864 16200         31197 my $key = $self->FoundTag($tagInfo,$val);
8865 16200 50       28096 $$self{BASE} = $oldBase if defined $oldBase;
8866 16200 100       23390 if ($key) {
8867 14861 100       31130 $$self{RATIONAL}{$key} = $rational if defined $rational;
8868             } else {
8869             # don't increment nextIndex if we didn't extract a tag
8870 1339 50       3444 $nextIndex = $saveNextIndex if defined $saveNextIndex;
8871             }
8872             }
8873 2055         4501 delete $$self{NO_UNKNOWN};
8874 2055         8679 return 1;
8875             }
8876              
8877             #..............................................................................
8878             # Load .ExifTool_config file from user's home directory
8879             # (use of noConfig is now deprecated, use configFile = '' instead)
8880             until ($Image::ExifTool::noConfig) {
8881             my $config = $Image::ExifTool::configFile;
8882             my $file;
8883             if (not defined $config) {
8884             $config = '.ExifTool_config';
8885             # get our home directory (HOMEDRIVE and HOMEPATH are used in Windows cmd shell)
8886             my $home = $ENV{EXIFTOOL_HOME} || $ENV{HOME} ||
8887             ($ENV{HOMEDRIVE} || '') . ($ENV{HOMEPATH} || '') || '.';
8888             # look for the config file in 1) the home directory, 2) the program dir
8889             $file = "$home/$config";
8890             } else {
8891             length $config or last; # filename of "" disables configuration
8892             $file = $config;
8893             }
8894             # also check executable directory unless path is absolute
8895             $exeDir = ($0 =~ /(.*)[\\\/]/) ? $1 : '.' unless defined $exeDir;
8896             -r $file or $config =~ /^\// or $file = "$exeDir/$config";
8897             unless (-r $file) {
8898             warn("Config file not found\n") if defined $Image::ExifTool::configFile;
8899             last;
8900             }
8901             unshift @INC, '.'; # look in current directory first
8902             eval { require $file }; # load the config file
8903             shift @INC;
8904             # print warning (minus "Compilation failed" part)
8905             $@ and $_=$@, s/Compilation failed.*//s, warn $_;
8906             last;
8907             }
8908             # read user-defined lenses (may have been defined by script instead of config file)
8909             if (@Image::ExifTool::UserDefined::Lenses) {
8910             foreach (@Image::ExifTool::UserDefined::Lenses) {
8911             $Image::ExifTool::userLens{$_} = 1;
8912             }
8913             }
8914             # add user-defined file types
8915             if (%Image::ExifTool::UserDefined::FileTypes) {
8916             foreach (sort keys %Image::ExifTool::UserDefined::FileTypes) {
8917             my $fileInfo = $Image::ExifTool::UserDefined::FileTypes{$_};
8918             my $type = uc $_;
8919             ref $fileInfo eq 'HASH' or $fileTypeLookup{$type} = $fileInfo, next;
8920             my $baseType = $$fileInfo{BaseType};
8921             if ($baseType) {
8922             if ($$fileInfo{Description}) {
8923             $fileTypeLookup{$type} = [ $baseType, $$fileInfo{Description} ];
8924             } else {
8925             $fileTypeLookup{$type} = $baseType;
8926             }
8927             if (defined $$fileInfo{Writable} and not $$fileInfo{Writable}) {
8928             # first make sure we are using an actual base type and not a derived type
8929             $baseType = $fileTypeLookup{$baseType} while $baseType and not ref $fileTypeLookup{$baseType};
8930             # mark this type as not writable
8931             $noWriteFile{$baseType} or $noWriteFile{$baseType} = [ ];
8932             push @{$noWriteFile{$baseType}}, $type;
8933             }
8934             } else {
8935             $fileTypeLookup{$type} = [ $type, $$fileInfo{Description} || $type ];
8936             $moduleName{$type} = 0; # not supported
8937             if ($$fileInfo{Magic}) {
8938             $magicNumber{$type} = $$fileInfo{Magic};
8939             push @fileTypes, $type unless grep /^$type$/, @fileTypes;
8940             }
8941             }
8942             $mimeType{$type} = $$fileInfo{MIMEType} if defined $$fileInfo{MIMEType};
8943             }
8944             }
8945              
8946             #------------------------------------------------------------------------------
8947             1; # end