File Coverage

blib/lib/Image/ExifTool.pm
Criterion Covered Total %
statement 3185 4351 73.2
branch 2028 3354 60.4
condition 908 1746 52.0
subroutine 159 177 89.8
pod 26 160 16.2
total 6306 9788 64.4


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-2026, 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 113     113   725049 use strict;
  113         180  
  113         5415  
19             require 5.004; # require 5.004 for UNIVERSAL::isa (otherwise 5.002 would do)
20             require Exporter;
21 113     113   51293 use File::RandomAccess;
  113         279  
  113         6433  
22 113     113   72164 use overload;
  113         168573  
  113         738  
23              
24 113         718535 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 113     113   9102 %static_vars $advFmtSelf $configFile @configFiles $noConfig);
  113         198  
31              
32             $VERSION = '13.55';
33             $RELEASE = '';
34             @ISA = qw(Exporter);
35             %EXPORT_TAGS = (
36             # all public non-object-oriented functions:
37             Public => [qw(
38             ImageInfo AvailableOptions GetTagName GetShortcuts GetAllTags
39             GetWritableTags GetAllGroups GetDeleteGroups GetFileType CanWrite
40             CanCreate AddUserDefinedTags OrderedKeys
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 Get64s 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             sub SetAlternateFile($$$);
79             # non-public routines below
80             sub InsertTagValues($$;$$$$);
81             sub IsWritable($);
82             sub IsSameFile($$$);
83             sub IsRawType($);
84             sub GetNewFileName($$);
85             sub LoadAllTables();
86             sub GetNewTagInfoList($;$);
87             sub GetNewTagInfoHash($@);
88             sub GetLangInfo($$);
89             sub Get64s($$);
90             sub Get64u($$);
91             sub GetFixed64s($$);
92             sub GetExtended($$);
93             sub Set64u(@);
94             sub Set64s(@);
95             sub DecodeBits($$;$);
96             sub EncodeBits($$;$$);
97             sub Filter($$$);
98             sub HexDump($;$%);
99             sub DumpTrailer($$);
100             sub DumpUnknownTrailer($$);
101             sub VerboseInfo($$$%);
102             sub VerboseValue($$$;$);
103             sub VPrint($$@);
104             sub Rationalize($;$);
105             sub Write($@);
106             sub GetGeolocateTags($$;$);
107             sub WriteTrailerBuffer($$$);
108             sub AddNewTrailers($;@);
109             sub Tell($);
110             sub WriteValue($$;$$$$);
111             sub WriteDirectory($$$;$);
112             sub WriteBinaryData($$$);
113             sub CheckBinaryData($$$);
114             sub WriteTIFF($$$);
115             sub PackUTF8(@);
116             sub UnpackUTF8($);
117             sub SetPreferredByteOrder($;$);
118             sub ImageDataHash($$$;$$);
119             sub CopyBlock($$$);
120             sub CopyFileAttrs($$$);
121             sub TimeNow(;$$);
122             sub InverseDateTime($$;$$);
123             sub NewGUID();
124             sub MakeTiffHeader($$$$;$$);
125              
126             # other subroutine definitions
127             sub SplitFileName($);
128             sub EncodeFileName($$;$);
129             sub WindowsLongPath($$);
130             sub Open($*$;$);
131             sub Exists($$;$);
132             sub IsDirectory($$);
133             sub Rename($$$);
134             sub Unlink($@);
135             sub SetFileTime($$;$$$$);
136             sub DoEscape($$);
137             sub ConvertFileSize($;$);
138             sub ParseArguments($;@); #(defined in attempt to avoid mod_perl problem)
139             sub ReadValue($$$;$$$);
140              
141             # list of main tag tables to load in LoadAllTables() (sub-tables are recursed
142             # automatically). Note: They will appear in this order in the documentation
143             # unless tweaked in BuildTagLookup::GetTableOrder().
144             @loadAllTables = qw(
145             PhotoMechanic Exif GeoTiff CanonRaw KyoceraRaw Lytro MinoltaRaw PanasonicRaw
146             SigmaRaw JPEG GIMP Jpeg2000 GIF BMP BMP::OS2 BMP::Extra BPG BPG::Extensions
147             WPG ICO PICT PNG MNG FLIF DjVu DPX OpenEXR ZISRAW MRC LIF MRC::FEI12 MIFF
148             PCX PGF PSP PhotoCD Radiance Other::PFM PDF PostScript Photoshop::Header
149             Photoshop::Layers Photoshop::ImageData FujiFilm::RAFHeader FujiFilm::RAF
150             FujiFilm::IFD FujiFilm::MRAW Samsung::Trailer Sony::SRF2 Sony::SR2SubIFD
151             Sony::PMP ITC ID3 ID3::Lyrics3 FLAC AAC Ogg Vorbis DSF WavPack APE
152             APE::NewHeader APE::OldHeader Audible MPC MPEG::Audio MPEG::Video MPEG::Xing
153             M2TS QuickTime QuickTime::ImageFile QuickTime::Stream QuickTime::Tags360Fly
154             Matroska Matroska::StdTag MOI MXF DV Flash Flash::FLV Real::Media
155             Real::Audio Real::Metafile Red RIFF AIFF ASF TNEF WTV DICOM FITS XISF MIE
156             JSON HTML XMP::SVG Palm Palm::MOBI Palm::EXTH Torrent EXE EXE::PEVersion
157             EXE::PEString EXE::DebugRSDS EXE::DebugNB10 EXE::Misc EXE::MachO EXE::PEF
158             EXE::ELF EXE::AR EXE::CHM LNK LNK::INI PCAP Font VCard Text VCard::VCalendar
159             VCard::VNote RSRC Rawzor ZIP ZIP::GZIP ZIP::RAR ZIP::RAR5 RTF OOXML iWork
160             ISO FLIR::AFF FLIR::FPF MacOS MacOS::MDItem FlashPix::DocTable
161             );
162              
163             # alphabetical list of current Lang modules
164             @langs = qw(cs de en en_ca en_gb es fi fr it ja ko nl pl ru sk sv tr zh_cn zh_tw);
165              
166             $defaultLang = 'en'; # default language
167              
168             # language names
169             %langName = (
170             cs => 'Czech (Čeština)',
171             de => 'German (Deutsch)',
172             en => 'English',
173             en_ca => 'Canadian English',
174             en_gb => 'British English',
175             es => 'Spanish (Español)',
176             fi => 'Finnish (Suomi)',
177             fr => 'French (Français)',
178             it => 'Italian (Italiano)',
179             ja => 'Japanese (日本語)',
180             ko => 'Korean (한국어)',
181             nl => 'Dutch (Nederlands)',
182             pl => 'Polish (Polski)',
183             ru => 'Russian (Русский)',
184             sk => 'Slovak (Slovenčina)',
185             sv => 'Swedish (Svenska)',
186             'tr'=> 'Turkish (Türkçe)',
187             zh_cn => 'Simplified Chinese (简体中文)',
188             zh_tw => 'Traditional Chinese (繁體中文)',
189             );
190              
191             # recognized file types, in the order we test unknown files
192             # Notes: 1) There is no need to test for like types separately here
193             # 2) Put types with weak file signatures at end of list to avoid false matches
194             # 3) PLIST must be in this list for the binary PLIST format, although it may
195             # cause a file to be checked twice for XML
196             @fileTypes = qw(JPEG EXV CRW DR4 TIFF GIF MRW RAF X3F JP2 PNG MIE MIFF PS PDF
197             PSD XMP BMP WPG BPG PPM WV RIFF AIFF ASF MOV MPEG Real SWF PSP
198             FLV OGG FLAC APE MPC MKV MXF DV PMP IND PGF ICC ITC FLIR FLIF
199             FPF LFP HTML VRD RTF FITS XISF XCF DSF DSS QTIF FPX PICT ZIP
200             GZIP PLIST RAR 7Z BZ2 CZI TAR EXE EXR HDR CHM LNK WMF AVC DEX
201             DPX RAW Font JUMBF RSRC M2TS MacOS PHP PCX DCX DWF DWG DXF WTV
202             Torrent VCard LRI R3D AA PDB PFM2 MRC LIF JXL MOI ISO ALIAS PCAP
203             JSON MP3 KVAR TNEF DICOM PCD NKA ICO TXT AAC);
204              
205             # file types that we can write (edit)
206             my @writeTypes = qw(JPEG TIFF GIF CRW MRW ORF RAF RAW PNG MIE PSD XMP PPM EPS
207             X3F PS PDF ICC VRD DR4 JP2 JXL EXIF AI AIT IND MOV EXV FLIF
208             RIFF);
209             my %writeTypes; # lookup for writable file types (hash filled if required)
210              
211             # file extensions that we can't write for various base types
212             # (See here for 3FR reason: https://exiftool.org/forum/index.php?msg=17570)
213             %noWriteFile = (
214             TIFF => [ qw(3FR DCR K25 KDC SRF) ],
215             XMP => [ qw(SVG INX NXD) ],
216             JP2 => [ qw(J2C JPC) ],
217             MOV => [ qw(INSV) ],
218             );
219             # file extensions that we can only write for various base types
220             my %onlyWriteFile = ( RIFF => [ qw(WEBP) ] );
221              
222             # file types that we can create from scratch
223             # - must update CanCreate() documentation if this list is changed!
224             my %createTypes = map { $_ => 1 } qw(XMP ICC MIE VRD DR4 EXIF EXV);
225              
226             # file type lookup for all recognized file extensions (upper case)
227             # (if extension may be more than one type, the type is a list where
228             # the writable type should come first if it exists)
229             %fileTypeLookup = (
230             '360' => ['MOV', 'GoPro 360 video'],
231             '3FR' => ['TIFF', 'Hasselblad RAW format'],
232             '3G2' => ['MOV', '3rd Gen. Partnership Project 2 audio/video'],
233             '3GP' => ['MOV', '3rd Gen. Partnership Project audio/video'],
234             '3GP2'=> '3G2',
235             '3GPP'=> '3GP',
236             '7Z' => ['7Z', '7z archive'],
237             A => ['EXE', 'Static library'],
238             AA => ['AA', 'Audible Audiobook'],
239             AAC => ['AAC', 'Advanced Audio Coding'],
240             AAE => ['PLIST','Apple edit information'],
241             AAX => ['MOV', 'Audible Enhanced Audiobook'],
242             ACR => ['DICOM','American College of Radiology ACR-NEMA'],
243             ACFM => ['Font', 'Adobe Composite Font Metrics'],
244             AFM => ['Font', 'Adobe Font Metrics'],
245             AMFM => ['Font', 'Adobe Multiple Master Font Metrics'],
246             AI => [['PDF','PS'], 'Adobe Illustrator'],
247             AIF => 'AIFF',
248             AIFC => ['AIFF', 'Audio Interchange File Format Compressed'],
249             AIFF => ['AIFF', 'Audio Interchange File Format'],
250             AIT => 'AI',
251             ALIAS=> ['ALIAS','MacOS file alias'],
252             APE => ['APE', "Monkey's Audio format"],
253             APNG => ['PNG', 'Animated Portable Network Graphics'],
254             ARW => ['TIFF', 'Sony Alpha RAW format'],
255             ARQ => ['TIFF', 'Sony Alpha Pixel-Shift RAW format'],
256             ASF => ['ASF', 'Microsoft Advanced Systems Format'],
257             AVC => ['AVC', 'Advanced Video Connection'], # (extensions are actually _AU,_AD,_IM,_ID)
258             AVI => ['RIFF', 'Audio Video Interleaved'],
259             AVIF => ['MOV', 'AV1 Image File Format'],
260             AZW => 'MOBI', # (see http://wiki.mobileread.com/wiki/AZW)
261             AZW3 => 'MOBI',
262             BMP => ['BMP', 'Windows Bitmap'],
263             BPG => ['BPG', 'Better Portable Graphics'],
264             BTF => ['BTF', 'Big Tagged Image File Format'], #(unofficial)
265             BZ2 => ['BZ2', 'BZIP2 archive'],
266             CAP => 'PCAP',
267             C2PA => ['JUMBF','Coalition for Content Provenance and Authenticity'],
268             CHM => ['CHM', 'Microsoft Compiled HTML format'],
269             CIFF => ['CRW', 'Camera Image File Format'],
270             COS => ['COS', 'Capture One Settings'],
271             CR2 => ['TIFF', 'Canon RAW 2 format'],
272             CR3 => ['MOV', 'Canon RAW 3 format'],
273             CRM => ['MOV', 'Canon RAW Movie'],
274             CRW => ['CRW', 'Canon RAW format'],
275             CS1 => ['PSD', 'Sinar CaptureShop 1-Shot RAW'],
276             CSV => ['TXT', 'Comma-Separated Values'],
277             CUR => ['ICO', 'Windows Cursor'],
278             CZI => ['CZI', 'Zeiss Integrated Software RAW'],
279             DC3 => 'DICM',
280             DCM => 'DICM',
281             DCP => ['TIFF', 'DNG Camera Profile'],
282             DCR => ['TIFF', 'Kodak Digital Camera RAW'],
283             DCX => ['DCX', 'Multi-page PC Paintbrush'],
284             DEX => ['DEX', 'Dalvik Executable format'],
285             DFONT=> ['Font', 'Macintosh Data fork Font'],
286             DIB => ['BMP', 'Device Independent Bitmap'],
287             DIC => 'DICM',
288             DICM => ['DICOM','Digital Imaging and Communications in Medicine'],
289             DIR => ['DIR', 'Directory'],
290             DIVX => ['ASF', 'DivX media format'],
291             DJV => 'DJVU',
292             DJVU => ['AIFF', 'DjVu image'],
293             DLL => ['EXE', 'Windows Dynamic Link Library'],
294             DNG => ['TIFF', 'Digital Negative'],
295             DOC => ['FPX', 'Microsoft Word Document'],
296             DOCM => [['ZIP','FPX'], 'Office Open XML Document Macro-enabled'],
297             # Note: I have seen a password-protected DOCX file which was FPX-like, so I assume
298             # that any other MS Office file could be like this too. The only difference is
299             # that the ZIP and FPX formats are checked first, so if this is wrong, no biggie.
300             DOCX => [['ZIP','FPX'], 'Office Open XML Document'],
301             DOT => ['FPX', 'Microsoft Word Template'],
302             DOTM => [['ZIP','FPX'], 'Office Open XML Document Template Macro-enabled'],
303             DOTX => [['ZIP','FPX'], 'Office Open XML Document Template'],
304             DPX => ['DPX', 'Digital Picture Exchange' ],
305             DR4 => ['DR4', 'Canon VRD version 4 Recipe'],
306             DS2 => ['DSS', 'Digital Speech Standard 2'],
307             DSF => ['DSF', 'DSF Stream File'],
308             DSS => ['DSS', 'Digital Speech Standard'],
309             DV => ['DV', 'Digital Video'],
310             DVB => ['MOV', 'Digital Video Broadcasting'],
311             'DVR-MS'=>['ASF', 'Microsoft Digital Video recording'],
312             DWF => ['DWF', 'Autodesk drawing (Design Web Format)'],
313             DWG => ['DWG', 'AutoCAD Drawing'],
314             DYLIB=> ['EXE', 'Mach-O Dynamic Link Library'],
315             DXF => ['DXF', 'AutoCAD Drawing Exchange Format'],
316             EIP => ['ZIP', 'Capture One Enhanced Image Package'],
317             EPS => ['EPS', 'Encapsulated PostScript Format'],
318             EPS2 => 'EPS',
319             EPS3 => 'EPS',
320             EPSF => 'EPS',
321             EPUB => ['ZIP', 'Electronic Publication'],
322             ERF => ['TIFF', 'Epson Raw Format'],
323             EXE => ['EXE', 'Windows executable file'],
324             EXR => ['EXR', 'Open EXR'],
325             EXIF => ['EXIF', 'Exchangable Image File Metadata'],
326             EXV => ['EXV', 'Exiv2 metadata'],
327             F4A => ['MOV', 'Adobe Flash Player 9+ Audio'],
328             F4B => ['MOV', 'Adobe Flash Player 9+ audio Book'],
329             F4P => ['MOV', 'Adobe Flash Player 9+ Protected'],
330             F4V => ['MOV', 'Adobe Flash Player 9+ Video'],
331             FFF => [['TIFF','FLIR'], 'Hasselblad Flexible File Format'],
332             FIT => 'FITS',
333             FITS => ['FITS', 'Flexible Image Transport System'],
334             FLAC => ['FLAC', 'Free Lossless Audio Codec'],
335             FLA => ['FPX', 'Macromedia/Adobe Flash project'],
336             FLIF => ['FLIF', 'Free Lossless Image Format'],
337             FLIR => ['FLIR', 'FLIR File Format'], # (not an actual extension)
338             FLV => ['FLV', 'Flash Video'],
339             FPF => ['FPF', 'FLIR Public image Format'],
340             FPX => ['FPX', 'FlashPix'],
341             GIF => ['GIF', 'Compuserve Graphics Interchange Format'],
342             GLV => ['MOV', 'Garmin Low-resolution Video'],
343             GPR => ['TIFF', 'General Purpose RAW'], # https://gopro.github.io/gpr/
344             GZ => 'GZIP',
345             GZIP => ['GZIP', 'GNU ZIP compressed archive'],
346             HDP => ['TIFF', 'Windows HD Photo'],
347             HDR => ['HDR', 'Radiance RGBE High Dynamic Range'],
348             HEIC => ['MOV', 'High Efficiency Image Format still image'],
349             HEIF => ['MOV', 'High Efficiency Image Format'],
350             HIF => 'HEIF',
351             HTM => 'HTML',
352             HTML => ['HTML', 'HyperText Markup Language'],
353             ICAL => 'ICS',
354             ICC => ['ICC', 'International Color Consortium'],
355             ICM => 'ICC',
356             ICO => ['ICO', 'Windows Icon'],
357             ICS => ['VCard','iCalendar Schedule'],
358             IDML => ['ZIP', 'Adobe InDesign Markup Language'],
359             IIQ => ['TIFF', 'Phase One Intelligent Image Quality RAW'],
360             IND => ['IND', 'Adobe InDesign'],
361             INDD => ['IND', 'Adobe InDesign Document'],
362             INDT => ['IND', 'Adobe InDesign Template'],
363             INSV => ['MOV', 'Insta360 Video'],
364             INSP => ['JPEG', 'Insta360 Picture'],
365             INX => ['XMP', 'Adobe InDesign Interchange'],
366             ISO => ['ISO', 'ISO 9660 disk image'],
367             ITC => ['ITC', 'iTunes Cover Flow'],
368             J2C => ['JP2', 'JPEG 2000 codestream'],
369             J2K => 'J2C',
370             JNG => ['PNG', 'JPG Network Graphics'],
371             JP2 => ['JP2', 'JPEG 2000 file'],
372             # JP4? - looks like a JPEG but the image data is different
373             JPC => 'J2C',
374             JPE => 'JPEG',
375             JPEG => ['JPEG', 'Joint Photographic Experts Group'],
376             JPH => ['JP2', 'High-throughput JPEG 2000'],
377             JPF => 'JP2',
378             JPG => 'JPEG',
379             JPM => ['JP2', 'JPEG 2000 compound image'],
380             JPS => ['JPEG', 'JPEG Stereo image'],
381             JPX => ['JP2', 'JPEG 2000 with extensions'],
382             JSON => ['JSON', 'JavaScript Object Notation'],
383             JUMBF=> ['JUMBF','JPEG Universal Metadata Box Format'],
384             JXL => ['JXL', 'JPEG XL'],
385             JXR => ['TIFF', 'JPEG XR'],
386             K25 => ['TIFF', 'Kodak DC25 RAW'],
387             KDC => ['TIFF', 'Kodak Digital Camera RAW'],
388             KEY => ['ZIP', 'Apple Keynote presentation'],
389             KTH => ['ZIP', 'Apple Keynote Theme'],
390             KVAR => ['KVAR', 'Kandao Video Asset Resource'], #PH (NC)
391             LA => ['RIFF', 'Lossless Audio'],
392             LFP => ['LFP', 'Lytro Light Field Picture'],
393             LFR => 'LFP', # (Light Field RAW)
394             LIF => ['LIF', 'Leica Image File'],
395             LNK => ['LNK', 'Windows shortcut'],
396             LRF => ['MOV', 'Low-Resolution video File'], # (DJI)
397             LRI => ['LRI', 'Light RAW'],
398             LRV => ['MOV', 'Low-Resolution Video'], # (GoPro)
399             M2T => 'M2TS',
400             M2TS => ['M2TS', 'MPEG-2 Transport Stream'],
401             M2V => ['MPEG', 'MPEG-2 Video'],
402             M4A => ['MOV', 'MPEG-4 Audio'],
403             M4B => ['MOV', 'MPEG-4 audio Book'],
404             M4P => ['MOV', 'MPEG-4 Protected'],
405             M4V => ['MOV', 'MPEG-4 Video'],
406             MACOS=> ['MacOS','MacOS ._ sidecar file'],
407             MAX => ['FPX', '3D Studio MAX'],
408             MEF => ['TIFF', 'Mamiya (RAW) Electronic Format'],
409             MIE => ['MIE', 'Meta Information Encapsulation format'],
410             MIF => 'MIFF',
411             MIFF => ['MIFF', 'Magick Image File Format'],
412             MKA => ['MKV', 'Matroska Audio'],
413             MKS => ['MKV', 'Matroska Subtitle'],
414             MKV => ['MKV', 'Matroska Video'],
415             MNG => ['PNG', 'Multiple-image Network Graphics'],
416             MOBI => ['PDB', 'Mobipocket electronic book'],
417             MODD => ['PLIST','Sony Picture Motion metadata'],
418             MOI => ['MOI', 'MOD Information file'],
419             MOS => ['TIFF', 'Creo Leaf Mosaic'],
420             MOV => ['MOV', 'Apple QuickTime movie'],
421             MP3 => ['MP3', 'MPEG-1 Layer 3 audio'],
422             MP4 => ['MOV', 'MPEG-4 video'],
423             MPC => ['MPC', 'Musepack Audio'],
424             MPEG => ['MPEG', 'MPEG-1 or MPEG-2 audio/video'],
425             MPG => 'MPEG',
426             MPO => ['JPEG', 'Extended Multi-Picture format'],
427             MQV => ['MOV', 'Sony Mobile Quicktime Video'],
428             MRC => ['MRC', 'Medical Research Council image'],
429             MRW => ['MRW', 'Minolta RAW format'],
430             MTS => 'M2TS',
431             MXF => ['MXF', 'Material Exchange Format'],
432             # NDPI => ['TIFF', 'Hamamatsu NanoZoomer Digital Pathology Image'],
433             NEF => ['TIFF', 'Nikon (RAW) Electronic Format'],
434             NEWER => 'COS',
435             NKA => ['NKA', 'Nikon NX Studio Adjustments'],
436             NKSC => ['XMP', 'Nikon Sidecar'],
437             NMBTEMPLATE => ['ZIP','Apple Numbers Template'],
438             NRW => ['TIFF', 'Nikon RAW (2)'],
439             NUMBERS => ['ZIP','Apple Numbers spreadsheet'],
440             NXD => ['XMP', 'Nikon NX-D Settings'],
441             O => ['EXE', 'Relocatable Object'],
442             ODB => ['ZIP', 'Open Document Database'],
443             ODC => ['ZIP', 'Open Document Chart'],
444             ODF => ['ZIP', 'Open Document Formula'],
445             ODG => ['ZIP', 'Open Document Graphics'],
446             ODI => ['ZIP', 'Open Document Image'],
447             ODP => ['ZIP', 'Open Document Presentation'],
448             ODS => ['ZIP', 'Open Document Spreadsheet'],
449             ODT => ['ZIP', 'Open Document Text file'],
450             OFR => ['RIFF', 'OptimFROG audio'],
451             OGG => ['OGG', 'Ogg Vorbis audio file'],
452             OGV => ['OGG', 'Ogg Video file'],
453             ONP => ['JSON', 'ON1 Presets'],
454             OPUS => ['OGG', 'Ogg Opus audio file'],
455             ORF => ['ORF', 'Olympus RAW format'],
456             ORI => 'ORF',
457             OTF => ['Font', 'Open Type Font'],
458             PAC => ['RIFF', 'Lossless Predictive Audio Compression'],
459             PAGES => ['ZIP', 'Apple Pages document'],
460             PBM => ['PPM', 'Portable BitMap'],
461             PCAP => ['PCAP', 'Packet Capture'],
462             PCAPNG => ['PCAP', 'Packet Capture Next Generation'],
463             PCD => ['PCD', 'Kodak Photo CD Image Pac'],
464             PCT => 'PICT',
465             PCX => ['PCX', 'PC Paintbrush'],
466             PDB => ['PDB', 'Palm Database'],
467             PDF => ['PDF', 'Adobe Portable Document Format'],
468             PEF => ['TIFF', 'Pentax (RAW) Electronic Format'],
469             PFA => ['Font', 'PostScript Font ASCII'],
470             PFB => ['Font', 'PostScript Font Binary'],
471             PFM => [['Font','PFM2'], 'Printer Font Metrics'], # (description is overridden for Portable FloatMap images)
472             PGF => ['PGF', 'Progressive Graphics File'],
473             PGM => ['PPM', 'Portable Gray Map'],
474             PHP => ['PHP', 'PHP Hypertext Preprocessor'],
475             PHP3 => 'PHP',
476             PHP4 => 'PHP',
477             PHP5 => 'PHP',
478             PHPS => 'PHP',
479             PHTML=> 'PHP',
480             PICT => ['PICT', 'Apple PICTure'],
481             PLIST=> ['PLIST','Apple Property List'],
482             PMP => ['PMP', 'Sony DSC-F1 Cyber-Shot PMP'], # should stand for Proprietery Metadata Package ;)
483             PNG => ['PNG', 'Portable Network Graphics'],
484             POT => ['FPX', 'Microsoft PowerPoint Template'],
485             POTM => [['ZIP','FPX'], 'Office Open XML Presentation Template Macro-enabled'],
486             POTX => [['ZIP','FPX'], 'Office Open XML Presentation Template'],
487             PPAM => [['ZIP','FPX'], 'Office Open XML Presentation Addin Macro-enabled'],
488             PPAX => [['ZIP','FPX'], 'Office Open XML Presentation Addin'],
489             PPM => ['PPM', 'Portable Pixel Map'],
490             PPS => ['FPX', 'Microsoft PowerPoint Slideshow'],
491             PPSM => [['ZIP','FPX'], 'Office Open XML Presentation Slideshow Macro-enabled'],
492             PPSX => [['ZIP','FPX'], 'Office Open XML Presentation Slideshow'],
493             PPT => ['FPX', 'Microsoft PowerPoint Presentation'],
494             PPTM => [['ZIP','FPX'], 'Office Open XML Presentation Macro-enabled'],
495             PPTX => [['ZIP','FPX'], 'Office Open XML Presentation'],
496             PRC => ['PDB', 'Palm Database'],
497             PS => ['PS', 'PostScript'],
498             PS2 => 'PS',
499             PS3 => 'PS',
500             PSB => ['PSD', 'Photoshop Large Document'],
501             PSD => ['PSD', 'Photoshop Document'],
502             PSDT => ['PSD', 'Photoshop Document Template'],
503             PSP => ['PSP', 'Paint Shop Pro'],
504             PSPFRAME => 'PSP',
505             PSPIMAGE => 'PSP',
506             PSPSHAPE => 'PSP',
507             PSPTUBE => 'PSP',
508             QIF => 'QTIF',
509             QT => 'MOV',
510             QTI => 'QTIF',
511             QTIF => ['QTIF', 'QuickTime Image File'],
512             R3D => ['R3D', 'Redcode RAW Video'],
513             RA => ['Real', 'Real Audio'],
514             RAF => ['RAF', 'FujiFilm RAW Format'],
515             RAM => ['Real', 'Real Audio Metafile'],
516             RAR => ['RAR', 'RAR Archive'],
517             RAW => [['RAW','TIFF'], 'Kyocera Contax N Digital RAW or Panasonic RAW'],
518             RIF => 'RIFF',
519             RIFF => ['RIFF', 'Resource Interchange File Format'],
520             RM => ['Real', 'Real Media'],
521             RMVB => ['Real', 'Real Media Variable Bitrate'],
522             RPM => ['Real', 'Real Media Plug-in Metafile'],
523             RSRC => ['RSRC', 'Mac OS Resource'],
524             RTF => ['RTF', 'Rich Text Format'],
525             RV => ['Real', 'Real Video'],
526             RW2 => ['TIFF', 'Panasonic RAW 2'],
527             RWL => ['TIFF', 'Leica RAW'],
528             RWZ => ['RWZ', 'Rawzor compressed image'],
529             SEQ => ['FLIR', 'FLIR image Sequence'],
530             SKETCH => ['ZIP', 'Sketch design file'],
531             SO => ['EXE', 'Shared Object file'],
532             SR2 => ['TIFF', 'Sony RAW Format 2'],
533             SRF => ['TIFF', 'Sony RAW Format'],
534             SRW => ['TIFF', 'Samsung RAW format'],
535             SVG => ['XMP', 'Scalable Vector Graphics'],
536             SWF => ['SWF', 'Shockwave Flash'],
537             TAR => ['TAR', 'TAR archive'],
538             THM => ['JPEG', 'Thumbnail'],
539             THMX => [['ZIP','FPX'], 'Office Open XML Theme'],
540             TIF => 'TIFF',
541             TIFF => ['TIFF', 'Tagged Image File Format'],
542             TNEF => ['TNEF', 'Transport Neural Encapsulation Format'], # (actual extension is .DAT)
543             TORRENT => ['Torrent', 'BitTorrent description file'],
544             TS => 'M2TS',
545             TTC => ['Font', 'True Type Font Collection'],
546             TTF => ['Font', 'True Type Font'],
547             TUB => 'PSP',
548             TXT => ['TXT', 'Text file'],
549             URL => ['LNK', 'Windows shortcut URL'],
550             VCARD=> ['VCard','Virtual Card'],
551             VCF => 'VCARD',
552             VOB => ['MPEG', 'Video Object'],
553             VNT => [['FPX','VCard'], 'Scene7 Vignette or V-Note text file'],
554             VRD => ['VRD', 'Canon VRD Recipe Data'],
555             VSD => ['FPX', 'Microsoft Visio Drawing'],
556             WAV => ['RIFF', 'WAVeform (Windows digital audio)'],
557             WDP => ['TIFF', 'Windows Media Photo'],
558             WEBM => ['MKV', 'Google Web Movie'],
559             WEBP => ['RIFF', 'Google Web Picture'],
560             WMA => ['ASF', 'Windows Media Audio'],
561             WMF => ['WMF', 'Windows Metafile Format'],
562             WMV => ['ASF', 'Windows Media Video'],
563             WV => ['WV', 'WavPack Audio'],
564             WVP => 'WV',
565             X3F => ['X3F', 'Sigma RAW format'],
566             XCF => ['XCF', 'GIMP native image format'],
567             XHTML=> ['HTML', 'Extensible HyperText Markup Language'],
568             XISF => ['XISF', 'Extensible Image Serialization Format'],
569             XLA => ['FPX', 'Microsoft Excel Add-in'],
570             XLAM => [['ZIP','FPX'], 'Office Open XML Spreadsheet Add-in Macro-enabled'],
571             XLS => ['FPX', 'Microsoft Excel Spreadsheet'],
572             XLSB => [['ZIP','FPX'], 'Office Open XML Spreadsheet Binary'],
573             XLSM => [['ZIP','FPX'], 'Office Open XML Spreadsheet Macro-enabled'],
574             XLSX => [['ZIP','FPX'], 'Office Open XML Spreadsheet'],
575             XLT => ['FPX', 'Microsoft Excel Template'],
576             XLTM => [['ZIP','FPX'], 'Office Open XML Spreadsheet Template Macro-enabled'],
577             XLTX => [['ZIP','FPX'], 'Office Open XML Spreadsheet Template'],
578             XMP => ['XMP', 'Extensible Metadata Platform'],
579             VSDX => ['ZIP', 'Visio Diagram Document'],
580             WOFF => ['Font', 'Web Open Font Format'],
581             WOFF2=> ['Font', 'Web Open Font Format 2'],
582             WPG => ['WPG', 'WordPerfect Graphics'],
583             WTV => ['WTV', 'Windows recorded TV show'],
584             ZIP => ['ZIP', 'ZIP archive'],
585             );
586              
587             # typical extension for each file type (if different than FileType)
588             # - case is not significant
589             my %fileTypeExt = (
590             'Canon 1D RAW' => 'tif',
591             DICOM => 'dcm',
592             FLIR => 'fff',
593             GZIP => 'gz',
594             JPEG => 'jpg',
595             M2TS => 'mts',
596             MPEG => 'mpg',
597             TIFF => 'tif',
598             VCard => 'vcf',
599             );
600              
601             # descriptions for file types not found in above file extension lookup
602             my %fileDescription = (
603             DICOM => 'Digital Imaging and Communications in Medicine',
604             XML => 'Extensible Markup Language',
605             'Win32 EXE' => 'Windows 32-bit Executable',
606             'Win32 DLL' => 'Windows 32-bit Dynamic Link Library',
607             'Win64 EXE' => 'Windows 64-bit Executable',
608             'Win64 DLL' => 'Windows 64-bit Dynamic Link Library',
609             VNote => 'V-Note document',
610             );
611              
612             # MIME types for applicable file types above
613             # (missing entries default to 'application/unknown', but note that other MIME
614             # types may be specified by some modules, eg. QuickTime.pm and RIFF.pm)
615             %mimeType = (
616             '3FR' => 'image/x-hasselblad-3fr',
617             '7Z' => 'application/x-7z-compressed',
618             AA => 'audio/audible',
619             AAC => 'audio/aac',
620             AAE => 'application/vnd.apple.photos',
621             AI => 'application/vnd.adobe.illustrator',
622             AIFF => 'audio/x-aiff',
623             ALIAS=> 'application/x-macos',
624             APE => 'audio/x-monkeys-audio',
625             APNG => 'image/apng',
626             ASF => 'video/x-ms-asf',
627             ARW => 'image/x-sony-arw',
628             BMP => 'image/bmp',
629             BPG => 'image/bpg',
630             BTF => 'image/x-tiff-big', #(NC) (ref http://www.asmail.be/msg0055371937.html)
631             BZ2 => 'application/bzip2',
632             C2PA => 'application/c2pa',
633             'Canon 1D RAW' => 'image/x-raw', # (uses .TIF file extension)
634             CHM => 'application/x-chm',
635             COS => 'application/octet-stream', #PH (NC)
636             CR2 => 'image/x-canon-cr2',
637             CR3 => 'image/x-canon-cr3',
638             CRM => 'video/x-canon-crm',
639             CRW => 'image/x-canon-crw',
640             CSV => 'text/csv',
641             CUR => 'image/x-cursor', #PH (NC)
642             CZI => 'image/x-zeiss-czi', #PH (NC)
643             DCP => 'application/octet-stream', #PH (NC)
644             DCR => 'image/x-kodak-dcr',
645             DCX => 'image/dcx',
646             DEX => 'application/octet-stream',
647             DFONT=> 'application/x-dfont',
648             DICOM=> 'application/dicom',
649             DIVX => 'video/divx',
650             DJVU => 'image/vnd.djvu',
651             DNG => 'image/x-adobe-dng',
652             DOC => 'application/msword',
653             DOCM => 'application/vnd.ms-word.document.macroEnabled.12',
654             DOCX => 'application/vnd.openxmlformats-officedocument.wordprocessingml.document',
655             DOT => 'application/msword',
656             DOTM => 'application/vnd.ms-word.template.macroEnabledTemplate',
657             DOTX => 'application/vnd.openxmlformats-officedocument.wordprocessingml.template',
658             DPX => 'image/x-dpx',
659             DR4 => 'application/octet-stream', #PH (NC)
660             DS2 => 'audio/x-ds2',
661             DSF => 'audio/x-dsf',
662             DSS => 'audio/x-dss',
663             DV => 'video/x-dv',
664             'DVR-MS' => 'video/x-ms-dvr',
665             DWF => 'model/vnd.dwf',
666             DWG => 'image/vnd.dwg',
667             DXF => 'application/dxf',
668             EIP => 'application/x-captureone', #(NC)
669             EPS => 'application/postscript',
670             ERF => 'image/x-epson-erf',
671             EXE => 'application/octet-stream',
672             EXR => 'image/x-exr',
673             EXV => 'image/x-exv',
674             FFF => 'image/x-hasselblad-fff',
675             FITS => 'image/fits',
676             FLA => 'application/vnd.adobe.fla',
677             FLAC => 'audio/flac',
678             FLIF => 'image/flif',
679             FLIR => 'image/x-flir-fff', #PH (NC)
680             FLV => 'video/x-flv',
681             Font => 'application/x-font-type1', # covers PFA, PFB and PFM (not sure about PFM)
682             FPF => 'image/x-flir-fpf', #PH (NC)
683             FPX => 'image/vnd.fpx',
684             GIF => 'image/gif',
685             GPR => 'image/x-gopro-gpr',
686             GZIP => 'application/x-gzip',
687             HDP => 'image/vnd.ms-photo',
688             HDR => 'image/vnd.radiance',
689             HTML => 'text/html',
690             ICC => 'application/vnd.iccprofile',
691             ICO => 'image/x-icon', #PH (NC)
692             ICS => 'text/calendar',
693             IDML => 'application/vnd.adobe.indesign-idml-package',
694             IIQ => 'image/x-raw',
695             IND => 'application/x-indesign',
696             INX => 'application/x-indesign-interchange', #PH (NC)
697             ISO => 'application/x-iso9660-image',
698             ITC => 'application/itunes',
699             J2C => 'image/x-j2c', #PH (NC)
700             JNG => 'image/jng',
701             JP2 => 'image/jp2',
702             JPEG => 'image/jpeg',
703             JPH => 'image/jph',
704             JPM => 'image/jpm',
705             JPS => 'image/x-jps',
706             JPX => 'image/jpx',
707             JSON => 'application/json',
708             JUMBF=> 'application/octet-stream', #PH (invented format)
709             JXL => 'image/jxl', #PH (NC)
710             JXR => 'image/jxr',
711             K25 => 'image/x-kodak-k25',
712             KDC => 'image/x-kodak-kdc',
713             KEY => 'application/x-iwork-keynote-sffkey',
714             LFP => 'image/x-lytro-lfp', #PH (NC)
715             LIF => 'image/x-lif',
716             LNK => 'application/octet-stream',
717             LRI => 'image/x-light-lri',
718             M2T => 'video/mpeg',
719             M2TS => 'video/m2ts',
720             MAX => 'application/x-3ds',
721             MEF => 'image/x-mamiya-mef',
722             MIE => 'application/x-mie',
723             MIFF => 'application/x-magick-image',
724             MKA => 'audio/x-matroska',
725             MKS => 'application/x-matroska',
726             MKV => 'video/x-matroska',
727             MNG => 'video/mng',
728             MOBI => 'application/x-mobipocket-ebook',
729             MOI => 'application/octet-stream', #PH (NC)
730             MOS => 'image/x-raw',
731             MOV => 'video/quicktime',
732             MP3 => 'audio/mpeg',
733             MP4 => 'video/mp4',
734             MPC => 'audio/x-musepack',
735             MPEG => 'video/mpeg',
736             MRC => 'image/x-mrc',
737             MRW => 'image/x-minolta-mrw',
738             MXF => 'application/mxf',
739             NEF => 'image/x-nikon-nef',
740             NKSC => 'application/x-nikon-nxstudio',
741             NRW => 'image/x-nikon-nrw',
742             NUMBERS => 'application/x-iwork-numbers-sffnumbers',
743             ODB => 'application/vnd.oasis.opendocument.database',
744             ODC => 'application/vnd.oasis.opendocument.chart',
745             ODF => 'application/vnd.oasis.opendocument.formula',
746             ODG => 'application/vnd.oasis.opendocument.graphics',
747             ODI => 'application/vnd.oasis.opendocument.image',
748             ODP => 'application/vnd.oasis.opendocument.presentation',
749             ODS => 'application/vnd.oasis.opendocument.spreadsheet',
750             ODT => 'application/vnd.oasis.opendocument.text',
751             OGG => 'audio/ogg',
752             OGV => 'video/ogg',
753             ONP => 'application/on1',
754             ORF => 'image/x-olympus-orf',
755             OTF => 'application/font-otf',
756             PAGES=> 'application/x-iwork-pages-sffpages',
757             PBM => 'image/x-portable-bitmap',
758             PCAP => 'application/vnd.tcpdump.pcap',
759             PCD => 'image/x-photo-cd',
760             PCX => 'image/pcx',
761             PDB => 'application/vnd.palm',
762             PDF => 'application/pdf',
763             PEF => 'image/x-pentax-pef',
764             PFA => 'application/x-font-type1', # (needed if handled by PostScript module)
765             PGF => 'image/pgf',
766             PGM => 'image/x-portable-graymap',
767             PHP => 'application/x-httpd-php',
768             PICT => 'image/pict',
769             PLIST=> 'application/xml', # (binary PLIST format is 'application/x-plist', recognized at run time)
770             PMP => 'image/x-sony-pmp', #PH (NC)
771             PNG => 'image/png',
772             POT => 'application/vnd.ms-powerpoint',
773             POTM => 'application/vnd.ms-powerpoint.template.macroEnabled.12',
774             POTX => 'application/vnd.openxmlformats-officedocument.presentationml.template',
775             PPAM => 'application/vnd.ms-powerpoint.addin.macroEnabled.12',
776             PPAX => 'application/vnd.openxmlformats-officedocument.presentationml.addin', # (NC, PH invented)
777             PPM => 'image/x-portable-pixmap',
778             PPS => 'application/vnd.ms-powerpoint',
779             PPSM => 'application/vnd.ms-powerpoint.slideshow.macroEnabled.12',
780             PPSX => 'application/vnd.openxmlformats-officedocument.presentationml.slideshow',
781             PPT => 'application/vnd.ms-powerpoint',
782             PPTM => 'application/vnd.ms-powerpoint.presentation.macroEnabled.12',
783             PPTX => 'application/vnd.openxmlformats-officedocument.presentationml.presentation',
784             PS => 'application/postscript',
785             PSD => 'application/vnd.adobe.photoshop',
786             PSP => 'image/x-paintshoppro', #(NC)
787             QTIF => 'image/x-quicktime',
788             R3D => 'video/x-red-r3d', #PH (invented)
789             RA => 'audio/x-pn-realaudio',
790             RAF => 'image/x-fujifilm-raf',
791             RAM => 'audio/x-pn-realaudio',
792             RAR => 'application/x-rar-compressed',
793             RAW => 'image/x-raw',
794             RM => 'application/vnd.rn-realmedia',
795             RMVB => 'application/vnd.rn-realmedia-vbr',
796             RPM => 'audio/x-pn-realaudio-plugin',
797             RSRC => 'application/ResEdit',
798             RTF => 'text/rtf',
799             RV => 'video/vnd.rn-realvideo',
800             RW2 => 'image/x-panasonic-rw2',
801             RWL => 'image/x-leica-rwl',
802             RWZ => 'image/x-rawzor', #(duplicated in Rawzor.pm)
803             SEQ => 'image/x-flir-seq', #PH (NC)
804             SKETCH => 'application/sketch',
805             SR2 => 'image/x-sony-sr2',
806             SRF => 'image/x-sony-srf',
807             SRW => 'image/x-samsung-srw',
808             SVG => 'image/svg+xml',
809             SWF => 'application/x-shockwave-flash',
810             TAR => 'application/x-tar',
811             THMX => 'application/vnd.ms-officetheme',
812             TIFF => 'image/tiff',
813             TNEF => 'application/vnd.ms-tnef',
814             Torrent => 'application/x-bittorrent',
815             TTC => 'application/font-ttf',
816             TTF => 'application/font-ttf',
817             TXT => 'text/plain',
818             VCard=> 'text/vcard',
819             VRD => 'application/octet-stream', #PH (NC)
820             VSD => 'application/x-visio',
821             VSDX => 'application/vnd.ms-visio.drawing',
822             WDP => 'image/vnd.ms-photo',
823             WEBM => 'video/webm',
824             WMA => 'audio/x-ms-wma',
825             WMF => 'application/x-wmf',
826             WMV => 'video/x-ms-wmv',
827             WPG => 'image/x-wpg',
828             WTV => 'video/x-ms-wtv',
829             WV => 'audio/x-wavpack',
830             X3F => 'image/x-sigma-x3f',
831             XCF => 'image/x-xcf',
832             XISF => 'image/x-xisf',
833             XLA => 'application/vnd.ms-excel',
834             XLAM => 'application/vnd.ms-excel.addin.macroEnabled.12',
835             XLS => 'application/vnd.ms-excel',
836             XLSB => 'application/vnd.ms-excel.sheet.binary.macroEnabled.12',
837             XLSM => 'application/vnd.ms-excel.sheet.macroEnabled.12',
838             XLSX => 'application/vnd.openxmlformats-officedocument.spreadsheetml.sheet',
839             XLT => 'application/vnd.ms-excel',
840             XLTM => 'application/vnd.ms-excel.template.macroEnabled.12',
841             XLTX => 'application/vnd.openxmlformats-officedocument.spreadsheetml.template',
842             XML => 'application/xml',
843             XMP => 'application/rdf+xml',
844             ZIP => 'application/zip',
845             );
846              
847             # module names for processing routines of each file type
848             # - undefined entries default to same module name as file type
849             # - module name '' defaults to Image::ExifTool
850             # - module name '0' indicates a recognized but unsupported file
851             my %moduleName = (
852             AA => 'Audible',
853             ALIAS=> 0,
854             AVC => 0,
855             BTF => 'BigTIFF',
856             BZ2 => 0,
857             CRW => 'CanonRaw',
858             CHM => 'EXE',
859             COS => 'CaptureOne',
860             CZI => 'ZISRAW',
861             DEX => 0,
862             DOCX => 'OOXML',
863             DCX => 0,
864             DIR => 0,
865             DR4 => 'CanonVRD',
866             DSS => 'Olympus',
867             DWF => 0,
868             DWG => 0,
869             DXF => 0,
870             EPS => 'PostScript',
871             EXIF => '',
872             EXR => 'OpenEXR',
873             EXV => '',
874             ICC => 'ICC_Profile',
875             IND => 'InDesign',
876             FLV => 'Flash',
877             FPF => 'FLIR',
878             FPX => 'FlashPix',
879             GZIP => 'ZIP',
880             HDR => 'Radiance',
881             JP2 => 'Jpeg2000',
882             JPEG => '',
883             JUMBF=> 'Jpeg2000',
884             JXL => 'Jpeg2000',
885             KVAR => 'Kandao',
886             LFP => 'Lytro',
887             LRI => 0,
888             MOV => 'QuickTime',
889             MKV => 'Matroska',
890             MP3 => 'ID3',
891             MRW => 'MinoltaRaw',
892             NKA => 'Nikon',
893             OGG => 'Ogg',
894             ORF => 'Olympus',
895             PDB => 'Palm',
896             PCD => 'PhotoCD',
897             PFM2 => 'Other',
898             PHP => 0,
899             PMP => 'Sony',
900             PS => 'PostScript',
901             PSD => 'Photoshop',
902             QTIF => 'QuickTime',
903             R3D => 'Red',
904             RAF => 'FujiFilm',
905             RAR => 'ZIP',
906             RAW => 'KyoceraRaw',
907             RWZ => 'Rawzor',
908             SWF => 'Flash',
909             TAR => 0,
910             TIFF => '',
911             TXT => 'Text',
912             VRD => 'CanonVRD',
913             WMF => 0,
914             WV => 'WavPack',
915             X3F => 'SigmaRaw',
916             XCF => 'GIMP',
917             );
918              
919             $testLen = 1024; # number of bytes to read when testing for magic number
920              
921             # quick "magic number" file test used to avoid loading module unnecessarily:
922             # - regular expression evaluated on first $testLen bytes of file
923             # - must match beginning at first byte in file
924             # - this test must not be more stringent than module logic
925             %magicNumber = (
926             AA => '.{4}\x57\x90\x75\x36',
927             AAC => '\xff[\xf0\xf1]',
928             AIFF => '(FORM....AIF[FC]|AT&TFORM)',
929             ALIAS=> "book\0\0\0\0mark\0\0\0\0",
930             APE => '(MAC |APETAGEX|ID3)',
931             ASF => '\x30\x26\xb2\x75\x8e\x66\xcf\x11\xa6\xd9\x00\xaa\x00\x62\xce\x6c',
932             AVC => '\+A\+V\+C\+',
933             Torrent => 'd\d+:\w+',
934             BMP => 'BM',
935             BPG => "BPG\xfb",
936             BTF => '(II\x2b\0|MM\0\x2b)',
937             BZ2 => 'BZh[1-9]\x31\x41\x59\x26\x53\x59',
938             CHM => 'ITSF.{20}\x10\xfd\x01\x7c\xaa\x7b\xd0\x11\x9e\x0c\0\xa0\xc9\x22\xe6\xec',
939             CRW => '(II|MM).{4}HEAP(CCDR|JPGM)',
940             CZI => 'ZISRAWFILE\0{6}',
941             DCX => '\xb1\x68\xde\x3a',
942             DEX => "dex\n035\0",
943             DICOM=> '(.{128}DICM|\0[\x02\x04\x06\x08]\0[\0-\x20]|[\x02\x04\x06\x08]\0[\0-\x20]\0)',
944             DOCX => 'PK\x03\x04',
945             DPX => '(SDPX|XPDS)',
946             DR4 => 'IIII[\x04|\x05]\0\x04\0',
947             DSF => 'DSD \x1c\0{7}.{16}fmt ',
948             DSS => '(\x02dss|\x03ds2)',
949             DV => '\x1f\x07\0[\x3f\xbf]', # (not tested if extension recognized)
950             DWF => '\(DWF V\d',
951             DWG => 'AC10\d{2}\0',
952             DXF => '\s*0\s+\0?\s*SECTION\s+2\s+HEADER',
953             EPS => '(%!PS|%!Ad|\xc5\xd0\xd3\xc6)',
954             EXE => '(MZ|\xca\xfe\xba\xbe|\xfe\xed\xfa[\xce\xcf]|[\xce\xcf]\xfa\xed\xfe|Joy!peff|\x7fELF|#!\s*/\S*bin/|!\x0a)',
955             EXIF => '(II\x2a\0|MM\0\x2a)',
956             EXR => '\x76\x2f\x31\x01',
957             EXV => '\xff\x01Exiv2',
958             FITS => 'SIMPLE = {20}T',
959             FLAC => '(fLaC|ID3)',
960             FLIF => 'FLIF[0-\x6f][0-2]',
961             FLIR => '[AF]FF\0',
962             FLV => 'FLV\x01',
963             Font => '((\0\x01\0\0|OTTO|true|typ1)[\0\x01]|ttcf\0[\x01\x02]\0\0|\0[\x01\x02]|' .
964             '(.{6})?%!(PS-(AdobeFont-|Bitstream )|FontType1-)|Start(Comp|Master)?FontMetrics|wOF[F2])',
965             FPF => 'FPF Public Image Format\0',
966             FPX => '\xd0\xcf\x11\xe0\xa1\xb1\x1a\xe1',
967             GIF => 'GIF8[79]a',
968             GZIP => '\x1f\x8b\x08',
969             HDR => '#\?(RADIANCE|RGBE)\x0a',
970             HTML => '(\xef\xbb\xbf)?\s*(?i)<(!DOCTYPE\s+HTML|HTML|\?xml)', # (case insensitive)
971             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}',
972             ICO => '\0\0[\x01\x02]\0[^0]\0', # (reasonably assume that the file contains less than 256 images)
973             IND => '\x06\x06\xed\xf5\xd8\x1d\x46\xe5\xbd\x31\xef\xe7\xfe\x74\xb7\x1d',
974             # ISO => signature is at byte 32768
975             ITC => '.{4}itch',
976             JP2 => '(\0\0\0\x0cjP( |\x1a\x1a)\x0d\x0a\x87\x0a|\xff\x4f\xff\x51\0)',
977             JPEG => '\xff\xd8\xff',
978             JSON => '(\xef\xbb\xbf)?\s*(\[\s*)?\{\s*"[^"]*"\s*:',
979             JUMBF=> '.{4}jumb\0.{3}jumd',
980             JXL => '(\xff\x0a|\0\0\0\x0cJXL \x0d\x0a......ftypjxl )',
981             KVAR => '.{2}\0\0[A-Z].{31}(CHAR|BOOL|[US](8|16|32|64)|FLOAT|DOUBLE)\0',
982             LFP => '\x89LFP\x0d\x0a\x1a\x0a',
983             LIF => '\x70\0{3}.{4}\x2a.{4}<\0',
984             LNK => '(.{4}\x01\x14\x02\0{5}\xc0\0{6}\x46|\[[InternetShortcut\][\x0d\x0a])',
985             LRI => 'LELR \0',
986             M2TS => '.{0,191}?\x47(.{187}|.{191})\x47(.{187}|.{191})\x47',
987             MacOS=> '\0\x05\x16\x07\0.\0\0Mac OS X ',
988             MIE => '~[\x10\x18]\x04.0MIE',
989             MIFF => 'id=ImageMagick',
990             MKV => '\x1a\x45\xdf\xa3',
991             MOV => '.{4}(free|skip|wide|ftyp|pnot|PICT|pict|moov|mdat|junk|uuid)', # (duplicated in WriteQuickTime.pl !!)
992             # MP3 => difficult to rule out
993             MPC => '(MP\+|ID3)',
994             MOI => 'V6',
995             MPEG => '\0\0\x01[\xb0-\xbf]',
996             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',
997             MRW => '\0MR[MI]',
998             MXF => '\x06\x0e\x2b\x34\x02\x05\x01\x01\x0d\x01\x02', # (not tested if extension recognized)
999             NKA => 'NIKONADJ',
1000             OGG => '(OggS|ID3)',
1001             ORF => '(II|MM)',
1002             PCAP => '\xa1\xb2(\xc3\xd4|\x3c\x4d)\0.\0.|(\xd4\xc3|\x4d\x3c)\xb2\xa1.\0.\0|\x0a\x0d\x0d\x0a.{4}(\x1a\x2b\x3c\x4d|\x4d\x3c\x2b\x1a)|GMBU\0\x02',
1003             # PCD => signature is at byte 2048
1004             PCX => '\x0a[\0-\x05]\x01[\x01\x02\x04\x08].{64}[\0-\x02]',
1005             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)',
1006             PDF => '\s*%PDF-\d+\.\d+',
1007             PFM => 'P[Ff]\x0a\d+ \d+\x0a[-+0-9.]+\x0a',
1008             PGF => 'PGF',
1009             PHP => '<\?php\s',
1010             PICT => '(.{10}|.{522})(\x11\x01|\x00\x11)',
1011             PLIST=> '(bplist0|\s*<|\xfe\xff\x00)',
1012             PMP => '.{8}\0{3}\x7c.{112}\xff\xd8\xff\xdb',
1013             PNG => '(\x89P|\x8aM|\x8bJ)NG\r\n\x1a\n',
1014             PPM => 'P[1-6]\s+',
1015             PS => '(%!PS|%!Ad|\xc5\xd0\xd3\xc6)',
1016             PSD => '8BPS\0[\x01\x02]',
1017             PSP => 'Paint Shop Pro Image File\x0a\x1a\0{5}',
1018             QTIF => '.{4}(idsc|idat|iicc)',
1019             R3D => '\0\0..RED(1|2)',
1020             RAF => 'FUJIFILM',
1021             RAR => 'Rar!\x1a\x07\x01?\0',
1022             RAW => '(.{25}ARECOYK|II|MM)',
1023             Real => '(\.RMF|\.ra\xfd|pnm://|rtsp://|http://)',
1024             RIFF => '(RIFF|LA0[234]|OFR |LPAC|wvpk|RF64)', # RIFF plus other variants
1025             RSRC => '(....)?\0\0\x01\0',
1026             RTF => '[\n\r]*\\{[\n\r]*\\\\rtf',
1027             RWZ => 'rawzor',
1028             SWF => '[FC]WS[^\0]',
1029             TAR => '.{257}ustar( )?\0', # (this doesn't catch old-style tar files)
1030             TNEF => '\x78\x9f\x3e\x22..\x01\x06\x90\x08\0',
1031             TXT => '(\xff\xfe|(\0\0)?\xfe\xff|(\xef\xbb\xbf)?[\x07-\x0d\x20-\x7e\x80-\xfe]*$)',
1032             TIFF => '(II|MM)', # don't test magic number (some raw formats are different)
1033             VCard=> '(?i)BEGIN:(VCARD|VCALENDAR|VNOTE)\r\n',
1034             VRD => 'CANON OPTIONAL DATA\0',
1035             WMF => '(\xd7\xcd\xc6\x9a\0\0|\x01\0\x09\0\0\x03)',
1036             WPG => '\xff\x57\x50\x43',
1037             WTV => '\xb7\xd8\x00\x20\x37\x49\xda\x11\xa6\x4e\x00\x07\xe9\x5e\xad\x8d',
1038             X3F => 'FOVb',
1039             XCF => 'gimp xcf ',
1040             XISF => 'XISF0100',
1041             XMP => '\0{0,3}(\xfe\xff|\xff\xfe|\xef\xbb\xbf)?\0{0,3}\s*<',
1042             ZIP => 'PK\x03\x04',
1043             );
1044              
1045             # file types with weak magic number recognition
1046             my %weakMagic = ( MP3 => 1 );
1047              
1048             # file types that are determined by the process proc when FastScan > 2
1049             # (when done, the process proc must exit after SetFileType if FastScan is > 2)
1050             my %processType = map { $_ => 1 } qw(JPEG TIFF XMP AIFF EXE Font PS Real VCard TXT);
1051              
1052             # Compact/XMPShorthand option settings
1053             my %compactOpt = (
1054             nopadding => 'NoPadding', noindent => 'NoIndent', nonewline => 'NoNewline',
1055             shorthand => 'Shorthand', onedesc => 'OneDesc',
1056             all => ['NoPadding','NoIndent','NoNewline','Shorthand','OneDesc'],
1057             allspace => ['NoPadding','NoIndent','NoNewline'], allformat => ['Shorthand','OneDesc'],
1058             # aliases to cover anticipated user typos
1059             nonewlines => 'NoNewline', nospace => 'NoIndent', nospaces => 'NoIndent',
1060             nopad => 'NoPadding', onedescr => 'OneDesc',
1061             # allow numerical settings for backward compatibility
1062             0 => 'None',
1063             1 => 'NoPadding',
1064             2 => ['NoPadding','NoIndent'],
1065             3 => ['NoPadding','NoIndent','OneDesc'],
1066             4 => ['NoPadding','NoIndent','OneDesc','NoNewline'],
1067             5 => ['NoPadding','NoIndent','OneDesc','NoNewline','Shorthand'],
1068             );
1069             my %xmpShorthandOpt = ( 0 => 'None', 1 => 'Shorthand', 2 => ['Shorthand','OneDesc'] );
1070              
1071             # lookup for valid character set names (keys are all lower case)
1072             %charsetName = (
1073             # Charset setting alias(es)
1074             # ------------------------- --------------------------------------------
1075             utf8 => 'UTF8', cp65001 => 'UTF8', 'utf-8' => 'UTF8',
1076             latin => 'Latin', cp1252 => 'Latin', latin1 => 'Latin',
1077             latin2 => 'Latin2', cp1250 => 'Latin2',
1078             cyrillic => 'Cyrillic', cp1251 => 'Cyrillic', russian => 'Cyrillic',
1079             greek => 'Greek', cp1253 => 'Greek',
1080             turkish => 'Turkish', cp1254 => 'Turkish',
1081             hebrew => 'Hebrew', cp1255 => 'Hebrew',
1082             arabic => 'Arabic', cp1256 => 'Arabic',
1083             baltic => 'Baltic', cp1257 => 'Baltic',
1084             vietnam => 'Vietnam', cp1258 => 'Vietnam',
1085             thai => 'Thai', cp874 => 'Thai',
1086             doslatinus => 'DOSLatinUS', cp437 => 'DOSLatinUS',
1087             doslatin1 => 'DOSLatin1', cp850 => 'DOSLatin1',
1088             doscyrillic => 'DOSCyrillic', cp866 => 'DOSCyrillic',
1089             macroman => 'MacRoman', cp10000 => 'MacRoman', mac => 'MacRoman', roman => 'MacRoman',
1090             maclatin2 => 'MacLatin2', cp10029 => 'MacLatin2',
1091             maccyrillic => 'MacCyrillic', cp10007 => 'MacCyrillic',
1092             macgreek => 'MacGreek', cp10006 => 'MacGreek',
1093             macturkish => 'MacTurkish', cp10081 => 'MacTurkish',
1094             macromanian => 'MacRomanian', cp10010 => 'MacRomanian',
1095             maciceland => 'MacIceland', cp10079 => 'MacIceland',
1096             maccroatian => 'MacCroatian', cp10082 => 'MacCroatian',
1097             );
1098              
1099             # list of available options
1100             # +-----------------------------------------------------+
1101             # ! DON'T FORGET!! When adding any new option, must !
1102             # ! decide how it is handled in SetNewValuesFromFile() !
1103             # +-----------------------------------------------------+
1104             # (Note: All options must exist in this lookup, even if undefined,
1105             # to facilitate case-insensitive options. 'Group#' is handled specially)
1106             # (item 3 is a flag indicating the option is undocumented)
1107             my @availableOptions = (
1108             [ 'Binary', undef, 'flag to extract binary values even if tag not specified' ],
1109             [ 'ByteOrder', undef, 'default byte order when creating EXIF information' ],
1110             [ 'ByteUnit', 'SI', 'units for byte conversions (SI or Binary)'],
1111             [ 'Charset', 'UTF8', 'character set for converting Unicode characters' ],
1112             [ 'CharsetEXIF', undef, 'internal EXIF "ASCII" string encoding' ],
1113             [ 'CharsetFileName', undef, 'external encoding for file names' ],
1114             [ 'CharsetID3', 'Latin','internal ID3v1 character set' ],
1115             [ 'CharsetIPTC', 'Latin','fallback IPTC character set if no CodedCharacterSet' ],
1116             [ 'CharsetPhotoshop', 'Latin','internal encoding for Photoshop resource names' ],
1117             [ 'CharsetQuickTime', 'MacRoman', 'internal QuickTime string encoding' ],
1118             [ 'CharsetRIFF', 0, 'internal RIFF string encoding (0=default to Latin)' ],
1119             [ 'Compact', { }, 'write compact XMP' ],
1120             [ 'Composite', 1, 'flag to calculate Composite tags' ],
1121             [ 'Compress', undef, 'flag to write new values as compressed if possible' ],
1122             [ 'CoordFormat', undef, 'GPS lat/long coordinate format' ],
1123             [ 'DateFormat', undef, 'format for date/time' ],
1124             [ 'Debug', undef, 'enable debugging output', 1 ], # (undocumented)
1125             [ 'Duplicates', 1, 'flag to save duplicate tag values' ],
1126             # ("require Encode" hangs on my Windows 10 virtual machine running under MacOS if
1127             # the current working directory has a long path name. This problem hasn't been
1128             # seen on other Windows systems, so I'm leaving this option undocumented for now)
1129             [ 'EncodeHangs', undef, 'flag set to avoid using Encode if it hangs on your system', 1 ], # (undocumented)
1130             [ 'Escape', undef, 'escape special characters' ],
1131             [ 'Exclude', undef, 'tags to exclude' ],
1132             [ 'ExtendedXMP', 1, 'strategy for reading extended XMP' ],
1133             [ 'ExtractEmbedded', undef, 'flag to extract information from embedded documents' ],
1134             [ 'FastScan', undef, 'flag to avoid scanning for trailer' ],
1135             [ 'Filter', undef, 'output filter for all tag values' ],
1136             [ 'FilterW', undef, 'input filter when writing tag values' ],
1137             [ 'FixBase', undef, 'fix maker notes base offsets' ],
1138             [ 'Geolocation', undef, 'generate geolocation tags' ],
1139             [ 'GeolocAltNames', 1, 'search alternate city names if available' ],
1140             [ 'GeolocFeature', undef, 'regular expression of geolocation features to match' ],
1141             [ 'GeolocMinPop', undef, 'minimum geolocation population' ],
1142             [ 'GeolocMaxDist', undef, 'maximum geolocation distance' ],
1143             [ 'GeoMaxIntSecs', 1800, 'geotag maximum interpolation time (secs)' ],
1144             [ 'GeoMaxExtSecs', 1800, 'geotag maximum extrapolation time (secs)' ],
1145             [ 'GeoMaxHDOP', undef, 'geotag maximum HDOP' ],
1146             [ 'GeoMaxPDOP', undef, 'geotag maximum PDOP' ],
1147             [ 'GeoMinSats', undef, 'geotag minimum satellites' ],
1148             [ 'GeoHPosErr', undef, 'geotag GPSHPositioningError based on $GPSDOP' ],
1149             [ 'GeoSpeedRef', undef, 'geotag GPSSpeedRef' ],
1150             [ 'GeoUserTag', undef, 'user-defined tags for geotagging' ],
1151             [ 'GlobalTimeShift', undef, 'apply time shift to all extracted date/time values' ],
1152             [ 'GPSQuadrant', undef, 'quadrant for GPS if not otherwise known' ],
1153             [ 'Group#', undef, 'return tags for specified groups in family #' ],
1154             [ 'HexTagIDs', 0, 'use hex tag ID\'s in family 7 group names' ],
1155             [ 'HtmlDump', 0, 'HTML dump (0-3, higher # = bigger limit)' ],
1156             [ 'HtmlDumpBase', undef, 'base address for HTML dump' ],
1157             [ 'IgnoreGroups', undef, 'list of groups to ignore when extracting' ],
1158             [ 'IgnoreMinorErrors',undef, 'ignore minor errors when reading/writing' ],
1159             [ 'IgnoreTags', undef, 'list of tags to ignore when extracting' ],
1160             [ 'ImageHashType', 'MD5', 'image hash algorithm' ],
1161             [ 'KeepUTCTime', undef, 'do not convert times stored as UTC' ],
1162             [ 'Lang', $defaultLang, 'localized language for descriptions etc' ],
1163             [ 'LargeFileSupport', 1, 'flag indicating support of 64-bit file offsets' ],
1164             [ 'LimitLongValues', 60, 'length limit for long values' ],
1165             [ 'List', undef, '[deprecated, use ListSplit and ListJoin instead]', 1 ],
1166             [ 'ListItem', undef, 'used to return a specific item from lists' ],
1167             [ 'ListJoin', ', ', 'join lists together with this separator' ],
1168             [ 'ListSep', ', ', '[deprecated, use ListSplit and ListJoin instead]', 1 ],
1169             [ 'ListSplit', undef, 'regex for splitting list-type tag values when writing' ],
1170             # LigoGPSScale - undocumented scale for unfuzzing LIGO GPS: 1,2,3 for standard scales (1 default), or scale value
1171             [ 'MakerNotes', undef, 'extract maker notes as a block' ],
1172             [ 'MDItemTags', undef, 'extract MacOS metadata item tags' ],
1173             [ 'MissingTagValue', undef, 'value for missing tags when expanded in expressions' ],
1174             [ 'NoMandatory', undef, 'bypass writing of mandatory EXIF tags' ],
1175             [ 'NoMultiExif', undef, 'raise error when writing multi-segment EXIF' ],
1176             [ 'NoPDFList', undef, 'flag to avoid splitting PDF List-type tag values' ],
1177             [ 'NoWarning', undef, 'regular expression for warnings to suppress' ],
1178             [ 'Password', undef, 'password for password-protected PDF documents' ],
1179             [ 'Plot', undef, 'SVG plot settings' ],
1180             [ 'PrintCSV', undef, 'flag to print CSV directly (selected metadata types only)' ],
1181             [ 'PrintConv', 1, 'flag to enable print conversion' ],
1182             [ 'QuickTimeHandler', 1, 'flag to add mdir Handler to newly created Meta box' ],
1183             [ 'QuickTimePad', undef, 'flag to preserve padding of QuickTime CR3 tags' ],
1184             [ 'QuickTimeUTC', undef, 'assume that QuickTime date/time tags are stored as UTC' ],
1185             [ 'RequestAll', undef, 'extract all tags that must be specifically requested' ],
1186             [ 'RequestTags', undef, 'extra tags to request (on top of those in the tag list)' ],
1187             [ 'SaveBin', undef, 'save binary values of tags' ],
1188             [ 'SaveFormat', undef, 'save family 6 tag TIFF format' ],
1189             [ 'SavePath', undef, 'save family 5 location path' ],
1190             [ 'ScanForXMP', undef, 'flag to scan for XMP information in all files' ],
1191             [ 'Sort', 'Input','order to sort found tags (Input, File, Tag, Descr, Group#)' ],
1192             [ 'Sort2', 'File', 'secondary sort order for tags in a group (File, Tag, Descr)' ],
1193             [ 'StrictDate', undef, 'flag to return undef for invalid date conversions' ],
1194             [ 'Struct', undef, 'return structures as hash references' ],
1195             [ 'StructFormat', undef, 'format for structure serialization when reading/writing' ],
1196             [ 'SystemTags', undef, 'extract additional File System tags' ],
1197             [ 'SystemTimeRes', 0, 'number of sub-second digits in system and epoch times' ],
1198             [ 'TextOut', \*STDOUT, 'file for Verbose/HtmlDump output' ],
1199             [ 'TimeZone', undef, 'local time zone' ],
1200             [ 'UndefTags', undef, 'leave undef tags in -if conditions when -m or -f are used' ],
1201             [ 'Unknown', 0, 'flag to get values of unknown tags (0-2)' ],
1202             [ 'UserParam', { }, 'user parameters for additional user-defined tag values' ],
1203             [ 'Validate', undef, 'perform additional validation' ],
1204             [ 'Verbose', 0, 'print verbose messages (0-5, higher # = more verbose)' ],
1205             [ 'WindowsLongPath', 0, 'enable support for long pathnames (enables WindowsWideFile)' ],
1206             [ 'WindowsWideFile', undef, 'force the use of Windows wide-character file routines' ], # (see forum15208)
1207             [ 'WriteMode', 'wcg', 'enable all write modes by default' ],
1208             [ 'XAttrTags', undef, 'extract MacOS extended attribute tags' ],
1209             [ 'XMPAutoConv', 1, 'automatic conversion of unknown XMP tag values' ],
1210             [ 'XMPShorthand', 0, '[deprecated, use Compact=Shorthand instead]', 1 ],
1211             );
1212              
1213             # default family 0 group priority for writing
1214             # (NOTE: tags in groups not specified here will not be written unless
1215             # overridden by the module or specified when writing)
1216             my @defaultWriteGroups = qw(
1217             EXIF IPTC XMP MakerNotes QuickTime Photoshop ICC_Profile CanonVRD Adobe
1218             );
1219              
1220             # group hash for ExifTool-generated tags
1221             my %allGroupsExifTool = ( 0 => 'ExifTool', 1 => 'ExifTool', 2 => 'ExifTool' );
1222             my %geoInfo = ( Groups => { 0 => 'ExifTool', 1 => 'ExifTool', 2 => 'Location' } );
1223              
1224             # special tag names (not used for tag info)
1225             %specialTags = map { $_ => 1 } qw(
1226             TABLE_NAME SHORT_NAME PROCESS_PROC WRITE_PROC CHECK_PROC
1227             GROUPS FORMAT FIRST_ENTRY TAG_PREFIX PRINT_CONV
1228             WRITABLE TABLE_DESC NOTES IS_OFFSET IS_SUBDIR
1229             EXTRACT_UNKNOWN NAMESPACE PREFERRED SRC_TABLE PRIORITY
1230             AVOID WRITE_GROUP LANG_INFO VARS DATAMEMBER
1231             SET_GROUP1 PERMANENT INIT_TABLE
1232             );
1233              
1234             # headers for various segment types
1235             $exifAPP1hdr = "Exif\0\0";
1236             $xmpAPP1hdr = "http://ns.adobe.com/xap/1.0/\0";
1237             $xmpExtAPP1hdr = "http://ns.adobe.com/xmp/extension/\0";
1238             $psAPP13hdr = "Photoshop 3.0\0";
1239             $psAPP13old = 'Adobe_Photoshop2.5:';
1240              
1241 777     777 0 2037 sub DummyWriteProc { return 1; }
1242              
1243             # lookup for user lenses defined in @Image::ExifTool::UserDefined::Lenses
1244             %Image::ExifTool::userLens = ( );
1245              
1246             # queued plug-in tags to add to lookup
1247             @Image::ExifTool::pluginTags = ( );
1248             %Image::ExifTool::pluginTags = ( );
1249              
1250             # memory purge variables
1251             my $purgeFlag = 0;
1252             my @purgeTags;
1253              
1254             my %systemTagsNotes = (
1255             Notes => q{
1256             extracted only if specifically requested or the API L or L
1257             option is set
1258             },
1259             );
1260              
1261             # tag information for preview image -- this should be used for all
1262             # PreviewImage tags so they are handled properly when reading/writing
1263             %Image::ExifTool::previewImageTagInfo = (
1264             Name => 'PreviewImage',
1265             Writable => 'undef',
1266             # a value of 'none' is ok...
1267             WriteCheck => '$val eq "none" ? undef : $self->CheckImage(\$val)',
1268             DataTag => 'PreviewImage',
1269             # accept either scalar or scalar reference
1270             RawConv => '$self->ValidateImage(ref $val ? $val : \$val, $tag)',
1271             # we allow preview image to be set to '', but we don't want a zero-length value
1272             # in the IFD, so set it temporarily to 'none'. Note that the length is <= 4,
1273             # so this value will fit in the IFD so the preview fixup won't be generated.
1274             ValueConvInv => '$val eq "" and $val="none"; $val',
1275             );
1276              
1277             # extra tags that aren't truly EXIF tags, but are generated by the script
1278             # Note: any tag in this list with a name corresponding to a Group0 name is
1279             # used to write the entire corresponding directory as a block.
1280             %Image::ExifTool::Extra = (
1281             GROUPS => { 0 => 'File', 1 => 'File', 2 => 'Image' },
1282             VARS => { ID_FMT => 'none' }, # tag ID's aren't meaningful for these tags
1283             WRITE_PROC => \&DummyWriteProc,
1284             Error => {
1285             Priority => 0,
1286             Groups => \%allGroupsExifTool,
1287             Notes => q{
1288             returns errors that may have occurred while reading or writing a file. Any
1289             Error will prevent the file from being processed. Minor errors may be
1290             downgraded to warnings with the -m or L option
1291             },
1292             },
1293             Warning => {
1294             Priority => 0,
1295             Groups => \%allGroupsExifTool,
1296             Notes => q{
1297             returns warnings that may have occurred while reading or writing a file.
1298             Use the -a or L option to see all warnings if more than one
1299             occurred. Minor warnings may be ignored with the -m or L
1300             option. Minor warnings with a capital "M" in the "[Minor]" designation
1301             indicate that the processing is affected by ignoring the warning. Multiple
1302             identical warnings are indicated by a count after the warning message, eg.
1303             "[x2]" if the same warning occurred twice
1304             },
1305             },
1306             Comment => {
1307             Notes => 'comment embedded in JPEG, GIF89a or PPM/PGM/PBM image',
1308             Writable => 1,
1309             WriteGroup => 'Comment',
1310             Priority => 0, # to preserve order of JPEG COM segments
1311             },
1312             Directory => {
1313             Groups => { 1 => 'System', 2 => 'Other' },
1314             Notes => q{
1315             the directory of the file as specified in the call to ExifTool, or "." if no
1316             directory was specified. May be written to move the file to another
1317             directory that will be created if doesn't already exist
1318             },
1319             Writable => 1,
1320             WritePseudo => 1,
1321             Priority => 2,
1322             DelCheck => q{"Can't delete"},
1323             Protected => 1,
1324             RawConv => '$self->ConvertFileName($val)',
1325             # translate backslashes in directory names and add trailing '/'
1326             ValueConvInv => '$_ = $self->InverseFileName($val); m{[^/]$} and $_ .= "/"; $_',
1327             },
1328             FileName => {
1329             Groups => { 1 => 'System', 2 => 'Other' },
1330             Writable => 1,
1331             WritePseudo => 1,
1332             DelCheck => q{"Can't delete"},
1333             Protected => 1,
1334             Priority => 2,
1335             Notes => q{
1336             may be written with a full path name to set FileName and Directory in one
1337             operation. This is such a powerful feature that a TestName tag is provided
1338             to allow dry-run tests before actually writing the file name. See
1339             L for more information on writing the
1340             FileName, Directory and TestName tags
1341             },
1342             RawConv => '$self->ConvertFileName($val)',
1343             ValueConvInv => '$self->InverseFileName($val)',
1344             },
1345             BaseName => {
1346             Groups => { 1 => 'System', 2 => 'Other' },
1347             Priority => 2,
1348             Notes => q{
1349             file name without extension. Not generated unless specifically requested or
1350             the API L option is set
1351             },
1352             },
1353             FilePath => {
1354             Groups => { 1 => 'System', 2 => 'Other' },
1355             Notes => q{
1356             absolute path of source file. Not generated unless specifically requested or
1357             the API L option is set. Does not support Windows Unicode file
1358             names
1359             },
1360             },
1361             TestName => {
1362             Writable => 1,
1363             WritePseudo => 1,
1364             DelCheck => q{"Can't delete"},
1365             Protected => 1,
1366             WriteOnly => 1,
1367             Notes => q{
1368             this write-only tag may be used instead of FileName for dry-run tests of the
1369             file renaming feature. Writing this tag prints the old and new file names
1370             to the console, but does not affect the file itself
1371             },
1372             ValueConvInv => '$self->InverseFileName($val)',
1373             },
1374             FileSequence => {
1375             Groups => { 0 => 'ExifTool', 1 => 'ExifTool', 2 => 'Other' },
1376             Notes => q{
1377             sequence number for each source file when extracting or copying information,
1378             including files that fail the -if condition of the command-line application,
1379             beginning at 0 for the first file. Not generated unless specifically
1380             requested or the API L option is set
1381             },
1382             },
1383             FileSize => {
1384             Groups => { 1 => 'System', 2 => 'Other' },
1385             Notes => q{
1386             note that the print conversion for this tag uses SI prefixes by default: 1
1387             kB = 1000 bytes, etc. Set the API ByteUnit option to "Binary" to use binary
1388             prefixes instead: 1 KiB = 1024 bytes, etc.
1389             },
1390             PrintConv => \&ConvertFileSize,
1391             },
1392             ResourceForkSize => {
1393             Groups => { 1 => 'System', 2 => 'Other' },
1394             Notes => q{
1395             size of the file's resource fork if it contains data. Mac OS only. If this
1396             tag is generated the L option may be used to extract
1397             resource-fork information as a sub-document. When writing, the resource
1398             fork is preserved by default, but it may be deleted with C<-rsrc:all=> on
1399             the command line
1400             },
1401             PrintConv => \&ConvertFileSize,
1402             },
1403             ZoneIdentifier => {
1404             Groups => { 1 => 'System', 2 => 'Other' },
1405             Notes => q{
1406             Windows only. Existence indicates that the file has a Zone.Identifier
1407             alternate data stream, which is used by some Windows browsers to mark
1408             downloaded files as possibly unsafe to run. May be deleted to remove this
1409             stream. Requires Win32API::File
1410             },
1411             Writable => 1,
1412             WritePseudo => 1,
1413             Protected => 1,
1414             },
1415             FileType => {
1416             Groups => { 2 => 'Other' },
1417             Priority => 2,
1418             Notes => q{
1419             a short description of the file type. For many file types this is the just
1420             the uppercase file extension
1421             },
1422             },
1423             FileTypeExtension => {
1424             Groups => { 2 => 'Other' },
1425             Notes => q{
1426             a common lowercase extension for this file type, or uppercase with the -n
1427             option
1428             },
1429             PrintConv => 'lc $val',
1430             },
1431             FileModifyDate => {
1432             Description => 'File Modification Date/Time',
1433             Notes => q{
1434             the filesystem modification date/time. Note that ExifTool may not be able
1435             to handle filesystem dates before 1970 depending on the limitations of the
1436             system's standard libraries
1437             },
1438             Groups => { 1 => 'System', 2 => 'Time' },
1439             Writable => 1,
1440             WritePseudo => 1,
1441             DelCheck => q{"Can't delete"},
1442             # all writable pseudo-tags must be protected so -tagsfromfile fails with
1443             # unrecognized files unless a pseudo tag is specified explicitly
1444             Protected => 1,
1445             Shift => 'Time',
1446             ValueConv => 'ConvertUnixTime($val,1)',
1447             ValueConvInv => 'GetUnixTime($val,1)',
1448             PrintConv => '$self->ConvertDateTime($val)',
1449             PrintConvInv => '$self->InverseDateTime($val)',
1450             },
1451             FileAccessDate => {
1452             Description => 'File Access Date/Time',
1453             Notes => q{
1454             the date/time of last access of the file. Note that this access time is
1455             updated whenever any software, including ExifTool, reads the file
1456             },
1457             Groups => { 1 => 'System', 2 => 'Time' },
1458             ValueConv => 'ConvertUnixTime($val,1)',
1459             PrintConv => '$self->ConvertDateTime($val)',
1460             },
1461             FileCreateDate => {
1462             Description => 'File Creation Date/Time',
1463             Notes => q{
1464             the filesystem creation date/time. Windows/Mac/Linux only. In Windows, the
1465             file creation date/time is preserved by default when writing if
1466             Win32API::File and Win32::API are available. On Mac, this tag is extracted
1467             only if it or the MacOS group is specifically requested or the API
1468             L option is set to 2 or higher. On
1469             Linux, this tag is read-only and extracted only if the filesystem supports
1470             btime and "File::StatX" is available. Requires "setfile" for writing on
1471             Mac, which may be installed by typing C in the
1472             Terminal
1473             },
1474             Groups => { 1 => 'System', 2 => 'Time' },
1475             Writable => 1,
1476             WritePseudo => 1,
1477             DelCheck => q{"Can't delete"},
1478             Protected => 1, # all writable pseudo-tags must be protected!
1479             Shift => 'Time',
1480             ValueConv => '$^O eq "darwin" ? $val : ConvertUnixTime($val,1)',
1481             ValueConvInv => q{
1482             return GetUnixTime($val,1) if $^O eq 'MSWin32';
1483             return $val if $^O eq 'darwin';
1484             warn "This tag is Windows/Mac only\n";
1485             return undef;
1486             },
1487             PrintConv => '$self->ConvertDateTime($val)',
1488             PrintConvInv => '$self->InverseDateTime($val)',
1489             },
1490             FileInodeChangeDate => {
1491             Description => 'File Inode Change Date/Time',
1492             Notes => q{
1493             the date/time when the file's directory information was last changed.
1494             Non-Windows systems only
1495             },
1496             Groups => { 1 => 'System', 2 => 'Time' },
1497             ValueConv => 'ConvertUnixTime($val,1)',
1498             PrintConv => '$self->ConvertDateTime($val)',
1499             },
1500             FilePermissions => {
1501             Groups => { 1 => 'System', 2 => 'Other' },
1502             Notes => q{
1503             r=read, w=write and x=execute permissions for the file owner, group and
1504             others. The ValueConv value is an octal number so bit test operations on
1505             this value should be done in octal, eg. 'oct($filePermissions#) & 0200'
1506             },
1507             Writable => 1,
1508             WritePseudo => 1,
1509             DelCheck => q{"Can't delete"},
1510             Protected => 1, # all writable pseudo-tags must be protected!
1511             ValueConv => 'sprintf("%.3o", $val)',
1512             ValueConvInv => 'oct($val & 07777)',
1513             PrintConv => sub {
1514             my ($mask, $val) = (0400, oct(shift));
1515             my %types = (
1516             0010000 => 'p', # FIFO
1517             0020000 => 'c', # character special file
1518             0040000 => 'd', # directory
1519             0060000 => 'b', # block special file
1520             0120000 => 'l', # sym link
1521             0140000 => 's', # socket link
1522             );
1523             my $str = $types{$val & 0170000} || '-';
1524             while ($mask) {
1525             foreach (qw(r w x)) {
1526             $str .= $val & $mask ? $_ : '-';
1527             $mask >>= 1;
1528             }
1529             }
1530             return $str;
1531             },
1532             PrintConvInv => sub {
1533             my ($bit, $val, $str) = (8, 0, shift);
1534             $str = substr($str, 1) if length($str) == 10;
1535             return undef if length($str) != 9;
1536             while ($bit >= 0) {
1537             foreach (qw(r w x)) {
1538             $val |= (1 << $bit) if substr($str, 8-$bit, 1) eq $_;
1539             --$bit;
1540             }
1541             }
1542             return sprintf('%.3o', $val);
1543             },
1544             },
1545             FileAttributes => {
1546             Groups => { 1 => 'System', 2 => 'Other' },
1547             Notes => q{
1548             extracted only if specifically requested or the API L or L
1549             option is set. 2 or 3 values: 0. File type, 1. Attribute bits, 2. Windows
1550             attribute bits if Win32API::File is available
1551             },
1552             PrintHex => 1,
1553             PrintConvColumns => 2,
1554             PrintConv => [{ # stat device types (bitmask 0xf000)
1555             0x0000 => 'Unknown',
1556             0x1000 => 'FIFO',
1557             0x2000 => 'Character',
1558             0x3000 => 'Mux Character',
1559             0x4000 => 'Directory',
1560             0x5000 => 'XENIX Named',
1561             0x6000 => 'Block',
1562             0x7000 => 'Mux Block',
1563             0x8000 => 'Regular',
1564             0x9000 => 'VxFS Compressed',
1565             0xa000 => 'Symbolic Link',
1566             0xb000 => 'Solaris Shadow Inode',
1567             0xc000 => 'Socket',
1568             0xd000 => 'Solaris Door',
1569             0xe000 => 'BSD Whiteout',
1570             },{ BITMASK => { # stat attribute bits (bitmask 0x0e00)
1571             9 => 'Sticky',
1572             10 => 'Set Group ID',
1573             11 => 'Set User ID',
1574             }},{ BITMASK => { # Windows attribute bits
1575             0 => 'Read Only',
1576             1 => 'Hidden',
1577             2 => 'System',
1578             3 => 'Volume Label',
1579             4 => 'Directory',
1580             5 => 'Archive',
1581             6 => 'Device',
1582             7 => 'Normal',
1583             8 => 'Temporary',
1584             9 => 'Sparse File',
1585             10 => 'Reparse Point',
1586             11 => 'Compressed',
1587             12 => 'Offline',
1588             13 => 'Not Content Indexed',
1589             14 => 'Encrypted',
1590             }}],
1591             },
1592             FileDeviceID => {
1593             Groups => { 1 => 'System', 2 => 'Other' },
1594             %systemTagsNotes,
1595             PrintConv => '(($val >> 24) & 0xff) . "." . ($val & 0xffffff)', # (major.minor)
1596             },
1597             FileDeviceNumber => { Groups => { 1 => 'System', 2 => 'Other' }, %systemTagsNotes },
1598             FileInodeNumber => { Groups => { 1 => 'System', 2 => 'Other' }, %systemTagsNotes },
1599             FileHardLinks => { Groups => { 1 => 'System', 2 => 'Other' }, %systemTagsNotes },
1600             FileUserID => {
1601             Groups => { 1 => 'System', 2 => 'Other' },
1602             Notes => q{
1603             extracted only if specifically requested or the API L or L
1604             option is set. Returns user ID number with the -n option, or name
1605             otherwise. May be written with either user name or number
1606             },
1607             Writable => 1,
1608             WritePseudo => 1,
1609             DelCheck => q{"Can't delete"},
1610             Protected => 1, # all writable pseudo-tags must be protected!
1611             PrintConv => 'eval { getpwuid($val) } || $val',
1612             PrintConvInv => 'eval { getpwnam($val) } || ($val=~/[^0-9]/ ? undef : $val)',
1613             },
1614             FileGroupID => {
1615             Groups => { 1 => 'System', 2 => 'Other' },
1616             Notes => q{
1617             extracted only if specifically requested or the API L or L
1618             option is set. Returns group ID number with the -n option, or name
1619             otherwise. May be written with either group name or number
1620             },
1621             Writable => 1,
1622             WritePseudo => 1,
1623             DelCheck => q{"Can't delete"},
1624             Protected => 1, # all writable pseudo-tags must be protected!
1625             PrintConv => 'eval { getgrgid($val) } || $val',
1626             PrintConvInv => 'eval { getgrnam($val) } || ($val=~/[^0-9]/ ? undef : $val)',
1627             },
1628             FileBlockSize => { Groups => { 1 => 'System', 2 => 'Other' }, %systemTagsNotes },
1629             FileBlockCount => { Groups => { 1 => 'System', 2 => 'Other' }, %systemTagsNotes },
1630             HardLink => {
1631             Writable => 1,
1632             DelCheck => q{"Can't delete"},
1633             WriteOnly => 1,
1634             WritePseudo => 1,
1635             Protected => 1,
1636             Notes => q{
1637             this write-only tag is used to create a hard link with the specified name to
1638             the source file. If the source file is edited, copied, renamed or moved in
1639             the same operation as writing HardLink, then the link is made to the updated
1640             file. Note that subsequent editing of either hard-linked file by exiftool
1641             will break the link unless the -overwrite_original_in_place option is used
1642             },
1643             ValueConvInv => '$val=~tr/\\\\/\//; $val',
1644             },
1645             SymLink => {
1646             Writable => 1,
1647             DelCheck => q{"Can't delete"},
1648             WriteOnly => 1,
1649             WritePseudo => 1,
1650             Protected => 1,
1651             Notes => q{
1652             this write-only tag is used to create a symbolic link with the specified
1653             name to the source file. If the source file is edited, copied, renamed or
1654             moved in the same operation as writing SymLink, then the link is made to the
1655             updated file. The link uses an absolute path unless it is created in the
1656             current working directory. Valid only for file systems that support
1657             symbolic links. Note that subsequent editing of the file via the symbolic
1658             link by exiftool will cause the link to be replaced by the edited file
1659             without changing the original unless the -overwrite_original_in_place option
1660             is used
1661             },
1662             ValueConvInv => '$val=~tr/\\\\/\//; $val',
1663             },
1664             MIMEType => { Notes => 'the MIME type of the source file', Groups => { 2 => 'Other' } },
1665             ImageWidth => { Notes => 'the width of the image in number of pixels' },
1666             ImageHeight => { Notes => 'the height of the image in number of pixels' },
1667             XResolution => { Notes => 'the horizontal pixel resolution' },
1668             YResolution => { Notes => 'the vertical pixel resolution' },
1669             NumPlanes => { Notes => 'number of color planes' },
1670             MaxVal => { Notes => 'maximum pixel value in PPM or PGM image' },
1671             EXIF => {
1672             Notes => q{
1673             the full EXIF data block from JPEG, PNG, JP2, MIE and MIFF images. This tag
1674             is generated only if specifically requested
1675             },
1676             Groups => { 0 => 'EXIF', 1 => 'EXIF' },
1677             Flags => ['Writable' ,'Protected', 'Binary', 'DelGroup'],
1678             WriteCheck => q{
1679             return undef if $val =~ /^(II\x2a\0|MM\0\x2a)/;
1680             return 'Invalid EXIF data';
1681             },
1682             },
1683             IPTC => {
1684             Notes => q{
1685             the full IPTC data block. This tag is generated only if specifically
1686             requested
1687             },
1688             Groups => { 0 => 'IPTC', 1 => 'IPTC' },
1689             Flags => ['Writable', 'Protected', 'Binary', 'DelGroup'],
1690             Priority => 0, # so main IPTC (which hopefully comes first) takes priority
1691             WriteCheck => q{
1692             return undef if $val =~ /^(\x1c|\0+$)/;
1693             return 'Invalid IPTC data';
1694             },
1695             },
1696             XMP => {
1697             Notes => q{
1698             the XMP data block, but note that extended XMP in JPEG images may be split
1699             into multiple blocks. This tag is generated only if specifically requested
1700             },
1701             Groups => { 0 => 'XMP', 1 => 'XMP' },
1702             Flags => ['Writable', 'Protected', 'Binary', 'DelGroup'],
1703             Priority => 0, # so main xmp (which usually comes first) takes priority
1704             WriteCheck => q{
1705             require Image::ExifTool::XMP;
1706             return Image::ExifTool::XMP::CheckXMP($self, $tagInfo, \$val);
1707             },
1708             },
1709             XML => {
1710             Notes => 'the XML data block, extracted for some file types',
1711             Groups => { 0 => 'XML', 1 => 'XML' },
1712             Binary => 1,
1713             },
1714             JUMBF => {
1715             Notes => 'the C2PA JUMBF data block, extracted only if specifically requested',
1716             Groups => { 0 => 'JUMBF', 1 => 'JUMBF' },
1717             Binary => 1,
1718             },
1719             ICC_Profile => {
1720             Notes => q{
1721             the full ICC_Profile data block. This tag is generated only if specifically
1722             requested
1723             },
1724             Groups => { 0 => 'ICC_Profile', 1 => 'ICC_Profile' },
1725             Flags => ['Writable' ,'Protected', 'Binary', 'DelGroup'],
1726             WriteCheck => q{
1727             require Image::ExifTool::ICC_Profile;
1728             return Image::ExifTool::ICC_Profile::ValidateICC(\$val);
1729             },
1730             },
1731             CanonVRD => {
1732             Notes => q{
1733             the full Canon DPP VRD trailer block. This tag is generated only if
1734             specifically requested
1735             },
1736             Groups => { 0 => 'CanonVRD', 1 => 'CanonVRD' },
1737             Flags => ['Writable' ,'Protected', 'Binary', 'DelGroup'],
1738             Permanent => 0, # (this is 1 by default for MakerNotes tags)
1739             WriteCheck => q{
1740             return undef if $val =~ /^CANON OPTIONAL DATA\0/;
1741             return 'Invalid CanonVRD data';
1742             },
1743             },
1744             CanonDR4 => {
1745             Notes => q{
1746             the full Canon DPP version 4 DR4 block. This tag is generated only if
1747             specifically requested
1748             },
1749             Groups => { 0 => 'CanonVRD', 1 => 'CanonVRD' },
1750             Flags => ['Writable' ,'Protected', 'Binary'],
1751             Permanent => 0, # (this is 1 by default for MakerNotes tags)
1752             WriteCheck => q{
1753             return undef if $val =~ /^IIII[\x04|\x05]\0\x04\0/;
1754             return 'Invalid CanonDR4 data';
1755             },
1756             },
1757             Adobe => {
1758             Notes => q{
1759             the JPEG APP14 Adobe segment. Extracted only if specified. See the
1760             L for more information
1761             },
1762             Groups => { 0 => 'APP14', 1 => 'Adobe' },
1763             WriteGroup => 'Adobe',
1764             Flags => ['Writable' ,'Protected', 'Binary'],
1765             },
1766             CurrentIPTCDigest => {
1767             Notes => q{
1768             MD5 digest of existing IPTC data. All zeros if IPTC exists but Digest::MD5
1769             is not installed. Only calculated for IPTC in the standard location as
1770             specified by the L. ExifTool
1771             automates the handling of this tag in the MWG module -- see the
1772             L for details
1773             },
1774             ValueConv => 'unpack("H*", $val)',
1775             },
1776             PreviewImage => {
1777             Notes => 'JPEG-format embedded preview image',
1778             Groups => { 2 => 'Preview' },
1779             Writable => 1,
1780             WriteCheck => '$self->CheckImage(\$val)',
1781             WriteGroup => 'All',
1782             # can't delete, so set to empty string and return no error
1783             DelCheck => '$val = ""; return undef',
1784             # accept either scalar or scalar reference
1785             RawConv => '$self->ValidateImage(ref $val ? $val : \$val, $tag)',
1786             },
1787             ThumbnailImage => {
1788             Groups => { 2 => 'Preview' },
1789             Notes => 'JPEG-format embedded thumbnail image',
1790             RawConv => '$self->ValidateImage(ref $val ? $val : \$val, $tag)',
1791             },
1792             OtherImage => {
1793             Groups => { 2 => 'Preview' },
1794             Notes => 'other JPEG-format embedded image',
1795             RawConv => '$self->ValidateImage(ref $val ? $val : \$val, $tag)',
1796             },
1797             PreviewPNG => {
1798             Groups => { 2 => 'Preview' },
1799             Notes => 'PNG-format embedded preview image',
1800             Binary => 1,
1801             },
1802             PreviewWMF => {
1803             Groups => { 2 => 'Preview' },
1804             Notes => 'WMF-format embedded preview image',
1805             Binary => 1,
1806             },
1807             PreviewTIFF => {
1808             Groups => { 2 => 'Preview' },
1809             Notes => 'TIFF-format embedded preview image',
1810             Binary => 1,
1811             },
1812             PreviewPDF => {
1813             Groups => { 2 => 'Preview' },
1814             Notes => 'PDF-format embedded preview image',
1815             Binary => 1,
1816             },
1817             PreviewJXL => {
1818             Groups => { 2 => 'Preview' },
1819             Notes => 'JXL-format embedded preview image',
1820             Binary => 1,
1821             },
1822             ExifByteOrder => {
1823             Writable => 1,
1824             DelCheck => q{"Can't delete"},
1825             Notes => q{
1826             represents the byte order of EXIF information. May be written to set the
1827             byte order only for newly created EXIF segments
1828             },
1829             PrintConv => {
1830             II => 'Little-endian (Intel, II)',
1831             MM => 'Big-endian (Motorola, MM)',
1832             },
1833             },
1834             MakerNoteByteOrder => {
1835             Notes => 'byte order of maker notes. Generated only if different from ExifByteOrder',
1836             PrintConv => {
1837             II => 'Little-endian (Intel, II)',
1838             MM => 'Big-endian (Motorola, MM)',
1839             },
1840             },
1841             ExifUnicodeByteOrder => {
1842             Writable => 1,
1843             WriteOnly => 1,
1844             DelCheck => q{"Can't delete"},
1845             Notes => q{
1846             specifies the byte order to use when writing EXIF Unicode text. The EXIF
1847             specification is particularly vague about this byte ordering, and different
1848             applications use different conventions. By default ExifTool writes Unicode
1849             text in EXIF byte order, but this write-only tag may be used to force a
1850             specific order. Applies to the EXIF UserComment tag when writing special
1851             characters
1852             },
1853             PrintConv => {
1854             II => 'Little-endian (Intel, II)',
1855             MM => 'Big-endian (Motorola, MM)',
1856             },
1857             },
1858             ExifToolVersion => {
1859             Description => 'ExifTool Version Number',
1860             Groups => \%allGroupsExifTool,
1861             Notes => 'the version of ExifTool currently running',
1862             },
1863             ProcessingTime => {
1864             Groups => { 0 => 'ExifTool', 1 => 'ExifTool', 2 => 'Other' },
1865             Notes => q{
1866             the clock time in seconds taken by ExifTool to extract information from this
1867             file. Not generated unless specifically requested or the API L
1868             option is set. Requires Time::HiRes
1869             },
1870             PrintConv => 'sprintf("%.3g s", $val)',
1871             },
1872             RAFVersion => { Notes => 'RAF file version number' },
1873             RAFCompression => { PrintConv => { 0 => 'Uncompressed', 2 => 'Compressed' } }, # 1 maybe lossy?
1874             JPEGDigest => {
1875             Notes => q{
1876             an MD5 digest of the JPEG quantization tables is combined with the component
1877             sub-sampling values to generate the value of this tag. The result is
1878             compared to known values in an attempt to deduce the originating software
1879             based only on the JPEG image data. For performance reasons, this tag is
1880             generated only if specifically requested or the API L option is set
1881             to 3 or higher
1882             },
1883             },
1884             JPEGQualityEstimate => {
1885             Notes => q{
1886             an estimate of the IJG JPEG quality setting for the image, calculated from
1887             the quantization tables. For performance reasons, this tag is generated
1888             only if specifically requested or the API L option is set to 3 or
1889             higher
1890             },
1891             },
1892             JPEGImageLength => {
1893             Notes => q{
1894             byte length of JPEG image without metadata. For performance reasons, this
1895             tag is generated only if specifically requested or the API L option
1896             is set to 3 or higher
1897             },
1898             },
1899             # Validate (added from Validate.pm)
1900             Now => {
1901             Groups => { 0 => 'ExifTool', 1 => 'ExifTool', 2 => 'Time' },
1902             Notes => q{
1903             the current date/time. Useful when setting the tag values, eg.
1904             C<"-modifydate. Not generated unless specifically requested or the
1905             API L option is set
1906             },
1907             PrintConv => '$self->ConvertDateTime($val)',
1908             },
1909             NewGUID => {
1910             Groups => { 0 => 'ExifTool', 1 => 'ExifTool', 2 => 'Other' },
1911             Notes => q{
1912             generates a new, random GUID with format
1913             YYYYmmdd-HHMM-SSNN-PPPP-RRRRRRRRRRRR, where Y=year, m=month, d=day, H=hour,
1914             M=minute, S=second, N=file sequence number in hex, P=process ID in hex, and
1915             R=random hex number; without dashes with the -n option. Not generated
1916             unless specifically requested or the API L option is set
1917             },
1918             PrintConv => '$val =~ s/(.{8})(.{4})(.{4})(.{4})/$1-$2-$3-$4-/; $val',
1919             },
1920             ID3Size => { Notes => 'size of the ID3 data block' },
1921             Geotag => {
1922             Writable => 1,
1923             WriteOnly => 1,
1924             WriteNothing => 1,
1925             AllowGroup => '(exif|gps|xmp|xmp-exif)',
1926             Notes => q{
1927             this write-only tag is used to define the GPS track log data or track log
1928             file name. Currently supported track log formats are GPX, NMEA RMC/GGA/GLL,
1929             KML, IGC, Garmin XML and TCX, Magellan PMGNTRK, Honeywell PTNTHPR, Winplus
1930             Beacon text, Bramor gEO, Google Takeout JSON, and CSV log files. May be set
1931             to the special value of "DATETIMEONLY" (all caps) to set GPS date/time tags
1932             if no input track points are available. See L
1933             for details
1934             },
1935             DelCheck => q{
1936             require Image::ExifTool::Geotag;
1937             # delete associated tags
1938             Image::ExifTool::Geotag::SetGeoValues($self, undef, $wantGroup);
1939             },
1940             ValueConvInv => q{
1941             require Image::ExifTool::Geotag;
1942             # always warn because this tag is never set (warning is "\n" on success)
1943             my $result = Image::ExifTool::Geotag::LoadTrackLog($self, $val);
1944             return '' if not defined $result; # deleting geo tags
1945             return $result if ref $result; # geotag data hash reference
1946             warn "$result\n"; # error string
1947             },
1948             },
1949             Geotime => {
1950             Writable => 1,
1951             WriteOnly => 1,
1952             AllowGroup => '(exif|gps|xmp|xmp-exif|quicktime|keys|itemlist|userdata)',
1953             Notes => q{
1954             this write-only tag is used to define a date/time for interpolating a
1955             position in the GPS track specified by the Geotag tag. Writing this tag
1956             causes GPS information to be written into the EXIF or XMP of the target
1957             files. The local system timezone is assumed if the date/time value does not
1958             contain a timezone. May be deleted to delete associated GPS tags. A group
1959             name of "EXIF" or "XMP" may be specified to write or delete only EXIF or XMP
1960             GPS tags
1961             },
1962             DelCheck => q{
1963             require Image::ExifTool::Geotag;
1964             # delete associated tags
1965             Image::ExifTool::Geotag::SetGeoValues($self, undef, $wantGroup);
1966             },
1967             ValueConvInv => q{
1968             require Image::ExifTool::Geotag;
1969             warn Image::ExifTool::Geotag::SetGeoValues($self, $val, $wantGroup) . "\n";
1970             return undef;
1971             },
1972             },
1973             Geosync => {
1974             Writable => 1,
1975             WriteOnly => 1,
1976             WriteNothing => 1,
1977             AllowGroup => '(exif|gps|xmp|xmp-exif)',
1978             Shift => 'Time', # enables "+=" syntax as well as "=+"
1979             Notes => q{
1980             this write-only tag specifies a time difference to add to Geotime for
1981             synchronization with the GPS clock. For example, set this to "-12" if the
1982             camera clock is 12 seconds faster than GPS time. Input format is
1983             "[+-][[[DD ]HH:]MM:]SS[.ss]". Additional features allow calculation of time
1984             differences and time drifts, and extraction of synchronization times from
1985             image files. See the L for details
1986             },
1987             ValueConvInv => q{
1988             require Image::ExifTool::Geotag;
1989             return Image::ExifTool::Geotag::ConvertGeosync($self, $val);
1990             },
1991             },
1992             ForceWrite => {
1993             Groups => { 0 => '*', 1 => '*', 2 => '*' },
1994             Writable => 1,
1995             WriteOnly => 1,
1996             Notes => q{
1997             write-only tag used to force metadata in a file to be rewritten even if no
1998             tag values are changed. May be set to "EXIF", "IPTC", "XMP" or "PNG" to
1999             force the corresponding metadata type to be rewritten, "FixBase" to cause
2000             EXIF to be rewritten only if the MakerNotes offset base was fixed, or "All"
2001             to rewrite all of these metadata types. Values are case insensitive, and
2002             multiple values may be separated with commas, eg. C<-ForceWrite=exif,xmp>
2003             },
2004             },
2005             EmbeddedVideo => { Groups => { 0 => 'Trailer', 2 => 'Video' } },
2006             Trailer => {
2007             Groups => { 0 => 'Trailer' },
2008             Notes => q{
2009             the full JPEG trailer data block. Extracted only if specifically requested
2010             or the API L option is set to 3 or higher
2011             },
2012             Writable => 1,
2013             Protected => 1,
2014             },
2015             PageCount => { Notes => 'the number of pages in a multi-page TIFF document' },
2016             SphericalVideoXML => {
2017             Groups => { 0 => 'QuickTime', 1 => 'GSpherical', 2 => 'Video' },
2018             # (group 1 is 'GSpherical' to trigger creation of this tag when writing,
2019             # but when reading the family 1 group is the track number)
2020             Flags => [ 'Writable', 'Binary', 'Protected' ],
2021             Notes => q{
2022             the SphericalVideoXML block from MP4/MOV videos. This tag is generated only
2023             if specifically requested
2024             },
2025             },
2026             ImageDataHash => {
2027             Notes => q{
2028             Hash of image data. Generated only if specifically requested for JPEG, TIFF,
2029             PNG, CRW, CR3, MRW, RAF, X3F, IIQ, JP2, JXL, HEIC and AVIF images, MOV/MP4
2030             videos, and some RIFF-based files such as AVI, WAV and WEBP. The hash
2031             algorithm is set by the API L option, and is 'MD5' by default.
2032             The hash includes the main image data, plus JpgFromRaw/OtherImage for some
2033             formats, but does not include ThumbnailImage or PreviewImage. Includes
2034             video and audio data for MOV/MP4. The L
2035             XMP-et:OriginalImageHashType tags|XMP.html#ExifTool> provide a way to store
2036             the this hash value and the hash type in the file.
2037             },
2038             },
2039             Geolocate => {
2040             Writable => 1,
2041             WriteOnly => 1,
2042             WriteNothing => 1,
2043             AllowGroup => '(exif|gps|xmp|xmp-exif|xmp-iptcext|xmp-iptccore|xmp-photoshop|iptc|quicktime|itemlist|keys|userdata)',
2044             Notes => q{
2045             this write-only tag may be used to write geolocation city, region, country
2046             code and country based in input GPS coordinates, or to write GPS
2047             coordinates based on geolocation name. See the
2048             L for
2049             details. This tag is writable regardless of the API L
2050             option setting
2051             },
2052             DelCheck => q{
2053             my @tags = $self->GetGeolocateTags($wantGroup);
2054             $self->SetNewValue($_) foreach @tags;
2055             return '';
2056             },
2057             ValueConvInv => q{
2058             require Image::ExifTool::Geolocation;
2059             # write this tag later if geotagging
2060             return $val if $val =~ /\bgeotag\b/i;
2061             $val .= ',both';
2062             my $opts = $$self{OPTIONS};
2063             my ($cities, $dist) = Image::ExifTool::Geolocation::Geolocate($self->Encode($val,'UTF8'), $opts);
2064             return '' unless $cities;
2065             if (@$cities > 1 and $self->Warn('Multiple matching cities found',2)) {
2066             warn "$$self{VALUE}{Warning}\n";
2067             return '';
2068             }
2069             my @geo = Image::ExifTool::Geolocation::GetEntry($$cities[0], $$opts{Lang});
2070             my @tags = $self->GetGeolocateTags($wantGroup, $dist ? 0 : 1);
2071             my %geoNum = ( City => 0, Province => 1, State => 1, Code => 3, Country => 4,
2072             Coordinates => 89, Latitude => 8, Longitude => 9 );
2073             my ($tag, $value);
2074             foreach $tag (@tags) {
2075             if ($tag =~ /GPS(Coordinates|Latitude|Longitude)?/) {
2076             $value = $geoNum{$1} == 89 ? "$geo[8],$geo[9]" : $geo[$geoNum{$1}];
2077             } elsif ($tag =~ /(Code)/ or $tag =~ /(City|Province|State|Country)/) {
2078             $value = $geo[$geoNum{$1}];
2079             next unless defined $value;
2080             $value = $self->Decode($value,'UTF8');
2081             $value .= ' ' if $tag eq 'iptc:Country-PrimaryLocationCode'; # (IPTC requires 3-char code)
2082             } elsif ($tag =~ /LocationName/) {
2083             $value = $geo[0] or next;
2084             $value .= ', ' . $geo[1] if $geo[1];
2085             $value .= ', ' . $geo[4] if $geo[4];
2086             $value = $self->Decode($value, 'UTF8');
2087             } else {
2088             next; # (shouldn't happen)
2089             }
2090             $self->SetNewValue($tag => $value, Type => 'PrintConv');
2091             }
2092             return '';
2093             },
2094             PrintConvInv => q{
2095             my @args = split /\s*,\s*/, $val;
2096             my $lat = 1;
2097             foreach (@args) {
2098             next unless /^[-+]?\d/;
2099             my @reals = /\.\d+/g;
2100             next if @reals > 1; # (allow floating "lat lon" format)
2101             require Image::ExifTool::GPS;
2102             $_ = Image::ExifTool::GPS::ToDegrees($_, 1, $lat ? 'lat' : 'lon');
2103             $lat ^= 1;
2104             }
2105             return join(',', @args);
2106             },
2107             },
2108             GeolocationBearing => { %geoInfo,
2109             Notes => q{
2110             compass bearing to GeolocationCity center. Geolocation tags are
2111             generated only if API L option is set
2112             },
2113             },
2114             GeolocationCity => { %geoInfo, Notes => 'name of city nearest to the current GPS coordinates', ValueConv => '$self->Decode($val,"UTF8")' },
2115             GeolocationRegion => { %geoInfo, Notes => 'geolocation state, province or region', ValueConv => '$self->Decode($val,"UTF8")' },
2116             GeolocationSubregion=> { %geoInfo, Notes => 'geolocation county or subregion', ValueConv => '$self->Decode($val,"UTF8")' },
2117             GeolocationCountry => { %geoInfo, Notes => 'geolocation country name', ValueConv => '$self->Decode($val,"UTF8")' },
2118             GeolocationCountryCode=>{%geoInfo, Notes => 'geolocation country code' },
2119             GeolocationTimeZone => { %geoInfo, Notes => 'geolocation time zone ID' },
2120             GeolocationFeatureCode=>{%geoInfo, Notes => 'geolocation feature code, see L' },
2121             GeolocationFeatureType=>{%geoInfo, Notes => 'geolocation feature type' },
2122             GeolocationPopulation=>{ %geoInfo, Notes => 'city population rounded to 2 significant digits' },
2123             GeolocationDistance => { %geoInfo, Notes => 'distance in km from current GPS to city', PrintConv => '"$val km"' },
2124             GeolocationPosition => { %geoInfo, Notes => 'approximate GPS coordinates of city',
2125             PrintConv => '$val =~ s/ /, /; $val',
2126             },
2127             GeolocationWarning => { %geoInfo },
2128             );
2129              
2130             # tags defined by UserParam option (added at runtime)
2131             %Image::ExifTool::UserParam = (
2132             GROUPS => { 0 => 'UserParam', 1 => 'UserParam', 2 => 'Other' },
2133             PRIORITY => 0,
2134             );
2135              
2136             # YCbCrSubSampling values (used by JPEG SOF, EXIF and XMP)
2137             %Image::ExifTool::JPEG::yCbCrSubSampling = (
2138             '1 1' => 'YCbCr4:4:4 (1 1)', #PH
2139             '2 1' => 'YCbCr4:2:2 (2 1)', #14 in Exif.pm
2140             '2 2' => 'YCbCr4:2:0 (2 2)', #14 in Exif.pm
2141             '4 1' => 'YCbCr4:1:1 (4 1)', #14 in Exif.pm
2142             '4 2' => 'YCbCr4:1:0 (4 2)', #PH
2143             '1 2' => 'YCbCr4:4:0 (1 2)', #PH
2144             '1 4' => 'YCbCr4:4:1 (1 4)', #JD
2145             '2 4' => 'YCbCr4:2:1 (2 4)', #JD
2146             );
2147              
2148             # define common JPEG segments here to avoid overhead of loading JPEG module
2149              
2150             # JPEG SOF (start of frame) tags
2151             # (ref http://www.w3.org/Graphics/JPEG/itu-t81.pdf)
2152             %Image::ExifTool::JPEG::SOF = (
2153             GROUPS => { 0 => 'File', 1 => 'File', 2 => 'Image' },
2154             NOTES => 'This information is extracted from the JPEG Start Of Frame segment.',
2155             VARS => { ID_FMT => 'none' }, # tag ID's aren't meaningful for these tags
2156             EncodingProcess => {
2157             PrintHex => 1,
2158             PrintConv => {
2159             0x0 => 'Baseline DCT, Huffman coding',
2160             0x1 => 'Extended sequential DCT, Huffman coding',
2161             0x2 => 'Progressive DCT, Huffman coding',
2162             0x3 => 'Lossless, Huffman coding',
2163             0x5 => 'Sequential DCT, differential Huffman coding',
2164             0x6 => 'Progressive DCT, differential Huffman coding',
2165             0x7 => 'Lossless, Differential Huffman coding',
2166             0x9 => 'Extended sequential DCT, arithmetic coding',
2167             0xa => 'Progressive DCT, arithmetic coding',
2168             0xb => 'Lossless, arithmetic coding',
2169             0xd => 'Sequential DCT, differential arithmetic coding',
2170             0xe => 'Progressive DCT, differential arithmetic coding',
2171             0xf => 'Lossless, differential arithmetic coding',
2172             }
2173             },
2174             BitsPerSample => { },
2175             ImageHeight => { },
2176             ImageWidth => { },
2177             ColorComponents => { },
2178             YCbCrSubSampling => {
2179             Notes => 'calculated from components table',
2180             PrintConv => \%Image::ExifTool::JPEG::yCbCrSubSampling,
2181             },
2182             );
2183              
2184             # JPEG JFIF APP0 definitions
2185             %Image::ExifTool::JFIF::Main = (
2186             PROCESS_PROC => \&Image::ExifTool::ProcessBinaryData,
2187             WRITE_PROC => \&Image::ExifTool::WriteBinaryData,
2188             CHECK_PROC => \&Image::ExifTool::CheckBinaryData,
2189             GROUPS => { 0 => 'JFIF', 1 => 'JFIF', 2 => 'Image' },
2190             DATAMEMBER => [ 2, 3, 5 ],
2191             0 => {
2192             Name => 'JFIFVersion',
2193             Format => 'int8u[2]',
2194             PrintConv => 'sprintf("%d.%.2d", split(" ",$val))',
2195             Mandatory => 1,
2196             },
2197             2 => {
2198             Name => 'ResolutionUnit',
2199             Writable => 1,
2200             RawConv => '$$self{JFIFResolutionUnit} = $val',
2201             PrintConv => {
2202             0 => 'None',
2203             1 => 'inches',
2204             2 => 'cm',
2205             },
2206             Priority => -1,
2207             Mandatory => 1,
2208             },
2209             3 => {
2210             Name => 'XResolution',
2211             Format => 'int16u',
2212             Writable => 1,
2213             Priority => -1,
2214             RawConv => '$$self{JFIFXResolution} = $val',
2215             Mandatory => 1,
2216             },
2217             5 => {
2218             Name => 'YResolution',
2219             Format => 'int16u',
2220             Writable => 1,
2221             Priority => -1,
2222             RawConv => '$$self{JFIFYResolution} = $val',
2223             Mandatory => 1,
2224             },
2225             7 => {
2226             Name => 'ThumbnailWidth',
2227             RawConv => '$val ? $$self{JFIFThumbnailWidth} = $val : undef',
2228             },
2229             8 => {
2230             Name => 'ThumbnailHeight',
2231             RawConv => '$val ? $$self{JFIFThumbnailHeight} = $val : undef',
2232             },
2233             9 => {
2234             Name => 'ThumbnailTIFF',
2235             Groups => { 2 => 'Preview' },
2236             Format => 'undef[3*($val{7}||0)*($val{8}||0)]',
2237             Notes => 'raw RGB thumbnail data, extracted as a TIFF image',
2238             RawConv => 'length($val) ? $val : undef',
2239             ValueConv => sub {
2240             my ($val, $et) = @_;
2241             my $len = length $val;
2242             return \ "Binary data $len bytes" unless $et->Options('Binary');
2243             my $img = MakeTiffHeader($$et{JFIFThumbnailWidth},$$et{JFIFThumbnailHeight},3,8) . $val;
2244             return \$img;
2245             },
2246             },
2247             );
2248             %Image::ExifTool::JFIF::Extension = (
2249             GROUPS => { 0 => 'JFIF', 1 => 'JFXX', 2 => 'Image' },
2250             NOTES => 'Thumbnail images extracted from the JFXX segment.',
2251             0x10 => {
2252             Name => 'ThumbnailImage',
2253             Groups => { 2 => 'Preview' },
2254             Notes => 'JPEG-format thumbnail image',
2255             RawConv => '$self->ValidateImage(\$val,$tag)',
2256             },
2257             0x11 => { # (untested)
2258             Name => 'ThumbnailTIFF',
2259             Groups => { 2 => 'Preview' },
2260             Notes => 'raw palette-color thumbnail data, extracted as a TIFF image',
2261             RawConv => '(length $val > 770 and $val !~ /^\0\0/) ? $val : undef',
2262             ValueConv => sub {
2263             my ($val, $et) = @_;
2264             my $len = length $val;
2265             return \ "Binary data $len bytes" unless $et->Options('Binary');
2266             my ($w, $h) = unpack('CC', $val);
2267             my $img = MakeTiffHeader($w,$h,1,8,undef,substr($val,2,768)) . substr($val,770);
2268             return \$img;
2269             },
2270             },
2271             0x13 => {
2272             Name => 'ThumbnailTIFF',
2273             Groups => { 2 => 'Preview' },
2274             Notes => 'raw RGB thumbnail data, extracted as a TIFF image',
2275             RawConv => '(length $val > 2 and $val !~ /^\0\0/) ? $val : undef',
2276             ValueConv => sub {
2277             my ($val, $et) = @_;
2278             my $len = length $val;
2279             return \ "Binary data $len bytes" unless $et->Options('Binary');
2280             my ($w, $h) = unpack('CC', $val);
2281             my $img = MakeTiffHeader($w,$h,3,8) . substr($val,2);
2282             return \$img;
2283             },
2284             },
2285             # Apple may add "AMPF" to the end of the JFIF record,
2286             # possibly indicating the existence of MPF images (ref forum12677)
2287             );
2288              
2289             # Composite tags (accumulation of all Composite tag tables)
2290             %Image::ExifTool::Composite = (
2291             GROUPS => { 0 => 'Composite', 1 => 'Composite' },
2292             TABLE_NAME => 'Image::ExifTool::Composite',
2293             SHORT_NAME => 'Composite',
2294             VARS => { ID_FMT => 'none' }, # want empty tagID's for Composite tags
2295             WRITE_PROC => \&DummyWriteProc,
2296             );
2297              
2298             my %compositeID; # lookup for new ID's of Composite tags based on original ID
2299              
2300             # static private ExifTool variables
2301              
2302             %allTables = ( ); # list of all tables loaded (except Composite tags)
2303             @tableOrder = ( ); # order the tables were loaded
2304              
2305             #------------------------------------------------------------------------------
2306             # Warning handler routines (warning string stored in $evalWarning)
2307             #
2308             # Set warning message
2309             # Inputs: 0) warning string (undef to reset warning)
2310 41     41 0 502 sub SetWarning($) { $evalWarning = $_[0]; }
2311              
2312             # Get warning message
2313 17     17 0 47 sub GetWarning() { return $evalWarning; }
2314              
2315             # Clean unnecessary information (line number, LF) from warning
2316             # Inputs: 0) warning string or undef to use $evalWarning
2317             # Returns: cleaned warning
2318             sub CleanWarning(;$)
2319             {
2320 226     226 0 292 my $str = shift;
2321 226 50       394 unless (defined $str) {
2322 226 50       408 return undef unless defined $evalWarning;
2323 226         266 $str = $evalWarning;
2324             }
2325             # truncate at first " at " for warnings like "syntax error at (eval 80) line 1, at EOF"
2326 226 100       1212 $str = $1 if $str =~ /(.*?) at /s;
2327 226         706 $str =~ s/\s+$//s;
2328 226         736 return $str;
2329             }
2330              
2331             #==============================================================================
2332             # New - create new ExifTool object
2333             # Inputs: 0) reference to exiftool object or ExifTool class name
2334             # Returns: blessed ExifTool object ref
2335             sub new
2336             {
2337 508     508 1 14014112 local $_;
2338 508         1185 my $that = shift;
2339 508   50     3507 my $class = ref($that) || $that || 'Image::ExifTool';
2340 508         1465 my $self = bless {}, $class;
2341              
2342             # make sure our main Exif tag table has been loaded
2343 508         2300 GetTagTable("Image::ExifTool::Exif::Main");
2344              
2345 508         2450 $self->ClearOptions(); # create default options hash
2346 508         1193 $$self{VALUE} = { }; # must initialize this for warning messages
2347 508         1246 $$self{PATH} = [ ]; # (this too)
2348 508         1192 $$self{DEL_GROUP} = { }; # lookup for groups to delete when writing
2349 508         1191 $$self{SAVE_COUNT} = 0; # count calls to SaveNewValues()
2350 508         1182 $$self{NV_COUNT} = 0; # count of NEW_VALUE entries
2351 508         1292 $$self{FILE_SEQUENCE} = 0; # sequence number for files when reading
2352 508         1258 $$self{FILES_WRITTEN} = 0; # count of files successfully written
2353 508         1161 $$self{INDENT2} = ''; # indentation of verbose messages from SetNewValue
2354 508         1045 $$self{ALT_EXIFTOOL} = { }; # alternate exiftool objects
2355              
2356             # initialize our new groups for writing
2357 508         2351 $self->SetNewGroups(@defaultWriteGroups);
2358              
2359 508         2059 return $self;
2360             }
2361              
2362             #------------------------------------------------------------------------------
2363             # ImageInfo - return specified information from image file
2364             # Inputs: 0) [optional] ExifTool object reference
2365             # 1) filename, file reference, or scalar data reference
2366             # 2-N) list of tag names to find (or tag list reference or options reference)
2367             # Returns: reference to hash of tag/value pairs (with "Error" entry on error)
2368             # Notes:
2369             # - if no tags names are specified, the values of all tags are returned
2370             # - tags may be specified with leading '-' to exclude, or trailing '#' for ValueConv
2371             # - can pass a reference to list of tags to find, in which case the list will
2372             # be updated with the tags found in the proper case and in the specified order.
2373             # - can pass reference to hash specifying options
2374             # - returned tag values may be scalar references indicating binary data
2375             # - see ClearOptions() below for a list of options and their default values
2376             # Examples:
2377             # use Image::ExifTool 'ImageInfo';
2378             # my $info = ImageInfo($file, 'DateTimeOriginal', 'ImageSize');
2379             # - or -
2380             # my $et = Image::ExifTool->new;
2381             # my $info = $et->ImageInfo($file, \@tagList, {Sort=>'Group0'} );
2382             sub ImageInfo($;@)
2383             {
2384 539     539 1 143778 local $_;
2385             # get our ExifTool object ($self) or create one if necessary
2386 539         894 my $self;
2387 539 100 100     4336 if (ref $_[0] and UNIVERSAL::isa($_[0],'Image::ExifTool')) {
2388 530         1037 $self = shift;
2389             } else {
2390 9         62 $self = Image::ExifTool->new;
2391             }
2392 539         902 my %saveOptions = %{$$self{OPTIONS}}; # save original options
  539         26365  
2393              
2394             # initialize file information
2395 539         3841 $$self{FILENAME} = $$self{RAF} = undef;
2396              
2397 539         2777 $self->ParseArguments(@_); # parse our function arguments
2398 539         2524 $self->ExtractInfo(undef); # extract meta information from image
2399 539         2366 my $info = $self->GetInfo(undef); # get requested information
2400              
2401 539         10710 $$self{OPTIONS} = \%saveOptions; # restore original options
2402              
2403 539         3184 return $info; # return requested information
2404             }
2405              
2406             #------------------------------------------------------------------------------
2407             # Get/set ExifTool options
2408             # Inputs: 0) ExifTool object reference,
2409             # 1) Parameter name (case insensitive), 2) Value to set the option
2410             # 3-N) More parameter/value pairs
2411             # Returns: original value of last option specified
2412             sub Options($$;@)
2413             {
2414 23373     23373 1 42584 local $_;
2415 23373         25271 my $self = shift;
2416 23373         30159 my $options = $$self{OPTIONS};
2417 23373         23666 my $oldVal;
2418              
2419 23373         35526 while (@_) {
2420 23886         27572 my $param = shift;
2421 23886         24075 my $plus;
2422             # fix parameter case if necessary
2423 23886 100       41080 unless (exists $$options{$param}) {
2424 535         1545 $plus = $param =~ s/\+$//;
2425 535         49474 my ($fixed) = grep /^$param$/i, keys %$options;
2426 535 50       3137 if ($fixed) {
2427 0         0 $param = $fixed;
2428             } else {
2429 535         1651 $param =~ s/^Group(\d*)$/Group$1/i;
2430             }
2431             }
2432 23886         30435 $oldVal = $$options{$param};
2433 23886 50 33     37848 if (ref $oldVal eq 'HASH' and ($param eq 'Compact' or $param eq 'XMPShorthand')) {
      66        
2434             # get previous Compact/XMPShorthand setting
2435 0         0 $oldVal = $$oldVal{$param};
2436             }
2437 23886 100       38862 last unless @_;
2438 6137         6558 my $newVal = shift;
2439 6137 100 66     53792 if ($param eq 'Lang') {
    100 100        
    100 66        
    100 100        
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    50          
2440             # allow this to be set to undef to select the default language
2441 78 50       308 $newVal = $defaultLang unless defined $newVal;
2442 78 100       304 if ($newVal eq $defaultLang) {
2443 59         144 $$options{$param} = $newVal;
2444 59         146 delete $$self{CUR_LANG};
2445             # make sure the language is available
2446             } else {
2447 19         60 my %langs = map { $_ => 1 } @langs;
  361         829  
2448 19 50 33     1704 if ($langs{$newVal} and eval "require Image::ExifTool::Lang::$newVal") {
2449 19         76 my $xlat = "Image::ExifTool::Lang::${newVal}::Translate";
2450 113     113   986 no strict 'refs';
  113         247  
  113         529173  
2451 19 50       134 if (%$xlat) {
2452 19         99 $$self{CUR_LANG} = \%$xlat;
2453 19         242 $$options{$param} = $newVal;
2454             }
2455             }
2456             } # else don't change Lang
2457             } elsif ($param eq 'Exclude' and defined $newVal) {
2458             # clone Exclude list and expand shortcuts
2459 8         17 my @exclude;
2460 8 100       31 if (ref $newVal eq 'ARRAY') {
2461 7         25 @exclude = @$newVal;
2462             } else {
2463 1         2 @exclude = ($newVal);
2464             }
2465 8         34 ExpandShortcuts(\@exclude, 1); # (also remove '#' suffix)
2466 8         29 $$options{$param} = \@exclude;
2467             } elsif ($param =~ /^Charset/ or $param eq 'IPTCCharset') {
2468             # only allow valid character sets to be set
2469 364 100 66     957 if ($newVal) {
    50 33        
    0          
2470 245         584 my $charset = $charsetName{lc $newVal};
2471 245 50       427 if ($charset) {
2472 245         342 $$options{$param} = $charset;
2473             # maintain backward-compatibility with old IPTCCharset option
2474 245 100       600 $$options{CharsetIPTC} = $charset if $param eq 'IPTCCharset';
2475             } else {
2476 0         0 warn "Invalid Charset $newVal\n";
2477             }
2478             } elsif ($param eq 'CharsetEXIF' or $param eq 'CharsetFileName' or $param eq 'CharsetRIFF') {
2479 119         263 $$options{$param} = $newVal; # only these may be set to a false value
2480             } elsif ($param eq 'CharsetQuickTime') {
2481 0         0 $$options{$param} = 'MacRoman'; # QuickTime defaults to MacRoman
2482             } else {
2483 0         0 $$options{$param} = 'Latin'; # all others default to Latin
2484             }
2485             } elsif ($param eq 'UserParam') {
2486             # clear options if $newVal is undef
2487 59 50       169 defined $newVal or $$options{$param} = {}, next;
2488 59         203 my $table = GetTagTable('Image::ExifTool::UserParam');
2489             # allow initialization of entire UserParam hash
2490 59 50       231 if (ref $newVal eq 'HASH') {
2491 59         109 my %newParams;
2492 59         211 foreach (sort keys %$newVal) {
2493 0         0 my $lcTag = lc $_;
2494 0         0 $newParams{$lcTag} = $$newVal{$_};
2495 0         0 delete $$table{$lcTag};
2496 0         0 AddTagToTable($table, $lcTag, $_);
2497             }
2498 59         154 $$options{$param} = \%newParams;
2499 59         176 next;
2500             }
2501 0         0 my ($force, $paramName);
2502             # set/reset single UserParam parameter
2503 0 0       0 if ($newVal =~ /(.*?)=(.*)/s) {
2504 0         0 $paramName = $1;
2505 0         0 $newVal = $2;
2506 0 0       0 $force = 1 if $paramName =~ s/\^$//;
2507 0         0 $paramName =~ tr/-_a-zA-Z0-9#//dc;
2508 0         0 $param = lc $paramName;
2509             } else {
2510 0         0 ($param = lc $newVal) =~ tr/-_a-zA-Z0-9#//dc;
2511 0         0 undef $newVal;
2512             }
2513 0         0 delete $$table{$param};
2514 0         0 $oldVal = $$options{UserParam}{$param};
2515 0 0       0 if (defined $newVal) {
2516 0 0 0     0 if (length $newVal or $force) {
2517 0         0 $$options{UserParam}{$param} = $newVal;
2518 0         0 AddTagToTable($table, $param, $paramName);
2519             } else {
2520 0         0 delete $$options{UserParam}{$param};
2521             }
2522             }
2523             # remove alternate version of tag
2524 0 0       0 $param .= '#' unless $param =~ s/#$//;
2525 0         0 delete $$table{$param};
2526 0         0 delete $$options{UserParam}{$param};
2527             } elsif ($param eq 'RequestTags') {
2528 102 100       246 if (defined $newVal) {
2529             # parse list from delimited string if necessary
2530 43 50       218 my @reqList = (ref $newVal eq 'ARRAY') ? @$newVal : ($newVal =~ /[-\w?*:]+/g);
2531 43         154 ExpandShortcuts(\@reqList);
2532             # add to existing list
2533 43 50       230 $$options{$param} or $$options{$param} = [ ];
2534 43         108 foreach (@reqList) {
2535 65 50       340 /^(.*:)?([-\w?*]*)#?$/ or next;
2536 65 50       217 push @{$$options{$param}}, lc($2) if $2;
  65         248  
2537 65 50       262 next unless $1;
2538             # add requested groups with trailing colon
2539 0         0 push @{$$options{$param}}, lc($_).':' foreach split /:/, $1;
  0         0  
2540             }
2541             } else {
2542 59         175 $$options{$param} = undef; # clear the list
2543             }
2544             } elsif ($param =~ /^(IgnoreTags|IgnoreGroups)$/) {
2545 118 50       243 if (defined $newVal) {
2546 0 0       0 ref $newVal eq 'HASH' and $$options{$param} = $newVal, next;
2547             # parse list from delimited string if necessary
2548 0 0       0 my @ignoreList = (ref $newVal eq 'ARRAY') ? @$newVal : ($newVal =~ /[-\w?*:#]+/g);
2549 0 0       0 ExpandShortcuts(\@ignoreList) if $param eq 'IgnoreTags';
2550             # add to existing tags/groups to ignore
2551 0 0       0 $$options{$param} or $$options{$param} = { };
2552 0         0 foreach (@ignoreList) {
2553 0 0       0 /^(.*:)?([-\w?*]+)#?$/ or next;
2554 0         0 $$options{$param}{lc $2} = 1;
2555             }
2556             } else {
2557 118         272 $$options{$param} = undef; # clear the option
2558             }
2559             } elsif ($param eq 'ListJoin') {
2560 12         44 $$options{$param} = $newVal;
2561             # set the old List and ListSep options for backward compatibility
2562 12 100       30 if (defined $newVal) {
2563 4         9 $$options{List} = 0;
2564 4         15 $$options{ListSep} = $newVal;
2565             } else {
2566 8         28 $$options{List} = 1;
2567             # (ListSep must be defined)
2568             }
2569             } elsif ($param eq 'List') {
2570 78         180 $$options{$param} = $newVal;
2571             # set the new ListJoin option for forward compatibility
2572 78 50       268 $$options{ListJoin} = $newVal ? undef : $$options{ListSep};
2573             } elsif ($param eq 'Compact' or $param eq 'XMPShorthand') {
2574             # set Compact and XMPShorthand options, preserving backward compatibility
2575 1         3 my ($p, %compact);
2576 1         2 foreach $p ('Compact','XMPShorthand') {
2577             # (allow setting from a HASH (undocumented)
2578 2 50       10 ref $newVal eq 'HASH' and %compact = %{$newVal}, next;
  0         0  
2579 2 100       7 my $val = $param eq $p ? $newVal : $$options{Compact}{$p};
2580 2 100       7 if (defined $val) {
2581 1         8 my @v = ($val =~ /\w+/g);
2582 1 50       7 my $opt = ($p eq 'Compact') ? \%compactOpt : \%xmpShorthandOpt;
2583 1         4 foreach (@v) {
2584 1 50       7 my $set = $$opt{lc $_} or warn("Invalid $p setting '${_}'\n"), return $oldVal;
2585 1 50       11 ref $set or $compact{$set} = 1, next;
2586 0         0 $compact{$_} = 1 foreach @$set;
2587             }
2588             }
2589 2         8 $compact{$p} = $val; # preserve most recent setting
2590             }
2591 1         6 $$options{Compact} = $$options{XMPShorthand} = \%compact;
2592             } elsif ($param eq 'NoWarning') {
2593             # validate regular expression
2594 59         139 undef $evalWarning;
2595 59 50       213 if (defined $newVal) {
2596 0         0 local $SIG{'__WARN__'} = \&SetWarning;
2597 0         0 eval { $param =~ /$newVal/ };
  0         0  
2598 0 0       0 $@ and $evalWarning = $@;
2599             }
2600 59 50       186 if ($evalWarning) {
2601 0         0 warn 'NoWarning: ' . CleanWarning() . "\n";
2602 0         0 next;
2603             }
2604             # add to existing expression if specified
2605 59 50 33     257 if ($plus and defined $oldVal) {
2606 0 0       0 $newVal = defined $newVal ? "$oldVal|$newVal" : $oldVal;
2607             }
2608 59         162 $$options{$param} = $newVal;
2609             } elsif ($param eq 'ImageHashType') {
2610 59 50       396 if (not defined $newVal) {
    50          
2611 0         0 warn("Can't set $param to undef\n");
2612             } elsif ($newVal =~ /^(MD5|SHA256|SHA512)$/i) {
2613 59         258 $$options{$param} = uc($newVal);
2614             } else {
2615 0         0 warn("Invalid $param setting '${newVal}'\n");
2616             }
2617             } elsif ($param eq 'StructFormat') {
2618 59 50       184 if (defined $newVal) {
2619 0 0       0 $newVal =~ /^(JSON|JSONQ)$/i or warn("Invalid $param setting '${newVal}'\n"), next;
2620 0         0 $newVal = uc($newVal);
2621             }
2622 59         139 $$options{$param} = $newVal;
2623             } elsif ($param eq 'ByteUnit') {
2624 59 50       155 if (defined $newVal) {
2625             # (allow "Metric" or "SI" for SI, and "IT" or "Binary" for Binary)
2626 59 0       355 my $goodVal = ($newVal =~ /^S|M/i ? 'SI' : ($newVal =~ /^I|B/i ? 'Binary' : undef));
    50          
2627 59 50       180 $goodVal or warn("Invalid $param setting '${newVal}'\n"), next;
2628 59         191 $$options{$param} = $goodVal;
2629             } else {
2630 0         0 warn("Can't set $param to undef\n");
2631             }
2632             } elsif ($param eq 'Plot') {
2633             # add to existing plot settings
2634 0 0 0     0 $newVal = "$oldVal,$newVal" if defined $oldVal and defined $newVal;
2635 0         0 $$options{$param} = $newVal;
2636             } elsif ($param eq 'KeepUTCTime' or $param eq 'SystemTimeRes') {
2637 118         347 $$options{$param} = $static_vars{$param} = $newVal;
2638             } elsif (lc $param eq 'geodir') {
2639 0         0 $Image::ExifTool::Geolocation::geoDir = $newVal;
2640             } else {
2641 4963 100 66     15036 if ($param eq 'Escape') {
    100 33        
    50          
    100          
2642             # set ESCAPE_PROC
2643 65 50 66     425 if (defined $newVal and $newVal eq 'XML') {
    100 66        
2644 0         0 require Image::ExifTool::XMP;
2645 0         0 $$self{ESCAPE_PROC} = \&Image::ExifTool::XMP::EscapeXML;
2646             } elsif (defined $newVal and $newVal eq 'HTML') {
2647 5         1555 require Image::ExifTool::HTML;
2648 5         23 $$self{ESCAPE_PROC} = \&Image::ExifTool::HTML::EscapeHTML;
2649             } else {
2650 60         112 delete $$self{ESCAPE_PROC};
2651             }
2652             # must forget saved values since they depend on Escape method
2653 65         212 $$self{BOTH} = { };
2654             } elsif ($param eq 'GlobalTimeShift') {
2655 60         126 delete $$self{GLOBAL_TIME_OFFSET}; # reset our calculated offset
2656             } elsif ($param eq 'TimeZone' and defined $newVal and length $newVal) {
2657 0         0 $ENV{TZ} = $newVal;
2658 0 0       0 if ($^O eq 'MSWin32') {
2659 0 0       0 if (eval { require Time::Piece }) {
  0         0  
2660 0         0 eval { Time::Piece::_tzset() };
  0         0  
2661             } else {
2662 0         0 warn("Install Time::Piece to set time zone in Windows\n");
2663             }
2664             } else {
2665 0         0 eval { require POSIX; POSIX::tzset() };
  0         0  
  0         0  
2666             }
2667             } elsif ($param eq 'Validate') {
2668             # load Validate module if Validate option enabled
2669 60 100       1028 $newVal and require Image::ExifTool::Validate;
2670             }
2671 4963         9795 $$options{$param} = $newVal;
2672             }
2673             }
2674 23373         50069 return $oldVal;
2675             }
2676              
2677             #------------------------------------------------------------------------------
2678             # ClearOptions - set options to default values
2679             # Inputs: 0) ExifTool object reference
2680             sub ClearOptions($)
2681             {
2682 508     508 1 920 local $_;
2683 508         2378 my $self = shift;
2684 508         6913 my $opts = $$self{OPTIONS} = { }; # clear all options
2685              
2686             # load default options
2687 508         62499 $$opts{$$_[0]} = $$_[1] foreach @availableOptions;
2688              
2689             # enable WindowsLongPath if Win32::API is available
2690 508 50 33     3099 $$opts{WindowsLongPath} = 1 if $^O eq 'MSWin32' and eval { require Win32::API };
  0         0  
2691              
2692             # keep necessary member variables in sync with options
2693 508         1103 delete $$self{CUR_LANG};
2694 508         989 delete $$self{ESCAPE_PROC};
2695              
2696             # load user-defined default options
2697 508 50       1793 if (%Image::ExifTool::UserDefined::Options) {
2698 0         0 foreach (keys %Image::ExifTool::UserDefined::Options) {
2699 0         0 $self->Options($_, $Image::ExifTool::UserDefined::Options{$_});
2700             }
2701             }
2702             }
2703              
2704             #------------------------------------------------------------------------------
2705             # Extract meta information from image
2706             # Inputs: 0) ExifTool object reference
2707             # 1-N) Same as ImageInfo()
2708             # Returns: 1 if this was a valid image, 0 otherwise
2709             # Notes: pass an undefined value to avoid parsing arguments
2710             # Internal 'ReEntry' option allows this routine to be called recursively
2711             sub ExtractInfo($;@)
2712             {
2713 552     552 1 1105 local $_;
2714 552         999 my $self = shift;
2715 552         1135 my $options = $$self{OPTIONS}; # pointer to current options
2716 552   100     2205 my $fast = $$options{FastScan} || 0;
2717 552         1025 my $req = $$self{REQ_TAG_LOOKUP};
2718 552   100     2020 my $reqAll = $$options{RequestAll} || 0;
2719 552         1209 my (%saveOptions, $reEntry, $rsize, $zid, $type, @startTime, $saveOrder, $isDir, $i);
2720              
2721             # check for internal ReEntry option to allow recursive calls to ExtractInfo
2722 552 100 100     2235 if (ref $_[1] eq 'HASH' and $_[1]{ReEntry} and
      33        
      66        
2723             (ref $_[0] eq 'SCALAR' or ref $_[0] eq 'GLOB'))
2724             {
2725             # save necessary members for restoring later
2726             $reEntry = {
2727             RAF => $$self{RAF},
2728             PROCESSED => $$self{PROCESSED},
2729             EXIF_DATA => $$self{EXIF_DATA},
2730             EXIF_POS => $$self{EXIF_POS},
2731             FILE_TYPE => $$self{FILE_TYPE},
2732 2         22 };
2733             $saveOrder = GetByteOrder(),
2734 2         5 $$self{RAF} = File::RandomAccess->new($_[0]);
2735 2         4 $$self{PROCESSED} = { };
2736 2         4 delete $$self{EXIF_DATA};
2737 2         3 delete $$self{EXIF_POS};
2738             } else {
2739 550 100 66     4077 if (defined $_[0] or $$options{HtmlDump} or $$req{validate}) {
      66        
2740 12         632 %saveOptions = %$options; # save original options
2741              
2742             # require duplicates for html dump
2743 12 50       80 $self->Options(Duplicates => 1) if $$options{HtmlDump};
2744             # enable Validate option if Validate tag is requested
2745 12 100       44 $self->Options(Validate => 1) if $$req{validate};
2746 12 100       37 if (defined $_[0]) {
2747             # only initialize filename if called with arguments
2748 11         30 $$self{FILENAME} = undef; # name of file (or '' if we didn't open it)
2749 11         33 $$self{RAF} = undef; # RandomAccess object reference
2750              
2751 11         54 $self->ParseArguments(@_); # initialize from our arguments
2752             }
2753             }
2754             # ignore all tags and set ExtractEmbedded if outputting CSV directly
2755 550 50       1587 if ($self->Options('PrintCSV')) {
2756 0         0 $$self{OPTIONS}{IgnoreTags} = { all => 1 };
2757 0         0 $self->Options(ExtractEmbedded => 1);
2758             }
2759             # initialize ExifTool object members
2760 550         2374 $self->Init();
2761 550         1136 $$self{InExtract} = 1; # set flag indicating we are inside ExtractInfo
2762              
2763 550         903 delete $$self{MAKER_NOTE_FIXUP}; # fixup information for extracted maker notes
2764 550         972 delete $$self{MAKER_NOTE_BYTE_ORDER};
2765              
2766             # return our version number
2767 550         3530 $self->FoundTag('ExifToolVersion', "$VERSION$RELEASE");
2768 550 100 66     2880 $self->FoundTag('Now', $self->TimeNow()) if $$req{now} or $reqAll;
2769 550 100 66     2616 $self->FoundTag('NewGUID', NewGUID()) if $$req{newguid} or $reqAll;
2770             # generate sequence number if necessary
2771 550 100 66     2591 $self->FoundTag('FileSequence', $$self{FILE_SEQUENCE}) if $$req{filesequence} or $reqAll;
2772              
2773 550 100 66     2309 if ($$req{processingtime} or $reqAll) {
2774 61         152 eval { require Time::HiRes; @startTime = Time::HiRes::gettimeofday() };
  61         8277  
  61         19861  
2775 61 0 33     238 if (not @startTime and $$req{processingtime}) {
2776 0         0 $self->Warn('Install Time::HiRes to generate ProcessingTime');
2777             }
2778             }
2779              
2780             # create Hash object if ImageDataHash is requested
2781 550 50 33     1885 if ($$req{imagedatahash} and not $$self{ImageDataHash}) {
2782 0         0 my $imageHashType = $self->Options('ImageHashType');
2783 0 0       0 if ($imageHashType =~ /^SHA(256|512)$/i) {
    0          
2784 0 0       0 if (require Digest::SHA) {
2785 0         0 $$self{ImageDataHash} = Digest::SHA->new($1);
2786             } else {
2787 0         0 $self->Warn("Install Digest::SHA to calculate image data SHA$1");
2788             }
2789             } elsif (require Digest::MD5) {
2790 0         0 $$self{ImageDataHash} = Digest::MD5->new;
2791             } else {
2792 0         0 $self->Warn('Install Digest::MD5 to calculate image data MD5');
2793             }
2794             }
2795 550         1177 ++$$self{FILE_SEQUENCE}; # count files read
2796             }
2797              
2798 552         1272 my $filename = $$self{FILENAME}; # image file name ('' if already open)
2799 552         1004 my $raf = $$self{RAF}; # RandomAccess object
2800              
2801 552         1681 local *EXIFTOOL_FILE; # avoid clashes with global namespace
2802              
2803 552         990 my $realname = $filename;
2804 552 100       1354 unless ($raf) {
2805             # save file name
2806 505 50 33     2297 if (defined $filename and $filename ne '') {
2807 505 50       1406 unless ($filename eq '-') {
2808             # extract file name from pipe if necessary
2809 505 50       1715 $realname =~ /\|$/ and $realname =~ s/^.*?"(.*?)".*/$1/s;
2810 505         1897 my ($dir, $name) = SplitFileName($realname);
2811 505         2108 $self->FoundTag('FileName', $name);
2812 505 100 66     2811 if ($$req{basename} or
      66        
2813             ($reqAll and not $$self{EXCL_TAG_LOOKUP}{basename}))
2814             {
2815 61 50       458 $self->FoundTag('BaseName', $name =~ /(.*)\./ ? $1 : $name);
2816             }
2817 505 50 33     3180 $self->FoundTag('Directory', $dir) if defined $dir and length $dir;
2818 505 100 66     2824 if ($$req{filepath} or
      66        
2819             ($reqAll and not $$self{EXCL_TAG_LOOKUP}{filepath}))
2820             {
2821 61         116 my $path;
2822 61         213 local $SIG{'__WARN__'} = \&SetWarning;
2823 61 50 33     336 if ($^O eq 'MSWin32' and $$options{WindowsLongPath}) {
    50          
2824 0         0 $path = $self->WindowsLongPath($filename);
2825 61         471 } elsif (eval { require Cwd }) {
2826 61         99 $path = eval { Cwd::abs_path($filename) };
  61         3404  
2827             }
2828 61 50       238 if (defined $path) {
    0          
2829 61 50       223 $path =~ tr/\\/\// if $^O eq 'MSWin32'; # return forward slashes
2830 61         227 $self->FoundTag('FilePath', $path);
2831             } elsif ($$req{filepath}) {
2832 0         0 $self->Warn('The Perl Cwd module must be installed to use FilePath');
2833             }
2834             }
2835             # get size of resource fork on Mac OS
2836 505 50 33     2178 $rsize = -s "$filename/..namedfork/rsrc" if $^O eq 'darwin' and not $$self{IN_RESOURCE};
2837             # check to see if Zone.Identifier file exists in Windows
2838 505 50 33     1844 if ($^O eq 'MSWin32' and eval { require Win32API::File }) {
  0         0  
2839 0         0 my $wattr;
2840 0         0 my $zfile = "${filename}:Zone.Identifier";
2841 0 0       0 if ($self->EncodeFileName($zfile)) {
2842 0         0 $wattr = eval { Win32API::File::GetFileAttributesW($zfile) };
  0         0  
2843             } else {
2844 0         0 $wattr = eval { Win32API::File::GetFileAttributes($zfile) };
  0         0  
2845             }
2846 0 0       0 $zid = 1 unless $wattr == Win32API::File::INVALID_FILE_ATTRIBUTES();
2847             }
2848             }
2849             # open the file
2850 505 50       2417 if ($self->Open(\*EXIFTOOL_FILE, $filename)) {
    0          
2851             # create random access file object
2852 505         5172 $raf = File::RandomAccess->new(\*EXIFTOOL_FILE);
2853             # patch to force pipe to be buffered because seek returns success
2854             # in Windows cmd shell pipe even though it really failed
2855 505 50 33     2851 $$raf{TESTED} = -1 if $filename eq '-' or $filename =~ /\|$/;
2856 505         1346 $$self{RAF} = $raf;
2857             } elsif ($self->IsDirectory($filename)) {
2858 0         0 $isDir = 1;
2859             } else {
2860 0         0 $self->Error('Error opening file');
2861             # continue to process alt files if necessary
2862 0 0       0 $self->DoneExtract() if $$self{ALT_EXIFTOOL};
2863             }
2864             } else {
2865 0         0 $self->Error('No file specified');
2866             }
2867             }
2868              
2869 552   33     1989 while ($raf or $isDir) {
2870 552         1049 my (@stat, $plainFile);
2871 552 100       6690 if ($reEntry) {
    50          
    100          
    50          
2872             # we already set these tags
2873             } elsif (not $raf) {
2874 0         0 @stat = stat $filename;
2875             } elsif (not $$raf{FILE_PT}) {
2876             # get file size from image in memory
2877 25         81 $self->FoundTag('FileSize', length ${$$raf{BUFF_PT}});
  25         92  
2878             } elsif (-f $$raf{FILE_PT}) {
2879             # get file tags if this is a plain file
2880 525         2000 @stat = stat _;
2881 525         1089 $plainFile = 1;
2882             # hack to patch Windows daylight savings time bug
2883 525 50       1852 @stat[8,9,10] = $self->GetFileTime($$raf{FILE_PT}) if $^O eq 'MSWin32';
2884             } else {
2885             # (note that Windows directories will still show the
2886             # daylight savings time bug -- should fix this sometime)
2887 0         0 @stat = stat $$raf{FILE_PT};
2888 0 0       0 $stat[7] = undef if -p $$raf{FILE_PT}; # (pipe buffer size isn't useful)
2889             }
2890 552         1118 my $fileSize = $stat[7];
2891 552 100       2906 $self->FoundTag('FileSize', $stat[7]) if defined $stat[7];
2892 552 50       1471 $self->FoundTag('ResourceForkSize', $rsize) if $rsize;
2893 552 50       1419 $self->FoundTag('ZoneIdentifier', 'Exists') if $zid;
2894 552 100       2127 $self->FoundTag('FileModifyDate', $stat[9]) if defined $stat[9];
2895 552 100       2097 $self->FoundTag('FileAccessDate', $stat[8]) if defined $stat[8];
2896 552 50       1809 my $cTag = $^O eq 'MSWin32' ? 'FileCreateDate' : 'FileInodeChangeDate';
2897 552 100       2254 $self->FoundTag($cTag, $stat[10]) if defined $stat[10];
2898 552 50 66     2965 if ($^O eq 'linux' and @stat and eval { require File::StatX }) {
  525   66     61336  
2899 0         0 my $stat;
2900 0         0 local $SIG{'__WARN__'} = \&SetWarning;
2901 0 0       0 if ($raf) {
2902 0         0 eval { $stat=File::StatX::fstatx($$raf{FILE_PT}, 0, File::StatX::STATX_BTIME()) };
  0         0  
2903             } else {
2904 0         0 eval { $stat=File::StatX::statx($filename, 0, File::StatX::STATX_BTIME()) };
  0         0  
2905             }
2906 0 0 0     0 $self->FoundTag('FileCreateDate', $stat->btime) if $stat and $stat->btime;
2907             }
2908 552 100       2885 $self->FoundTag('FilePermissions', $stat[2]) if defined $stat[2];
2909             # extract more system info if SystemTags option is set
2910 552 100       1556 if (@stat) {
2911 525   66     3046 my $sys = $$options{SystemTags} || ($reqAll and not defined $$options{SystemTags});
2912 525 100 66     2473 if ($sys or $$req{fileattributes}) {
2913 61         789 my @attr = ($stat[2] & 0xf000, $stat[2] & 0x0e00);
2914             # add Windows file attributes if available
2915 61 0 33     269 if ($^O eq 'MSWin32' and defined $filename and $filename ne '' and $filename ne '-') {
      33        
      0        
2916 0         0 local $SIG{'__WARN__'} = \&SetWarning;
2917 0 0       0 if (eval { require Win32API::File }) {
  0         0  
2918 0         0 my $wattr;
2919 0         0 my $file = $filename;
2920 0 0       0 if ($self->EncodeFileName($file)) {
2921 0         0 $wattr = eval { Win32API::File::GetFileAttributesW($file) };
  0         0  
2922             } else {
2923 0         0 $wattr = eval { Win32API::File::GetFileAttributes($file) };
  0         0  
2924             }
2925 0 0 0     0 push @attr, $wattr if defined $wattr and $wattr != 0xffffffff;
2926             }
2927             }
2928 61         332 $self->FoundTag('FileAttributes', "@attr");
2929             }
2930 525 100 66     2478 $self->FoundTag('FileDeviceNumber', $stat[0]) if $sys or $$req{filedevicenumber};
2931 525 100 66     2713 $self->FoundTag('FileInodeNumber', $stat[1]) if $sys or $$req{fileinodenumber};
2932 525 100 66     2842 $self->FoundTag('FileHardLinks', $stat[3]) if $sys or $$req{filehardlinks};
2933 525 100 66     2472 $self->FoundTag('FileUserID', $stat[4]) if $sys or $$req{fileuserid};
2934 525 100 66     2305 $self->FoundTag('FileGroupID', $stat[5]) if $sys or $$req{filegroupid};
2935 525 100 66     2206 $self->FoundTag('FileDeviceID', $stat[6]) if $sys or $$req{filedeviceid};
2936 525 100 66     2295 $self->FoundTag('FileBlockSize', $stat[11]) if $sys or $$req{fileblocksize};
2937 525 100 66     2300 $self->FoundTag('FileBlockCount', $stat[12]) if $sys or $$req{fileblockcount};
2938             }
2939             # extract MDItem tags if requested (only on plain files)
2940 552 0 33     2174 if ($^O eq 'darwin' and defined $filename and $filename ne '' and defined $fileSize) {
      33        
      0        
2941 0   0     0 my $reqMacOS = ($reqAll > 1 or $$req{'macos:'});
2942 0   0     0 my $crDate = ($reqMacOS || $$req{filecreatedate});
2943 0   0     0 my $mdItem = ($reqMacOS || $$options{MDItemTags} || grep /^mditem/, keys %$req);
2944 0   0     0 my $xattr = ($reqMacOS || $$options{XAttrTags} || grep /^xattr/, keys %$req);
2945 0 0 0     0 if ($crDate or $mdItem or $xattr) {
      0        
2946 0         0 require Image::ExifTool::MacOS;
2947 0 0       0 Image::ExifTool::MacOS::GetFileCreateDate($self, $filename) if $crDate;
2948 0 0 0     0 Image::ExifTool::MacOS::ExtractMDItemTags($self, $filename) if $mdItem and $plainFile;
2949 0 0       0 Image::ExifTool::MacOS::ExtractXAttrTags($self, $filename) if $xattr;
2950             }
2951             }
2952             # do whatever else we can with directories, then return
2953 552 50 66     3443 if ($isDir or (defined $stat[2] and ($stat[2] & 0170000) == 0040000)) {
      33        
2954 0         0 $self->FoundTag('FileType', 'DIR');
2955 0         0 $self->FoundTag('FileTypeExtension', '');
2956 0         0 $self->DoneExtract();
2957 0 0       0 $raf->Close() if $raf;
2958 0 0       0 %saveOptions and $$self{OPTIONS} = \%saveOptions;
2959 0 0       0 delete $$self{InExtract} unless $reEntry;
2960 0         0 return 1;
2961             }
2962             # get list of file types to check
2963 552         1271 my ($tiffType, %noMagic, $recognizedExt);
2964 552         1780 my $ext = $$self{FILE_EXT} = GetFileExtension($realname);
2965             # set $recognizedExt if this file type is recognized by extension only
2966             $recognizedExt = $ext if defined $ext and not defined $magicNumber{$ext} and
2967 552 50 100     4310 defined $moduleName{$ext} and not $moduleName{$ext};
      100        
      66        
2968 552         1806 my @fileTypeList = GetFileType($realname);
2969 552 50       1596 if ($fast >= 4) {
2970 0 0       0 if (@fileTypeList) {
2971 0         0 $type = shift @fileTypeList;
2972 0         0 $self->SetFileType($$self{FILE_TYPE} = $type);
2973             } else {
2974 0         0 $self->Error('Unknown file type');
2975             }
2976 0         0 $self->DoneExtract();
2977 0         0 last; # don't read the file
2978             }
2979 552 100       1189 if (@fileTypeList) {
2980             # add remaining types to end of list so we test them all
2981 502         2674 my $pat = join '|', @fileTypeList;
2982 502         49824 push @fileTypeList, grep(!/^($pat)$/, @fileTypes);
2983 502         1393 $tiffType = $$self{FILE_EXT};
2984 502 100       1523 unless ($fast == 3) {
2985 501         1277 $noMagic{MXF} = 1; # don't do magic number test on MXF or DV files
2986 501         1240 $noMagic{DV} = 1;
2987             }
2988             } else {
2989             # scan through all recognized file types
2990 50         1150 @fileTypeList = @fileTypes;
2991 50         118 $tiffType = 'TIFF';
2992             }
2993 552         1079 push @fileTypeList, ''; # end of list marker
2994             # initialize the input file for seeking in binary data
2995 552         2922 $raf->BinMode(); # set binary mode before we start reading
2996 552         1675 my $pos = $raf->Tell(); # get file position so we can rewind
2997             # loop through list of file types to test
2998 552         1062 my ($buff, $err);
2999 552         2749 my %dirInfo = ( RAF => $raf, Base => $pos, TestBuff => \$buff );
3000             # read start of file for testing
3001 552 100       2167 if ($raf->Read($buff, $testLen)) {
3002 549 50       1841 $raf->Seek($pos, 0) or $err = 'Error seeking in file';
3003             } else {
3004 3         6 $err = $$raf{ERROR};
3005 3         7 $buff = '';
3006             }
3007 552         1677 until ($err) {
3008 2383         2873 my $unkHeader;
3009 2383         3139 $type = shift @fileTypeList;
3010 2383 100       3496 if ($type) {
    100          
    50          
3011 2377 100       4662 if ($magicNumber{$type}) {
3012             # do quick test for this file type to avoid loading module unnecessarily
3013 2301 100 100     46672 next if $buff !~ /^$magicNumber{$type}/s and not $noMagic{$type};
3014             } else {
3015             # keep checking for other types if we recognize this file only by extension
3016 76 50 66     323 next if defined $moduleName{$type} and not $moduleName{$type};
3017 76 50       194 next if $fast > 2; # keep checking if we aren't processing the file
3018             }
3019 632 50 66     2589 next if $weakMagic{$type} and defined $recognizedExt;
3020             } elsif (not defined $type) {
3021 3         6 last;
3022             } elsif ($recognizedExt) {
3023 0         0 $type = $recognizedExt; # set type from recognized file extension only
3024             } else {
3025             # last ditch effort to scan past unknown header for JPEG/TIFF
3026 3 50       13 next unless $buff =~ /(\xff\xd8\xff|MM\0\x2a|II\x2a\0)/g;
3027 0 0       0 $type = ($1 eq "\xff\xd8\xff") ? 'JPEG' : 'TIFF';
3028 0         0 my $skip = pos($buff) - length($1);
3029 0         0 $dirInfo{Base} = $pos + $skip;
3030 0 0       0 $raf->Seek($pos + $skip, 0) or $err = 'Error seeking in file', last;
3031 0         0 $self->Warn("Processing $type-like data after unknown $skip-byte header");
3032 0 0       0 $unkHeader = 1 unless $$self{DOC_NUM};
3033             }
3034             # save file type in member variable
3035 632         1563 $$self{FILE_TYPE} = $type;
3036 632 100       2248 $dirInfo{Parent} = ($type eq 'TIFF') ? $tiffType : $type;
3037             # don't process the file when FastScan > 2
3038 632 50 66     1970 if ($fast > 2 and not $processType{$type}) {
3039 0 0 0     0 unless ($weakMagic{$type} and (not $ext or $ext ne $type)) {
      0        
3040 0         0 $self->SetFileType($dirInfo{Parent});
3041             }
3042 0         0 last;
3043             }
3044 632         1174 my $module = $moduleName{$type};
3045 632 100       1538 $module = $type unless defined $module;
3046 632         1329 my $func = "Process$type";
3047              
3048             # load module if necessary
3049 632 100       1701 if ($module) {
    50          
3050 362         31007 require "Image/ExifTool/$module.pm";
3051 362         944 $func = "Image::ExifTool::${module}::$func";
3052             } elsif ($module eq '0') {
3053 0         0 $self->SetFileType();
3054 0         0 $self->Warn('Unsupported file type');
3055 0         0 last;
3056             }
3057 632         988 push @{$$self{PATH}}, $type; # save file type in metadata PATH
  632         1948  
3058              
3059             # process the file
3060 113     113   973 no strict 'refs';
  113         182  
  113         5861  
3061 632         4440 my $result = &$func($self, \%dirInfo);
3062 113     113   517 use strict 'refs';
  113         177  
  113         1934847  
3063              
3064 632         1320 pop @{$$self{PATH}};
  632         1748  
3065              
3066 632 100       1762 if ($result) { # all done if successful
3067 549 50       1447 if ($unkHeader) {
3068 0         0 $self->DeleteTag('FileType');
3069 0         0 $self->DeleteTag('FileTypeExtension');
3070 0         0 $self->DeleteTag('MIMEType');
3071 0         0 $self->VPrint(0,"Reset file type due to unknown header\n");
3072             }
3073 549         1233 last;
3074             }
3075             # seek back to try again from the same position in the file
3076 83 50       193 $raf->Seek($pos, 0) or $err = 'Error seeking in file';
3077             }
3078 552 50 66     2643 if (not $err and not defined $type and not $$self{DOC_NUM}) {
      66        
3079             # if we were given a single image with a known type there
3080             # must be a format error since we couldn't read it, otherwise
3081             # it is likely we don't support images of this type
3082 3   50     11 my $fileType = GetFileType($realname) || '';
3083 3 50       9 if (not length $buff) {
3084 3         6 $err = 'File is empty';
3085             } else {
3086 0         0 my $ch = substr($buff, 0, 1);
3087 0 0 0     0 if (length $buff < 16 or $buff =~ /[^\Q$ch\E]/) {
3088 0 0       0 if ($fileType eq 'RAW') {
    0          
3089 0         0 $err = 'Unsupported RAW file type';
3090             } elsif ($fileType) {
3091 0         0 $err = 'File format error';
3092             } else {
3093 0         0 $err = 'Unknown file type';
3094             }
3095             } else {
3096             # provide some insight into the content of some corrupted files
3097 0 0       0 if ($$self{OPTIONS}{FastScan}) {
3098 0         0 $err = 'File header is all';
3099             } else {
3100 0         0 my $num = 0;
3101 0         0 for (;;) {
3102 0 0       0 $raf->Read($buff, 65536) or undef($num), last;
3103 0 0       0 $buff =~ /[^\Q$ch\E]/g and $num += pos($buff) - 1, last;
3104 0         0 $num += length($buff);
3105             }
3106 0 0       0 if ($num) {
3107 0         0 $err = 'First ' . ConvertFileSize($num) . ' of file is';
3108             } else {
3109 0         0 $err = 'Entire file is';
3110             }
3111             }
3112 0 0       0 if ($ch eq "\0") {
    0          
    0          
3113 0         0 $err .= ' binary zeros';
3114             } elsif ($ch eq ' ') {
3115 0         0 $err .= ' ASCII spaces';
3116             } elsif ($ch =~ /[a-zA-Z0-9]/) {
3117 0         0 $err .= " ASCII '${ch}' characters";
3118             } else {
3119 0         0 $err .= sprintf(" binary 0x%.2x's", ord $ch);
3120             }
3121             }
3122             }
3123             }
3124 552 100 0     2251 if ($err) {
    50 33        
3125 3         13 $self->Error($err);
3126             } elsif ($self->Options('ScanForXMP') and (not defined $type or
3127             (not $fast and not $$self{FoundXMP})))
3128             {
3129             # scan for XMP
3130 0         0 $raf->Seek($pos, 0);
3131 0         0 require Image::ExifTool::XMP;
3132 0 0       0 Image::ExifTool::XMP::ScanForXMP($self, $raf) and $type = '';
3133             }
3134             # extract binary EXIF data block only if requested
3135 552 100 100     5349 if (defined $$self{EXIF_DATA} and length $$self{EXIF_DATA} > 16 and
      100        
      100        
3136             ($$req{exif} or
3137             # (not extracted normally, so check TAGS_FROM_FILE)
3138             ($$self{TAGS_FROM_FILE} and not $$self{EXCL_TAG_LOOKUP}{exif})))
3139             {
3140 37         157 $self->FoundTag('EXIF', $$self{EXIF_DATA});
3141             }
3142 552 100       1383 unless ($reEntry) {
3143 550         1531 $$self{PATH} = [ ]; # reset PATH
3144 550         2719 $self->DoneExtract();
3145             # do our HTML dump if requested
3146 550 50       1987 if ($$self{HTML_DUMP}) {
3147 0         0 $raf->Seek(0, 2); # seek to end of file
3148 0         0 $$self{HTML_DUMP}->FinishTiffDump($self, $raf->Tell());
3149 0         0 my $pos = $$options{HtmlDumpBase};
3150 0 0 0     0 $pos = ($$self{FIRST_EXIF_POS} || 0) unless defined $pos;
3151 0 0       0 my $dataPt = defined $$self{EXIF_DATA} ? \$$self{EXIF_DATA} : undef;
3152 0 0 0     0 undef $dataPt if defined $$self{EXIF_POS} and $pos != $$self{EXIF_POS};
3153 0 0       0 undef $dataPt if $$self{ExtendedEXIF}; # can't use EXIF block if not contiguous
3154             my $success = $$self{HTML_DUMP}->Print($raf, $dataPt, $pos,
3155             $$options{TextOut}, $$options{HtmlDump},
3156 0 0       0 $$self{FILENAME} ? "HTML Dump ($$self{FILENAME})" : 'HTML Dump');
3157 0 0       0 $self->Warn("Error reading $$self{HTML_DUMP}{ERROR}") if $success < 0;
3158             }
3159             }
3160 552 100       1558 if ($filename) {
3161 507         3169 $raf->Close(); # close the file if we opened it
3162             # process the resource fork as an embedded file on Mac filesystems
3163 507 0 33     1355 if ($rsize and $$options{ExtractEmbedded}) {
3164 0         0 local *RESOURCE_FILE;
3165 0 0       0 if ($self->Open(\*RESOURCE_FILE, "$filename/..namedfork/rsrc")) {
3166 0         0 $$self{DOC_NUM} = $$self{DOC_COUNT} + 1;
3167 0         0 $$self{IN_RESOURCE} = 1;
3168 0         0 $self->ExtractInfo(\*RESOURCE_FILE, { ReEntry => 1 });
3169 0         0 close RESOURCE_FILE;
3170 0         0 delete $$self{IN_RESOURCE};
3171             } else {
3172 0         0 $self->Warn('Error opening resource fork');
3173             }
3174             }
3175             }
3176 552         10855 last; # (loop was a cheap "goto")
3177             }
3178              
3179             # Note: This should be the only tag generated after BuildCompositeTags,
3180             # and as such it can't be used in user-defined Composite tags
3181 552 100       1831 @startTime and $self->FoundTag('ProcessingTime', Time::HiRes::tv_interval(\@startTime));
3182              
3183             # add numbers to warnings with multiple occurrences
3184 552 100       834 if (%{$$self{WAS_WARNED}}) {
  552         2198  
3185 46         171 my ($tag, $val) = ( 'Warning', $$self{VALUE} );
3186 46         186 for ($i=1; $$val{$tag}; ++$i) {
3187 56         168 my $n = $$self{WAS_WARNED}{$$val{$tag}};
3188 56 100 66     268 $$val{$tag} .= " [x$n]" if $n and $n > 1;
3189 56         210 $tag = "Warning ($i)";
3190             }
3191             }
3192             # restore original options
3193 552 100       1448 %saveOptions and $$self{OPTIONS} = \%saveOptions;
3194              
3195 552 100       2536 if ($reEntry) {
3196             # restore necessary members when exiting re-entrant code
3197 2         15 $$self{$_} = $$reEntry{$_} foreach keys %$reEntry;
3198 2         15 SetByteOrder($saveOrder);
3199             } else {
3200             # call cleanup routines if necessary
3201 550 50       1402 if ($$self{Cleanup}) {
3202 0         0 &$_($self) foreach @{$$self{Cleanup}};
  0         0  
3203 0         0 delete $$self{Cleanup};
3204             }
3205 550         1112 delete $$self{InExtract};
3206             }
3207              
3208             # ($type may be undef without an Error when processing sub-documents)
3209 552 100 66     3148 return 0 if not defined $type or exists $$self{VALUE}{Error};
3210 549         4156 return 1;
3211             }
3212              
3213             #------------------------------------------------------------------------------
3214             # Get hash of extracted meta information
3215             # Inputs: 0) ExifTool object reference
3216             # 1-N) options hash reference, tag list reference or tag names
3217             # Returns: Reference to information hash
3218             # Notes: - pass an undefined value to avoid parsing arguments
3219             # - If groups are specified, first groups take precedence if duplicate
3220             # tags found but Duplicates option not set.
3221             # - tag names may end in '#' to extract ValueConv value
3222             sub GetInfo($;@)
3223             {
3224 714     714 1 3130 local $_;
3225 714         1146 my $self = shift;
3226 714         1441 my (%saveOptions, @saveMembers, @savedMembers);
3227              
3228             # save necessary members to allow GetInfo to be called from within ExtractInfo
3229 714 100       2229 if ($$self{InExtract}) {
3230 4         10 @saveMembers = qw(REQUESTED_TAGS REQ_TAG_LOOKUP IO_TAG_LIST);
3231 4         15 @savedMembers = @$self{@saveMembers};
3232             }
3233 714 100 66     3297 unless (@_ and not defined $_[0]) {
3234 175         329 %saveOptions = %{$$self{OPTIONS}}; # save original options
  175         13130  
3235             # must set FILENAME so it isn't parsed from the arguments
3236 175 100       1425 $$self{FILENAME} = '' unless defined $$self{FILENAME};
3237 175         925 $self->ParseArguments(@_);
3238             }
3239              
3240             # get reference to list of tags for which we will return info
3241 714         3332 my ($rtnTags, $byValue, $wildTags) = $self->SetFoundTags();
3242              
3243             # build hash of tag information
3244 714         1478 my (%info, %ignored);
3245 714 100       2561 my $conv = $$self{OPTIONS}{PrintConv} ? 'PrintConv' : 'ValueConv';
3246 714         1478 foreach (@$rtnTags) {
3247 36335         53653 my $val = $self->GetValue($_, $conv);
3248 36335 100       52118 defined $val or $ignored{$_} = 1, next;
3249 35277         66013 $info{$_} = $val;
3250             }
3251              
3252             # override specified tags with ValueConv value if necessary
3253 714 100       2384 if (@$byValue) {
3254             # first determine the number of times each non-ValueConv value is used
3255 4         7 my %nonVal;
3256 4   100     58 $nonVal{$_} = ($nonVal{$_} || 0) + 1 foreach @$rtnTags;
3257 4         16 --$nonVal{$$rtnTags[$_]} foreach @$byValue;
3258             # loop through ValueConv tags, updating tag keys and returned values
3259 4         8 foreach (@$byValue) {
3260 25         34 my $tag = $$rtnTags[$_];
3261 25         34 my $val = $self->GetValue($tag, 'ValueConv');
3262 25 100       38 next unless defined $val;
3263 16         26 my $vtag = $tag;
3264             # generate a new tag key like "Tag #" or "Tag #(1)"
3265 16         72 $vtag =~ s/( |$)/ #/;
3266 16 50       36 unless (defined $$self{VALUE}{$vtag}) {
3267 16         34 $$self{VALUE}{$vtag} = $$self{VALUE}{$tag};
3268 16         29 $$self{TAG_INFO}{$vtag} = $$self{TAG_INFO}{$tag};
3269 16         31 $$self{TAG_EXTRA}{$vtag} = $$self{TAG_EXTRA}{$tag};
3270 16         27 $$self{FILE_ORDER}{$vtag} = $$self{FILE_ORDER}{$tag};
3271             # remove existing PrintConv entry unless we are using it too
3272 16 100       36 delete $info{$tag} unless $nonVal{$tag};
3273             }
3274 16         26 $$rtnTags[$_] = $vtag; # store ValueConv value with new tag key
3275 16         35 $info{$vtag} = $val; # return ValueConv value
3276             }
3277             }
3278              
3279             # remove ignored tags from the list
3280 714   50     2239 my $reqTags = $$self{REQUESTED_TAGS} || [ ];
3281 714 100       1803 if (%ignored) {
3282 427 100       1626 if (not @$reqTags) {
    100          
3283 197         355 my @goodTags;
3284 197         470 foreach (@$rtnTags) {
3285 22982 100       33363 push @goodTags, $_ unless $ignored{$_};
3286             }
3287 197         1340 $rtnTags = $$self{FOUND_TAGS} = \@goodTags;
3288             } elsif (@$wildTags) {
3289             # only remove tags specified by wildcard
3290 42         49 my @goodTags;
3291 42         55 my $i = 0;
3292 42         83 foreach (@$rtnTags) {
3293 392 100 100     697 if (@$wildTags and $i == $$wildTags[0]) {
3294 231         231 shift @$wildTags;
3295 231 50       385 push @goodTags, $_ unless $ignored{$_};
3296             } else {
3297 161         217 push @goodTags, $_;
3298             }
3299 392         400 ++$i;
3300             }
3301 42         145 $rtnTags = $$self{FOUND_TAGS} = \@goodTags;
3302             }
3303             }
3304              
3305             # return sorted tag list if provided with a list reference
3306 714 100       2220 if ($$self{IO_TAG_LIST}) {
3307             # use file order by default if no tags specified
3308             # (no such thing as 'Input' order in this case)
3309 10         28 my $sort = $$self{OPTIONS}{Sort};
3310 10 50 33     47 $sort = 'File' unless @$reqTags or ($sort and $sort ne 'Input');
      66        
3311             # return tags in specified sort order
3312 10         43 @{$$self{IO_TAG_LIST}} = $self->GetTagList($rtnTags, $sort, $$self{OPTIONS}{Sort2});
  10         53  
3313             }
3314              
3315             # restore original options and member variables
3316 714 100       3951 %saveOptions and $$self{OPTIONS} = \%saveOptions;
3317 714 100       1761 @$self{@saveMembers} = @savedMembers if @saveMembers;
3318              
3319 714         3084 return \%info;
3320             }
3321              
3322             #------------------------------------------------------------------------------
3323             # Inputs: 0) ExifTool object reference
3324             # 1) [optional] reference to info hash or tag list ref (default is found tags)
3325             # 2) [optional] sort order ('File', 'Input', ...)
3326             # 3) [optional] secondary sort order
3327             # Returns: List of tags in specified order
3328             sub GetTagList($;$$$)
3329             {
3330 462     462 1 187574 local $_;
3331 462         1520 my ($self, $info, $sort, $sort2) = @_;
3332              
3333 462         851 my $foundTags;
3334 462 100       1979 if (ref $info eq 'HASH') {
    50          
3335 451         5613 my @tags = keys %$info;
3336 451         1253 $foundTags = \@tags;
3337             } elsif (ref $info eq 'ARRAY') {
3338 11         19 $foundTags = $info;
3339             }
3340 462         1089 my $fileOrder = $$self{FILE_ORDER};
3341              
3342 462 50       1180 if ($foundTags) {
3343             # make sure a FILE_ORDER entry exists for all tags
3344             # (note: already generated bogus entries for FOUND_TAGS case below)
3345 462         1300 foreach (@$foundTags) {
3346 24957 50       35123 next if defined $$fileOrder{$_};
3347 0         0 $$fileOrder{$_} = 999;
3348             }
3349             } else {
3350 0 0 0     0 $sort = $info if $info and not $sort;
3351 0 0 0     0 $foundTags = $$self{FOUND_TAGS} || $self->SetFoundTags() or return undef;
3352             }
3353 462 100       1852 $sort or $sort = $$self{OPTIONS}{Sort};
3354              
3355             # return original list if no sort order specified
3356 462 100 66     2873 return @$foundTags unless $sort and $sort ne 'Input';
3357              
3358 439 50 33     4558 if ($sort eq 'Tag' or $sort eq 'Alpha') {
    100          
    50          
3359 0         0 return sort @$foundTags;
3360             } elsif ($sort =~ /^Group(\d*(:\d+)*)/) {
3361 436   50     2280 my $family = $1 || 0;
3362             # want to maintain a basic file order with the groups
3363             # ordered in the way they appear in the file
3364 436         796 my (%groupCount, %groupOrder);
3365 436         755 my $numGroups = 0;
3366 436         687 my $tag;
3367 436         2915 foreach $tag (sort { $$fileOrder{$a} <=> $$fileOrder{$b} } @$foundTags) {
  133840         139108  
3368 23997         29021 my $group = $self->GetGroup($tag, $family);
3369 23997         27290 my $num = $groupCount{$group};
3370 23997 100       30673 $num or $num = $groupCount{$group} = ++$numGroups;
3371 23997         33479 $groupOrder{$tag} = $num;
3372             }
3373 436 50       2033 $sort2 or $sort2 = $$self{OPTIONS}{Sort2};
3374 436 50       1168 if ($sort2) {
3375 436 50 33     2414 if ($sort2 eq 'Tag' or $sort2 eq 'Alpha') {
    50          
3376 0 0       0 return sort { $groupOrder{$a} <=> $groupOrder{$b} or $a cmp $b } @$foundTags;
  0         0  
3377             } elsif ($sort2 eq 'Descr') {
3378 0         0 my $desc = $self->GetDescriptions($foundTags);
3379 0         0 return sort { $groupOrder{$a} <=> $groupOrder{$b} or
3380 0 0       0 $$desc{$a} cmp $$desc{$b} } @$foundTags;
3381             }
3382             }
3383 436         1833 return sort { $groupOrder{$a} <=> $groupOrder{$b} or
3384 133847 50       187788 $$fileOrder{$a} <=> $$fileOrder{$b} } @$foundTags;
3385             } elsif ($sort eq 'Descr') {
3386 0         0 my $desc = $self->GetDescriptions($foundTags);
3387 0         0 return sort { $$desc{$a} cmp $$desc{$b} } @$foundTags;
  0         0  
3388             } else {
3389 3         27 return sort { $$fileOrder{$a} <=> $$fileOrder{$b} } @$foundTags;
  4783         4749  
3390             }
3391             }
3392              
3393             #------------------------------------------------------------------------------
3394             # Get list of found tags in specified sort order
3395             # Inputs: 0) ExifTool object reference, 1) sort order ('File', 'Input', ...)
3396             # 2) secondary sort order
3397             # Returns: List of tag keys in specified order
3398             # Notes: If not specified, sort order is taken from OPTIONS
3399             sub GetFoundTags($;$$)
3400             {
3401 1     1 1 290 local $_;
3402 1         4 my ($self, $sort, $sort2) = @_;
3403 1 50 33     7 my $foundTags = $$self{FOUND_TAGS} || $self->SetFoundTags() or return undef;
3404 1         4 return $self->GetTagList($foundTags, $sort, $sort2);
3405             }
3406              
3407             #------------------------------------------------------------------------------
3408             # Get list of requested tags
3409             # Inputs: 0) ExifTool object reference
3410             # Returns: List of requested tag keys
3411             sub GetRequestedTags($)
3412             {
3413 2     2 1 4 local $_;
3414 2         2 return @{$_[0]{REQUESTED_TAGS}};
  2         12  
3415             }
3416              
3417             #------------------------------------------------------------------------------
3418             # Get tag value
3419             # Inputs: 0) ExifTool object reference
3420             # 1) tag key or tag name with optional group names (case sensitive)
3421             # (or flattened tagInfo for getting field values, not part of public API)
3422             # 2) [optional] Value type: PrintConv, ValueConv, Both, Raw, Bin or Rational, the
3423             # default is PrintConv or ValueConv, depending on the PrintConv option setting
3424             # 3) raw field value (not part of public API)
3425             # Returns: Scalar context: tag value or undefined
3426             # List context: list of values or empty list
3427             sub GetValue($$;$)
3428             {
3429 54748     54748 1 51971 local $_;
3430 54748         72679 my ($self, $tag, $type) = @_; # plus: ($fieldValue)
3431 54748         55094 my (@convTypes, $tagInfo, $valueConv, $both);
3432 54748         59216 my $rawValue = $$self{VALUE};
3433              
3434             # get specific tag key if tag has a group name
3435 54748 50       81980 if ($tag =~ /^(.*):(.+)/) {
3436 0         0 my ($gp, $tg) = ($1, $2);
3437 0         0 my ($i, $key, @keys);
3438             # build list of tag keys in the order of priority (no index
3439             # is top priority, otherwise higher index is higher priority)
3440 0   0     0 for ($key=$tg, $i=$$self{DUPL_TAG}{$tg} || 0; ; --$i) {
3441 0 0       0 push @keys, $key if defined $$rawValue{$key};
3442 0 0       0 last if $i <= 0;
3443 0         0 $key = "$tg ($i)";
3444             }
3445 0 0       0 if (@keys) {
3446 0         0 $key = $self->GroupMatches($gp, \@keys);
3447 0 0       0 $tag = $key if $key;
3448             }
3449             }
3450             # figure out what conversions to do
3451 54748 100       63988 if ($type) {
3452 54721 50       69177 return $$self{TAG_EXTRA}{$tag}{Rational} if $type eq 'Rational';
3453 54721 50       67666 return $$self{TAG_EXTRA}{$tag}{BinVal} if $type eq 'Bin';
3454             } else {
3455 27 50       77 $type = $$self{OPTIONS}{PrintConv} ? 'PrintConv' : 'ValueConv';
3456             }
3457              
3458             # start with the raw value
3459 54748         75765 my $value = $$rawValue{$tag};
3460 54748 100       69968 if (not defined $value) {
3461 10496 100       20130 return () unless ref $tag;
3462             # get the value of a structure field
3463 194         200 $tagInfo = $tag;
3464 194         281 $tag = $$tagInfo{Name};
3465 194         221 $value = $_[3];
3466             # (note: type "Both" is not allowed for structure fields)
3467 194 50       273 if ($type ne 'Raw') {
3468 194         239 push @convTypes, 'ValueConv';
3469 194 100       314 push @convTypes, 'PrintConv' unless $type eq 'ValueConv';
3470             }
3471             } else {
3472 44252         62273 $tagInfo = $$self{TAG_INFO}{$tag};
3473 44252 100 66     77928 if ($$tagInfo{Struct} and ref $value) {
3474             # must load XMPStruct.pl just in case (should already be loaded if
3475             # a structure was extracted, but we could also arrive here if a simple
3476             # list of values was stored incorrectly in a Struct tag)
3477 53         879 require 'Image/ExifTool/XMPStruct.pl';
3478             # convert strucure field values
3479 53 100       127 unless ($type eq 'Both') {
3480             # (note: ConvertStruct handles the filtering and escaping too if necessary)
3481 48         333 return Image::ExifTool::XMP::ConvertStruct($self,$tagInfo,$value,$type);
3482             }
3483 5         20 $valueConv = Image::ExifTool::XMP::ConvertStruct($self,$tagInfo,$value,'ValueConv');
3484 5         12 $value = Image::ExifTool::XMP::ConvertStruct($self,$tagInfo,$value,'PrintConv');
3485             # (must not save these in $$self{BOTH} because the values may have been escaped)
3486 5         20 return ($valueConv, $value);
3487             }
3488 44199 50       58946 if ($type ne 'Raw') {
3489             # use values we calculated already if we stored them
3490 44199         54629 $both = $$self{BOTH}{$tag};
3491 44199 100       51469 if ($both) {
3492 6716 100       10880 if ($type eq 'PrintConv') {
    100          
3493 2247         3806 $value = $$both[1];
3494             } elsif ($type eq 'ValueConv') {
3495 102         141 $value = $$both[0];
3496 102 100       173 $value = $$both[1] unless defined $value;
3497             } else {
3498 4367         6821 ($valueConv, $value) = @$both;
3499             }
3500             } else {
3501 37483         43273 push @convTypes, 'ValueConv';
3502 37483 100       57850 push @convTypes, 'PrintConv' unless $type eq 'ValueConv';
3503             }
3504             }
3505             }
3506              
3507             # do the conversions
3508 44393         46214 my (@val, @prt, @raw, $convType);
3509 44393         47374 foreach $convType (@convTypes) {
3510             # don't convert a scalar reference or structure
3511 72559 100 66     104502 last if ref $value eq 'SCALAR' and not $$tagInfo{ConvertBinary};
3512 71894         93228 my $conv = $$tagInfo{$convType};
3513 71894 100       89874 unless (defined $conv) {
3514 46930 100       54774 if ($convType eq 'ValueConv') {
3515 29793 100       49520 next unless $$tagInfo{Binary};
3516 415         637 $conv = '\$val'; # return scalar reference for binary values
3517             } else {
3518             # use PRINT_CONV from tag table if PrintConv doesn't exist
3519 17137 100       39138 next unless defined($conv = $$tagInfo{Table}{PRINT_CONV});
3520 207 100       447 next if exists $$tagInfo{$convType};
3521             }
3522             }
3523             # save old ValueConv value if we want Both
3524 25537 100 100     45159 $valueConv = $value if $type eq 'Both' and $convType eq 'PrintConv';
3525 25537         30135 my ($i, $val, $vals, @values, $convList);
3526             # split into list if conversion is an array
3527 25537 100       36760 if (ref $conv eq 'ARRAY') {
3528 125         195 $convList = $conv;
3529 125         289 $conv = $$convList[0];
3530 125 50       508 my @valList = (ref $value eq 'ARRAY') ? @$value : split ' ', $value;
3531             # reorganize list if specified (Note: The writer currently doesn't
3532             # relist values, so they may be grouped but the order must not change)
3533 125         244 my $relist = $$tagInfo{Relist};
3534 125 100       268 if ($relist) {
3535 7         14 my (@newList, $oldIndex);
3536 7         16 foreach $oldIndex (@$relist) {
3537 14         32 my ($newVal, @join);
3538 14 100       24 if (ref $oldIndex) {
3539 7         14 foreach (@$oldIndex) {
3540 16 50       44 push @join, $valList[$_] if defined $valList[$_];
3541             }
3542 7 50       42 $newVal = join(' ', @join) if @join;
3543             } else {
3544 7         13 $newVal = $valList[$oldIndex];
3545             }
3546 14 100       38 push @newList, $newVal if defined $newVal;
3547             }
3548 7         14 $value = \@newList;
3549             } else {
3550 118         210 $value = \@valList;
3551             }
3552 125 50       329 return () unless @$value;
3553             }
3554             # initialize array so we can iterate over values in list
3555 25537 100       32896 if (ref $value eq 'ARRAY') {
3556 157 100       357 if (defined $$tagInfo{RawJoin}) {
3557 7         29 $val = join ' ', @$value;
3558             } else {
3559 150         209 $i = 0;
3560 150         216 $vals = $value;
3561 150         261 $val = $$vals[0];
3562             }
3563             } else {
3564 25380         27430 $val = $value;
3565             }
3566             # loop through all values in list
3567 25537         25221 for (;;) {
3568 25758 100       30965 if (defined $conv) {
3569             # get values of required tags if this is a Composite tag
3570 25739 100 66     42917 if (ref $val eq 'HASH' and not @val) {
3571             # disable escape of source values so we don't double escape them
3572 3020         3968 my $oldEscape = $$self{ESCAPE_PROC};
3573 3020         3735 delete $$self{ESCAPE_PROC};
3574             # temporarily delete filter so it isn't applied to the Require'd values
3575 3020         3784 my $oldFilter = $$self{OPTIONS}{Filter};
3576 3020         3957 delete $$self{OPTIONS}{Filter};
3577 3020         8838 foreach (keys %$val) {
3578 17620 50       25333 next unless defined $$val{$_};
3579 17620         32449 $raw[$_] = $$rawValue{$$val{$_}};
3580 17620         26130 ($val[$_], $prt[$_]) = $self->GetValue($$val{$_}, 'Both');
3581 17620 100 100     39671 next if defined $val[$_] or not $$tagInfo{Require}{$_};
3582 385 50       730 $$self{OPTIONS}{Filter} = $oldFilter if defined $oldFilter;
3583 385         602 $$self{ESCAPE_PROC} = $oldEscape;
3584 385         1396 return ();
3585             }
3586 2635 100       5390 $$self{OPTIONS}{Filter} = $oldFilter if defined $oldFilter;
3587 2635         4109 $$self{ESCAPE_PROC} = $oldEscape;
3588             # set $val to $val[0], or \@val for a CODE ref conversion
3589 2635 50       5245 $val = ref $conv eq 'CODE' ? \@val : $val[0];
3590             }
3591 25354 100       33094 if (ref $conv eq 'HASH') {
3592             # look up converted value in hash
3593 7776 100       19806 if (not defined($value = $$conv{$val})) {
3594 461 100       1220 if ($$conv{BITMASK}) {
3595 128         680 $value = DecodeBits($val, $$conv{BITMASK}, $$tagInfo{BitsPerWord});
3596             } else {
3597             # use alternate conversion routine if available
3598 333 100       832 if ($$conv{OTHER}) {
3599 257         977 local $SIG{'__WARN__'} = \&SetWarning;
3600 257         481 undef $evalWarning;
3601 257         421 $value = &{$$conv{OTHER}}($val, undef, $conv);
  257         1002  
3602 257 50       849 $self->Warn("$convType $tag: " . CleanWarning()) if $evalWarning;
3603             }
3604 333 100       680 if (not defined $value) {
3605 78 50 66     321 if ($$tagInfo{PrintHex} and defined $val and IsInt($val) and
      66        
      33        
3606             $convType eq 'PrintConv')
3607             {
3608 0         0 $value = sprintf('Unknown (0x%x)',$val);
3609             } else {
3610 78         155 $value = "Unknown ($val)";
3611             }
3612             }
3613             }
3614             }
3615             # override with our localized language PrintConv if available
3616 7776         8185 my $tmp;
3617 7776 100 66     16248 if ($$self{CUR_LANG} and $convType eq 'PrintConv' and
      100        
      66        
3618             # (no need to check for lang-alt tag names -- they won't have a PrintConv)
3619             ref($tmp = $$self{CUR_LANG}{$$tagInfo{Name}}) eq 'HASH' and
3620             ($tmp = $$tmp{PrintConv}))
3621             {
3622 261 50 33     943 if ($$conv{BITMASK} and not defined $$conv{$val}) {
    100          
3623 0         0 my @vals = split ', ', $value;
3624 0         0 foreach (@vals) {
3625 0 0       0 $_ = $$tmp{$_} if defined $$tmp{$_};
3626             }
3627 0         0 $value = join ', ', @vals;
3628             } elsif (defined($tmp = $$tmp{$value})) {
3629 213         393 $value = $self->Decode($tmp, 'UTF8');
3630             }
3631             }
3632             } else {
3633             # call subroutine or do eval to convert value
3634 17578         50661 local $SIG{'__WARN__'} = \&SetWarning;
3635 17578         22094 undef $evalWarning;
3636 17578 100       23008 if (ref $conv eq 'CODE') {
3637 1278         3463 $value = &$conv($val, $self);
3638             } else {
3639             #### eval ValueConv/PrintConv ($val, $self, @val, @prt, @raw)
3640 16300         925599 $value = eval $conv;
3641 16300 50       49705 $@ and $evalWarning = $@;
3642             }
3643 17578 50       44442 $self->Warn("$convType $tag: " . CleanWarning()) if $evalWarning;
3644             }
3645             } else {
3646 19         24 $value = $val;
3647             }
3648 25373 100       39103 last unless $vals;
3649             # must store a separate copy of each binary data value in the list
3650 371 100       627 if (ref $value eq 'SCALAR') {
3651 3         4 my $tval = $$value;
3652 3         4 $value = \$tval;
3653             }
3654             # save this converted value and step to next value in list
3655 371 50       723 push @values, $value if defined $value;
3656 371 100       678 if (++$i >= scalar(@$vals)) {
3657 150 50       329 $value = \@values if @values;
3658 150         221 last;
3659             }
3660 221         317 $val = $$vals[$i];
3661 221 100       377 if ($convList) {
3662 133         192 my $nextConv = $$convList[$i];
3663 133 50 66     494 if ($nextConv and $nextConv eq 'REPEAT') {
3664 0         0 undef $convList;
3665             } else {
3666 133         212 $conv = $nextConv;
3667             }
3668             }
3669             }
3670             # return undefined now if no value
3671 25152 100       37234 return () unless defined $value;
3672             # join back into single value if split for conversion list
3673 24576 100 66     50862 if ($convList and ref $value eq 'ARRAY') {
3674 125 100       864 $value = join($convType eq 'PrintConv' ? '; ' : ' ', @$value);
3675             }
3676             }
3677 43432 100       58494 if ($type eq 'Both') {
3678             # save both (unescaped) values because we often need them again
3679             # (Composite tags need "Both" and often Require one tag for various Composite tags)
3680 7806 100       17006 $$self{BOTH}{$tag} = [ $valueConv, $value ] unless $both;
3681             # escape values if necessary
3682 7806 50       14565 if ($$self{ESCAPE_PROC}) {
    100          
3683 0         0 DoEscape($value, $$self{ESCAPE_PROC});
3684 0 0       0 if (defined $valueConv) {
3685 0         0 DoEscape($valueConv, $$self{ESCAPE_PROC});
3686             } else {
3687 0         0 $valueConv = $value;
3688             }
3689             } elsif (not defined $valueConv) {
3690             # $valueConv is undefined if there was no print conversion done
3691 3914         4329 $valueConv = $value;
3692             }
3693 7806         22327 $self->Filter($$self{OPTIONS}{Filter}, \$value);
3694             # return Both values as a list (ValueConv, PrintConv)
3695 7806         24253 return ($valueConv, $value);
3696             }
3697             # escape value if necessary
3698 35626 100       52158 DoEscape($value, $$self{ESCAPE_PROC}) if $$self{ESCAPE_PROC};
3699              
3700             # filter if necessary
3701 35626 100 100     59595 $self->Filter($$self{OPTIONS}{Filter}, \$value) if $$self{OPTIONS}{Filter} and $type eq 'PrintConv';
3702              
3703 35626 100       46891 if (ref $value eq 'ARRAY') {
3704 311 100 100     1977 if (defined $$self{OPTIONS}{ListItem}) {
    100          
    100          
3705 3         5 $value = $$value[$$self{OPTIONS}{ListItem}];
3706             } elsif (wantarray) {
3707             # return array if requested
3708 1         6 return @$value;
3709             } elsif ($type eq 'PrintConv' and not $$self{OPTIONS}{List}) {
3710             # join PrintConv values in delimited string if List option not used
3711             # and list contains simple scalars (otherwise return ARRAY ref)
3712 170   100     652 ref and return $value foreach @$value;
3713 169         617 $value = join $$self{OPTIONS}{ListSep}, @$value;
3714             }
3715             }
3716 35624         69280 return $value;
3717             }
3718              
3719             #------------------------------------------------------------------------------
3720             # Get tag identification number
3721             # Inputs: 0) ExifTool object reference, 1) tag key
3722             # Returns: Scalar context: tag ID if available, otherwise ''
3723             # List context: 0) tag ID (or ''), 1) language code (or undef)
3724             sub GetTagID($$)
3725             {
3726 24010     24010 1 90235 my ($self, $tag) = @_;
3727 24010         29219 my $tagInfo = $$self{TAG_INFO}{$tag};
3728 24010 100 66     53351 return '' unless $tagInfo and defined $$tagInfo{TagID};
3729 24008   100     46035 my $id = $$tagInfo{KeysID} || $$tagInfo{TagID};
3730 24008 50       31160 return ($id, $$tagInfo{LangCode}) if wantarray;
3731 24008         33892 return $id;
3732             }
3733              
3734             #------------------------------------------------------------------------------
3735             # Get description for specified tag
3736             # Inputs: 0) ExifTool object reference, 1) tag key
3737             # Returns: Tag description
3738             # Notes: Will always return a defined value, even if description isn't available
3739             sub GetDescription($$)
3740             {
3741 24010     24010 1 66206 local $_;
3742 24010         27590 my ($self, $tag) = @_;
3743 24010         23867 my ($desc, $name);
3744 24010         27474 my $tagInfo = $$self{TAG_INFO}{$tag};
3745             # ($tagInfo won't be defined for missing tags extracted with -f)
3746 24010 50       31690 if ($tagInfo) {
3747             # use alternate language description if available
3748 24010         34924 while ($$self{CUR_LANG}) {
3749 847         1829 $desc = $$self{CUR_LANG}{$$tagInfo{Name}};
3750 847 100       1175 if ($desc) {
3751             # must look up Description if this tag also has a PrintConv
3752 718 100 100     1630 $desc = $$desc{Description} or last if ref $desc;
3753             } else {
3754             # look up default language of lang-alt tag
3755             last unless $$tagInfo{LangCode} and
3756             ($name = $$tagInfo{Name}) =~ s/-$$tagInfo{LangCode}$// and
3757 129 50 66     314 $desc = $$self{CUR_LANG}{$name};
      66        
3758 1 50 0     2 $desc = $$desc{Description} or last if ref $desc;
3759 1         5 $desc .= " ($$tagInfo{LangCode})";
3760             }
3761             # escape description if necessary
3762 710 50       1089 DoEscape($desc, $$self{ESCAPE_PROC}) if $$self{ESCAPE_PROC};
3763             # return description in proper Charset
3764 710         1033 return $self->Decode($desc, 'UTF8');
3765             }
3766 23300         29596 $desc = $$tagInfo{Description};
3767             }
3768             # just make the tag more readable if description doesn't exist
3769 23300 100       31108 unless ($desc) {
3770 9894         12716 $desc = MakeDescription(GetTagName($tag));
3771             # save description in tag information
3772 9894 50       21583 $$tagInfo{Description} = $desc if $tagInfo;
3773             }
3774 23300         35505 return $desc;
3775             }
3776              
3777             #------------------------------------------------------------------------------
3778             # Get group name for specified tag
3779             # Inputs: 0) ExifTool object reference
3780             # 1) tag key (or reference to tagInfo hash, not part of the public API)
3781             # 2) [optional] group family (-1 to get extended group list, or multiple
3782             # families separated by colons to return multiple groups as a string)
3783             # Returns: Scalar context: group name (for family 0 if not otherwise specified)
3784             # List context: group name if family specified, otherwise list of
3785             # group names for each family. Returns '' for undefined tag.
3786             # Notes: Multiple families may be specified with ':' in family argument (eg. '1:2')
3787             sub GetGroup($$;$)
3788             {
3789 204764     204764 1 477761 local $_;
3790 204764         247312 my ($self, $tag, $family) = @_;
3791 204764         210603 my ($tagInfo, @groups, @families, $simplify, $byTagInfo, $ex, $noID);
3792 204764 100       258248 if (ref $tag eq 'HASH') {
3793 129957         125401 $tagInfo = $tag;
3794 129957         162413 $tag = $$tagInfo{Name};
3795             # set flag so we don't get extra information for an extracted tag
3796 129957         120503 $byTagInfo = 1;
3797 129957         131404 $ex = { };
3798             } else {
3799 74807   50     123954 $tagInfo = $$self{TAG_INFO}{$tag} || { };
3800 74807   50     115178 $ex = $$self{TAG_EXTRA}{$tag} || { };
3801             }
3802 204764         255523 my $groups = $$tagInfo{Groups};
3803             # fill in default groups unless already done
3804             # (after this, Groups 0-2 in tagInfo are guaranteed to be defined)
3805 204764 100       287401 unless ($$tagInfo{GotGroups}) {
3806 39174   50     54127 my $tagTablePtr = $$tagInfo{Table} || { GROUPS => { } };
3807             # construct our group list
3808 39174 100       81536 $groups or $groups = $$tagInfo{Groups} = { };
3809             # fill in default groups
3810 39174         48758 foreach (0..2) {
3811 117522 100 50     287939 $$groups{$_} = $$tagTablePtr{GROUPS}{$_} || '' unless $$groups{$_};
3812             }
3813             # set flag indicating group list was built
3814 39174         52377 $$tagInfo{GotGroups} = 1;
3815             }
3816 204764 100 100     376125 if (defined $family and $family ne '-1') {
3817 103316 100       153814 if ($family =~ /[^\d]/) {
3818 2736         5416 @families = ($family =~ /\d+/g);
3819 2736 50 0     3480 return($$ex{G0} || $$groups{0}) unless @families;
3820 2736 50       3759 $simplify = 1 unless $family =~ /^:/;
3821 2736         2693 undef $family;
3822 2736         3055 foreach (0..2) { $groups[$_] = $$groups{$_}; }
  8208         11750  
3823 2736 50 33     3992 $noID = 1 if @families == 1 and $families[0] != 7;
3824             } else {
3825 100580 100 66     346158 return($$ex{"G$family"} || $$groups{$family}) if $family == 0 or $family == 2;
      100        
3826 30783         61723 $groups[1] = $$groups{1};
3827             }
3828             } else {
3829 101448 100 33     126977 return($$ex{G0} || $$groups{0}) unless wantarray;
3830 101068         117927 foreach (0..2) { $groups[$_] = $$groups{$_}; }
  303204         443694  
3831             }
3832 134587         153635 $groups[3] = 'Main';
3833 134587 100 66     263707 $groups[4] = ($tag =~ /\((\d+)\)$/ and $1 ne '0') ? "Copy$1" : '';
3834             # handle dynamic group names if necessary
3835 134587 100       183002 unless ($byTagInfo) {
3836 48513 100       67310 $groups[0] = $$ex{G0} if $$ex{G0};
3837 48513 100       78392 $groups[1] = $$ex{G1} =~ /^\+(.*)/ ? "$groups[1]$1" : $$ex{G1} if $$ex{G1};
    100          
3838 48513 100       61716 $groups[3] = 'Doc' . $$ex{G3} if $$ex{G3};
3839 48513 100 66     64054 $groups[5] = $$ex{G5} || $groups[1] if defined $$ex{G5};
3840 48513 50       61801 if (defined $$ex{G6}) {
3841 0 0       0 $groups[5] = '' unless defined $groups[5]; # (can't leave a hole in the array)
3842 0         0 $groups[6] = $$ex{G6};
3843             }
3844 48513 100       61497 if ($$ex{G8}) {
3845 16         22 $groups[7] = '';
3846 16         26 $groups[8] = $$ex{G8};
3847             }
3848             # generate tag ID group names unless obviously not needed
3849 48513 50       60089 unless ($noID) {
3850 48513   100     107311 my $id = $$tagInfo{KeysID} || $$tagInfo{TagID};
3851 48513 100       99276 if (not defined $id) {
    100          
3852 2         3 $id = ''; # (just to be safe)
3853             } elsif ($id =~ /^\d+$/) {
3854 30259 50       49378 $id = sprintf('0x%x', $id) if $$self{OPTIONS}{HexTagIDs};
3855             } else {
3856 18252         27138 $id =~ s/([^-_A-Za-z0-9])/sprintf('%.2x',ord $1)/ge;
  1510         4506  
3857             }
3858 48513         60814 $groups[7] = 'ID-' . $id;
3859 48513   100     117924 defined $groups[$_] or $groups[$_] = '' foreach (5,6);
3860             }
3861             }
3862 134587 100       174892 if ($family) {
3863 49269 100 50     159614 return $groups[$family] || '' if $family > 0;
3864             # add additional matching group names to list
3865             # eg) for MIE-Doc, also add MIE1, MIE1-Doc, MIE-Doc1 and MIE1-Doc1
3866             # and for MIE2-Doc3, also add MIE2, MIE-Doc3, MIE2-Doc and MIE-Doc
3867 18486 100       25713 if ($groups[1] =~ /^MIE(\d*)-(.+?)(\d*)$/) {
3868 42   50     154 push @groups, 'MIE' . ($1 || '1');
3869 42 50       190 push @groups, 'MIE' . ($1 ? '' : '1') . "-$2$3";
3870 42 50       134 push @groups, "MIE$1-$2" . ($3 ? '' : '1');
3871 42 50       150 push @groups, 'MIE' . ($1 ? '' : '1') . "-$2" . ($3 ? '' : '1');
    50          
3872             }
3873             }
3874 103804 100       130638 if (@families) {
3875 2736         2460 my @grps;
3876             # create list of group names (without identical adjacent groups if simplifying)
3877 2736         2818 foreach (@families) {
3878 5472         5896 my $grp = $groups[$_];
3879 5472 50       6436 unless ($grp) {
3880 0 0       0 next if $simplify;
3881 0         0 $grp = '';
3882             }
3883 5472 100 66     14224 push @grps, $grp unless $simplify and @grps and $grp eq $grps[-1];
      100        
3884             }
3885             # remove leading "Main:" if simplifying
3886 2736 50 66     7589 shift @grps if $simplify and @grps > 1 and $grps[0] eq 'Main';
      66        
3887             # return colon-separated string of group names
3888 2736         6592 return join ':', @grps;
3889             }
3890 101068         283460 return @groups;
3891             }
3892              
3893             #------------------------------------------------------------------------------
3894             # Get group names for specified tags
3895             # Inputs: 0) ExifTool object reference
3896             # 1) [optional] information hash reference (default all extracted info)
3897             # 2) [optional] group family (default 0)
3898             # Returns: List of group names in alphabetical order
3899             sub GetGroups($;$$)
3900             {
3901 3     3 1 21 local $_;
3902 3         6 my $self = shift;
3903 3         4 my $info = shift;
3904 3         5 my $family;
3905              
3906             # figure out our arguments
3907 3 100       12 if (ref $info ne 'HASH') {
3908 2         4 $family = $info;
3909 2         5 $info = $$self{VALUE};
3910             } else {
3911 1         2 $family = shift;
3912             }
3913 3 50       7 $family = 0 unless defined $family;
3914              
3915             # get a list of all groups in specified information
3916 3         6 my ($tag, %groups);
3917 3         53 foreach $tag (keys %$info) {
3918 383         505 $groups{ $self->GetGroup($tag, $family) } = 1;
3919             }
3920 3         50 return sort keys %groups;
3921             }
3922              
3923             #------------------------------------------------------------------------------
3924             # Set priority for group where new values are written
3925             # Inputs: 0) ExifTool object reference,
3926             # 1-N) group names (reset to default if no groups specified)
3927             # - used when new tag values are set (ie. before files are written)
3928             sub SetNewGroups($;@)
3929             {
3930 508     508 1 735 local $_;
3931 508         2060 my ($self, @groups) = @_;
3932 508 50       1254 @groups or @groups = @defaultWriteGroups;
3933 508         1064 my $count = @groups * 10;
3934 508         887 my %priority;
3935 508         945 foreach (@groups) {
3936 4572         7666 $priority{lc($_)} = $count;
3937 4572         5090 $count -= 10;
3938             }
3939 508         1181 $priority{file} = 500; # 'File' group is always written (Comment)
3940 508         1160 $priority{composite} = 500; # 'Composite' group is always written
3941             # set write priority (higher # is higher priority)
3942 508         1278 $$self{WRITE_PRIORITY} = \%priority;
3943 508         1537 $$self{WRITE_GROUPS} = \@groups;
3944             }
3945              
3946             #------------------------------------------------------------------------------
3947             # Build Composite tags from Require'd/Desire'd tags
3948             # Inputs: 0) ExifTool object reference, 1) flag to build only tags that require
3949             # tags from alternate files (without this, these tags are ignored)
3950             # Note: Tag values are calculated in alphabetical order unless a tag Require's
3951             # or Desire's another Composite tag, in which case the calculation is
3952             # deferred until after the other tag is calculated.
3953             sub BuildCompositeTags($)
3954             {
3955 541     541 1 887 local $_;
3956 541         2363 my ($self, $altOnly) = @_;
3957              
3958 541         1440 $$self{BuildingComposite} = 1;
3959              
3960 541         1421 my $compTable = GetTagTable('Image::ExifTool::Composite');
3961 541         29835 my @tagList = sort keys %$compTable;
3962 541         2476 my $rawValue = $$self{VALUE};
3963 541         1131 my $compKeys = $$self{COMP_KEYS};
3964 541         1138 my (%cache, $allBuilt);
3965              
3966 541         876 for (;;) {
3967 2363         3103 my (%notBuilt, $tag, @deferredTags);
3968 2363         3577 foreach (@tagList) {
3969 47601 100       119328 $notBuilt{$$compTable{$_}{Name}} = 1 unless $specialTags{$_};
3970             }
3971             COMPOSITE_TAG:
3972 2363         3281 foreach $tag (@tagList) {
3973 47601 100       78368 next if $specialTags{$tag};
3974 44355         62612 my $tagInfo = $self->GetTagInfo($compTable, $tag);
3975 44355 100       60818 next unless $tagInfo;
3976 44092         56242 my $tagName = $$compTable{$tag}{Name};
3977             # put required tags into array and make sure they all exist
3978 44092   100     65461 my $subDoc = ($$tagInfo{SubDoc} and $$self{DOC_COUNT});
3979 44092   100     83660 my $require = $$tagInfo{Require} || { };
3980 44092   100     76695 my $desire = $$tagInfo{Desire} || { };
3981 44092   100     79083 my $inhibit = $$tagInfo{Inhibit} || { };
3982             # loop through sub-documents if necessary
3983 44092         43563 my $docNum = 0;
3984 44092         41228 for (;;) {
3985 44092         44656 my (%tagKey, $found, $index, $requireAlt);
3986             # save Require'd and Desire'd tag values in list
3987 44092         43421 for ($index=0; ; ++$index) {
3988 103005   100     225523 my $reqTag = $$require{$index} || $$desire{$index} || $$inhibit{$index};
3989 103005 100       125324 unless ($reqTag) {
3990             # allow Composite with no Require'd or Desire'd tags
3991 9508 50       14162 $found = 1 if $index == 0;
3992 9508         11697 last;
3993             }
3994 93497 100 66     226740 if ($subDoc) {
    100          
    100          
3995             # handle SubDoc tags specially to cache tag keys for faster
3996             # processing when there are a large number of sub-documents
3997             # - get document number from the tag groups if specified,
3998             # otherwise we are looping through all documents for this tag
3999 304 50 0     567 my $doc = $reqTag =~ s/\b(Main|Doc(\d+)):// ? ($2 || 0) : $docNum;
4000             # make fast lookup for keys of this tag with specified groups other than doc group
4001             # (similar to code in InsertTagValues(), but this is case-sensitive)
4002 304         415 my $cacheTag = $cache{$reqTag};
4003 304 50       444 unless ($cacheTag) {
4004 304         595 $cacheTag = $cache{$reqTag} = [ ];
4005 304         340 my $reqGroup;
4006 304 50       1559 $reqTag =~ s/^(.*):// and $reqGroup = $1;
4007 304         407 my ($i, $key, @keys);
4008             # build list of tag keys in order of precedence
4009 304   50     785 for ($key=$reqTag, $i=$$self{DUPL_TAG}{$reqTag} || 0; ; --$i) {
4010 304 50       491 push @keys, $key if defined $$rawValue{$key};
4011 304 50       500 last if $i <= 0;
4012 0         0 $key = "$reqTag ($i)";
4013             }
4014 304 50       698 @keys = $self->GroupMatches($reqGroup, \@keys) if defined $reqGroup;
4015             # loop through tags in reverse order of precedence so the higher
4016             # priority tag will win in the case of duplicates within a doc
4017 304   0     449 $$cacheTag[$$self{TAG_EXTRA}{$_}{G3} || 0] = $_ foreach reverse @keys;
4018             }
4019             # (set $reqTag to a bogus key if not found)
4020 304   33     780 $reqTag = $$cacheTag[$doc] || "$reqTag (0)";
4021             } elsif ($reqTag =~ /^(.*):(.+)/) {
4022 29587         51695 my ($reqGroup, $name) = ($1, $2);
4023 29587 100 100     47679 if ($reqGroup eq 'Composite' and $notBuilt{$name}) {
4024             # defer only until all other tags are built if
4025             # we are inhibiting based on another Composite tag
4026 2238 100 100     8063 unless ($$inhibit{$index} and $allBuilt) {
4027 1767         4104 push @deferredTags, $tag;
4028 1767         5251 next COMPOSITE_TAG;
4029             }
4030             }
4031 27820         28010 my ($i, $key, @keys, $altFile);
4032 27820         26837 my $et = $self;
4033             # get tags from alternate file if a family 8 group was specified
4034 27820 100 100     66637 if ($reqTag =~ /\b(File\d+):/i and $$self{ALT_EXIFTOOL}{$1}) {
4035 2         5 $et = $$self{ALT_EXIFTOOL}{$1};
4036 2         4 $altFile = $1;
4037             # set flags indicating we require tags from alternate files
4038 2         8 $$self{DoAltComposite} = $requireAlt = 1;
4039             }
4040             # (CAREFUL! keys may not be sequential if one was deleted)
4041 27820   100     62387 for ($key=$name, $i=$$et{DUPL_TAG}{$name} || 0; ; --$i) {
4042 28526 100       47472 push @keys, $key if defined $$et{VALUE}{$key};
4043 28526 100       40440 last if $i <= 0;
4044 706         1287 $key = "$name ($i)";
4045             }
4046             # make sure the necessary information is available from the alternate file
4047 27820 100       35623 $self->CopyAltInfo($altFile, \@keys) if $altFile;
4048             # find first matching tag
4049 27820         43910 $key = $self->GroupMatches($reqGroup, \@keys);
4050 27820   66     61863 $reqTag = $key || "$name (0)";
4051             } elsif ($notBuilt{$reqTag} and not $$inhibit{$index}) {
4052             # calculate this tag later if it relies on another
4053             # Composite tag which hasn't been calculated yet
4054 5241         7204 push @deferredTags, $tag;
4055 5241         10674 next COMPOSITE_TAG;
4056             }
4057 86489 100       145611 if (defined $$rawValue{$reqTag}) {
    100          
4058 17030 100       22195 if ($$inhibit{$index}) {
4059 71         104 $found = 0;
4060 71         126 last;
4061             } else {
4062 16959         17002 $found = 1;
4063             }
4064             } elsif ($$require{$index}) {
4065 27505         27353 $found = 0;
4066 27505         28344 last; # don't continue since we require this tag
4067             }
4068 58913         89180 $tagKey{$index} = $reqTag;
4069             }
4070             # stop now if this requires alternate tags and we aren't building them
4071 37084 100 100     74628 last if $requireAlt xor $altOnly;
4072 37011 50       64371 if ($docNum) {
    100          
    100          
4073 0 0       0 if ($found) {
4074 0         0 $$self{DOC_NUM} = $docNum;
4075             # save pointers to all used tag keys
4076 0         0 foreach (keys %tagKey) {
4077 0 0       0 $$compKeys{$_} or $$compKeys{$_} = [ ];
4078 0         0 push @{$$compKeys{$tagKey{$_}}}, [ \%tagKey, $_ ];
  0         0  
4079             }
4080 0         0 $self->FoundTag($tagInfo, \%tagKey);
4081 0         0 delete $$self{DOC_NUM};
4082             }
4083 0 0       0 next if ++$docNum <= $$self{DOC_COUNT};
4084 0         0 last;
4085             } elsif ($found) {
4086 5513         8531 delete $notBuilt{$tagName}; # this tag is OK to build now
4087             # keep track of all Require'd tag keys
4088 5513         13115 foreach (keys %tagKey) {
4089             # only tag keys with same name as a Composite tag
4090             # can be replaced (also eliminates keys with
4091             # instance numbers which can't be replaced either)
4092 24355 100       39923 next unless $compositeID{$tagKey{$_}};
4093             }
4094             # save pointers to all used tag keys
4095 5513         10294 foreach (keys %tagKey) {
4096 24355 100       37403 $$compKeys{$_} or $$compKeys{$_} = [ ];
4097 24355         22693 push @{$$compKeys{$tagKey{$_}}}, [ \%tagKey, $_ ];
  24355         74668  
4098             }
4099             # save reference to tag key lookup as value for Composite tag
4100 5513         13211 my $key = $self->FoundTag($tagInfo, \%tagKey);
4101             } elsif (not defined $found) {
4102 3965         6207 delete $notBuilt{$tagName}; # tag can't be built anyway
4103             }
4104 37011 100       77874 last unless $subDoc;
4105             # don't process sub-documents if there is no chance to build this tag
4106             # (can be very time-consuming if there are many docs)
4107 208 100       361 if (%$require) {
4108 176         348 foreach (keys %$require) {
4109 176         265 my $reqTag = $$require{$_};
4110 176         468 $reqTag =~ s/.*://;
4111 176 50       593 next COMPOSITE_TAG unless defined $$rawValue{$reqTag};
4112             }
4113 0         0 $docNum = 1; # go ahead and process the 1st sub-document
4114             } else {
4115 32 50       96 my @try = ref $$tagInfo{SubDoc} ? @{$$tagInfo{SubDoc}} : keys %$desire;
  32         87  
4116             # at least one of the specified desire tags must exist
4117 32         74 foreach (@try) {
4118 64 50       168 my $desTag = $$desire{$_} or next;
4119 64         215 $desTag =~ s/.*://;
4120 64 50       156 defined $$rawValue{$desTag} and $docNum = 1, last;
4121             }
4122 32 50       143 last unless $docNum;
4123             }
4124             }
4125             }
4126 2363 100       4742 last unless @deferredTags;
4127 1822 100       3456 if (@deferredTags == @tagList) {
4128 471 50       1261 if ($allBuilt) {
4129             # everything was deferred in the last pass,
4130             # must be a circular dependency
4131 0         0 warn "Circular dependency in Composite tags\n";
4132 0         0 last;
4133             }
4134 471         820 $allBuilt = 1; # try once more, ignoring Composite Inhibit tags
4135             }
4136 1822         10884 @tagList = @deferredTags; # calculate deferred tags now
4137             }
4138 541         2071 delete $$self{BuildingComposite};
4139             }
4140              
4141             #------------------------------------------------------------------------------
4142             # Get reference to Composite tag info hash
4143             # Inputs: 0) case-sensitive Composite tag name
4144             # Returns: tagInfo hash or undef
4145             sub GetCompositeTagInfo($)
4146             {
4147 11     11 0 22 my $tag = shift;
4148 11 50       77 return undef unless $compositeID{$tag};
4149 11         49 return $Image::ExifTool::Composite{$compositeID{$tag}[0]};
4150             }
4151              
4152             #------------------------------------------------------------------------------
4153             # Return List ExifTool API options
4154             # Returns: 0) reference to list of available options -- each entry is a list
4155             # [0=option name, 1=default value, 2=description]
4156             sub AvailableOptions()
4157             {
4158 0     0 1 0 return \@availableOptions;
4159             }
4160              
4161             #------------------------------------------------------------------------------
4162             # Get tag name (removes copy index)
4163             # Inputs: 0) Tag key
4164             # Returns: Tag name
4165             sub GetTagName($)
4166             {
4167 17429     17429 1 17014 local $_;
4168 17429         26030 $_[0] =~ /^(\S+)/;
4169 17429         30791 return $1;
4170             }
4171              
4172             #------------------------------------------------------------------------------
4173             # Get list of shortcuts
4174             # Returns: Shortcut list (sorted alphabetically)
4175             sub GetShortcuts()
4176             {
4177 0     0 1 0 local $_;
4178 0         0 require Image::ExifTool::Shortcuts;
4179 0         0 return sort keys %Image::ExifTool::Shortcuts::Main;
4180             }
4181              
4182             #------------------------------------------------------------------------------
4183             # Get file type for specified extension
4184             # Inputs: 0) file name or extension (case is not significant),
4185             # or FileType value if a description is requested
4186             # 1) flag to return long description instead of type ('0' to return any recognized type)
4187             # Returns: File type (or desc) or undef if extension not supported or if
4188             # description is the same as the input FileType. In list context,
4189             # may return more than one file type if the file may be different formats.
4190             # Returns list of all supported extensions if no file specified
4191             sub GetFileType(;$$)
4192             {
4193 1010     1010 1 1437 local $_;
4194 1010         2236 my ($file, $desc) = @_;
4195 1010 50       2455 unless (defined $file) {
4196 0         0 my @types;
4197 0 0 0     0 if (defined $desc and $desc eq '0') {
4198             # return all recognized types
4199 0         0 @types = sort keys %fileTypeLookup;
4200             } else {
4201             # return all supported types
4202 0         0 foreach (sort keys %fileTypeLookup) {
4203 0         0 my $module = $moduleName{$_};
4204 0 0       0 $module = $moduleName{$fileTypeLookup{$_}} unless defined $module;
4205 0 0 0     0 push @types, $_ unless defined $module and $module eq '0';
4206             }
4207             }
4208 0         0 return @types;
4209             }
4210 1010         1825 my ($fileType, $subType);
4211 1010         2105 my $fileExt = GetFileExtension($file);
4212 1010 100       2351 unless ($fileExt) {
4213 73 50       281 if ($file =~ s/ \((.*)\)$//) {
4214 0         0 $subType = $1;
4215 0         0 $fileExt = GetFileExtension($file);
4216             }
4217 73 50       244 $fileExt = uc($file) unless $fileExt;
4218             }
4219 1010 100       3955 $fileExt and $fileType = $fileTypeLookup{$fileExt}; # look up the file type
4220 1010   100     5080 $fileType = $fileTypeLookup{$fileType} while $fileType and not ref $fileType;
4221             # return description if specified
4222             # (allow input $file to be a FileType for this purpose)
4223 1010 50 33     5518 if ($desc) {
    100 66        
4224 0 0       0 if ($fileType) {
4225 0 0 0     0 if ($static_vars{OverrideFileDescription} and $static_vars{OverrideFileDescription}{$fileExt}) {
4226 0         0 $desc = $static_vars{OverrideFileDescription}{$fileExt};
4227             } else {
4228 0         0 $desc = $$fileType[1];
4229             }
4230             } else {
4231 0   0     0 $desc = $fileDescription{$file} || $file;
4232             }
4233 0 0       0 $desc .= ", $subType" if $subType;
4234 0         0 return $desc;
4235             } elsif ($fileType and (not defined $desc or $desc ne '0')) {
4236             # return only supported file types
4237 955         2979 my $mod = $moduleName{$$fileType[0]};
4238 955 50 66     3138 undef $fileType if defined $mod and $mod eq '0';
4239             }
4240 1010 100       2034 $fileType or return ();
4241 955         1709 $fileType = $$fileType[0]; # get file type (or list of types)
4242 955 100       2056 if (wantarray) {
    50          
4243 716 100       1762 return @$fileType if ref $fileType eq 'ARRAY';
4244             } elsif ($fileType) {
4245 239 50       738 $fileType = $fileExt if ref $fileType eq 'ARRAY';
4246             }
4247 951         2267 return $fileType;
4248             }
4249              
4250             #------------------------------------------------------------------------------
4251             # Return true if we can write the specified file type
4252             # Inputs: 0) file name or ext
4253             # Returns: true if writable, 0 if not writable, '' if not writable due to extension,
4254             # undef if unrecognized
4255             sub CanWrite($)
4256             {
4257 0     0 1 0 local $_;
4258 0 0       0 my $file = shift or return undef;
4259 0 0       0 my ($type) = GetFileType($file) or return undef;
4260 0 0       0 if ($noWriteFile{$type}) {
4261             # can't write TIFF files with certain extensions (various RAW formats)
4262 0   0     0 my $ext = GetFileExtension($file) || uc($file);
4263 0 0       0 return grep(/^$ext$/, @{$noWriteFile{$type}}) ? '' : 1 if $ext;
  0 0       0  
4264             }
4265 0 0       0 if ($onlyWriteFile{$type}) {
4266 0   0     0 my $ext = GetFileExtension($file) || uc($file);
4267 0 0       0 return grep(/^$ext$/, @{$onlyWriteFile{$type}}) ? 1 : 0 if $ext;
  0 0       0  
4268             }
4269 0 0       0 unless (%writeTypes) {
4270 0         0 $writeTypes{$_} = 1 foreach @writeTypes;
4271             }
4272 0         0 return $writeTypes{$type};
4273             }
4274              
4275             #------------------------------------------------------------------------------
4276             # Return true if we can create the specified file type
4277             # Inputs: 0) file name or ext
4278             # Returns: true if creatable, 0 if not writable, undef if unrecognized
4279             sub CanCreate($)
4280             {
4281 24     24 1 51 local $_;
4282 24 50       81 my $file = shift or return undef;
4283 24   33     70 my $ext = GetFileExtension($file) || uc($file);
4284 24 50       77 my $type = GetFileType($file) or return undef;
4285 24 50 33     188 return 1 if $createTypes{$ext} or $createTypes{$type};
4286 0         0 return 0;
4287             }
4288              
4289             #------------------------------------------------------------------------------
4290             # Return list of ordered keys if available, otherwise just sort alphabetically
4291             # Inputs: 0) hash ref
4292             # Returns: List of ordered/sorted keys
4293             sub OrderedKeys($)
4294             {
4295 357     357 1 1370 my $hash = shift;
4296 357 100       1138 return $$hash{_ordered_keys_} ? @{$$hash{_ordered_keys_}} : sort keys %$hash;
  111         250  
4297             }
4298              
4299             #==============================================================================
4300             # Functions below this are not part of the public API
4301              
4302             # Initialize member variables before reading or writing a new file
4303             # Inputs: 0) ExifTool object reference
4304             sub Init($)
4305             {
4306 818     818 0 1384 local $_;
4307 818         1339 my $self = shift;
4308             # delete all DataMember variables (lower-case names)
4309 818         16214 delete $$self{$_} foreach grep /[a-z]/, keys %$self;
4310             # reset static variables
4311             %static_vars = (
4312             KeepUTCTime => $$self{OPTIONS}{KeepUTCTime},
4313             SystemTimeRes => $$self{OPTIONS}{SystemTimeRes},
4314 818         5226 );
4315 818         2018 delete $$self{FOUND_TAGS}; # list of found tags
4316 818         1365 delete $$self{EXIF_DATA}; # the EXIF data block
4317 818         1255 delete $$self{EXIF_POS}; # EXIF position in file
4318 818         1336 delete $$self{FIRST_EXIF_POS}; # position of first EXIF in file
4319 818         1236 delete $$self{HTML_DUMP}; # html dump information
4320 818         1179 delete $$self{SET_GROUP0}; # group0 name override
4321 818         1195 delete $$self{SET_GROUP1}; # group1 name override
4322 818         1144 delete $$self{DOC_NUM}; # current embedded document number
4323 818         1648 $$self{DOC_COUNT} = 0; # count of embedded documents processed
4324 818         1684 $$self{BASE} = 0; # base for offsets from start of file
4325 818         3510 $$self{FILE_ORDER} = { }; # * hash of tag order in file ('*' = based on tag key)
4326 818         4020 $$self{VALUE} = { }; # * hash of raw tag values
4327 818         2089 $$self{BOTH} = { }; # * hash for Value/PrintConv values of Require'd tags
4328 818         3431 $$self{TAG_INFO} = { }; # * hash of tag information
4329 818         5584 $$self{TAG_EXTRA} = { }; # * hash of extra tag information (dynamic group names)
4330 818         2095 $$self{PRIORITY} = { }; # * priority of current tags
4331 818         1750 $$self{LIST_TAGS} = { }; # hash of tagInfo refs for active List-type tags
4332 818         2396 $$self{PROCESSED} = { }; # hash of processed directory start positions
4333 818         2040 $$self{DIR_COUNT} = { }; # count various types of directories
4334 818         1942 $$self{DUPL_TAG} = { }; # last-used index for duplicate-tag keys
4335 818         1673 $$self{WAS_WARNED} = { }; # number of times each warning was issued
4336 818         1548 $$self{WRITTEN} = { }; # list of tags written (selected tags only)
4337 818         1503 $$self{FORCE_WRITE}= { }; # ForceWrite lookup (set from ForceWrite tag)
4338 818         1776 $$self{FOUND_DIR} = { }; # hash of directory names found in file
4339 818         5703 $$self{COMP_KEYS} = { }; # lookup for tag keys used in Composite tags
4340 818         1673 $$self{PATH} = [ ]; # current subdirectory path in file when reading
4341 818         1574 $$self{NUM_FOUND} = 0; # total number of tags found (incl. duplicates)
4342 818         1482 $$self{CHANGED} = 0; # number of tags changed (writer only)
4343 818         1640 $$self{INDENT} = ' '; # initial indent for verbose messages
4344 818         1544 $$self{PRIORITY_DIR} = ''; # the priority directory name
4345 818         2596 $$self{LOW_PRIORITY_DIR} = { PreviewIFD => 1 }; # names of priority 0 directories
4346 818         1778 $$self{TIFF_TYPE} = ''; # type of TIFF data (APP1, TIFF, NEF, etc...)
4347 818         1596 $$self{FMT_EXPR} = undef; # current advanced formatting expression
4348 818         1612 $$self{HAS_DOC} = { }; # lookup for all document numbers in this file
4349 818         1769 $$self{Make} = ''; # camera make
4350 818         1762 $$self{Model} = ''; # camera model
4351 818         1925 $$self{CameraType} = ''; # Olympus camera type
4352 818         1543 $$self{FileType} = ''; # identified file type
4353 818 50       2264 if ($self->Options('HtmlDump')) {
4354 0         0 require Image::ExifTool::HtmlDump;
4355 0         0 $$self{HTML_DUMP} = Image::ExifTool::HtmlDump->new;
4356             }
4357             # make sure our TextOut is a file reference
4358 818 50       2866 $$self{OPTIONS}{TextOut} = \*STDOUT unless ref $$self{OPTIONS}{TextOut};
4359             }
4360              
4361             #------------------------------------------------------------------------------
4362             # Purge temporary tags from memory and set purge flag for next time
4363             # Inputs: 0) false=disable purging, true=enable purging, and
4364             # purge now if number of digits in tags to purge >= flag
4365             sub Purge(;$)
4366             {
4367 0   0 0 0 0 $purgeFlag = shift || 0;
4368 0 0 0     0 if (@purgeTags and length(scalar @purgeTags) >= $purgeFlag) {
4369 0         0 foreach (@purgeTags) {
4370 0 0       0 delete $$_{Table}{$$_{TagID}} unless defined $$_{IsProtobuf};
4371             }
4372 0         0 undef @purgeTags;
4373             }
4374             }
4375              
4376             #------------------------------------------------------------------------------
4377             # Combine information from a list of info hashes
4378             # Unless Duplicates is enabled, first entry found takes priority
4379             # Inputs: 0) ExifTool object reference, 1-N) list of info hash references
4380             # Returns: Combined information hash reference
4381             sub CombineInfo($;@)
4382             {
4383 2     2 0 985 local $_;
4384 2         5 my $self = shift;
4385 2         4 my (%combinedInfo, $info, $tag, %haveInfo);
4386              
4387 2 50       6 if ($$self{OPTIONS}{Duplicates}) {
4388 0         0 while ($info = shift) {
4389 0         0 foreach $tag (keys %$info) {
4390 0         0 $combinedInfo{$tag} = $$info{$tag};
4391             }
4392             }
4393             } else {
4394 2         8 while ($info = shift) {
4395 4         43 foreach $tag (keys %$info) {
4396 266         261 my $tagName = GetTagName($tag);
4397 266 100       327 next if $haveInfo{$tagName};
4398 252         290 $haveInfo{$tagName} = 1;
4399 252         413 $combinedInfo{$tag} = $$info{$tag};
4400             }
4401             }
4402             }
4403 2         40 return \%combinedInfo;
4404             }
4405              
4406             #------------------------------------------------------------------------------
4407             # Finish generating tags after extracting information from a file
4408             # Inputs: 0) ExifTool ref
4409             # Notes: The sequencing here is a bit tricky because tags from the main file
4410             # may be used in the names of alternate files, so we finish generating
4411             # all main file tags first (including all Composite tags which don't
4412             # rely on alternate files) before extracting tags from alternate files,
4413             # then we finish by generating the remaingin Composite tags.
4414             sub DoneExtract($)
4415             {
4416 550     550 0 957 my $self = shift;
4417             # extract information from alternate files if necessary
4418 550         929 my ($g8, $altExifTool);
4419 550         1281 my $opts = $$self{OPTIONS};
4420              
4421             # generate ImageDataHash if requested
4422 550 50       2881 if ($$self{ImageDataHash}) {
4423 0         0 my $digest = $$self{ImageDataHash}->hexdigest;
4424             # (don't store empty digest)
4425 0 0 0     0 $self->FoundTag(ImageDataHash => $digest) unless
      0        
4426             $digest eq 'd41d8cd98f00b204e9800998ecf8427e' or
4427             $digest eq 'e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855' or
4428             $digest eq 'cf83e1357eefb8bdf1542850d66d8007d620e4050b5715dc83f4a921d36ce9ce47d0d13c5d85f2b0ff8318d2877eec2f63b931bd47417a81a538327af927da3e';
4429             }
4430             # generate Validate tag if requested
4431 550 100       1652 if ($$opts{Validate}) {
4432 1         5 Image::ExifTool::Validate::FinishValidate($self, $$self{REQ_TAG_LOOKUP}{validate});
4433             }
4434             # generate geolocation tags if requested
4435 550 100       2718 if ($$opts{Geolocation}) {
4436 4         8 my ($arg, @defaults, @tags, $tag, @coord, @ref, @city, $doneCity, $both);
4437 4         9 my $geoOpt = $$opts{Geolocation};
4438 4         28 my @args = split /\s*,\s*/, $$opts{Geolocation};
4439 4         8 foreach $arg (@args) {
4440 8 50       22 lc $arg eq 'both' and $both = 1, next;
4441 8 50       22 $arg !~ s/^\$// and push(@defaults, $arg), next;
4442 0         0 push @tags, $arg; # argument is a tag name
4443             }
4444 4 50       13 unless (@tags) {
4445             # default tags to read if not specified
4446 4         25 @tags = qw(GPSLatitude GPSLongitude GPSLatitudeRef GPSLongitudeRef
4447             GPSCoordinates LocationShownGPSLatitude LocationShownGPSLongitude
4448             XMP:City State CountryCode Country
4449             IPTC:City Province-State Country-PrimaryLocationCode Country-PrimaryLocationName
4450             LocationShownCity LocationShownProvinceState LocationShownCountryCode LocationShownCountryName);
4451             }
4452             # get information for specified tags
4453 4         33 my $info = $self->GetInfo(\@tags, { PrintConv => 0, Duplicates => 0 }); # (returns tags in proper case)
4454 4         9 $opts = $$self{OPTIONS}; # (necessary because GetInfo changes the OPTIONS hash)
4455 4         10 foreach $tag (@tags) {
4456 76         82 my $val = $$info{$tag};
4457 76 100       111 next unless defined $val;
4458 7         22 $self->VPrint(0, "Found $tag ($val)\n");
4459 7 50       14 if ($tag =~ /Coordinates/) {
4460 0 0 0     0 next if defined $coord[0] and defined $coord[1];
4461 0         0 @coord = split ' ', $val;
4462 0         0 next;
4463             }
4464 7 100       13 my $n = $tag =~ /Latitude/ ? 0 : ($tag =~ /Longitude/ ? 1 : undef);
    100          
4465 7 100       9 if (defined $n) {
4466 4 100       8 if ($tag =~ /Ref$/) {
4467 2 50       5 $ref[$n] = $val unless $ref[$n];
4468             } else {
4469 2 50       4 $coord[$n] = $val unless defined $coord[$n];
4470             }
4471 4         5 next;
4472             }
4473             # handle city tags (save info for first city found)
4474 3 100       10 if ($tag =~ /City/) {
    50          
4475 1 50       2 @city and $doneCity = 1, next;
4476 1         2 push @city, $val;
4477             } elsif (@city) {
4478 2 50       4 push @city, $val unless $doneCity;
4479 2 50       4 next if $doneCity;
4480             }
4481             }
4482 4 100 66     20 if (defined $coord[0] and defined $coord[1]) {
    50          
4483 1 50 33     6 $coord[0] = -$coord[0] if $ref[0] and $coord[0] > 0 and $ref[0] eq 'S';
      33        
4484 1 50 33     6 $coord[1] = -$coord[1] if $ref[1] and $coord[1] > 0 and $ref[1] eq 'W';
      33        
4485 1         7 $arg = join ',', @coord;
4486             } elsif (@city) {
4487 0         0 $arg = join ',', @city;
4488             }
4489 4 100       11 if (not defined $arg) {
4490             # use specified default values if no tags found
4491 3         12 $arg = join ',', @defaults;
4492 3 50       10 undef $arg if $arg eq '1';
4493 3         7 $both = 1; # use 'both' GPS and place names if provided
4494             }
4495 4 50       24 if ($arg) {
4496 4 100       16 $arg .= ',both' if $both;
4497 4         15 $arg = $self->Encode($arg, 'UTF8');
4498 4         26 require Image::ExifTool::Geolocation;
4499 4 50       9 if ($$opts{Verbose}) {
4500 0 0       0 if ($Image::ExifTool::Geolocation::dbInfo) {
4501 0         0 print "Loaded $Image::ExifTool::Geolocation::dbInfo\n";
4502             } else {
4503 0         0 print "Error loading Geolocation.dat\n";
4504             }
4505             }
4506 4         25 local $SIG{'__WARN__'} = \&SetWarning;
4507 4         8 undef $evalWarning;
4508 4         9 $$opts{GeolocMulti} = $$opts{Duplicates};
4509 4         20 $self->VPrint(0, "Geolocation arguments: '${arg}'\n");
4510 4         20 my ($cities, $dist) = Image::ExifTool::Geolocation::Geolocate($arg, $opts);
4511 4         13 delete $$opts{GeolocMulti};
4512 4 50 33     26 if ($cities and (@$cities < 2 or $dist or not $self->Warn('Multiple Geolocation cities are possible',2))) {
    0 33        
4513 4 100       14 $self->FoundTag(GeolocationWarning => 'Search matched '.scalar(@$cities).' cities') if @$cities > 1;
4514 4         7 my $city;
4515 4         10 foreach $city (@$cities) {
4516 5 100       18 $$self{DOC_NUM} = ++$$self{DOC_COUNT} unless $city eq $$cities[0];
4517 5         24 my @geo = Image::ExifTool::Geolocation::GetEntry($city, $$opts{Lang});
4518 5         25 $self->FoundTag(GeolocationCity => $geo[0]);
4519 5 50       20 $self->FoundTag(GeolocationRegion => $geo[1]) if $geo[1];
4520 5 50       19 $self->FoundTag(GeolocationSubregion => $geo[2]) if $geo[2];
4521 5         13 $self->FoundTag(GeolocationCountryCode => $geo[3]);
4522 5 50       32 $self->FoundTag(GeolocationCountry => $geo[4]) if $geo[4];
4523 5 50       19 $self->FoundTag(GeolocationTimeZone => $geo[5]) if $geo[5];
4524 5         14 $self->FoundTag(GeolocationFeatureCode => $geo[6]);
4525 5 100       30 $self->FoundTag(GeolocationFeatureType => $geo[10]) if $geo[10];
4526 5         12 $self->FoundTag(GeolocationPopulation => $geo[7]);
4527 5         18 $self->FoundTag(GeolocationPosition => "$geo[8] $geo[9]");
4528 5 100       18 if ($dist) {
4529 4         9 $self->FoundTag(GeolocationDistance => $$dist[0][0]);
4530 4         8 $self->FoundTag(GeolocationBearing => $$dist[0][1]);
4531 4         4 shift @$dist;
4532             }
4533 5 50       21 last unless $$opts{Duplicates};
4534             }
4535 4         47 delete $$self{DOC_NUM};
4536             } elsif ($evalWarning) {
4537 0         0 $self->Warn(CleanWarning());
4538             }
4539             }
4540             }
4541             # generate tags for user-defined parameters that ended with '#'
4542 550 50       804 if (%{$$opts{UserParam}}) {
  550         1805  
4543 0         0 my $doMsg = $$opts{Verbose};
4544 0         0 my $table = GetTagTable('Image::ExifTool::UserParam');
4545 0         0 foreach (sort keys %{$$opts{UserParam}}) {
  0         0  
4546 0 0       0 next unless /#$/;
4547 0 0       0 if ($doMsg) {
4548 0         0 $self->VPrint(0, "UserParam tags:\n");
4549 0         0 undef $doMsg;
4550             }
4551 0         0 $self->HandleTag($table, $_, $$opts{UserParam}{$_});
4552             }
4553             }
4554 550 50 66     3271 if ($$opts{Composite} and (not $$opts{FastScan} or $$opts{FastScan} < 5)) {
      100        
4555             # build all composite tags except those requiring tags from alternate files
4556 540         2330 $self->BuildCompositeTags();
4557             }
4558 550         967 foreach $g8 (sort keys %{$$self{ALT_EXIFTOOL}}) {
  550         2617  
4559 8         24 $altExifTool = $$self{ALT_EXIFTOOL}{$g8};
4560 8 100       29 next if $$altExifTool{DID_EXTRACT}; # avoid extracting twice
4561 6         203 $$altExifTool{OPTIONS} = $$self{OPTIONS};
4562 6         26 $$altExifTool{GLOBAL_TIME_OFFSET} = $$self{GLOBAL_TIME_OFFSET};
4563 6         15 $$altExifTool{REQ_TAG_LOOKUP} = $$self{REQ_TAG_LOOKUP};
4564 6         16 $$altExifTool{ReqTagAlreadySet} = 1;
4565 6         15 my $fileName = $$altExifTool{ALT_FILE};
4566             # allow tags from the main file to be used in the alternate file names
4567             # (eg. -file1 '$originalfilename')
4568 6 50       23 if ($fileName =~ /\$/) {
4569 0         0 my @tags = reverse sort keys %{$$self{VALUE}};
  0         0  
4570 0         0 $fileName = $self->InsertTagValues($fileName, \@tags, 'Warn');
4571 0 0       0 next unless defined $fileName;
4572             }
4573 6         67 $altExifTool->ExtractInfo($fileName);
4574 6         16 my $err = $$altExifTool{VALUE}{Error};
4575 6 50       15 $err and $self->Warn(qq{$err "$fileName"});
4576             # set family 8 group name for all tags
4577 6         14 $$altExifTool{TAG_EXTRA}{$_}{G8} = $g8 foreach keys %{$$altExifTool{VALUE}};
  6         529  
4578             # prepare our sorted list of found tags
4579 6         48 $$altExifTool{FoundTags} = $altExifTool->SetFoundTags();
4580 6         21 $$altExifTool{DID_EXTRACT} = 1;
4581             }
4582             # if necessary, build composite tags that rely on tags from alternate files
4583 550 100       2186 $self->BuildCompositeTags(1) if $$self{DoAltComposite};
4584             }
4585              
4586             #------------------------------------------------------------------------------
4587             # Get tag table name
4588             # Inputs: 0) ExifTool object reference, 1) tag key
4589             # Returns: Table name if available, otherwise ''
4590             sub GetTableName($$)
4591             {
4592 0     0 0 0 my ($self, $tag) = @_;
4593 0 0       0 my $tagInfo = $$self{TAG_INFO}{$tag} or return '';
4594 0         0 return $$tagInfo{Table}{SHORT_NAME};
4595             }
4596              
4597             #------------------------------------------------------------------------------
4598             # Get tag index number
4599             # Inputs: 0) ExifTool object reference, 1) tag key
4600             # Returns: Table index number, or undefined if this tag isn't indexed
4601             sub GetTagIndex($$)
4602             {
4603 0     0 0 0 my ($self, $tag) = @_;
4604 0 0       0 my $tagInfo = $$self{TAG_INFO}{$tag} or return undef;
4605 0         0 return $$tagInfo{Index};
4606             }
4607              
4608             #------------------------------------------------------------------------------
4609             # Find value for specified tag
4610             # Inputs: 0) ExifTool ref, 1) tag name, 2) tag group (family 1)
4611             # Returns: value or undef
4612             sub FindValue($$$)
4613             {
4614 72     72 0 119 my ($et, $tag, $grp) = @_;
4615 72         75 my ($i, $val);
4616 72         84 my $value = $$et{VALUE};
4617 72         81 for ($i=0; ; ++$i) {
4618 144 100       223 my $key = $tag . ($i ? " ($i)" : '');
4619 144 100       237 last unless defined $$value{$key};
4620 142 100       170 if ($et->GetGroup($key, 1) eq $grp) {
4621 70         86 $val = $$value{$key};
4622 70         79 last;
4623             }
4624             }
4625 72         126 return $val;
4626             }
4627              
4628             #------------------------------------------------------------------------------
4629             # Get tag key for next existing tag
4630             # Inputs: 0) ExifTool ref, 1) tag key or case-sensitive tag name
4631             # Returns: Key of next existing tag, or undef if no more
4632             # Notes: This routine is provided for iterating through duplicate tags in the
4633             # ValueConv of Composite tags.
4634             sub NextTagKey($$)
4635             {
4636 23     23 0 72 my ($self, $tag) = @_;
4637 23 50       73 my $i = ($tag =~ s/ \((\d+)\)$//) ? $1 + 1 : 1;
4638 23         60 $tag = "$tag ($i)";
4639 23 50       64 return $tag if defined $$self{VALUE}{$tag};
4640 23         398 return undef;
4641             }
4642              
4643             #------------------------------------------------------------------------------
4644             # Does a string contain valid UTF-8 characters?
4645             # Inputs: 0) string reference, 1) true to allow last character to be truncated
4646             # Returns: 0=regular ASCII, -1=invalid UTF-8, 1=valid UTF-8 with maximum 16-bit
4647             # wide characters, 2=valid UTF-8 requiring 32-bit wide characters
4648             # Notes: Changes current string position
4649             # (see http://www.fileformat.info/info/unicode/utf8.htm for help understanding this)
4650             sub IsUTF8($;$)
4651             {
4652 125     125 0 179 my ($strPt, $trunc) = @_;
4653 125         423 pos($$strPt) = 0; # start at beginning of string
4654 125 100       449 return 0 unless $$strPt =~ /([\x80-\xff])/g;
4655 56         78 my $rtnVal = 1;
4656 56         60 for (;;) {
4657 198         231 my $ch = ord($1);
4658             # minimum lead byte for 2-byte sequence is 0xc2 (overlong sequences
4659             # not allowed), 0xf8-0xfd are restricted by RFC 3629 (no 5 or 6 byte
4660             # sequences), and 0xfe and 0xff are not valid in UTF-8 strings
4661 198 100 100     432 return -1 if $ch < 0xc2 or $ch >= 0xf8;
4662             # determine number of bytes remaining in sequence
4663 153         129 my $n;
4664 153 100       175 if ($ch < 0xe0) {
    50          
4665 75         61 $n = 1;
4666             } elsif ($ch < 0xf0) {
4667 78         71 $n = 2;
4668             } else {
4669 0         0 $n = 3;
4670             # character code is greater than 0xffff if more than 2 extra bytes
4671             # were required in the UTF-8 character
4672 0         0 $rtnVal = 2;
4673             }
4674 153         141 my $pos = pos $$strPt;
4675 153 100       510 unless ($$strPt =~ /\G([\x80-\xbf]{$n})/g) {
4676 1 50 33     16 return $rtnVal if $trunc and $pos + $n > length $$strPt;
4677 1         4 return -1;
4678             }
4679             # the following is ref https://www.cl.cam.ac.uk/%7Emgk25/ucs/utf8_check.c
4680 152 100       167 if ($n == 2) {
4681 77 50 66     292 return -1 if ($ch == 0xe0 and (ord($1) & 0xe0) == 0x80) or
      33        
      33        
      66        
      33        
      33        
4682             ($ch == 0xed and (ord($1) & 0xe0) == 0xa0) or
4683             ($ch == 0xef and ord($1) == 0xbf and
4684             (ord(substr $1, 1) & 0xfe) == 0xbe);
4685             } else {
4686 75 50 33     246 return -1 if ($ch == 0xf0 and (ord($1) & 0xf0) == 0x80) or
      33        
      33        
      33        
4687             ($ch == 0xf4 and ord($1) > 0x8f) or $ch > 0xf4;
4688             }
4689 152 100       244 last unless $$strPt =~ /([\x80-\xff])/g;
4690             }
4691 10         20 return $rtnVal;
4692             }
4693              
4694             #------------------------------------------------------------------------------
4695             # Split file name into directory and name parts
4696             # Inptus: 0) file name
4697             # Returns: 0) directory, 1) filename
4698             sub SplitFileName($)
4699             {
4700 505     505 0 838 my $file = shift;
4701 505         951 my ($dir, $name);
4702 505 50       934 if (eval { require File::Basename }) {
  505         4313  
4703 505         24338 $dir = File::Basename::dirname($file);
4704 505         9593 $name = File::Basename::basename($file);
4705             } else {
4706 0         0 ($name = $file) =~ tr/\\/\//;
4707             # remove path
4708 0 0       0 if ($name =~ s/(.*)\///) {
4709 0 0       0 $dir = length($1) ? $1 : '/';
4710             } else {
4711 0         0 $dir = '.';
4712             }
4713             }
4714 505         1547 return ($dir, $name);
4715             }
4716              
4717             #------------------------------------------------------------------------------
4718             # Encode file name for calls to system i/o routines
4719             # Inputs: 0) ExifTool ref, 1) file name in CharsetFileName encoding,
4720             # 2) flag to force conversion even if no special characters
4721             # Returns: true if Windows Unicode routines should be used (in which case
4722             # the file name will be encoded as a null-terminated UTF-16LE string)
4723             sub EncodeFileName($$;$)
4724             {
4725 1198     1198 0 2438 my ($self, $file, $force) = @_;
4726 1198 50       2470 return 0 if $file eq '-'; # special case for stdin pipe
4727 1198         1977 my $enc = $$self{OPTIONS}{CharsetFileName};
4728 1198         1447 my $hasSpecialChars;
4729 1198 50       3445 if ($file =~ /[\x80-\xff]/) {
4730 0         0 $hasSpecialChars = 1;
4731 0 0 0     0 if (not $enc and $^O eq 'MSWin32') {
4732 0 0       0 if (IsUTF8(\$file) < 0) {
4733 0 0       0 $self->Warn('FileName encoding must be specified') if not defined $enc;
4734 0         0 return 0;
4735             } else {
4736 0         0 $enc = 'UTF8'; # assume UTF8
4737             }
4738             }
4739             }
4740 1198 50 33     8226 if ($hasSpecialChars or $force or $$self{OPTIONS}{WindowsLongPath} or $$self{OPTIONS}{WindowsWideFile}) {
      33        
      33        
4741 0 0       0 $enc or $enc = 'UTF8';
4742 0 0       0 if ($^O eq 'MSWin32') {
    0          
4743 0         0 local $SIG{'__WARN__'} = \&SetWarning;
4744 0 0       0 if (eval { require Win32API::File }) {
  0         0  
4745 0 0       0 $file = $self->WindowsLongPath($file) if $$self{OPTIONS}{WindowsLongPath};
4746             # recode as UTF-16LE and add null terminator
4747 0         0 $_[1] = $self->Decode($file, $enc, undef, 'UTF16', 'II') . "\0\0";
4748 0         0 return 1;
4749             }
4750 0         0 $self->Warn('Install Win32API::File for Windows wide/long file name support');
4751             } elsif ($enc ne 'UTF8') {
4752             # recode as UTF-8 for other platforms if necessary
4753 0         0 $_[1] = $self->Decode($file, $enc, undef, 'UTF8');
4754             }
4755             }
4756 1198         3119 return 0;
4757             }
4758              
4759             #------------------------------------------------------------------------------
4760             # Rebuild a path as an absolute long path to be usable in Windows system calls
4761             # Inputs: 0) ExifTool ref, 1) path string (CharsetFileName)
4762             # Returns: normalized long path (CharsetFileName)
4763             # Note: this should only be called for Windows systems
4764             # References:
4765             # - https://learn.microsoft.com/en-us/dotnet/standard/io/file-path-formats
4766             # - https://learn.microsoft.com/en-us/windows/win32/fileio/maximum-file-path-limitation
4767             # GetFullPathName supported by Windows XP and later. It handles:
4768             # full path names EG: c:\foto\sub\abc.jpg
4769             # relative EG: .\abc.jpg, ..\abc.jpg
4770             # full UNC paths EG: \\server\share\abc.jpg
4771             # relative UNC paths EG: .\abc.jpg, ..\abc.jpg
4772             # Dos device paths EG: \\.\c:\fotoabc.jpg
4773             # relative path on other drives EG: z:abc.jpg (working dir on z: z:\foto called from c:\foto)
4774             # Wide chars EG: Chars that need UTF8.
4775             my $k32GetFullPathName;
4776             sub WindowsLongPath($$)
4777             {
4778 0     0 1 0 my ($self, $path) = @_;
4779 0         0 my $debug = $$self{OPTIONS}{Debug};
4780 0         0 my $out = $$self{OPTIONS}{TextOut};
4781 0         0 my $suffix = '';
4782 0         0 my $longPath;
4783              
4784             # remove common suffixes to make cache more effective
4785 0 0       0 if ($path =~ s/(_original|_exiftool_tmp|:Zone\.Identifier)$//) {
4786 0         0 $suffix = $1;
4787 0 0 0     0 if (not length $path or $path =~ m([:./\\]$)) {
4788             # don't remove suffix if it could be the whole file name
4789 0         0 $path .= $suffix;
4790 0         0 $suffix = '';
4791             }
4792             }
4793 0 0 0     0 return $$self{LONG_PATH_OUT}.$suffix if defined $$self{LONG_PATH_IN} and $$self{LONG_PATH_IN} eq $path;
4794              
4795 0 0       0 $debug and print $out "WindowsLongPath input : $path$suffix\n";
4796              
4797 0         0 for (;;) { # (cheap goto)
4798 0         0 ($longPath = $path) =~ tr(/)(\\); # convert slashes to backslashes
4799 0 0       0 last if $longPath =~ /^\\\\\?\\/; # already a device path in the format we want
4800              
4801 0 0       0 unless ($k32GetFullPathName) { # need to import (once) GetFullPathNameW
4802 0 0       0 last if defined $k32GetFullPathName;
4803 0 0       0 unless (eval { require Win32::API }) {
  0         0  
4804 0         0 $self->Warn('Install Win32::API to use WindowsLongPath option');
4805 0         0 last;
4806             }
4807 0         0 $k32GetFullPathName = Win32::API->new('KERNEL32', 'GetFullPathNameW', 'PNPP', 'I');
4808 0 0       0 unless ($k32GetFullPathName) {
4809 0         0 $k32GetFullPathName = 0;
4810 0         0 $self->Warn('Error loading Win32::API GetFullPathNameW');
4811 0         0 last;
4812             }
4813             }
4814 0   0     0 my $enc = $$self{OPTIONS}{CharsetFileName} || 'UTF8';
4815 0         0 my $encPath = $self->Decode($longPath, $enc, undef, 'UTF16', 'II');# need to encode to UTF16
4816 0         0 my $lenReq = $k32GetFullPathName->Call($encPath,0,0,0) + 1; # first pass gets length required, +1 for safety (null?)
4817 0         0 my $fullPath = "\0" x $lenReq x 2; # create buffer to hold full path
4818 0         0 $k32GetFullPathName->Call($encPath, $lenReq, $fullPath, 0); # fullPath is UTF16 now
4819 0         0 $longPath = $self->Decode($fullPath, 'UTF16', 'II', $enc);
4820              
4821 0 0       0 last if length($longPath) <= 247 - length($suffix);
4822              
4823 0 0       0 if ($longPath =~ /^\\\\/) {
4824 0         0 $longPath = '\\\\?\\UNC' . substr($longPath, 1);
4825             } else {
4826 0         0 $longPath = '\\\\?\\' . $longPath;
4827             }
4828 0         0 last;
4829             }
4830             # this may be called repeatedly for the same file file (exists, stat, open),
4831             # so cache the last return value (without any of the suffixes that we use)
4832 0         0 $$self{LONG_PATH_IN} = $path;
4833 0         0 $$self{LONG_PATH_OUT} = $longPath;
4834 0 0       0 $debug and print $out "WindowsLongPath return: $longPath$suffix\n";
4835 0         0 return $longPath . $suffix;
4836             }
4837              
4838             #------------------------------------------------------------------------------
4839             # Modified perl open() routine to properly handle special characters in file names
4840             # Inputs: 0) ExifTool ref, 1) filehandle, 2) filename,
4841             # 3) mode: '<' or undef = read, '>' = write, '+<' = update
4842             # Returns: true on success
4843             # Note: Must call like "$et->Open(\*FH,$file)", not "$et->Open(FH,$file)" to avoid
4844             # "unopened filehandle" errors due to a change in scope of the filehandle
4845             sub Open($*$;$)
4846             {
4847 960     960 0 2473 my ($self, $fh, $file, $mode) = @_;
4848              
4849 960         3143 $file =~ s/^([\s&])/.\/$1/; # protect leading whitespace or ampersand
4850             # default to read mode ('<') unless input is a trusted pipe
4851 960 50 33     4022 $mode = (($file =~ /\|$/ and $$self{TRUST_PIPE}) ? '' : '<') unless $mode;
    100          
4852 960         1724 delete $$self{TRUST_PIPE};
4853 960 50       2221 if ($mode) {
4854 960 50       2822 if ($self->EncodeFileName($file)) {
4855             # handle Windows Unicode file name
4856 0         0 local $SIG{'__WARN__'} = \&SetWarning;
4857 0         0 my ($access, $create);
4858 0 0 0     0 if ($mode eq '>' or $mode eq '>>') {
4859 0         0 eval {
4860 0         0 $access = Win32API::File::GENERIC_WRITE();
4861 0 0       0 if ($mode eq '>>') {
4862 0         0 $access |= Win32API::File::FILE_APPEND_DATA();
4863 0         0 $create = Win32API::File::OPEN_ALWAYS();
4864             } else {
4865 0         0 $create = Win32API::File::CREATE_ALWAYS();
4866             }
4867             }
4868             } else {
4869 0         0 eval {
4870 0         0 $access = Win32API::File::GENERIC_READ();
4871 0 0       0 $access |= Win32API::File::GENERIC_WRITE() if $mode eq '+<'; # update
4872 0         0 $create = Win32API::File::OPEN_EXISTING();
4873             }
4874             }
4875 0         0 my $share = 0;
4876 0         0 eval {
4877 0 0       0 unless ($access & Win32API::File::GENERIC_WRITE()) {
4878 0         0 $share = Win32API::File::FILE_SHARE_READ() | Win32API::File::FILE_SHARE_WRITE();
4879             }
4880             };
4881 0         0 my $wh = eval { Win32API::File::CreateFileW($file, $access, $share, [], $create, 0, []) };
  0         0  
4882 0 0       0 return undef unless $wh;
4883 0         0 my $fd = eval { Win32API::File::OsFHandleOpenFd($wh, 0) };
  0         0  
4884 0 0 0     0 if (not defined $fd or $fd < 0) {
4885 0         0 eval { Win32API::File::CloseHandle($wh) };
  0         0  
4886 0         0 return undef;
4887             }
4888 0         0 $file = "&=$fd"; # specify file by descriptor
4889             } else {
4890             # add leading space to protect against leading characters like '>'
4891             # in file name, and trailing "\0" to protect trailing spaces
4892 960         1973 $file = " $file\0";
4893             }
4894             }
4895 960         80230 return open $fh, "$mode$file";
4896             }
4897              
4898             #------------------------------------------------------------------------------
4899             # Check to see if a file exists (with Windows Unicode support)
4900             # Inputs: 0) ExifTool ref, 1) file name, 2) flag if we are writing this file
4901             # Returns: true if file exists
4902             sub Exists($$;$)
4903             {
4904 231     231 0 645 my ($self, $file, $writing) = @_;
4905              
4906 231 50       987 if ($self->EncodeFileName($file)) {
    50          
4907 0         0 local $SIG{'__WARN__'} = \&SetWarning;
4908 0         0 my $wh = eval { Win32API::File::CreateFileW($file,
  0         0  
4909             Win32API::File::GENERIC_READ(),
4910             Win32API::File::FILE_SHARE_READ(), [],
4911             Win32API::File::OPEN_EXISTING(), 0, []) };
4912 0 0       0 return 0 unless $wh;
4913 0         0 eval { Win32API::File::CloseHandle($wh) };
  0         0  
4914             } elsif ($writing) {
4915             # (named pipes already exist, but we pretend that they don't
4916             # so we will be able to write them, so test for pipe with -p)
4917 231   33     3698 return(-e $file and not -p $file);
4918             } else {
4919 0         0 return(-e $file);
4920             }
4921 0         0 return 1;
4922             }
4923              
4924             #------------------------------------------------------------------------------
4925             # Return true if file is a directory (with Windows Unicode support)
4926             # Inputs: 0) ExifTool ref, 1) file name
4927             # Returns: true if file is a directory (false if file isn't, or doesn't exist)
4928             sub IsDirectory($$)
4929             {
4930 1     1 0 2 my ($et, $file) = @_;
4931 1 50       3 if ($et->EncodeFileName($file)) {
4932 0         0 local $SIG{'__WARN__'} = \&SetWarning;
4933 0         0 my $attrs = eval { Win32API::File::GetFileAttributesW($file) };
  0         0  
4934 0   0     0 my $dirBit = eval { Win32API::File::FILE_ATTRIBUTE_DIRECTORY() } || 0;
4935 0 0 0     0 return 1 if $attrs and $attrs != 0xffffffff and $attrs & $dirBit;
      0        
4936             } else {
4937 1         15 return -d $file;
4938             }
4939 0         0 return 0;
4940             }
4941              
4942             #------------------------------------------------------------------------------
4943             # Create directory for specified file
4944             # Inputs: 0) ExifTool ref, 1) complete file name including path
4945             # Returns: '' = directory created, undef = nothing done, otherwise error string
4946             my $k32CreateDir;
4947             sub CreateDirectory($$)
4948             {
4949 1     1 0 1 local $_;
4950 1         3 my ($self, $file) = @_;
4951 1         3 my ($err, $dir);
4952 1         6 ($dir = $file) =~ s/[^\/]*$//; # remove filename from path specification
4953 1 50 33     7 if ($dir and not $self->IsDirectory($dir)) {
4954 0         0 my @parts = split /\//, $dir;
4955 0         0 $dir = '';
4956 0         0 foreach (@parts) {
4957 0         0 $dir .= $_;
4958 0 0 0     0 if (length and not $self->IsDirectory($dir) and
      0        
      0        
4959             # don't try to create a network drive root directory
4960             not (IsPC() and $dir =~ m{^//[^/]*$}))
4961             {
4962 0         0 my $success;
4963             # create directory since it doesn't exist
4964 0         0 my $d2 = $dir; # (must make a copy in case EncodeFileName recodes it)
4965 0 0       0 if ($self->EncodeFileName($d2)) {
4966             # handle Windows Unicode directory names
4967 0 0       0 unless (defined $k32CreateDir) {
4968 0 0       0 unless (eval { require Win32::API }) {
  0         0  
4969 0         0 $err = 'Install Win32::API to create directories with Unicode names';
4970 0         0 last;
4971             }
4972 0         0 $k32CreateDir = Win32::API->new('KERNEL32', 'CreateDirectoryW', 'PP', 'I');
4973 0 0       0 unless ($k32CreateDir) {
4974 0         0 $k32CreateDir = 0;
4975             # give this error once, then just "Error creating" for subsequent attempts
4976 0         0 return 'Error loading Win32::API CreateDirectoryW';
4977             }
4978             }
4979 0 0       0 $success = $k32CreateDir->Call($d2, 0) if $k32CreateDir;
4980             } else {
4981 0         0 $success = mkdir($d2, 0777);
4982             }
4983 0 0       0 $success or $err = "Error creating directory $dir", last;
4984 0         0 $err = '';
4985             }
4986 0         0 $dir .= '/';
4987             }
4988             }
4989 1         5 return $err;
4990             }
4991              
4992             #------------------------------------------------------------------------------
4993             # Get file times (Unix seconds since the epoch)
4994             # Inputs: 0) ExifTool ref, 1) file name or ref
4995             # Returns: 0) access time, 1) modification time, 2) creation time (or undefs on error)
4996             my $k32GetFileTime;
4997             sub GetFileTime($$)
4998             {
4999 0     0 0 0 my ($self, $file) = @_;
5000              
5001             # open file by name if necessary
5002 0 0       0 unless (ref $file) {
5003 0         0 local *FH;
5004 0 0       0 unless ($self->Open(\*FH, $file)) {
5005 0 0       0 if ($self->IsDirectory($file)) {
5006 0         0 my @rtn = (stat $file)[8, 9, 10];
5007 0 0       0 return @rtn if defined $rtn[0];
5008             }
5009 0         0 $self->Warn("GetFileTime error for '${file}'");
5010 0         0 return ();
5011             }
5012 0         0 $file = *FH; # (not \*FH, so *FH will be kept open until $file goes out of scope)
5013             }
5014             # on Windows, try to work around incorrect file times when daylight saving time is in effect
5015 0 0       0 if ($^O eq 'MSWin32') {
5016 0 0       0 if (not eval { require Win32::API }) {
  0 0       0  
5017 0         0 $self->Warn('Install Win32::API for proper handling of Windows file times', 1);
5018 0         0 } elsif (not eval { require Win32API::File }) {
5019 0         0 $self->Warn('Install Win32API::File for proper handling of Windows file times', 1);
5020             } else {
5021             # get Win32 handle, needed for GetFileTime
5022 0         0 my $win32Handle = eval { Win32API::File::GetOsFHandle($file) };
  0         0  
5023 0 0       0 unless ($win32Handle) {
5024 0         0 $self->Warn("Win32API::File::GetOsFHandle returned invalid handle");
5025 0         0 return ();
5026             }
5027             # get FILETIME structs
5028 0         0 my ($atime, $mtime, $ctime, $time);
5029 0         0 $atime = $mtime = $ctime = pack 'LL', 0, 0;
5030 0 0       0 unless ($k32GetFileTime) {
5031 0 0       0 return () if defined $k32GetFileTime;
5032 0         0 $k32GetFileTime = Win32::API->new('KERNEL32', 'GetFileTime', 'NPPP', 'I');
5033 0 0       0 unless ($k32GetFileTime) {
5034 0         0 $self->Warn('Error loading Win32::API GetFileTime');
5035 0         0 $k32GetFileTime = 0;
5036 0         0 return ();
5037             }
5038             }
5039 0 0       0 unless ($k32GetFileTime->Call($win32Handle, $ctime, $atime, $mtime)) {
5040 0         0 $self->Warn("Win32::API GetFileTime returned " . Win32::GetLastError());
5041 0         0 return ();
5042             }
5043             # convert FILETIME structs to Unix seconds
5044 0         0 foreach $time ($atime, $mtime, $ctime) {
5045 0         0 my ($lo, $hi) = unpack 'LL', $time; # unpack FILETIME struct
5046             # FILETIME is in 100 ns intervals since 0:00 UTC Jan 1, 1601
5047             # (89 leap years between 1601 and 1970)
5048 0         0 $time = ($hi * 4294967296 + $lo) * 1e-7 - (((1970-1601)*365+89)*24*3600);
5049             }
5050 0         0 return ($atime, $mtime, $ctime);
5051             }
5052             }
5053             # other os (or Windows fallback)
5054 0         0 return (stat $file)[8, 9, 10];
5055             }
5056              
5057             #------------------------------------------------------------------------------
5058             # Parse function arguments and set member variables accordingly
5059             # Inputs: Same as ImageInfo()
5060             # - sets REQUESTED_TAGS, REQ_TAG_LOOKUP, IO_TAG_LIST, FILENAME, RAF, OPTIONS
5061             sub ParseArguments($;@)
5062             {
5063 725     725 0 1176 my $self = shift;
5064 725         1471 my $options = $$self{OPTIONS};
5065 725         1202 my @oldGroupOpts = grep /^Group/, keys %{$$self{OPTIONS}};
  725         15546  
5066 725         3314 my (@exclude, $wasExcludeOpt);
5067              
5068 725         2075 $$self{REQUESTED_TAGS} = [ ];
5069 725 100       3057 $$self{REQ_TAG_LOOKUP} = { } unless $$self{ReqTagAlreadySet};
5070 725         1762 $$self{EXCL_TAG_LOOKUP} = { };
5071 725         1566 $$self{IO_TAG_LIST} = undef;
5072 725         1457 delete $$self{EXCL_XMP_LOOKUP};
5073              
5074             # handle our input arguments
5075 725         1922 while (@_) {
5076 1591         2321 my $arg = shift;
5077 1591 100 66     5382 if (ref $arg and not overload::Method($arg, q[""])) {
    100          
5078 171 100 100     4541 if (ref $arg eq 'ARRAY') {
    100          
    100          
    50          
5079 10         24 $$self{IO_TAG_LIST} = $arg;
5080 10         28 foreach (@$arg) {
5081 91 100       132 if (/^-(.*)/) {
5082 2         6 push @exclude, $1;
5083             } else {
5084 89         88 push @{$$self{REQUESTED_TAGS}}, $_;
  89         182  
5085             }
5086             }
5087             } elsif (ref $arg eq 'HASH') {
5088 116         233 my $opt;
5089 116         348 foreach $opt (keys %$arg) {
5090             # a single new group option overrides all old group options
5091 189 100 100     980 if (@oldGroupOpts and $opt =~ /^Group/) {
5092 28         63 foreach (@oldGroupOpts) {
5093 28         75 delete $$options{$_};
5094             }
5095 28         68 undef @oldGroupOpts;
5096             }
5097 189         669 $self->Options($opt, $$arg{$opt});
5098 189 50       574 $opt eq 'Exclude' and $wasExcludeOpt = 1;
5099             }
5100             } elsif (ref $arg eq 'SCALAR' or UNIVERSAL::isa($arg,'GLOB')) {
5101 26 50       103 next if defined $$self{RAF};
5102             # convert image data from UTF-8 to character stream if necessary
5103             # (patches RHEL 3 UTF8 LANG problem)
5104 26 50 66     252 if (ref $arg eq 'SCALAR' and $] >= 5.006 and ($$self{OPTIONS}{EncodeHangs} or
      33        
      66        
5105             eval { require Encode; Encode::is_utf8($$arg) } or $@))
5106             {
5107 0         0 local $SIG{'__WARN__'} = \&SetWarning;
5108             # repack by hand if Encode isn't available
5109 0 0 0     0 my $buff = ($$self{OPTIONS}{EncodeHangs} or $@) ? pack('C*',unpack($] < 5.010000 ?
    0          
5110             'U0C*' : 'C0C*', $$arg)) : Encode::encode('utf8', $$arg);
5111 0         0 $arg = \$buff;
5112             }
5113 26         181 $$self{RAF} = File::RandomAccess->new($arg);
5114             # set filename to empty string to indicate that
5115             # we have a file but we didn't open it
5116 26         85 $$self{FILENAME} = '';
5117             } elsif (UNIVERSAL::isa($arg, 'File::RandomAccess')) {
5118 19         43 $$self{RAF} = $arg;
5119 19         55 $$self{FILENAME} = '';
5120             } else {
5121 0         0 warn "Don't understand ImageInfo argument $arg\n";
5122             }
5123             } elsif (defined $$self{FILENAME}) {
5124 915 100       1777 if ($arg =~ /^-(.*)/) {
5125 58         251 push @exclude, $1;
5126             } else {
5127 857         940 push @{$$self{REQUESTED_TAGS}}, $arg;
  857         2115  
5128             }
5129             } else {
5130 505         1353 $$self{FILENAME} = $arg;
5131             }
5132             }
5133             # add additional requested tags to lookup
5134 725 100       1973 if ($$options{RequestTags}) {
5135 46         86 $$self{REQ_TAG_LOOKUP}{$_} = 1 foreach @{$$options{RequestTags}};
  46         296  
5136             }
5137             # expand shortcuts in tag arguments if provided
5138 725 100       1015 if (@{$$self{REQUESTED_TAGS}}) {
  725         2102  
5139 367         1591 ExpandShortcuts($$self{REQUESTED_TAGS});
5140             # initialize lookup for requested tags
5141 367         550 foreach (@{$$self{REQUESTED_TAGS}}) {
  367         916  
5142 989 50       3571 /^(.*:)?([-\w?*]*)#?$/ or next;
5143 989 50       3658 $$self{REQ_TAG_LOOKUP}{lc($2)} = 1 if $2;
5144 989 100       2087 next unless $1;
5145 255         1126 $$self{REQ_TAG_LOOKUP}{lc($_).':'} = 1 foreach split /:/, $1;
5146             }
5147             }
5148 725 100 66     3278 if (@exclude or $wasExcludeOpt) {
5149             # must add existing excluded tags
5150 45 100       228 push @exclude, @{$$options{Exclude}} if $$options{Exclude};
  1         2  
5151 45         115 $$options{Exclude} = \@exclude;
5152             # expand shortcuts in new exclude list
5153 45         182 ExpandShortcuts($$options{Exclude}, 1); # (also remove '#' suffix)
5154             }
5155             # generate lookup for excluded tags
5156 725 100       2310 if ($$options{Exclude}) {
5157 52         91 foreach (@{$$options{Exclude}}) {
  52         139  
5158 69 100       554 /([-\w]+)#?$/ and $$self{EXCL_TAG_LOOKUP}{lc $1} = 1;
5159 69 50       272 if (/(xmp-.*:[-\w]+)#?/i) {
5160 0 0       0 $$self{EXCL_XMP_LOOKUP} or $$self{EXCL_XMP_LOOKUP} = { };
5161 0         0 $$self{EXCL_XMP_LOOKUP}{lc $1} = 1;
5162             }
5163             }
5164             # exclude list is used only for EXCL_TAG_LOOKUP when TAGS_FROM_FILE is set
5165 52 100       207 undef $$options{Exclude} if $$self{TAGS_FROM_FILE};
5166             }
5167             }
5168              
5169             #------------------------------------------------------------------------------
5170             # Does group name match the tag ID?
5171             # Inputs: 0) tag ID, 1) group name (with "ID-" removed)
5172             # Returns: true on success
5173             sub IsSameID($$)
5174             {
5175 2     2 0 6 my ($id, $grp) = @_;
5176 2         3 for (;;) {
5177 2 100       8 return 1 if $grp eq $id; # decimal ID's or raw ID's
5178 1 50       5 if ($id =~ /^\d+$/) { # numerical numerical ID's may be in hex
5179 0 0 0     0 return 1 if $grp =~ s/^0x0*// and $grp eq sprintf('%x', $id);
5180             } else { # other ID's may conform to ExifTool group name conventions
5181 1         4 my $tmp = $id;
5182 1 50 33     6 return 1 if $tmp =~ s/([^-_A-Za-z0-9])/sprintf('%.2x',ord $1)/ge and $grp eq $tmp;
  1         13  
5183             }
5184 1 50       5 last unless $id =~ s/-.*//; # remove language code if it exists
5185             }
5186 1         16 return 0;
5187             }
5188              
5189             #------------------------------------------------------------------------------
5190             # Get list of tags in specified group
5191             # Inputs: 0) ExifTool ref, 1) group spec (case insensitive), 2) tag key or reference to list of tag keys
5192             # Returns: list of matching tags in list context, or first match in scalar context
5193             # Notes: Group spec may contain multiple groups separated by colons, each
5194             # possibly with a leading family number
5195             sub GroupMatches($$$)
5196             {
5197 28417     28417 0 35541 my ($self, $group, $tagList) = @_;
5198 28417 50       36842 $tagList = [ $tagList ] unless ref $tagList;
5199 28417         28211 my ($tag, @matches);
5200             # check each group name individually (eg. "Author:1IPTC")
5201 28417         41350 my @grps = split ':', $group;
5202 28417         29153 my (@fmys, $g);
5203 28417         40518 for ($g=0; $g<@grps; ++$g) {
5204 29008 50       73990 if ($grps[$g] =~ s/^(\d*)(id-)?//i) {
5205 29008 100       43138 $fmys[$g] = $1 if length $1;
5206 29008 50       42073 if ($2) {
5207 0         0 $fmys[$g] = 7;
5208 0         0 next; # (don't convert tag ID's to lower case)
5209             }
5210             }
5211 29008         37708 $grps[$g] = lc $grps[$g];
5212 29008 50       54362 $grps[$g] = '' if $grps[$g] eq 'copy0'; # accept 'Copy0' for primary tag
5213             }
5214 28417         34268 foreach $tag (@$tagList) {
5215 18486         29381 my @groups = $self->GetGroup($tag, -1);
5216 18486         27476 for ($g=0; $g<@grps; ++$g) {
5217 18951         21235 my $grp = $grps[$g];
5218 18951 50 33     39389 next if $grp eq '*' or $grp eq 'all';
5219 18951         17822 my $f;
5220 18951 100       23761 if (defined($f = $fmys[$g])) {
5221 3 50       5 last unless defined $groups[$f];
5222 3 50       5 if ($f == 7) {
5223 0 0       0 next if IsSameID($self->GetTagID($tag), $grp);
5224             } else {
5225 3 100       7 next if $grp eq lc $groups[$f];
5226             }
5227 1         2 last;
5228             } else {
5229 18948 100       157091 last unless grep /^$grp$/i, @groups;
5230             }
5231             }
5232 18486 100       34553 if ($g == @grps) {
5233 4729 100       10677 return $tag unless wantarray;
5234 2567         4724 push @matches, $tag;
5235             }
5236             }
5237 26255 100       45484 return wantarray ? @matches : $matches[0];
5238             }
5239              
5240             #------------------------------------------------------------------------------
5241             # Remove specified tags from returned tag list, updating indices in other lists
5242             # Inputs: 0) tag list ref, 1) index list ref, 2) index list ref, 3) hash ref,
5243             # 4) true to include tags from hash instead of excluding
5244             # Returns: nothing, but updates input lists
5245             sub RemoveTagsFromList($$$$;$)
5246             {
5247 73     73 0 104 local $_;
5248 73         202 my ($tags, $list1, $list2, $exclude, $inv) = @_;
5249 73         134 my @filteredTags;
5250              
5251 73 100 100     329 if (@$list1 or @$list2) {
5252 6         26 while (@$tags) {
5253 229         244 my $tag = pop @$tags;
5254 229         235 my $i = @$tags;
5255 229 100 50     430 if ($$exclude{$tag} xor $inv) {
5256             # remove index of excluded tag from each list
5257 150 100       160 @$list1 = map { $_ < $i ? $_ : $_ == $i ? () : $_ - 1 } @$list1;
  12 100       22  
5258 150 100       173 @$list2 = map { $_ < $i ? $_ : $_ == $i ? () : $_ - 1 } @$list2;
  8211 100       8954  
5259             } else {
5260 79         136 unshift @filteredTags, $tag;
5261             }
5262             }
5263             } else {
5264 67         130 foreach (@$tags) {
5265 6950 100 100     14320 push @filteredTags, $_ unless $$exclude{$_} xor $inv;
5266             }
5267             }
5268 73         406 $_[0] = \@filteredTags; # update tag list
5269             }
5270              
5271             #------------------------------------------------------------------------------
5272             # Copy tags from alternate input file
5273             # Inputs: 0) ExifTool ref, 1) family 8 group, 2) list ref for tag keys to copy
5274             # - updates tag key list to match keys newly added to $self
5275             sub CopyAltInfo($$$)
5276             {
5277 8     8 0 17 my ($self, $g8, $tags) = @_;
5278 8         11 my ($tag, $vtag);
5279 8 50       35 return unless $g8 =~ /(\d+)/;
5280 8 50       25 my $et = $$self{ALT_EXIFTOOL}{$g8} or return;
5281 8         22 my $altOrder = ($1 + 1) * 100000; # increment file order
5282 8         16 foreach $tag (@$tags) {
5283 9         49 ($vtag = $tag) =~ s/( |$)/ #[$g8]/;
5284 9 100       26 unless (defined $$self{VALUE}{$vtag}) {
5285 8         23 $$self{VALUE}{$vtag} = $$et{VALUE}{$tag};
5286 8         19 $$self{TAG_INFO}{$vtag} = $$et{TAG_INFO}{$tag};
5287 8   50     22 $$self{TAG_EXTRA}{$vtag} = $$et{TAG_EXTRA}{$tag} || { };
5288 8   50     23 $$self{FILE_ORDER}{$vtag} = ($$et{FILE_ORDER}{$tag} || 0) + $altOrder;
5289             }
5290 9         23 $tag = $vtag;
5291             }
5292             }
5293              
5294             #------------------------------------------------------------------------------
5295             # Set list of found tags from previously requested tags
5296             # Inputs: 0) ExifTool object reference
5297             # Returns: 0) Reference to list of found tag keys (in order of requested tags)
5298             # 1) Reference to list of indices for tags requested by value
5299             # 2) Reference to list of indices for tags specified by wildcard or "all"
5300             # Notes: index lists are returned in increasing order
5301             sub SetFoundTags($)
5302             {
5303 720     720 0 1048 local $_;
5304 720         1116 my $self = shift;
5305 720         1664 my $options = $$self{OPTIONS};
5306 720   50     2133 my $reqTags = $$self{REQUESTED_TAGS} || [ ];
5307 720         1516 my $duplicates = $$options{Duplicates};
5308 720         1307 my $exclude = $$options{Exclude};
5309 720         1238 my $fileOrder = $$self{FILE_ORDER};
5310 720         1045 my @groupOptions;
5311             # ignore empty group options
5312 720   100     26361 $$options{$_} and push @groupOptions, $_ foreach sort grep /^Group/, keys %$options;
5313 720   100     4909 my $doDups = $duplicates || $exclude || @groupOptions;
5314 720         1670 my ($tag, $rtnTags, @byValue, @wildTags);
5315              
5316             # only return requested tags if specified
5317 720 100       1769 if (@$reqTags) {
5318 367 50       1043 $rtnTags or $rtnTags = [ ];
5319             # scan through the requested tags and generate a list of tags we found
5320 367         719 my $tagHash = $$self{VALUE};
5321 367         569 my $reqTag;
5322 367         796 foreach $reqTag (@$reqTags) {
5323 989         1643 my (@matches, $group, $allGrp, $allTag, $byValue, $g8);
5324 989         1269 my $et = $self;
5325 989 100       2524 if ($reqTag =~ /^(.*):(.+)/) {
5326 255         930 ($group, $tag) = ($1, $2);
5327 255 50       1823 if ($group =~ /^(\*|all)$/i) {
    100          
    50          
5328 0         0 $allGrp = 1;
5329             } elsif ($reqTag =~ /\bfile(\d+):/i) {
5330 6         14 $g8 = "File$1";
5331 6   33     18 $et = $$self{ALT_EXIFTOOL}{$g8} || $self;
5332 6         11 $fileOrder = $$et{FILE_ORDER};
5333 6         8 $tagHash = $$et{VALUE};
5334             } elsif ($group !~ /^[-\w:]*$/) {
5335 0         0 $self->Warn("Invalid group name '${group}'");
5336 0         0 $group = 'invalid';
5337             }
5338             } else {
5339 734         1003 $tag = $reqTag;
5340             }
5341 989 50 66     2270 $byValue = 1 if $tag =~ s/#$// and $$options{PrintConv};
5342 989 100 100     6190 if (defined $$tagHash{$reqTag} and not $doDups) {
    100 100        
    100          
    100          
    50          
5343 6         7 $matches[0] = $tag;
5344             } elsif ($tag =~ /^(\*|all)$/i) {
5345             # tag name of '*' or 'all' matches all tags
5346 164 100 66     589 if ($doDups or $allGrp) {
5347 163         5003 @matches = grep(!/#/, keys %$tagHash);
5348             } else {
5349 1         33 @matches = grep(!/ /, keys %$tagHash);
5350             }
5351 164 50       800 next unless @matches; # don't want entry in list for '*' tag
5352 164         264 $allTag = 1;
5353             } elsif ($tag =~ /[*?]/) {
5354             # allow wildcards in tag names
5355 9         20 $tag =~ tr/-_A-Za-z0-9*?//dc; # sterilize
5356 9         27 $tag =~ s/\*/[-\\w]*/g;
5357 9         21 $tag =~ s/\?/[-\\w]/g;
5358 9 50 33     38 $tag .= '( \\(.*)?' if $doDups or $allGrp;
5359 9         1846 @matches = grep(/^$tag$/i, keys %$tagHash);
5360 9 50       62 next unless @matches; # don't want entry in list for wildcard tags
5361 9         17 $allTag = 1;
5362             } elsif ($doDups or defined $group) {
5363 748         1375 $tag =~ tr/-_A-Za-z0-9//dc; # sterilize
5364             # must also look for tags like "Tag (1)"
5365             # (but be sure not to match temporary ValueConv entries like "Tag #")
5366 748         51771 @matches = grep(/^$tag( \(|$)/i, keys %$tagHash);
5367             } elsif ($tag =~ /^[-\w]+$/) {
5368             # find first matching value
5369             # (use in list context to return value instead of count)
5370 62         1206 ($matches[0]) = grep /^$tag$/i, keys %$tagHash;
5371 62 50       216 defined $matches[0] or undef @matches;
5372             } else {
5373 0         0 $self->Warn("Invalid tag name '${tag}'");
5374             }
5375 989 100 66     4519 if (defined $group and not $allGrp) {
5376             # keep only specified group
5377 255         691 @matches = $et->GroupMatches($group, \@matches);
5378 255 100 100     889 next unless @matches or not $allTag;
5379             }
5380 969 100       2446 if (@matches > 1) {
    100          
5381             # maintain original file order for multiple tags
5382 162         889 @matches = sort { $$fileOrder{$a} <=> $$fileOrder{$b} } @matches;
  8245         9398  
5383             # return only the highest priority tag unless duplicates wanted
5384 162 50 66     560 unless ($doDups or $allTag or $allGrp) {
      33        
5385 0         0 $tag = shift @matches;
5386 0   0     0 my $oldPriority = $$et{PRIORITY}{$tag} || 1;
5387 0         0 foreach (@matches) {
5388 0         0 my $priority = $$et{PRIORITY}{$_};
5389 0 0       0 $priority = 1 unless defined $priority;
5390 0 0       0 next unless $priority >= $oldPriority;
5391 0         0 $tag = $_;
5392 0   0     0 $oldPriority = $priority || 1;
5393             }
5394 0         0 @matches = ( $tag );
5395             }
5396             } elsif (not @matches) {
5397             # put entry in return list even without value (value is undef)
5398 532 100       1400 $matches[0] = $byValue ? "$tag #(0)" : "$tag (0)";
5399             # bogus file order entry to avoid warning if sorting in file order
5400 532         1364 $$self{FILE_ORDER}{$matches[0]} = 9999;
5401             }
5402             # copy over necessary information for tags from alternate files
5403 969 100       1701 if ($g8) {
5404 6         19 $self->CopyAltInfo($g8, \@matches);
5405             # restore variables to original values for main file
5406 6         28 $fileOrder = $$self{FILE_ORDER};
5407 6         9 $tagHash = $$self{VALUE};
5408             }
5409             # save indices of tags extracted by value
5410 969 100       1836 push @byValue, scalar(@$rtnTags) .. (scalar(@$rtnTags)+scalar(@matches)-1) if $byValue;
5411             # save indices of wildcard tags
5412 969 100       2201 push @wildTags, scalar(@$rtnTags) .. (scalar(@$rtnTags)+scalar(@matches)-1) if $allTag;
5413 969         2939 push @$rtnTags, @matches;
5414             }
5415             } else {
5416             # no requested tags, so we want all tags
5417 353         510 my @allTags;
5418 353 50       857 if ($doDups) {
5419 353         594 @allTags = keys %{$$self{VALUE}};
  353         9821  
5420             } else {
5421             # only include tag if it doesn't end in a copy number
5422 0         0 @allTags = grep(!/ /, keys %{$$self{VALUE}});
  0         0  
5423             }
5424 353         965 $rtnTags = \@allTags;
5425             }
5426              
5427             # filter excluded tags and group options
5428 720   100     3983 while (($exclude or @groupOptions) and @$rtnTags) {
      66        
5429 72 100       1491 if ($exclude) {
5430 45         130 my ($pat, %exclude);
5431 45         102 foreach $pat (@$exclude) {
5432 61         92 my $group;
5433 61 100       265 if ($pat =~ /^(.*):(.+)/) {
5434 34         146 ($group, $tag) = ($1, $2);
5435 34 50       258 if ($group =~ /^(\*|all)$/i) {
    50          
5436 0         0 undef $group;
5437             } elsif ($group !~ /^[-\w:]*$/) {
5438 0         0 $self->Warn("Invalid group name '${group}'");
5439 0         0 $group = 'invalid';
5440             }
5441             } else {
5442 27         40 $tag = $pat;
5443             }
5444 61         110 my @matches;
5445 61 100       223 if ($tag =~ /^(\*|all)$/i) {
5446 34         185 @matches = @$rtnTags;
5447             } else {
5448             # allow wildcards in tag names
5449 27         49 $tag =~ s/\*/[-\\w]*/g;
5450 27         42 $tag =~ s/\?/[-\\w]/g;
5451 27         2735 @matches = grep(/^$tag( |$)/i, @$rtnTags);
5452             }
5453 61 100 66     348 @matches = $self->GroupMatches($group, \@matches) if $group and @matches;
5454 61         428 $exclude{$_} = 1 foreach @matches;
5455             }
5456 45 50       132 if (%exclude) {
5457             # remove excluded tags from return list(s)
5458 45         185 RemoveTagsFromList($rtnTags, \@byValue, \@wildTags, \%exclude);
5459 45 50       141 last unless @$rtnTags; # all done if nothing left
5460             }
5461 45 100 66     262 last if $duplicates and not @groupOptions;
5462             }
5463             # filter groups if requested, or to remove duplicates
5464 28         52 my (%keepTags, %wantGroup, $family, $groupOpt);
5465 28         47 my $allGroups = 1;
5466             # build hash of requested/excluded group names for each group family
5467 28         58 my $wantOrder = 0;
5468 28         57 foreach $groupOpt (@groupOptions) {
5469 29 50       156 $groupOpt =~ /^Group(\d*(:\d+)*)/ or next;
5470 29   100     118 $family = $1 || 0;
5471 29 50       118 $wantGroup{$family} or $wantGroup{$family} = { };
5472 29         37 my $groupList;
5473 29 100       88 if (ref $$options{$groupOpt} eq 'ARRAY') {
5474 4         10 $groupList = $$options{$groupOpt};
5475             } else {
5476 25         70 $groupList = [ $$options{$groupOpt} ];
5477             }
5478 29         53 foreach (@$groupList) {
5479             # groups have priority in order they were specified
5480 33         47 ++$wantOrder;
5481 33         56 my ($groupName, $want);
5482 33 100       81 if (/^-(.*)/) {
5483             # excluded group begins with '-'
5484 2         4 $groupName = $1;
5485 2         3 $want = 0; # we don't want tags in this group
5486             } else {
5487 31         68 $groupName = $_;
5488 31         44 $want = $wantOrder; # we want tags in this group
5489 31         45 $allGroups = 0; # don't want all groups if we requested one
5490             }
5491 33         109 $wantGroup{$family}{$groupName} = $want;
5492             }
5493             }
5494             # loop through all tags and decide which ones we want
5495 28         36 my (@tags, %bestTag);
5496 28         35 GR_TAG: foreach $tag (@$rtnTags) {
5497 4505         4134 my $wantTag = $allGroups; # want tag by default if want all groups
5498 4505         5221 foreach $family (keys %wantGroup) {
5499 4676         5627 my $group = $self->GetGroup($tag, $family);
5500 4676         5750 my $wanted = $wantGroup{$family}{$group};
5501 4676 100       6342 next unless defined $wanted;
5502 1212 100       1538 next GR_TAG unless $wanted; # skip tag if group excluded
5503             # take lowest non-zero want flag
5504 1035 50 33     1422 next if $wantTag and $wantTag < $wanted;
5505 1035         1051 $wantTag = $wanted;
5506             }
5507 4328 100       5850 next unless $wantTag;
5508 1047 100       1491 $duplicates and $keepTags{$tag} = 1, next;
5509             # determine which tag we want to keep
5510 665         691 my $tagName = GetTagName($tag);
5511 665         736 my $bestTag = $bestTag{$tagName};
5512 665 100       841 if (defined $bestTag) {
5513 28 100       59 next if $wantTag > $keepTags{$bestTag};
5514 14 50       27 if ($wantTag == $keepTags{$bestTag}) {
5515             # want two tags with the same name -- keep the latest one
5516 0 0       0 if ($tag =~ / \((\d+)\)$/) {
5517 0         0 my $tagNum = $1;
5518 0 0 0     0 next if $bestTag !~ / \((\d+)\)$/ or $1 > $tagNum;
5519             }
5520             }
5521             # this tag is better, so delete old best tag
5522 14         16 delete $keepTags{$bestTag};
5523             }
5524 651         785 $keepTags{$tag} = $wantTag; # keep this tag (for now...)
5525 651         814 $bestTag{$tagName} = $tag; # this is our current best tag
5526             }
5527             # include only tags we want to keep in return lists
5528 28         126 RemoveTagsFromList($rtnTags, \@byValue, \@wildTags, \%keepTags, 1);
5529 28         199 last;
5530             }
5531 720         2003 $$self{FOUND_TAGS} = $rtnTags; # save found tags
5532              
5533             # return reference to found tag keys (and list of indices of tags to extract by value)
5534 720 100       3700 return wantarray ? ($rtnTags, \@byValue, \@wildTags) : $rtnTags;
5535             }
5536              
5537             #------------------------------------------------------------------------------
5538             # Utility to load our write routines if required (called via AUTOLOAD)
5539             # Inputs: 0) autoload function, 1-N) function arguments
5540             # Returns: result of function or dies if function not available
5541             sub DoAutoLoad(@)
5542             {
5543 763     763 0 1775 my $autoload = shift;
5544 763         3471 my @callInfo = split(/::/, $autoload);
5545 763         1637 my $file = 'Image/ExifTool/Write';
5546              
5547 763 100       150062 return if $callInfo[$#callInfo] eq 'DESTROY';
5548 255 100       893 if (@callInfo == 4) {
    100          
5549             # load Image/ExifTool/WriteMODULE.pl
5550 193         777 $file .= "$callInfo[2].pl";
5551             } elsif ($callInfo[-1] eq 'ShiftTime') {
5552 1         3 $file = 'Image/ExifTool/Shift.pl'; # load Shift.pl
5553             } else {
5554             # load Image/ExifTool/Writer.pl
5555 61         154 $file .= 'r.pl';
5556             }
5557             # attempt to load the package
5558 255 50       543 eval { require $file } or die "Error while attempting to call $autoload\n$@\n";
  255         243848  
5559 255 50       1746 unless (defined &$autoload) {
5560 0         0 my @caller = caller(0);
5561             # reproduce Perl's standard 'undefined subroutine' message:
5562 0         0 die "Undefined subroutine $autoload called at $caller[1] line $caller[2]\n";
5563             }
5564 113     113   1152 no strict 'refs';
  113         201  
  113         144803  
5565 255         1207 return &$autoload(@_); # call the function
5566             }
5567              
5568             #------------------------------------------------------------------------------
5569             # AutoLoad our writer routines when necessary
5570             #
5571             sub AUTOLOAD
5572             {
5573 570     570   277499 return DoAutoLoad($AUTOLOAD, @_);
5574             }
5575              
5576             #------------------------------------------------------------------------------
5577             # Add cleanup routine to call before returning from Extract
5578             # Inputs: 0) ExifTool ref, 1) code ref to routine with ExifTool ref as an argument
5579             sub AddCleanup($)
5580             {
5581 0     0 0 0 my ($self, $sub) = @_;
5582 0 0       0 $$self{Cleanup} or $$self{Cleanup} = [ ];
5583 0         0 push @{$$self{Cleanup}}, $sub;
  0         0  
5584             }
5585              
5586             #------------------------------------------------------------------------------
5587             # Add warning tag
5588             # Inputs: 0) ExifTool object reference, 1) warning message
5589             # 2) 0=normal warning, 1=minor, 2=minor with behavioural change when
5590             # ignored, 3=warning shouldn't be issued with Validate option,
5591             # bit 0x04 set causes warning count to not be incremented
5592             # Returns: true if warning tag was added
5593             sub Warn($$;$)
5594             {
5595 95     95 0 252 my ($self, $str, $ignorable) = @_;
5596 95         254 my $noWarn = $$self{OPTIONS}{NoWarning};
5597 95         136 my $noCount;
5598 95         330 while ($ignorable) {
5599 40 100       120 if ($ignorable & 0x04) {
5600 1         2 $noCount = 1;
5601 1 50       2 $ignorable &= 0x03 or last;
5602             }
5603 40         61 my $ignorable = $ignorable & 0x03;
5604 40 100       104 return 0 if $$self{OPTIONS}{IgnoreMinorErrors};
5605 39 50 66     106 return 0 if $ignorable eq '3' and $$self{OPTIONS}{Validate};
5606 39 50 33     121 return 1 if defined $noWarn and eval { $str =~ /$noWarn/ };
  0         0  
5607 39 100       130 $str = $ignorable eq '2' ? "[Minor] $str" : "[minor] $str";
5608 39         62 last;
5609             }
5610 94 50 33     307 unless (defined $noWarn and eval { $str =~ /$noWarn/ }) {
  0         0  
5611             # add each warning only once but count number of occurrences
5612 94 100       264 if ($$self{WAS_WARNED}{$str}) {
5613 10 50       27 ++$$self{WAS_WARNED}{$str} unless $noCount;
5614             } else {
5615 84         351 $self->FoundTag('Warning', $str);
5616 84         250 $$self{WAS_WARNED}{$str} = 1;
5617             }
5618             }
5619 94         270 return 1;
5620             }
5621              
5622             #------------------------------------------------------------------------------
5623             # Add error tag
5624             # Inputs: 0) ExifTool object reference, 1) error message, 2) true if minor
5625             # Returns: true if error tag was added, otherwise warning was added
5626             sub Error($$;$)
5627             {
5628 4     4 0 11 my ($self, $str, $ignorable) = @_;
5629 4 50       17 if ($$self{DemoteErrors}) {
    100          
5630 0 0       0 $self->Warn($str) and ++$$self{DemoteErrors};
5631 0         0 return 1;
5632             } elsif ($ignorable) {
5633 1 50       7 $$self{OPTIONS}{IgnoreMinorErrors} and $self->Warn($str), return 0;
5634 0         0 $str = "[minor] $str";
5635             }
5636 3         13 $self->FoundTag('Error', $str);
5637 3         7 return 1;
5638             }
5639              
5640             #------------------------------------------------------------------------------
5641             # Expand shortcuts
5642             # Inputs: 0) reference to list of tags, 1) set to remove trailing '#'
5643             # Notes: Handles leading '-' for excluded tags, trailing '#' for ValueConv,
5644             # multiple group names, and redirected tags
5645             sub ExpandShortcuts($;$)
5646             {
5647 528     528 0 1220 my ($tagList, $removeSuffix) = @_;
5648 528 50 33     2749 return unless $tagList and @$tagList;
5649              
5650 528         29175 require Image::ExifTool::Shortcuts;
5651              
5652             # expand shortcuts
5653 528 100       1326 my $suffix = $removeSuffix ? '' : '#';
5654 528         744 my @expandedTags;
5655 528         938 my ($entry, $tag, $excl);
5656 528         1021 foreach $entry (@$tagList) {
5657             # skip things like options hash references in list
5658 1174 100       2116 if (ref $entry) {
5659 1         4 push @expandedTags, $entry;
5660 1         2 next;
5661             }
5662             # remove leading '-'
5663 1173         4602 ($excl, $tag) = $entry =~ /^(-?)(.*)/s;
5664 1173         1759 my ($post, @post, $pre, $v);
5665             # handle redirection
5666 1173 100 100     9766 if (not $excl and $tag =~ /(.+?)([-+]?[<>].+)/s) {
5667 31         96 ($tag, $post) = ($1, $2);
5668 31 100 100     177 if ($post =~ /^[-+]?>/ or $post !~ /\$/) {
5669             # expand shortcuts in postfix (rhs of redirection)
5670 23         114 my ($op, $p2, $t2) = ($post =~ /([-+]?[<>])(.+:)?(.+)/);
5671 23 100       64 $p2 = '' unless defined $p2;
5672 23 50       69 $v = ($t2 =~ s/#$//) ? $suffix : ''; # ValueConv suffix
5673 23         491 my ($match) = grep /^\Q$t2\E$/i, keys %Image::ExifTool::Shortcuts::Main;
5674 23 50       85 if ($match) {
5675 0         0 foreach (@{$Image::ExifTool::Shortcuts::Main{$match}}) {
  0         0  
5676 0 0       0 /^-/ and next; # ignore excluded tags
5677 0 0 0     0 if ($p2 and /(.+:)(.+)/) {
5678 0         0 push @post, "$op$_$v";
5679             } else {
5680 0         0 push @post, "$op$p2$_$v";
5681             }
5682             }
5683 0 0       0 next unless @post;
5684 0         0 $post = shift @post;
5685             }
5686             }
5687             } else {
5688 1142         1649 $post = '';
5689             }
5690             # handle group names
5691 1173 100       2685 if ($tag =~ /(.+:)(.+)/) {
5692 328         988 ($pre, $tag) = ($1, $2);
5693             } else {
5694 845         1048 $pre = '';
5695             }
5696 1173 100       2205 $v = ($tag =~ s/#$//) ? $suffix : ''; # ValueConv suffix
5697             # loop over all postfixes
5698 1173         1317 for (;;) {
5699             # expand the tag name
5700 1173         23285 my ($match) = grep /^\Q$tag\E$/i, keys %Image::ExifTool::Shortcuts::Main;
5701 1173 100       2633 if ($match) {
5702 17 50 66     126 if ($excl) {
    100 66        
5703             # entry starts with '-', so exclude all tags in this shortcut
5704 0         0 foreach (@{$Image::ExifTool::Shortcuts::Main{$match}}) {
  0         0  
5705 0 0       0 /^-/ and next; # ignore excluded exclude tags
5706             # group of expanded tag takes precedence
5707 0 0 0     0 if ($pre and /(.+:)(.+)/) {
5708 0         0 push @expandedTags, "$excl$_";
5709             } else {
5710 0         0 push @expandedTags, "$excl$pre$_";
5711             }
5712             }
5713             } elsif (length $pre or length $post or $v) {
5714 1         4 foreach (@{$Image::ExifTool::Shortcuts::Main{$match}}) {
  1         4  
5715 12         25 /(-?)(.+:)?(.+)/;
5716 12 50       16 if ($2) {
5717             # group from expanded tag takes precedence
5718 0         0 push @expandedTags, "$_$v$post";
5719             } else {
5720 12         27 push @expandedTags, "$1$pre$3$v$post";
5721             }
5722             }
5723             } else {
5724 16         24 push @expandedTags, @{$Image::ExifTool::Shortcuts::Main{$match}};
  16         47  
5725             }
5726             } else {
5727 1156         2517 push @expandedTags, "$excl$pre$tag$v$post";
5728             }
5729 1173 50       2872 last unless @post;
5730 0         0 $post = shift @post;
5731             }
5732             }
5733 528         1676 @$tagList = @expandedTags;
5734             }
5735              
5736             #------------------------------------------------------------------------------
5737             # Add hash of Composite tags to our composites
5738             # Inputs: 0) hash reference to table of Composite tags to add or module name,
5739             # 1) override existing tag definition
5740             sub AddCompositeTags($;$)
5741             {
5742 637     637 0 1648 local $_;
5743 637         1872 my ($add, $override) = @_;
5744 637         1364 my ($module, $prefix, $tagID);
5745 637 50       2429 unless (ref $add) {
5746 637         5941 ($prefix = $add) =~ s/.*:://;
5747 637         1328 $module = $add;
5748 637         1712 $add .= '::Composite';
5749 113     113   867 no strict 'refs';
  113         244  
  113         1055318  
5750 637         3196 $add = \%$add;
5751 637         1327 $prefix .= '-';
5752             } else {
5753 0         0 $prefix = 'UserDefined-';
5754             }
5755 637         1648 my $defaultGroups = $$add{GROUPS};
5756 637         2720 my $compTable = GetTagTable('Image::ExifTool::Composite');
5757              
5758             # make sure default groups are defined in families 0 and 1
5759 637 100       1525 if ($defaultGroups) {
5760 525 100       1837 $$defaultGroups{0} or $$defaultGroups{0} = 'Composite';
5761 525 100       1462 $$defaultGroups{1} or $$defaultGroups{1} = 'Composite';
5762 525 50       1324 $$defaultGroups{2} or $$defaultGroups{2} = 'Other';
5763             } else {
5764 112         601 $defaultGroups = $$add{GROUPS} = { 0 => 'Composite', 1 => 'Composite', 2 => 'Other' };
5765             }
5766 637         2005 SetupTagTable($add); # generate Name, TagID, etc
5767 637         4706 foreach $tagID (sort keys %$add) {
5768 6301 100       9847 next if $specialTags{$tagID}; # must skip special tags
5769 5661         6479 my $tagInfo = $$add{$tagID};
5770 5661         7476 my $new = $prefix . $tagID; # new tag ID for Composite table
5771 5661 100       8903 $$tagInfo{Module} = $module if $$tagInfo{Writable};
5772 5661 50 33     8650 $$tagInfo{Override} = 1 if $override and not defined $$tagInfo{Override};
5773 5661         8077 $$tagInfo{IsComposite} = 1;
5774             # handle Composite tags with the same name
5775 5661 100       9106 if ($compositeID{$tagID}) {
5776             # determine if we want to override this tag
5777             # (=0 keep both, >0 override, <0 keep existing)
5778 364   50     2801 my $over = ($$tagInfo{Override} || 0) - ($$compTable{$compositeID{$tagID}[0]}{Override} || 0);
      50        
5779 364 50       818 next if $over < 0;
5780 364 50       836 if ($over) {
5781             # remove existing tags with this ID
5782 0         0 delete $$compTable{$_} foreach @{$compositeID{$tagID}};
  0         0  
5783 0         0 delete $compositeID{$tagID};
5784             }
5785             }
5786             # make sure new TagID is unique by adding index if necessary
5787             # (could only happen for UserDefined tags now that module name is added to tag ID)
5788 5661         6187 my $n = 0;
5789 5661         9742 while ($$compTable{$new}) {
5790 0 0       0 $new =~ s/-\d+$// if $n++;
5791 0         0 $new .= "-$n";
5792             }
5793             # use new ID and save it so we can use it in TagLookup
5794 5661 50       10888 $$tagInfo{NewTagID} = $new unless $tagID eq $new;
5795              
5796             # add new ID to lookup of Composite tag ID's
5797 5661 100       11455 $compositeID{$tagID} = [ ] unless $compositeID{$tagID};
5798 5661         6091 unshift @{$compositeID{$tagID}}, $new; # (most recent one first)
  5661         10197  
5799              
5800             # convert scalar Require/Desire/Inhibit entries
5801 5661         6571 my ($type, @hashes, @scalars, %used);
5802 5661         6434 foreach $type ('Require','Desire','Inhibit') {
5803 16983 100       26007 my $req = $$tagInfo{$type} or next;
5804 7484 100       7238 push @{ref($req) eq 'HASH' ? \@hashes : \@scalars}, $type;
  7484         13235  
5805             }
5806 5661 100       7780 if (@scalars) {
5807             # make lookup for indices that are used
5808 1012         1357 foreach $type (@hashes) {
5809 113         193 $used{$_} = 1 foreach keys %{$$tagInfo{$type}};
  113         1174  
5810             }
5811 1012         1206 my $next = 0;
5812 1012         1247 foreach $type (@scalars) {
5813 1012         1983 ++$next while $used{$next};
5814 1012         2958 $$tagInfo{$type} = { $next++ => $$tagInfo{$type} };
5815             }
5816             }
5817             # add this Composite tag to our main Composite table
5818 5661         6628 $$tagInfo{Table} = $compTable;
5819             # (use the original TagID, even if we changed it, so don't do this:)
5820 5661         6521 $$tagInfo{TagID} = $new;
5821             # save tag under new ID in Composite table
5822 5661         9962 $$compTable{$new} = $tagInfo;
5823             # set all default groups in tag
5824 5661         6468 my $groups = $$tagInfo{Groups};
5825 5661 100       8985 $groups or $groups = $$tagInfo{Groups} = { };
5826             # fill in default groups
5827 5661         9827 foreach (keys %$defaultGroups) {
5828 16983 100       28960 $$groups{$_} or $$groups{$_} = $$defaultGroups{$_};
5829             }
5830             # set flag indicating group list was built
5831 5661         12362 $$tagInfo{GotGroups} = 1;
5832             }
5833             }
5834              
5835             #------------------------------------------------------------------------------
5836             # Add tags to TagLookup (used for writing)
5837             # Inputs: 0) source hash of tag definitions, 1) name of destination tag table
5838             sub AddTagsToLookup($$)
5839             {
5840 1     1 0 2 my ($tagHash, $table) = @_;
5841 1 50       6 if (defined &Image::ExifTool::TagLookup::AddTags) {
    50          
5842 0         0 Image::ExifTool::TagLookup::AddTags($tagHash, $table);
5843             } elsif (not $Image::ExifTool::pluginTags{$tagHash}) {
5844             # queue these tags until TagLookup is loaded
5845 1         3 push @Image::ExifTool::pluginTags, [ $tagHash, $table ];
5846             # set flag so we don't load same tags twice
5847 1         3 $Image::ExifTool::pluginTags{$tagHash} = 1;
5848             }
5849             }
5850              
5851             #------------------------------------------------------------------------------
5852             # Expand tagInfo Flags
5853             # Inputs: 0) tagInfo hash ref
5854             # Notes: $$tagInfo{Flags} must be defined to call this routine
5855             sub ExpandFlags($)
5856             {
5857 5049     5049 0 5655 my $tagInfo = shift;
5858 5049         5905 my $flags = $$tagInfo{Flags};
5859 5049 100       8888 if (ref $flags eq 'ARRAY') {
    50          
5860 2621         4080 foreach (@$flags) {
5861 7008         13080 $$tagInfo{$_} = 1;
5862             }
5863             } elsif (ref $flags eq 'HASH') {
5864 0         0 my $key;
5865 0         0 foreach $key (keys %$flags) {
5866 0         0 $$tagInfo{$key} = $$flags{$key};
5867             }
5868             } else {
5869 2428         4962 $$tagInfo{$flags} = 1;
5870             }
5871             }
5872              
5873             #------------------------------------------------------------------------------
5874             # Set up tag table (must be done once for each tag table used)
5875             # Inputs: 0) Reference to tag table
5876             # Notes: - generates 'Name' field from key if it doesn't exist
5877             # - stores 'Table' pointer and 'TagID' value
5878             # - expands 'Flags' for quick lookup
5879             sub SetupTagTable($)
5880             {
5881 5462     5462 0 10526 my $tagTablePtr = shift;
5882 5462         7528 my $avoid = $$tagTablePtr{AVOID};
5883 5462         7179 my ($tagID, $tagInfo);
5884 5462         10291 foreach $tagID (TagTableKeys($tagTablePtr)) {
5885 236056         256380 my @infoArray = GetTagInfoList($tagTablePtr,$tagID);
5886             # process conditional tagInfo arrays
5887 236056         236769 foreach $tagInfo (@infoArray) {
5888 259041         349835 $$tagInfo{Table} = $tagTablePtr;
5889 259041         325187 $$tagInfo{TagID} = $tagID;
5890 259041 100       340816 $$tagInfo{Name} or $$tagInfo{Name} = MakeTagName($tagID);
5891 259041 100       320081 $$tagInfo{Flags} and ExpandFlags($tagInfo);
5892 259041 100       302795 $$tagInfo{Avoid} = $avoid if defined $avoid;
5893             # calculate BitShift from Mask if necessary
5894 259041 100 100     368108 if ($$tagInfo{Mask} and not defined $$tagInfo{BitShift}) {
5895 3091         3827 my ($mask, $bitShift) = ($$tagInfo{Mask}, 0);
5896 3091         7273 ++$bitShift until $mask & (1 << $bitShift);
5897 3091         4803 $$tagInfo{BitShift} = $bitShift;
5898             }
5899             }
5900 236056 100       329201 next unless @infoArray > 1;
5901             # add an "Index" member to each tagInfo in a list
5902 3933         4883 my $index = 0;
5903 3933         5085 foreach $tagInfo (@infoArray) {
5904 26918         38309 $$tagInfo{Index} = $index++;
5905             }
5906             }
5907             }
5908              
5909             #------------------------------------------------------------------------------
5910             # Is this a PC system?
5911             # Returns: true for PC systems
5912             # uses lookup for O/S names which may use a backslash as a directory separator
5913             # (ref File::Spec of PathTools-3.2701)
5914             my %isPC = (MSWin32 => 1, os2 => 1, dos => 1, NetWare => 1, symbian => 1, cygwin => 1);
5915             sub IsPC()
5916             {
5917 0     0 0 0 return $isPC{$^O};
5918             }
5919              
5920             #------------------------------------------------------------------------------
5921             # Utilities to check for numerical types
5922             # Inputs: 0) value; Returns: true if value is a numerical type
5923             # Notes: May change commas to decimals in floats for use in other locales
5924             sub IsFloat($) {
5925 8229 100   8229 0 69564 return 1 if $_[0] =~ /^[+-]?(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/;
5926             # allow comma separators (for other locales)
5927 2519 50       17329 return 0 unless $_[0] =~ /^[+-]?(?=\d|,\d)\d*(,\d*)?([Ee]([+-]?\d+))?$/;
5928 0         0 $_[0] =~ tr/,/./; # but translate ',' to '.'
5929 0         0 return 1;
5930             }
5931 20366     20366 0 76147 sub IsInt($) { return scalar($_[0] =~ /^[+-]?\d+$/); }
5932 3369     3369 0 10032 sub IsHex($) { return scalar($_[0] =~ /^(0x)?[0-9a-f]{1,8}$/i); }
5933 16     16 0 109 sub IsRational($) { return scalar($_[0] =~ m{^[-+]?\d+/\d+$}); }
5934              
5935             # round floating point value to specified number of significant digits
5936             # Inputs: 0) value, 1) number of sig digits; Returns: rounded number
5937             sub RoundFloat($$)
5938             {
5939 3522     3522 0 4993 my ($val, $sig) = @_;
5940 3522         19508 return sprintf("%.${sig}g", $val);
5941             }
5942              
5943             # Convert strings to floating point numbers (or undef)
5944             # Inputs: 0-N) list of strings (may be undef)
5945             # Returns: last value converted
5946             sub ToFloat(@)
5947             {
5948 1004     1004 0 1474 local $_;
5949 1004         1903 foreach (@_) {
5950 10756 100       14034 next unless defined $_;
5951             # (add 0 to convert "0.0" to "0" for tests)
5952 4030 100       17086 $_ = /((?:[+-]?)(?=\d|\.\d)\d*(?:\.\d*)?(?:[Ee](?:[+-]?\d+))?)/ ? $1 + 0 : undef;
5953             }
5954 1004         7478 return $_[-1];
5955             }
5956              
5957             #------------------------------------------------------------------------------
5958             # Utility routines to for reading binary data values from file
5959              
5960             my %unpackMotorola = ( S => 'n', L => 'N', C => 'C', c => 'c' );
5961             my %unpackIntel = ( S => 'v', L => 'V', C => 'C', c => 'c' );
5962             my %unpackRev = ( N => 'V', V => 'N', C => 'C', n => 'v', v => 'n', c => 'c' );
5963              
5964             # the following 4 variables are defined in 'use vars' instead of using 'my'
5965             # because mod_perl 5.6.1 apparently has a problem with setting file-scope 'my'
5966             # variables from within subroutines (ref communication with Pavel Merdin):
5967             # $swapBytes - set if EXIF header is not native byte ordering
5968             # $swapWords - swap 32-bit words in doubles (ARM quirk)
5969             $currentByteOrder = 'MM'; # current byte ordering ('II' or 'MM')
5970             %unpackStd = %unpackMotorola;
5971              
5972             # Swap bytes in data if necessary
5973             # Inputs: 0) data, 1) number of bytes
5974             # Returns: swapped data
5975             sub SwapBytes($$)
5976             {
5977 1366 100   1366 0 2872 return $_[0] unless $swapBytes;
5978 212         393 my ($val, $bytes) = @_;
5979 212         300 my $newVal = '';
5980 212         1219 $newVal .= substr($val, $bytes, 1) while $bytes--;
5981 212         401 return $newVal;
5982             }
5983             # Swap words. Inputs: 8 bytes of data, Returns: swapped data
5984             sub SwapWords($)
5985             {
5986 1302 50 33 1302 0 3980 return $_[0] unless $swapWords and length($_[0]) == 8;
5987 0         0 return substr($_[0],4,4) . substr($_[0],0,4)
5988             }
5989              
5990             # Unpack value, letting unpack() handle byte swapping
5991             # Inputs: 0) unpack template, 1) data reference, 2) offset
5992             # Returns: unpacked number
5993             # - uses value of %unpackStd to determine the unpack template
5994             # - can only be called for 'S' or 'L' templates since these are the only
5995             # templates for which you can specify the byte ordering.
5996             sub DoUnpackStd(@)
5997             {
5998 163368 100   163368 0 275203 $_[2] and return unpack("x$_[2] $unpackStd{$_[0]}", ${$_[1]});
  158515         268496  
5999 4853         6916 return unpack($unpackStd{$_[0]}, ${$_[1]});
  4853         11159  
6000             }
6001             # same, but with reversed byte order
6002             sub DoUnpackRev(@)
6003             {
6004 12     12 0 22 my $fmt = $unpackRev{$unpackStd{$_[0]}};
6005 12 50       27 $_[2] and return unpack("x$_[2] $fmt", ${$_[1]});
  12         26  
6006 0         0 return unpack($fmt, ${$_[1]});
  0         0  
6007             }
6008             # Pack value
6009             # Inputs: 0) template, 1) value, 2) data ref (or undef), 3) offset (if data ref)
6010             # Returns: packed value
6011             sub DoPackStd(@)
6012             {
6013 31736     31736 0 46294 my $val = pack($unpackStd{$_[0]}, $_[1]);
6014 31736 100       39717 $_[2] and substr(${$_[2]}, $_[3], length($val)) = $val;
  7720         9018  
6015 31736         51384 return $val;
6016             }
6017             # same, but with reversed byte order
6018             sub DoPackRev(@)
6019             {
6020 0     0 0 0 my $val = pack($unpackRev{$unpackStd{$_[0]}}, $_[1]);
6021 0 0       0 $_[2] and substr(${$_[2]}, $_[3], length($val)) = $val;
  0         0  
6022 0         0 return $val;
6023             }
6024              
6025             # Unpack value, handling the byte swapping manually
6026             # Inputs: 0) # bytes, 1) unpack template, 2) data reference, 3) offset
6027             # Returns: unpacked number
6028             # - uses value of $swapBytes to determine byte ordering
6029             sub DoUnpack(@)
6030             {
6031 27969     27969 0 34961 my ($bytes, $template, $dataPt, $pos) = @_;
6032 27969         25604 my $val;
6033 27969 100       31256 if ($swapBytes) {
6034 5448         5722 $val = '';
6035 5448         17374 $val .= substr($$dataPt,$pos+$bytes,1) while $bytes--;
6036             } else {
6037 22521         27024 $val = substr($$dataPt,$pos,$bytes);
6038             }
6039 27969 50       36792 defined($val) or return undef;
6040 27969         42819 return unpack($template,$val);
6041             }
6042              
6043             # Unpack double value
6044             # Inputs: 0) unpack template, 1) data reference, 2) offset
6045             # Returns: unpacked number
6046             sub DoUnpackDbl(@)
6047             {
6048 1236     1236 0 1641 my ($template, $dataPt, $pos) = @_;
6049 1236         1752 my $val = substr($$dataPt,$pos,8);
6050 1236 50       1741 defined($val) or return undef;
6051             # swap bytes and 32-bit words (ARM quirk) if necessary, then unpack value
6052 1236         1775 return unpack($template, SwapWords(SwapBytes($val, 8)));
6053             }
6054              
6055             # Inputs: 0) data reference, 1) offset into data
6056 135     135 0 285 sub Get8s($$) { return DoUnpackStd('c', @_); }
6057 8006     8006 0 11261 sub Get8u($$) { return DoUnpackStd('C', @_); }
6058 15000     15000 0 19854 sub Get16s($$) { return DoUnpack(2, 's', @_); }
6059 78835     78835 0 101367 sub Get16u($$) { return DoUnpackStd('S', @_); }
6060 12274     12274 0 15621 sub Get32s($$) { return DoUnpack(4, 'l', @_); }
6061 76392     76392 0 95337 sub Get32u($$) { return DoUnpackStd('L', @_); }
6062 695     695 0 1316 sub GetFloat($$) { return DoUnpack(4, 'f', @_); }
6063 1236     1236 0 1748 sub GetDouble($$) { return DoUnpackDbl('d', @_); }
6064 12     12 0 21 sub Get16uRev($$) { return DoUnpackRev('S', @_); }
6065 0     0 0 0 sub Get32uRev($$) { return DoUnpackRev('L', @_); }
6066              
6067             # rationals may be a floating point number, 'inf' or 'undef'
6068             my ($ratNumer, $ratDenom);
6069             sub GetRational32s($$)
6070             {
6071 12     12 0 20 my ($dataPt, $pos) = @_;
6072 12         32 $ratNumer = Get16s($dataPt,$pos);
6073 12 0       27 $ratDenom = Get16s($dataPt, $pos + 2) or return $ratNumer ? 'inf' : 'undef';
    50          
6074             # round off to a reasonable number of significant figures
6075 12         38 return RoundFloat($ratNumer / $ratDenom, 7);
6076             }
6077             sub GetRational32u($$)
6078             {
6079 12     12 0 22 my ($dataPt, $pos) = @_;
6080 12         23 $ratNumer = Get16u($dataPt,$pos);
6081 12 0       22 $ratDenom = Get16u($dataPt, $pos + 2) or return $ratNumer ? 'inf' : 'undef';
    50          
6082 12         32 return RoundFloat($ratNumer / $ratDenom, 7);
6083             }
6084             sub GetRational64s($$)
6085             {
6086 690     690 0 1104 my ($dataPt, $pos) = @_;
6087 690         1202 $ratNumer = Get32s($dataPt,$pos);
6088 690 0       1291 $ratDenom = Get32s($dataPt, $pos + 4) or return $ratNumer ? 'inf' : 'undef';
    50          
6089 690         1669 return RoundFloat($ratNumer / $ratDenom, 10);
6090             }
6091             sub GetRational64u($$)
6092             {
6093 2840     2840 0 3971 my ($dataPt, $pos) = @_;
6094 2840         4038 $ratNumer = Get32u($dataPt,$pos);
6095 2840 50       4518 $ratDenom = Get32u($dataPt, $pos + 4) or return $ratNumer ? 'inf' : 'undef';
    100          
6096 2808         6360 return RoundFloat($ratNumer / $ratDenom, 10);
6097             }
6098             sub GetFixed16s($$)
6099             {
6100 18     18 0 34 my ($dataPt, $pos) = @_;
6101 18         35 my $val = Get16s($dataPt, $pos) / 0x100;
6102 18 50       74 return int($val * 1000 + ($val<0 ? -0.5 : 0.5)) / 1000;
6103             }
6104             sub GetFixed16u($$)
6105             {
6106 0     0 0 0 my ($dataPt, $pos) = @_;
6107 0         0 return int((Get16u($dataPt, $pos) / 0x100) * 1000 + 0.5) / 1000;
6108             }
6109             sub GetFixed32s($$)
6110             {
6111 1889     1889 0 2397 my ($dataPt, $pos) = @_;
6112 1889         2304 my $val = Get32s($dataPt, $pos) / 0x10000;
6113             # remove insignificant digits
6114 1889 100       3582 return int($val * 1e5 + ($val>0 ? 0.5 : -0.5)) / 1e5;
6115             }
6116             sub GetFixed32u($$)
6117             {
6118 216     216 0 296 my ($dataPt, $pos) = @_;
6119             # remove insignificant digits
6120 216         323 return int((Get32u($dataPt, $pos) / 0x10000) * 1e5 + 0.5) / 1e5;
6121             }
6122             # Inputs: 0) value, 1) data ref, 2) offset
6123 5     5 0 12 sub Set8s(@) { return DoPackStd('c', @_); }
6124 308     308 0 430 sub Set8u(@) { return DoPackStd('C', @_); }
6125 12729     12729 0 15782 sub Set16u(@) { return DoPackStd('S', @_); }
6126 18694     18694 0 23351 sub Set32u(@) { return DoPackStd('L', @_); }
6127 0     0 0 0 sub Set16uRev(@) { return DoPackRev('S', @_); }
6128              
6129             #------------------------------------------------------------------------------
6130             # Get current byte order ('II' or 'MM')
6131 14749     14749 0 30098 sub GetByteOrder() { return $currentByteOrder; }
6132              
6133             #------------------------------------------------------------------------------
6134             # Set byte ordering
6135             # Inputs: 0) 'MM'=motorola, 'II'=intel (will translate 'BigEndian', 'LittleEndian')
6136             # Returns: 1 on success
6137             sub SetByteOrder($)
6138             {
6139 16310     16310 0 22990 my $order = shift;
6140              
6141 16310 100       28836 if ($order eq 'MM') { # big endian (Motorola)
    100          
    100          
    100          
6142 8653         31289 %unpackStd = %unpackMotorola;
6143             } elsif ($order eq 'II') { # little endian (Intel)
6144 7460         27534 %unpackStd = %unpackIntel;
6145             } elsif ($order =~ /^Big/i) {
6146 16         34 $order = 'MM';
6147 16         109 %unpackStd = %unpackMotorola;
6148             } elsif ($order =~ /^Little/i) {
6149 12         25 $order = 'II';
6150 12         73 %unpackStd = %unpackIntel;
6151             } else {
6152 169         468 return 0;
6153             }
6154 16141         30675 my $val = unpack('S','A ');
6155 16141         16999 my $nativeOrder;
6156 16141 50       27247 if ($val == 0x4120) { # big endian
    50          
6157 0         0 $nativeOrder = 'MM';
6158             } elsif ($val == 0x2041) { # little endian
6159 16141         18084 $nativeOrder = 'II';
6160             } else {
6161 0         0 warn sprintf("Unknown native byte order! (pattern %x)\n",$val);
6162 0         0 return 0;
6163             }
6164 16141         18317 $currentByteOrder = $order; # save current byte order
6165              
6166             # swap bytes if our native CPU byte ordering is not the same as the EXIF
6167 16141         20661 $swapBytes = ($order ne $nativeOrder);
6168              
6169             # little-endian ARM has big-endian words for doubles (thanks Riku Voipio)
6170             # (Note: Riku's patch checked for '0ff3', but I think it should be 'f03f' since
6171             # 1 is '000000000000f03f' on an x86 -- so check for both, but which is correct?)
6172 16141         17516 my $pack1d = pack('d', 1);
6173 16141   33     36174 $swapWords = ($pack1d eq "\0\0\x0f\xf3\0\0\0\0" or
6174             $pack1d eq "\0\0\xf0\x3f\0\0\0\0");
6175 16141         25326 return 1;
6176             }
6177              
6178             #------------------------------------------------------------------------------
6179             # Change byte order
6180             sub ToggleByteOrder()
6181             {
6182 39 100   39 0 100 SetByteOrder(GetByteOrder() eq 'II' ? 'MM' : 'II');
6183             }
6184              
6185             #------------------------------------------------------------------------------
6186             # hash lookups for reading values from data
6187             my %formatSize = (
6188             int8s => 1,
6189             int8u => 1,
6190             int16s => 2,
6191             int16u => 2,
6192             int16uRev => 2,
6193             int32s => 4,
6194             int32u => 4,
6195             int32uRev => 4,
6196             int64s => 8,
6197             int64u => 8,
6198             rational32s => 4,
6199             rational32u => 4,
6200             rational64s => 8,
6201             rational64u => 8,
6202             fixed16s => 2,
6203             fixed16u => 2,
6204             fixed32s => 4,
6205             fixed32u => 4,
6206             fixed64s => 8,
6207             float => 4,
6208             double => 8,
6209             extended => 10,
6210             unicode => 2,
6211             complex => 8,
6212             string => 1,
6213             binary => 1,
6214             'undef' => 1,
6215             ifd => 4,
6216             ifd64 => 8,
6217             ue7 => 1,
6218             utf8 => 1, # (Exif 3.0)
6219             );
6220             my %readValueProc = (
6221             int8s => \&Get8s,
6222             int8u => \&Get8u,
6223             int16s => \&Get16s,
6224             int16u => \&Get16u,
6225             int16uRev => \&Get16uRev,
6226             int32s => \&Get32s,
6227             int32u => \&Get32u,
6228             int32uRev => \&Get32uRev,
6229             int64s => \&Get64s,
6230             int64u => \&Get64u,
6231             rational32s => \&GetRational32s,
6232             rational32u => \&GetRational32u,
6233             rational64s => \&GetRational64s,
6234             rational64u => \&GetRational64u,
6235             fixed16s => \&GetFixed16s,
6236             fixed16u => \&GetFixed16u,
6237             fixed32s => \&GetFixed32s,
6238             fixed32u => \&GetFixed32u,
6239             fixed64s => \&GetFixed64s,
6240             float => \&GetFloat,
6241             double => \&GetDouble,
6242             extended => \&GetExtended,
6243             ifd => \&Get32u,
6244             ifd64 => \&Get64u,
6245             );
6246             # lookup for all rational types
6247             my %isRational = (
6248             rational32u => 1,
6249             rational32s => 1,
6250             rational64u => 1,
6251             rational64s => 1,
6252             );
6253 1600     1600 0 3527 sub FormatSize($) { return $formatSize{$_[0]}; }
6254              
6255             #------------------------------------------------------------------------------
6256             # Read value from binary data (with current byte ordering)
6257             # Inputs: 0) data reference, 1) value offset, 2) format string,
6258             # 3) number of values (or undef to use all data),
6259             # 4) valid data length relative to offset (or undef to use all data),
6260             # 5) optional pointer to returned rational
6261             # Returns: converted value, or undefined if data isn't there
6262             # or list of values in list context
6263             sub ReadValue($$$;$$$)
6264             {
6265 37363     37363 0 67106 my ($dataPt, $offset, $format, $count, $size, $ratPt) = @_;
6266              
6267 37363         54461 my $len = $formatSize{$format};
6268 37363 50       52462 unless ($len) {
6269 0         0 warn "Unknown format $format";
6270 0         0 $len = 1;
6271             }
6272 37363 50       53571 $size = length($$dataPt) - $offset unless defined $size;
6273 37363 100       49796 unless ($count) {
6274 1417 100 100     3708 return '' if defined $count or $size < $len;
6275 1388         2105 $count = int($size / $len);
6276             }
6277             # make sure entry is inside data
6278 37334 100       54281 if ($len * $count > $size) {
6279 3         9 $count = int($size / $len); # shorten count if necessary
6280 3 50       13 $count < 1 and return undef; # return undefined if no data
6281             }
6282 37331         37508 my @vals;
6283 37331         46026 my $proc = $readValueProc{$format};
6284 37331 100 100     76141 if (not $proc) {
    100          
6285             # handle undef/binary/string (also unsupported unicode/complex)
6286 6623         15954 $vals[0] = substr($$dataPt, $offset, $count * $len);
6287             # truncate string at null terminator if necessary
6288 6623 100       23513 $vals[0] =~ s/\0.*//s if $format eq 'string';
6289             } elsif ($isRational{$format} and $ratPt) {
6290             # store rationals separately as string fractions
6291 3132         3278 my @rat;
6292 3132         3401 for (;;) {
6293 3466         6153 push @vals, &$proc($dataPt, $offset);
6294 3466         6963 push @rat, "$ratNumer/$ratDenom";
6295 3466 100       6265 last if --$count <= 0;
6296 334         384 $offset += $len;
6297             }
6298 3132         6775 $$ratPt = join(' ',@rat);
6299             } else {
6300 27576         28465 for (;;) {
6301 50479         66546 push @vals, &$proc($dataPt, $offset);
6302 50479 100       75040 last if --$count <= 0;
6303 22903         21648 $offset += $len;
6304             }
6305             }
6306 37331 100       54137 return @vals if wantarray;
6307 36919 100       71708 return join(' ', @vals) if @vals > 1;
6308 33206         57344 return $vals[0];
6309             }
6310              
6311             #------------------------------------------------------------------------------
6312             # Decode string with specified encoding
6313             # Inputs: 0) ExifTool object ref, 1) string to decode
6314             # 2) source character set name (undef for current Charset)
6315             # 3) optional source byte order (2-byte and 4-byte fixed-width sets only)
6316             # 4) optional destination character set (defaults to Charset setting)
6317             # 5) optional destination byte order (2-byte and 4-byte fixed-width only)
6318             # Returns: string in destination encoding
6319             # Note: ExifTool ref may be undef if character both character sets are provided
6320             # (but in this case no warnings will be issued)
6321             sub Decode($$$;$$$)
6322             {
6323 6494     6494 0 11693 my ($self, $val, $from, $fromOrder, $to, $toOrder) = @_;
6324 6494 100       10008 $from or $from = $$self{OPTIONS}{Charset};
6325 6494 100       13787 $to or $to = $$self{OPTIONS}{Charset};
6326 6494 100 100     12501 if ($from ne $to and length $val) {
6327 1165         27287 require Image::ExifTool::Charset;
6328 1165         1957 my $cs1 = $Image::ExifTool::Charset::csType{$from};
6329 1165         1560 my $cs2 = $Image::ExifTool::Charset::csType{$to};
6330 1165 50 33     4390 if ($cs1 and $cs2 and not $cs2 & 0x002) {
    0 33        
6331             # treat as straight ASCII if no character will need remapping
6332 1165 100 100     3330 if (($cs1 | $cs2) & 0x680 or $val =~ /[\x80-\xff]/) {
6333 825         2056 my $uni = Image::ExifTool::Charset::Decompose($self, $val, $from, $fromOrder);
6334 825         1727 $val = Image::ExifTool::Charset::Recompose($self, $uni, $to, $toOrder);
6335             }
6336             } elsif ($self) {
6337 0 0       0 my $set = $cs1 ? $to : $from;
6338 0 0       0 unless ($$self{"DecodeWarn$set"}) {
6339 0         0 $self->Warn("Unsupported character set ($set)");
6340 0         0 $$self{"DecodeWarn$set"} = 1;
6341             }
6342             }
6343             }
6344 6494         13608 return $val;
6345             }
6346              
6347             #------------------------------------------------------------------------------
6348             # Encode string (in Charset encoding) to specified encoding
6349             # Inputs: 0) ExifTool object ref, 1) string, 2) destination character set name,
6350             # 3) optional destination byte order (2-byte and 4-byte fixed-width sets only)
6351             # Returns: string in specified encoding
6352             sub Encode($$;$$)
6353             {
6354 110     110 0 306 my ($self, $val, $to, $toOrder) = @_;
6355 110         386 return $self->Decode($val, undef, undef, $to, $toOrder);
6356             }
6357              
6358             #------------------------------------------------------------------------------
6359             # Decode bit mask
6360             # Inputs: 0) value to decode, 1) Reference to hash for decoding (or undef)
6361             # 2) optional bits per word (defaults to 32)
6362             sub DecodeBits($$;$)
6363             {
6364 177     177 0 606 my ($vals, $lookup, $bits) = @_;
6365 177 100       444 $bits or $bits = 32;
6366 177         331 my ($val, $i, @bitList);
6367 177         263 my $num = 0;
6368 177         500 foreach $val (split ' ', $vals) {
6369 245         628 for ($i=0; $i<$bits; ++$i) {
6370 6112 100       9353 next unless $val & (1 << $i);
6371 140         217 my $n = $i + $num;
6372 140 100       475 if (not $lookup) {
    100          
6373 19         58 push @bitList, $n;
6374             } elsif ($$lookup{$n}) {
6375 115         314 push @bitList, $$lookup{$n};
6376             } else {
6377 6         34 push @bitList, "[$n]";
6378             }
6379             }
6380 245         383 $num += $bits;
6381             }
6382 177 100       626 return '(none)' unless @bitList;
6383 97 100       634 return join($lookup ? ', ' : ',', @bitList);
6384             }
6385              
6386             #------------------------------------------------------------------------------
6387             # Validate an extracted image and repair if necessary
6388             # Inputs: 0) ExifTool object reference, 1) image reference, 2) tag name or key
6389             # Returns: image reference or undef if it wasn't valid
6390             # Note: should be called from RawConv, not ValueConv
6391             sub ValidateImage($$$)
6392             {
6393 208     208 0 534 my ($self, $imagePt, $tag) = @_;
6394 208 50       570 return undef if $$imagePt eq 'none';
6395 208 100 66     1546 unless ($$imagePt =~ /^(Binary data|\xff\xd8\xff)/ or
      100        
6396             # the first byte of the preview of some Minolta cameras is wrong,
6397             # so check for this and set it back to 0xff if necessary
6398             $$imagePt =~ s/^.(\xd8\xff\xdb)/\xff$1/s or
6399             $self->Options('IgnoreMinorErrors'))
6400             {
6401             # issue warning only if the tag was specifically requested
6402 124 50       447 if ($$self{REQ_TAG_LOOKUP}{lc GetTagName($tag)}) {
6403 0         0 $self->Warn("$tag is not a valid JPEG image",1);
6404 0         0 return undef;
6405             }
6406             }
6407 208         2132 return $imagePt;
6408             }
6409              
6410             #------------------------------------------------------------------------------
6411             # Validate a tag name argument (including group name and wildcards, etc)
6412             # Inputs: 0) tag name
6413             # Returns: true if tag name is valid
6414             # - a tag name may contain [-_A-Za-z0-9], but may not start with [-0-9]
6415             # - tag names may contain wildcards [?*], and end with a hash [#]
6416             # - may have group name prefixes (which may have family number prefix), separated by colons
6417             # - a group name may be zero or more characters
6418             sub ValidTagName($)
6419             {
6420 54     54 0 83 my $tag = shift;
6421 54         297 return $tag =~ /^(([-\w]*|\d*\*):)*[_a-zA-Z?*][-\w?*]*#?$/;
6422             }
6423              
6424             #------------------------------------------------------------------------------
6425             # Generate a valid tag name based on the tag ID or name
6426             # Inputs: 0) tag ID or name
6427             # Returns: valid tag name
6428             sub MakeTagName($)
6429             {
6430 39041     39041 0 38119 my $name = shift;
6431 39041         48241 $name =~ tr/-_a-zA-Z0-9//dc; # remove illegal characters
6432 39041         42192 $name = ucfirst $name; # capitalize first letter
6433             # must at least 2 characters long and not start with - or 0-9-
6434 39041 100 66     86602 $name = "Tag$name" if length($name) < 2 or $name =~ /^[-0-9]/;
6435 39041         59066 return $name;
6436             }
6437              
6438             #------------------------------------------------------------------------------
6439             # Make description from a tag name
6440             # Inputs: 0) tag name 1) optional tagID to add at end of description
6441             # Returns: description
6442             sub MakeDescription($;$)
6443             {
6444 11317     11317 0 15386 my ($tag, $tagID) = @_;
6445             # start with the tag name and force first letter to be upper case
6446 11317         14528 my $desc = ucfirst($tag);
6447             # translate underlines to spaces
6448 11317         13682 $desc =~ tr/_/ /;
6449             # remove hex TagID from name (to avoid inserting spaces in the number)
6450 11317 100 66     23017 $desc =~ s/ (0x[\da-f]+)$//i and $tagID = $1 unless defined $tagID;
6451             # put a space between lower/UPPER case and lower/number combinations
6452 11317         52323 $desc =~ s/([a-z])([A-Z\d])/$1 $2/g;
6453             # put a space between acronyms and words
6454 11317         22472 $desc =~ s/([A-Z])([A-Z][a-z])/$1 $2/g;
6455             # put spaces after numbers (if more than one character follows the number)
6456 11317         14916 $desc =~ s/(\d)([A-Z]\S)/$1 $2/g;
6457             # add TagID to description
6458 11317 100       16312 $desc .= ' ' . $tagID if defined $tagID;
6459 11317         21661 return $desc;
6460             }
6461              
6462             #------------------------------------------------------------------------------
6463             # Get descriptions for all tags in an array
6464             # Inputs: 0) ExifTool ref, 1) reference to list of tag keys
6465             # Returns: reference to hash lookup for descriptions
6466             # Note: Returned descriptions are NOT escaped by ESCAPE_PROC
6467             sub GetDescriptions($$)
6468             {
6469 0     0 0 0 local $_;
6470 0         0 my ($self, $tags) = @_;
6471 0         0 my %desc;
6472 0         0 my $oldEscape = $$self{ESCAPE_PROC};
6473 0         0 delete $$self{ESCAPE_PROC};
6474 0         0 $desc{$_} = $self->GetDescription($_) foreach @$tags;
6475 0         0 $$self{ESCAPE_PROC} = $oldEscape;
6476 0         0 return \%desc;
6477             }
6478              
6479             #------------------------------------------------------------------------------
6480             # Apply filter to value(s) if necessary
6481             # Inputs: 0) ExifTool ref, 1) filter expression, 2) reference to value to filter
6482             # Returns: true unless a filter returned undef; changes value if necessary
6483             sub Filter($$$)
6484             {
6485 13477     13477 1 14985 local $_;
6486 13477         23399 my ($self, $filter, $valPt) = @_;
6487 13477 100 66     32442 return 1 unless defined $filter and defined $$valPt;
6488 463         535 my $rtnVal;
6489 463 100       680 if (not ref $$valPt) {
    100          
    50          
    0          
6490 447         574 $_ = $$valPt;
6491             #### eval Filter ($_, $self)
6492 447         18526 eval $filter;
6493 447 50       1061 if (defined $_) {
6494 447         570 $$valPt = $_;
6495 447         468 $rtnVal = 1;
6496             }
6497             } elsif (ref $$valPt eq 'SCALAR') {
6498 12         16 my $val = $$$valPt; # make a copy to avoid filtering twice
6499 12         24 $rtnVal = $self->Filter($filter, \$val);
6500 12         21 $$valPt = \$val;
6501             } elsif (ref $$valPt eq 'ARRAY') {
6502 4         4 my @val = @{$$valPt}; # make a copy to avoid filtering twice
  4         15  
6503 4   33     12 $self->Filter($filter, \$_) and $rtnVal = 1 foreach @val;
6504 4         7 $$valPt = \@val;
6505             } elsif (ref $$valPt eq 'HASH') {
6506 0         0 my %val = %{$$valPt}; # make a copy to avoid filtering twice
  0         0  
6507 0   0     0 $self->Filter($filter, \$val{$_}) and $rtnVal = 1 foreach keys %val;
6508 0         0 $$valPt = \%val;
6509             } else {
6510 0         0 $rtnVal = 1;
6511             }
6512 463         634 return $rtnVal;
6513             }
6514              
6515             #------------------------------------------------------------------------------
6516             # Return printable value
6517             # Inputs: 0) ExifTool object reference
6518             # 1) value to print, 2) line length limit (undef defaults to 60, 0=unlimited)
6519             # Returns: Printable string
6520             sub Printable($;$)
6521             {
6522 590     590 0 940 my ($self, $outStr, $maxLen) = @_;
6523 590 50       924 return '(undef)' unless defined $outStr;
6524 590 50       1196 ref $outStr eq 'SCALAR' and return '(Binary data '.length($$outStr).' bytes)';
6525 590         982 $outStr =~ tr/\x01-\x1f\x7f-\xff/./;
6526 590         1141 $outStr =~ s/\x00//g;
6527 590         867 my $verbose = $$self{OPTIONS}{Verbose};
6528 590 50       924 if ($verbose < 4) {
6529 590 100       967 if ($maxLen) {
    50          
6530 589 50       968 $maxLen = 20 if $maxLen < 20; # minimum length is 20
6531             } elsif (defined $maxLen) {
6532 1         2 $maxLen = length $outStr; # 0 is unlimited
6533             } else {
6534 0         0 $maxLen = 60; # default maximum is 60
6535             }
6536             } else {
6537 0         0 $maxLen = length $outStr;
6538             # limit to 2048 characters if verbose < 5
6539 0 0 0     0 $maxLen = 2048 if $maxLen > 2048 and $verbose < 5;
6540             }
6541              
6542             # limit length if necessary
6543 590 100       921 $outStr = substr($outStr,0,$maxLen-6) . '[snip]' if length($outStr) > $maxLen;
6544 590         1282 return $outStr;
6545             }
6546              
6547             #------------------------------------------------------------------------------
6548             # Convert date/time from Exif format
6549             # Inputs: 0) ExifTool object reference, 1) Date/time in EXIF format
6550             # Returns: Formatted date/time string
6551             sub ConvertDateTime($$)
6552             {
6553 1845     1845 0 3495 my ($self, $date) = @_;
6554 1845         3680 my $fmt = $$self{OPTIONS}{DateFormat};
6555 1845         3018 my $shift = $$self{OPTIONS}{GlobalTimeShift};
6556 1845 100       3708 if ($shift) {
6557 8         18 my $offset = $$self{GLOBAL_TIME_OFFSET};
6558 8         9 my ($g, $t, $dir, @matches);
6559 8 50       29 if ($shift =~ s/^((\d?[A-Z][-\w]*\w:)*)([A-Z][-\w]*\w)([-+])//i) {
6560 0 0       0 ($g, $t, $dir) = ($1, $3, ($4 eq '-' ? -1 : 1));
6561             } else {
6562 8 50 33     42 $dir = ($shift =~ s/^([-+])// and $1 eq '-') ? -1 : 1;
6563             }
6564 8 100       17 unless ($offset) {
6565 1         5 $offset = $$self{GLOBAL_TIME_OFFSET} = { };
6566             # (see forum16692 for a discussion about why this code was added)
6567 1 50       12 if ($t) {
6568             # determine initial shift from specified tag
6569 0         0 @matches = sort grep(/^$t( \(|$)/i, keys %{$$self{VALUE}});
  0         0  
6570 0 0 0     0 if ($g and @matches) {
6571 0         0 $g =~ s/:$//;
6572 0         0 @matches = $self->GroupMatches($g, \@matches);
6573             }
6574             }
6575 1 0 33     7 if (not @matches and $$self{TAGS_FROM_FILE} and $$self{OPTIONS}{RequestTags}) {
      33        
6576             # determine initial shift from first requested date/time tag
6577 0         0 my @reqDate = grep /date/i, @{$$self{OPTIONS}{RequestTags}};
  0         0  
6578 0         0 while (@reqDate) {
6579 0         0 $t = shift @reqDate;
6580 0         0 @matches = sort grep(/^$t( \(|$)/i, keys %{$$self{VALUE}});
  0         0  
6581 0         0 my $ti = $$self{TAG_INFO};
6582 0         0 for (; @matches; shift @matches) {
6583             # select the first tag that calls this routine in its PrintConv
6584 0 0       0 next unless $$ti{$matches[0]}{PrintConv};
6585 0 0       0 next unless $$ti{$matches[0]}{PrintConv} =~ /ConvertDateTime/;
6586 0         0 undef @reqDate;
6587 0         0 last;
6588             }
6589             }
6590             }
6591 1 50       3 if (@matches) {
6592 0         0 my $val = $self->GetValue($matches[0], 'ValueConv');
6593 0 0       0 ShiftTime($val, $shift, $dir, $offset) if defined $val;
6594             }
6595             }
6596 8         24 ShiftTime($date, $shift, $dir, $offset);
6597             }
6598             # only convert date if a format was specified and the date is recognizable
6599 1845 100       3254 if ($fmt) {
6600             # separate time zone if it exists
6601 5         6 my $tz;
6602 5 100       31 $date =~ s/([-+]\d{2}:\d{2}|Z)$// and $tz = $1;
6603             # a few cameras use incorrect date/time formatting:
6604             # - slashes instead of colons in date (RolleiD330, ImpressCam)
6605             # - date/time values separated by colon instead of space (Polariod, Sanyo, Sharp, Vivitar)
6606             # - single-digit seconds with leading space (HP scanners)
6607 5         36 my @a = reverse ($date =~ /\d+/g); # be very flexible about date/time format
6608 5 50 33     41 if (@a and $a[-1] >= 1000 and $a[-1] < 3000 and eval { require POSIX }) {
  5 0 33     32  
      33        
6609 5         13 shift @a while @a > 6; # remove superfluous entries
6610 5         9 unshift @a, 1 while @a < 3; # add month and day if necessary
6611 5         9 unshift @a, 0 while @a < 6; # add h,m,s if necessary
6612 5         10 $a[4] -= 1; # base month is 1
6613             # parse our %f fractional seconds first (and round up seconds if necessary)
6614             # - if there are multiple %f codes, they all get the same number of digits as the first
6615 5 50       24 if ($fmt =~ /%(-?)\.?(\d*)f/) {
6616 0         0 my ($neg, $dig) = ($1, $2);
6617 0 0       0 my $frac = $date =~ /(\.\d+)/ ? $1 : '';
6618 0 0       0 if (not $frac) {
    0          
6619 0 0       0 $frac = '.' . ('0' x $dig) if $dig;
6620             } elsif (length $dig) {
6621 0 0       0 if ($dig+1 > length($frac)) {
    0          
6622 0         0 $frac .= '0' x ($dig+1-length($frac));
6623             } elsif ($dig+1 < length($frac)) {
6624 0         0 $frac = sprintf("%.${dig}f", $frac);
6625 0   0     0 while ($frac =~ s/^(\d)// and $1 ne '0') {
6626             # this is a pain, but we must round up to the next second
6627 0 0       0 ++$a[0] < 60 and last;
6628 0         0 $a[0] = 0;
6629 0 0       0 ++$a[1] < 60 and last;
6630 0         0 $a[1] = 0;
6631 0 0       0 ++$a[2] < 24 and last;
6632 0         0 $a[2] = 0;
6633 0         0 require 'Image/ExifTool/Shift.pl';
6634 0 0       0 ++$a[3] <= DaysInMonth($a[4]+1, $a[5]) and last;
6635 0         0 $a[3] = 1;
6636 0 0       0 ++$a[4] < 12 and last;
6637 0         0 $a[4] = 0;
6638 0         0 ++$a[5];
6639 0         0 last; # (this was a goto)
6640             }
6641             }
6642             }
6643 0 0       0 $neg and $frac =~ s/^\.//;
6644 0         0 $fmt =~ s/(^|[^%])((%%)*)%-?\.?\d*f/$1$2$frac/g;
6645             }
6646             # parse %z and %s ourself (to handle time zones properly)
6647 5 50       15 if ($fmt =~ /%:?[sz]/) {
6648             # use system time zone unless otherwise specified
6649 0 0 0     0 $tz = TimeZoneString(\@a, TimeLocal(@a)) if not $tz and eval { require Time::Local };
  0         0  
6650             # remove colon, setting to UTC if time zone is not numeric
6651 0 0 0     0 $tz = '+00:00' unless $tz and $tz=~/^[-+]\d{2}:\d{2}$/;
6652 0         0 $fmt =~ s/(^|[^%])((%%)*)%:z/$1$2$tz/g; # convert '%:z' format codes
6653 0         0 $tz =~ s/://;
6654 0         0 $fmt =~ s/(^|[^%])((%%)*)%z/$1$2$tz/g; # convert '%z' format codes
6655 0 0 0     0 if ($fmt =~ /%s/ and eval { require Time::Local }) {
  0         0  
6656             # calculate seconds since the Epoch, UTC
6657 0         0 my $s = Time::Local::timegm(@a) - 60 * ($tz - int($tz/100) * 40);
6658 0         0 $fmt =~ s/(^|[^%])((%%)*)%s/$1$2$s/g; # convert '%s' format codes
6659             }
6660             }
6661 5         9 $a[5] -= 1900; # strftime year starts from 1900
6662 5         159 $date = POSIX::strftime($fmt, @a); # generate the formatted date/time
6663             # apparently strftime can set the UTF-8 flag (argh!), so reset this if necessary
6664 5 50       21 $self->Sanitize(\$date) if $fmt =~ /[\x80-\xff]/;
6665             } elsif ($$self{OPTIONS}{StrictDate}) {
6666 0         0 undef $date;
6667             }
6668             }
6669 1845         10192 return $date;
6670             }
6671              
6672             #------------------------------------------------------------------------------
6673             # Print conversion for time span value
6674             # Inputs: 0) time ticks, 1) number of seconds per tick (default 1)
6675             # Returns: readable time
6676             sub ConvertTimeSpan($;$)
6677             {
6678 3     3 0 7 my ($val, $mult) = @_;
6679 3 50 33     13 if (Image::ExifTool::IsFloat($val) and $val != 0) {
6680 3 100       9 $val *= $mult if $mult;
6681 3 50       27 if ($val < 60) {
    50          
    0          
6682 0         0 $val = "$val seconds";
6683             } elsif ($val < 3600) {
6684 3 100 66     29 my $fmt = ($mult and $mult >= 60) ? '%d' : '%.1f';
6685 3 100 66     20 my $s = ($val == 60 and $mult) ? '' : 's';
6686 3         20 $val = sprintf("$fmt minute$s", $val / 60);
6687             } elsif ($val < 24 * 3600) {
6688 0         0 $val = sprintf("%.1f hours", $val / 3600);
6689             } else {
6690 0         0 $val = sprintf("%.1f days", $val / (24 * 3600));
6691             }
6692             }
6693 3         25 return $val;
6694             }
6695              
6696             #------------------------------------------------------------------------------
6697             # Patched timelocal() that fixes ActivePerl timezone bug
6698             # Inputs/Returns: same as timelocal()
6699             # Notes: must 'require Time::Local' before calling this routine.
6700             # Also note that year should be full year, and not relative to 1900 as with localtime
6701             sub TimeLocal(@)
6702             {
6703 36     36 0 1416 my $tm = Time::Local::timelocal(@_);
6704 36 50       2383 if ($^O eq 'MSWin32') {
6705             # patch for ActivePerl timezone bug
6706 0         0 my @t2 = localtime($tm);
6707 0         0 $t2[5] += 1900;
6708 0         0 my $t2 = Time::Local::timelocal(@t2);
6709             # adjust timelocal() return value to be consistent with localtime()
6710 0         0 $tm += $tm - $t2;
6711             }
6712 36         78 return $tm;
6713             }
6714              
6715             #------------------------------------------------------------------------------
6716             # Get time zone in minutes
6717             # Inputs: 0) localtime array ref, 1) gmtime array ref
6718             # Returns: time zone offset in minutes
6719             sub GetTimeZone($$)
6720             {
6721 967     967 0 1971 my ($tm, $gm) = @_;
6722             # compute the number of minutes between localtime and gmtime
6723 967         2506 my $min = $$tm[2] * 60 + $$tm[1] - ($$gm[2] * 60 + $$gm[1]);
6724 967 50       2099 if ($$tm[3] != $$gm[3]) {
6725             # account for case where one date wraps to the first of the next month
6726 0 0       0 $$gm[3] = $$tm[3] - ($$tm[3]==1 ? 1 : -1) if abs($$tm[3]-$$gm[3]) != 1;
    0          
6727             # adjust for the +/- one day difference
6728 0         0 $min += ($$tm[3] - $$gm[3]) * 24 * 60;
6729             }
6730             # MirBSD patch to round to the nearest 30 minutes because
6731             # it includes leap seconds in localtime but not gmtime
6732 967 0       3055 $min = int($min / 30 + ($min > 0 ? 0.5 : -0.5)) * 30 if $^O eq 'mirbsd';
    50          
6733 967         2245 return $min;
6734             }
6735              
6736             #------------------------------------------------------------------------------
6737             # Get time zone string
6738             # Inputs: 0) time zone offset in minutes
6739             # or 0) localtime array ref, 1) corresponding time value
6740             # Returns: time zone string ("+/-HH:MM")
6741             sub TimeZoneString($;$)
6742             {
6743 1008     1008 0 1756 my $min = shift;
6744 1008 100       2152 if (ref $min) {
6745 967         3035 my @gm = gmtime(shift);
6746 967         2424 $min = GetTimeZone($min, \@gm);
6747             }
6748 1008         2071 my $sign = '+';
6749 1008 100       1961 $min < 0 and $sign = '-', $min = -$min;
6750 1008         2107 $min = int($min + 0.5); # round off to nearest minute
6751 1008         1730 my $h = int($min / 60);
6752 1008         4385 return sprintf('%s%.2d:%.2d', $sign, $h, $min - $h * 60);
6753             }
6754              
6755             #------------------------------------------------------------------------------
6756             # Convert Unix time to EXIF date/time string
6757             # Inputs: 0) Unix time value, 1) non-zero to convert to local time, 2) number of
6758             # digits after the decimal for fractional seconds, negative to trim
6759             # trailing zeros, or undef to use SystemTimeRes
6760             # Returns: EXIF date/time string (with timezone for local times)
6761             sub ConvertUnixTime($;$$)
6762             {
6763 1070     1070 0 2601 my ($time, $toLocal, $dec) = @_;
6764 1070 100       2428 return '0000:00:00 00:00:00' if $time == 0;
6765 1069         1529 my (@tm, $tz, $trim);
6766 1069 100 50     4715 $dec = $static_vars{SystemTimeRes} || 0 unless defined $dec;
6767 1069 100       2127 $dec < 0 and $dec = -$dec, $trim = 1;
6768 1069         1596 my $itime = int($time);
6769 1069         1569 my $frac = $time - $itime;
6770 1069 50       2004 $frac < 0 and $frac += 1, $itime -= 1;
6771 1069         6001 $dec = sprintf('%.*f', $dec, $frac);
6772             # remove number before decimal and increment integer time if necessary
6773 1069 100 66     6344 $dec =~ s/^(\d)// and $1 eq '1' and $itime += 1;
6774 1069 100       2169 $dec =~ s/\.?0+$// if $trim; # trim trailing zeros if specified
6775 1069 100       2811 if (not $toLocal) {
    50          
6776 164         532 @tm = gmtime($itime);
6777 164         275 $tz = '';
6778             } elsif ($static_vars{KeepUTCTime}) {
6779 0         0 @tm = gmtime($itime);
6780 0         0 $tz = 'Z';
6781             } else {
6782 905         22701 @tm = localtime($itime);
6783 905         2920 $tz = TimeZoneString(\@tm, $itime);
6784             }
6785 1069         5361 my $str = sprintf("%4d:%.2d:%.2d %.2d:%.2d:%.2d$dec%s",
6786             $tm[5]+1900, $tm[4]+1, $tm[3], $tm[2], $tm[1], $tm[0], $tz);
6787 1069         8270 return $str;
6788             }
6789              
6790             #------------------------------------------------------------------------------
6791             # Get Unix time from EXIF-formatted date/time string with optional timezone
6792             # Inputs: 0) EXIF date/time string, 1) non-zero if time is local, or 2 to assume UTC
6793             # Returns: Unix time (seconds since 0:00 GMT Jan 1, 1970) or undefined on error
6794             sub GetUnixTime($;$)
6795             {
6796 176     176 0 34043 my ($timeStr, $isLocal) = @_;
6797 176 50       370 return 0 if $timeStr eq '0000:00:00 00:00:00';
6798 176         869 my @tm = ($timeStr =~ /^(\d+)[-:](\d+)[-:](\d+)\s+(\d+):(\d+):(\d+)(.*)/);
6799 176 50       362 return undef unless @tm == 7;
6800 176 50       247 unless (eval { require Time::Local }) {
  176         4130  
6801 0         0 warn "Time::Local is not installed\n";
6802 0         0 return undef;
6803             }
6804 176         10930 my ($tzStr, $tzSec) = (pop(@tm), 0);
6805             # use specified timezone offset (if given) instead of local system time
6806             # if we are converting a local time value
6807 176 100       356 if ($isLocal) {
6808 127 50       326 if ($tzStr =~ /(?:Z|([-+])(\d+):(\d+))/i) {
    0          
6809             # use specified timezone if one exists
6810 127 100       453 $tzSec = ($2 * 60 + $3) * ($1 eq '-' ? -60 : 60) if $1;
    100          
6811 127         153 undef $isLocal; # convert using GMT corrected for specified timezone
6812             } elsif ($isLocal eq '2') {
6813 0         0 undef $isLocal;
6814             }
6815             }
6816 176         291 $tm[1] -= 1; # convert month
6817 176         261 @tm = reverse @tm; # change to order required by timelocal()
6818 176 50       551 my $val = $isLocal ? TimeLocal(@tm) : Time::Local::timegm(@tm) - $tzSec;
6819             # handle fractional seconds
6820 174 100 100     4865 $val += $1 if $tzStr and $tzStr =~ /^(\.\d+)/;
6821 174         1061 return $val;
6822             }
6823              
6824             #------------------------------------------------------------------------------
6825             # Print conversion for file size
6826             # Inputs: 0) file size in bytes, 1) optional ExifTool ref
6827             # Returns: converted file size
6828             sub ConvertFileSize($;$)
6829             {
6830 310     310 0 945 my ($val, $et) = @_;
6831 310 50 66     2503 if ($et and $$et{OPTIONS}{ByteUnit} eq 'Binary') {
6832 0 0       0 $val < 2048 and return "$val bytes";
6833 0 0       0 $val < 10240 and return sprintf('%.1f KiB', $val / 1024);
6834 0 0       0 $val < 2097152 and return sprintf('%.0f KiB', $val / 1024);
6835 0 0       0 $val < 10485760 and return sprintf('%.1f MiB', $val / 1048576);
6836 0 0       0 $val < 2147483648 and return sprintf('%.0f MiB', $val / 1048576);
6837 0 0       0 $val < 10737418240 and return sprintf('%.1f GiB', $val / 1073741824);
6838 0         0 return sprintf('%.0f GiB', $val / 1073741824);
6839             } else {
6840 310 100       1280 $val < 2000 and return "$val bytes";
6841 199 100       1392 $val < 10000 and return sprintf('%.1f kB', $val / 1000);
6842 50 100       421 $val < 2000000 and return sprintf('%.0f kB', $val / 1000);
6843 4 100       44 $val < 10000000 and return sprintf('%.1f MB', $val / 1000000);
6844 1 50       6 $val < 2000000000 and return sprintf('%.0f MB', $val / 1000000);
6845 0 0       0 $val < 10000000000 and return sprintf('%.1f GB', $val / 1000000000);
6846 0         0 return sprintf('%.0f GB', $val / 1000000000);
6847             }
6848             }
6849              
6850             #------------------------------------------------------------------------------
6851             # Convert seconds to duration string (handles negative durations)
6852             # Inputs: 0) floating point seconds
6853             # Returns: duration string in form "S.SS s", "H:MM:SS" or "DD days HH:MM:SS"
6854             sub ConvertDuration($)
6855             {
6856 130     130 0 201 my $time = shift;
6857 130 50       314 return $time unless IsFloat($time);
6858 130 100       666 return '0 s' if $time == 0;
6859 61 50       181 my $sign = ($time > 0 ? '' : (($time = -$time), '-'));
6860 61 100       825 return sprintf("$sign%.2f s", $time) if $time < 30;
6861 4         7 $time += 0.5; # to round off to nearest second
6862 4         10 my $h = int($time / 3600);
6863 4         9 $time -= $h * 3600;
6864 4         7 my $m = int($time / 60);
6865 4         6 $time -= $m * 60;
6866 4 50       8 if ($h > 24) {
6867 0         0 my $d = int($h / 24);
6868 0         0 $h -= $d * 24;
6869 0         0 $sign = "$sign$d days ";
6870             }
6871 4         38 return sprintf("$sign%d:%.2d:%.2d", $h, $m, int($time));
6872             }
6873              
6874             #------------------------------------------------------------------------------
6875             # Print conversion for bitrate values
6876             # Inputs: 0) bitrate in bits per second
6877             # Returns: human-readable bitrate string
6878             # Notes: returns input value without formatting if it isn't numerical
6879             sub ConvertBitrate($)
6880             {
6881 20     20 0 47 my $bitrate = shift;
6882 20 50       51 IsFloat($bitrate) or return $bitrate;
6883 20         76 my @units = ('bps', 'kbps', 'Mbps', 'Gbps');
6884 20         23 for (;;) {
6885 38         54 my $units = shift @units;
6886 38 100 66     194 $bitrate >= 1000 and @units and $bitrate /= 1000, next;
6887 20 100       1205 my $fmt = $bitrate < 100 ? '%.3g' : '%.0f';
6888 20         218 return sprintf("$fmt $units", $bitrate);
6889             }
6890             }
6891              
6892             #------------------------------------------------------------------------------
6893             # Convert file name for printing
6894             # Inputs: 0) ExifTool ref, 1) file name in CharsetFileName character set
6895             # Returns: converted file name in external character set
6896             sub ConvertFileName($$)
6897             {
6898 1010     1010 0 2270 my ($self, $val) = @_;
6899 1010         2041 my $enc = $$self{OPTIONS}{CharsetFileName};
6900 1010 50       2246 $val = $self->Decode($val, $enc) if $enc;
6901 1010         6843 return $val;
6902             }
6903              
6904             #------------------------------------------------------------------------------
6905             # Inverse conversion for file name (encode in CharsetFileName)
6906             # Inputs: 0) ExifTool ref, 1) file name in external character set
6907             # Returns: file name in CharsetFileName character set
6908             sub InverseFileName($$)
6909             {
6910 1     1 0 3 my ($self, $val) = @_;
6911 1         3 my $enc = $$self{OPTIONS}{CharsetFileName};
6912 1 50       4 $val = $self->Encode($val, $enc) if $enc;
6913 1         2 $val =~ tr/\\/\//; # make sure we are using forward slashes
6914 1         8 return $val;
6915             }
6916              
6917             #------------------------------------------------------------------------------
6918             # Limit length of long values (to be used in PrintConv)
6919             # Inputs: 0) string value, 1) ExifTool ref
6920             # Returns: length-limited value
6921             sub LimitLongValues($$)
6922             {
6923 416     416 1 660 my ($str, $self) = @_;
6924 416         587 my $lim = $$self{OPTIONS}{LimitLongValues};
6925 416 100 66     993 if (length($str) > $lim and $lim >= 5) {
6926 48         116 $str = substr($str,0,$lim-5) . "[...]";
6927             }
6928 416         691 return $str;
6929             }
6930              
6931             #------------------------------------------------------------------------------
6932             # Save information for HTML dump
6933             # Inputs: 0) ExifTool hash ref, 1) start offset, 2) data size
6934             # 3) comment string, 4) tool tip (or SAME), 5) flags, 6) IFD name
6935             sub HDump($$$$;$$$)
6936             {
6937 0     0 0 0 my $self = shift;
6938 0 0       0 $$self{HTML_DUMP} or return;
6939 0         0 my ($pos, $len, $com, $tip, $flg, $ifd) = @_;
6940 0 0       0 $pos += $$self{BASE} if $$self{BASE};
6941             # skip structural data blocks which have been removed from the middle of this dump
6942             # (SkipData list contains ordered [start,end+1] offsets to skip)
6943 0 0       0 if ($$self{SkipData}) {
6944 0         0 my $end = $pos + $len;
6945 0         0 my $skip;
6946 0         0 foreach $skip (@{$$self{SkipData}}) {
  0         0  
6947 0 0       0 $end <= $$skip[0] and last;
6948 0 0       0 $pos >= $$skip[1] and $pos += $$skip[1] - $$skip[0], next;
6949 0 0       0 if ($pos != $$skip[0]) {
6950 0         0 $$self{HTML_DUMP}->Add($pos, $$skip[0]-$pos, $com, $tip, $flg, $ifd);
6951 0         0 $len -= $$skip[0] - $pos;
6952 0         0 $tip = 'SAME';
6953             }
6954 0         0 $pos = $$skip[1];
6955             }
6956             }
6957 0         0 $$self{HTML_DUMP}->Add($pos, $len, $com, $tip, $flg, $ifd);
6958             }
6959              
6960             #------------------------------------------------------------------------------
6961             # Identify trailer ending at specified offset from end of file
6962             # Inputs: 0) RAF reference, 1) offset from end of file (0 by default)
6963             # Returns: Trailer info hash (with RAF and DirName set),
6964             # or undef if no recognized trailer was found
6965             # Notes: leaves file position unchanged
6966             sub IdentifyTrailer($$;$)
6967             {
6968 585     585 0 1387 my ($self, $raf, $offset) = @_;
6969 585 100       1257 $offset or $offset = 0;
6970 585         2913 my $pos = $raf->Tell();
6971 585         992 my ($buff, $type, $len);
6972 585   33     1828 while ($raf->Seek(-$offset, 2) and ($len = $raf->Tell()) > 0) {
6973             # read up to 64 bytes before specified offset from end of file
6974 585 50       1514 $len = 64 if $len > 64;
6975 585 50 33     1313 $raf->Seek(-$len, 1) and $raf->Read($buff, $len) == $len or last;
6976 585 100 66     10395 if ($buff =~ /AXS(!|\*).{8}$/s) {
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    100          
    50          
    100          
6977 29         59 $type = 'AFCP';
6978             } elsif ($buff =~ /\xa1\xb2\xc3\xd4$/) {
6979 29         53 $type = 'FotoStation';
6980             } elsif ($buff =~ /cbipcbbl$/) {
6981 34         59 $type = 'PhotoMechanic';
6982             } elsif ($buff =~ /^CANON OPTIONAL DATA\0/) {
6983 41         76 $type = 'CanonVRD';
6984             } elsif ($buff =~ /~\0\x04\0zmie~\0\0\x06.{4}[\x10\x18]\x04$/s or
6985             $buff =~ /~\0\x04\0zmie~\0\0\x0a.{8}[\x10\x18]\x08$/s)
6986             {
6987 26         51 $type = 'MIE';
6988             } elsif ($buff =~ /\0\0(QDIOBS|SEFT)$/) {
6989 26         52 $type = 'Samsung';
6990             } elsif ($buff =~ /8db42d694ccc418790edff439fe026bf$/s) {
6991 0         0 $type = 'Insta360';
6992             } elsif ($buff =~ m(\0{6}/NIKON APP$)) {
6993 0         0 $type = 'NikonApp';
6994             } elsif ($buff =~ /\xff{4}\x1b\*9HWfu\x84\x93\xa2\xb1$/) {
6995 26         64 $type = 'Vivo';
6996             } elsif ($buff =~ /jxrs...\0$/s) {
6997 0         0 $type = 'OnePlus';
6998             } elsif ($$self{ProcessGoogleTrailer}) {
6999             # check for Google trailer information if specific XMP tags exist
7000 1         3 $type = 'Google';
7001             }
7002 585         971 last;
7003             }
7004 585         1581 $raf->Seek($pos, 0); # restore original file position
7005 585 100       1977 return $type ? { RAF => $raf, DirName => $type } : undef;
7006             }
7007              
7008             #------------------------------------------------------------------------------
7009             # Read/rewrite trailer information (including multiple trailers)
7010             # Inputs: 0) ExifTool object ref, 1) DirInfo ref:
7011             # - requires RAF and DirName
7012             # - OutFile is a scalar reference for writing
7013             # - scans from current file position for each trailer if ScanForTrailer is set
7014             # (current file position is just after JPEG EOF for a JPEG image)
7015             # Returns: 1 if trailer was processed or couldn't be processed (or written OK)
7016             # 0 if trailer was recognized but offsets need fixing (or write error)
7017             # - DirName, DirLen, DataPos, Offset, Fixup and OutFile are updated
7018             # - preserves current file position and byte order
7019             sub ProcessTrailers($$)
7020             {
7021 78     78 0 203 my ($self, $dirInfo) = @_;
7022 78         167 my $dirName = $$dirInfo{DirName};
7023 78         143 my $outfile = $$dirInfo{OutFile};
7024 78   50     302 my $offset = $$dirInfo{Offset} || 0;
7025 78         129 my $fixup = $$dirInfo{Fixup};
7026 78         144 my $raf = $$dirInfo{RAF};
7027 78         159 my $pos = $raf->Tell();
7028 78         178 my $byteOrder = GetByteOrder();
7029 78         136 my $success = 1;
7030 78         144 my $path = $$self{PATH};
7031              
7032             # get position of end of file
7033 78         205 $raf->Seek(0,2);
7034 78         169 $$self{FileEnd} = $raf->Tell();
7035              
7036 78         122 for (;;) { # loop through all trailers
7037 232         526 $raf->Seek($pos);
7038 232         318 my ($proc, $outBuff);
7039             # trailer-processing procs residing in modules of a different name
7040             my $module = {
7041             Insta360 => 'QuickTimeStream.pl',
7042             NikonApp => 'Nikon.pm',
7043             Vivo => 'Trailer.pm',
7044             OnePlus => 'Trailer.pm',
7045             Google => 'Trailer.pm',
7046 232   66     1866 }->{$dirName} || "$dirName.pm";
7047 232         18253 require "Image/ExifTool/$module";
7048 232         1923 $module =~ s/(Stream)?\..*//; # remove extension and change QuickTimeStream to QuickTime
7049 232         429 $proc = "Image::ExifTool::${module}::Process$dirName";
7050 232 100       533 if ($outfile) {
7051             # write to local buffer so we can add trailer in proper order later
7052 57 100       190 $$outfile and $$dirInfo{OutFile} = \$outBuff, $outBuff = '';
7053             # must generate new fixup if necessary so we can shift
7054             # the old fixup separately after we prepend this trailer
7055 57         92 delete $$dirInfo{Fixup};
7056             }
7057 232         381 delete $$dirInfo{DirLen}; # reset trailer length
7058 232         366 $$dirInfo{Offset} = $offset; # set offset from end of file
7059 232         364 $$dirInfo{Trailer} = 1; # set Trailer flag in case proc cares
7060             # add trailer and DirName to SubDirectory PATH
7061 232         488 push @$path, 'Trailer', $dirName;
7062             #
7063             # Call proc to read or write this trailer
7064             #
7065             # Proc inputs:
7066             # 0) ExifTool ref, with FileEnd set, and TrailerStart possibly set (start of all trailers)
7067             # 1) DirInfo with the following elements:
7068             # DirName - name of this trailer
7069             # RAF - RAF reference
7070             # Offset - positive offset from end of this trailer to the end of file
7071             # OutFile - (write mode) scalar reference for output buffer consisting of an empty string
7072             # Trailer - flag set so proc knows we are processing a trailer (if it cares)
7073             # Fixup - optional fixup for pointers in trailer
7074             # ScanForTrailer - set if we should now scan for the trailer start. For JPEG
7075             # images the ExifTool TrailerStart member will also be set, but for TIFF
7076             # images TrailerStart will only be set when writing, so the proc should
7077             # scan from the current file position when reading in a TIFF image.
7078             # Proc returns in read mode (OutFile not set):
7079             # 1 = success
7080             # 0 = error processing trailer (no warning will be issued and remaining trailers will be ignored)
7081             # -1 = must scan from TrailerStart since length can not be determined
7082             # (in which case this routine will be called again later when TrailerStart is known)
7083             # Proc returns in write mode:
7084             # 1 = success (and proc updates OutFile with the trailer to write, or empty string to delete)
7085             # 0 = error processing trailer (will issue minor error)
7086             # -1 = caller to copy or delete the trailer as-is (from TrailerStart if DataPos isn't set)
7087             # - TrailerStart will always be set in write mode
7088             # - the write routine will not be called if all trailers are being deleted
7089             # Proc sets the following elements of $dirInfo in both read and write mode:
7090             # DataPos - file position for start of this trailer
7091             # DirLen - length of this trailer (subsequent trailers are not processed if this is not set)
7092             # Fixup - for any pointers in the trailer that need adjusting
7093             #
7094 113     113   1014 no strict 'refs';
  113         791  
  113         6770  
7095 232         1977 my $result = &$proc($self, $dirInfo);
7096 113     113   719 use strict 'refs';
  113         254  
  113         1641812  
7097              
7098             # restore PATH (pop last 2 items)
7099 232         556 splice @$path, -2;
7100              
7101 232         616 my ($dataPos, $dirLen) = @$dirInfo{'DataPos','DirLen'};
7102 232 100       579 if ($outfile) {
    100          
7103 57 100       320 if ($result < 0) {
7104             # copy or delete the trailer ourself
7105 7         15 $result = 1;
7106 7 50       21 if ($$self{TrailerStart}) {
7107 7 50       16 $dataPos or $dataPos = $$self{TrailerStart};
7108 7 50       19 $dirLen or $dirLen = $$self{FileEnd} - $offset - $dataPos;
7109             }
7110 7 50 33     78 if ($$self{DEL_GROUP}{Trailer} or $$self{DEL_GROUP}{$dirName}) {
    50 33        
7111 0 0       0 my $bytes = $dirLen ? " ($dirLen bytes)" : '';
7112 0         0 $self->VPrint(0, "Deleting $dirName trailer$bytes\n");
7113 0         0 ++$$self{CHANGED};
7114             } elsif ($dataPos and $dirLen) {
7115 7         47 $self->VPrint(0, "Copying $dirName trailer ($dirLen bytes)\n");
7116             $result = 0 unless $raf->Seek($dataPos) and
7117 7 50 33     23 $raf->Read(${$$dirInfo{OutFile}}, $dirLen) == $dirLen;
  7         29  
7118             } else {
7119 0         0 $result = 0;
7120             }
7121             }
7122 57 50       125 if ($result > 0) {
7123 57 100       134 if ($outBuff) {
7124             # write trailers to OutFile in original order
7125 40         192 $$outfile = $outBuff . $$outfile;
7126             # must adjust old fixup start if it exists
7127 40 100       114 $$fixup{Start} += length($outBuff) if $fixup;
7128 40         63 $outBuff = ''; # free memory
7129             }
7130 57 100       132 if ($$dirInfo{Fixup}) {
7131 15 100       47 if ($fixup) {
7132             # add fixup for subsequent trailers to the fixup for this trailer
7133             # (but first we must adjust for the new start position)
7134 7         19 $$fixup{Shift} += $$dirInfo{Fixup}{Start};
7135 7         14 $$fixup{Start} -= $$dirInfo{Fixup}{Start};
7136 7         25 $$dirInfo{Fixup}->AddFixup($fixup);
7137             }
7138 15         46 $fixup = $$dirInfo{Fixup}; # save fixup
7139             }
7140             } else {
7141 0 0       0 $success = 0 if $self->Error("Error rewriting $dirName trailer", 2);
7142 0         0 last;
7143             }
7144             } elsif ($result < 0) {
7145             # can't continue if we must scan for this trailer
7146 20         26 $success = 0;
7147 20         61 last;
7148             }
7149 212 100 66     837 last unless $result > 0 and $dirLen;
7150 211         322 $offset += $dirLen;
7151 211 100 66     1132 last if $dataPos and $$self{TrailerStart} and $dataPos <= $$self{TrailerStart};
      100        
7152             # look for next trailer
7153 182         531 my $nextTrail = $self->IdentifyTrailer($raf, $offset);
7154             # process Google trailer after all others if necessary and not done already
7155 182 100       409 unless ($nextTrail) {
7156 28 50       134 last unless $$self{ProcessGoogleTrailer};
7157 0         0 $nextTrail = { DirName => 'Google', RAF => $raf };
7158             }
7159 154         494 $dirName = $$dirInfo{DirName} = $$nextTrail{DirName};
7160             }
7161 78         215 SetByteOrder($byteOrder); # restore original byte order
7162 78         275 $raf->Seek($pos); # restore original file position
7163 78         195 $$dirInfo{OutFile} = $outfile; # restore original outfile
7164 78         163 $$dirInfo{Offset} = $offset; # return offset from EOF to start of first trailer
7165 78         180 $$dirInfo{Fixup} = $fixup; # return fixup information
7166 78         334 return $success;
7167             }
7168              
7169             #------------------------------------------------------------------------------
7170             # JPEG constants
7171              
7172             # JPEG marker names
7173             %jpegMarker = (
7174             0x00 => 'NULL',
7175             0x01 => 'TEM',
7176             0xc0 => 'SOF0', # to SOF15, with a few exceptions below
7177             0xc4 => 'DHT',
7178             0xc8 => 'JPGA',
7179             0xcc => 'DAC',
7180             0xd0 => 'RST0', # to RST7
7181             0xd8 => 'SOI',
7182             0xd9 => 'EOI',
7183             0xda => 'SOS',
7184             0xdb => 'DQT',
7185             0xdc => 'DNL',
7186             0xdd => 'DRI',
7187             0xde => 'DHP',
7188             0xdf => 'EXP',
7189             0xe0 => 'APP0', # to APP15
7190             0xf0 => 'JPG0',
7191             0xfe => 'COM',
7192             );
7193              
7194             # lookup for size of JPEG marker length word
7195             # (2 bytes assumed unless specified here)
7196             my %markerLenBytes = (
7197             0x00 => 0, 0x01 => 0,
7198             0xd0 => 0, 0xd1 => 0, 0xd2 => 0, 0xd3 => 0, 0xd4 => 0, 0xd5 => 0, 0xd6 => 0, 0xd7 => 0,
7199             0xd8 => 0, 0xd9 => 0, 0xda => 0,
7200             # J2C
7201             0x30 => 0, 0x31 => 0, 0x32 => 0, 0x33 => 0, 0x34 => 0, 0x35 => 0, 0x36 => 0, 0x37 => 0,
7202             0x38 => 0, 0x39 => 0, 0x3a => 0, 0x3b => 0, 0x3c => 0, 0x3d => 0, 0x3e => 0, 0x3f => 0,
7203             0x4f => 0,
7204             0x92 => 0, 0x93 => 0,
7205             # J2C extensions
7206             0x74 => 4, 0x75 => 4, 0x77 => 4,
7207             );
7208              
7209             #------------------------------------------------------------------------------
7210             # Get JPEG marker name
7211             # Inputs: 0) Jpeg number
7212             # Returns: marker name
7213             sub JpegMarkerName($)
7214             {
7215 3200     3200 0 3959 my $marker = shift;
7216 3200         5636 my $markerName = $jpegMarker{$marker};
7217 3200 100       5621 unless ($markerName) {
7218 1180         2640 $markerName = $jpegMarker{$marker & 0xf0};
7219 1180 50 33     7241 if ($markerName and $markerName =~ /^([A-Z]+)\d+$/) {
7220 1180         3538 $markerName = $1 . ($marker & 0x0f);
7221             } else {
7222 0         0 $markerName = sprintf("marker 0x%.2x", $marker);
7223             }
7224             }
7225 3200         5825 return $markerName;
7226             }
7227              
7228             #------------------------------------------------------------------------------
7229             # Adjust directory start position
7230             # Inputs: 0) dirInfo ref, 1) start offset
7231             # 2) Base for offsets (relative to DataPos, defaults to absolute Base of 0)
7232             sub DirStart($$;$)
7233             {
7234 582     582 0 1255 my ($dirInfo, $start, $base) = @_;
7235 582         1140 $$dirInfo{DirStart} = $start;
7236 582         1018 $$dirInfo{DirLen} -= $start;
7237 582 100       1350 if (defined $base) {
7238 279         587 $$dirInfo{Base} = $$dirInfo{DataPos} + $base;
7239 279         615 $$dirInfo{DataPos} = -$base; # (relative to Base!)
7240             }
7241             }
7242              
7243             #------------------------------------------------------------------------------
7244             # Extract metadata from a jpg image
7245             # Inputs: 0) ExifTool object reference, 1) dirInfo ref with RAF set
7246             # 2) tag table ref to process JPEG-like metadata
7247             # Returns: 1 on success, 0 if this wasn't a valid JPEG file
7248             sub ProcessJPEG($$;$)
7249             {
7250 251     251 0 436 local $_;
7251 251         567 my ($self, $dirInfo, $optionalTagTable) = @_;
7252 251         588 my $options = $$self{OPTIONS};
7253 251         603 my $verbose = $$options{Verbose};
7254 251         506 my $out = $$options{TextOut};
7255 251   100     983 my $fast = $$options{FastScan} || 0;
7256 251         513 my $raf = $$dirInfo{RAF};
7257 251         490 my $req = $$self{REQ_TAG_LOOKUP};
7258 251         528 my $htmlDump = $$self{HTML_DUMP};
7259 251         1111 my %dumpParms = ( Out => $out, Prefix => $$self{INDENT} );
7260 251         1306 my ($ch, $s, $length, $hash, $hashsize, $indent);
7261 251         0 my ($success, $wantTrailer, $trailInfo, $foundSOS, $gotSize, %jumbfChunk);
7262 251         0 my (@iccChunk, $iccChunkCount, $iccChunksTotal, @flirChunk, $flirCount, $flirTotal);
7263 251         0 my ($preview, $scalado, @dqt, $subSampling, $dumpEnd, %extendedXMP);
7264              
7265 251         1495 ($indent = $$self{INDENT}) =~ s/ $//;
7266 251 50       643 unless ($raf) {
7267 0         0 $raf = File::RandomAccess->new($$dirInfo{DataPt});
7268 0         0 $self->VerboseDir('JPEG', undef, length(${$$dirInfo{DataPt}}));
  0         0  
7269             }
7270             # get pointer to hash object if it exists and we are the top-level JPEG or JP2
7271 251 100 100     2077 if ($$self{FILE_TYPE} =~ /^(JPEG|JP2)$/ and not $$self{DOC_NUM}) {
7272 242         511 $hash = $$self{ImageDataHash};
7273 242         441 $hashsize = 0;
7274             }
7275             # check to be sure this is a valid JPG (or J2C, or EXV) file
7276 251 50 33     893 if ($raf->Read($s, 2) == 2 and $s =~ /^\xff[\xd8\x4f\x01]/) {
7277 251         506 undef $optionalTagTable;
7278             } else {
7279 0 0 0     0 return 0 unless $optionalTagTable and $s =~ /^\xff[\xe0-\xef]/;
7280 0 0       0 $raf->Seek(-2, 1) or $self->Error('Seek error'), return 1;
7281             }
7282 251 100       710 if ($s eq "\xff\x01") {
7283 2 50 33     7 return 0 unless $raf->Read($s, 5) == 5 and $s eq 'Exiv2';
7284 2         19 $$self{FILE_TYPE} = 'EXV';
7285             }
7286 251         403 my $appBytes = 0;
7287 251         450 my $calcImageLen = $$req{jpegimagelength};
7288 251 50 66     1111 if ($$options{RequestAll} and $$options{RequestAll} > 2) {
7289 0         0 $calcImageLen = 1;
7290             }
7291 251 100 66     977 if (not $$self{VALUE}{FileType} or ($$self{DOC_NUM} and $$options{ExtractEmbedded})) {
      66        
7292 243         1100 $self->SetFileType(); # set FileType tag
7293 243 100       713 return 1 if $fast > 2; # don't process file when FastScan > 2
7294 242         720 $$self{LOW_PRIORITY_DIR}{IFD1} = 1; # lower priority of IFD1 tags
7295             }
7296 250 100       859 $$raf{NoBuffer} = 1 if $self->Options('FastScan'); # disable buffering in FastScan mode
7297              
7298 250 50       945 $dumpParms{MaxLen} = 128 if $verbose < 4;
7299 250 50 33     756 if ($htmlDump and not $optionalTagTable) {
7300 0         0 $dumpEnd = $raf->Tell();
7301 0 0       0 my ($n, $t, $m) = $s eq 'Exiv2' ? (7,'EXV','TEM') : (2,'JPEG','SOI');
7302 0         0 my $pos = $dumpEnd - $n;
7303 0 0       0 $self->HDump(0, $pos, '[unknown header]') if $pos;
7304 0         0 $self->HDump($pos, $n, "$t header", "$m Marker");
7305             }
7306 250         522 my $path = $$self{PATH};
7307 250         500 my $pn = scalar @$path;
7308              
7309             # set input record separator to 0xff (the JPEG marker) to make reading quicker
7310 250         1290 local $/ = "\xff";
7311              
7312 250         526 my ($nextMarker, $nextSegDataPt, $nextSegPos, $combinedSegData, $firstSegPos, @skipData);
7313              
7314             # read file until we reach an end of image (EOI) or start of scan (SOS)
7315 250         376 Marker: for (;;) {
7316             # set marker and data pointer for current segment
7317 2217         3410 my $marker = $nextMarker;
7318 2217 50 66     5973 last if $marker and $marker < 0;
7319 2217         2764 my $segDataPt = $nextSegDataPt;
7320 2217         2710 my $segPos = $nextSegPos;
7321 2217         2259 my $skipped;
7322 2217         2812 undef $nextMarker;
7323 2217         2633 undef $nextSegDataPt;
7324             #
7325             # read ahead to the next segment unless we have reached EOI, SOS or SOD
7326             #
7327 2217   100     11650 until ($marker and ($marker==0xd9 or ($marker==0xda and not $wantTrailer and not $hash) or
      100        
7328             $marker==0x93))
7329             {
7330             # read up to next marker (JPEG markers begin with 0xff)
7331 1946         2196 my $buff;
7332 1946 50       6410 unless ($raf->ReadLine($buff)) {
7333 0 0       0 last Marker unless $optionalTagTable;
7334 0         0 $nextMarker = -1;
7335 0         0 $success = 1;
7336 0         0 last;
7337             }
7338 1946         2754 $skipped = length($buff) - 1;
7339             # JPEG markers can be padded with unlimited 0xff's
7340 1946         2193 for (;;) {
7341 1946 50       4052 $raf->Read($ch, 1) or last Marker;
7342 1946         2668 $nextMarker = ord($ch);
7343 1946 50       3504 last unless $nextMarker == 0xff;
7344 0         0 ++$skipped;
7345             }
7346             # read segment data if it exists
7347 1946 100 33     5644 if (not defined $markerLenBytes{$nextMarker}) {
    50 0        
    50 33        
7348             # read record length word
7349 1675 50       2915 last Marker unless $raf->Read($s, 2) == 2;
7350 1675         3218 my $len = unpack('n',$s); # get data length
7351 1675 50 33     4798 last Marker unless defined($len) and $len >= 2;
7352 1675         3404 $nextSegPos = $raf->Tell();
7353 1675         2125 $len -= 2; # subtract size of length word
7354 1675 50       2830 last Marker unless $raf->Read($buff, $len) == $len;
7355 1675         2491 $nextSegDataPt = \$buff; # set pointer to our next data
7356             } elsif ($markerLenBytes{$nextMarker} == 4) {
7357             # handle J2C extensions with 4-byte length word
7358 0 0       0 last Marker unless $raf->Read($s, 4) == 4;
7359 0         0 my $len = unpack('N',$s); # get data length
7360 0 0 0     0 last Marker unless defined($len) and $len >= 4;
7361 0         0 $nextSegPos = $raf->Tell();
7362 0         0 $len -= 4; # subtract size of length word
7363 0 0       0 last Marker unless $raf->Seek($len, 1);
7364             } elsif ($hash and defined $marker and ($marker == 0x00 or $marker == 0xda or
7365             ($marker >= 0xd0 and $marker <= 0xd7)))
7366             {
7367             # calculate hash for image data (includes leading ff d9 but not trailing ff da)
7368 0         0 $hash->add("\xff" . chr($marker));
7369 0         0 my $n = $skipped - (length($buff) - 1); # number of extra 0xff's
7370 0 0       0 if (not $n) {
    0          
7371 0         0 $buff = substr($buff, 0, -1); # remove trailing 0xff
7372             } elsif ($n > 1) {
7373 0         0 $buff .= "\xff" x ($n - 1); # add back extra 0xff's
7374             }
7375 0         0 $hash->add($buff);
7376 0         0 $hashsize += $skipped + 2;
7377             }
7378             # read second segment too if this was the first
7379 1946 100       3656 next Marker unless defined $marker;
7380 1675         2189 last;
7381             }
7382             # set some useful variables for the current segment
7383 1946         3893 my $markerName = JpegMarkerName($marker);
7384 1946         3508 $$path[$pn] = $markerName;
7385             # issue warning if we skipped some garbage
7386 1946 0 33     3962 if ($skipped and not $foundSOS and $markerName ne 'SOS') {
      33        
7387 0         0 $self->Warn("Skipped unknown $skipped bytes after JPEG $markerName segment", 1);
7388 0 0       0 if ($htmlDump) {
7389 0         0 $self->HDump($nextSegPos-4-$skipped, $skipped, "[unknown $skipped bytes]", undef, 0x08);
7390 0         0 $dumpEnd = $nextSegPos - 4;
7391             }
7392             }
7393             #
7394             # parse the current segment
7395             #
7396             # handle SOF markers: SOF0-SOF15, except DHT(0xc4), JPGA(0xc8) and DAC(0xcc)
7397 1946 100 66     13739 if (($marker & 0xf0) == 0xc0 and ($marker == 0xc0 or $marker & 0x03)) {
    100 100        
    100 66        
    100 33        
    50 66        
    100          
7398 247         479 $length = length $$segDataPt;
7399 247 100       941 if ($verbose) {
    50          
7400 2         7 print $out "${indent}JPEG $markerName ($length bytes):\n";
7401 2 100       9 HexDump($segDataPt, undef, %dumpParms, Addr=>$segPos) if $verbose>2;
7402             } elsif ($htmlDump) {
7403 0         0 $self->HDump($segPos-4, $length+4, "[JPEG $markerName]", undef, 0x08);
7404 0         0 $dumpEnd = $segPos + $length;
7405             }
7406 247 50 33     1241 next if $length < 6 or $gotSize;
7407 247         431 $gotSize = 1; # (ignore subsequent SOF segments in probably corrupted JPEG)
7408             # extract some useful information
7409 247         903 my ($p, $h, $w, $n) = unpack('Cn2C', $$segDataPt);
7410 247         808 my $sof = GetTagTable('Image::ExifTool::JPEG::SOF');
7411 247         1037 $self->HandleTag($sof, 'ImageWidth', $w);
7412 247         658 $self->HandleTag($sof, 'ImageHeight', $h);
7413 247         763 $self->HandleTag($sof, 'EncodingProcess', $marker - 0xc0);
7414 247         722 $self->HandleTag($sof, 'BitsPerSample', $p);
7415 247         759 $self->HandleTag($sof, 'ColorComponents', $n);
7416 247 50 33     1142 next unless $n == 3 and $length >= 15;
7417 247         480 my ($i, $hmin, $hmax, $vmin, $vmax);
7418             # loop through all components to determine sampling frequency
7419 247         453 $subSampling = '';
7420 247         959 for ($i=0; $i<$n; ++$i) {
7421 741         1371 my $sf = Get8u($segDataPt, 7 + 3 * $i);
7422 741         1837 $subSampling .= sprintf('%.2x', $sf);
7423             # isolate horizontal and vertical components
7424 741         1220 my ($hf, $vf) = ($sf >> 4, $sf & 0x0f);
7425 741 100       1244 unless ($i) {
7426 247         433 $hmin = $hmax = $hf;
7427 247         358 $vmin = $vmax = $vf;
7428 247         582 next;
7429             }
7430             # determine min/max frequencies
7431 494 100       979 $hmin = $hf if $hf < $hmin;
7432 494 50       840 $hmax = $hf if $hf > $hmax;
7433 494 100       878 $vmin = $vf if $vf < $vmin;
7434 494 50       1182 $vmax = $vf if $vf > $vmax;
7435             }
7436 247 50 33     1025 if ($hmin and $vmin) {
7437 247         659 my ($hs, $vs) = ($hmax / $hmin, $vmax / $vmin);
7438 247         1895 $self->HandleTag($sof, 'YCbCrSubSampling', "$hs $vs");
7439             }
7440 247         601 next;
7441             } elsif ($marker == 0xd9) { # EOI
7442 23         43 pop @$path;
7443 23 100       63 $verbose and print $out "${indent}JPEG EOI\n";
7444 23         63 my $pos = $raf->Tell();
7445 23 50       107 $$self{TrailerStart} = $pos unless $$self{DOC_NUM};
7446 23 50 33     72 if ($htmlDump and $dumpEnd) {
7447 0         0 $self->HDump($dumpEnd, $pos-2-$dumpEnd, '[JPEG Image Data]', undef, 0x08);
7448 0         0 $self->HDump($pos-2, 2, 'JPEG EOI', undef);
7449 0         0 $dumpEnd = 0;
7450             }
7451 23 50 66     91 if ($foundSOS or $$self{FILE_TYPE} eq 'EXV') {
7452 23         41 $success = 1;
7453             } else {
7454 0         0 $self->Warn('Missing JPEG SOS');
7455             }
7456 23 50       73 if ($$req{trailer}) {
7457             # read entire trailer into memory
7458 0 0       0 if ($raf->Seek(0,2)) {
7459 0         0 my $len = $raf->Tell() - $pos;
7460 0 0       0 if ($len) {
7461 0         0 my $buff;
7462 0         0 $raf->Seek($pos, 0);
7463 0 0       0 $self->FoundTag(Trailer => \$buff) if $raf->Read($buff,$len) == $len;
7464 0         0 $raf->Seek($pos, 0);
7465             }
7466             } else {
7467 0         0 $self->Warn('Error seeking in file');
7468             }
7469             }
7470             # we are here because we are looking for trailer information
7471 23 50       72 if ($wantTrailer) {
7472 0         0 my $start = $$self{PreviewImageStart};
7473 0 0 0     0 if ($start or $$options{ExtractEmbedded}) {
7474 0         0 my $buff;
7475             # most previews start right after the JPEG EOI, but the Olympus E-20
7476             # preview is 508 bytes into the trailer, the K-M Maxxum 7D preview is
7477             # 979 bytes in, and Sony previews can start up to 32 kB into the trailer.
7478             # (and Minolta and Sony previews can have a random first byte...)
7479 0 0       0 my $scanLen = $$self{Make} =~ /Sony/i ? 65536 : 1024;
7480 0 0       0 if ($raf->Read($buff, $scanLen)) {
7481 0 0 0     0 if ($buff =~ /^.{4}ftyp/s) {
    0 0        
7482 0         0 my $val;
7483 0 0       0 if ($raf->Seek(0,2)) {
7484 0         0 my $len = $raf->Tell() - $pos;
7485 0 0       0 if ($$options{Binary}) {
7486 0 0 0     0 $val = \$buff if $raf->Seek($pos,0) and $raf->Read($buff,$len)==$len;
7487             } else {
7488 0         0 $val = \ "Binary data $len bytes";
7489             }
7490 0 0       0 if ($val) {
7491 0         0 $self->FoundTag('EmbeddedVideo', $val);
7492             } else {
7493 0         0 $self->Warn('Error reading trailer');
7494             }
7495             } else {
7496 0         0 $self->Warn('Error seeking to end of file');
7497             }
7498             } elsif ($buff =~ /\xff\xd8\xff./g or
7499             ($$self{Make} =~ /(Minolta|Sony)/i and $buff =~ /.\xd8\xff\xdb/g))
7500             {
7501             # adjust PreviewImageStart to this location
7502 0         0 my $actual = $pos + pos($buff) - 4;
7503 0 0 0     0 if ($start and $start ne $actual and $verbose > 1) {
      0        
7504 0         0 print $out "${indent}(Fixed PreviewImage location: $start -> $actual)\n";
7505             }
7506             # update preview image offsets
7507 0 0       0 if ($start) {
7508 0 0       0 $$self{VALUE}{PreviewImageStart} = $actual if $$self{VALUE}{PreviewImageStart};
7509 0         0 $$self{PreviewImageStart} = $actual;
7510             }
7511             # load preview now if we tried and failed earlier
7512 0 0 0     0 if ($$self{PreviewError} and $$self{PreviewImageLength}) {
7513 0 0 0     0 if ($raf->Seek($actual, 0) and $raf->Read($buff, $$self{PreviewImageLength})) {
7514 0         0 $self->FoundTag('PreviewImage', $buff);
7515 0         0 delete $$self{PreviewError};
7516             }
7517             }
7518             }
7519             }
7520 0         0 $raf->Seek($pos, 0);
7521             }
7522             }
7523             # process trailer now or finish processing trailers
7524             # and scan for AFCP if necessary
7525 23         36 my $fromEnd = 0;
7526 23 100       61 if ($trailInfo) {
7527 20         47 $$trailInfo{ScanForTrailer} = 1; # scan now if necessary
7528 20         68 $self->ProcessTrailers($trailInfo);
7529             # save offset from end of file to start of first trailer
7530 20         51 $fromEnd = $$trailInfo{Offset};
7531 20         74 undef $trailInfo;
7532             }
7533 23 50       79 if ($$self{LeicaTrailer}) {
7534 0         0 $raf->Seek(0, 2);
7535 0         0 $$self{LeicaTrailer}{TrailPos} = $pos;
7536 0         0 $$self{LeicaTrailer}{TrailLen} = $raf->Tell() - $pos - $fromEnd;
7537 0         0 Image::ExifTool::Panasonic::ProcessLeicaTrailer($self);
7538             }
7539             # finally, dump remaining information in JPEG trailer
7540 23 100 66     112 if ($verbose or $htmlDump) {
7541 1         2 my $endPos = $$self{LeicaTrailerPos};
7542 1 50       4 unless ($endPos) {
7543 1         4 $raf->Seek(0, 2);
7544 1         3 $endPos = $raf->Tell() - $fromEnd;
7545             }
7546             $self->DumpUnknownTrailer({
7547 1 50       3 RAF => $raf,
7548             DataPos => $pos,
7549             DirLen => $endPos - $pos
7550             }) if $endPos > $pos;
7551             }
7552 23 50       60 $self->FoundTag('JPEGImageLength', $pos - $appBytes) if $calcImageLen;
7553 23         60 last; # all done parsing file
7554             } elsif ($marker == 0xda) { # SOS
7555 247         473 pop @$path;
7556 247         441 $foundSOS = 1;
7557             # all done with meta information unless we have a trailer
7558 247 100       712 $verbose and print $out "${indent}JPEG SOS\n";
7559             # process extended XMP now if it existed
7560             # (must do this before trailers because XMP is required to process Google trailer)
7561 247 100       635 if (%extendedXMP) {
7562 2         3 my $guid;
7563             # GUID indicated by the last main XMP segment
7564 2   50     8 my $goodGuid = $$self{VALUE}{HasExtendedXMP} || '';
7565             # GUID of the extended XMP that we will process ('2' for all)
7566 2   50     8 my $readGuid = $$options{ExtendedXMP} || 0;
7567 2 50       22 $readGuid = $goodGuid if $readGuid eq '1';
7568 2         8 foreach $guid (sort keys %extendedXMP) {
7569 2 50       7 next unless length $guid == 32; # ignore other (internal) keys
7570 2         4 my $extXMP = $extendedXMP{$guid};
7571 2         4 my ($off, @offsets, $warn);
7572             # make sure we have all chunks, and create a list of sorted offsets
7573 2         9 for ($off=0; $off<$$extXMP{Size}; ) {
7574 3 50       9 last unless defined $$extXMP{$off};
7575 3         5 push @offsets, $off;
7576 3         6 $off += length $$extXMP{$off};
7577             }
7578 2 50       6 unless ($off == $$extXMP{Size}) {
7579 0         0 $self->Warn("Incomplete extended XMP (GUID $guid)");
7580 0         0 next;
7581             }
7582 2 50 33     9 if ($guid eq $readGuid or $readGuid eq '2') {
7583 2 50       7 $warn = 'Reading non-' if $guid ne $goodGuid;
7584 2         5 my $buff = '';
7585             # assemble XMP all together
7586 2         74 $buff .= $$extXMP{$_} foreach @offsets;
7587 2         7 my $tagTablePtr = GetTagTable('Image::ExifTool::XMP::Main');
7588 2         8 my %dirInfo = (
7589             DataPt => \$buff,
7590             Parent => 'APP1',
7591             IsExtended => 1,
7592             );
7593 2         5 $$path[$pn] = 'APP1';
7594 2         8 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7595 2         7 pop @$path;
7596             } else {
7597 0         0 $warn = 'Ignored ';
7598 0 0       0 $warn .= 'non-' if $guid ne $goodGuid;
7599             }
7600 2 50       9 $self->Warn("${warn}standard extended XMP (GUID $guid)") if $warn;
7601 2         13 delete $extendedXMP{$guid};
7602             }
7603             }
7604 247 100       569 unless ($fast) {
7605 246         1118 $trailInfo = $self->IdentifyTrailer($raf);
7606             # process trailer now unless we are doing verbose dump
7607 246 50 66     966 if ($trailInfo and $verbose < 3 and not $htmlDump) {
      66        
7608             # process trailers (keep trailInfo to finish processing later
7609             # only if we can't finish without scanning from JPEG EOF)
7610 29 100       256 $self->ProcessTrailers($trailInfo) and undef $trailInfo;
7611             }
7612 246 0 33     617 if ($wantTrailer and $$self{PreviewImageStart}) {
7613             # seek ahead and validate preview image
7614 0         0 my $buff;
7615 0         0 my $curPos = $raf->Tell();
7616 0 0 0     0 if ($raf->Seek($$self{PreviewImageStart}, 0) and
      0        
7617             $raf->Read($buff, 4) == 4 and
7618             $buff =~ /^.\xd8\xff[\xc4\xdb\xe0-\xef]/)
7619             {
7620 0         0 undef $wantTrailer;
7621             }
7622 0 0       0 $raf->Seek($curPos, 0) or last;
7623             }
7624             # seek ahead and process Leica trailer
7625 246 50 33     2090 if ($$self{LeicaTrailer}) {
    50 0        
      0        
      33        
7626 0         0 require Image::ExifTool::Panasonic;
7627 0         0 Image::ExifTool::Panasonic::ProcessLeicaTrailer($self);
7628 0 0       0 $wantTrailer = 1 if $$self{LeicaTrailer};
7629             } elsif ($$options{ExtractEmbedded} or ($$self{VALUE}{HiddenDataOffset} and
7630             $$self{VALUE}{HiddenDataLength} and ($$options{Validate} or $$req{hiddendata})))
7631             {
7632 0         0 $wantTrailer = 1;
7633             }
7634 246 100 66     2065 next if $trailInfo or $wantTrailer or $verbose > 2 or $htmlDump;
      100        
      66        
7635             }
7636             # must scan to EOI if Validate or JpegCompressionFactor used
7637 226 50 33     1985 next if $$options{Validate} or $calcImageLen or $$req{trailer} or $hash;
      33        
      33        
7638             # nothing interesting to parse after start of scan (SOS)
7639 226         331 $success = 1;
7640 226         460 last; # all done parsing file
7641             } elsif ($marker == 0x93) {
7642 1         2 pop @$path;
7643 1 50       5 $verbose and print $out "${indent}JPEG SOD\n";
7644 1         1 $success = 1;
7645 1 50 33     4 if ($hash and $$self{FILE_TYPE} eq 'JP2') {
7646 0         0 my $pos = $raf->Tell();
7647 0         0 $self->ImageDataHash($raf, undef, 'SOD');
7648 0         0 $raf->Seek($pos, 0);
7649             }
7650 1 50 33     4 next if $verbose > 2 or $htmlDump;
7651 1         3 last; # all done parsing file
7652             } elsif (defined $markerLenBytes{$marker}) {
7653             # handle other stand-alone markers and segments we skipped over
7654 0 0 0     0 if ($verbose and $marker) {
7655 0 0 0     0 next if $verbose < 4 and ($marker & 0xf8) == 0xd0;
7656 0         0 print $out "${indent}JPEG $markerName\n";
7657             }
7658 0         0 next;
7659             } elsif ($marker == 0xdb and length($$segDataPt) and # DQT
7660             # save the DQT data only if JPEGDigest has been requested
7661             # (Note: since we aren't checking the API RequestAll option here, the application
7662             # must use the RequestTags option to generate these tags if they have not been
7663             # specifically requested. The reason is that there is too much overhead involved
7664             # in the calculation of this tag to make this worth the CPU time.)
7665             ($$req{jpegdigest} or $$req{jpegqualityestimate}
7666             or ($$options{RequestAll} and $$options{RequestAll} > 2)))
7667             {
7668 1         4 my $num = unpack('C',$$segDataPt) & 0x0f; # get table index
7669 1 50       4 $dqt[$num] = $$segDataPt if $num < 4; # save for hash calculation
7670             }
7671             # handle all other markers
7672 1428         2184 my $dumpType = '';
7673 1428         2029 my ($desc, $tip, $xtra, $useJpegMain);
7674 1428         1836 $length = length $$segDataPt;
7675 1428 100       2810 $appBytes += $length + 4 if ($marker & 0xf0) == 0xe0; # total size of APP segments
7676 1428 100       2553 if ($verbose) {
7677 6         17 print $out "${indent}JPEG $markerName ($length bytes):\n";
7678 6 100       17 if ($verbose > 2) {
7679 3         9 my %extraParms = ( Addr => $segPos );
7680 3 50       9 $extraParms{MaxLen} = 128 if $verbose == 4;
7681 3         13 HexDump($segDataPt, undef, %dumpParms, %extraParms);
7682             }
7683             }
7684             # prepare dirInfo hash for processing this information
7685 1428         7466 my %dirInfo = (
7686             Parent => $markerName,
7687             DataPt => $segDataPt,
7688             DataPos => $segPos,
7689             DataLen => $length,
7690             DirStart => 0,
7691             DirLen => $length,
7692             Base => 0,
7693             );
7694 1428 100       13237 if ($marker == 0xe0) { # APP0 (JFIF, JFXX, CIFF, AVI1, Ocad)
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
7695 108 100       788 if ($$segDataPt =~ /^JFIF\0/) {
    100          
    100          
    50          
7696 51         118 $dumpType = 'JFIF';
7697 51         206 DirStart(\%dirInfo, 5); # start at byte 5
7698 51         168 SetByteOrder('MM');
7699 51         134 my $tagTablePtr = GetTagTable('Image::ExifTool::JFIF::Main');
7700 51         307 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7701             } elsif ($$segDataPt =~ /^JFXX\0(\x10|\x11|\x13)/) {
7702 19         53 my $tag = ord $1;
7703 19         35 $dumpType = 'JFXX';
7704 19         56 my $tagTablePtr = GetTagTable('Image::ExifTool::JFIF::Extension');
7705 19         57 my $tagInfo = $self->GetTagInfo($tagTablePtr, $tag);
7706 19         82 $self->FoundTag($tagInfo, substr($$segDataPt, 6));
7707             } elsif ($$segDataPt =~ /^(II|MM).{4}HEAPJPGM/s) {
7708 19 50       56 next if $fast > 1; # skip processing for very fast
7709 19         41 $dumpType = 'CIFF';
7710 19         108 my %dirInfo = ( RAF => File::RandomAccess->new($segDataPt) );
7711 19         73 $$self{SET_GROUP1} = 'CIFF';
7712 19         30 push @{$$self{PATH}}, 'CIFF';
  19         47  
7713 19         1395 require Image::ExifTool::CanonRaw;
7714 19         126 Image::ExifTool::CanonRaw::ProcessCRW($self, \%dirInfo);
7715 19         39 pop @{$$self{PATH}};
  19         40  
7716 19         100 delete $$self{SET_GROUP1};
7717             } elsif ($$segDataPt =~ /^(AVI1|Ocad)/) {
7718 19         54 $dumpType = $1;
7719 19         58 SetByteOrder('MM');
7720 19         82 my $tagTablePtr = GetTagTable("Image::ExifTool::JPEG::$dumpType");
7721 19         77 DirStart(\%dirInfo, 4);
7722 19         63 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7723             }
7724             } elsif ($marker == 0xe1) { # APP1 (EXIF, XMP, QVCI, PARROT)
7725             # (some Kodak cameras don't put a second "\0", and I have seen an
7726             # example where there was a second 4-byte APP1 segment header)
7727 280 100 66     2892 if ($$segDataPt =~ /^(.{0,4})Exif\0./is) {
    100          
    100          
    100          
    50          
7728 203         399 undef $dumpType; # (will be dumped here)
7729             # this is EXIF data --
7730             # get the data block (into a common variable)
7731 203         400 my $hdrLen = length($exifAPP1hdr);
7732 203 50       1040 if (length $1) {
    50          
7733 0         0 $hdrLen += length $1;
7734 0         0 $self->Warn('Unknown garbage at start of EXIF segment',1);
7735             } elsif ($$segDataPt !~ /^Exif\0/) {
7736 0         0 $self->Warn('Incorrect EXIF segment identifier',1);
7737             }
7738 203 50       490 if ($htmlDump) {
7739 0         0 $self->HDump($segPos-4, 4, 'APP1 header', "Data size: $length bytes");
7740 0         0 $self->HDump($segPos, $hdrLen, 'Exif header', 'APP1 data type: Exif');
7741 0         0 $dumpEnd = $segPos + $length;
7742             }
7743 203         356 my $dataPt = $segDataPt;
7744 203 50       517 if (defined $combinedSegData) {
7745 0         0 push @skipData, [ $segPos-4, $segPos+$hdrLen ];
7746 0         0 $combinedSegData .= substr($$segDataPt,$hdrLen);
7747 0         0 undef $$segDataPt;
7748 0         0 $dataPt = \$combinedSegData;
7749 0         0 $segPos = $firstSegPos;
7750             }
7751             # peek ahead to see if the next segment is extended EXIF
7752 203 50 66     1166 if ($nextMarker == $marker and
7753             $$nextSegDataPt =~ /^$exifAPP1hdr(?!(MM\0\x2a|II\x2a\0))/)
7754             {
7755             # initialize combined data if necessary
7756 0 0       0 unless (defined $combinedSegData) {
7757 0         0 $combinedSegData = $$segDataPt;
7758 0         0 undef $$segDataPt;
7759 0         0 $firstSegPos = $segPos;
7760 0         0 $self->Warn('File contains multi-segment EXIF',1);
7761 0         0 $$self{ExtendedEXIF} = 1;
7762             }
7763 0         0 next;
7764             }
7765 203         470 $dirInfo{DataPt} = $dataPt;
7766 203         371 $dirInfo{DataPos} = $segPos;
7767 203         459 $dirInfo{DataLen} = $dirInfo{DirLen} = length $$dataPt;
7768 203         744 DirStart(\%dirInfo, $hdrLen, $hdrLen);
7769 203 50       494 $$self{SkipData} = \@skipData if @skipData;
7770             # extract the EXIF information (it is in standard TIFF format)
7771 203 50       800 $self->ProcessTIFF(\%dirInfo) or $self->Warn('Malformed APP1 EXIF segment');
7772             # scan for Vivo HiddenData if necessary
7773 203 0 0     798 if ($$self{Make} eq 'vivo' and
      33        
      33        
7774             # (stored as UserComment by some models)
7775             not ($$self{VALUE}{UserComment} and $$self{VALUE}{UserComment} =~ /^filter:/) and
7776             $$dataPt =~ /(filter: .*?; \n)\0/sg)
7777             {
7778 0 0       0 if ($htmlDump) {
7779 0         0 my $n = length($1) + 1;
7780 0         0 $self->HDump($segPos+pos($$dataPt)-$n, $n, '[Vivo HiddenData]', undef, 0x08);
7781             }
7782 0         0 my $tbl = GetTagTable('Image::ExifTool::Trailer::Vivo');
7783 0         0 $self->HandleTag($tbl, HiddenData => $1);
7784             }
7785             # avoid looking for preview unless necessary because it really slows
7786             # us down -- only look for it if we found pointer, and preview is
7787             # outside EXIF, and PreviewImage is specifically requested
7788 203         1062 my $start = $self->GetValue('PreviewImageStart', 'ValueConv');
7789 203         520 my $plen = $self->GetValue('PreviewImageLength', 'ValueConv');
7790 203 100 66     821 if (not $start or not $plen and $$self{PreviewError}) {
      66        
7791 187         345 $start = $$self{PreviewImageStart};
7792 187         456 $plen = $$self{PreviewImageLength};
7793             }
7794 203 0 100     698 if ($start and $plen and IsInt($start) and IsInt($plen) and
      66        
      66        
      33        
      0        
      33        
7795             $start + $plen > $$self{EXIF_POS} + length($$self{EXIF_DATA}) and
7796             ($$req{previewimage} or
7797             # (extracted normally, so check Binary option)
7798             ($$options{Binary} and not $$self{EXCL_TAG_LOOKUP}{previewimage})))
7799             {
7800 0         0 $$self{PreviewImageStart} = $start;
7801 0         0 $$self{PreviewImageLength} = $plen;
7802 0         0 $wantTrailer = 1;
7803             }
7804 203 50       597 if (@skipData) {
7805 0         0 undef @skipData;
7806 0         0 delete $$self{SkipData};
7807             }
7808 203         426 undef $$dataPt;
7809 203         906 next;
7810             } elsif ($$segDataPt =~ /^$xmpExtAPP1hdr/) {
7811             # off len -- extended XMP header (75 bytes total):
7812             # 0 35 bytes - signature
7813             # 35 32 bytes - GUID (MD5 hash of full extended XMP data in ASCII)
7814             # 67 4 bytes - total size of extended XMP data
7815             # 71 4 bytes - offset for this XMP data portion
7816 3         8 $dumpType = 'Extended XMP';
7817 3 50       8 if ($length > 75) {
7818 3         11 my ($size, $off) = unpack('x67N2', $$segDataPt);
7819 3         7 my $guid = substr($$segDataPt, 35, 32);
7820 3 50       13 if ($guid =~ /[^A-Za-z0-9]/) { # (technically, should be uppercase)
7821 0         0 $self->Warn($tip = 'Invalid extended XMP GUID');
7822             } else {
7823 3         7 my $extXMP = $extendedXMP{$guid};
7824 3 100       9 if (not $extXMP) {
    50          
7825 2         5 $extXMP = $extendedXMP{$guid} = { };
7826             } elsif ($size != $$extXMP{Size}) {
7827 0         0 $self->Warn('Inconsistent extended XMP size');
7828             }
7829 3         6 $$extXMP{Size} = $size;
7830 3         57 $$extXMP{$off} = substr($$segDataPt, 75);
7831 3         14 $tip = "Full length: $size\nChunk offset: $off\nChunk length: " .
7832             ($length - 75) . "\nGUID: $guid";
7833             # (delay processing extended XMP until after reading all segments)
7834             }
7835             } else {
7836 0         0 $self->Warn($tip = 'Invalid extended XMP segment');
7837             }
7838             } elsif ($$segDataPt =~ /^QVCI\0/) {
7839 1         3 $dumpType = 'QVCI';
7840 1         3 my $tagTablePtr = GetTagTable('Image::ExifTool::Casio::QVCI');
7841 1         4 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7842             } elsif ($$segDataPt =~ /^FLIR\0/ and $length >= 8) {
7843 1         2 $dumpType = 'FLIR';
7844             # must concatenate FLIR chunks (note: handle the case where
7845             # some software erroneously writes zeros for the chunk counts)
7846 1         3 my $chunkNum = Get8u($segDataPt, 6);
7847 1         3 my $chunksTot = Get8u($segDataPt, 7) + 1; # (note the "+ 1"!)
7848 1 50       3 $verbose and printf $out "${indent}FLIR chunk %d of %d\n",
7849             $chunkNum + 1, $chunksTot;
7850 1 50       2 if (defined $flirTotal) {
7851             # abort parsing FLIR if the total chunk count is inconsistent
7852 0 0       0 undef $flirCount if $chunksTot != $flirTotal;
7853             } else {
7854 1         1 $flirCount = 0;
7855 1         2 $flirTotal = $chunksTot;
7856             }
7857 1 50       2 if (defined $flirCount) {
7858 1 50       2 if (defined $flirChunk[$chunkNum]) {
7859 0         0 $self->Warn('Duplicate FLIR chunk number(s)');
7860 0         0 $flirChunk[$chunkNum] .= substr($$segDataPt, 8);
7861             } else {
7862 1         10 $flirChunk[$chunkNum] = substr($$segDataPt, 8);
7863             }
7864             # process the FLIR information if we have all of the chunks
7865 1 50       3 if (++$flirCount >= $flirTotal) {
7866 1         1 my $flir = '';
7867 1   33     9 defined $_ and $flir .= $_ foreach @flirChunk;
7868 1         3 undef @flirChunk; # free memory
7869 1         3 my $tagTablePtr = GetTagTable('Image::ExifTool::FLIR::FFF');
7870 1         4 my %dirInfo = (
7871             DataPt => \$flir,
7872             Parent => $markerName,
7873             DirName => 'FLIR',
7874             );
7875 1         3 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7876 1         3 undef $flirCount; # prevent reprocessing
7877             }
7878             } else {
7879 0         0 $self->Warn('Invalid or extraneous FLIR chunk(s)');
7880             }
7881             } elsif ($$segDataPt =~ /^PARROT\0(II\x2a\0|MM\0\x2a)/) {
7882             # (don't know if this could span multiple segments)
7883 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::Main');
7884 0         0 $self->HandleTag($tagTablePtr, 'APP1', $$segDataPt);
7885 0         0 $dumpType = 'Parrot';
7886             } else {
7887             # Hmmm. Could be XMP, let's see
7888 72         156 my $processed;
7889 72 50 33     454 if ($$segDataPt =~ /^(http|XMP\0)/ or $$segDataPt =~ /<(exif:|\?xpacket)/) {
7890 72         117 $dumpType = 'XMP';
7891             # also try to parse XMP with a non-standard header
7892             # (note: this non-standard XMP is ignored when writing)
7893 72 50       587 my $start = ($$segDataPt =~ /^$xmpAPP1hdr/) ? length($xmpAPP1hdr) : 0;
7894 72         206 my $tagTablePtr = GetTagTable('Image::ExifTool::XMP::Main');
7895 72         268 DirStart(\%dirInfo, $start);
7896 72 50       454 $dirInfo{DirName} = $start ? 'XMP' : 'XML',
7897             $processed = $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7898 72 50 33     422 if ($processed and not $start) {
7899 0         0 $self->Warn('Non-standard header for APP1 XMP segment');
7900             }
7901             }
7902 72 50 33     262 if ($verbose and not $processed) {
7903 0         0 $self->Warn("Ignored APP1 segment length $length (unknown header)");
7904             }
7905             }
7906             } elsif ($marker == 0xe2) { # APP2 (ICC Profile, FPXR, MPF, InfiRay, URN, PreviewImage)
7907 121 100 66     661 if ($$segDataPt =~ /^ICC_PROFILE\0/ and $length >= 14) {
    100          
    100          
    50          
    0          
    0          
    0          
7908 34         66 $dumpType = 'ICC_Profile';
7909             # must concatenate profile chunks (note: handle the case where
7910             # some software erroneously writes zeros for the chunk counts)
7911 34         110 my $chunkNum = Get8u($segDataPt, 12);
7912 34         99 my $chunksTot = Get8u($segDataPt, 13);
7913 34 50       98 $verbose and print $out "${indent}ICC_Profile chunk $chunkNum of $chunksTot\n";
7914 34 50       88 if (defined $iccChunksTotal) {
7915             # abort parsing ICC_Profile if the total chunk count is inconsistent
7916 0 0       0 undef $iccChunkCount if $chunksTot != $iccChunksTotal;
7917             } else {
7918 34         53 $iccChunkCount = 0;
7919 34         48 $iccChunksTotal = $chunksTot;
7920 34 50       82 $self->Warn('ICC_Profile chunk count is zero') if !$chunksTot;
7921             }
7922 34 50       88 if (defined $iccChunkCount) {
7923 34 50       91 if (defined $iccChunk[$chunkNum]) {
7924 0         0 $self->Warn('Duplicate ICC_Profile chunk number(s)');
7925 0         0 $iccChunk[$chunkNum] .= substr($$segDataPt, 14);
7926             } else {
7927 34         195 $iccChunk[$chunkNum] = substr($$segDataPt, 14);
7928             }
7929             # process profile if we have all of the chunks
7930 34 50       107 if (++$iccChunkCount >= $iccChunksTotal) {
7931 34         67 my $icc_profile = '';
7932 34   66     226 defined $_ and $icc_profile .= $_ foreach @iccChunk;
7933 34         69 undef @iccChunk; # free memory
7934 34         98 my $tagTablePtr = GetTagTable('Image::ExifTool::ICC_Profile::Main');
7935 34         189 my %dirInfo = (
7936             DataPt => \$icc_profile,
7937             DataPos => $segPos + 14,
7938             DataLen => length($icc_profile),
7939             DirStart => 0,
7940             DirLen => length($icc_profile),
7941             Parent => $markerName,
7942             );
7943 34         171 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7944 34         178 undef $iccChunkCount; # prevent reprocessing
7945             }
7946             } else {
7947 0         0 $self->Warn('Invalid or extraneous ICC_Profile chunk(s)');
7948             }
7949             } elsif ($$segDataPt =~ /^FPXR\0/) {
7950 67 50       131 next if $fast > 1; # skip processing for very fast
7951 67         86 $dumpType = 'FPXR';
7952 67         207 my $tagTablePtr = GetTagTable('Image::ExifTool::FlashPix::Main');
7953             # set flag if this is the last FPXR segment
7954 67   100     406 $dirInfo{LastFPXR} = not ($nextMarker==$marker and $$nextSegDataPt=~/^FPXR\0/),
7955             $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7956             } elsif ($$segDataPt =~ /^MPF\0/) {
7957 19         31 undef $dumpType; # (will be dumped here)
7958 19         62 DirStart(\%dirInfo, 4, 4);
7959 19         62 $dirInfo{Multi} = 1; # the MP Attribute IFD will be MPF1
7960 19 50       56 if ($htmlDump) {
7961 0         0 $self->HDump($segPos-4, 4, 'APP2 header', "Data size: $length bytes");
7962 0         0 $self->HDump($segPos, 4, 'MPF header', 'APP2 data type: MPF');
7963 0         0 $dumpEnd = $segPos + $length;
7964             }
7965             # extract the MPF information (it is in standard TIFF format)
7966 19         49 my $tagTablePtr = GetTagTable('Image::ExifTool::MPF::Main');
7967 19         82 $self->ProcessTIFF(\%dirInfo, $tagTablePtr);
7968             } elsif ($$segDataPt =~ /^....IJPEG\0/s) {
7969 1         2 $dumpType = 'InfiRay Version';
7970 1         3 $$self{HasIJPEG} = 1;
7971 1         2 SetByteOrder('II');
7972 1         2 my $tagTablePtr = GetTagTable('Image::ExifTool::InfiRay::Version');
7973 1         4 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7974             } elsif ($$segDataPt =~ /^(|QVGA\0|BGTH)\xff\xd8\xff[\xdb\xe0\xe1]/) {
7975             # Samsung/GE/GoPro="", BenQ DC C1220/Pentacon/Polaroid="QVGA\0",
7976             # Digilife DDC-690/Rollei="BGTH"
7977 0         0 $dumpType = 'Preview Image';
7978 0         0 $preview = substr($$segDataPt, length($1));
7979             } elsif ($$segDataPt =~ /^urn:/) { # (found in Apple HDR images)
7980 0         0 $dumpType = 'URN';
7981 0         0 $useJpegMain = 1;
7982             } elsif ($preview) {
7983 0         0 $dumpType = 'Preview Image';
7984 0         0 $preview .= $$segDataPt;
7985             }
7986 121 50 33     325 if ($preview and $nextMarker ne $marker) {
7987 0         0 $self->FoundTag('PreviewImage', $preview);
7988 0         0 undef $preview;
7989             }
7990             } elsif ($marker == 0xe3) { # APP3 (Kodak "Meta", Stim)
7991 21 100 33     131 if ($$segDataPt =~ /^(Meta|META|Exif)\0\0/) {
    50          
    100          
    50          
    0          
7992 19         29 undef $dumpType; # (will be dumped here)
7993 19         52 DirStart(\%dirInfo, 6, 6);
7994 19 50       64 if ($htmlDump) {
7995 0         0 $self->HDump($segPos-4, 10, 'APP3 Meta header');
7996 0         0 $dumpEnd = $segPos + $length;
7997             }
7998 19         52 my $tagTablePtr = GetTagTable('Image::ExifTool::Kodak::Meta');
7999 19         71 $self->ProcessTIFF(\%dirInfo, $tagTablePtr);
8000             } elsif ($$segDataPt =~ /^Stim\0/) {
8001 0         0 undef $dumpType; # (will be dumped here)
8002 0         0 DirStart(\%dirInfo, 6, 6);
8003 0 0       0 if ($htmlDump) {
8004 0         0 $self->HDump($segPos-4, 4, 'APP3 header', "Data size: $length bytes");
8005 0         0 $self->HDump($segPos, 5, 'Stim header', 'APP3 data type: Stim');
8006 0         0 $dumpEnd = $segPos + $length;
8007             }
8008             # extract the Stim information (it is in standard TIFF format)
8009 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::Stim::Main');
8010 0         0 $self->ProcessTIFF(\%dirInfo, $tagTablePtr);
8011             } elsif ($$segDataPt =~ /^_JPSJPS_/) {
8012 1         3 $dumpType = 'JPS';
8013 1 50       6 $self->OverrideFileType('JPS') if $$self{FILE_TYPE} eq 'JPEG';
8014 1         3 SetByteOrder('MM');
8015 1         3 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::JPS');
8016 1         5 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8017             } elsif ($$self{HasIJPEG} or $$self{Make} eq 'DJI') {
8018 1 50       4 $dumpType = $$self{HasIJPEG} ? 'InfiRay ImagingData' : 'DJI ThermalData';
8019             # add this data to the combined data if it exists
8020 1         2 my $dataPt = $segDataPt;
8021 1 50       3 if (defined $combinedSegData) {
8022 0         0 $combinedSegData .= $$segDataPt;
8023 0         0 $dataPt = \$combinedSegData;
8024             }
8025 1 50       2 if ($nextMarker == $marker) {
8026 0 0       0 $combinedSegData = $$segDataPt unless defined $combinedSegData;
8027             } else {
8028             # process InfiRay/DJI thermal data
8029 1         4 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::Main');
8030 1         5 $self->HandleTag($tagTablePtr, 'APP3', $$dataPt);
8031 1         3 undef $combinedSegData;
8032             }
8033             } elsif ($$segDataPt =~ /^\xff\xd8\xff\xdb/) {
8034 0         0 $dumpType = 'PreviewImage'; # (Samsung, HP, BenQ)
8035 0         0 $preview = $$segDataPt;
8036             }
8037 21 50 33     81 if ($preview and $nextMarker ne 0xe4) { # this preview continues in APP4
8038 0         0 $self->FoundTag('PreviewImage', $preview);
8039 0         0 undef $preview;
8040             }
8041             } elsif ($marker == 0xe4) { # APP4 (InfiRay, "SCALADO", FPXR, DJI, PreviewImage)
8042 1 50 33     29 if ($$segDataPt =~ /^SCALADO\0/ and $length >= 16) {
    50 33        
    50 33        
    50 33        
    50 33        
    50          
    50          
    0          
8043 0         0 $dumpType = 'SCALADO';
8044 0         0 my ($num, $idx, $len) = unpack('x8n2N', $$segDataPt);
8045             # assume that the segments are in order and just concatinate them
8046 0 0       0 $scalado = '' unless defined $scalado;
8047 0         0 $scalado .= substr($$segDataPt, 16);
8048 0 0       0 if ($idx == $num - 1) {
8049 0 0       0 if ($len != length $scalado) {
8050 0         0 $self->Warn('Possibly corrupted APP4 SCALADO data', 1);
8051             }
8052 0         0 my %dirInfo = (
8053             Parent => $markerName,
8054             DataPt => \$scalado,
8055             );
8056 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::Scalado::Main');
8057 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8058 0         0 undef $scalado;
8059             }
8060             } elsif ($$segDataPt =~ /^Qualcomm Dual Camera Attributes/) {
8061 0         0 $dumpType = 'Qualcomm Dual Camera';
8062 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::Qualcomm::DualCamera');
8063 0         0 DirStart(\%dirInfo, 31);
8064 0         0 $dirInfo{DirName} = 'Qualcomm Dual Camera';
8065 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8066             } elsif ($$segDataPt =~ /^FPXR\0/) {
8067 0 0       0 next if $fast > 1; # skip processing for very fast
8068 0         0 $dumpType = 'FPXR';
8069 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::FlashPix::Main');
8070             # set flag if this is the last FPXR segment
8071 0   0     0 $dirInfo{LastFPXR} = not ($nextMarker==$marker and $$nextSegDataPt=~/^FPXR\0/),
8072             $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8073             } elsif ($$self{Make} eq 'DJI' and $$segDataPt =~ /^\xaa\x55\x12\x06/) {
8074 0         0 $dumpType = 'DJI ThermalParams';
8075 0         0 DirStart(\%dirInfo, 0, 0);
8076 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::DJI::ThermalParams');
8077 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8078             } elsif ($$self{Make} eq 'DJI' and $$segDataPt =~ /^(.{32})?.{32}\x2c\x01\x20\0/s) {
8079 0         0 $dumpType = 'DJI ThermalParams2';
8080 0 0       0 DirStart(\%dirInfo, $1 ? 32 : 0, 0);
8081 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::DJI::ThermalParams2');
8082 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8083             } elsif ($$self{Make} eq 'DJI' and $$segDataPt =~ /^.{32}\xaa\x55\x38\0/s) {
8084 0         0 $dumpType = 'DJI ThermalParams3';
8085 0         0 DirStart(\%dirInfo, 32, 0);
8086 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::DJI::ThermalParams3');
8087 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8088             } elsif ($$self{HasIJPEG} and $length >= 120) {
8089 1         4 $dumpType = 'InfiRay Factory';
8090 1         6 SetByteOrder('II');
8091 1         4 my $tagTablePtr = GetTagTable('Image::ExifTool::InfiRay::Factory');
8092 1         8 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8093             } elsif ($preview) {
8094             # continued Samsung S1060 preview from APP3
8095 0         0 $dumpType = 'PreviewImage';
8096 0         0 $preview .= $$segDataPt;
8097             }
8098             # (also seen "QTI Debug Metadata\0" segment in some newer Samsung images)
8099             # BenQ DC E1050 continues preview in APP5
8100 1 50 33     4 if ($preview and $nextMarker ne 0xe5) {
8101 0         0 $self->FoundTag('PreviewImage', $preview);
8102 0         0 undef $preview;
8103             }
8104             } elsif ($marker == 0xe5) { # APP5 (InfiRay, Ricoh "RMETA")
8105 21 100 33     120 if ($$segDataPt =~ /^RMETA\0/) {
    50          
    50          
    50          
    0          
8106             # (NOTE: apparently these may span multiple segments, but I haven't seen
8107             # a sample like this, so multi-segment support hasn't yet been implemented)
8108 20         43 $dumpType = 'Ricoh RMETA';
8109 20         71 DirStart(\%dirInfo, 6, 6);
8110 20         57 my $tagTablePtr = GetTagTable('Image::ExifTool::Ricoh::RMETA');
8111 20         70 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8112             } elsif ($$segDataPt =~ /^ssuniqueid\0/) {
8113 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::Samsung::APP5');
8114 0         0 $self->HandleTag($tagTablePtr, 'ssuniqueid', substr($$segDataPt, 11));
8115             } elsif ($$self{Make} eq 'DJI') {
8116 0         0 $dumpType = 'DJI ThermalCal';
8117 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::Main');
8118 0         0 $self->HandleTag($tagTablePtr, 'APP5', $$segDataPt);
8119             } elsif ($$self{HasIJPEG} and $length >= 38) {
8120 1         2 $dumpType = 'InfiRay Picture';
8121 1         3 SetByteOrder('II');
8122 1         3 my $tagTablePtr = GetTagTable('Image::ExifTool::InfiRay::Picture');
8123 1         2 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8124             } elsif ($preview) {
8125 0         0 $dumpType = 'PreviewImage';
8126 0         0 $preview .= $$segDataPt;
8127 0         0 $self->FoundTag('PreviewImage', $preview);
8128 0         0 undef $preview;
8129             }
8130             } elsif ($marker == 0xe6) { # APP6 (InfiRay, Toshiba EPPIM, NITF, HP_TDHD)
8131 38 100 33     198 if ($$segDataPt =~ /^EPPIM\0/) {
    100 33        
    50          
    100          
    50          
    50          
8132 18         20 undef $dumpType; # (will be dumped here)
8133 18         72 DirStart(\%dirInfo, 6, 6);
8134 18 50       61 if ($htmlDump) {
8135 0         0 $self->HDump($segPos-4, 10, 'APP6 EPPIM header');
8136 0         0 $dumpEnd = $segPos + $length;
8137             }
8138 18         50 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::EPPIM');
8139 18         65 $self->ProcessTIFF(\%dirInfo, $tagTablePtr);
8140             } elsif ($$segDataPt =~ /^NITF\0/) {
8141 18         31 $dumpType = 'NITF';
8142 18         52 SetByteOrder('MM');
8143 18         47 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::NITF');
8144 18         69 DirStart(\%dirInfo, 5);
8145 18         65 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8146             } elsif ($$segDataPt =~ /^TDHD\x01\0\0\0/ and $length > 12) {
8147             # HP Photosmart R837 APP6 "TDHD" segment
8148 0         0 $dumpType = 'TDHD';
8149 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::HP::TDHD');
8150             # (ignore first TDHD element because size includes 12-byte tag header)
8151 0         0 DirStart(\%dirInfo, 12);
8152 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8153             } elsif ($$segDataPt =~ /^GoPro\0/) {
8154             # GoPro segment
8155 1         2 $dumpType = 'GoPro';
8156 1         4 my $tagTablePtr = GetTagTable('Image::ExifTool::GoPro::GPMF');
8157 1         4 DirStart(\%dirInfo, 6);
8158 1         3 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8159             } elsif ($$segDataPt =~ /^DTAT\0\0.\{/s) {
8160 0         0 $dumpType = 'DJI_DTAT';
8161 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::Main');
8162 0         0 $self->HandleTag($tagTablePtr, 'APP6', $$segDataPt);
8163             } elsif ($$self{HasIJPEG} and $length >= 129) {
8164 1         2 $dumpType = 'InfiRay MixMode';
8165 1         2 SetByteOrder('II');
8166 1         2 my $tagTablePtr = GetTagTable('Image::ExifTool::InfiRay::MixMode');
8167 1         3 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8168             }
8169             } elsif ($marker == 0xe7) { # APP7 (InfiRay, Pentax, Huawei, Qualcomm)
8170 20 50 33     200 if ($$segDataPt =~ /^(PENTAX |RICOH)\0(II|MM)/) {
    50          
    50          
    100          
    50          
8171             # found in K-3 and Ricoh GR_IV images (is this multi-segment??)
8172 0         0 SetByteOrder($2);
8173 0         0 undef $dumpType; # (dump this ourself)
8174 0         0 my $hdrLen = length($1) + 3;
8175 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::Pentax::Main');
8176 0         0 DirStart(\%dirInfo, $hdrLen, 0);
8177 0         0 $dirInfo{DirName} = 'Pentax APP7';
8178 0 0       0 if ($htmlDump) {
8179 0         0 $self->HDump($segPos-4, 4, 'APP7 header', "Data size: $length bytes");
8180 0         0 $self->HDump($segPos, $hdrLen, 'Pentax header', 'APP7 data type: Pentax');
8181 0         0 $dumpEnd = $segPos + $length;
8182             }
8183 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8184             } elsif ($$segDataPt =~ /^HUAWEI\0\0(II|MM)/) {
8185 0         0 SetByteOrder($1);
8186 0         0 undef $dumpType; # (dump this ourself)
8187 0         0 my $hdrLen = 16;
8188 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::Unknown::Main');
8189 0         0 DirStart(\%dirInfo, $hdrLen, 8);
8190 0         0 $dirInfo{DirName} = 'Huawei APP7';
8191 0 0       0 if ($htmlDump) {
8192 0         0 $self->HDump($segPos-4, 4, 'APP7 header', "Data size: $length bytes");
8193 0         0 $self->HDump($segPos, $hdrLen, 'Huawei header', 'APP7 data type: Huawei');
8194 0         0 $dumpEnd = $segPos + $length;
8195             }
8196 0         0 $$self{SET_GROUP0} = 'APP7';
8197 0         0 $$self{SET_GROUP1} = 'Huawei';
8198 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8199 0         0 delete $$self{SET_GROUP0};
8200 0         0 delete $$self{SET_GROUP1};
8201             } elsif ($$segDataPt =~ /^DJI-DBG\0/) {
8202 0         0 $dumpType = 'DJI Info';
8203 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::DJI::Info');
8204 0         0 DirStart(\%dirInfo, 8, 0);
8205 0         0 $$self{SET_GROUP0} = 'APP7';
8206 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8207 0         0 delete $$self{SET_GROUP0};
8208             } elsif ($$segDataPt =~ /^\x1aQualcomm Camera Attributes/) {
8209             # found in HP iPAQ_VoiceMessenger
8210 19         39 $dumpType = 'Qualcomm';
8211 19         49 my $tagTablePtr = GetTagTable('Image::ExifTool::Qualcomm::Main');
8212 19         73 DirStart(\%dirInfo, 27);
8213 19         53 $dirInfo{DirName} = 'Qualcomm';
8214 19         85 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8215             } elsif ($$self{HasIJPEG} and $length >= 32) {
8216 1         2 $dumpType = 'InfiRay OpMode';
8217 1         3 SetByteOrder('II');
8218 1         2 my $tagTablePtr = GetTagTable('Image::ExifTool::InfiRay::OpMode');
8219 1         4 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8220             }
8221             } elsif ($marker == 0xe8) { # APP8 (InfiRay, SPIFF)
8222             # my sample SPIFF has 32 bytes of data, but spec states 30
8223 20 100 66     149 if ($$segDataPt =~ /^SPIFF\0/ and $length == 32) {
    50 33        
    0          
8224 19         38 $dumpType = 'SPIFF';
8225 19         50 DirStart(\%dirInfo, 6);
8226 19         51 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::SPIFF');
8227 19         69 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8228             } elsif ($$self{HasIJPEG} and $length >= 32) {
8229 1         2 $dumpType = 'InfiRay Isothermal';
8230 1         3 SetByteOrder('II');
8231 1         3 my $tagTablePtr = GetTagTable('Image::ExifTool::InfiRay::Isothermal');
8232 1         3 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8233             } elsif ($$segDataPt =~ /^SEAL\0/) {
8234 0         0 $dumpType = 'SEAL';
8235 0         0 DirStart(\%dirInfo, 5);
8236 0         0 $self->ProcessDirectory(\%dirInfo, GetTagTable("Image::ExifTool::XMP::SEAL"));
8237             }
8238             } elsif ($marker == 0xe9) { # APP9 (InfiRay, Media Jukebox)
8239 20 100 66     134 if ($$segDataPt =~ /^Media Jukebox\0/ and $length > 22) {
    50 33        
    0          
8240 19         41 $dumpType = 'MediaJukebox';
8241             # (start parsing after the "")
8242 19         67 DirStart(\%dirInfo, 22);
8243 19         50 $dirInfo{DirName} = 'MediaJukebox';
8244 19         145 require Image::ExifTool::XMP;
8245 19         86 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::MediaJukebox');
8246 19         100 $self->ProcessDirectory(\%dirInfo, $tagTablePtr, \&Image::ExifTool::XMP::ProcessXMP);
8247             } elsif ($$self{HasIJPEG} and $length >= 768) {
8248 1         3 $dumpType = 'InfiRay Sensor';
8249 1         2 SetByteOrder('II');
8250 1         3 my $tagTablePtr = GetTagTable('Image::ExifTool::InfiRay::Sensor');
8251 1         4 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8252             } elsif ($$segDataPt =~ /^SEAL\0/) {
8253 0         0 $dumpType = 'SEAL';
8254 0         0 DirStart(\%dirInfo, 5);
8255 0         0 $self->ProcessDirectory(\%dirInfo, GetTagTable("Image::ExifTool::XMP::SEAL"));
8256             }
8257             } elsif ($marker == 0xea) { # APP10 (PhotoStudio Unicode comments, HDR gain curve)
8258 19 50       80 if ($$segDataPt =~ /^UNICODE\0/) {
    0          
8259 19         27 $dumpType = 'PhotoStudio';
8260 19         94 my $comment = $self->Decode(substr($$segDataPt,8), 'UTF16', 'MM');
8261 19         77 $self->FoundTag('Comment', $comment);
8262             } elsif ($$segDataPt =~ /^AROT\0\0.{4}/s) {
8263 0         0 $dumpType = 'AROT', # (HDR gain curve? PH guess)
8264             $useJpegMain = 1;
8265             }
8266             } elsif ($marker == 0xeb) { # APP11 (JPEG-HDR, JUMBF)
8267 38 100 33     244 if ($$segDataPt =~ /^HDR_RI /) {
    50          
8268 19         29 $dumpType = 'JPEG-HDR';
8269 19         44 my $dataPt = $segDataPt;
8270 19 50       52 if (defined $combinedSegData) {
8271 0 0       0 if ($$segDataPt =~ /~\0/g) {
8272 0         0 $combinedSegData .= substr($$segDataPt,pos($$segDataPt));
8273             } else {
8274 0         0 $self->Warn('Invalid format for JPEG-HDR extended segment');
8275             }
8276 0         0 $dataPt = \$combinedSegData;
8277             }
8278 19 50 33     100 if ($nextMarker == $marker and $$nextSegDataPt =~ /^HDR_RI /) {
8279 0 0       0 $combinedSegData = $$segDataPt unless defined $combinedSegData;
8280             } else {
8281 19         47 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::HDR');
8282 19         61 my %dirInfo = ( DataPt => $dataPt );
8283 19         67 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8284 19         51 undef $combinedSegData;
8285             }
8286             } elsif ($$segDataPt =~ /^(JP..)/s and length($$segDataPt) >= 16) {
8287             # JUMBF extension marker
8288 19         40 my $hdr = $1;
8289 19         31 $dumpType = 'JUMBF';
8290 19         47 SetByteOrder('MM');
8291             # (sequence should start from 1, but some software incorrectly writes 0)
8292 19         45 my $seq = Get32u($segDataPt, 4);
8293 19         49 my $len = Get32u($segDataPt, 8);
8294 19         46 my $type = substr($$segDataPt, 12, 4);
8295             # a Microsoft bug writes $len and $type incorrectly as little-endian
8296 19 50       70 if ($type eq 'bmuj') {
8297 0         0 $self->Warn('Wrong byte order in C2PA APP11 JUMBF header');
8298 0         0 $type = 'jumb';
8299 0         0 $len = unpack('x8V', $$segDataPt);
8300             # fix the header
8301 0         0 substr($$segDataPt, 8, 8) = Set32u($len) . $type;
8302             }
8303 19         31 my $hdrLen;
8304 19 50 33     68 if ($len == 1 and length($$segDataPt) >= 24) {
8305             # (haven't seen this with the Microsoft bug)
8306 0         0 $len = Get64u($$segDataPt, 16);
8307 0         0 $hdrLen = 16;
8308             } else {
8309 19         33 $hdrLen = 8;
8310             }
8311 19 50       98 $jumbfChunk{$type} or $jumbfChunk{$type} = [ '' ];
8312 19 50 33     95 if ($len < $hdrLen) {
    50          
8313 0         0 $self->Warn('Invalid JUMBF segment');
8314             } elsif (defined $jumbfChunk{$type}[$seq] and length $jumbfChunk{$type}[$seq]) {
8315 0         0 $self->Warn('Duplicate JUMBF sequence number');
8316             } else {
8317 19 50       57 $seq or $self->Warn('Incorrect JUMBF sequence numbering (should start from 0, not 1)');
8318             # add to list of JUMBF chunks
8319 19         75 $jumbfChunk{$type}[$seq] = substr($$segDataPt, 8 + $hdrLen);
8320             # check to see if we have a complete JUMBF box
8321 19         30 my $size = $hdrLen;
8322 19         35 foreach (@{$jumbfChunk{$type}}) {
  19         49  
8323 38 50       77 defined $_ or $size = 0, last;
8324 38         61 $size += length $_;
8325             }
8326 19 50       57 if ($size == $len) {
8327 19         38 my $buff = join '', substr($$segDataPt,8,$hdrLen), @{$jumbfChunk{$type}};
  19         73  
8328 19         37 $dirInfo{DataPt} = \$buff;
8329 19         40 $dirInfo{DataPos} = $segPos + 8; # (shows correct offsets for single-segment JUMBF)
8330 19         37 $dirInfo{DataLen} = $dirInfo{DirLen} = $size;
8331 19         40 $dirInfo{DirName} = 'JUMBF';
8332 19         48 my $tagTablePtr = GetTagTable('Image::ExifTool::Jpeg2000::Main');
8333 19         80 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8334 19         82 delete $jumbfChunk{$type};
8335             }
8336             }
8337             }
8338             } elsif ($marker == 0xec) { # APP12 (Ducky, Picture Info)
8339 40 100       165 if ($$segDataPt =~ /^Ducky/) {
8340 21         45 $dumpType = 'Ducky';
8341 21         70 DirStart(\%dirInfo, 5);
8342 21         67 my $tagTablePtr = GetTagTable('Image::ExifTool::APP12::Ducky');
8343 21         111 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8344             } else {
8345 19         61 my $tagTablePtr = GetTagTable('Image::ExifTool::APP12::PictureInfo');
8346 19 50       73 $self->ProcessDirectory(\%dirInfo, $tagTablePtr) and $dumpType = 'Picture Info';
8347             }
8348             } elsif ($marker == 0xed) { # APP13 (Photoshop, Adobe_CM)
8349 85         131 my $isOld;
8350 85 100 50     1178 if ($$segDataPt =~ /^$psAPP13hdr/ or ($$segDataPt =~ /^$psAPP13old/ and $isOld=1)) {
    50 66        
8351 66         130 $dumpType = 'Photoshop';
8352             # add this data to the combined data if it exists
8353 66         112 my $dataPt = $segDataPt;
8354 66 50       183 if (defined $combinedSegData) {
8355 0         0 $combinedSegData .= substr($$segDataPt,length($psAPP13hdr));
8356 0         0 $dataPt = \$combinedSegData;
8357             }
8358             # peek ahead to see if the next segment is photoshop data too
8359 66 50 66     347 if ($nextMarker == $marker and $$nextSegDataPt =~ /^$psAPP13hdr/) {
8360             # initialize combined data if necessary
8361 0 0       0 $combinedSegData = $$segDataPt unless defined $combinedSegData;
8362             # (will handle the Photoshop data the next time around)
8363             } else {
8364 66 50       153 my $hdrLen = $isOld ? 27 : 14;
8365             # process APP13 Photoshop record
8366 66         165 my $tagTablePtr = GetTagTable('Image::ExifTool::Photoshop::Main');
8367 66         378 my %dirInfo = (
8368             DataPt => $dataPt,
8369             DataPos => $segPos,
8370             DataLen => length $$dataPt,
8371             DirStart => $hdrLen, # directory starts after identifier
8372             DirLen => length($$dataPt) - $hdrLen,
8373             Parent => $markerName,
8374             );
8375 66         267 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8376 66         230 undef $combinedSegData;
8377             }
8378             } elsif ($$segDataPt =~ /^Adobe_CM/) {
8379 19         39 $dumpType = 'Adobe_CM';
8380 19         48 SetByteOrder('MM');
8381 19         45 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::AdobeCM');
8382 19         77 DirStart(\%dirInfo, 8);
8383 19         60 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8384             }
8385             } elsif ($marker == 0xee) { # APP14 (Adobe)
8386 45 50       193 if ($$segDataPt =~ /^Adobe/) {
8387             # extract as a block if requested, or if copying tags from file
8388 45 100 100     322 if ($$req{adobe} or
      66        
8389             # (not extracted normally, so check TAGS_FROM_FILE)
8390             ($$self{TAGS_FROM_FILE} and not $$self{EXCL_TAG_LOOKUP}{adobe}))
8391             {
8392 15         50 $self->FoundTag('Adobe', $$segDataPt);
8393             }
8394 45         86 $dumpType = 'Adobe';
8395 45         237 SetByteOrder('MM');
8396 45         110 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::Adobe');
8397 45         170 DirStart(\%dirInfo, 5);
8398 45         146 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8399             }
8400             } elsif ($marker == 0xef) { # APP15 (GraphicConverter)
8401 19 50 33     144 if ($$segDataPt =~ /^Q\s*(\d+)/ and $length == 4) {
8402 19         39 $dumpType = 'GraphicConverter';
8403 19         50 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::GraphConv');
8404 19         62 $self->HandleTag($tagTablePtr, 'Q', $1);
8405             }
8406             } elsif ($marker == 0xfe) { # COM (JPEG comment)
8407 27         62 $dumpType = 'Comment';
8408 27         90 $$segDataPt =~ s/\0+$//; # some dumb softwares add null terminators
8409 27         98 $self->FoundTag('Comment', $$segDataPt);
8410             } elsif ($marker == 0x64) { # CME (J2C comment and extension)
8411 2         3 $dumpType = 'Comment';
8412 2 50       6 if ($length > 2) {
8413 2         3 my $reg = unpack('n', $$segDataPt); # get registration value
8414 2         7 my $val = substr($$segDataPt, 2);
8415 2 50       8 $val = $self->Decode($val, 'Latin') if $reg == 1;
8416             # (actually an extension for $reg==65535, but store as binary comment)
8417 2 50 33     13 $self->FoundTag('Comment', ($reg==0 or $reg==65535) ? \$val : $val);
8418             }
8419             } elsif ($marker == 0x51) { # SIZ (J2C)
8420 1         4 my ($w, $h) = unpack('x2N2', $$segDataPt);
8421 1 50       3 unless ($gotSize) {
8422 1         1 $gotSize = 1;
8423 1         3 $self->FoundTag('ImageWidth', $w);
8424 1         2 $self->FoundTag('ImageHeight', $h);
8425             }
8426             } elsif (($marker & 0xf0) != 0xe0) {
8427 502         877 $dumpType = "$markerName segment";
8428 502         820 $desc = "[JPEG $markerName]"; # (other known JPEG segments)
8429             }
8430 1225 100       2551 if (defined $dumpType) {
8431 1169 50       2274 if ($useJpegMain) {
8432 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::Main');
8433 0         0 $self->HandleTag($tagTablePtr, $markerName, $$segDataPt);
8434             }
8435 1169 50 33     3431 if (not $dumpType and ($$options{Unknown} or $$options{Validate})) {
      66        
8436 0 0       0 my $str = ($$segDataPt =~ /^([\x20-\x7e]{1,20})\0/) ? " '${1}'" : '';
8437 0 0       0 $xtra = 'segment' unless $xtra;
8438 0         0 $self->Warn("Unknown $markerName$str $xtra", 1);
8439             }
8440 1169 50       2083 if ($htmlDump) {
8441 0 0       0 $desc or $desc = $markerName . ($dumpType ? " $dumpType" : '') . ' segment';
    0          
8442 0         0 $self->HDump($segPos-4, $length+4, $desc, $tip, 0x08);
8443 0         0 $dumpEnd = $segPos + $length;
8444             }
8445             }
8446 1225         3910 undef $$segDataPt;
8447             }
8448             # print verbose hash message if necessary
8449 250 50 33     784 print $out "${indent}(ImageDataHash: $hashsize bytes of JPEG image data)\n" if $hashsize and $verbose;
8450             # calculate JPEGDigest if requested
8451 250 100       659 if (@dqt) {
8452 1         1739 require Image::ExifTool::JPEGDigest;
8453 1         7 Image::ExifTool::JPEGDigest::Calculate($self, \@dqt, $subSampling);
8454             }
8455             # issue necessary warnings
8456 250 50       547 $self->Warn('Invalid JUMBF size or missing JUMBF chunk') if %jumbfChunk;
8457 250 50       562 $self->Warn('Incomplete ICC_Profile record', 1) if defined $iccChunkCount;
8458 250 50       664 $self->Warn('Incomplete FLIR record', 1) if defined $flirCount;
8459 250 50       683 $self->Warn('Error reading PreviewImage', 1) if $$self{PreviewError};
8460 250 50       594 $success or $self->Warn('JPEG format error');
8461 250 50       628 pop @$path if @$path > $pn;
8462 250         2252 return 1;
8463             }
8464              
8465             #------------------------------------------------------------------------------
8466             # Extract metadata from an Exiv2 EXV file
8467             # Inputs: 0) ExifTool object reference, 1) dirInfo ref with RAF set
8468             # Returns: 1 on success, 0 if this wasn't a valid JPEG file
8469             sub ProcessEXV($$)
8470             {
8471 2     2 0 5 my ($self, $dirInfo) = @_;
8472 2         9 return $self->ProcessJPEG($dirInfo);
8473             }
8474              
8475             #------------------------------------------------------------------------------
8476             # Process EXIF file
8477             # Inputs/Returns: same as ProcessTIFF
8478             sub ProcessEXIF($$;$)
8479             {
8480 2     2 0 5 my ($self, $dirInfo, $tagTablePtr) = @_;
8481 2         8 return $self->ProcessTIFF($dirInfo, $tagTablePtr);
8482             }
8483              
8484             #------------------------------------------------------------------------------
8485             # Process TIFF data (wrapper for DoProcessTIFF to allow re-entry)
8486             # Inputs: 0) ExifTool object ref, 1) dirInfo ref, 2) optional tag table ref
8487             # Returns: 1 if this looked like a valid EXIF block, 0 otherwise, or -1 on write error
8488             sub ProcessTIFF($$;$)
8489             {
8490 502     502 0 1212 my ($self, $dirInfo, $tagTablePtr) = @_;
8491 502         1050 my $exifData = $$self{EXIF_DATA};
8492 502         830 my $exifPos = $$self{EXIF_POS};
8493 502         1998 my $rtnVal = $self->DoProcessTIFF($dirInfo, $tagTablePtr);
8494             # restore original EXIF information (in case ProcessTIFF is nested)
8495 502 100       1429 if (defined $exifData) {
8496 108         245 $$self{EXIF_DATA} = $exifData;
8497 108         193 $$self{EXIF_POS} = $exifPos;
8498             }
8499 502         1976 return $rtnVal;
8500             }
8501              
8502             #------------------------------------------------------------------------------
8503             # Process TIFF as a sub-document
8504             # Inputs: 0) ExifTool object ref, 1) dirInfo ref, 2) optional tag table ref
8505             # Returns: 1 if this looked like a valid EXIF block, 0 otherwise, or -1 on write error
8506             sub ProcessSubTIFF($$;$)
8507             {
8508 0     0 0 0 my ($self, $dirInfo, $tagTablePtr) = @_;
8509 0         0 $$self{DOC_NUM} = ++$$self{DOC_COUNT};
8510 0         0 my $rtnVal = $self->ProcessTIFF($dirInfo, $tagTablePtr);
8511 0         0 delete $$self{DOC_NUM};
8512 0         0 return $rtnVal;
8513             }
8514              
8515             #------------------------------------------------------------------------------
8516             # Process TIFF data
8517             # Inputs: 0) ExifTool object ref, 1) dirInfo ref, 2) optional tag table ref
8518             # Returns: 1 if this looked like a valid EXIF block, 0 otherwise, or -1 on write error
8519             sub DoProcessTIFF($$;$)
8520             {
8521 502     502 0 1025 my ($self, $dirInfo, $tagTablePtr) = @_;
8522 502         979 my $dataPt = $$dirInfo{DataPt};
8523 502   100     1544 my $fileType = $$dirInfo{Parent} || '';
8524 502         891 my $raf = $$dirInfo{RAF};
8525 502   100     1406 my $base = $$dirInfo{Base} || 0;
8526 502         948 my $outfile = $$dirInfo{OutFile};
8527 502         895 my ($err, $sig, $canonSig, $otherSig);
8528              
8529             # attempt to read TIFF header
8530 502 100 100     2431 if ($raf) {
    100          
    50          
8531 47         140 $$self{EXIF_DATA} = '';
8532 47 100       143 if ($outfile) {
8533 14 50       72 $raf->Seek(0, 0) or return 0;
8534 14 50       57 if ($base) {
8535 0 0       0 $raf->Read($$dataPt, $base) == $base or return 0;
8536 0 0       0 Write($outfile, $$dataPt) or $err = 1;
8537             }
8538             } else {
8539 33 50       99 $raf->Seek($base, 0) or return 0;
8540             }
8541             # extract full EXIF block (for block copy) from EXIF file
8542 47 100       152 my $amount = $fileType eq 'EXIF' ? 65536 * 8 : 8;
8543 47         157 my $n = $raf->Read($$self{EXIF_DATA}, $amount);
8544 47 100       153 if ($n < 8) {
8545 1 50 33     11 return 0 if $n or not $outfile or $fileType ne 'EXIF';
      33        
8546             # create EXIF file from scratch
8547 1         2 delete $$self{EXIF_DATA};
8548 1         4 undef $raf;
8549             }
8550 47 100       137 if ($n > 8) {
8551 2         7 $raf->Seek(8, 0);
8552 2 50       9 if ($n == $amount) {
8553 0         0 $$self{EXIF_DATA} = substr($$self{EXIF_DATA}, 0, 8);
8554 0         0 $self->Warn('EXIF too large to extract as a block'); #(shouldn't happen)
8555             }
8556             }
8557             } elsif ($dataPt and length $$dataPt) {
8558             # save a copy of the EXIF data
8559 411   100     1157 my $dirStart = $$dirInfo{DirStart} || 0;
8560 411   66     1079 my $dirLen = $$dirInfo{DirLen} || (length($$dataPt) - $dirStart);
8561 411 50 33     1202 if ($dirLen > 0 or not $outfile) {
8562 411         2203 $$self{EXIF_DATA} = substr($$dataPt, $dirStart, $dirLen);
8563             } else {
8564 0         0 delete $$self{EXIF_DATA}; # create from scratch;
8565             }
8566 411 50 66     1569 $self->VerboseDir('TIFF') if $$self{OPTIONS}{Verbose} and length($$self{INDENT}) > 2;
8567             } elsif ($outfile) {
8568 44         128 delete $$self{EXIF_DATA}; # create from scratch
8569             } else {
8570 0         0 $$self{EXIF_DATA} = '';
8571             }
8572 502 100       1299 unless (defined $$self{EXIF_DATA}) {
8573             # set default byte order for creating new GPS in CR3 images
8574 45         69 my $defaultByteOrder;
8575 45 50 33     334 if ($$dirInfo{DirName} and $$dirInfo{DirName} eq 'GPS') {
8576 0         0 $defaultByteOrder = $$self{SaveExifByteOrder};
8577             }
8578             # create TIFF information from scratch
8579 45 100       231 if ($self->SetPreferredByteOrder($defaultByteOrder) eq 'MM') {
8580 36         111 $$self{EXIF_DATA} = "MM\0\x2a\0\0\0\x08";
8581             } else {
8582 9         26 $$self{EXIF_DATA} = "II\x2a\0\x08\0\0\0";
8583             }
8584             }
8585 502         1249 $$self{EXIF_POS} = $base + $$self{BASE};
8586 502 100       1706 $$self{FIRST_EXIF_POS} = $$self{EXIF_POS} unless defined $$self{FIRST_EXIF_POS};
8587 502         996 $dataPt = \$$self{EXIF_DATA};
8588              
8589             # set byte ordering
8590 502         1320 my $byteOrder = substr($$dataPt,0,2);
8591 502 100       1327 SetByteOrder($byteOrder) or return 0;
8592              
8593             # verify the byte ordering
8594 496         1359 my $identifier = Get16u($dataPt, 2);
8595             # identifier is 0x2a for TIFF (but 0x4f52, 0x5352 or ?? for ORF)
8596             # no longer do this because various files use different values
8597             # (TIFF=0x2a, RW2/RWL=0x55, HDP=0xbc, BTF=0x2b, ORF=0x4f52/0x5352/0x????)
8598             # return 0 unless $identifier == 0x2a;
8599 496 50 66     1955 $self->Warn('Invalid magic number in EXIF TIFF header') if $fileType eq 'APP1' and $identifier != 0x2a;
8600              
8601             # get offset to IFD0
8602 496 50       1347 return 0 if length $$dataPt < 8;
8603 496         1164 my $offset = Get32u($dataPt, 4);
8604 496 50       1361 $offset >= 8 or return 0;
8605              
8606 496 100       1335 if ($raf) {
8607             # check for canon or EXIF signature
8608             # (Canon CR2 images should have an offset of 16, but it may be
8609             # greater if edited by PhotoMechanic)
8610 40 100 100     289 if ($identifier == 0x2a and $offset >= 16) {
    100 66        
    100          
    50          
8611 17 50       48 $raf->Read($sig, 8) == 8 or return 0;
8612 17         45 $$dataPt .= $sig;
8613 17 100       91 if ($sig =~ /^(CR\x02\0|\xba\xb0\xac\xbb|ExifMeta)/) {
8614 10 100       34 if ($sig eq 'ExifMeta') {
8615 1         6 $self->SetFileType($fileType = 'EXIF');
8616 1         3 $otherSig = $sig;
8617             } else {
8618 9 50       36 $fileType = $sig =~ /^CR/ ? 'CR2' : 'Canon 1D RAW';
8619 9         19 $canonSig = $sig;
8620             }
8621 10 50       40 $self->HDump($base+8, 8, "[$fileType header]") if $$self{HTML_DUMP};
8622             }
8623             } elsif ($identifier == 0x55 and $fileType =~ /^(RAW|RW2|RWL|TIFF)$/) {
8624             # panasonic RAW, RW2 or RWL file
8625 3         7 my $magic;
8626             # test for RW2/RWL magic number
8627 3 50 33     14 if ($offset >= 0x18 and $raf->Read($magic, 16) and
      33        
8628             $magic eq "\x88\xe7\x74\xd8\xf8\x25\x1d\x4d\x94\x7a\x6e\x77\x82\x2b\x5d\x6a")
8629             {
8630 3 50       11 $fileType = 'RW2' unless $fileType eq 'RWL';
8631 3 50       12 $self->HDump($base + 8, 16, '[RW2/RWL header]') if $$self{HTML_DUMP};
8632 3         7 $otherSig = $magic; # save signature for writing
8633             } else {
8634 0         0 $fileType = 'RAW';
8635             }
8636 3         28 $tagTablePtr = GetTagTable('Image::ExifTool::PanasonicRaw::Main');
8637             } elsif ($fileType eq 'TIFF') {
8638 13 50 33     95 if ($identifier == 0x2b) {
    50 33        
    50          
    50          
8639             # this looks like a BigTIFF image
8640 0         0 $raf->Seek(0);
8641 0         0 require Image::ExifTool::BigTIFF;
8642 0         0 my $result = Image::ExifTool::BigTIFF::ProcessBTF($self, $dirInfo);
8643 0 0       0 if ($result) {
8644 0 0       0 $self->FoundTag(PageCount => $$self{PageCount}) if $$self{MultiPage};
8645 0         0 return 1;
8646             }
8647             } elsif ($identifier == 0x4f52 or $identifier == 0x5352) {
8648             # Olympus ORF image (set FileType now because base type is 'ORF')
8649 0         0 $self->SetFileType($fileType = 'ORF');
8650             } elsif ($identifier == 0x4352) {
8651 0         0 $fileType = 'DCP';
8652             } elsif ($byteOrder eq 'II' and ($identifier & 0xff) == 0xbc) {
8653 0         0 $fileType = 'HDP'; # Windows HD Photo file
8654             # check version number
8655 0         0 my $ver = Get8u($dataPt, 3);
8656 0 0       0 if ($ver > 1) {
8657 0         0 $self->Error("Windows HD Photo version $ver files not yet supported");
8658 0         0 return 1;
8659             }
8660             }
8661             } elsif ($fileType eq 'ARW') {
8662 0         0 $$self{LOW_PRIORITY_DIR}{IFD1} = 1; # lower priority of IFD1 tags in ARW files
8663             }
8664             # we have a valid TIFF (or whatever) file
8665 40 100 66     223 if ($fileType and not $$self{VALUE}{FileType}) {
8666 38         85 my $lookup = $fileTypeLookup{$fileType};
8667 38 50 33     143 $lookup = $fileTypeLookup{$lookup} unless ref $lookup or not $lookup;
8668             # use file extension to pre-determine type if extension is TIFF-based or type is RAW
8669 38 50       151 my $baseType = $lookup ? (ref $$lookup[0] ? $$lookup[0][0] : $$lookup[0]) : '';
    50          
8670 38 100 66     148 my $t = ($baseType eq 'TIFF' or $fileType =~ /RAW/) ? $fileType : undef;
8671 38         172 $self->SetFileType($t);
8672             }
8673             # don't process file if FastScan > 2
8674 40 50 66     216 return 1 if not $outfile and $$self{OPTIONS}{FastScan} and $$self{OPTIONS}{FastScan} > 2;
      33        
8675             }
8676             # (accommodate CR3 images which have a TIFF directory with ExifIFD at the top level)
8677 496 100 100     2777 my $ifdName = ($$dirInfo{DirName} and $$dirInfo{DirName} =~ /^(ExifIFD|GPS)$/) ? $1 : 'IFD0';
8678 496 100 100     2312 if (not $tagTablePtr or $$tagTablePtr{GROUPS}{0} eq 'EXIF') {
    100          
8679 420 100       1575 $self->FoundTag('ExifByteOrder', $byteOrder) unless $outfile;
8680 420         1028 $$self{ExifByteOrder} = $byteOrder;
8681             } elsif ($$tagTablePtr{GROUPS}{0} eq 'MakerNotes') { # (for writing CR3 maker notes)
8682 19         62 $ifdName = $$tagTablePtr{GROUPS}{0};
8683             } else {
8684 57         116 $ifdName = $$tagTablePtr{GROUPS}{1};
8685             }
8686 496 50       1373 if ($$self{HTML_DUMP}) {
8687 0 0       0 my $tip = sprintf("Byte order: %s endian\nIdentifier: 0x%.4x\n$ifdName offset: 0x%.4x",
8688             ($byteOrder eq 'II') ? 'Little' : 'Big', $identifier, $offset);
8689 0         0 $self->HDump($base, 8, 'TIFF header', $tip, 0);
8690             }
8691             # remember where we found the TIFF data (APP1, APP3, TIFF, NEF, etc...)
8692 496         2066 $$self{TIFF_TYPE} = $fileType;
8693              
8694             # get reference to the main EXIF table
8695 496 100       1419 $tagTablePtr or $tagTablePtr = GetTagTable('Image::ExifTool::Exif::Main');
8696              
8697             # build directory information hash
8698             my %dirInfo = (
8699             Base => $base,
8700             DataPt => $dataPt,
8701             DataLen => length $$dataPt,
8702             DataPos => 0,
8703             DirStart => $offset,
8704             DirLen => length($$dataPt) - $offset,
8705             RAF => $raf,
8706             DirName => $ifdName,
8707             Parent => $fileType,
8708             ImageData=> 'Main', # set flag to get information to copy main image data later
8709             Multi => $$dirInfo{Multi},
8710 496         4909 );
8711              
8712             # extract information from the image
8713 496 100       1223 unless ($outfile) {
8714             # process the directory
8715 370         1372 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8716             # process GeoTiff information if available
8717 370 100       1436 if ($$self{VALUE}{GeoTiffDirectory}) {
8718 7         806 require Image::ExifTool::GeoTiff;
8719 7         30 Image::ExifTool::GeoTiff::ProcessGeoTiff($self);
8720             }
8721             # process information in recognized trailers
8722 370 100       989 if ($raf) {
8723 27         136 my $trailInfo = $self->IdentifyTrailer($raf);
8724 27 100       84 if ($trailInfo) {
8725             # scan to find AFCP if necessary (Note: we are scanning
8726             # from a random file position in the TIFF)
8727 3         7 $$trailInfo{ScanForTrailer} = 1;
8728 3         17 $self->ProcessTrailers($trailInfo);
8729             }
8730             # dump any other known trailer (eg. A100 RAW Data)
8731 27 0 33     105 if ($$self{HTML_DUMP} and $$self{KnownTrailer}) {
8732 0         0 my $known = $$self{KnownTrailer};
8733 0         0 $raf->Seek(0, 2);
8734 0         0 my $len = $raf->Tell() - $$known{Start};
8735 0 0       0 $len -= $$trailInfo{Offset} if $trailInfo; # account for other trailers
8736 0 0       0 $self->HDump($$known{Start}, $len, "[$$known{Name}]") if $len > 0;
8737             }
8738             }
8739             # update FileType if necessary now that we know more about the file
8740 370 50 66     1259 if ($$self{DNGVersion} and $$self{FILE_TYPE} eq 'TIFF' and $$self{FileType} !~ /^(DNG|GPR)$/) {
      66        
8741             # override whatever FileType we set since we now know it is DNG
8742 0         0 $self->OverrideFileType($$self{TIFF_TYPE} = 'DNG');
8743             }
8744 370 100 33     1654 if ($$self{TIFF_TYPE} eq 'TIFF') {
    50          
8745 10 50       30 $self->FoundTag(PageCount => $$self{PageCount}) if $$self{MultiPage};
8746             } elsif ($$self{TIFF_TYPE} eq 'NRW' and $$self{VALUE}{NEFLinearizationTable}) {
8747             # fix NEF type if misidentified as NRW
8748 0         0 $self->OverrideFileType($$self{TIFF_TYPE} = 'NEF');
8749             }
8750 370 0 33     1044 if ($$self{ImageDataHash} and $$self{A100DataOffset} and $raf->Seek($$self{A100DataOffset},0)) {
      0        
8751 0         0 $self->ImageDataHash($raf, undef, 'A100');
8752             }
8753 370         2041 return 1;
8754             }
8755             #
8756             # rewrite the image
8757             #
8758 126 100       440 if ($$dirInfo{NoTiffEnd}) {
8759 1         3 delete $$self{TIFF_END};
8760             } else {
8761             # initialize TIFF_END so it will be updated by WriteExif()
8762 125         325 $$self{TIFF_END} = 0;
8763             }
8764 126 100       346 if ($canonSig) {
8765             # write Canon CR2 specially because it has a header we want to preserve,
8766             # and possibly trailers added by the Canon utilities and/or PhotoMechanic
8767 3         9 $dirInfo{OutFile} = $outfile;
8768 3         22 require Image::ExifTool::CanonRaw;
8769 3 50       21 Image::ExifTool::CanonRaw::WriteCR2($self, \%dirInfo, $tagTablePtr) or $err = 1;
8770             } else {
8771             # write TIFF header (8 bytes [plus optional signature] followed by IFD)
8772 123 100       496 if ($fileType eq 'EXIF') {
    100          
8773 3         24 $otherSig = 'ExifMeta'; # force this signature for all EXIF files
8774             } elsif (not defined $otherSig) {
8775 119         223 $otherSig = '';
8776             }
8777 123         255 my $offset = 8 + length($otherSig);
8778             # construct tiff header
8779 123         425 my $header = substr($$dataPt, 0, 4) . Set32u($offset) . $otherSig;
8780 123         342 $dirInfo{NewDataPos} = $offset;
8781 123         286 $dirInfo{HeaderPtr} = \$header;
8782             # preserve padding between image data blocks in ORF images
8783             # (otherwise dcraw has problems because it assumes fixed block spacing)
8784 123 100 66     560 $dirInfo{PreserveImagePadding} = 1 if $fileType eq 'ORF' or $identifier != 0x2a;
8785 123         920 my $newData = $self->WriteDirectory(\%dirInfo, $tagTablePtr);
8786 123 50       581 if (not defined $newData) {
    100          
8787 0         0 $err = 1;
8788             } elsif (length($newData)) {
8789             # update header length in case more was added
8790 117         225 my $hdrLen = length $header;
8791 117 100       399 if ($hdrLen != 8) {
8792 5         18 Set32u($hdrLen, \$header, 4);
8793             # also update preview fixup if necessary
8794 5         8 my $pi = $$self{PREVIEW_INFO};
8795 5 0 33     13 $$pi{Fixup}{Start} += $hdrLen - 8 if $pi and $$pi{Fixup};
8796             }
8797 117 50 33     521 if ($$self{TIFF_TYPE} eq 'ARW' and not $err) {
8798             # write any required ARW trailer and patch other ARW quirks
8799 0         0 require Image::ExifTool::Sony;
8800             my $errStr = Image::ExifTool::Sony::FinishARW($self, $dirInfo, \$newData,
8801 0         0 $dirInfo{ImageData});
8802 0 0       0 $errStr and $self->Error($errStr);
8803 0         0 delete $dirInfo{ImageData}; # (was copied by FinishARW)
8804             } else {
8805 117 50       516 Write($outfile, $header, $newData) or $err = 1;
8806             }
8807 117         314 undef $newData; # free memory
8808             }
8809             # copy over image data now if necessary
8810 123 100 66     584 if (ref $dirInfo{ImageData} and not $err) {
8811 10 50       61 $self->CopyImageData($dirInfo{ImageData}, $outfile) or $err = 1;
8812 10         39 delete $dirInfo{ImageData};
8813             }
8814             }
8815             # make local copy of TIFF_END now (it may be reset when processing trailers)
8816 126         281 my $tiffEnd = $$self{TIFF_END};
8817 126         251 delete $$self{TIFF_END};
8818              
8819             # rewrite trailers if they exist
8820 126 100 100     530 if ($raf and $tiffEnd and not $err) {
      66        
8821 12         25 my ($buf, $trailInfo);
8822 12 50       41 $raf->Seek(0, 2) or $err = 1;
8823 12         44 my $extra = $raf->Tell() - $tiffEnd;
8824             # check for trailer and process if possible
8825 12         22 for (;;) {
8826 12 100       37 last unless $extra > 12;
8827 3         10 $raf->Seek($tiffEnd); # seek back to end of image
8828 3         16 $trailInfo = $self->IdentifyTrailer($raf);
8829 3 50       9 last unless $trailInfo;
8830 0         0 my $tbuf = '';
8831 0         0 $$trailInfo{OutFile} = \$tbuf; # rewrite trailer(s)
8832 0         0 $$trailInfo{ScanForTrailer} = 1; # scan for AFCP if necessary
8833 0         0 $$self{TrailerStart} = $tiffEnd;
8834             # rewrite all trailers to buffer
8835 0 0       0 unless ($self->ProcessTrailers($trailInfo)) {
8836 0         0 undef $trailInfo;
8837 0         0 $err = 1;
8838 0         0 last;
8839             }
8840             # calculate unused bytes before trailer
8841 0         0 $extra = $$trailInfo{DataPos} - $tiffEnd;
8842 0         0 last; # yes, the 'for' loop was just a cheap 'goto'
8843             }
8844             # ignore a single zero byte if used for padding
8845 12 100 100     51 if ($extra > 0 and $tiffEnd & 0x01) {
8846 1 50       2 $raf->Seek($tiffEnd, 0) or $err = 1;
8847 1 50       3 $raf->Read($buf, 1) or $err = 1;
8848 1 50 33     11 defined $buf and $buf eq "\0" and --$extra, ++$tiffEnd;
8849             }
8850 12 100       42 if ($extra > 0) {
8851 3         9 my $known = $$self{KnownTrailer};
8852 3 50 33     18 if ($$self{DEL_GROUP}{Trailer} and not $known) {
    50          
8853 0         0 $self->VPrint(0, " Deleting unknown trailer ($extra bytes)\n");
8854 0         0 ++$$self{CHANGED};
8855             } elsif ($known) {
8856 0         0 $self->VPrint(0, " Copying $$known{Name} ($extra bytes)\n");
8857 0 0       0 $raf->Seek($tiffEnd, 0) or $err = 1;
8858 0 0       0 CopyBlock($raf, $outfile, $extra) or $err = 1;
8859             } else {
8860 3 50       7 $raf->Seek($tiffEnd, 0) or $err = 1;
8861             # preserve unknown trailer only if it contains non-null data
8862             # (Photoshop CS adds a trailer with 2 null bytes)
8863 3         6 my $size = $extra;
8864 3         6 for (;;) {
8865 3 50       9 my $n = $size > 65536 ? 65536 : $size;
8866 3 50       8 $raf->Read($buf, $n) == $n or $err = 1, last;
8867 3 50       19 if ($buf =~ /[^\0]/) {
8868 3         16 $self->VPrint(0, " Preserving unknown trailer ($extra bytes)\n");
8869             # copy the trailer since it contains non-null data
8870 3 50 0     8 Write($outfile, "\0"x($extra-$size)) or $err = 1, last if $size != $extra;
8871 3 50       10 Write($outfile, $buf) or $err = 1, last;
8872 3 50 0     6 CopyBlock($raf, $outfile, $size-$n) or $err = 1 if $size > $n;
8873 3         8 last;
8874             }
8875 0         0 $size -= $n;
8876 0 0       0 next if $size > 0;
8877 0         0 $self->VPrint(0, " Deleting blank trailer ($extra bytes)\n");
8878 0         0 last;
8879             }
8880             }
8881             }
8882             # write trailer buffer if necessary
8883 12 50 0     31 $self->WriteTrailerBuffer($trailInfo, $outfile) or $err = 1 if $trailInfo;
8884             # add any new trailers we are creating
8885 12         62 my $trailPt = $self->AddNewTrailers();
8886 12 100 33     53 Write($outfile, $$trailPt) or $err = 1 if $trailPt;
8887             }
8888             # check DNG version
8889 126 100       414 if ($$self{DNGVersion}) {
8890 1         2 my $ver = $$self{DNGVersion};
8891             # currently support up to DNG version 1.7
8892 1 50 33     18 unless ($ver =~ /^(\d+) (\d+)/ and "$1.$2" <= 1.7) {
8893 0         0 $ver =~ tr/ /./;
8894 0         0 $self->Error("DNG Version $ver not yet tested", 1);
8895             }
8896             }
8897 126 50       1002 return $err ? -1 : 1;
8898             }
8899              
8900             #------------------------------------------------------------------------------
8901             # Return list of tag table keys (ignoring special keys)
8902             # Inputs: 0) reference to tag table
8903             # Returns: List of table keys (unsorted)
8904             sub TagTableKeys($)
8905             {
8906 8162     8162 0 9812 local $_;
8907 8162         10291 my $tagTablePtr = shift;
8908 8162         9301 my @keyList;
8909 8162         102420 foreach (keys %$tagTablePtr) {
8910 521672 100       718742 push(@keyList, $_) unless $specialTags{$_};
8911             }
8912 8162         77951 return @keyList;
8913             }
8914              
8915             #------------------------------------------------------------------------------
8916             # GetTagTable
8917             # Inputs: 0) table name
8918             # Returns: tag table reference, or undefined if not found
8919             # Notes: Always use this function instead of requiring module and using table
8920             # directly since this function also does the following the first time the table
8921             # is loaded:
8922             # - requires new module if necessary
8923             # - generates default GROUPS hash and Group 0 name from module name
8924             # - registers Composite tags if Composite table found
8925             # - saves descriptions for tags in specified table
8926             # - generates default TAG_PREFIX to be used for unknown tags
8927             sub GetTagTable($)
8928             {
8929 97544 100   97544 0 153214 my $tableName = shift or return undef;
8930 97540         161431 my $table = $allTables{$tableName};
8931              
8932 97540 100       129642 unless ($table) {
8933 113     113   1072 no strict 'refs';
  113         191  
  113         19694  
8934 4825 100       26435 unless (%$tableName) {
8935             # try to load module for this table
8936 919 50       5993 if ($tableName =~ /(.*)::/) {
8937 919         2616 my $module = $1;
8938 919 50       77440 if (not eval "require $module") {
    100          
8939 0 0       0 $@ and warn $@;
8940             } elsif (not %$tableName) {
8941             # load additional modules if required
8942 28 50       119 if ($module eq 'Image::ExifTool::XMP') {
    0          
8943 28         21948 require 'Image/ExifTool/XMP2.pl';
8944             } elsif ($tableName eq 'Image::ExifTool::QuickTime::Stream') {
8945 0         0 require 'Image/ExifTool/QuickTimeStream.pl';
8946             }
8947             }
8948             }
8949 919 50       5969 %$tableName or warn("Can't find table $tableName\n"), return undef;
8950             }
8951 113     113   631 no strict 'refs';
  113         237  
  113         4535  
8952 4825         9244 $table = \%$tableName;
8953 113     113   463 use strict 'refs';
  113         337  
  113         94325  
8954 4825 100       11071 &{$$table{INIT_TABLE}}($table) if $$table{INIT_TABLE};
  13         83  
8955 4825         10175 $$table{TABLE_NAME} = $tableName; # set table name
8956 4825         19944 ($$table{SHORT_NAME} = $tableName) =~ s/^Image::ExifTool:://;
8957             # set default group 0 and 1 from module name unless already specified
8958 4825         8990 my $defaultGroups = $$table{GROUPS};
8959 4825 100       8515 $defaultGroups or $defaultGroups = $$table{GROUPS} = { };
8960 4825 100 100     16684 unless ($$defaultGroups{0} and $$defaultGroups{1}) {
8961 3829 50       19366 if ($tableName =~ /Image::.*?::([^:]*)/) {
8962 3829 100       10152 $$defaultGroups{0} = $1 unless $$defaultGroups{0};
8963 3829 100       12003 $$defaultGroups{1} = $1 unless $$defaultGroups{1};
8964             } else {
8965 0 0       0 $$defaultGroups{0} = $tableName unless $$defaultGroups{0};
8966 0 0       0 $$defaultGroups{1} = $tableName unless $$defaultGroups{1};
8967             }
8968             }
8969 4825 100       9570 $$defaultGroups{2} = 'Other' unless $$defaultGroups{2};
8970 4825 100 100     15688 if ($$defaultGroups{0} eq 'XMP' or $$table{NAMESPACE}) {
8971             # initialize some XMP table defaults
8972 549         2840 require Image::ExifTool::XMP;
8973 549         2311 Image::ExifTool::XMP::RegisterNamespace($table); # register all table namespaces
8974             # set default write/check procs
8975 549 100       1724 $$table{WRITE_PROC} = \&Image::ExifTool::XMP::WriteXMP unless $$table{WRITE_PROC};
8976 549 100       1395 $$table{CHECK_PROC} = \&Image::ExifTool::XMP::CheckXMP unless $$table{CHECK_PROC};
8977 549 100       2753 $$table{LANG_INFO} = \&Image::ExifTool::XMP::GetLangInfo unless $$table{LANG_INFO};
8978             }
8979             # generate a tag prefix for unknown tags if necessary
8980 4825 100       8884 unless (defined $$table{TAG_PREFIX}) {
8981 4691         5410 my $tagPrefix;
8982 4691 50 66     22937 if ($tableName =~ /Image::.*?::(.*)::Main/ || $tableName =~ /Image::.*?::(.*)/) {
8983 4691         15439 ($tagPrefix = $1) =~ s/::/_/g;
8984             } else {
8985 0         0 $tagPrefix = $tableName;
8986             }
8987 4691         12327 $$table{TAG_PREFIX} = $tagPrefix;
8988             }
8989             # set up the new table
8990 4825         11583 SetupTagTable($table);
8991             # add any user-defined tags (except Composite tags, which are handled specially)
8992 4825 100 100     19256 if (%UserDefined and $UserDefined{$tableName} and $table ne \%Image::ExifTool::Composite) {
      66        
8993 2         4 my $tagID;
8994 2         5 foreach $tagID (TagTableKeys($UserDefined{$tableName})) {
8995 3 50       5 next if $specialTags{$tagID};
8996 3         5 delete $$table{$tagID}; # replace any existing entry
8997 3         10 AddTagToTable($table, $tagID, $UserDefined{$tableName}{$tagID}, 1);
8998             }
8999             }
9000             # remember order we loaded the tables in
9001 4825         8865 push @tableOrder, $tableName;
9002             # insert newly loaded table into list
9003 4825         14190 $allTables{$tableName} = $table;
9004             }
9005             # must check each time to add UserDefined Composite tags because the Composite table
9006             # may be loaded before the UserDefined tags are available
9007 97540 50 66     190331 if ($table eq \%Image::ExifTool::Composite and not $$table{VARS}{LOADED_USERDEFINED} and
      100        
      66        
9008             %UserDefined and $UserDefined{$tableName})
9009             {
9010 0         0 my $userComp = $UserDefined{$tableName};
9011 0         0 delete $UserDefined{$tableName}; # (must delete first to avoid infinite recursion)
9012 0         0 AddCompositeTags($userComp, 1);
9013 0         0 $UserDefined{$tableName} = $userComp; # (add back again for adding writable tags later)
9014 0         0 $$table{VARS}{LOADED_USERDEFINED} = 1; # set flag to avoid doing this again
9015             }
9016 97540         143471 return $table;
9017             }
9018              
9019             #------------------------------------------------------------------------------
9020             # Process an image directory
9021             # Inputs: 0) ExifTool object reference, 1) directory information reference
9022             # 2) tag table reference, 3) optional reference to processing procedure
9023             # Returns: Result from processing (1=success)
9024             sub ProcessDirectory($$$;$)
9025             {
9026 5230     5230 0 11233 my ($self, $dirInfo, $tagTablePtr, $proc) = @_;
9027              
9028 5230 50 33     14873 return 0 unless $tagTablePtr and $dirInfo;
9029             # use default proc from tag table or EXIF proc as fallback if no proc specified
9030 5230 100 100     15262 $proc or $proc = $$tagTablePtr{PROCESS_PROC} || \&Image::ExifTool::Exif::ProcessExif;
9031             # set directory name from default group0 name if not done already
9032 5230         7774 my $dirName = $$dirInfo{DirName};
9033 5230 100       8511 unless ($dirName) {
9034 704         1856 $dirName = $$tagTablePtr{GROUPS}{0};
9035 704 100       2152 $dirName = $$tagTablePtr{GROUPS}{1} if $dirName =~ /^APP\d+$/; # (use specific APP name)
9036 704         1333 $$dirInfo{DirName} = $dirName;
9037             }
9038              
9039             # guard against cyclical recursion into the same directory
9040 5230 100 100     21105 if (defined $$dirInfo{DirStart} and defined $$dirInfo{DataPos} and
      100        
      100        
9041             # directories don't overlap if the length is zero
9042             ($$dirInfo{DirLen} or not defined $$dirInfo{DirLen}))
9043             {
9044 4420   100     11959 my $addr = $$dirInfo{DirStart} + $$dirInfo{DataPos} + ($$dirInfo{Base}||0) + $$self{BASE};
9045 4420 50 33     11372 if ($$self{PROCESSED}{$addr} and not $$dirInfo{NotDup}) {
9046 0         0 $self->Warn("$dirName pointer references previous $$self{PROCESSED}{$addr} directory");
9047             # patch for bug in Windows phone 7.5 O/S that writes incorrect InteropIFD pointer
9048 0 0 0     0 return 0 unless $dirName eq 'GPS' and $$self{PROCESSED}{$addr} eq 'InteropIFD';
9049             }
9050 4420 50 66     16557 $$self{PROCESSED}{$addr} = $dirName unless $$tagTablePtr{VARS} and $$tagTablePtr{VARS}{ALLOW_REPROCESS};
9051             }
9052 5230         9197 my $oldOrder = GetByteOrder();
9053 5230         17089 my @save = @$self{'INDENT','DIR_NAME','Compression','SubfileType'};
9054 5230         12105 $$self{LIST_TAGS} = { }; # don't build lists across different directories
9055 5230         8169 $$self{INDENT} .= '| ';
9056 5230         7463 $$self{DIR_NAME} = $dirName;
9057 5230         5802 push @{$$self{PATH}}, $dirName;
  5230         10236  
9058 5230         12058 $$self{FOUND_DIR}{$dirName} = 1;
9059              
9060             # process the directory
9061 113     113   794 no strict 'refs';
  113         188  
  113         5406  
9062 5230         19197 my $rtnVal = &$proc($self, $dirInfo, $tagTablePtr);
9063 113     113   466 use strict 'refs';
  113         173  
  113         925789  
9064              
9065 5230         6576 pop @{$$self{PATH}};
  5230         10177  
9066 5230         18079 @$self{'INDENT','DIR_NAME','Compression','SubfileType'} = @save;
9067 5230         11868 SetByteOrder($oldOrder);
9068 5230         16153 return $rtnVal;
9069             }
9070              
9071             #------------------------------------------------------------------------------
9072             # Get Metadata path
9073             # Inputs: 0) ExifTool object ref
9074             # Return: Metadata path string
9075             sub MetadataPath($)
9076             {
9077 742     742 0 1185 my $self = shift;
9078 742         1021 return join '-', @{$$self{PATH}}
  742         3093  
9079             }
9080              
9081             #------------------------------------------------------------------------------
9082             # Get standardized file extension
9083             # Inputs: 0) file name
9084             # Returns: standardized extension (all uppercase), or undefined if no extension
9085             sub GetFileExtension($)
9086             {
9087 2039     2039 0 2832 my $filename = shift;
9088 2039         2629 my $fileExt;
9089 2039 100 100     10102 if ($filename and $filename =~ /^.*\.([^.]+)$/s) {
9090 1897         4019 $fileExt = uc($1); # change extension to upper case
9091             # convert TIF extension to TIFF because we use the
9092             # extension for the file type tag of TIFF images
9093 1897 100       3737 $fileExt eq 'TIF' and $fileExt = 'TIFF';
9094             }
9095 2039         5375 return $fileExt;
9096             }
9097              
9098             #------------------------------------------------------------------------------
9099             # Get list of tag information hashes for given tag ID
9100             # Inputs: 0) Tag table reference, 1) tag ID
9101             # Returns: Array of tag information references
9102             # Notes: Generates tagInfo hash if necessary
9103             sub GetTagInfoList($$)
9104             {
9105 610528     610528 0 677739 my ($tagTablePtr, $tagID) = @_;
9106 610528         723593 my $tagInfo = $$tagTablePtr{$tagID};
9107              
9108 610528 50       908730 if ($specialTags{$tagID}) {
    100          
    100          
    100          
9109             # (hopefully this won't happen)
9110 0         0 warn "Tag $tagID conflicts with internal ExifTool variable in $$tagTablePtr{TABLE_NAME}\n";
9111             } elsif (ref $tagInfo eq 'HASH') {
9112 556576         735762 return ($tagInfo);
9113             } elsif (ref $tagInfo eq 'ARRAY') {
9114 11784         34642 return @$tagInfo;
9115             } elsif ($tagInfo) {
9116             # create hash with name
9117 37641         65361 $tagInfo = $$tagTablePtr{$tagID} = { Name => $tagInfo };
9118 37641         50580 return ($tagInfo);
9119             }
9120 4527         6939 return ();
9121             }
9122              
9123             #------------------------------------------------------------------------------
9124             # Find tag information, processing conditional tags
9125             # Inputs: 0) ExifTool object reference, 1) tagTable pointer, 2) tag ID
9126             # 3) optional value reference (usually reference to binary data value, but
9127             # depends on information type), 4) optional format type, 5) optional value count
9128             # Returns: pointer to tagInfo hash, undefined if none found, or '' if $valPt needed
9129             # Notes: You should always call this routine to find a tag in a table because
9130             # this routine will evaluate conditional tags.
9131             # Arguments 3-5 are only required if the information type allows $valPt, $format and/or
9132             # $count in a Condition, and if not given when needed this routine returns ''.
9133             sub GetTagInfo($$$;$$$)
9134             {
9135 114742     114742 0 160551 my ($self, $tagTablePtr, $tagID) = @_;
9136 114742         122747 my ($valPt, $format, $count);
9137              
9138 114742         163873 my @infoArray = GetTagInfoList($tagTablePtr, $tagID);
9139 114742         134366 my $options = $$self{OPTIONS};
9140             # evaluate condition
9141 114742         111464 my $tagInfo;
9142 114742         133098 foreach $tagInfo (@infoArray) {
9143 120419         163007 my $condition = $$tagInfo{Condition};
9144 120419 100       168503 if ($condition) {
9145 14283 100       24527 ($valPt, $format, $count) = splice(@_, 3) if @_ > 3;
9146 14283 100 100     55538 return '' if $condition =~ /\$(valPt|format|count)\b/ and not defined $valPt;
9147             # set old value for use in condition if needed
9148 13588         41008 local $SIG{'__WARN__'} = \&SetWarning;
9149 13588         16217 undef $evalWarning;
9150             #### eval Condition ($self, [$valPt, $format, $count])
9151 13588 100       829718 unless (eval $condition) {
9152 11043 50       17569 $@ and $evalWarning = $@;
9153 11043 50       15401 $self->Warn("Condition $$tagInfo{Name}: " . CleanWarning()) if $evalWarning;
9154 11043         36686 next;
9155             }
9156             }
9157             # don't return Unknown tags unless that option is set or we are writing (also see forum13716)
9158 108681 100 100     201679 if ($$tagInfo{Unknown} and not $$options{Unknown} and
      100        
      100        
      66        
      100        
9159             (not $$self{IsWriting} or $$tagInfo{AddedUnknown}) and not
9160             ($$options{Verbose} or $$self{HTML_DUMP} or
9161             ($$options{Validate} and not $$tagInfo{AddedUnknown})))
9162             {
9163 1957         3834 return undef;
9164             }
9165             # return the tag information we found
9166 106724         181794 return $tagInfo;
9167             }
9168             # generate information for unknown tags (numerical only) if required
9169 5366 100 66     32365 if (not $tagInfo and ($$options{Unknown} or $$options{Verbose} or $$self{HTML_DUMP}) and
      66        
      100        
      100        
9170             $tagID =~ /^\d+$/ and not $$self{NO_UNKNOWN})
9171             {
9172 589         780 my $printConv;
9173 589 100       1192 if (defined $$tagTablePtr{PRINT_CONV}) {
9174 155         199 $printConv = $$tagTablePtr{PRINT_CONV};
9175             } else {
9176             # limit length of printout (can be very long)
9177 434         786 $printConv = \&LimitLongValues;
9178             }
9179 589         1656 my $hex = sprintf("0x%.4x", $tagID);
9180 589         1003 my $prefix = $$tagTablePtr{TAG_PREFIX};
9181 589         1623 $tagInfo = {
9182             Name => "${prefix}_$hex",
9183             Description => MakeDescription($prefix, $hex),
9184             Unknown => 1,
9185             Writable => 0, # can't write unknown tags
9186             PrintConv => $printConv,
9187             AddedUnknown => 1,
9188             };
9189             # add tag information to table
9190 589         1286 AddTagToTable($tagTablePtr, $tagID, $tagInfo);
9191             } else {
9192 4777         5682 undef $tagInfo;
9193             }
9194 5366         10236 return $tagInfo;
9195             }
9196              
9197             #------------------------------------------------------------------------------
9198             # Add new tag to table (must use this routine to add new tags to a table)
9199             # Inputs: 0) reference to tag table, 1) tag ID
9200             # 2) [optional] tag name or reference to tag information hash
9201             # 3) [optional] flag to avoid adding prefix when generating tag name
9202             # Returns: tagInfo ref
9203             # Notes: - will not override existing entry in table
9204             # - info need contain no entries when this routine is called
9205             # - tag name is cleaned if necessary
9206             sub AddTagToTable($$;$$)
9207             {
9208 7230     7230 0 10053 my ($tagTablePtr, $tagID, $tagInfo, $noPrefix) = @_;
9209              
9210             # generate tag info hash if necessary
9211 7230 0       11183 $tagInfo = $tagInfo ? { Name => $tagInfo } : { } unless ref $tagInfo eq 'HASH';
    50          
9212              
9213             # define necessary entries in information hash
9214 7230 100       9440 if ($$tagInfo{Groups}) {
9215             # fill in default groups from table GROUPS
9216 496         589 foreach (keys %{$$tagTablePtr{GROUPS}}) {
  496         1328  
9217 1488 100       2481 next if $$tagInfo{Groups}{$_};
9218 534         887 $$tagInfo{Groups}{$_} = $$tagTablePtr{GROUPS}{$_};
9219             }
9220             } else {
9221 6734         6383 $$tagInfo{Groups} = { %{$$tagTablePtr{GROUPS}} };
  6734         23940  
9222             }
9223 7230 100       11772 $$tagInfo{Flags} and ExpandFlags($tagInfo);
9224             $$tagInfo{GotGroups} = 1,
9225 7230         14719 $$tagInfo{Table} = $tagTablePtr;
9226 7230         9903 $$tagInfo{TagID} = $tagID;
9227 7230 100       11528 $$tagInfo{Hidden} = 1 unless defined $$tagInfo{Hidden};
9228 7230 100 100     12494 if (defined $$tagTablePtr{AVOID} and not defined $$tagInfo{Avoid}) {
9229 1744         2263 $$tagInfo{Avoid} = $$tagTablePtr{AVOID};
9230             }
9231              
9232 7230         7944 my $name = $$tagInfo{Name};
9233 7230 100       9967 $name = $tagID unless defined $name;
9234 7230         10780 $name =~ tr/-_a-zA-Z0-9//dc; # remove illegal characters
9235 7230         8236 $name = ucfirst $name; # capitalize first letter
9236             # add tag-name prefix if specified and tag name not provided
9237 7230 100 100     12175 unless (defined $$tagInfo{Name} or $noPrefix or not $$tagTablePtr{TAG_PREFIX}) {
      66        
9238             # make description to prevent tagID from getting mangled by MakeDescription()
9239 514         948 $$tagInfo{Description} = MakeDescription($$tagTablePtr{TAG_PREFIX}, $name);
9240 514         895 $name = "$$tagTablePtr{TAG_PREFIX}_$name";
9241             }
9242             # tag names must be at least 2 characters long and prefer them to start with a letter
9243 7230 100 66     23023 $name = "Tag$name" if length($name) < 2 or $name !~ /^[A-Z]/i;
9244 7230         9434 $$tagInfo{Name} = $name;
9245             # add tag to table, but never override existing entries (could potentially happen
9246             # if someone thinks there isn't any tagInfo because a condition wasn't satisfied)
9247 7230 50 66     17846 unless (defined $$tagTablePtr{$tagID} or $specialTags{$tagID}) {
9248 7163         28793 $$tagTablePtr{$tagID} = $tagInfo;
9249 7163 0 33     10128 if ($purgeFlag and $$tagInfo{Unknown} and not $$tagInfo{SubDirectory}) {
      0        
9250 0         0 push @purgeTags, $tagInfo;
9251             }
9252             }
9253 7230 100       10697 $$tagInfo{AddedUnknown} = 1 if $$tagInfo{Unknown};
9254 7230         10667 return $tagInfo;
9255             }
9256              
9257             #------------------------------------------------------------------------------
9258             # Handle simple extraction of new tag information
9259             # Inputs: 0) ExifTool object ref, 1) tag table reference, 2) tagID, 3) raw value,
9260             # 4-N) parameters hash: Index, DataPt, DataPos, Base, Start, Size, Parent,
9261             # TagInfo, ProcessProc, RAF, Format, Count, MakeTagInfo
9262             # Returns: tag key or undef if tag not found
9263             # Notes: if value is not defined, it is extracted from DataPt using TagInfo
9264             # Format and Count if provided
9265             # - set MakeTagInfo to add tag info for unknown tags with name made from tag ID
9266             sub HandleTag($$$$;%)
9267             {
9268 9771     9771 0 29973 my ($self, $tagTablePtr, $tag, $val, %parms) = @_;
9269 9771         14437 my $verbose = $$self{OPTIONS}{Verbose};
9270 9771         11381 my $pfmt = $parms{Format};
9271 9771 100       14820 my $valPt = defined $val ? \$val : undef;
9272 9771   100     28260 my $tagInfo = $parms{TagInfo} || $self->GetTagInfo($tagTablePtr, $tag, $valPt, $pfmt, $parms{Count});
9273 9771         14312 my $dataPt = $parms{DataPt};
9274 9771         11698 my ($subdir, $format, $noTagInfo, $rational, $binVal);
9275              
9276             # get binary data for Condition if necessary
9277 9771 50 66     19097 if (not $tagInfo and defined $tagInfo and $dataPt) {
      33        
9278 0   0     0 my $start = $parms{Start} || 0;
9279 0         0 my $size = $parms{Size};
9280 0 0       0 $size = length($$dataPt) - $start unless defined $size;
9281 0 0       0 return undef if $start + $size > length($$dataPt);
9282 0 0       0 $size = 1024 if $size > 1024; # max 1024 bytes available for the Condition
9283 0         0 my $dat = substr($$dataPt, $start, $size);
9284 0         0 $tagInfo = $self->GetTagInfo($tagTablePtr, $tag, \$dat, $pfmt, $parms{Count});
9285             }
9286 9771 100       14175 if ($tagInfo) {
    50          
9287 7576         9586 $subdir = $$tagInfo{SubDirectory};
9288             } elsif ($parms{MakeTagInfo}) {
9289 0 0       0 $self->VPrint(0, $$self{INDENT}, "[adding $tag]\n") if $verbose;
9290 0         0 my $name = $tag;
9291 0         0 $name =~ s/([A-Z]) ([A-Z][ A-Z])/${1}_$2/g; # underline between acronyms
9292 0         0 $name =~ s/([^A-Za-z])([a-z])/$1\u$2/g; # capitalize words
9293 0         0 $name =~ tr/-_a-zA-Z0-9//dc; # remove illegal characters
9294 0 0 0     0 $name = "Tag$name" if length($name) < 2 or $name =~ /^[-0-9]/;
9295 0         0 $tagInfo = { Name => ucfirst($name) };
9296 0         0 AddTagToTable($tagTablePtr, $tag, $tagInfo);
9297             } else {
9298 2195 50       6127 return undef unless $verbose;
9299 0         0 $tagInfo = { Name => "tag $tag" }; # create temporary tagInfo hash
9300 0         0 $noTagInfo = 1;
9301             }
9302             # read value if not done already (not necessary for subdir)
9303 7576 50 66     15216 unless (defined $val or ($subdir and not $$tagInfo{Writable} and not $$tagInfo{RawConv})) {
      66        
      100        
9304 890   100     1812 my $start = $parms{Start} || 0;
9305 890 50       1579 my $dLen = $dataPt ? length($$dataPt) : -1;
9306 890         1102 my $size = $parms{Size};
9307 890 50       1382 defined $size or $size = ($dLen > 0 ? $dLen : 0);
    100          
9308             # read from data in memory if possible
9309 890 50 33     2244 if ($start >= 0 and $start + $size <= $dLen) {
9310 890   100     2083 $format = $$tagInfo{Format} || $$tagTablePtr{FORMAT};
9311 890 50 100     2566 $format = $pfmt if not $format and $pfmt and $formatSize{$pfmt};
      66        
9312 890 100       1537 if (not $format) {
    50          
9313 452         885 $val = substr($$dataPt, $start, $size);
9314             } elsif (not $$tagInfo{ByteOrder}) {
9315 438         1335 $val = ReadValue($dataPt, $start, $format, $$tagInfo{Count}, $size, \$rational);
9316             } else {
9317 0         0 my $oldOrder = GetByteOrder(), SetByteOrder($$tagInfo{ByteOrder});
9318 0         0 $val = ReadValue($dataPt, $start, $format, $$tagInfo{Count}, $size, \$rational);
9319 0         0 SetByteOrder($oldOrder);
9320             }
9321 890 50       2048 $binVal = substr($$dataPt, $start, $size) if $$self{OPTIONS}{SaveBin};
9322             } else {
9323 0         0 $self->Warn("Error extracting value for $$tagInfo{Name}");
9324 0         0 return undef;
9325             }
9326             }
9327             # do verbose print if necessary
9328 7576 100       11183 if ($verbose) {
9329 51 50       70 undef $tagInfo if $noTagInfo;
9330 51         87 $parms{Value} = $val;
9331 51 50       72 $parms{Value} .= " ($rational)" if defined $rational;
9332 51         83 $parms{Table} = $tagTablePtr;
9333 51 50       67 if ($format) {
9334 0   0     0 my $count = int(($parms{Size} || 0) / ($formatSize{$format} || 1));
      0        
9335 0         0 $parms{Format} = $format . "[$count]";
9336             }
9337 51         145 $self->VerboseInfo($tag, $tagInfo, %parms);
9338             }
9339 7576 50       11005 if ($tagInfo) {
9340 7576 100       10705 if ($subdir) {
9341 753 50 66     1675 if ($$tagInfo{MakerNotes} and $$self{OPTIONS}{FastScan} and $$self{OPTIONS}{FastScan} > 1) {
      33        
9342 0         0 return undef; # don't process maker note directories when FastScan > 1
9343             }
9344 753         1049 my $subdirStart = $parms{Start};
9345 753         985 my $subdirLen = $parms{Size};
9346 753 100 66     3539 if ($$tagInfo{RawConv} and not $$tagInfo{Writable}) {
    100          
9347 1         3 my $conv = $$tagInfo{RawConv};
9348 1         5 local $SIG{'__WARN__'} = \&SetWarning;
9349 1         2 undef $evalWarning;
9350 1 50       3 if (ref $conv eq 'CODE') {
9351 0         0 $val = &$conv($val, $self);
9352             } else {
9353 1         1 my ($priority, @grps);
9354             # NOTE: RawConv is evaluated in Writer.pl and twice in ExifTool.pm
9355             #### eval RawConv ($self, $val, $tag, $tagInfo, $priority, @grps)
9356 1         69 $val = eval $conv;
9357 1 50       6 $@ and $evalWarning = $@;
9358             }
9359 1 50       3 $self->Warn("RawConv $tag: " . CleanWarning()) if $evalWarning;
9360 1 50       2 return undef unless defined $val;
9361 1 50       5 $dataPt = ref $val eq 'SCALAR' ? $val : \$val;
9362 1         1 $subdirStart = 0;
9363 1         4 $subdirLen = length $$dataPt;
9364             } elsif (not $dataPt) {
9365 13 100       36 $dataPt = ref $val eq 'SCALAR' ? $val : \$val;
9366             }
9367 753 100       1587 if ($$subdir{Start}) {
9368 8         16 my $valuePtr = 0;
9369             #### eval Start ($valuePtr)
9370 8         472 my $off = eval $$subdir{Start};
9371 8         27 $subdirStart += $off;
9372 8         17 $subdirLen -= $off;
9373             }
9374             # process subdirectory information
9375             my %dirInfo = (
9376             DirName => $$subdir{DirName} || $$tagInfo{Name},
9377             DataPt => $dataPt,
9378             DataLen => length $$dataPt,
9379             DataPos => $parms{DataPos},
9380             DirStart => $subdirStart,
9381             DirLen => $subdirLen,
9382             DirID => $tag,
9383             Parent => $parms{Parent},
9384             Base => $parms{Base},
9385             Multi => $$subdir{Multi},
9386             TagInfo => $tagInfo,
9387             IgnoreProp => $$subdir{IgnoreProp},
9388             RAF => $parms{RAF},
9389 753   66     6958 );
9390 753         1545 my $oldOrder = GetByteOrder();
9391 753 100       1412 if ($$subdir{ByteOrder}) {
9392 3 100       8 if ($$subdir{ByteOrder} eq 'Unknown') {
9393 1 50       4 if ($subdirStart + 2 <= $subdirLen) {
9394             # attempt to determine the byte ordering of an IFD-style subdirectory
9395 1         3 my $num = Get16u($dataPt, $subdirStart);
9396 1 50 33     7 ToggleByteOrder if $num & 0xff00 and ($num>>8) > ($num&0xff);
9397             }
9398             } else {
9399 2         5 SetByteOrder($$subdir{ByteOrder});
9400             }
9401             }
9402 753   33     1703 my $subTablePtr = GetTagTable($$subdir{TagTable}) || $tagTablePtr;
9403 753   100     3672 $self->ProcessDirectory(\%dirInfo, $subTablePtr, $$subdir{ProcessProc} || $parms{ProcessProc});
9404 753         1531 SetByteOrder($oldOrder);
9405             # return now unless directory is writable as a block
9406 753 50       5513 return undef unless $$tagInfo{Writable};
9407             }
9408 6823         11809 my $key = $self->FoundTag($tagInfo, $val);
9409 6823 100       11101 if (defined $key) {
9410             # save original components of rational numbers and original binary value
9411 6814 100       10211 $$self{TAG_EXTRA}{$key}{Rational} = $rational if defined $rational;
9412 6814 50       10140 $$self{TAG_EXTRA}{$key}{BinVal} = $binVal if defined $binVal;
9413             }
9414 6823         17335 return $key;
9415             }
9416 0         0 return undef;
9417             }
9418              
9419             #------------------------------------------------------------------------------
9420             # Add tag to hash of extracted information
9421             # Inputs: 0) ExifTool object reference
9422             # 1) reference to tagInfo hash or tag name
9423             # 2) data value (or reference to require hash if Composite)
9424             # 3) optional family 0 group, 4) optional family 1 group
9425             # Returns: tag key or undef if no value
9426             sub FoundTag($$$;@)
9427             {
9428 61467     61467 0 70375 local $_;
9429 61467         93349 my ($self, $tagInfo, $value, @grps) = @_;
9430 61467         67149 my ($tag, $noListDel, $tbl);
9431 61467         74733 my $options = $$self{OPTIONS};
9432              
9433 61467 100       101490 if (ref $tagInfo eq 'HASH') {
9434 53662 50       102549 $tag = $$tagInfo{Name} or warn("No tag name\n"), return undef;
9435 53662         67899 $tbl = $$tagInfo{Table};
9436             } else {
9437 7805         8832 $tag = $tagInfo;
9438             # look for tag in Extra
9439 7805         12380 $tbl = GetTagTable('Image::ExifTool::Extra');
9440 7805         14717 $tagInfo = $self->GetTagInfo($tbl, $tag);
9441             # make temporary hash if tag doesn't exist in Extra
9442             # (not advised to do this since the tag won't show in list)
9443 7805 100       11679 $tagInfo or $tagInfo = { Name => $tag, Groups => \%allGroupsExifTool };
9444 7805 100       13054 $$options{Verbose} and $self->VerboseInfo(undef, $tagInfo, Value => $value);
9445             }
9446             # get tag priority
9447 61467         73611 my $priority = $$tagInfo{Priority};
9448 61467 100       89750 unless (defined $priority) {
9449 55161         63852 $priority = $$tbl{PRIORITY};
9450 55161 100 100     140017 $priority = 0 if not defined $priority and $$tagInfo{Avoid};
9451             }
9452 61467 100       105896 $grps[0] or $grps[0] = $$self{SET_GROUP0};
9453 61467 100       97778 $grps[1] or $grps[1] = $$self{SET_GROUP1};
9454 61467 50       99061 if ($$options{IgnoreGroups}) {
9455 0         0 foreach (0..1) {
9456 0   0     0 my $g = lc($grps[$_] || $$tagInfo{Groups}{$_} || $$tagInfo{Table}{GROUPS}{$_});
9457 0 0 0     0 return undef if $$options{IgnoreGroups}{$g} or $$options{IgnoreGroups}{"$_$g"};
9458             }
9459             }
9460 61467         76687 my $valueHash = $$self{VALUE};
9461              
9462 61467 100       91204 if ($$tagInfo{RawConv}) {
9463             # initialize @val for use in Composite RawConv expressions
9464 9930         11949 my @val;
9465 9930 50 66     19992 if (ref $value eq 'HASH' and $$tagInfo{IsComposite}) {
9466 1840         3576 foreach (keys %$value) { $val[$_] = $$valueHash{$$value{$_}}; }
  6164         11898  
9467             }
9468 9930         13727 my $conv = $$tagInfo{RawConv};
9469 9930         39349 local $SIG{'__WARN__'} = \&SetWarning;
9470 9930         14573 undef $evalWarning;
9471 9930 100       14786 if (ref $conv eq 'CODE') {
9472 241         757 $value = &$conv($value, $self);
9473 241 50       666 $$self{grps} and @grps = @{$$self{grps}}, delete $$self{grps};
  0         0  
9474             } else {
9475 9689         12187 my $val = $value; # do this so eval can use $val
9476             # NOTE: RawConv is also evaluated in Writer.pl
9477             #### eval RawConv ($self, $val, $tag, $tagInfo, $priority, @grps)
9478 9689         840059 $value = eval $conv;
9479 9689 50       34679 $@ and $evalWarning = $@;
9480             }
9481 9930 50       15841 $self->Warn("RawConv $tag: " . CleanWarning()) if $evalWarning;
9482 9930 100       36158 return undef unless defined $value;
9483             }
9484             # ignore specified tags (AFTER doing RawConv if necessary!)
9485 58732 50       92100 if ($$options{IgnoreTags}) {
9486 0 0       0 if ($$options{IgnoreTags}{all}) {
9487 0 0       0 return undef unless $$self{REQ_TAG_LOOKUP}{lc $tag};
9488             } else {
9489 0 0       0 return undef if $$options{IgnoreTags}{lc $tag};
9490             }
9491             }
9492             # handle duplicate tag names
9493 58732 100       119228 if (defined $$valueHash{$tag}) {
    100          
9494             # add to list if there is an active list for this tag
9495 7035 100       16289 if ($$self{LIST_TAGS}{$tagInfo}) {
9496 701         1108 $tag = $$self{LIST_TAGS}{$tagInfo}; # use key from previous list tag
9497 701 100       1199 if (defined $$self{NO_LIST}) {
9498             # accumulate list in TAG_EXTRA "NoList" element
9499 65 100       167 if (defined $$self{TAG_EXTRA}{$tag}{NoList}) {
9500 31         51 push @{$$self{TAG_EXTRA}{$tag}{NoList}}, $value;
  31         117  
9501             } else {
9502 34         166 $$self{TAG_EXTRA}{$tag}{NoList} = [ $$valueHash{$tag}, $value ];
9503             }
9504 65         111 $noListDel = 1; # set flag to delete this tag if re-listed
9505             } else {
9506 636 100       1268 if (ref $$valueHash{$tag} ne 'ARRAY') {
9507 319         910 $$valueHash{$tag} = [ $$valueHash{$tag} ];
9508             }
9509 636         806 push @{$$valueHash{$tag}}, $value;
  636         1568  
9510 636         1689 return $tag; # return without creating a new entry
9511             }
9512             }
9513             # get next available tag key
9514 6399   100     21622 my $nextInd = $$self{DUPL_TAG}{$tag} = ($$self{DUPL_TAG}{$tag} || 0) + 1;
9515 6399         10428 my $nextTag = "$tag ($nextInd)";
9516             #
9517             # take tag with highest priority
9518             #
9519             # promote existing 0-priority tag so it takes precedence over a new 0-tag
9520             # (unless old tag was a sub-document and new tag isn't. Also, never override
9521             # a Warning tag because they may be added by ValueConv, which could be confusing)
9522 6399         10010 my $oldPriority = $$self{PRIORITY}{$tag};
9523 6399 100       9753 unless ($oldPriority) {
9524 5408 100 100     21390 if ($$self{DOC_NUM} or $tag eq 'Warning' or not $$self{TAG_EXTRA}{$tag}{G3}) {
      100        
9525 5373         6611 $oldPriority = 1;
9526             } else {
9527 35         44 $oldPriority = 0; # don't promote sub-document tag over main document
9528             }
9529             }
9530             # set priority for this tag
9531 6399 100 100     22661 if (defined $priority) {
    100 33        
9532             # increase 0-priority tags if this is the priority directory
9533             $priority = 1 if not $priority and $$self{DIR_NAME} and
9534 2134 100 100     9476 $$self{DIR_NAME} eq $$self{PRIORITY_DIR};
      100        
9535             } elsif ($$self{LOW_PRIORITY_DIR}{'*'} or
9536             ($$self{DIR_NAME} and $$self{LOW_PRIORITY_DIR}{$$self{DIR_NAME}}))
9537             {
9538 411         445 $priority = 0; # default is 0 for a LOW_PRIORITY_DIR
9539             } else {
9540 3854         4729 $priority = 1; # the normal default
9541             }
9542 6399 100 100     22459 if ($priority >= $oldPriority and (not $$self{DOC_NUM} or ($$self{TAG_EXTRA}{$tag}{G3} and
      100        
      100        
9543             $$self{DOC_NUM} eq $$self{TAG_EXTRA}{$tag}{G3})) and not $noListDel)
9544             {
9545             # move existing tag out of the way since this tag is higher priority
9546             # (NOTE: any new members added here must also be added to DeleteTag())
9547 2957         7294 $$self{PRIORITY}{$nextTag} = $$self{PRIORITY}{$tag};
9548 2957         6335 $$valueHash{$nextTag} = $$valueHash{$tag};
9549 2957         5870 $$self{FILE_ORDER}{$nextTag} = $$self{FILE_ORDER}{$tag};
9550 2957         6184 my $oldInfo = $$self{TAG_INFO}{$nextTag} = $$self{TAG_INFO}{$tag};
9551 2957         5141 $$self{TAG_EXTRA}{$nextTag} = $$self{TAG_EXTRA}{$tag};
9552 2957         4609 $$self{TAG_EXTRA}{$tag} = { };
9553 2957         4475 delete $$self{BOTH}{$tag};
9554             # update tag key for list if necessary
9555 2957 100       5535 $$self{LIST_TAGS}{$oldInfo} = $nextTag if $$self{LIST_TAGS}{$oldInfo};
9556             # update this key if used in a Composite tag
9557 2957 100       6925 if ($$self{COMP_KEYS}{$tag}) {
9558 97         144 $$_[0]{$$_[1]} = $nextTag foreach @{$$self{COMP_KEYS}{$tag}};
  97         383  
9559 97         209 $$self{COMP_KEYS}{$nextTag} = $$self{COMP_KEYS}{$tag};
9560 97         180 delete $$self{COMP_KEYS}{$tag};
9561             }
9562             } else {
9563 3442         4309 $tag = $nextTag; # don't override the existing tag
9564             }
9565 6399         12055 $$self{PRIORITY}{$tag} = $priority;
9566 6399 100       11311 $$self{TAG_EXTRA}{$tag}{NoListDel} = 1 if $noListDel;
9567             } elsif ($priority) {
9568             # set tag priority (only if exists and is non-zero)
9569 1915         4491 $$self{PRIORITY}{$tag} = $priority;
9570             }
9571              
9572             # save the raw value, file order, tagInfo ref, group1 name,
9573             # and tag key for lists if necessary
9574 58096         118964 $$valueHash{$tag} = $value;
9575 58096         102795 $$self{FILE_ORDER}{$tag} = ++$$self{NUM_FOUND};
9576 58096         93254 $$self{TAG_INFO}{$tag} = $tagInfo;
9577 58096 100       134037 $$self{TAG_EXTRA}{$tag} = { } unless $$self{TAG_EXTRA}{$tag};
9578             # set dynamic groups 0, 1 and 3 if necessary
9579 58096 100       87063 $$self{TAG_EXTRA}{$tag}{G0} = $grps[0] if $grps[0];
9580 58096 100       85066 $$self{TAG_EXTRA}{$tag}{G1} = $grps[1] if $grps[1];
9581 58096 100       86068 if ($$self{DOC_NUM}) {
9582 1798         3461 $$self{TAG_EXTRA}{$tag}{G3} = $$self{DOC_NUM};
9583 1798         2940 $$self{HAS_DOC}{$$self{DOC_NUM}} = 1;
9584 1798 50       5032 if ($$self{DOC_NUM} =~ /^(\d+)/) {
9585             # keep track of maximum 1st-level sub-document number
9586 1798 100       4271 $$self{DOC_COUNT} = $1 unless $$self{DOC_COUNT} >= $1;
9587             }
9588             }
9589             # save path if requested
9590 58096 100       86148 $$self{TAG_EXTRA}{$tag}{G5} = $self->MetadataPath() if $$options{SavePath};
9591              
9592             # remember this tagInfo if we will be accumulating values in a list
9593             # (but don't override earlier list if this may be deleted by NoListDel flag)
9594 58096 100 100     101603 if ($$tagInfo{List} and not $$self{NO_LIST} and not $noListDel) {
      100        
9595 1166         3277 $$self{LIST_TAGS}{$tagInfo} = $tag;
9596             }
9597              
9598             # validate tag if requested (but only for simple values -- could result
9599             # in infinite recursion if called for a Composite tag (HASH ref value)
9600             # because FoundTag is called in the middle of building Composite tags
9601 58096 100 100     102828 if ($$options{Validate} and not ref $value) {
9602 213         520 Image::ExifTool::Validate::ValidateRaw($self, $tag, $value);
9603             }
9604              
9605 58096         124690 return $tag;
9606             }
9607              
9608             #------------------------------------------------------------------------------
9609             # Make current directory the priority directory if not set already
9610             # Inputs: 0) ExifTool object reference
9611             sub SetPriorityDir($)
9612             {
9613 22     22 0 47 my $self = shift;
9614 22 50       414 $$self{PRIORITY_DIR} = $$self{DIR_NAME} unless $$self{PRIORITY_DIR};
9615             }
9616              
9617             #------------------------------------------------------------------------------
9618             # Set family 0 or 1 group name specific to this tag instance
9619             # Inputs: 0) ExifTool ref, 1) tag key, 2) group name, 3) family (default 1)
9620             sub SetGroup($$$;$)
9621             {
9622 13786     13786 0 22968 my ($self, $tagKey, $extra, $fam) = @_;
9623 13786 50       40574 $$self{TAG_EXTRA}{$tagKey}{defined $fam ? "G$fam" : 'G1'} = $extra;
9624             }
9625              
9626             #------------------------------------------------------------------------------
9627             # Delete specified tag
9628             # Inputs: 0) ExifTool object ref, 1) tag key
9629             sub DeleteTag($$)
9630             {
9631 224     224 0 319 my ($self, $tag) = @_;
9632 224         331 delete $$self{VALUE}{$tag};
9633 224         295 delete $$self{FILE_ORDER}{$tag};
9634 224         266 delete $$self{TAG_INFO}{$tag};
9635 224         372 delete $$self{TAG_EXTRA}{$tag};
9636 224         276 delete $$self{PRIORITY}{$tag};
9637 224         435 delete $$self{BOTH}{$tag};
9638             }
9639              
9640             #------------------------------------------------------------------------------
9641             # Escape all elements of a value
9642             # Inputs: 0) value, 1) escape proc
9643             sub DoEscape($$)
9644             {
9645 173     173 0 184 my ($val, $key);
9646 173 100       237 if (not ref $_[0]) {
    100          
    50          
9647 167         170 $_[0] = &{$_[1]}($_[0]);
  167         324  
9648             } elsif (ref $_[0] eq 'ARRAY') {
9649 4         7 foreach $val (@{$_[0]}) {
  4         12  
9650 10         19 DoEscape($val, $_[1]);
9651             }
9652             } elsif (ref $_[0] eq 'HASH') {
9653 0         0 foreach $key (keys %{$_[0]}) {
  0         0  
9654 0         0 DoEscape($_[0]{$key}, $_[1]);
9655             }
9656             }
9657             }
9658              
9659             #------------------------------------------------------------------------------
9660             # Set the FileType and MIMEType tags
9661             # Inputs: 0) ExifTool object reference
9662             # 1) Optional file type (uses FILE_TYPE if not specified)
9663             # 2) Optional MIME type (uses our lookup if not specified)
9664             # 3) Optional recommended extension (converted to lower case; uses FileType if undef)
9665             # Notes: Will NOT set file type twice (subsequent calls ignored)
9666             sub SetFileType($;$$$)
9667             {
9668 676     676 0 1925 my ($self, $fileType, $mimeType, $normExt) = @_;
9669             # use only the first FileType set if called again for the main document
9670 676 100 66     2998 unless ($$self{FileType} and not $$self{DOC_NUM}) {
9671 627         1184 my $baseType = $$self{FILE_TYPE};
9672 627         1161 my $ext = $$self{FILE_EXT};
9673 627 100       1682 $fileType or $fileType = $baseType;
9674             # handle sub-types which are identified by extension
9675 627 100 100     3759 if (defined $ext and $ext ne $fileType and not $$self{DOC_NUM}) {
      66        
9676 275         2225 my ($f,$e) = @fileTypeLookup{$fileType,$ext};
9677 275 100 100     1711 if (ref $f eq 'ARRAY' and ref $e eq 'ARRAY' and $$f[0] eq $$e[0]) {
      100        
9678             # make sure $fileType was a root type and not another sub-type
9679 10 100 66     79 $fileType = $ext if $$f[0] eq $fileType or not $fileTypeLookup{$$f[0]};
9680             }
9681             }
9682 627 100       2502 $mimeType or $mimeType = $mimeType{$fileType};
9683             # use base file type if necessary (except if 'TIFF', which is a special case)
9684 627 100 66     1827 $mimeType = $mimeType{$baseType} unless $mimeType or $baseType eq 'TIFF';
9685 627 100       1487 unless (defined $normExt) {
9686 617         1509 $normExt = $fileTypeExt{$fileType};
9687 617 100       1531 $normExt = $fileType unless defined $normExt;
9688             }
9689             # ($$self{FileType} is the file type of the main document)
9690 627 50       1967 $$self{FileType} = $fileType unless $$self{DOC_NUM};
9691 627         2233 $self->FoundTag('FileType', $fileType);
9692 627         2179 $self->FoundTag('FileTypeExtension', uc $normExt);
9693 627   100     2257 $self->FoundTag('MIMEType', $mimeType || 'application/unknown');
9694             }
9695             }
9696              
9697             #------------------------------------------------------------------------------
9698             # Override the FileType and MIMEType tags
9699             # Inputs: 0) ExifTool object ref, 1) file type, 2) MIME type, 3) normal extension (lower case)
9700             # Notes: does nothing if FileType was not previously defined (ie. when writing)
9701             sub OverrideFileType($$;$$)
9702             {
9703 18     18 0 51 my ($self, $fileType, $mimeType, $normExt) = @_;
9704 18 100 66     126 if (defined $$self{VALUE}{FileType} and $fileType ne $$self{VALUE}{FileType}) {
9705 12         23 $$self{FileType} = $fileType;
9706 12         23 $$self{VALUE}{FileType} = $fileType;
9707 12 100       30 unless (defined $normExt) {
9708 5         13 $normExt = $fileTypeExt{$fileType};
9709 5 50       17 $normExt = $fileType unless defined $normExt;
9710             }
9711 12         28 $$self{VALUE}{FileTypeExtension} = uc $normExt;
9712 12 50       48 $mimeType or $mimeType = $mimeType{$fileType};
9713 12 100       34 $$self{VALUE}{MIMEType} = $mimeType if $mimeType;
9714 12 50       126 if ($$self{OPTIONS}{Verbose}) {
9715 0         0 $self->VPrint(0,"$$self{INDENT}FileType [override] = $fileType\n");
9716 0         0 $self->VPrint(0,"$$self{INDENT}FileTypeExtension [override] = $$self{VALUE}{FileTypeExtension}\n");
9717 0 0       0 $self->VPrint(0,"$$self{INDENT}MIMEType [override] = $mimeType\n") if $mimeType;
9718             }
9719             }
9720             }
9721              
9722             #------------------------------------------------------------------------------
9723             # Modify the value of the MIMEType tag
9724             # Inputs: 0) ExifTool object reference, 1) file or MIME type
9725             # Notes: combines existing type with new type: ie) a/b + c/d => c/b-d
9726             sub ModifyMimeType($;$)
9727             {
9728 8     8 0 21 my ($self, $mime) = @_;
9729 8 50 33     49 $mime =~ m{/} or $mime = $mimeType{$mime} or return;
9730 8         24 my $old = $$self{VALUE}{MIMEType};
9731 8 50       23 if (defined $old) {
9732 8         37 my ($a, $b) = split '/', $old;
9733 8         52 my ($c, $d) = split '/', $mime;
9734 8         33 $d =~ s/^x-//;
9735 8         31 $$self{VALUE}{MIMEType} = "$c/$b-$d";
9736 8         41 $self->VPrint(0, " Modified MIMEType = $c/$b-$d\n");
9737             } else {
9738 0         0 $self->FoundTag('MIMEType', $mime);
9739             }
9740             }
9741              
9742             #------------------------------------------------------------------------------
9743             # Print verbose output
9744             # Inputs: 0) ExifTool ref, 1) verbose level (prints if level > this), 2-N) print args
9745             sub VPrint($$@)
9746             {
9747 12499     12499 0 17732 my $self = shift;
9748 12499         13407 my $level = shift;
9749 12499 100 66     37510 if ($$self{OPTIONS}{Verbose} and $$self{OPTIONS}{Verbose} > $level) {
9750 4         8 my $out = $$self{OPTIONS}{TextOut};
9751 4         16 print $out @_;
9752 4 50       22 print $out "\n" unless $_[-1] =~ /\n$/;
9753             }
9754             }
9755              
9756             #------------------------------------------------------------------------------
9757             # Print verbose directory information
9758             # Inputs: 0) ExifTool object reference, 1) directory name or dirInfo ref
9759             # 2) number of entries in directory (or 0 if unknown)
9760             # 3) optional size of directory in bytes, 4) optional byte order for -v3 output
9761             sub VerboseDir($$;$$$)
9762             {
9763 2009     2009 0 3553 my ($self, $name, $entries, $size, $byteOrder) = @_;
9764 2009 100       4369 return unless $$self{OPTIONS}{Verbose};
9765 44 50       105 if (ref $name eq 'HASH') {
9766 0 0       0 $size = $$name{DirLen} unless $size;
9767 0   0     0 $name = $$name{Name} || $$name{DirName};
9768             }
9769 44         91 my $indent = substr($$self{INDENT}, 0, -2);
9770 44         74 my $out = $$self{OPTIONS}{TextOut};
9771 44 100 66     171 my $str = ($entries or defined $entries and not $size) ? " with $entries entries" : '';
9772 44 100       92 $str .= ", $size bytes" if $size;
9773 44 100 100     162 if ($byteOrder and $$self{OPTIONS}{Verbose} > 2) {
9774 11 50       17 $str .= ', ' . (GetByteOrder() eq 'II' ? 'Little-endian' : 'Big-endian');
9775             }
9776 44         135 print $out "$indent+ [$name directory$str]\n";
9777             }
9778              
9779             #------------------------------------------------------------------------------
9780             # Verbose dump
9781             # Inputs: 0) ExifTool ref, 1) data ref, 2-N) HexDump options
9782             sub VerboseDump($$;%)
9783             {
9784 1666     1666 0 1797 my $self = shift;
9785 1666         1724 my $dataPt = shift;
9786 1666         1988 my $verbose = $$self{OPTIONS}{Verbose};
9787 1666 50 33     3253 if ($verbose and $verbose > 2) {
9788             my %parms = (
9789             Prefix => $$self{INDENT},
9790             Out => $$self{OPTIONS}{TextOut},
9791 0 0       0 MaxLen => $verbose < 4 ? 96 : $verbose < 5 ? 2048 : undef,
    0          
9792             );
9793 0         0 HexDump($dataPt, undef, %parms, @_);
9794             }
9795             }
9796              
9797             #------------------------------------------------------------------------------
9798             # Print data in hex
9799             # Inputs: 0) data
9800             # Returns: hex string
9801             # (this is a convenience function for use in debugging PrintConv statements)
9802             sub PrintHex($)
9803             {
9804 0     0 0 0 my $val = shift;
9805 0         0 return join(' ', unpack('H2' x length($val), $val));
9806             }
9807              
9808             #------------------------------------------------------------------------------
9809             # Extract binary data from file
9810             # 0) ExifTool object reference, 1) offset, 2) length, 3) tag name if conditional
9811             # Returns: binary data, or undef on error
9812             # Notes: Returns "Binary data #### bytes" instead of data unless tag is
9813             # specifically requested or the Binary option is set
9814             sub ExtractBinary($$$;$)
9815             {
9816 47     47 0 112 my ($self, $offset, $length, $tag) = @_;
9817 47         73 my ($isPreview, $buff);
9818              
9819 47 100       98 if ($tag) {
9820 43 100       105 if ($tag eq 'PreviewImage') {
9821             # save PreviewImage start/length in case we want to dump trailer
9822 29         117 $$self{PreviewImageStart} = $offset;
9823 29         64 $$self{PreviewImageLength} = $length;
9824 29         37 $isPreview = 1;
9825             }
9826 43         111 my $lcTag = lc $tag;
9827 43         74 my $options = $$self{OPTIONS};
9828 43 100 66     495 if ((not $$options{Binary} or $$self{EXCL_TAG_LOOKUP}{$lcTag}) and
      66        
      100        
      66        
9829             not $$options{Verbose} and not $$options{Validate} and
9830             not $$self{REQ_TAG_LOOKUP}{$lcTag})
9831             {
9832 32         124 return "Binary data $length bytes";
9833             }
9834             }
9835 15 100 66     68 unless ($$self{RAF}->Seek($offset,0)
9836             and $$self{RAF}->Read($buff, $length) == $length)
9837             {
9838 5 50       13 $tag or $tag = 'binary data';
9839 5 50 33     42 if ($isPreview and not $$self{BuildingComposite}) {
9840 0         0 $$self{PreviewError} = 1;
9841             } else {
9842 5         30 $self->Warn("Error reading $tag from file", $isPreview);
9843             }
9844 5         17 return undef;
9845             }
9846 10         30 return $buff;
9847             }
9848              
9849             #------------------------------------------------------------------------------
9850             # Process binary data
9851             # Inputs: 0) ExifTool object ref, 1) directory information ref, 2) tag table ref
9852             # Returns: 1 on success
9853             # Notes: dirInfo may contain VarFormatData (reference to empty list) to return
9854             # details about any variable-length-format tags in the table (used when writing)
9855             sub ProcessBinaryData($$$)
9856             {
9857 2224     2224 0 3785 my ($self, $dirInfo, $tagTablePtr) = @_;
9858 2224         3364 my $dataPt = $$dirInfo{DataPt};
9859 2224         2986 my $dataLen = length $$dataPt;
9860 2224   100     5073 my $dirStart = $$dirInfo{DirStart} || 0;
9861 2224         2952 my $maxLen = $dataLen - $dirStart;
9862 2224         3113 my $size = $$dirInfo{DirLen};
9863 2224   100     4882 my $base = $$dirInfo{Base} || 0;
9864 2224         3737 my $verbose = $$self{OPTIONS}{Verbose};
9865 2224         3400 my $unknown = $$self{OPTIONS}{Unknown};
9866 2224   100     5144 my $dataPos = $$dirInfo{DataPos} || 0;
9867              
9868 2224 100 66     6195 $size = $maxLen if not defined $size or $size > $maxLen;
9869             # get default format ('int8u' unless specified)
9870 2224   100     5591 my $defaultFormat = $$tagTablePtr{FORMAT} || 'int8u';
9871 2224         3790 my $increment = $formatSize{$defaultFormat};
9872 2224 50       3969 unless ($increment) {
9873 0         0 warn "Unknown format $defaultFormat\n";
9874 0         0 $defaultFormat = 'int8u';
9875 0         0 $increment = $formatSize{$defaultFormat};
9876             }
9877             # prepare list of tag numbers to extract
9878 2224         3106 my (@tags, $topIndex, $binVal);
9879 2224 50 33     7365 if ($unknown > 1 and defined $$tagTablePtr{FIRST_ENTRY}) {
    100          
    100          
9880             # don't create a stupid number of tags if data is huge
9881 0 0       0 my $sizeLimit = $size < 65536 ? $size : 65536;
9882             # scan through entire binary table
9883 0         0 $topIndex = int($sizeLimit/$increment);
9884 0         0 @tags = ($$tagTablePtr{FIRST_ENTRY}..($topIndex - 1));
9885             # add in floating point tag ID's if they exist
9886 0         0 my @ftags = grep /\./, TagTableKeys($tagTablePtr);
9887 0 0       0 @tags = sort { $a <=> $b } @tags, @ftags if @ftags;
  0         0  
9888             } elsif ($$dirInfo{DataMember}) {
9889 220         317 @tags = @{$$dirInfo{DataMember}};
  220         509  
9890 220         322 $verbose = 0; # no verbose output of extracted values when writing
9891             } elsif ($$dirInfo{MixedTags}) {
9892             # process sorted integer-ID tags only
9893 48         121 @tags = sort { $a <=> $b } grep /^\d+$/, TagTableKeys($tagTablePtr);
  556         793  
9894             } else {
9895             # extract known tags in numerical order
9896 1956 50       4426 @tags = sort { ($a < 0 ? $a + 1e9 : $a) <=> ($b < 0 ? $b + 1e9 : $b) } TagTableKeys($tagTablePtr);
  57882 50       84165  
9897             }
9898 2224 100       4749 $self->VerboseDir('BinaryData', undef, $size, GetByteOrder()) if $verbose;
9899             # avoid creating unknown tags for tags that fail condition if Unknown is 1
9900 2224 50       6095 $$self{NO_UNKNOWN} = 1 if $unknown < 2;
9901 2224         3093 my ($index, %val);
9902 2224         2708 my $nextIndex = 0;
9903 2224         2634 my $varSize = 0;
9904 2224         3129 foreach $index (@tags) {
9905 18428         24923 my ($tagInfo, $val, $saveNextIndex, $len, $mask, $wasVar, $rational, $offAdj);
9906 18428 50 0     31160 if ($$tagTablePtr{$index}) {
    0          
9907 18428         32679 $tagInfo = $self->GetTagInfo($tagTablePtr, $index);
9908 18428 100       28447 unless ($tagInfo) {
9909 789 100       1583 next unless defined $tagInfo;
9910             # $entry = offset of value relative to directory start (or end if negative)
9911 51         156 my $entry = int($index) * $increment + $varSize;
9912 51 50       141 if ($entry < 0) {
9913 0         0 $entry += $size;
9914 0 0       0 next if $entry < 0;
9915             }
9916 51 100       160 next if $entry >= $size;
9917 7         19 my $more = $size - $entry;
9918 7 50       19 $more = 128 if $more > 128;
9919 7         35 my $v = substr($$dataPt, $entry+$dirStart, $more);
9920 7         23 $tagInfo = $self->GetTagInfo($tagTablePtr, $index, \$v);
9921 7 50       24 next unless $tagInfo;
9922             }
9923             next if $$tagInfo{Unknown} and
9924 17646 100 66     27925 ($$tagInfo{Unknown} > $unknown or $index < $nextIndex);
      66        
9925             } elsif ($topIndex and $$tagTablePtr{$index - $topIndex}) {
9926 0 0       0 $tagInfo = $self->GetTagInfo($tagTablePtr, $index - $topIndex) or next;
9927             } else {
9928             # don't generate unknown tags in binary tables unless Unknown > 1
9929 0 0       0 next unless $unknown > 1;
9930 0 0       0 next if $index < $nextIndex; # skip if data already used
9931 0 0       0 $tagInfo = $self->GetTagInfo($tagTablePtr, $index) or next;
9932 0         0 $$tagInfo{Unknown} = 2; # set unknown to 2 for binary unknowns
9933             }
9934             # get relative offset of this entry
9935 17645         22969 my $entry = int($index) * $increment + $varSize;
9936             # allow negative indices to represent bytes from end
9937 17645 50       24716 if ($entry < 0) {
9938 0         0 $entry += $size;
9939 0 0       0 next if $entry < 0;
9940             }
9941 17645         19481 my $more = $size - $entry;
9942 17645 100       23907 last if $more <= 0; # all done if we have reached the end of data
9943 17341         18446 my $count = 1;
9944 17341         22382 my $format = $$tagInfo{Format};
9945 17341 100       33337 if (not $format) {
    100          
    50          
    100          
9946 9978         11697 $format = $defaultFormat;
9947             } elsif ($format eq 'string') {
9948             # string with no specified count runs to end of block
9949 127         192 $count = $more;
9950             } elsif ($format eq 'pstring') {
9951 0         0 $format = 'string';
9952 0         0 $count = Get8u($dataPt, ($entry++)+$dirStart);
9953 0         0 --$more;
9954             } elsif (not $formatSize{$format}) {
9955 3354 100       13715 if ($format =~ /(.*)\[(.*)\]/) {
    50          
9956             # handle format count field
9957 3170         6454 $format = $1;
9958 3170         4511 $count = $2;
9959             # evaluate count to allow count to be based on previous values
9960             #### eval Format size (%val, $size, $varSize, $self)
9961 3170         114655 $count = eval $count;
9962 3170 50       9098 $@ and warn("Format $$tagInfo{Name}: $@"), next;
9963 3170 50       5263 next if $count < 0;
9964             # allow a variable-length value of any format
9965             # (note: the next incremental index points to data immediately after
9966             # this value, regardless of the size of this value, even if it is zero)
9967 3170 50       6327 if ($format =~ s/^var_//) {
9968 0   0     0 $varSize += $count * ($formatSize{$format} || 1) - $increment;
9969 0         0 $wasVar = 1;
9970             # save variable size data if required for writing
9971 0 0       0 if ($$dirInfo{VarFormatData}) {
9972 0         0 push @{$$dirInfo{VarFormatData}}, [ $index, $varSize, $format ];
  0         0  
9973             }
9974             # don't extract value if large and we wanted it just to get
9975             # the variable-format information when writing
9976 0 0 0     0 next if $$tagInfo{LargeTag} and $$dirInfo{VarFormatData};
9977             }
9978             } elsif ($format =~ /^var_/) {
9979             # handle variable-length string formats
9980 184         348 $format = substr($format, 4);
9981 184         584 pos($$dataPt) = $entry + $dirStart;
9982 184         352 undef $count;
9983 184 50 100     780 if ($format eq 'ustring') {
    50          
    100          
    100          
    100          
    50          
9984 0 0       0 $count = pos($$dataPt) - ($entry+$dirStart) if $$dataPt =~ /\G(..)*?\0\0/sg;
9985 0         0 $varSize -= 2; # ($count includes base size of 2 bytes)
9986             } elsif ($format eq 'pstring') {
9987 0         0 $count = Get8u($dataPt, ($entry++)+$dirStart);
9988 0         0 --$more;
9989             } elsif ($format eq 'pstr32' or $format eq 'ustr32') {
9990 170 50       306 last if $more < 4;
9991 170         315 $count = Get32u($dataPt, $entry + $dirStart);
9992 170 100       360 $count *= 2 if $format eq 'ustr32';
9993 170         240 $entry += 4;
9994 170         229 $more -= 4;
9995 170         349 $nextIndex += 4 / $increment; # (increment next index for int32u)
9996             } elsif ($format eq 'int16u') {
9997             # int16u size of binary data to follow
9998 10 50       24 last if $more < 2;
9999 10         21 $count = Get16u($dataPt, $entry + $dirStart) + 2;
10000 10         19 $varSize -= 2; # ($count includes size word)
10001 10         14 $format = 'undef';
10002             } elsif ($format eq 'ue7') {
10003 3         11 require Image::ExifTool::BPG;
10004 3         8 ($val, $count) = Image::ExifTool::BPG::Get_ue7($dataPt, $entry + $dirStart);
10005 3 50       20 last unless defined $val;
10006 3         4 --$varSize; # ($count includes base size of 1 byte)
10007             } elsif ($$dataPt =~ /\0/g) {
10008 1         1 $count = pos($$dataPt) - ($entry+$dirStart);
10009 1         2 --$varSize; # ($count includes base size of 1 byte)
10010             }
10011 184 50 33     530 $count = $more if not defined $count or $count > $more;
10012 184         248 $varSize += $count; # shift subsequent indices
10013 184 100       323 unless (defined $val) {
10014 181         367 $val = substr($$dataPt, $entry+$dirStart, $count);
10015 181 100 66     745 $val = $self->Decode($val, 'UTF16') if $format eq 'ustring' or $format eq 'ustr32';
10016 181 100       436 $val =~ s/\0.*//s unless $format eq 'undef'; # truncate at null
10017             }
10018 184 50       703 $binVal = substr($$dataPt, $entry+$dirStart, $count) if $$self{OPTIONS}{SaveBin};
10019 184         236 $wasVar = 1;
10020             # save variable size data if required for writing
10021 184 100       386 if ($$dirInfo{VarFormatData}) {
10022 5         8 push @{$$dirInfo{VarFormatData}}, [ $index, $varSize, $format ];
  5         18  
10023             }
10024             }
10025             }
10026             # hook to allow format, etc to be set dynamically
10027 17341 100       27834 if (defined $$tagInfo{Hook}) {
10028 691         868 my $oldVarSize = $varSize;
10029 691         828 my $pos = $entry + $dirStart;
10030             #### eval Hook ($format, $varSize, $size, $dataPt, $pos)
10031 691         38955 eval $$tagInfo{Hook};
10032             # save variable size data if required for writing (in case changed by Hook)
10033 691 100 66     3036 if ($$dirInfo{VarFormatData}) {
    50          
10034 322 50       595 $#{$$dirInfo{VarFormatData}} -= 1 if $wasVar; # remove previous entry for this tag
  0         0  
10035 322         439 push @{$$dirInfo{VarFormatData}}, [ $index, $varSize, $format ];
  322         1074  
10036             } elsif ($varSize != $oldVarSize and $verbose > 2) {
10037 0         0 my ($tmp, $sign) = ($varSize, '+');
10038 0 0       0 $tmp < 0 and $tmp = -$tmp, $sign = '-';
10039 0         0 $offAdj = sprintf("$$self{INDENT}\[offsets adjusted by ${sign}0x%.4x after 0x%.4x $$tagInfo{Name}]\n", $tmp, $index);
10040             }
10041             }
10042 17341 50       25047 if ($unknown > 1) {
10043             # calculate next valid index for unknown tag
10044 0         0 my $ni = int $index;
10045 0 0 0     0 $ni += (($formatSize{$format} || 1) * $count) / $increment unless $wasVar;
10046 0         0 $saveNextIndex = $nextIndex;
10047 0 0       0 $nextIndex = $ni unless $nextIndex > $ni;
10048             }
10049             # allow large tags to be excluded from extraction
10050             # (provides a work-around for some tight memory situations)
10051 17341 50 33     29950 next if $$tagInfo{LargeTag} and $$self{EXCL_TAG_LOOKUP}{lc $$tagInfo{Name}};
10052             # read value now if necessary
10053 17341 100 66     28537 unless (defined $val and not $$tagInfo{SubDirectory}) {
10054 17157         33192 $val = ReadValue($dataPt, $entry+$dirStart, $format, $count, $more, \$rational);
10055 17157 50       26102 next unless defined $val;
10056 17157         20921 $mask = $$tagInfo{Mask};
10057 17157 100       24777 $val = ($val & $mask) >> $$tagInfo{BitShift} if $mask;
10058             }
10059 17341 100 66     27491 if ($verbose and not $$tagInfo{Hidden}) {
10060 198 50 33     437 if (not $$tagInfo{SubDirectory} or $$tagInfo{Format}) {
10061 198   50     372 $len = $count * ($formatSize{$format} || 1);
10062 198 50       318 $len = $more if $len > $more;
10063             } else {
10064 0         0 $len = $more;
10065             }
10066 198 100       703 $self->VerboseInfo($index, $tagInfo,
10067             Table => $tagTablePtr,
10068             Value => $val,
10069             DataPt => $dataPt,
10070             Size => $len,
10071             Start => $entry+$dirStart,
10072             Addr => $entry+$dirStart+$base+$dataPos,
10073             Format => $format,
10074             Count => $count,
10075             Extra => $mask ? sprintf(', mask 0x%.2x',$mask) : undef,
10076             );
10077             }
10078 17341 50       23925 $offAdj and $self->VPrint(2, $offAdj);
10079             # parse nested BinaryData directories
10080 17341 100       26850 if ($$tagInfo{SubDirectory}) {
10081 14         36 my $subdir = $$tagInfo{SubDirectory};
10082 14         45 my $subTablePtr = GetTagTable($$subdir{TagTable});
10083             # use specified subdirectory length if given
10084 14 100 66     93 if ($$tagInfo{Format} and $formatSize{$format}) {
10085 12         28 $len = $count * $formatSize{$format};
10086 12 50       37 $len = $more if $len > $more;
10087             } else {
10088 2         4 $len = $more; # directory size is all of remaining data
10089 2 50 33     12 if ($$subTablePtr{PROCESS_PROC} and
10090             $$subTablePtr{PROCESS_PROC} eq \&ProcessBinaryData)
10091             {
10092             # the rest of the data will be printed in the subdirectory
10093 2         6 $nextIndex = $size / $increment;
10094             }
10095             }
10096 14         25 my $subdirBase = $base;
10097 14 50       44 if (defined $$subdir{Base}) {
10098             #### eval Base ($start,$base)
10099 0         0 my $start = $entry + $dirStart + $dataPos;
10100 0         0 $subdirBase = eval($$subdir{Base}) + $base;
10101             }
10102 14   50     56 my $start = $$subdir{Start} || 0;
10103 14         25 my $notDup;
10104 14 50       46 if ($start =~ /\$/) {
10105             # ignore directories with a zero offset (ie. missing Nikon ShotInfo entries)
10106 0 0       0 next unless $val;
10107             #### eval Start ($val, $dirStart)
10108 0         0 $start = eval($start);
10109 0 0 0     0 next if $start < $dirStart or $start > $dataLen;
10110 0         0 $len = $$subdir{DirLen};
10111 0 0 0     0 $len = $dataLen - $start unless $len and $len <= $dataLen - $start;
10112             } else {
10113 14         28 $start += $dirStart + $entry;
10114 14         20 $notDup = 1,
10115             }
10116 14         96 my %subdirInfo = (
10117             DataPt => $dataPt,
10118             DataPos => $dataPos,
10119             DataLen => $dataLen,
10120             DirStart => $start,
10121             DirLen => $len,
10122             Base => $subdirBase,
10123             NotDup => $notDup,
10124             );
10125 14         34 delete $$self{NO_UNKNOWN};
10126 14         99 $self->ProcessDirectory(\%subdirInfo, $subTablePtr, $$subdir{ProcessProc});
10127 14 50       66 $$self{NO_UNKNOWN} = 1 if $unknown < 2;
10128 14         48 next;
10129             }
10130 17327 100 66     29856 if ($$tagInfo{IsOffset} and $$tagInfo{IsOffset} ne '3') {
10131 38         48 my $et = $self;
10132             #### eval IsOffset ($val, $et)
10133 38 100       2165 $val += $base + $$self{BASE} if eval $$tagInfo{IsOffset};
10134             }
10135 17327         28495 $val{$index} = $val;
10136 17327         18313 my $oldBase;
10137 17327 50       24256 if ($$tagInfo{SetBase}) {
10138 0         0 $oldBase = $$self{BASE};
10139 0         0 $$self{BASE} += $base;
10140             }
10141 17327         31422 my $key = $self->FoundTag($tagInfo,$val);
10142 17327 50       28275 $$self{BASE} = $oldBase if defined $oldBase;
10143 17327 100       22689 if ($key) {
10144 15834 100       22193 $$self{TAG_EXTRA}{$key}{Rational} = $rational if defined $rational;
10145 15834 50       31660 $$self{TAG_EXTRA}{$key}{BinVal} = $binVal if defined $binVal;
10146             } else {
10147             # don't increment nextIndex if we didn't extract a tag
10148 1493 50       3758 $nextIndex = $saveNextIndex if defined $saveNextIndex;
10149             }
10150             }
10151 2224         3780 delete $$self{NO_UNKNOWN};
10152 2224         10331 return 1;
10153             }
10154              
10155             #..............................................................................
10156             # Load .ExifTool_config file from user's home directory
10157             # (use of noConfig is now deprecated, use configFile = '' instead)
10158             push @configFiles, $configFile if defined $configFile;
10159             until ($noConfig) {
10160             my $config = shift @configFiles;
10161             my $file;
10162             if (not defined $config) {
10163             $config = '.ExifTool_config';
10164             # get our home directory (HOMEDRIVE and HOMEPATH are used in Windows cmd shell)
10165             my $home = $ENV{EXIFTOOL_HOME} || $ENV{HOME} ||
10166             ($ENV{HOMEDRIVE} || '') . ($ENV{HOMEPATH} || '') || '.';
10167             # look for the config file in 1) the home directory, 2) the program dir
10168             $file = "$home/$config";
10169             } else {
10170             length $config or last; # filename of "" disables configuration
10171             $file = $config;
10172             }
10173             # also check executable directory unless path is absolute
10174             $exeDir = ($0 =~ /(.*)[\\\/]/) ? $1 : '.' unless defined $exeDir;
10175             -r $file or $config =~ /^\// or $file = "$exeDir/$config";
10176             unless (-r $file) {
10177             warn("Config file not found\n") if defined $Image::ExifTool::configFile;
10178             last;
10179             }
10180             unshift @INC, '.'; # look in current directory first
10181             eval { require $file }; # load the config file
10182             shift @INC;
10183             # print warning (minus "Compilation failed" part)
10184             $@ and $_=$@, s/Compilation failed.*//s, warn $_;
10185             last unless @configFiles;
10186             }
10187             # read user-defined lenses (may have been defined by script instead of config file)
10188             if (@Image::ExifTool::UserDefined::Lenses) {
10189             foreach (@Image::ExifTool::UserDefined::Lenses) {
10190             $Image::ExifTool::userLens{$_} = 1;
10191             }
10192             }
10193             # add user-defined file types
10194             if (%Image::ExifTool::UserDefined::FileTypes) {
10195             foreach (sort keys %Image::ExifTool::UserDefined::FileTypes) {
10196             my $fileInfo = $Image::ExifTool::UserDefined::FileTypes{$_};
10197             my $type = uc $_;
10198             ref $fileInfo eq 'HASH' or $fileTypeLookup{$type} = $fileInfo, next;
10199             my $baseType = $$fileInfo{BaseType};
10200             if ($baseType) {
10201             if ($$fileInfo{Description}) {
10202             $fileTypeLookup{$type} = [ $baseType, $$fileInfo{Description} ];
10203             } else {
10204             $fileTypeLookup{$type} = $baseType;
10205             }
10206             if (defined $$fileInfo{Writable} and not $$fileInfo{Writable}) {
10207             # first make sure we are using an actual base type and not a derived type
10208             $baseType = $fileTypeLookup{$baseType} while $baseType and not ref $fileTypeLookup{$baseType};
10209             # mark this type as not writable
10210             $noWriteFile{$baseType} or $noWriteFile{$baseType} = [ ];
10211             push @{$noWriteFile{$baseType}}, $type;
10212             }
10213             } else {
10214             $fileTypeLookup{$type} = [ $type, $$fileInfo{Description} || $type ];
10215             $moduleName{$type} = 0; # not supported
10216             if ($$fileInfo{Magic}) {
10217             $magicNumber{$type} = $$fileInfo{Magic};
10218             push @fileTypes, $type unless grep /^$type$/, @fileTypes;
10219             }
10220             }
10221             $mimeType{$type} = $$fileInfo{MIMEType} if defined $$fileInfo{MIMEType};
10222             }
10223             }
10224              
10225             #------------------------------------------------------------------------------
10226             1; # end