File Coverage

blib/lib/Image/ExifTool.pm
Criterion Covered Total %
statement 3182 4331 73.4
branch 2024 3336 60.6
condition 902 1723 52.3
subroutine 159 176 90.3
pod 26 159 16.3
total 6293 9725 64.7


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   900146 use strict;
  113         285  
  113         7021  
19             require 5.004; # require 5.004 for UNIVERSAL::isa (otherwise 5.002 would do)
20             require Exporter;
21 113     113   67399 use File::RandomAccess;
  113         365  
  113         8265  
22 113     113   78871 use overload;
  113         218210  
  113         874  
23              
24 113         988557 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   11671 %static_vars $advFmtSelf $configFile @configFiles $noConfig);
  113         221  
31              
32             $VERSION = '13.50';
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', 1, '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 3092 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             my %systemTagsNotes = (
1251             Notes => q{
1252             extracted only if specifically requested or the API L or L
1253             option is set
1254             },
1255             );
1256              
1257             # tag information for preview image -- this should be used for all
1258             # PreviewImage tags so they are handled properly when reading/writing
1259             %Image::ExifTool::previewImageTagInfo = (
1260             Name => 'PreviewImage',
1261             Writable => 'undef',
1262             # a value of 'none' is ok...
1263             WriteCheck => '$val eq "none" ? undef : $self->CheckImage(\$val)',
1264             DataTag => 'PreviewImage',
1265             # accept either scalar or scalar reference
1266             RawConv => '$self->ValidateImage(ref $val ? $val : \$val, $tag)',
1267             # we allow preview image to be set to '', but we don't want a zero-length value
1268             # in the IFD, so set it temporarily to 'none'. Note that the length is <= 4,
1269             # so this value will fit in the IFD so the preview fixup won't be generated.
1270             ValueConvInv => '$val eq "" and $val="none"; $val',
1271             );
1272              
1273             # extra tags that aren't truly EXIF tags, but are generated by the script
1274             # Note: any tag in this list with a name corresponding to a Group0 name is
1275             # used to write the entire corresponding directory as a block.
1276             %Image::ExifTool::Extra = (
1277             GROUPS => { 0 => 'File', 1 => 'File', 2 => 'Image' },
1278             VARS => { ID_FMT => 'none' }, # tag ID's aren't meaningful for these tags
1279             WRITE_PROC => \&DummyWriteProc,
1280             Error => {
1281             Priority => 0,
1282             Groups => \%allGroupsExifTool,
1283             Notes => q{
1284             returns errors that may have occurred while reading or writing a file. Any
1285             Error will prevent the file from being processed. Minor errors may be
1286             downgraded to warnings with the -m or L option
1287             },
1288             },
1289             Warning => {
1290             Priority => 0,
1291             Groups => \%allGroupsExifTool,
1292             Notes => q{
1293             returns warnings that may have occurred while reading or writing a file.
1294             Use the -a or L option to see all warnings if more than one
1295             occurred. Minor warnings may be ignored with the -m or L
1296             option. Minor warnings with a capital "M" in the "[Minor]" designation
1297             indicate that the processing is affected by ignoring the warning. Multiple
1298             identical warnings are indicated by a count after the warning message, eg.
1299             "[x2]" if the same warning occurred twice
1300             },
1301             },
1302             Comment => {
1303             Notes => 'comment embedded in JPEG, GIF89a or PPM/PGM/PBM image',
1304             Writable => 1,
1305             WriteGroup => 'Comment',
1306             Priority => 0, # to preserve order of JPEG COM segments
1307             },
1308             Directory => {
1309             Groups => { 1 => 'System', 2 => 'Other' },
1310             Notes => q{
1311             the directory of the file as specified in the call to ExifTool, or "." if no
1312             directory was specified. May be written to move the file to another
1313             directory that will be created if doesn't already exist
1314             },
1315             Writable => 1,
1316             WritePseudo => 1,
1317             Priority => 2,
1318             DelCheck => q{"Can't delete"},
1319             Protected => 1,
1320             RawConv => '$self->ConvertFileName($val)',
1321             # translate backslashes in directory names and add trailing '/'
1322             ValueConvInv => '$_ = $self->InverseFileName($val); m{[^/]$} and $_ .= "/"; $_',
1323             },
1324             FileName => {
1325             Groups => { 1 => 'System', 2 => 'Other' },
1326             Writable => 1,
1327             WritePseudo => 1,
1328             DelCheck => q{"Can't delete"},
1329             Protected => 1,
1330             Priority => 2,
1331             Notes => q{
1332             may be written with a full path name to set FileName and Directory in one
1333             operation. This is such a powerful feature that a TestName tag is provided
1334             to allow dry-run tests before actually writing the file name. See
1335             L for more information on writing the
1336             FileName, Directory and TestName tags
1337             },
1338             RawConv => '$self->ConvertFileName($val)',
1339             ValueConvInv => '$self->InverseFileName($val)',
1340             },
1341             BaseName => {
1342             Groups => { 1 => 'System', 2 => 'Other' },
1343             Priority => 2,
1344             Notes => q{
1345             file name without extension. Not generated unless specifically requested or
1346             the API L option is set
1347             },
1348             },
1349             FilePath => {
1350             Groups => { 1 => 'System', 2 => 'Other' },
1351             Notes => q{
1352             absolute path of source file. Not generated unless specifically requested or
1353             the API L option is set. Does not support Windows Unicode file
1354             names
1355             },
1356             },
1357             TestName => {
1358             Writable => 1,
1359             WritePseudo => 1,
1360             DelCheck => q{"Can't delete"},
1361             Protected => 1,
1362             WriteOnly => 1,
1363             Notes => q{
1364             this write-only tag may be used instead of FileName for dry-run tests of the
1365             file renaming feature. Writing this tag prints the old and new file names
1366             to the console, but does not affect the file itself
1367             },
1368             ValueConvInv => '$self->InverseFileName($val)',
1369             },
1370             FileSequence => {
1371             Groups => { 0 => 'ExifTool', 1 => 'ExifTool', 2 => 'Other' },
1372             Notes => q{
1373             sequence number for each source file when extracting or copying information,
1374             including files that fail the -if condition of the command-line application,
1375             beginning at 0 for the first file. Not generated unless specifically
1376             requested or the API L option is set
1377             },
1378             },
1379             FileSize => {
1380             Groups => { 1 => 'System', 2 => 'Other' },
1381             Notes => q{
1382             note that the print conversion for this tag uses SI prefixes by default: 1
1383             kB = 1000 bytes, etc. Set the API ByteUnit option to "Binary" to use binary
1384             prefixes instead: 1 KiB = 1024 bytes, etc.
1385             },
1386             PrintConv => \&ConvertFileSize,
1387             },
1388             ResourceForkSize => {
1389             Groups => { 1 => 'System', 2 => 'Other' },
1390             Notes => q{
1391             size of the file's resource fork if it contains data. Mac OS only. If this
1392             tag is generated the L option may be used to extract
1393             resource-fork information as a sub-document. When writing, the resource
1394             fork is preserved by default, but it may be deleted with C<-rsrc:all=> on
1395             the command line
1396             },
1397             PrintConv => \&ConvertFileSize,
1398             },
1399             ZoneIdentifier => {
1400             Groups => { 1 => 'System', 2 => 'Other' },
1401             Notes => q{
1402             Windows only. Existence indicates that the file has a Zone.Identifier
1403             alternate data stream, which is used by some Windows browsers to mark
1404             downloaded files as possibly unsafe to run. May be deleted to remove this
1405             stream. Requires Win32API::File
1406             },
1407             Writable => 1,
1408             WritePseudo => 1,
1409             Protected => 1,
1410             },
1411             FileType => {
1412             Groups => { 2 => 'Other' },
1413             Priority => 2,
1414             Notes => q{
1415             a short description of the file type. For many file types this is the just
1416             the uppercase file extension
1417             },
1418             },
1419             FileTypeExtension => {
1420             Groups => { 2 => 'Other' },
1421             Notes => q{
1422             a common lowercase extension for this file type, or uppercase with the -n
1423             option
1424             },
1425             PrintConv => 'lc $val',
1426             },
1427             FileModifyDate => {
1428             Description => 'File Modification Date/Time',
1429             Notes => q{
1430             the filesystem modification date/time. Note that ExifTool may not be able
1431             to handle filesystem dates before 1970 depending on the limitations of the
1432             system's standard libraries
1433             },
1434             Groups => { 1 => 'System', 2 => 'Time' },
1435             Writable => 1,
1436             WritePseudo => 1,
1437             DelCheck => q{"Can't delete"},
1438             # all writable pseudo-tags must be protected so -tagsfromfile fails with
1439             # unrecognized files unless a pseudo tag is specified explicitly
1440             Protected => 1,
1441             Shift => 'Time',
1442             ValueConv => 'ConvertUnixTime($val,1)',
1443             ValueConvInv => 'GetUnixTime($val,1)',
1444             PrintConv => '$self->ConvertDateTime($val)',
1445             PrintConvInv => '$self->InverseDateTime($val)',
1446             },
1447             FileAccessDate => {
1448             Description => 'File Access Date/Time',
1449             Notes => q{
1450             the date/time of last access of the file. Note that this access time is
1451             updated whenever any software, including ExifTool, reads the file
1452             },
1453             Groups => { 1 => 'System', 2 => 'Time' },
1454             ValueConv => 'ConvertUnixTime($val,1)',
1455             PrintConv => '$self->ConvertDateTime($val)',
1456             },
1457             FileCreateDate => {
1458             Description => 'File Creation Date/Time',
1459             Notes => q{
1460             the filesystem creation date/time. Windows/Mac only. In Windows, the file
1461             creation date/time is preserved by default when writing if Win32API::File
1462             and Win32::API are available. On Mac, this tag is extracted only if it or
1463             the MacOS group is specifically requested or the API L option is
1464             set to 2 or higher. Requires "setfile" for writing on Mac, which may be
1465             installed by typing C in the Terminal
1466             },
1467             Groups => { 1 => 'System', 2 => 'Time' },
1468             Writable => 1,
1469             WritePseudo => 1,
1470             DelCheck => q{"Can't delete"},
1471             Protected => 1, # all writable pseudo-tags must be protected!
1472             Shift => 'Time',
1473             ValueConv => '$^O eq "darwin" ? $val : ConvertUnixTime($val,1)',
1474             ValueConvInv => q{
1475             return GetUnixTime($val,1) if $^O eq 'MSWin32';
1476             return $val if $^O eq 'darwin';
1477             warn "This tag is Windows/Mac only\n";
1478             return undef;
1479             },
1480             PrintConv => '$self->ConvertDateTime($val)',
1481             PrintConvInv => '$self->InverseDateTime($val)',
1482             },
1483             FileInodeChangeDate => {
1484             Description => 'File Inode Change Date/Time',
1485             Notes => q{
1486             the date/time when the file's directory information was last changed.
1487             Non-Windows systems only
1488             },
1489             Groups => { 1 => 'System', 2 => 'Time' },
1490             ValueConv => 'ConvertUnixTime($val,1)',
1491             PrintConv => '$self->ConvertDateTime($val)',
1492             },
1493             FilePermissions => {
1494             Groups => { 1 => 'System', 2 => 'Other' },
1495             Notes => q{
1496             r=read, w=write and x=execute permissions for the file owner, group and
1497             others. The ValueConv value is an octal number so bit test operations on
1498             this value should be done in octal, eg. 'oct($filePermissions#) & 0200'
1499             },
1500             Writable => 1,
1501             WritePseudo => 1,
1502             DelCheck => q{"Can't delete"},
1503             Protected => 1, # all writable pseudo-tags must be protected!
1504             ValueConv => 'sprintf("%.3o", $val)',
1505             ValueConvInv => 'oct($val & 07777)',
1506             PrintConv => sub {
1507             my ($mask, $val) = (0400, oct(shift));
1508             my %types = (
1509             0010000 => 'p', # FIFO
1510             0020000 => 'c', # character special file
1511             0040000 => 'd', # directory
1512             0060000 => 'b', # block special file
1513             0120000 => 'l', # sym link
1514             0140000 => 's', # socket link
1515             );
1516             my $str = $types{$val & 0170000} || '-';
1517             while ($mask) {
1518             foreach (qw(r w x)) {
1519             $str .= $val & $mask ? $_ : '-';
1520             $mask >>= 1;
1521             }
1522             }
1523             return $str;
1524             },
1525             PrintConvInv => sub {
1526             my ($bit, $val, $str) = (8, 0, shift);
1527             $str = substr($str, 1) if length($str) == 10;
1528             return undef if length($str) != 9;
1529             while ($bit >= 0) {
1530             foreach (qw(r w x)) {
1531             $val |= (1 << $bit) if substr($str, 8-$bit, 1) eq $_;
1532             --$bit;
1533             }
1534             }
1535             return sprintf('%.3o', $val);
1536             },
1537             },
1538             FileAttributes => {
1539             Groups => { 1 => 'System', 2 => 'Other' },
1540             Notes => q{
1541             extracted only if specifically requested or the API L or L
1542             option is set. 2 or 3 values: 0. File type, 1. Attribute bits, 2. Windows
1543             attribute bits if Win32API::File is available
1544             },
1545             PrintHex => 1,
1546             PrintConvColumns => 2,
1547             PrintConv => [{ # stat device types (bitmask 0xf000)
1548             0x0000 => 'Unknown',
1549             0x1000 => 'FIFO',
1550             0x2000 => 'Character',
1551             0x3000 => 'Mux Character',
1552             0x4000 => 'Directory',
1553             0x5000 => 'XENIX Named',
1554             0x6000 => 'Block',
1555             0x7000 => 'Mux Block',
1556             0x8000 => 'Regular',
1557             0x9000 => 'VxFS Compressed',
1558             0xa000 => 'Symbolic Link',
1559             0xb000 => 'Solaris Shadow Inode',
1560             0xc000 => 'Socket',
1561             0xd000 => 'Solaris Door',
1562             0xe000 => 'BSD Whiteout',
1563             },{ BITMASK => { # stat attribute bits (bitmask 0x0e00)
1564             9 => 'Sticky',
1565             10 => 'Set Group ID',
1566             11 => 'Set User ID',
1567             }},{ BITMASK => { # Windows attribute bits
1568             0 => 'Read Only',
1569             1 => 'Hidden',
1570             2 => 'System',
1571             3 => 'Volume Label',
1572             4 => 'Directory',
1573             5 => 'Archive',
1574             6 => 'Device',
1575             7 => 'Normal',
1576             8 => 'Temporary',
1577             9 => 'Sparse File',
1578             10 => 'Reparse Point',
1579             11 => 'Compressed',
1580             12 => 'Offline',
1581             13 => 'Not Content Indexed',
1582             14 => 'Encrypted',
1583             }}],
1584             },
1585             FileDeviceID => {
1586             Groups => { 1 => 'System', 2 => 'Other' },
1587             %systemTagsNotes,
1588             PrintConv => '(($val >> 24) & 0xff) . "." . ($val & 0xffffff)', # (major.minor)
1589             },
1590             FileDeviceNumber => { Groups => { 1 => 'System', 2 => 'Other' }, %systemTagsNotes },
1591             FileInodeNumber => { Groups => { 1 => 'System', 2 => 'Other' }, %systemTagsNotes },
1592             FileHardLinks => { Groups => { 1 => 'System', 2 => 'Other' }, %systemTagsNotes },
1593             FileUserID => {
1594             Groups => { 1 => 'System', 2 => 'Other' },
1595             Notes => q{
1596             extracted only if specifically requested or the API L or L
1597             option is set. Returns user ID number with the -n option, or name
1598             otherwise. May be written with either user name or number
1599             },
1600             Writable => 1,
1601             WritePseudo => 1,
1602             DelCheck => q{"Can't delete"},
1603             Protected => 1, # all writable pseudo-tags must be protected!
1604             PrintConv => 'eval { getpwuid($val) } || $val',
1605             PrintConvInv => 'eval { getpwnam($val) } || ($val=~/[^0-9]/ ? undef : $val)',
1606             },
1607             FileGroupID => {
1608             Groups => { 1 => 'System', 2 => 'Other' },
1609             Notes => q{
1610             extracted only if specifically requested or the API L or L
1611             option is set. Returns group ID number with the -n option, or name
1612             otherwise. May be written with either group name or number
1613             },
1614             Writable => 1,
1615             WritePseudo => 1,
1616             DelCheck => q{"Can't delete"},
1617             Protected => 1, # all writable pseudo-tags must be protected!
1618             PrintConv => 'eval { getgrgid($val) } || $val',
1619             PrintConvInv => 'eval { getgrnam($val) } || ($val=~/[^0-9]/ ? undef : $val)',
1620             },
1621             FileBlockSize => { Groups => { 1 => 'System', 2 => 'Other' }, %systemTagsNotes },
1622             FileBlockCount => { Groups => { 1 => 'System', 2 => 'Other' }, %systemTagsNotes },
1623             HardLink => {
1624             Writable => 1,
1625             DelCheck => q{"Can't delete"},
1626             WriteOnly => 1,
1627             WritePseudo => 1,
1628             Protected => 1,
1629             Notes => q{
1630             this write-only tag is used to create a hard link with the specified name to
1631             the source file. If the source file is edited, copied, renamed or moved in
1632             the same operation as writing HardLink, then the link is made to the updated
1633             file. Note that subsequent editing of either hard-linked file by exiftool
1634             will break the link unless the -overwrite_original_in_place option is used
1635             },
1636             ValueConvInv => '$val=~tr/\\\\/\//; $val',
1637             },
1638             SymLink => {
1639             Writable => 1,
1640             DelCheck => q{"Can't delete"},
1641             WriteOnly => 1,
1642             WritePseudo => 1,
1643             Protected => 1,
1644             Notes => q{
1645             this write-only tag is used to create a symbolic link with the specified
1646             name to the source file. If the source file is edited, copied, renamed or
1647             moved in the same operation as writing SymLink, then the link is made to the
1648             updated file. The link uses an absolute path unless it is created in the
1649             current working directory. Valid only for file systems that support
1650             symbolic links. Note that subsequent editing of the file via the symbolic
1651             link by exiftool will cause the link to be replaced by the edited file
1652             without changing the original unless the -overwrite_original_in_place option
1653             is used
1654             },
1655             ValueConvInv => '$val=~tr/\\\\/\//; $val',
1656             },
1657             MIMEType => { Notes => 'the MIME type of the source file', Groups => { 2 => 'Other' } },
1658             ImageWidth => { Notes => 'the width of the image in number of pixels' },
1659             ImageHeight => { Notes => 'the height of the image in number of pixels' },
1660             XResolution => { Notes => 'the horizontal pixel resolution' },
1661             YResolution => { Notes => 'the vertical pixel resolution' },
1662             NumPlanes => { Notes => 'number of color planes' },
1663             MaxVal => { Notes => 'maximum pixel value in PPM or PGM image' },
1664             EXIF => {
1665             Notes => q{
1666             the full EXIF data block from JPEG, PNG, JP2, MIE and MIFF images. This tag
1667             is generated only if specifically requested
1668             },
1669             Groups => { 0 => 'EXIF', 1 => 'EXIF' },
1670             Flags => ['Writable' ,'Protected', 'Binary', 'DelGroup'],
1671             WriteCheck => q{
1672             return undef if $val =~ /^(II\x2a\0|MM\0\x2a)/;
1673             return 'Invalid EXIF data';
1674             },
1675             },
1676             IPTC => {
1677             Notes => q{
1678             the full IPTC data block. This tag is generated only if specifically
1679             requested
1680             },
1681             Groups => { 0 => 'IPTC', 1 => 'IPTC' },
1682             Flags => ['Writable', 'Protected', 'Binary', 'DelGroup'],
1683             Priority => 0, # so main IPTC (which hopefully comes first) takes priority
1684             WriteCheck => q{
1685             return undef if $val =~ /^(\x1c|\0+$)/;
1686             return 'Invalid IPTC data';
1687             },
1688             },
1689             XMP => {
1690             Notes => q{
1691             the XMP data block, but note that extended XMP in JPEG images may be split
1692             into multiple blocks. This tag is generated only if specifically requested
1693             },
1694             Groups => { 0 => 'XMP', 1 => 'XMP' },
1695             Flags => ['Writable', 'Protected', 'Binary', 'DelGroup'],
1696             Priority => 0, # so main xmp (which usually comes first) takes priority
1697             WriteCheck => q{
1698             require Image::ExifTool::XMP;
1699             return Image::ExifTool::XMP::CheckXMP($self, $tagInfo, \$val);
1700             },
1701             },
1702             XML => {
1703             Notes => 'the XML data block, extracted for some file types',
1704             Groups => { 0 => 'XML', 1 => 'XML' },
1705             Binary => 1,
1706             },
1707             JUMBF => {
1708             Notes => 'the C2PA JUMBF data block, extracted only if specifically requested',
1709             Groups => { 0 => 'JUMBF', 1 => 'JUMBF' },
1710             Binary => 1,
1711             },
1712             ICC_Profile => {
1713             Notes => q{
1714             the full ICC_Profile data block. This tag is generated only if specifically
1715             requested
1716             },
1717             Groups => { 0 => 'ICC_Profile', 1 => 'ICC_Profile' },
1718             Flags => ['Writable' ,'Protected', 'Binary', 'DelGroup'],
1719             WriteCheck => q{
1720             require Image::ExifTool::ICC_Profile;
1721             return Image::ExifTool::ICC_Profile::ValidateICC(\$val);
1722             },
1723             },
1724             CanonVRD => {
1725             Notes => q{
1726             the full Canon DPP VRD trailer block. This tag is generated only if
1727             specifically requested
1728             },
1729             Groups => { 0 => 'CanonVRD', 1 => 'CanonVRD' },
1730             Flags => ['Writable' ,'Protected', 'Binary', 'DelGroup'],
1731             Permanent => 0, # (this is 1 by default for MakerNotes tags)
1732             WriteCheck => q{
1733             return undef if $val =~ /^CANON OPTIONAL DATA\0/;
1734             return 'Invalid CanonVRD data';
1735             },
1736             },
1737             CanonDR4 => {
1738             Notes => q{
1739             the full Canon DPP version 4 DR4 block. This tag is generated only if
1740             specifically requested
1741             },
1742             Groups => { 0 => 'CanonVRD', 1 => 'CanonVRD' },
1743             Flags => ['Writable' ,'Protected', 'Binary'],
1744             Permanent => 0, # (this is 1 by default for MakerNotes tags)
1745             WriteCheck => q{
1746             return undef if $val =~ /^IIII[\x04|\x05]\0\x04\0/;
1747             return 'Invalid CanonDR4 data';
1748             },
1749             },
1750             Adobe => {
1751             Notes => q{
1752             the JPEG APP14 Adobe segment. Extracted only if specified. See the
1753             L for more information
1754             },
1755             Groups => { 0 => 'APP14', 1 => 'Adobe' },
1756             WriteGroup => 'Adobe',
1757             Flags => ['Writable' ,'Protected', 'Binary'],
1758             },
1759             CurrentIPTCDigest => {
1760             Notes => q{
1761             MD5 digest of existing IPTC data. All zeros if IPTC exists but Digest::MD5
1762             is not installed. Only calculated for IPTC in the standard location as
1763             specified by the L. ExifTool
1764             automates the handling of this tag in the MWG module -- see the
1765             L for details
1766             },
1767             ValueConv => 'unpack("H*", $val)',
1768             },
1769             PreviewImage => {
1770             Notes => 'JPEG-format embedded preview image',
1771             Groups => { 2 => 'Preview' },
1772             Writable => 1,
1773             WriteCheck => '$self->CheckImage(\$val)',
1774             WriteGroup => 'All',
1775             # can't delete, so set to empty string and return no error
1776             DelCheck => '$val = ""; return undef',
1777             # accept either scalar or scalar reference
1778             RawConv => '$self->ValidateImage(ref $val ? $val : \$val, $tag)',
1779             },
1780             ThumbnailImage => {
1781             Groups => { 2 => 'Preview' },
1782             Notes => 'JPEG-format embedded thumbnail image',
1783             RawConv => '$self->ValidateImage(ref $val ? $val : \$val, $tag)',
1784             },
1785             OtherImage => {
1786             Groups => { 2 => 'Preview' },
1787             Notes => 'other JPEG-format embedded image',
1788             RawConv => '$self->ValidateImage(ref $val ? $val : \$val, $tag)',
1789             },
1790             PreviewPNG => {
1791             Groups => { 2 => 'Preview' },
1792             Notes => 'PNG-format embedded preview image',
1793             Binary => 1,
1794             },
1795             PreviewWMF => {
1796             Groups => { 2 => 'Preview' },
1797             Notes => 'WMF-format embedded preview image',
1798             Binary => 1,
1799             },
1800             PreviewTIFF => {
1801             Groups => { 2 => 'Preview' },
1802             Notes => 'TIFF-format embedded preview image',
1803             Binary => 1,
1804             },
1805             PreviewPDF => {
1806             Groups => { 2 => 'Preview' },
1807             Notes => 'PDF-format embedded preview image',
1808             Binary => 1,
1809             },
1810             PreviewJXL => {
1811             Groups => { 2 => 'Preview' },
1812             Notes => 'JXL-format embedded preview image',
1813             Binary => 1,
1814             },
1815             ExifByteOrder => {
1816             Writable => 1,
1817             DelCheck => q{"Can't delete"},
1818             Notes => q{
1819             represents the byte order of EXIF information. May be written to set the
1820             byte order only for newly created EXIF segments
1821             },
1822             PrintConv => {
1823             II => 'Little-endian (Intel, II)',
1824             MM => 'Big-endian (Motorola, MM)',
1825             },
1826             },
1827             MakerNoteByteOrder => {
1828             Notes => 'byte order of maker notes. Generated only if different from ExifByteOrder',
1829             PrintConv => {
1830             II => 'Little-endian (Intel, II)',
1831             MM => 'Big-endian (Motorola, MM)',
1832             },
1833             },
1834             ExifUnicodeByteOrder => {
1835             Writable => 1,
1836             WriteOnly => 1,
1837             DelCheck => q{"Can't delete"},
1838             Notes => q{
1839             specifies the byte order to use when writing EXIF Unicode text. The EXIF
1840             specification is particularly vague about this byte ordering, and different
1841             applications use different conventions. By default ExifTool writes Unicode
1842             text in EXIF byte order, but this write-only tag may be used to force a
1843             specific order. Applies to the EXIF UserComment tag when writing special
1844             characters
1845             },
1846             PrintConv => {
1847             II => 'Little-endian (Intel, II)',
1848             MM => 'Big-endian (Motorola, MM)',
1849             },
1850             },
1851             ExifToolVersion => {
1852             Description => 'ExifTool Version Number',
1853             Groups => \%allGroupsExifTool,
1854             Notes => 'the version of ExifTool currently running',
1855             },
1856             ProcessingTime => {
1857             Groups => { 0 => 'ExifTool', 1 => 'ExifTool', 2 => 'Other' },
1858             Notes => q{
1859             the clock time in seconds taken by ExifTool to extract information from this
1860             file. Not generated unless specifically requested or the API L
1861             option is set. Requires Time::HiRes
1862             },
1863             PrintConv => 'sprintf("%.3g s", $val)',
1864             },
1865             RAFVersion => { Notes => 'RAF file version number' },
1866             RAFCompression => { PrintConv => { 0 => 'Uncompressed', 2 => 'Compressed' } }, # 1 maybe lossy?
1867             JPEGDigest => {
1868             Notes => q{
1869             an MD5 digest of the JPEG quantization tables is combined with the component
1870             sub-sampling values to generate the value of this tag. The result is
1871             compared to known values in an attempt to deduce the originating software
1872             based only on the JPEG image data. For performance reasons, this tag is
1873             generated only if specifically requested or the API L option is set
1874             to 3 or higher
1875             },
1876             },
1877             JPEGQualityEstimate => {
1878             Notes => q{
1879             an estimate of the IJG JPEG quality setting for the image, calculated from
1880             the quantization tables. For performance reasons, this tag is generated
1881             only if specifically requested or the API L option is set to 3 or
1882             higher
1883             },
1884             },
1885             JPEGImageLength => {
1886             Notes => q{
1887             byte length of JPEG image without metadata. For performance reasons, this
1888             tag is generated only if specifically requested or the API L option
1889             is set to 3 or higher
1890             },
1891             },
1892             # Validate (added from Validate.pm)
1893             Now => {
1894             Groups => { 0 => 'ExifTool', 1 => 'ExifTool', 2 => 'Time' },
1895             Notes => q{
1896             the current date/time. Useful when setting the tag values, eg.
1897             C<"-modifydate. Not generated unless specifically requested or the
1898             API L option is set
1899             },
1900             PrintConv => '$self->ConvertDateTime($val)',
1901             },
1902             NewGUID => {
1903             Groups => { 0 => 'ExifTool', 1 => 'ExifTool', 2 => 'Other' },
1904             Notes => q{
1905             generates a new, random GUID with format
1906             YYYYmmdd-HHMM-SSNN-PPPP-RRRRRRRRRRRR, where Y=year, m=month, d=day, H=hour,
1907             M=minute, S=second, N=file sequence number in hex, P=process ID in hex, and
1908             R=random hex number; without dashes with the -n option. Not generated
1909             unless specifically requested or the API L option is set
1910             },
1911             PrintConv => '$val =~ s/(.{8})(.{4})(.{4})(.{4})/$1-$2-$3-$4-/; $val',
1912             },
1913             ID3Size => { Notes => 'size of the ID3 data block' },
1914             Geotag => {
1915             Writable => 1,
1916             WriteOnly => 1,
1917             WriteNothing => 1,
1918             AllowGroup => '(exif|gps|xmp|xmp-exif)',
1919             Notes => q{
1920             this write-only tag is used to define the GPS track log data or track log
1921             file name. Currently supported track log formats are GPX, NMEA RMC/GGA/GLL,
1922             KML, IGC, Garmin XML and TCX, Magellan PMGNTRK, Honeywell PTNTHPR, Winplus
1923             Beacon text, Bramor gEO, Google Takeout JSON, and CSV log files. May be set
1924             to the special value of "DATETIMEONLY" (all caps) to set GPS date/time tags
1925             if no input track points are available. See L
1926             for details
1927             },
1928             DelCheck => q{
1929             require Image::ExifTool::Geotag;
1930             # delete associated tags
1931             Image::ExifTool::Geotag::SetGeoValues($self, undef, $wantGroup);
1932             },
1933             ValueConvInv => q{
1934             require Image::ExifTool::Geotag;
1935             # always warn because this tag is never set (warning is "\n" on success)
1936             my $result = Image::ExifTool::Geotag::LoadTrackLog($self, $val);
1937             return '' if not defined $result; # deleting geo tags
1938             return $result if ref $result; # geotag data hash reference
1939             warn "$result\n"; # error string
1940             },
1941             },
1942             Geotime => {
1943             Writable => 1,
1944             WriteOnly => 1,
1945             AllowGroup => '(exif|gps|xmp|xmp-exif|quicktime|keys|itemlist|userdata)',
1946             Notes => q{
1947             this write-only tag is used to define a date/time for interpolating a
1948             position in the GPS track specified by the Geotag tag. Writing this tag
1949             causes GPS information to be written into the EXIF or XMP of the target
1950             files. The local system timezone is assumed if the date/time value does not
1951             contain a timezone. May be deleted to delete associated GPS tags. A group
1952             name of "EXIF" or "XMP" may be specified to write or delete only EXIF or XMP
1953             GPS tags
1954             },
1955             DelCheck => q{
1956             require Image::ExifTool::Geotag;
1957             # delete associated tags
1958             Image::ExifTool::Geotag::SetGeoValues($self, undef, $wantGroup);
1959             },
1960             ValueConvInv => q{
1961             require Image::ExifTool::Geotag;
1962             warn Image::ExifTool::Geotag::SetGeoValues($self, $val, $wantGroup) . "\n";
1963             return undef;
1964             },
1965             },
1966             Geosync => {
1967             Writable => 1,
1968             WriteOnly => 1,
1969             WriteNothing => 1,
1970             AllowGroup => '(exif|gps|xmp|xmp-exif)',
1971             Shift => 'Time', # enables "+=" syntax as well as "=+"
1972             Notes => q{
1973             this write-only tag specifies a time difference to add to Geotime for
1974             synchronization with the GPS clock. For example, set this to "-12" if the
1975             camera clock is 12 seconds faster than GPS time. Input format is
1976             "[+-][[[DD ]HH:]MM:]SS[.ss]". Additional features allow calculation of time
1977             differences and time drifts, and extraction of synchronization times from
1978             image files. See the L for details
1979             },
1980             ValueConvInv => q{
1981             require Image::ExifTool::Geotag;
1982             return Image::ExifTool::Geotag::ConvertGeosync($self, $val);
1983             },
1984             },
1985             ForceWrite => {
1986             Groups => { 0 => '*', 1 => '*', 2 => '*' },
1987             Writable => 1,
1988             WriteOnly => 1,
1989             Notes => q{
1990             write-only tag used to force metadata in a file to be rewritten even if no
1991             tag values are changed. May be set to "EXIF", "IPTC", "XMP" or "PNG" to
1992             force the corresponding metadata type to be rewritten, "FixBase" to cause
1993             EXIF to be rewritten only if the MakerNotes offset base was fixed, or "All"
1994             to rewrite all of these metadata types. Values are case insensitive, and
1995             multiple values may be separated with commas, eg. C<-ForceWrite=exif,xmp>
1996             },
1997             },
1998             EmbeddedVideo => { Groups => { 0 => 'Trailer', 2 => 'Video' } },
1999             Trailer => {
2000             Groups => { 0 => 'Trailer' },
2001             Notes => q{
2002             the full JPEG trailer data block. Extracted only if specifically requested
2003             or the API L option is set to 3 or higher
2004             },
2005             Writable => 1,
2006             Protected => 1,
2007             },
2008             PageCount => { Notes => 'the number of pages in a multi-page TIFF document' },
2009             SphericalVideoXML => {
2010             Groups => { 0 => 'QuickTime', 1 => 'GSpherical', 2 => 'Video' },
2011             # (group 1 is 'GSpherical' to trigger creation of this tag when writing,
2012             # but when reading the family 1 group is the track number)
2013             Flags => [ 'Writable', 'Binary', 'Protected' ],
2014             Notes => q{
2015             the SphericalVideoXML block from MP4/MOV videos. This tag is generated only
2016             if specifically requested
2017             },
2018             },
2019             ImageDataHash => {
2020             Notes => q{
2021             Hash of image data. Generated only if specifically requested for JPEG, TIFF,
2022             PNG, CRW, CR3, MRW, RAF, X3F, IIQ, JP2, JXL, HEIC and AVIF images, MOV/MP4
2023             videos, and some RIFF-based files such as AVI, WAV and WEBP. The hash
2024             algorithm is set by the API L option, and is 'MD5' by default.
2025             The hash includes the main image data, plus JpgFromRaw/OtherImage for some
2026             formats, but does not include ThumbnailImage or PreviewImage. Includes
2027             video and audio data for MOV/MP4. The L
2028             XMP-et:OriginalImageHashType tags|XMP.html#ExifTool> provide a way to store
2029             the this hash value and the hash type in the file.
2030             },
2031             },
2032             Geolocate => {
2033             Writable => 1,
2034             WriteOnly => 1,
2035             WriteNothing => 1,
2036             AllowGroup => '(exif|gps|xmp|xmp-exif|xmp-iptcext|xmp-iptccore|xmp-photoshop|iptc|quicktime|itemlist|keys|userdata)',
2037             Notes => q{
2038             this write-only tag may be used to write geolocation city, region, country
2039             code and country based in input GPS coordinates, or to write GPS
2040             coordinates based on geolocation name. See the
2041             L for
2042             details. This tag is writable regardless of the API L
2043             option setting
2044             },
2045             DelCheck => q{
2046             my @tags = $self->GetGeolocateTags($wantGroup);
2047             $self->SetNewValue($_) foreach @tags;
2048             return '';
2049             },
2050             ValueConvInv => q{
2051             require Image::ExifTool::Geolocation;
2052             # write this tag later if geotagging
2053             return $val if $val =~ /\bgeotag\b/i;
2054             $val .= ',both';
2055             my $opts = $$self{OPTIONS};
2056             my ($cities, $dist) = Image::ExifTool::Geolocation::Geolocate($self->Encode($val,'UTF8'), $opts);
2057             return '' unless $cities;
2058             if (@$cities > 1 and $self->Warn('Multiple matching cities found',2)) {
2059             warn "$$self{VALUE}{Warning}\n";
2060             return '';
2061             }
2062             my @geo = Image::ExifTool::Geolocation::GetEntry($$cities[0], $$opts{Lang});
2063             my @tags = $self->GetGeolocateTags($wantGroup, $dist ? 0 : 1);
2064             my %geoNum = ( City => 0, Province => 1, State => 1, Code => 3, Country => 4,
2065             Coordinates => 89, Latitude => 8, Longitude => 9 );
2066             my ($tag, $value);
2067             foreach $tag (@tags) {
2068             if ($tag =~ /GPS(Coordinates|Latitude|Longitude)?/) {
2069             $value = $geoNum{$1} == 89 ? "$geo[8],$geo[9]" : $geo[$geoNum{$1}];
2070             } elsif ($tag =~ /(Code)/ or $tag =~ /(City|Province|State|Country)/) {
2071             $value = $geo[$geoNum{$1}];
2072             next unless defined $value;
2073             $value = $self->Decode($value,'UTF8');
2074             $value .= ' ' if $tag eq 'iptc:Country-PrimaryLocationCode'; # (IPTC requires 3-char code)
2075             } elsif ($tag =~ /LocationName/) {
2076             $value = $geo[0] or next;
2077             $value .= ', ' . $geo[1] if $geo[1];
2078             $value .= ', ' . $geo[4] if $geo[4];
2079             $value = $self->Decode($value, 'UTF8');
2080             } else {
2081             next; # (shouldn't happen)
2082             }
2083             $self->SetNewValue($tag => $value, Type => 'PrintConv');
2084             }
2085             return '';
2086             },
2087             PrintConvInv => q{
2088             my @args = split /\s*,\s*/, $val;
2089             my $lat = 1;
2090             foreach (@args) {
2091             next unless /^[-+]?\d/;
2092             my @reals = /\.\d+/g;
2093             next if @reals > 1; # (allow floating "lat lon" format)
2094             require Image::ExifTool::GPS;
2095             $_ = Image::ExifTool::GPS::ToDegrees($_, 1, $lat ? 'lat' : 'lon');
2096             $lat ^= 1;
2097             }
2098             return join(',', @args);
2099             },
2100             },
2101             GeolocationBearing => { %geoInfo,
2102             Notes => q{
2103             compass bearing to GeolocationCity center. Geolocation tags are
2104             generated only if API L option is set
2105             },
2106             },
2107             GeolocationCity => { %geoInfo, Notes => 'name of city nearest to the current GPS coordinates', ValueConv => '$self->Decode($val,"UTF8")' },
2108             GeolocationRegion => { %geoInfo, Notes => 'geolocation state, province or region', ValueConv => '$self->Decode($val,"UTF8")' },
2109             GeolocationSubregion=> { %geoInfo, Notes => 'geolocation county or subregion', ValueConv => '$self->Decode($val,"UTF8")' },
2110             GeolocationCountry => { %geoInfo, Notes => 'geolocation country name', ValueConv => '$self->Decode($val,"UTF8")' },
2111             GeolocationCountryCode=>{%geoInfo, Notes => 'geolocation country code' },
2112             GeolocationTimeZone => { %geoInfo, Notes => 'geolocation time zone ID' },
2113             GeolocationFeatureCode=>{%geoInfo, Notes => 'geolocation feature code, see L' },
2114             GeolocationFeatureType=>{%geoInfo, Notes => 'geolocation feature type' },
2115             GeolocationPopulation=>{ %geoInfo, Notes => 'city population rounded to 2 significant digits' },
2116             GeolocationDistance => { %geoInfo, Notes => 'distance in km from current GPS to city', PrintConv => '"$val km"' },
2117             GeolocationPosition => { %geoInfo, Notes => 'approximate GPS coordinates of city',
2118             PrintConv => '$val =~ s/ /, /; $val',
2119             },
2120             GeolocationWarning => { %geoInfo },
2121             );
2122              
2123             # tags defined by UserParam option (added at runtime)
2124             %Image::ExifTool::UserParam = (
2125             GROUPS => { 0 => 'UserParam', 1 => 'UserParam', 2 => 'Other' },
2126             PRIORITY => 0,
2127             );
2128              
2129             # YCbCrSubSampling values (used by JPEG SOF, EXIF and XMP)
2130             %Image::ExifTool::JPEG::yCbCrSubSampling = (
2131             '1 1' => 'YCbCr4:4:4 (1 1)', #PH
2132             '2 1' => 'YCbCr4:2:2 (2 1)', #14 in Exif.pm
2133             '2 2' => 'YCbCr4:2:0 (2 2)', #14 in Exif.pm
2134             '4 1' => 'YCbCr4:1:1 (4 1)', #14 in Exif.pm
2135             '4 2' => 'YCbCr4:1:0 (4 2)', #PH
2136             '1 2' => 'YCbCr4:4:0 (1 2)', #PH
2137             '1 4' => 'YCbCr4:4:1 (1 4)', #JD
2138             '2 4' => 'YCbCr4:2:1 (2 4)', #JD
2139             );
2140              
2141             # define common JPEG segments here to avoid overhead of loading JPEG module
2142              
2143             # JPEG SOF (start of frame) tags
2144             # (ref http://www.w3.org/Graphics/JPEG/itu-t81.pdf)
2145             %Image::ExifTool::JPEG::SOF = (
2146             GROUPS => { 0 => 'File', 1 => 'File', 2 => 'Image' },
2147             NOTES => 'This information is extracted from the JPEG Start Of Frame segment.',
2148             VARS => { ID_FMT => 'none' }, # tag ID's aren't meaningful for these tags
2149             EncodingProcess => {
2150             PrintHex => 1,
2151             PrintConv => {
2152             0x0 => 'Baseline DCT, Huffman coding',
2153             0x1 => 'Extended sequential DCT, Huffman coding',
2154             0x2 => 'Progressive DCT, Huffman coding',
2155             0x3 => 'Lossless, Huffman coding',
2156             0x5 => 'Sequential DCT, differential Huffman coding',
2157             0x6 => 'Progressive DCT, differential Huffman coding',
2158             0x7 => 'Lossless, Differential Huffman coding',
2159             0x9 => 'Extended sequential DCT, arithmetic coding',
2160             0xa => 'Progressive DCT, arithmetic coding',
2161             0xb => 'Lossless, arithmetic coding',
2162             0xd => 'Sequential DCT, differential arithmetic coding',
2163             0xe => 'Progressive DCT, differential arithmetic coding',
2164             0xf => 'Lossless, differential arithmetic coding',
2165             }
2166             },
2167             BitsPerSample => { },
2168             ImageHeight => { },
2169             ImageWidth => { },
2170             ColorComponents => { },
2171             YCbCrSubSampling => {
2172             Notes => 'calculated from components table',
2173             PrintConv => \%Image::ExifTool::JPEG::yCbCrSubSampling,
2174             },
2175             );
2176              
2177             # JPEG JFIF APP0 definitions
2178             %Image::ExifTool::JFIF::Main = (
2179             PROCESS_PROC => \&Image::ExifTool::ProcessBinaryData,
2180             WRITE_PROC => \&Image::ExifTool::WriteBinaryData,
2181             CHECK_PROC => \&Image::ExifTool::CheckBinaryData,
2182             GROUPS => { 0 => 'JFIF', 1 => 'JFIF', 2 => 'Image' },
2183             DATAMEMBER => [ 2, 3, 5 ],
2184             0 => {
2185             Name => 'JFIFVersion',
2186             Format => 'int8u[2]',
2187             PrintConv => 'sprintf("%d.%.2d", split(" ",$val))',
2188             Mandatory => 1,
2189             },
2190             2 => {
2191             Name => 'ResolutionUnit',
2192             Writable => 1,
2193             RawConv => '$$self{JFIFResolutionUnit} = $val',
2194             PrintConv => {
2195             0 => 'None',
2196             1 => 'inches',
2197             2 => 'cm',
2198             },
2199             Priority => -1,
2200             Mandatory => 1,
2201             },
2202             3 => {
2203             Name => 'XResolution',
2204             Format => 'int16u',
2205             Writable => 1,
2206             Priority => -1,
2207             RawConv => '$$self{JFIFXResolution} = $val',
2208             Mandatory => 1,
2209             },
2210             5 => {
2211             Name => 'YResolution',
2212             Format => 'int16u',
2213             Writable => 1,
2214             Priority => -1,
2215             RawConv => '$$self{JFIFYResolution} = $val',
2216             Mandatory => 1,
2217             },
2218             7 => {
2219             Name => 'ThumbnailWidth',
2220             RawConv => '$val ? $$self{JFIFThumbnailWidth} = $val : undef',
2221             },
2222             8 => {
2223             Name => 'ThumbnailHeight',
2224             RawConv => '$val ? $$self{JFIFThumbnailHeight} = $val : undef',
2225             },
2226             9 => {
2227             Name => 'ThumbnailTIFF',
2228             Groups => { 2 => 'Preview' },
2229             Format => 'undef[3*($val{7}||0)*($val{8}||0)]',
2230             Notes => 'raw RGB thumbnail data, extracted as a TIFF image',
2231             RawConv => 'length($val) ? $val : undef',
2232             ValueConv => sub {
2233             my ($val, $et) = @_;
2234             my $len = length $val;
2235             return \ "Binary data $len bytes" unless $et->Options('Binary');
2236             my $img = MakeTiffHeader($$et{JFIFThumbnailWidth},$$et{JFIFThumbnailHeight},3,8) . $val;
2237             return \$img;
2238             },
2239             },
2240             );
2241             %Image::ExifTool::JFIF::Extension = (
2242             GROUPS => { 0 => 'JFIF', 1 => 'JFXX', 2 => 'Image' },
2243             NOTES => 'Thumbnail images extracted from the JFXX segment.',
2244             0x10 => {
2245             Name => 'ThumbnailImage',
2246             Groups => { 2 => 'Preview' },
2247             Notes => 'JPEG-format thumbnail image',
2248             RawConv => '$self->ValidateImage(\$val,$tag)',
2249             },
2250             0x11 => { # (untested)
2251             Name => 'ThumbnailTIFF',
2252             Groups => { 2 => 'Preview' },
2253             Notes => 'raw palette-color thumbnail data, extracted as a TIFF image',
2254             RawConv => '(length $val > 770 and $val !~ /^\0\0/) ? $val : undef',
2255             ValueConv => sub {
2256             my ($val, $et) = @_;
2257             my $len = length $val;
2258             return \ "Binary data $len bytes" unless $et->Options('Binary');
2259             my ($w, $h) = unpack('CC', $val);
2260             my $img = MakeTiffHeader($w,$h,1,8,undef,substr($val,2,768)) . substr($val,770);
2261             return \$img;
2262             },
2263             },
2264             0x13 => {
2265             Name => 'ThumbnailTIFF',
2266             Groups => { 2 => 'Preview' },
2267             Notes => 'raw RGB thumbnail data, extracted as a TIFF image',
2268             RawConv => '(length $val > 2 and $val !~ /^\0\0/) ? $val : undef',
2269             ValueConv => sub {
2270             my ($val, $et) = @_;
2271             my $len = length $val;
2272             return \ "Binary data $len bytes" unless $et->Options('Binary');
2273             my ($w, $h) = unpack('CC', $val);
2274             my $img = MakeTiffHeader($w,$h,3,8) . substr($val,2);
2275             return \$img;
2276             },
2277             },
2278             # Apple may add "AMPF" to the end of the JFIF record,
2279             # possibly indicating the existence of MPF images (ref forum12677)
2280             );
2281              
2282             # Composite tags (accumulation of all Composite tag tables)
2283             %Image::ExifTool::Composite = (
2284             GROUPS => { 0 => 'Composite', 1 => 'Composite' },
2285             TABLE_NAME => 'Image::ExifTool::Composite',
2286             SHORT_NAME => 'Composite',
2287             VARS => { ID_FMT => 'none' }, # want empty tagID's for Composite tags
2288             WRITE_PROC => \&DummyWriteProc,
2289             );
2290              
2291             my %compositeID; # lookup for new ID's of Composite tags based on original ID
2292              
2293             # static private ExifTool variables
2294              
2295             %allTables = ( ); # list of all tables loaded (except Composite tags)
2296             @tableOrder = ( ); # order the tables were loaded
2297              
2298             #------------------------------------------------------------------------------
2299             # Warning handler routines (warning string stored in $evalWarning)
2300             #
2301             # Set warning message
2302             # Inputs: 0) warning string (undef to reset warning)
2303 41     41 0 895 sub SetWarning($) { $evalWarning = $_[0]; }
2304              
2305             # Get warning message
2306 17     17 0 115 sub GetWarning() { return $evalWarning; }
2307              
2308             # Clean unnecessary information (line number, LF) from warning
2309             # Inputs: 0) warning string or undef to use $evalWarning
2310             # Returns: cleaned warning
2311             sub CleanWarning(;$)
2312             {
2313 226     226 0 410 my $str = shift;
2314 226 50       504 unless (defined $str) {
2315 226 50       556 return undef unless defined $evalWarning;
2316 226         389 $str = $evalWarning;
2317             }
2318             # truncate at first " at " for warnings like "syntax error at (eval 80) line 1, at EOF"
2319 226 100       1376 $str = $1 if $str =~ /(.*?) at /s;
2320 226         884 $str =~ s/\s+$//s;
2321 226         1025 return $str;
2322             }
2323              
2324             #==============================================================================
2325             # New - create new ExifTool object
2326             # Inputs: 0) reference to exiftool object or ExifTool class name
2327             # Returns: blessed ExifTool object ref
2328             sub new
2329             {
2330 508     508 1 20334133 local $_;
2331 508         1583 my $that = shift;
2332 508   50     4567 my $class = ref($that) || $that || 'Image::ExifTool';
2333 508         1947 my $self = bless {}, $class;
2334              
2335             # make sure our main Exif tag table has been loaded
2336 508         3046 GetTagTable("Image::ExifTool::Exif::Main");
2337              
2338 508         3503 $self->ClearOptions(); # create default options hash
2339 508         1694 $$self{VALUE} = { }; # must initialize this for warning messages
2340 508         1496 $$self{PATH} = [ ]; # (this too)
2341 508         1778 $$self{DEL_GROUP} = { }; # lookup for groups to delete when writing
2342 508         1483 $$self{SAVE_COUNT} = 0; # count calls to SaveNewValues()
2343 508         1777 $$self{NV_COUNT} = 0; # count of NEW_VALUE entries
2344 508         1520 $$self{FILE_SEQUENCE} = 0; # sequence number for files when reading
2345 508         1475 $$self{FILES_WRITTEN} = 0; # count of files successfully written
2346 508         1500 $$self{INDENT2} = ''; # indentation of verbose messages from SetNewValue
2347 508         1546 $$self{ALT_EXIFTOOL} = { }; # alternate exiftool objects
2348              
2349             # initialize our new groups for writing
2350 508         3376 $self->SetNewGroups(@defaultWriteGroups);
2351              
2352 508         2731 return $self;
2353             }
2354              
2355             #------------------------------------------------------------------------------
2356             # ImageInfo - return specified information from image file
2357             # Inputs: 0) [optional] ExifTool object reference
2358             # 1) filename, file reference, or scalar data reference
2359             # 2-N) list of tag names to find (or tag list reference or options reference)
2360             # Returns: reference to hash of tag/value pairs (with "Error" entry on error)
2361             # Notes:
2362             # - if no tags names are specified, the values of all tags are returned
2363             # - tags may be specified with leading '-' to exclude, or trailing '#' for ValueConv
2364             # - can pass a reference to list of tags to find, in which case the list will
2365             # be updated with the tags found in the proper case and in the specified order.
2366             # - can pass reference to hash specifying options
2367             # - returned tag values may be scalar references indicating binary data
2368             # - see ClearOptions() below for a list of options and their default values
2369             # Examples:
2370             # use Image::ExifTool 'ImageInfo';
2371             # my $info = ImageInfo($file, 'DateTimeOriginal', 'ImageSize');
2372             # - or -
2373             # my $et = Image::ExifTool->new;
2374             # my $info = $et->ImageInfo($file, \@tagList, {Sort=>'Group0'} );
2375             sub ImageInfo($;@)
2376             {
2377 539     539 1 235459 local $_;
2378             # get our ExifTool object ($self) or create one if necessary
2379 539         1224 my $self;
2380 539 100 100     5847 if (ref $_[0] and UNIVERSAL::isa($_[0],'Image::ExifTool')) {
2381 530         1447 $self = shift;
2382             } else {
2383 9         108 $self = Image::ExifTool->new;
2384             }
2385 539         1211 my %saveOptions = %{$$self{OPTIONS}}; # save original options
  539         37805  
2386              
2387             # initialize file information
2388 539         5993 $$self{FILENAME} = $$self{RAF} = undef;
2389              
2390 539         3717 $self->ParseArguments(@_); # parse our function arguments
2391 539         3533 $self->ExtractInfo(undef); # extract meta information from image
2392 539         3388 my $info = $self->GetInfo(undef); # get requested information
2393              
2394 539         17430 $$self{OPTIONS} = \%saveOptions; # restore original options
2395              
2396 539         4850 return $info; # return requested information
2397             }
2398              
2399             #------------------------------------------------------------------------------
2400             # Get/set ExifTool options
2401             # Inputs: 0) ExifTool object reference,
2402             # 1) Parameter name (case insensitive), 2) Value to set the option
2403             # 3-N) More parameter/value pairs
2404             # Returns: original value of last option specified
2405             sub Options($$;@)
2406             {
2407 23369     23369 1 61299 local $_;
2408 23369         35614 my $self = shift;
2409 23369         43628 my $options = $$self{OPTIONS};
2410 23369         33215 my $oldVal;
2411              
2412 23369         51544 while (@_) {
2413 23882         38845 my $param = shift;
2414 23882         33311 my $plus;
2415             # fix parameter case if necessary
2416 23882 100       61725 unless (exists $$options{$param}) {
2417 535         2054 $plus = $param =~ s/\+$//;
2418 535         71659 my ($fixed) = grep /^$param$/i, keys %$options;
2419 535 50       5068 if ($fixed) {
2420 0         0 $param = $fixed;
2421             } else {
2422 535         2291 $param =~ s/^Group(\d*)$/Group$1/i;
2423             }
2424             }
2425 23882         43183 $oldVal = $$options{$param};
2426 23882 50 33     54898 if (ref $oldVal eq 'HASH' and ($param eq 'Compact' or $param eq 'XMPShorthand')) {
      66        
2427             # get previous Compact/XMPShorthand setting
2428 0         0 $oldVal = $$oldVal{$param};
2429             }
2430 23882 100       56165 last unless @_;
2431 6137         9551 my $newVal = shift;
2432 6137 100 66     79177 if ($param eq 'Lang') {
    100 100        
    100 66        
    100 100        
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    50          
2433             # allow this to be set to undef to select the default language
2434 78 50       280 $newVal = $defaultLang unless defined $newVal;
2435 78 100       326 if ($newVal eq $defaultLang) {
2436 59         176 $$options{$param} = $newVal;
2437 59         206 delete $$self{CUR_LANG};
2438             # make sure the language is available
2439             } else {
2440 19         77 my %langs = map { $_ => 1 } @langs;
  361         909  
2441 19 50 33     1861 if ($langs{$newVal} and eval "require Image::ExifTool::Lang::$newVal") {
2442 19         89 my $xlat = "Image::ExifTool::Lang::${newVal}::Translate";
2443 113     113   1177 no strict 'refs';
  113         299  
  113         685879  
2444 19 50       161 if (%$xlat) {
2445 19         101 $$self{CUR_LANG} = \%$xlat;
2446 19         295 $$options{$param} = $newVal;
2447             }
2448             }
2449             } # else don't change Lang
2450             } elsif ($param eq 'Exclude' and defined $newVal) {
2451             # clone Exclude list and expand shortcuts
2452 8         29 my @exclude;
2453 8 100       38 if (ref $newVal eq 'ARRAY') {
2454 7         27 @exclude = @$newVal;
2455             } else {
2456 1         5 @exclude = ($newVal);
2457             }
2458 8         37 ExpandShortcuts(\@exclude, 1); # (also remove '#' suffix)
2459 8         33 $$options{$param} = \@exclude;
2460             } elsif ($param =~ /^Charset/ or $param eq 'IPTCCharset') {
2461             # only allow valid character sets to be set
2462 364 100 66     1296 if ($newVal) {
    50 33        
    0          
2463 245         738 my $charset = $charsetName{lc $newVal};
2464 245 50       505 if ($charset) {
2465 245         461 $$options{$param} = $charset;
2466             # maintain backward-compatibility with old IPTCCharset option
2467 245 100       808 $$options{CharsetIPTC} = $charset if $param eq 'IPTCCharset';
2468             } else {
2469 0         0 warn "Invalid Charset $newVal\n";
2470             }
2471             } elsif ($param eq 'CharsetEXIF' or $param eq 'CharsetFileName' or $param eq 'CharsetRIFF') {
2472 119         369 $$options{$param} = $newVal; # only these may be set to a false value
2473             } elsif ($param eq 'CharsetQuickTime') {
2474 0         0 $$options{$param} = 'MacRoman'; # QuickTime defaults to MacRoman
2475             } else {
2476 0         0 $$options{$param} = 'Latin'; # all others default to Latin
2477             }
2478             } elsif ($param eq 'UserParam') {
2479             # clear options if $newVal is undef
2480 59 50       224 defined $newVal or $$options{$param} = {}, next;
2481 59         283 my $table = GetTagTable('Image::ExifTool::UserParam');
2482             # allow initialization of entire UserParam hash
2483 59 50       309 if (ref $newVal eq 'HASH') {
2484 59         120 my %newParams;
2485 59         253 foreach (sort keys %$newVal) {
2486 0         0 my $lcTag = lc $_;
2487 0         0 $newParams{$lcTag} = $$newVal{$_};
2488 0         0 delete $$table{$lcTag};
2489 0         0 AddTagToTable($table, $lcTag, $_);
2490             }
2491 59         188 $$options{$param} = \%newParams;
2492 59         273 next;
2493             }
2494 0         0 my ($force, $paramName);
2495             # set/reset single UserParam parameter
2496 0 0       0 if ($newVal =~ /(.*?)=(.*)/s) {
2497 0         0 $paramName = $1;
2498 0         0 $newVal = $2;
2499 0 0       0 $force = 1 if $paramName =~ s/\^$//;
2500 0         0 $paramName =~ tr/-_a-zA-Z0-9#//dc;
2501 0         0 $param = lc $paramName;
2502             } else {
2503 0         0 ($param = lc $newVal) =~ tr/-_a-zA-Z0-9#//dc;
2504 0         0 undef $newVal;
2505             }
2506 0         0 delete $$table{$param};
2507 0         0 $oldVal = $$options{UserParam}{$param};
2508 0 0       0 if (defined $newVal) {
2509 0 0 0     0 if (length $newVal or $force) {
2510 0         0 $$options{UserParam}{$param} = $newVal;
2511 0         0 AddTagToTable($table, $param, $paramName);
2512             } else {
2513 0         0 delete $$options{UserParam}{$param};
2514             }
2515             }
2516             # remove alternate version of tag
2517 0 0       0 $param .= '#' unless $param =~ s/#$//;
2518 0         0 delete $$table{$param};
2519 0         0 delete $$options{UserParam}{$param};
2520             } elsif ($param eq 'RequestTags') {
2521 102 100       334 if (defined $newVal) {
2522             # parse list from delimited string if necessary
2523 43 50       282 my @reqList = (ref $newVal eq 'ARRAY') ? @$newVal : ($newVal =~ /[-\w?*:]+/g);
2524 43         249 ExpandShortcuts(\@reqList);
2525             # add to existing list
2526 43 50       243 $$options{$param} or $$options{$param} = [ ];
2527 43         134 foreach (@reqList) {
2528 65 50       415 /^(.*:)?([-\w?*]*)#?$/ or next;
2529 65 50       285 push @{$$options{$param}}, lc($2) if $2;
  65         245  
2530 65 50       341 next unless $1;
2531             # add requested groups with trailing colon
2532 0         0 push @{$$options{$param}}, lc($_).':' foreach split /:/, $1;
  0         0  
2533             }
2534             } else {
2535 59         201 $$options{$param} = undef; # clear the list
2536             }
2537             } elsif ($param =~ /^(IgnoreTags|IgnoreGroups)$/) {
2538 118 50       357 if (defined $newVal) {
2539 0 0       0 ref $newVal eq 'HASH' and $$options{$param} = $newVal, next;
2540             # parse list from delimited string if necessary
2541 0 0       0 my @ignoreList = (ref $newVal eq 'ARRAY') ? @$newVal : ($newVal =~ /[-\w?*:#]+/g);
2542 0 0       0 ExpandShortcuts(\@ignoreList) if $param eq 'IgnoreTags';
2543             # add to existing tags/groups to ignore
2544 0 0       0 $$options{$param} or $$options{$param} = { };
2545 0         0 foreach (@ignoreList) {
2546 0 0       0 /^(.*:)?([-\w?*]+)#?$/ or next;
2547 0         0 $$options{$param}{lc $2} = 1;
2548             }
2549             } else {
2550 118         376 $$options{$param} = undef; # clear the option
2551             }
2552             } elsif ($param eq 'ListJoin') {
2553 12         43 $$options{$param} = $newVal;
2554             # set the old List and ListSep options for backward compatibility
2555 12 100       47 if (defined $newVal) {
2556 4         9 $$options{List} = 0;
2557 4         16 $$options{ListSep} = $newVal;
2558             } else {
2559 8         33 $$options{List} = 1;
2560             # (ListSep must be defined)
2561             }
2562             } elsif ($param eq 'List') {
2563 78         225 $$options{$param} = $newVal;
2564             # set the new ListJoin option for forward compatibility
2565 78 50       472 $$options{ListJoin} = $newVal ? undef : $$options{ListSep};
2566             } elsif ($param eq 'Compact' or $param eq 'XMPShorthand') {
2567             # set Compact and XMPShorthand options, preserving backward compatibility
2568 1         4 my ($p, %compact);
2569 1         4 foreach $p ('Compact','XMPShorthand') {
2570             # (allow setting from a HASH (undocumented)
2571 2 50       10 ref $newVal eq 'HASH' and %compact = %{$newVal}, next;
  0         0  
2572 2 100       8 my $val = $param eq $p ? $newVal : $$options{Compact}{$p};
2573 2 100       8 if (defined $val) {
2574 1         7 my @v = ($val =~ /\w+/g);
2575 1 50       6 my $opt = ($p eq 'Compact') ? \%compactOpt : \%xmpShorthandOpt;
2576 1         3 foreach (@v) {
2577 1 50       7 my $set = $$opt{lc $_} or warn("Invalid $p setting '${_}'\n"), return $oldVal;
2578 1 50       10 ref $set or $compact{$set} = 1, next;
2579 0         0 $compact{$_} = 1 foreach @$set;
2580             }
2581             }
2582 2         7 $compact{$p} = $val; # preserve most recent setting
2583             }
2584 1         6 $$options{Compact} = $$options{XMPShorthand} = \%compact;
2585             } elsif ($param eq 'NoWarning') {
2586             # validate regular expression
2587 59         248 undef $evalWarning;
2588 59 50       283 if (defined $newVal) {
2589 0         0 local $SIG{'__WARN__'} = \&SetWarning;
2590 0         0 eval { $param =~ /$newVal/ };
  0         0  
2591 0 0       0 $@ and $evalWarning = $@;
2592             }
2593 59 50       261 if ($evalWarning) {
2594 0         0 warn 'NoWarning: ' . CleanWarning() . "\n";
2595 0         0 next;
2596             }
2597             # add to existing expression if specified
2598 59 50 33     275 if ($plus and defined $oldVal) {
2599 0 0       0 $newVal = defined $newVal ? "$oldVal|$newVal" : $oldVal;
2600             }
2601 59         213 $$options{$param} = $newVal;
2602             } elsif ($param eq 'ImageHashType') {
2603 59 50       538 if (not defined $newVal) {
    50          
2604 0         0 warn("Can't set $param to undef\n");
2605             } elsif ($newVal =~ /^(MD5|SHA256|SHA512)$/i) {
2606 59         330 $$options{$param} = uc($newVal);
2607             } else {
2608 0         0 warn("Invalid $param setting '${newVal}'\n");
2609             }
2610             } elsif ($param eq 'StructFormat') {
2611 59 50       238 if (defined $newVal) {
2612 0 0       0 $newVal =~ /^(JSON|JSONQ)$/i or warn("Invalid $param setting '${newVal}'\n"), next;
2613 0         0 $newVal = uc($newVal);
2614             }
2615 59         233 $$options{$param} = $newVal;
2616             } elsif ($param eq 'ByteUnit') {
2617 59 50       242 if (defined $newVal) {
2618             # (allow "Metric" or "SI" for SI, and "IT" or "Binary" for Binary)
2619 59 0       398 my $goodVal = ($newVal =~ /^S|M/i ? 'SI' : ($newVal =~ /^I|B/i ? 'Binary' : undef));
    50          
2620 59 50       240 $goodVal or warn("Invalid $param setting '${newVal}'\n"), next;
2621 59         256 $$options{$param} = $goodVal;
2622             } else {
2623 0         0 warn("Can't set $param to undef\n");
2624             }
2625             } elsif ($param eq 'Plot') {
2626             # add to existing plot settings
2627 0 0 0     0 $newVal = "$oldVal,$newVal" if defined $oldVal and defined $newVal;
2628 0         0 $$options{$param} = $newVal;
2629             } elsif ($param eq 'KeepUTCTime' or $param eq 'SystemTimeRes') {
2630 118         534 $$options{$param} = $static_vars{$param} = $newVal;
2631             } elsif (lc $param eq 'geodir') {
2632 0         0 $Image::ExifTool::Geolocation::geoDir = $newVal;
2633             } else {
2634 4963 100 66     22520 if ($param eq 'Escape') {
    100 33        
    50          
    100          
2635             # set ESCAPE_PROC
2636 65 50 66     556 if (defined $newVal and $newVal eq 'XML') {
    100 66        
2637 0         0 require Image::ExifTool::XMP;
2638 0         0 $$self{ESCAPE_PROC} = \&Image::ExifTool::XMP::EscapeXML;
2639             } elsif (defined $newVal and $newVal eq 'HTML') {
2640 5         2130 require Image::ExifTool::HTML;
2641 5         29 $$self{ESCAPE_PROC} = \&Image::ExifTool::HTML::EscapeHTML;
2642             } else {
2643 60         188 delete $$self{ESCAPE_PROC};
2644             }
2645             # must forget saved values since they depend on Escape method
2646 65         289 $$self{BOTH} = { };
2647             } elsif ($param eq 'GlobalTimeShift') {
2648 60         194 delete $$self{GLOBAL_TIME_OFFSET}; # reset our calculated offset
2649             } elsif ($param eq 'TimeZone' and defined $newVal and length $newVal) {
2650 0         0 $ENV{TZ} = $newVal;
2651 0 0       0 if ($^O eq 'MSWin32') {
2652 0 0       0 if (eval { require Time::Piece }) {
  0         0  
2653 0         0 eval { Time::Piece::_tzset() };
  0         0  
2654             } else {
2655 0         0 warn("Install Time::Piece to set time zone in Windows\n");
2656             }
2657             } else {
2658 0         0 eval { require POSIX; POSIX::tzset() };
  0         0  
  0         0  
2659             }
2660             } elsif ($param eq 'Validate') {
2661             # load Validate module if Validate option enabled
2662 60 100       2500 $newVal and require Image::ExifTool::Validate;
2663             }
2664 4963         14339 $$options{$param} = $newVal;
2665             }
2666             }
2667 23369         75564 return $oldVal;
2668             }
2669              
2670             #------------------------------------------------------------------------------
2671             # ClearOptions - set options to default values
2672             # Inputs: 0) ExifTool object reference
2673             sub ClearOptions($)
2674             {
2675 508     508 1 1327 local $_;
2676 508         1217 my $self = shift;
2677              
2678 508         21904 $$self{OPTIONS} = { }; # clear all options
2679              
2680             # load default options
2681 508         88377 $$self{OPTIONS}{$$_[0]} = $$_[1] foreach @availableOptions;
2682              
2683             # keep necessary member variables in sync with options
2684 508         2167 delete $$self{CUR_LANG};
2685 508         1207 delete $$self{ESCAPE_PROC};
2686              
2687             # load user-defined default options
2688 508 50       2718 if (%Image::ExifTool::UserDefined::Options) {
2689 0         0 foreach (keys %Image::ExifTool::UserDefined::Options) {
2690 0         0 $self->Options($_, $Image::ExifTool::UserDefined::Options{$_});
2691             }
2692             }
2693             }
2694              
2695             #------------------------------------------------------------------------------
2696             # Extract meta information from image
2697             # Inputs: 0) ExifTool object reference
2698             # 1-N) Same as ImageInfo()
2699             # Returns: 1 if this was a valid image, 0 otherwise
2700             # Notes: pass an undefined value to avoid parsing arguments
2701             # Internal 'ReEntry' option allows this routine to be called recursively
2702             sub ExtractInfo($;@)
2703             {
2704 552     552 1 1907 local $_;
2705 552         1204 my $self = shift;
2706 552         1489 my $options = $$self{OPTIONS}; # pointer to current options
2707 552   100     2861 my $fast = $$options{FastScan} || 0;
2708 552         1361 my $req = $$self{REQ_TAG_LOOKUP};
2709 552   100     2846 my $reqAll = $$options{RequestAll} || 0;
2710 552         1702 my (%saveOptions, $reEntry, $rsize, $zid, $type, @startTime, $saveOrder, $isDir, $i);
2711              
2712             # check for internal ReEntry option to allow recursive calls to ExtractInfo
2713 552 100 100     3023 if (ref $_[1] eq 'HASH' and $_[1]{ReEntry} and
      33        
      66        
2714             (ref $_[0] eq 'SCALAR' or ref $_[0] eq 'GLOB'))
2715             {
2716             # save necessary members for restoring later
2717             $reEntry = {
2718             RAF => $$self{RAF},
2719             PROCESSED => $$self{PROCESSED},
2720             EXIF_DATA => $$self{EXIF_DATA},
2721             EXIF_POS => $$self{EXIF_POS},
2722             FILE_TYPE => $$self{FILE_TYPE},
2723 2         13 };
2724             $saveOrder = GetByteOrder(),
2725 2         6 $$self{RAF} = File::RandomAccess->new($_[0]);
2726 2         4 $$self{PROCESSED} = { };
2727 2         4 delete $$self{EXIF_DATA};
2728 2         3 delete $$self{EXIF_POS};
2729             } else {
2730 550 100 66     5522 if (defined $_[0] or $$options{HtmlDump} or $$req{validate}) {
      66        
2731 12         915 %saveOptions = %$options; # save original options
2732              
2733             # require duplicates for html dump
2734 12 50       129 $self->Options(Duplicates => 1) if $$options{HtmlDump};
2735             # enable Validate option if Validate tag is requested
2736 12 100       68 $self->Options(Validate => 1) if $$req{validate};
2737 12 100       48 if (defined $_[0]) {
2738             # only initialize filename if called with arguments
2739 11         53 $$self{FILENAME} = undef; # name of file (or '' if we didn't open it)
2740 11         37 $$self{RAF} = undef; # RandomAccess object reference
2741              
2742 11         76 $self->ParseArguments(@_); # initialize from our arguments
2743             }
2744             }
2745             # ignore all tags and set ExtractEmbedded if outputting CSV directly
2746 550 50       2218 if ($self->Options('PrintCSV')) {
2747 0         0 $$self{OPTIONS}{IgnoreTags} = { all => 1 };
2748 0         0 $self->Options(ExtractEmbedded => 1);
2749             }
2750             # initialize ExifTool object members
2751 550         3514 $self->Init();
2752 550         1876 $$self{InExtract} = 1; # set flag indicating we are inside ExtractInfo
2753              
2754 550         1362 delete $$self{MAKER_NOTE_FIXUP}; # fixup information for extracted maker notes
2755 550         1514 delete $$self{MAKER_NOTE_BYTE_ORDER};
2756              
2757             # return our version number
2758 550         4893 $self->FoundTag('ExifToolVersion', "$VERSION$RELEASE");
2759 550 100 66     4408 $self->FoundTag('Now', $self->TimeNow()) if $$req{now} or $reqAll;
2760 550 100 66     3638 $self->FoundTag('NewGUID', NewGUID()) if $$req{newguid} or $reqAll;
2761             # generate sequence number if necessary
2762 550 100 66     3672 $self->FoundTag('FileSequence', $$self{FILE_SEQUENCE}) if $$req{filesequence} or $reqAll;
2763              
2764 550 100 66     3195 if ($$req{processingtime} or $reqAll) {
2765 61         167 eval { require Time::HiRes; @startTime = Time::HiRes::gettimeofday() };
  61         10724  
  61         22945  
2766 61 0 33     279 if (not @startTime and $$req{processingtime}) {
2767 0         0 $self->Warn('Install Time::HiRes to generate ProcessingTime');
2768             }
2769             }
2770              
2771             # create Hash object if ImageDataHash is requested
2772 550 50 33     2349 if ($$req{imagedatahash} and not $$self{ImageDataHash}) {
2773 0         0 my $imageHashType = $self->Options('ImageHashType');
2774 0 0       0 if ($imageHashType =~ /^SHA(256|512)$/i) {
    0          
2775 0 0       0 if (require Digest::SHA) {
2776 0         0 $$self{ImageDataHash} = Digest::SHA->new($1);
2777             } else {
2778 0         0 $self->Warn("Install Digest::SHA to calculate image data SHA$1");
2779             }
2780             } elsif (require Digest::MD5) {
2781 0         0 $$self{ImageDataHash} = Digest::MD5->new;
2782             } else {
2783 0         0 $self->Warn('Install Digest::MD5 to calculate image data MD5');
2784             }
2785             }
2786 550         1740 ++$$self{FILE_SEQUENCE}; # count files read
2787             }
2788              
2789 552         1746 my $filename = $$self{FILENAME}; # image file name ('' if already open)
2790 552         1293 my $raf = $$self{RAF}; # RandomAccess object
2791              
2792 552         2311 local *EXIFTOOL_FILE; # avoid clashes with global namespace
2793              
2794 552         1370 my $realname = $filename;
2795 552 100       2104 unless ($raf) {
2796             # save file name
2797 505 50 33     3362 if (defined $filename and $filename ne '') {
2798 505 50       1714 unless ($filename eq '-') {
2799             # extract file name from pipe if necessary
2800 505 50       2299 $realname =~ /\|$/ and $realname =~ s/^.*?"(.*?)".*/$1/s;
2801 505         2443 my ($dir, $name) = SplitFileName($realname);
2802 505         2629 $self->FoundTag('FileName', $name);
2803 505 100 66     3781 if ($$req{basename} or
      66        
2804             ($reqAll and not $$self{EXCL_TAG_LOOKUP}{basename}))
2805             {
2806 61 50       576 $self->FoundTag('BaseName', $name =~ /(.*)\./ ? $1 : $name);
2807             }
2808 505 50 33     4239 $self->FoundTag('Directory', $dir) if defined $dir and length $dir;
2809 505 100 66     3977 if ($$req{filepath} or
      66        
2810             ($reqAll and not $$self{EXCL_TAG_LOOKUP}{filepath}))
2811             {
2812 61         160 my $path;
2813 61         329 local $SIG{'__WARN__'} = \&SetWarning;
2814 61 50 33     453 if ($^O eq 'MSWin32' and $$options{WindowsLongPath}) {
    50          
2815 0         0 $path = $self->WindowsLongPath($filename);
2816 61         617 } elsif (eval { require Cwd }) {
2817 61         147 $path = eval { Cwd::abs_path($filename) };
  61         4070  
2818             }
2819 61 50       300 if (defined $path) {
    0          
2820 61 50       287 $path =~ tr/\\/\// if $^O eq 'MSWin32'; # return forward slashes
2821 61         291 $self->FoundTag('FilePath', $path);
2822             } elsif ($$req{filepath}) {
2823 0         0 $self->Warn('The Perl Cwd module must be installed to use FilePath');
2824             }
2825             }
2826             # get size of resource fork on Mac OS
2827 505 50 33     3041 $rsize = -s "$filename/..namedfork/rsrc" if $^O eq 'darwin' and not $$self{IN_RESOURCE};
2828             # check to see if Zone.Identifier file exists in Windows
2829 505 50 33     2328 if ($^O eq 'MSWin32' and eval { require Win32API::File }) {
  0         0  
2830 0         0 my $wattr;
2831 0         0 my $zfile = "${filename}:Zone.Identifier";
2832 0 0       0 if ($self->EncodeFileName($zfile)) {
2833 0         0 $wattr = eval { Win32API::File::GetFileAttributesW($zfile) };
  0         0  
2834             } else {
2835 0         0 $wattr = eval { Win32API::File::GetFileAttributes($zfile) };
  0         0  
2836             }
2837 0 0       0 $zid = 1 unless $wattr == Win32API::File::INVALID_FILE_ATTRIBUTES();
2838             }
2839             }
2840             # open the file
2841 505 50       3190 if ($self->Open(\*EXIFTOOL_FILE, $filename)) {
    0          
2842             # create random access file object
2843 505         7263 $raf = File::RandomAccess->new(\*EXIFTOOL_FILE);
2844             # patch to force pipe to be buffered because seek returns success
2845             # in Windows cmd shell pipe even though it really failed
2846 505 50 33     3964 $$raf{TESTED} = -1 if $filename eq '-' or $filename =~ /\|$/;
2847 505         1912 $$self{RAF} = $raf;
2848             } elsif ($self->IsDirectory($filename)) {
2849 0         0 $isDir = 1;
2850             } else {
2851 0         0 $self->Error('Error opening file');
2852             # continue to process alt files if necessary
2853 0 0       0 $self->DoneExtract() if $$self{ALT_EXIFTOOL};
2854             }
2855             } else {
2856 0         0 $self->Error('No file specified');
2857             }
2858             }
2859              
2860 552   33     2563 while ($raf or $isDir) {
2861 552         1391 my (@stat, $plainFile);
2862 552 100       9649 if ($reEntry) {
    50          
    100          
    50          
2863             # we already set these tags
2864             } elsif (not $raf) {
2865 0         0 @stat = stat $filename;
2866             } elsif (not $$raf{FILE_PT}) {
2867             # get file size from image in memory
2868 25         72 $self->FoundTag('FileSize', length ${$$raf{BUFF_PT}});
  25         145  
2869             } elsif (-f $$raf{FILE_PT}) {
2870             # get file tags if this is a plain file
2871 525         2612 @stat = stat _;
2872 525         1242 $plainFile = 1;
2873             # hack to patch Windows daylight savings time bug
2874 525 50       2687 @stat[8,9,10] = $self->GetFileTime($$raf{FILE_PT}) if $^O eq 'MSWin32';
2875             } else {
2876             # (note that Windows directories will still show the
2877             # daylight savings time bug -- should fix this sometime)
2878 0         0 @stat = stat $$raf{FILE_PT};
2879 0 0       0 $stat[7] = undef if -p $$raf{FILE_PT}; # (pipe buffer size isn't useful)
2880             }
2881 552         1395 my $fileSize = $stat[7];
2882 552 100       3645 $self->FoundTag('FileSize', $stat[7]) if defined $stat[7];
2883 552 50       2053 $self->FoundTag('ResourceForkSize', $rsize) if $rsize;
2884 552 50       1709 $self->FoundTag('ZoneIdentifier', 'Exists') if $zid;
2885 552 100       2932 $self->FoundTag('FileModifyDate', $stat[9]) if defined $stat[9];
2886 552 100       3090 $self->FoundTag('FileAccessDate', $stat[8]) if defined $stat[8];
2887 552 50       2743 my $cTag = $^O eq 'MSWin32' ? 'FileCreateDate' : 'FileInodeChangeDate';
2888 552 100       3247 $self->FoundTag($cTag, $stat[10]) if defined $stat[10];
2889 552 100       3303 $self->FoundTag('FilePermissions', $stat[2]) if defined $stat[2];
2890             # extract more system info if SystemTags option is set
2891 552 100       2018 if (@stat) {
2892 525   66     4285 my $sys = $$options{SystemTags} || ($reqAll and not defined $$options{SystemTags});
2893 525 100 66     3462 if ($sys or $$req{fileattributes}) {
2894 61         306 my @attr = ($stat[2] & 0xf000, $stat[2] & 0x0e00);
2895             # add Windows file attributes if available
2896 61 0 33     830 if ($^O eq 'MSWin32' and defined $filename and $filename ne '' and $filename ne '-') {
      33        
      0        
2897 0         0 local $SIG{'__WARN__'} = \&SetWarning;
2898 0 0       0 if (eval { require Win32API::File }) {
  0         0  
2899 0         0 my $wattr;
2900 0         0 my $file = $filename;
2901 0 0       0 if ($self->EncodeFileName($file)) {
2902 0         0 $wattr = eval { Win32API::File::GetFileAttributesW($file) };
  0         0  
2903             } else {
2904 0         0 $wattr = eval { Win32API::File::GetFileAttributes($file) };
  0         0  
2905             }
2906 0 0 0     0 push @attr, $wattr if defined $wattr and $wattr != 0xffffffff;
2907             }
2908             }
2909 61         450 $self->FoundTag('FileAttributes', "@attr");
2910             }
2911 525 100 66     3475 $self->FoundTag('FileDeviceNumber', $stat[0]) if $sys or $$req{filedevicenumber};
2912 525 100 66     3334 $self->FoundTag('FileInodeNumber', $stat[1]) if $sys or $$req{fileinodenumber};
2913 525 100 66     3270 $self->FoundTag('FileHardLinks', $stat[3]) if $sys or $$req{filehardlinks};
2914 525 100 66     3721 $self->FoundTag('FileUserID', $stat[4]) if $sys or $$req{fileuserid};
2915 525 100 66     3447 $self->FoundTag('FileGroupID', $stat[5]) if $sys or $$req{filegroupid};
2916 525 100 66     3257 $self->FoundTag('FileDeviceID', $stat[6]) if $sys or $$req{filedeviceid};
2917 525 100 66     2909 $self->FoundTag('FileBlockSize', $stat[11]) if $sys or $$req{fileblocksize};
2918 525 100 66     3167 $self->FoundTag('FileBlockCount', $stat[12]) if $sys or $$req{fileblockcount};
2919             }
2920             # extract MDItem tags if requested (only on plain files)
2921 552 0 33     3109 if ($^O eq 'darwin' and defined $filename and $filename ne '' and defined $fileSize) {
      33        
      0        
2922 0   0     0 my $reqMacOS = ($reqAll > 1 or $$req{'macos:'});
2923 0   0     0 my $crDate = ($reqMacOS || $$req{filecreatedate});
2924 0   0     0 my $mdItem = ($reqMacOS || $$options{MDItemTags} || grep /^mditem/, keys %$req);
2925 0   0     0 my $xattr = ($reqMacOS || $$options{XAttrTags} || grep /^xattr/, keys %$req);
2926 0 0 0     0 if ($crDate or $mdItem or $xattr) {
      0        
2927 0         0 require Image::ExifTool::MacOS;
2928 0 0       0 Image::ExifTool::MacOS::GetFileCreateDate($self, $filename) if $crDate;
2929 0 0 0     0 Image::ExifTool::MacOS::ExtractMDItemTags($self, $filename) if $mdItem and $plainFile;
2930 0 0       0 Image::ExifTool::MacOS::ExtractXAttrTags($self, $filename) if $xattr;
2931             }
2932             }
2933             # do whatever else we can with directories, then return
2934 552 50 66     4650 if ($isDir or (defined $stat[2] and ($stat[2] & 0170000) == 0040000)) {
      33        
2935 0         0 $self->FoundTag('FileType', 'DIR');
2936 0         0 $self->FoundTag('FileTypeExtension', '');
2937 0         0 $self->DoneExtract();
2938 0 0       0 $raf->Close() if $raf;
2939 0 0       0 %saveOptions and $$self{OPTIONS} = \%saveOptions;
2940 0 0       0 delete $$self{InExtract} unless $reEntry;
2941 0         0 return 1;
2942             }
2943             # get list of file types to check
2944 552         1528 my ($tiffType, %noMagic, $recognizedExt);
2945 552         2421 my $ext = $$self{FILE_EXT} = GetFileExtension($realname);
2946             # set $recognizedExt if this file type is recognized by extension only
2947             $recognizedExt = $ext if defined $ext and not defined $magicNumber{$ext} and
2948 552 50 100     6101 defined $moduleName{$ext} and not $moduleName{$ext};
      100        
      66        
2949 552         2689 my @fileTypeList = GetFileType($realname);
2950 552 50       2178 if ($fast >= 4) {
2951 0 0       0 if (@fileTypeList) {
2952 0         0 $type = shift @fileTypeList;
2953 0         0 $self->SetFileType($$self{FILE_TYPE} = $type);
2954             } else {
2955 0         0 $self->Error('Unknown file type');
2956             }
2957 0         0 $self->DoneExtract();
2958 0         0 last; # don't read the file
2959             }
2960 552 100       1661 if (@fileTypeList) {
2961             # add remaining types to end of list so we test them all
2962 502         1966 my $pat = join '|', @fileTypeList;
2963 502         72939 push @fileTypeList, grep(!/^($pat)$/, @fileTypes);
2964 502         2161 $tiffType = $$self{FILE_EXT};
2965 502 100       2086 unless ($fast == 3) {
2966 501         1682 $noMagic{MXF} = 1; # don't do magic number test on MXF or DV files
2967 501         1638 $noMagic{DV} = 1;
2968             }
2969             } else {
2970             # scan through all recognized file types
2971 50         1526 @fileTypeList = @fileTypes;
2972 50         139 $tiffType = 'TIFF';
2973             }
2974 552         1323 push @fileTypeList, ''; # end of list marker
2975             # initialize the input file for seeking in binary data
2976 552         3870 $raf->BinMode(); # set binary mode before we start reading
2977 552         2242 my $pos = $raf->Tell(); # get file position so we can rewind
2978             # loop through list of file types to test
2979 552         1263 my ($buff, $err);
2980 552         3618 my %dirInfo = ( RAF => $raf, Base => $pos, TestBuff => \$buff );
2981             # read start of file for testing
2982 552 100       8787 if ($raf->Read($buff, $testLen)) {
2983 549 50       3019 $raf->Seek($pos, 0) or $err = 'Error seeking in file';
2984             } else {
2985 3         8 $err = $$raf{ERROR};
2986 3         7 $buff = '';
2987             }
2988 552         2279 until ($err) {
2989 2383         3826 my $unkHeader;
2990 2383         4322 $type = shift @fileTypeList;
2991 2383 100       4656 if ($type) {
    100          
    50          
2992 2377 100       6298 if ($magicNumber{$type}) {
2993             # do quick test for this file type to avoid loading module unnecessarily
2994 2301 100 100     63896 next if $buff !~ /^$magicNumber{$type}/s and not $noMagic{$type};
2995             } else {
2996             # keep checking for other types if we recognize this file only by extension
2997 76 50 66     418 next if defined $moduleName{$type} and not $moduleName{$type};
2998 76 50       250 next if $fast > 2; # keep checking if we aren't processing the file
2999             }
3000 632 50 66     3442 next if $weakMagic{$type} and defined $recognizedExt;
3001             } elsif (not defined $type) {
3002 3         8 last;
3003             } elsif ($recognizedExt) {
3004 0         0 $type = $recognizedExt; # set type from recognized file extension only
3005             } else {
3006             # last ditch effort to scan past unknown header for JPEG/TIFF
3007 3 50       11 next unless $buff =~ /(\xff\xd8\xff|MM\0\x2a|II\x2a\0)/g;
3008 0 0       0 $type = ($1 eq "\xff\xd8\xff") ? 'JPEG' : 'TIFF';
3009 0         0 my $skip = pos($buff) - length($1);
3010 0         0 $dirInfo{Base} = $pos + $skip;
3011 0 0       0 $raf->Seek($pos + $skip, 0) or $err = 'Error seeking in file', last;
3012 0         0 $self->Warn("Processing $type-like data after unknown $skip-byte header");
3013 0 0       0 $unkHeader = 1 unless $$self{DOC_NUM};
3014             }
3015             # save file type in member variable
3016 632         2260 $$self{FILE_TYPE} = $type;
3017 632 100       2980 $dirInfo{Parent} = ($type eq 'TIFF') ? $tiffType : $type;
3018             # don't process the file when FastScan > 2
3019 632 50 66     2415 if ($fast > 2 and not $processType{$type}) {
3020 0 0 0     0 unless ($weakMagic{$type} and (not $ext or $ext ne $type)) {
      0        
3021 0         0 $self->SetFileType($dirInfo{Parent});
3022             }
3023 0         0 last;
3024             }
3025 632         1708 my $module = $moduleName{$type};
3026 632 100       2000 $module = $type unless defined $module;
3027 632         1668 my $func = "Process$type";
3028              
3029             # load module if necessary
3030 632 100       2269 if ($module) {
    50          
3031 362         50624 require "Image/ExifTool/$module.pm";
3032 362         1249 $func = "Image::ExifTool::${module}::$func";
3033             } elsif ($module eq '0') {
3034 0         0 $self->SetFileType();
3035 0         0 $self->Warn('Unsupported file type');
3036 0         0 last;
3037             }
3038 632         1390 push @{$$self{PATH}}, $type; # save file type in metadata PATH
  632         2786  
3039              
3040             # process the file
3041 113     113   1319 no strict 'refs';
  113         277  
  113         7746  
3042 632         6036 my $result = &$func($self, \%dirInfo);
3043 113     113   675 use strict 'refs';
  113         234  
  113         2581380  
3044              
3045 632         1626 pop @{$$self{PATH}};
  632         2272  
3046              
3047 632 100       2708 if ($result) { # all done if successful
3048 549 50       1805 if ($unkHeader) {
3049 0         0 $self->DeleteTag('FileType');
3050 0         0 $self->DeleteTag('FileTypeExtension');
3051 0         0 $self->DeleteTag('MIMEType');
3052 0         0 $self->VPrint(0,"Reset file type due to unknown header\n");
3053             }
3054 549         3903 last;
3055             }
3056             # seek back to try again from the same position in the file
3057 83 50       275 $raf->Seek($pos, 0) or $err = 'Error seeking in file';
3058             }
3059 552 50 66     3817 if (not $err and not defined $type and not $$self{DOC_NUM}) {
      66        
3060             # if we were given a single image with a known type there
3061             # must be a format error since we couldn't read it, otherwise
3062             # it is likely we don't support images of this type
3063 3   50     12 my $fileType = GetFileType($realname) || '';
3064 3 50       14 if (not length $buff) {
3065 3         10 $err = 'File is empty';
3066             } else {
3067 0         0 my $ch = substr($buff, 0, 1);
3068 0 0 0     0 if (length $buff < 16 or $buff =~ /[^\Q$ch\E]/) {
3069 0 0       0 if ($fileType eq 'RAW') {
    0          
3070 0         0 $err = 'Unsupported RAW file type';
3071             } elsif ($fileType) {
3072 0         0 $err = 'File format error';
3073             } else {
3074 0         0 $err = 'Unknown file type';
3075             }
3076             } else {
3077             # provide some insight into the content of some corrupted files
3078 0 0       0 if ($$self{OPTIONS}{FastScan}) {
3079 0         0 $err = 'File header is all';
3080             } else {
3081 0         0 my $num = 0;
3082 0         0 for (;;) {
3083 0 0       0 $raf->Read($buff, 65536) or undef($num), last;
3084 0 0       0 $buff =~ /[^\Q$ch\E]/g and $num += pos($buff) - 1, last;
3085 0         0 $num += length($buff);
3086             }
3087 0 0       0 if ($num) {
3088 0         0 $err = 'First ' . ConvertFileSize($num) . ' of file is';
3089             } else {
3090 0         0 $err = 'Entire file is';
3091             }
3092             }
3093 0 0       0 if ($ch eq "\0") {
    0          
    0          
3094 0         0 $err .= ' binary zeros';
3095             } elsif ($ch eq ' ') {
3096 0         0 $err .= ' ASCII spaces';
3097             } elsif ($ch =~ /[a-zA-Z0-9]/) {
3098 0         0 $err .= " ASCII '${ch}' characters";
3099             } else {
3100 0         0 $err .= sprintf(" binary 0x%.2x's", ord $ch);
3101             }
3102             }
3103             }
3104             }
3105 552 100 0     3148 if ($err) {
    50 33        
3106 3         18 $self->Error($err);
3107             } elsif ($self->Options('ScanForXMP') and (not defined $type or
3108             (not $fast and not $$self{FoundXMP})))
3109             {
3110             # scan for XMP
3111 0         0 $raf->Seek($pos, 0);
3112 0         0 require Image::ExifTool::XMP;
3113 0 0       0 Image::ExifTool::XMP::ScanForXMP($self, $raf) and $type = '';
3114             }
3115             # extract binary EXIF data block only if requested
3116 552 100 100     5545 if (defined $$self{EXIF_DATA} and length $$self{EXIF_DATA} > 16 and
      100        
      100        
3117             ($$req{exif} or
3118             # (not extracted normally, so check TAGS_FROM_FILE)
3119             ($$self{TAGS_FROM_FILE} and not $$self{EXCL_TAG_LOOKUP}{exif})))
3120             {
3121 37         313 $self->FoundTag('EXIF', $$self{EXIF_DATA});
3122             }
3123 552 100       2501 unless ($reEntry) {
3124 550         1999 $$self{PATH} = [ ]; # reset PATH
3125 550         3435 $self->DoneExtract();
3126             # do our HTML dump if requested
3127 550 50       2969 if ($$self{HTML_DUMP}) {
3128 0         0 $raf->Seek(0, 2); # seek to end of file
3129 0         0 $$self{HTML_DUMP}->FinishTiffDump($self, $raf->Tell());
3130 0         0 my $pos = $$options{HtmlDumpBase};
3131 0 0 0     0 $pos = ($$self{FIRST_EXIF_POS} || 0) unless defined $pos;
3132 0 0       0 my $dataPt = defined $$self{EXIF_DATA} ? \$$self{EXIF_DATA} : undef;
3133 0 0 0     0 undef $dataPt if defined $$self{EXIF_POS} and $pos != $$self{EXIF_POS};
3134 0 0       0 undef $dataPt if $$self{ExtendedEXIF}; # can't use EXIF block if not contiguous
3135             my $success = $$self{HTML_DUMP}->Print($raf, $dataPt, $pos,
3136             $$options{TextOut}, $$options{HtmlDump},
3137 0 0       0 $$self{FILENAME} ? "HTML Dump ($$self{FILENAME})" : 'HTML Dump');
3138 0 0       0 $self->Warn("Error reading $$self{HTML_DUMP}{ERROR}") if $success < 0;
3139             }
3140             }
3141 552 100       2259 if ($filename) {
3142 507         4468 $raf->Close(); # close the file if we opened it
3143             # process the resource fork as an embedded file on Mac filesystems
3144 507 0 33     1841 if ($rsize and $$options{ExtractEmbedded}) {
3145 0         0 local *RESOURCE_FILE;
3146 0 0       0 if ($self->Open(\*RESOURCE_FILE, "$filename/..namedfork/rsrc")) {
3147 0         0 $$self{DOC_NUM} = $$self{DOC_COUNT} + 1;
3148 0         0 $$self{IN_RESOURCE} = 1;
3149 0         0 $self->ExtractInfo(\*RESOURCE_FILE, { ReEntry => 1 });
3150 0         0 close RESOURCE_FILE;
3151 0         0 delete $$self{IN_RESOURCE};
3152             } else {
3153 0         0 $self->Warn('Error opening resource fork');
3154             }
3155             }
3156             }
3157 552         14794 last; # (loop was a cheap "goto")
3158             }
3159              
3160             # Note: This should be the only tag generated after BuildCompositeTags,
3161             # and as such it can't be used in user-defined Composite tags
3162 552 100       2829 @startTime and $self->FoundTag('ProcessingTime', Time::HiRes::tv_interval(\@startTime));
3163              
3164             # add numbers to warnings with multiple occurrences
3165 552 100       1106 if (%{$$self{WAS_WARNED}}) {
  552         2807  
3166 46         230 my ($tag, $val) = ( 'Warning', $$self{VALUE} );
3167 46         268 for ($i=1; $$val{$tag}; ++$i) {
3168 56         211 my $n = $$self{WAS_WARNED}{$$val{$tag}};
3169 56 100 66     433 $$val{$tag} .= " [x$n]" if $n and $n > 1;
3170 56         262 $tag = "Warning ($i)";
3171             }
3172             }
3173             # restore original options
3174 552 100       2081 %saveOptions and $$self{OPTIONS} = \%saveOptions;
3175              
3176 552 100       1742 if ($reEntry) {
3177             # restore necessary members when exiting re-entrant code
3178 2         19 $$self{$_} = $$reEntry{$_} foreach keys %$reEntry;
3179 2         7 SetByteOrder($saveOrder);
3180             } else {
3181             # call cleanup routines if necessary
3182 550 50       2095 if ($$self{Cleanup}) {
3183 0         0 &$_($self) foreach @{$$self{Cleanup}};
  0         0  
3184 0         0 delete $$self{Cleanup};
3185             }
3186 550         1764 delete $$self{InExtract};
3187             }
3188              
3189             # ($type may be undef without an Error when processing sub-documents)
3190 552 100 66     4002 return 0 if not defined $type or exists $$self{VALUE}{Error};
3191 549         3974 return 1;
3192             }
3193              
3194             #------------------------------------------------------------------------------
3195             # Get hash of extracted meta information
3196             # Inputs: 0) ExifTool object reference
3197             # 1-N) options hash reference, tag list reference or tag names
3198             # Returns: Reference to information hash
3199             # Notes: - pass an undefined value to avoid parsing arguments
3200             # - If groups are specified, first groups take precedence if duplicate
3201             # tags found but Duplicates option not set.
3202             # - tag names may end in '#' to extract ValueConv value
3203             sub GetInfo($;@)
3204             {
3205 714     714 1 4510 local $_;
3206 714         1600 my $self = shift;
3207 714         1824 my (%saveOptions, @saveMembers, @savedMembers);
3208              
3209             # save necessary members to allow GetInfo to be called from within ExtractInfo
3210 714 100       2995 if ($$self{InExtract}) {
3211 4         14 @saveMembers = qw(REQUESTED_TAGS REQ_TAG_LOOKUP IO_TAG_LIST);
3212 4         39 @savedMembers = @$self{@saveMembers};
3213             }
3214 714 100 66     4262 unless (@_ and not defined $_[0]) {
3215 175         443 %saveOptions = %{$$self{OPTIONS}}; # save original options
  175         18016  
3216             # must set FILENAME so it isn't parsed from the arguments
3217 175 100       2124 $$self{FILENAME} = '' unless defined $$self{FILENAME};
3218 175         1928 $self->ParseArguments(@_);
3219             }
3220              
3221             # get reference to list of tags for which we will return info
3222 714         4238 my ($rtnTags, $byValue, $wildTags) = $self->SetFoundTags();
3223              
3224             # build hash of tag information
3225 714         1850 my (%info, %ignored);
3226 714 100       3517 my $conv = $$self{OPTIONS}{PrintConv} ? 'PrintConv' : 'ValueConv';
3227 714         2081 foreach (@$rtnTags) {
3228 36322         85337 my $val = $self->GetValue($_, $conv);
3229 36322 100       77438 defined $val or $ignored{$_} = 1, next;
3230 35264         101368 $info{$_} = $val;
3231             }
3232              
3233             # override specified tags with ValueConv value if necessary
3234 714 100       3295 if (@$byValue) {
3235             # first determine the number of times each non-ValueConv value is used
3236 4         14 my %nonVal;
3237 4   100     107 $nonVal{$_} = ($nonVal{$_} || 0) + 1 foreach @$rtnTags;
3238 4         29 --$nonVal{$$rtnTags[$_]} foreach @$byValue;
3239             # loop through ValueConv tags, updating tag keys and returned values
3240 4         10 foreach (@$byValue) {
3241 25         51 my $tag = $$rtnTags[$_];
3242 25         66 my $val = $self->GetValue($tag, 'ValueConv');
3243 25 100       111 next unless defined $val;
3244 16         35 my $vtag = $tag;
3245             # generate a new tag key like "Tag #" or "Tag #(1)"
3246 16         166 $vtag =~ s/( |$)/ #/;
3247 16 50       66 unless (defined $$self{VALUE}{$vtag}) {
3248 16         56 $$self{VALUE}{$vtag} = $$self{VALUE}{$tag};
3249 16         53 $$self{TAG_INFO}{$vtag} = $$self{TAG_INFO}{$tag};
3250 16         69 $$self{TAG_EXTRA}{$vtag} = $$self{TAG_EXTRA}{$tag};
3251 16         43 $$self{FILE_ORDER}{$vtag} = $$self{FILE_ORDER}{$tag};
3252             # remove existing PrintConv entry unless we are using it too
3253 16 100       62 delete $info{$tag} unless $nonVal{$tag};
3254             }
3255 16         51 $$rtnTags[$_] = $vtag; # store ValueConv value with new tag key
3256 16         68 $info{$vtag} = $val; # return ValueConv value
3257             }
3258             }
3259              
3260             # remove ignored tags from the list
3261 714   50     3254 my $reqTags = $$self{REQUESTED_TAGS} || [ ];
3262 714 100       2460 if (%ignored) {
3263 427 100       2094 if (not @$reqTags) {
    100          
3264 197         544 my @goodTags;
3265 197         597 foreach (@$rtnTags) {
3266 22980 100       49747 push @goodTags, $_ unless $ignored{$_};
3267             }
3268 197         2258 $rtnTags = $$self{FOUND_TAGS} = \@goodTags;
3269             } elsif (@$wildTags) {
3270             # only remove tags specified by wildcard
3271 42         77 my @goodTags;
3272 42         85 my $i = 0;
3273 42         112 foreach (@$rtnTags) {
3274 392 100 100     1185 if (@$wildTags and $i == $$wildTags[0]) {
3275 231         348 shift @$wildTags;
3276 231 50       676 push @goodTags, $_ unless $ignored{$_};
3277             } else {
3278 161         399 push @goodTags, $_;
3279             }
3280 392         569 ++$i;
3281             }
3282 42         230 $rtnTags = $$self{FOUND_TAGS} = \@goodTags;
3283             }
3284             }
3285              
3286             # return sorted tag list if provided with a list reference
3287 714 100       3053 if ($$self{IO_TAG_LIST}) {
3288             # use file order by default if no tags specified
3289             # (no such thing as 'Input' order in this case)
3290 10         54 my $sort = $$self{OPTIONS}{Sort};
3291 10 50 33     67 $sort = 'File' unless @$reqTags or ($sort and $sort ne 'Input');
      66        
3292             # return tags in specified sort order
3293 10         65 @{$$self{IO_TAG_LIST}} = $self->GetTagList($rtnTags, $sort, $$self{OPTIONS}{Sort2});
  10         80  
3294             }
3295              
3296             # restore original options and member variables
3297 714 100       5830 %saveOptions and $$self{OPTIONS} = \%saveOptions;
3298 714 100       2440 @$self{@saveMembers} = @savedMembers if @saveMembers;
3299              
3300 714         4331 return \%info;
3301             }
3302              
3303             #------------------------------------------------------------------------------
3304             # Inputs: 0) ExifTool object reference
3305             # 1) [optional] reference to info hash or tag list ref (default is found tags)
3306             # 2) [optional] sort order ('File', 'Input', ...)
3307             # 3) [optional] secondary sort order
3308             # Returns: List of tags in specified order
3309             sub GetTagList($;$$$)
3310             {
3311 462     462 1 170419 local $_;
3312 462         2047 my ($self, $info, $sort, $sort2) = @_;
3313              
3314 462         1169 my $foundTags;
3315 462 100       2572 if (ref $info eq 'HASH') {
    50          
3316 451         7592 my @tags = keys %$info;
3317 451         1567 $foundTags = \@tags;
3318             } elsif (ref $info eq 'ARRAY') {
3319 11         27 $foundTags = $info;
3320             }
3321 462         1481 my $fileOrder = $$self{FILE_ORDER};
3322              
3323 462 50       1579 if ($foundTags) {
3324             # make sure a FILE_ORDER entry exists for all tags
3325             # (note: already generated bogus entries for FOUND_TAGS case below)
3326 462         1554 foreach (@$foundTags) {
3327 24944 50       53723 next if defined $$fileOrder{$_};
3328 0         0 $$fileOrder{$_} = 999;
3329             }
3330             } else {
3331 0 0 0     0 $sort = $info if $info and not $sort;
3332 0 0 0     0 $foundTags = $$self{FOUND_TAGS} || $self->SetFoundTags() or return undef;
3333             }
3334 462 100       1879 $sort or $sort = $$self{OPTIONS}{Sort};
3335              
3336             # return original list if no sort order specified
3337 462 100 66     3582 return @$foundTags unless $sort and $sort ne 'Input';
3338              
3339 439 50 33     5778 if ($sort eq 'Tag' or $sort eq 'Alpha') {
    100          
    50          
3340 0         0 return sort @$foundTags;
3341             } elsif ($sort =~ /^Group(\d*(:\d+)*)/) {
3342 436   50     3034 my $family = $1 || 0;
3343             # want to maintain a basic file order with the groups
3344             # ordered in the way they appear in the file
3345 436         1116 my (%groupCount, %groupOrder);
3346 436         912 my $numGroups = 0;
3347 436         874 my $tag;
3348 436         3431 foreach $tag (sort { $$fileOrder{$a} <=> $$fileOrder{$b} } @$foundTags) {
  133553         221632  
3349 23984         44759 my $group = $self->GetGroup($tag, $family);
3350 23984         40729 my $num = $groupCount{$group};
3351 23984 100       45079 $num or $num = $groupCount{$group} = ++$numGroups;
3352 23984         51846 $groupOrder{$tag} = $num;
3353             }
3354 436 50       2582 $sort2 or $sort2 = $$self{OPTIONS}{Sort2};
3355 436 50       1805 if ($sort2) {
3356 436 50 33     3739 if ($sort2 eq 'Tag' or $sort2 eq 'Alpha') {
    50          
3357 0 0       0 return sort { $groupOrder{$a} <=> $groupOrder{$b} or $a cmp $b } @$foundTags;
  0         0  
3358             } elsif ($sort2 eq 'Descr') {
3359 0         0 my $desc = $self->GetDescriptions($foundTags);
3360 0         0 return sort { $groupOrder{$a} <=> $groupOrder{$b} or
3361 0 0       0 $$desc{$a} cmp $$desc{$b} } @$foundTags;
3362             }
3363             }
3364 436         3003 return sort { $groupOrder{$a} <=> $groupOrder{$b} or
3365 133677 50       287088 $$fileOrder{$a} <=> $$fileOrder{$b} } @$foundTags;
3366             } elsif ($sort eq 'Descr') {
3367 0         0 my $desc = $self->GetDescriptions($foundTags);
3368 0         0 return sort { $$desc{$a} cmp $$desc{$b} } @$foundTags;
  0         0  
3369             } else {
3370 3         40 return sort { $$fileOrder{$a} <=> $$fileOrder{$b} } @$foundTags;
  4779         8901  
3371             }
3372             }
3373              
3374             #------------------------------------------------------------------------------
3375             # Get list of found tags in specified sort order
3376             # Inputs: 0) ExifTool object reference, 1) sort order ('File', 'Input', ...)
3377             # 2) secondary sort order
3378             # Returns: List of tag keys in specified order
3379             # Notes: If not specified, sort order is taken from OPTIONS
3380             sub GetFoundTags($;$$)
3381             {
3382 1     1 1 257 local $_;
3383 1         4 my ($self, $sort, $sort2) = @_;
3384 1 50 33     9 my $foundTags = $$self{FOUND_TAGS} || $self->SetFoundTags() or return undef;
3385 1         8 return $self->GetTagList($foundTags, $sort, $sort2);
3386             }
3387              
3388             #------------------------------------------------------------------------------
3389             # Get list of requested tags
3390             # Inputs: 0) ExifTool object reference
3391             # Returns: List of requested tag keys
3392             sub GetRequestedTags($)
3393             {
3394 2     2 1 7 local $_;
3395 2         4 return @{$_[0]{REQUESTED_TAGS}};
  2         17  
3396             }
3397              
3398             #------------------------------------------------------------------------------
3399             # Get tag value
3400             # Inputs: 0) ExifTool object reference
3401             # 1) tag key or tag name with optional group names (case sensitive)
3402             # (or flattened tagInfo for getting field values, not part of public API)
3403             # 2) [optional] Value type: PrintConv, ValueConv, Both, Raw, Bin or Rational, the
3404             # default is PrintConv or ValueConv, depending on the PrintConv option setting
3405             # 3) raw field value (not part of public API)
3406             # Returns: Scalar context: tag value or undefined
3407             # List context: list of values or empty list
3408             sub GetValue($$;$)
3409             {
3410 54446     54446 1 73745 local $_;
3411 54446         105781 my ($self, $tag, $type) = @_; # plus: ($fieldValue)
3412 54446         79243 my (@convTypes, $tagInfo, $valueConv, $both);
3413 54446         87268 my $rawValue = $$self{VALUE};
3414              
3415             # get specific tag key if tag has a group name
3416 54446 50       127969 if ($tag =~ /^(.*):(.+)/) {
3417 0         0 my ($gp, $tg) = ($1, $2);
3418 0         0 my ($i, $key, @keys);
3419             # build list of tag keys in the order of priority (no index
3420             # is top priority, otherwise higher index is higher priority)
3421 0   0     0 for ($key=$tg, $i=$$self{DUPL_TAG}{$tg} || 0; ; --$i) {
3422 0 0       0 push @keys, $key if defined $$rawValue{$key};
3423 0 0       0 last if $i <= 0;
3424 0         0 $key = "$tg ($i)";
3425             }
3426 0 0       0 if (@keys) {
3427 0         0 $key = $self->GroupMatches($gp, \@keys);
3428 0 0       0 $tag = $key if $key;
3429             }
3430             }
3431             # figure out what conversions to do
3432 54446 100       92671 if ($type) {
3433 54419 50       102423 return $$self{TAG_EXTRA}{$tag}{Rational} if $type eq 'Rational';
3434 54419 50       98785 return $$self{TAG_EXTRA}{$tag}{BinVal} if $type eq 'Bin';
3435             } else {
3436 27 50       136 $type = $$self{OPTIONS}{PrintConv} ? 'PrintConv' : 'ValueConv';
3437             }
3438              
3439             # start with the raw value
3440 54446         122327 my $value = $$rawValue{$tag};
3441 54446 100       95963 if (not defined $value) {
3442 10386 100       29966 return () unless ref $tag;
3443             # get the value of a structure field
3444 194         285 $tagInfo = $tag;
3445 194         451 $tag = $$tagInfo{Name};
3446 194         368 $value = $_[3];
3447             # (note: type "Both" is not allowed for structure fields)
3448 194 50       392 if ($type ne 'Raw') {
3449 194         317 push @convTypes, 'ValueConv';
3450 194 100       531 push @convTypes, 'PrintConv' unless $type eq 'ValueConv';
3451             }
3452             } else {
3453 44060         97271 $tagInfo = $$self{TAG_INFO}{$tag};
3454 44060 100 66     117376 if ($$tagInfo{Struct} and ref $value) {
3455             # must load XMPStruct.pl just in case (should already be loaded if
3456             # a structure was extracted, but we could also arrive here if a simple
3457             # list of values was stored incorrectly in a Struct tag)
3458 53         1367 require 'Image/ExifTool/XMPStruct.pl';
3459             # convert strucure field values
3460 53 100       164 unless ($type eq 'Both') {
3461             # (note: ConvertStruct handles the filtering and escaping too if necessary)
3462 48         230 return Image::ExifTool::XMP::ConvertStruct($self,$tagInfo,$value,$type);
3463             }
3464 5         30 $valueConv = Image::ExifTool::XMP::ConvertStruct($self,$tagInfo,$value,'ValueConv');
3465 5         23 $value = Image::ExifTool::XMP::ConvertStruct($self,$tagInfo,$value,'PrintConv');
3466             # (must not save these in $$self{BOTH} because the values may have been escaped)
3467 5         30 return ($valueConv, $value);
3468             }
3469 44007 50       84433 if ($type ne 'Raw') {
3470             # use values we calculated already if we stored them
3471 44007         83479 $both = $$self{BOTH}{$tag};
3472 44007 100       74089 if ($both) {
3473 6598 100       14549 if ($type eq 'PrintConv') {
    100          
3474 2319         5736 $value = $$both[1];
3475             } elsif ($type eq 'ValueConv') {
3476 87         212 $value = $$both[0];
3477 87 100       205 $value = $$both[1] unless defined $value;
3478             } else {
3479 4192         9366 ($valueConv, $value) = @$both;
3480             }
3481             } else {
3482 37409         67062 push @convTypes, 'ValueConv';
3483 37409 100       81926 push @convTypes, 'PrintConv' unless $type eq 'ValueConv';
3484             }
3485             }
3486             }
3487              
3488             # do the conversions
3489 44201         64865 my (@val, @prt, @raw, $convType);
3490 44201         72470 foreach $convType (@convTypes) {
3491             # don't convert a scalar reference or structure
3492 72396 100 66     157117 last if ref $value eq 'SCALAR' and not $$tagInfo{ConvertBinary};
3493 71731         135829 my $conv = $$tagInfo{$convType};
3494 71731 100       133807 unless (defined $conv) {
3495 46877 100       80541 if ($convType eq 'ValueConv') {
3496 29757 100       75636 next unless $$tagInfo{Binary};
3497 415         881 $conv = '\$val'; # return scalar reference for binary values
3498             } else {
3499             # use PRINT_CONV from tag table if PrintConv doesn't exist
3500 17120 100       56569 next unless defined($conv = $$tagInfo{Table}{PRINT_CONV});
3501 206 100       728 next if exists $$tagInfo{$convType};
3502             }
3503             }
3504             # save old ValueConv value if we want Both
3505 25426 100 100     65106 $valueConv = $value if $type eq 'Both' and $convType eq 'PrintConv';
3506 25426         54066 my ($i, $val, $vals, @values, $convList);
3507             # split into list if conversion is an array
3508 25426 100       52998 if (ref $conv eq 'ARRAY') {
3509 125         287 $convList = $conv;
3510 125         381 $conv = $$convList[0];
3511 125 50       711 my @valList = (ref $value eq 'ARRAY') ? @$value : split ' ', $value;
3512             # reorganize list if specified (Note: The writer currently doesn't
3513             # relist values, so they may be grouped but the order must not change)
3514 125         357 my $relist = $$tagInfo{Relist};
3515 125 100       354 if ($relist) {
3516 7         19 my (@newList, $oldIndex);
3517 7         21 foreach $oldIndex (@$relist) {
3518 14         26 my ($newVal, @join);
3519 14 100       33 if (ref $oldIndex) {
3520 7         23 foreach (@$oldIndex) {
3521 16 50       53 push @join, $valList[$_] if defined $valList[$_];
3522             }
3523 7 50       35 $newVal = join(' ', @join) if @join;
3524             } else {
3525 7         16 $newVal = $valList[$oldIndex];
3526             }
3527 14 100       51 push @newList, $newVal if defined $newVal;
3528             }
3529 7         16 $value = \@newList;
3530             } else {
3531 118         283 $value = \@valList;
3532             }
3533 125 50       470 return () unless @$value;
3534             }
3535             # initialize array so we can iterate over values in list
3536 25426 100       46874 if (ref $value eq 'ARRAY') {
3537 157 100       539 if (defined $$tagInfo{RawJoin}) {
3538 7         35 $val = join ' ', @$value;
3539             } else {
3540 150         326 $i = 0;
3541 150         300 $vals = $value;
3542 150         341 $val = $$vals[0];
3543             }
3544             } else {
3545 25269         39286 $val = $value;
3546             }
3547             # loop through all values in list
3548 25426         35169 for (;;) {
3549 25647 100       47099 if (defined $conv) {
3550             # get values of required tags if this is a Composite tag
3551 25628 100 66     61789 if (ref $val eq 'HASH' and not @val) {
3552             # disable escape of source values so we don't double escape them
3553 2978         5809 my $oldEscape = $$self{ESCAPE_PROC};
3554 2978         5117 delete $$self{ESCAPE_PROC};
3555             # temporarily delete filter so it isn't applied to the Require'd values
3556 2978         5559 my $oldFilter = $$self{OPTIONS}{Filter};
3557 2978         5374 delete $$self{OPTIONS}{Filter};
3558 2978         12360 foreach (keys %$val) {
3559 17331 50       35829 next unless defined $$val{$_};
3560 17331         47277 $raw[$_] = $$rawValue{$$val{$_}};
3561 17331         38079 ($val[$_], $prt[$_]) = $self->GetValue($$val{$_}, 'Both');
3562 17331 100 100     57341 next if defined $val[$_] or not $$tagInfo{Require}{$_};
3563 385 50       1019 $$self{OPTIONS}{Filter} = $oldFilter if defined $oldFilter;
3564 385         850 $$self{ESCAPE_PROC} = $oldEscape;
3565 385         1845 return ();
3566             }
3567 2593 100       7869 $$self{OPTIONS}{Filter} = $oldFilter if defined $oldFilter;
3568 2593         5685 $$self{ESCAPE_PROC} = $oldEscape;
3569             # set $val to $val[0], or \@val for a CODE ref conversion
3570 2593 50       7177 $val = ref $conv eq 'CODE' ? \@val : $val[0];
3571             }
3572 25243 100       47572 if (ref $conv eq 'HASH') {
3573             # look up converted value in hash
3574 7742 100       28692 if (not defined($value = $$conv{$val})) {
3575 464 100       1534 if ($$conv{BITMASK}) {
3576 128         956 $value = DecodeBits($val, $$conv{BITMASK}, $$tagInfo{BitsPerWord});
3577             } else {
3578             # use alternate conversion routine if available
3579 336 100       1083 if ($$conv{OTHER}) {
3580 259         1473 local $SIG{'__WARN__'} = \&SetWarning;
3581 259         634 undef $evalWarning;
3582 259         582 $value = &{$$conv{OTHER}}($val, undef, $conv);
  259         1401  
3583 259 50       1166 $self->Warn("$convType $tag: " . CleanWarning()) if $evalWarning;
3584             }
3585 336 100       978 if (not defined $value) {
3586 81 50 66     496 if ($$tagInfo{PrintHex} and $val and IsInt($val) and
      66        
      33        
3587             $convType eq 'PrintConv')
3588             {
3589 0         0 $value = sprintf('Unknown (0x%x)',$val);
3590             } else {
3591 81         225 $value = "Unknown ($val)";
3592             }
3593             }
3594             }
3595             }
3596             # override with our localized language PrintConv if available
3597 7742         11610 my $tmp;
3598 7742 100 66     23331 if ($$self{CUR_LANG} and $convType eq 'PrintConv' and
      100        
      66        
3599             # (no need to check for lang-alt tag names -- they won't have a PrintConv)
3600             ref($tmp = $$self{CUR_LANG}{$$tagInfo{Name}}) eq 'HASH' and
3601             ($tmp = $$tmp{PrintConv}))
3602             {
3603 261 50 33     1137 if ($$conv{BITMASK} and not defined $$conv{$val}) {
    100          
3604 0         0 my @vals = split ', ', $value;
3605 0         0 foreach (@vals) {
3606 0 0       0 $_ = $$tmp{$_} if defined $$tmp{$_};
3607             }
3608 0         0 $value = join ', ', @vals;
3609             } elsif (defined($tmp = $$tmp{$value})) {
3610 213         566 $value = $self->Decode($tmp, 'UTF8');
3611             }
3612             }
3613             } else {
3614             # call subroutine or do eval to convert value
3615 17501         83352 local $SIG{'__WARN__'} = \&SetWarning;
3616 17501         30866 undef $evalWarning;
3617 17501 100       32149 if (ref $conv eq 'CODE') {
3618 1286         4641 $value = &$conv($val, $self);
3619             } else {
3620             #### eval ValueConv/PrintConv ($val, $self, @val, @prt, @raw)
3621 16215         1363018 $value = eval $conv;
3622 16215 50       73167 $@ and $evalWarning = $@;
3623             }
3624 17501 50       66493 $self->Warn("$convType $tag: " . CleanWarning()) if $evalWarning;
3625             }
3626             } else {
3627 19         40 $value = $val;
3628             }
3629 25262 100       57729 last unless $vals;
3630             # must store a separate copy of each binary data value in the list
3631 371 100       922 if (ref $value eq 'SCALAR') {
3632 3         3 my $tval = $$value;
3633 3         5 $value = \$tval;
3634             }
3635             # save this converted value and step to next value in list
3636 371 50       1090 push @values, $value if defined $value;
3637 371 100       969 if (++$i >= scalar(@$vals)) {
3638 150 50       498 $value = \@values if @values;
3639 150         300 last;
3640             }
3641 221         509 $val = $$vals[$i];
3642 221 100       612 if ($convList) {
3643 133         689 my $nextConv = $$convList[$i];
3644 133 50 66     802 if ($nextConv and $nextConv eq 'REPEAT') {
3645 0         0 undef $convList;
3646             } else {
3647 133         312 $conv = $nextConv;
3648             }
3649             }
3650             }
3651             # return undefined now if no value
3652 25041 100       53500 return () unless defined $value;
3653             # join back into single value if split for conversion list
3654 24465 100 66     76765 if ($convList and ref $value eq 'ARRAY') {
3655 125 100       881 $value = join($convType eq 'PrintConv' ? '; ' : ' ', @$value);
3656             }
3657             }
3658 43240 100       86788 if ($type eq 'Both') {
3659             # save both (unescaped) values because we often need them again
3660             # (Composite tags need "Both" and often Require one tag for various Composite tags)
3661 7627 100       24891 $$self{BOTH}{$tag} = [ $valueConv, $value ] unless $both;
3662             # escape values if necessary
3663 7627 50       21609 if ($$self{ESCAPE_PROC}) {
    100          
3664 0         0 DoEscape($value, $$self{ESCAPE_PROC});
3665 0 0       0 if (defined $valueConv) {
3666 0         0 DoEscape($valueConv, $$self{ESCAPE_PROC});
3667             } else {
3668 0         0 $valueConv = $value;
3669             }
3670             } elsif (not defined $valueConv) {
3671             # $valueConv is undefined if there was no print conversion done
3672 3804         5823 $valueConv = $value;
3673             }
3674 7627         34489 $self->Filter($$self{OPTIONS}{Filter}, \$value);
3675             # return Both values as a list (ValueConv, PrintConv)
3676 7627         35456 return ($valueConv, $value);
3677             }
3678             # escape value if necessary
3679 35613 100       77871 DoEscape($value, $$self{ESCAPE_PROC}) if $$self{ESCAPE_PROC};
3680              
3681             # filter if necessary
3682 35613 100 100     92671 $self->Filter($$self{OPTIONS}{Filter}, \$value) if $$self{OPTIONS}{Filter} and $type eq 'PrintConv';
3683              
3684 35613 100       68793 if (ref $value eq 'ARRAY') {
3685 311 100 100     2874 if (defined $$self{OPTIONS}{ListItem}) {
    100          
    100          
3686 3         24 $value = $$value[$$self{OPTIONS}{ListItem}];
3687             } elsif (wantarray) {
3688             # return array if requested
3689 1         11 return @$value;
3690             } elsif ($type eq 'PrintConv' and not $$self{OPTIONS}{List}) {
3691             # join PrintConv values in delimited string if List option not used
3692             # and list contains simple scalars (otherwise return ARRAY ref)
3693 170   100     855 ref and return $value foreach @$value;
3694 169         850 $value = join $$self{OPTIONS}{ListSep}, @$value;
3695             }
3696             }
3697 35611         112990 return $value;
3698             }
3699              
3700             #------------------------------------------------------------------------------
3701             # Get tag identification number
3702             # Inputs: 0) ExifTool object reference, 1) tag key
3703             # Returns: Scalar context: tag ID if available, otherwise ''
3704             # List context: 0) tag ID (or ''), 1) language code (or undef)
3705             sub GetTagID($$)
3706             {
3707 23997     23997 1 166898 my ($self, $tag) = @_;
3708 23997         49057 my $tagInfo = $$self{TAG_INFO}{$tag};
3709 23997 100 66     89713 return '' unless $tagInfo and defined $$tagInfo{TagID};
3710 23995   100     72028 my $id = $$tagInfo{KeysID} || $$tagInfo{TagID};
3711 23995 50       48880 return ($id, $$tagInfo{LangCode}) if wantarray;
3712 23995         55126 return $id;
3713             }
3714              
3715             #------------------------------------------------------------------------------
3716             # Get description for specified tag
3717             # Inputs: 0) ExifTool object reference, 1) tag key
3718             # Returns: Tag description
3719             # Notes: Will always return a defined value, even if description isn't available
3720             sub GetDescription($$)
3721             {
3722 23997     23997 1 120871 local $_;
3723 23997         42308 my ($self, $tag) = @_;
3724 23997         36372 my ($desc, $name);
3725 23997         42029 my $tagInfo = $$self{TAG_INFO}{$tag};
3726             # ($tagInfo won't be defined for missing tags extracted with -f)
3727 23997 50       49376 if ($tagInfo) {
3728             # use alternate language description if available
3729 23997         54778 while ($$self{CUR_LANG}) {
3730 847         2340 $desc = $$self{CUR_LANG}{$$tagInfo{Name}};
3731 847 100       1560 if ($desc) {
3732             # must look up Description if this tag also has a PrintConv
3733 718 100 100     2205 $desc = $$desc{Description} or last if ref $desc;
3734             } else {
3735             # look up default language of lang-alt tag
3736             last unless $$tagInfo{LangCode} and
3737             ($name = $$tagInfo{Name}) =~ s/-$$tagInfo{LangCode}$// and
3738 129 50 66     328 $desc = $$self{CUR_LANG}{$name};
      66        
3739 1 50 0     5 $desc = $$desc{Description} or last if ref $desc;
3740 1         4 $desc .= " ($$tagInfo{LangCode})";
3741             }
3742             # escape description if necessary
3743 710 50       1381 DoEscape($desc, $$self{ESCAPE_PROC}) if $$self{ESCAPE_PROC};
3744             # return description in proper Charset
3745 710         1527 return $self->Decode($desc, 'UTF8');
3746             }
3747 23287         46466 $desc = $$tagInfo{Description};
3748             }
3749             # just make the tag more readable if description doesn't exist
3750 23287 100       47409 unless ($desc) {
3751 9883         20603 $desc = MakeDescription(GetTagName($tag));
3752             # save description in tag information
3753 9883 50       34106 $$tagInfo{Description} = $desc if $tagInfo;
3754             }
3755 23287         58175 return $desc;
3756             }
3757              
3758             #------------------------------------------------------------------------------
3759             # Get group name for specified tag
3760             # Inputs: 0) ExifTool object reference
3761             # 1) tag key (or reference to tagInfo hash, not part of the public API)
3762             # 2) [optional] group family (-1 to get extended group list, or multiple
3763             # families separated by colons to return multiple groups as a string)
3764             # Returns: Scalar context: group name (for family 0 if not otherwise specified)
3765             # List context: group name if family specified, otherwise list of
3766             # group names for each family. Returns '' for undefined tag.
3767             # Notes: Multiple families may be specified with ':' in family argument (eg. '1:2')
3768             sub GetGroup($$;$)
3769             {
3770 204492     204492 1 799975 local $_;
3771 204492         377877 my ($self, $tag, $family) = @_;
3772 204492         302444 my ($tagInfo, @groups, @families, $simplify, $byTagInfo, $ex, $noID);
3773 204492 100       440617 if (ref $tag eq 'HASH') {
3774 129711         186721 $tagInfo = $tag;
3775 129711         238904 $tag = $$tagInfo{Name};
3776             # set flag so we don't get extra information for an extracted tag
3777 129711         172235 $byTagInfo = 1;
3778 129711         201423 $ex = { };
3779             } else {
3780 74781   50     201710 $tagInfo = $$self{TAG_INFO}{$tag} || { };
3781 74781   50     180187 $ex = $$self{TAG_EXTRA}{$tag} || { };
3782             }
3783 204492         369582 my $groups = $$tagInfo{Groups};
3784             # fill in default groups unless already done
3785             # (after this, Groups 0-2 in tagInfo are guaranteed to be defined)
3786 204492 100       464850 unless ($$tagInfo{GotGroups}) {
3787 39102   50     83810 my $tagTablePtr = $$tagInfo{Table} || { GROUPS => { } };
3788             # construct our group list
3789 39102 100       104496 $groups or $groups = $$tagInfo{Groups} = { };
3790             # fill in default groups
3791 39102         78732 foreach (0..2) {
3792 117306 100 50     464269 $$groups{$_} = $$tagTablePtr{GROUPS}{$_} || '' unless $$groups{$_};
3793             }
3794             # set flag indicating group list was built
3795 39102         90459 $$tagInfo{GotGroups} = 1;
3796             }
3797 204492 100 100     600929 if (defined $family and $family ne '-1') {
3798 103156 100       245518 if ($family =~ /[^\d]/) {
3799 2736         9704 @families = ($family =~ /\d+/g);
3800 2736 50 0     5473 return($$ex{G0} || $$groups{0}) unless @families;
3801 2736 50       5809 $simplify = 1 unless $family =~ /^:/;
3802 2736         4342 undef $family;
3803 2736         5087 foreach (0..2) { $groups[$_] = $$groups{$_}; }
  8208         19141  
3804 2736 50 33     6388 $noID = 1 if @families == 1 and $families[0] != 7;
3805             } else {
3806 100420 100 66     532549 return($$ex{"G$family"} || $$groups{$family}) if $family == 0 or $family == 2;
      100        
3807 30727         81703 $groups[1] = $$groups{1};
3808             }
3809             } else {
3810 101336 100 33     191897 return($$ex{G0} || $$groups{0}) unless wantarray;
3811 100956         191441 foreach (0..2) { $groups[$_] = $$groups{$_}; }
  302868         691269  
3812             }
3813 134419         215354 $groups[3] = 'Main';
3814 134419 100 66     416055 $groups[4] = ($tag =~ /\((\d+)\)$/ and $1 ne '0') ? "Copy$1" : '';
3815             # handle dynamic group names if necessary
3816 134419 100       271944 unless ($byTagInfo) {
3817 48500 100       104891 $groups[0] = $$ex{G0} if $$ex{G0};
3818 48500 100       122786 $groups[1] = $$ex{G1} =~ /^\+(.*)/ ? "$groups[1]$1" : $$ex{G1} if $$ex{G1};
    100          
3819 48500 100       95329 $groups[3] = 'Doc' . $$ex{G3} if $$ex{G3};
3820 48500 100 66     98261 $groups[5] = $$ex{G5} || $groups[1] if defined $$ex{G5};
3821 48500 50       92971 if (defined $$ex{G6}) {
3822 0 0       0 $groups[5] = '' unless defined $groups[5]; # (can't leave a hole in the array)
3823 0         0 $groups[6] = $$ex{G6};
3824             }
3825 48500 100       91303 if ($$ex{G8}) {
3826 16         43 $groups[7] = '';
3827 16         38 $groups[8] = $$ex{G8};
3828             }
3829             # generate tag ID group names unless obviously not needed
3830 48500 50       91959 unless ($noID) {
3831 48500   100     173277 my $id = $$tagInfo{KeysID} || $$tagInfo{TagID};
3832 48500 100       173995 if (not defined $id) {
    100          
3833 2         3 $id = ''; # (just to be safe)
3834             } elsif ($id =~ /^\d+$/) {
3835 30251 50       83713 $id = sprintf('0x%x', $id) if $$self{OPTIONS}{HexTagIDs};
3836             } else {
3837 18247         46051 $id =~ s/([^-_A-Za-z0-9])/sprintf('%.2x',ord $1)/ge;
  1510         7688  
3838             }
3839 48500         93162 $groups[7] = 'ID-' . $id;
3840 48500   100     186726 defined $groups[$_] or $groups[$_] = '' foreach (5,6);
3841             }
3842             }
3843 134419 100       259788 if ($family) {
3844 49213 100 50     227740 return $groups[$family] || '' if $family > 0;
3845             # add additional matching group names to list
3846             # eg) for MIE-Doc, also add MIE1, MIE1-Doc, MIE-Doc1 and MIE1-Doc1
3847             # and for MIE2-Doc3, also add MIE2, MIE-Doc3, MIE2-Doc and MIE-Doc
3848 18486 100       43070 if ($groups[1] =~ /^MIE(\d*)-(.+?)(\d*)$/) {
3849 42   50     280 push @groups, 'MIE' . ($1 || '1');
3850 42 50       288 push @groups, 'MIE' . ($1 ? '' : '1') . "-$2$3";
3851 42 50       201 push @groups, "MIE$1-$2" . ($3 ? '' : '1');
3852 42 50       298 push @groups, 'MIE' . ($1 ? '' : '1') . "-$2" . ($3 ? '' : '1');
    50          
3853             }
3854             }
3855 103692 100       197799 if (@families) {
3856 2736         3705 my @grps;
3857             # create list of group names (without identical adjacent groups if simplifying)
3858 2736         4247 foreach (@families) {
3859 5472         9463 my $grp = $groups[$_];
3860 5472 50       9974 unless ($grp) {
3861 0 0       0 next if $simplify;
3862 0         0 $grp = '';
3863             }
3864 5472 100 66     23048 push @grps, $grp unless $simplify and @grps and $grp eq $grps[-1];
      100        
3865             }
3866             # remove leading "Main:" if simplifying
3867 2736 50 66     12086 shift @grps if $simplify and @grps > 1 and $grps[0] eq 'Main';
      66        
3868             # return colon-separated string of group names
3869 2736         12665 return join ':', @grps;
3870             }
3871 100956         468878 return @groups;
3872             }
3873              
3874             #------------------------------------------------------------------------------
3875             # Get group names for specified tags
3876             # Inputs: 0) ExifTool object reference
3877             # 1) [optional] information hash reference (default all extracted info)
3878             # 2) [optional] group family (default 0)
3879             # Returns: List of group names in alphabetical order
3880             sub GetGroups($;$$)
3881             {
3882 3     3 1 25 local $_;
3883 3         8 my $self = shift;
3884 3         5 my $info = shift;
3885 3         6 my $family;
3886              
3887             # figure out our arguments
3888 3 100       10 if (ref $info ne 'HASH') {
3889 2         5 $family = $info;
3890 2         5 $info = $$self{VALUE};
3891             } else {
3892 1         3 $family = shift;
3893             }
3894 3 50       9 $family = 0 unless defined $family;
3895              
3896             # get a list of all groups in specified information
3897 3         7 my ($tag, %groups);
3898 3         61 foreach $tag (keys %$info) {
3899 383         556 $groups{ $self->GetGroup($tag, $family) } = 1;
3900             }
3901 3         80 return sort keys %groups;
3902             }
3903              
3904             #------------------------------------------------------------------------------
3905             # Set priority for group where new values are written
3906             # Inputs: 0) ExifTool object reference,
3907             # 1-N) group names (reset to default if no groups specified)
3908             # - used when new tag values are set (ie. before files are written)
3909             sub SetNewGroups($;@)
3910             {
3911 508     508 1 1190 local $_;
3912 508         2810 my ($self, @groups) = @_;
3913 508 50       1956 @groups or @groups = @defaultWriteGroups;
3914 508         1350 my $count = @groups * 10;
3915 508         1113 my %priority;
3916 508         1301 foreach (@groups) {
3917 4572         10267 $priority{lc($_)} = $count;
3918 4572         6859 $count -= 10;
3919             }
3920 508         1585 $priority{file} = 500; # 'File' group is always written (Comment)
3921 508         1593 $priority{composite} = 500; # 'Composite' group is always written
3922             # set write priority (higher # is higher priority)
3923 508         1877 $$self{WRITE_PRIORITY} = \%priority;
3924 508         2142 $$self{WRITE_GROUPS} = \@groups;
3925             }
3926              
3927             #------------------------------------------------------------------------------
3928             # Build Composite tags from Require'd/Desire'd tags
3929             # Inputs: 0) ExifTool object reference, 1) flag to build only tags that require
3930             # tags from alternate files (without this, these tags are ignored)
3931             # Note: Tag values are calculated in alphabetical order unless a tag Require's
3932             # or Desire's another Composite tag, in which case the calculation is
3933             # deferred until after the other tag is calculated.
3934             sub BuildCompositeTags($)
3935             {
3936 541     541 1 1098 local $_;
3937 541         1655 my ($self, $altOnly) = @_;
3938              
3939 541         2020 $$self{BuildingComposite} = 1;
3940              
3941 541         1982 my $compTable = GetTagTable('Image::ExifTool::Composite');
3942 541         39001 my @tagList = sort keys %$compTable;
3943 541         3702 my $rawValue = $$self{VALUE};
3944 541         1572 my $compKeys = $$self{COMP_KEYS};
3945 541         1416 my (%cache, $allBuilt);
3946              
3947 541         1065 for (;;) {
3948 2363         4654 my (%notBuilt, $tag, @deferredTags);
3949 2363         5352 foreach (@tagList) {
3950 47597 100       168400 $notBuilt{$$compTable{$_}{Name}} = 1 unless $specialTags{$_};
3951             }
3952             COMPOSITE_TAG:
3953 2363         4746 foreach $tag (@tagList) {
3954 47597 100       113898 next if $specialTags{$tag};
3955 44351         112803 my $tagInfo = $self->GetTagInfo($compTable, $tag);
3956 44351 100       85986 next unless $tagInfo;
3957 44088         86803 my $tagName = $$compTable{$tag}{Name};
3958             # put required tags into array and make sure they all exist
3959 44088   100     111452 my $subDoc = ($$tagInfo{SubDoc} and $$self{DOC_COUNT});
3960 44088   100     111039 my $require = $$tagInfo{Require} || { };
3961 44088   100     117733 my $desire = $$tagInfo{Desire} || { };
3962 44088   100     121703 my $inhibit = $$tagInfo{Inhibit} || { };
3963             # loop through sub-documents if necessary
3964 44088         62344 my $docNum = 0;
3965 44088         58414 for (;;) {
3966 44088         64442 my (%tagKey, $found, $index, $requireAlt);
3967             # save Require'd and Desire'd tag values in list
3968 44088         64335 for ($index=0; ; ++$index) {
3969 103001   100     337281 my $reqTag = $$require{$index} || $$desire{$index} || $$inhibit{$index};
3970 103001 100       183270 unless ($reqTag) {
3971             # allow Composite with no Require'd or Desire'd tags
3972 9508 50       19918 $found = 1 if $index == 0;
3973 9508         16516 last;
3974             }
3975 93493 100 66     364126 if ($subDoc) {
    100          
    100          
3976             # handle SubDoc tags specially to cache tag keys for faster
3977             # processing when there are a large number of sub-documents
3978             # - get document number from the tag groups if specified,
3979             # otherwise we are looping through all documents for this tag
3980 304 50 0     928 my $doc = $reqTag =~ s/\b(Main|Doc(\d+)):// ? ($2 || 0) : $docNum;
3981             # make fast lookup for keys of this tag with specified groups other than doc group
3982             # (similar to code in InsertTagValues(), but this is case-sensitive)
3983 304         584 my $cacheTag = $cache{$reqTag};
3984 304 50       650 unless ($cacheTag) {
3985 304         896 $cacheTag = $cache{$reqTag} = [ ];
3986 304         498 my $reqGroup;
3987 304 50       1762 $reqTag =~ s/^(.*):// and $reqGroup = $1;
3988 304         557 my ($i, $key, @keys);
3989             # build list of tag keys in order of precedence
3990 304   50     1285 for ($key=$reqTag, $i=$$self{DUPL_TAG}{$reqTag} || 0; ; --$i) {
3991 304 50       781 push @keys, $key if defined $$rawValue{$key};
3992 304 50       760 last if $i <= 0;
3993 0         0 $key = "$reqTag ($i)";
3994             }
3995 304 50       1118 @keys = $self->GroupMatches($reqGroup, \@keys) if defined $reqGroup;
3996             # loop through tags in reverse order of precedence so the higher
3997             # priority tag will win in the case of duplicates within a doc
3998 304   0     638 $$cacheTag[$$self{TAG_EXTRA}{$_}{G3} || 0] = $_ foreach reverse @keys;
3999             }
4000             # (set $reqTag to a bogus key if not found)
4001 304   33     1247 $reqTag = $$cacheTag[$doc] || "$reqTag (0)";
4002             } elsif ($reqTag =~ /^(.*):(.+)/) {
4003 29583         86882 my ($reqGroup, $name) = ($1, $2);
4004 29583 100 100     71337 if ($reqGroup eq 'Composite' and $notBuilt{$name}) {
4005             # defer only until all other tags are built if
4006             # we are inhibiting based on another Composite tag
4007 2238 100 100     9301 unless ($$inhibit{$index} and $allBuilt) {
4008 1767         4339 push @deferredTags, $tag;
4009 1767         8355 next COMPOSITE_TAG;
4010             }
4011             }
4012 27816         41254 my ($i, $key, @keys, $altFile);
4013 27816         38981 my $et = $self;
4014             # get tags from alternate file if a family 8 group was specified
4015 27816 100 100     94120 if ($reqTag =~ /\b(File\d+):/i and $$self{ALT_EXIFTOOL}{$1}) {
4016 2         9 $et = $$self{ALT_EXIFTOOL}{$1};
4017 2         7 $altFile = $1;
4018             # set flags indicating we require tags from alternate files
4019 2         7 $$self{DoAltComposite} = $requireAlt = 1;
4020             }
4021             # (CAREFUL! keys may not be sequential if one was deleted)
4022 27816   100     100018 for ($key=$name, $i=$$et{DUPL_TAG}{$name} || 0; ; --$i) {
4023 28522 100       74467 push @keys, $key if defined $$et{VALUE}{$key};
4024 28522 100       60022 last if $i <= 0;
4025 706         2005 $key = "$name ($i)";
4026             }
4027             # make sure the necessary information is available from the alternate file
4028 27816 100       52849 $self->CopyAltInfo($altFile, \@keys) if $altFile;
4029             # find first matching tag
4030 27816         71451 $key = $self->GroupMatches($reqGroup, \@keys);
4031 27816   66     99201 $reqTag = $key || "$name (0)";
4032             } elsif ($notBuilt{$reqTag} and not $$inhibit{$index}) {
4033             # calculate this tag later if it relies on another
4034             # Composite tag which hasn't been calculated yet
4035 5241         10653 push @deferredTags, $tag;
4036 5241         18651 next COMPOSITE_TAG;
4037             }
4038 86485 100       217586 if (defined $$rawValue{$reqTag}) {
    100          
4039 17030 100       29570 if ($$inhibit{$index}) {
4040 71         178 $found = 0;
4041 71         164 last;
4042             } else {
4043 16959         23962 $found = 1;
4044             }
4045             } elsif ($$require{$index}) {
4046 27501         38368 $found = 0;
4047 27501         43288 last; # don't continue since we require this tag
4048             }
4049 58913         135174 $tagKey{$index} = $reqTag;
4050             }
4051             # stop now if this requires alternate tags and we aren't building them
4052 37080 100 100     114476 last if $requireAlt xor $altOnly;
4053 37007 50       98003 if ($docNum) {
    100          
    100          
4054 0 0       0 if ($found) {
4055 0         0 $$self{DOC_NUM} = $docNum;
4056             # save pointers to all used tag keys
4057 0         0 foreach (keys %tagKey) {
4058 0 0       0 $$compKeys{$_} or $$compKeys{$_} = [ ];
4059 0         0 push @{$$compKeys{$tagKey{$_}}}, [ \%tagKey, $_ ];
  0         0  
4060             }
4061 0         0 $self->FoundTag($tagInfo, \%tagKey);
4062 0         0 delete $$self{DOC_NUM};
4063             }
4064 0 0       0 next if ++$docNum <= $$self{DOC_COUNT};
4065 0         0 last;
4066             } elsif ($found) {
4067 5513         12122 delete $notBuilt{$tagName}; # this tag is OK to build now
4068             # keep track of all Require'd tag keys
4069 5513         21185 foreach (keys %tagKey) {
4070             # only tag keys with same name as a Composite tag
4071             # can be replaced (also eliminates keys with
4072             # instance numbers which can't be replaced either)
4073 24355 100       58727 next unless $compositeID{$tagKey{$_}};
4074             }
4075             # save pointers to all used tag keys
4076 5513         14753 foreach (keys %tagKey) {
4077 24355 100       53234 $$compKeys{$_} or $$compKeys{$_} = [ ];
4078 24355         31170 push @{$$compKeys{$tagKey{$_}}}, [ \%tagKey, $_ ];
  24355         97574  
4079             }
4080             # save reference to tag key lookup as value for Composite tag
4081 5513         20849 my $key = $self->FoundTag($tagInfo, \%tagKey);
4082             } elsif (not defined $found) {
4083 3965         9148 delete $notBuilt{$tagName}; # tag can't be built anyway
4084             }
4085 37007 100       126846 last unless $subDoc;
4086             # don't process sub-documents if there is no chance to build this tag
4087             # (can be very time-consuming if there are many docs)
4088 208 100       505 if (%$require) {
4089 176         506 foreach (keys %$require) {
4090 176         390 my $reqTag = $$require{$_};
4091 176         739 $reqTag =~ s/.*://;
4092 176 50       933 next COMPOSITE_TAG unless defined $$rawValue{$reqTag};
4093             }
4094 0         0 $docNum = 1; # go ahead and process the 1st sub-document
4095             } else {
4096 32 50       719 my @try = ref $$tagInfo{SubDoc} ? @{$$tagInfo{SubDoc}} : keys %$desire;
  32         130  
4097             # at least one of the specified desire tags must exist
4098 32         90 foreach (@try) {
4099 64 50       244 my $desTag = $$desire{$_} or next;
4100 64         332 $desTag =~ s/.*://;
4101 64 50       227 defined $$rawValue{$desTag} and $docNum = 1, last;
4102             }
4103 32 50       239 last unless $docNum;
4104             }
4105             }
4106             }
4107 2363 100       6924 last unless @deferredTags;
4108 1822 100       4797 if (@deferredTags == @tagList) {
4109 471 50       1719 if ($allBuilt) {
4110             # everything was deferred in the last pass,
4111             # must be a circular dependency
4112 0         0 warn "Circular dependency in Composite tags\n";
4113 0         0 last;
4114             }
4115 471         1022 $allBuilt = 1; # try once more, ignoring Composite Inhibit tags
4116             }
4117 1822         17663 @tagList = @deferredTags; # calculate deferred tags now
4118             }
4119 541         3042 delete $$self{BuildingComposite};
4120             }
4121              
4122             #------------------------------------------------------------------------------
4123             # Get reference to Composite tag info hash
4124             # Inputs: 0) case-sensitive Composite tag name
4125             # Returns: tagInfo hash or undef
4126             sub GetCompositeTagInfo($)
4127             {
4128 11     11 0 33 my $tag = shift;
4129 11 50       74 return undef unless $compositeID{$tag};
4130 11         70 return $Image::ExifTool::Composite{$compositeID{$tag}[0]};
4131             }
4132              
4133             #------------------------------------------------------------------------------
4134             # Return List ExifTool API options
4135             # Returns: 0) reference to list of available options -- each entry is a list
4136             # [0=option name, 1=default value, 2=description]
4137             sub AvailableOptions()
4138             {
4139 0     0 1 0 return \@availableOptions;
4140             }
4141              
4142             #------------------------------------------------------------------------------
4143             # Get tag name (removes copy index)
4144             # Inputs: 0) Tag key
4145             # Returns: Tag name
4146             sub GetTagName($)
4147             {
4148 17418     17418 1 25089 local $_;
4149 17418         43688 $_[0] =~ /^(\S+)/;
4150 17418         52820 return $1;
4151             }
4152              
4153             #------------------------------------------------------------------------------
4154             # Get list of shortcuts
4155             # Returns: Shortcut list (sorted alphabetically)
4156             sub GetShortcuts()
4157             {
4158 0     0 1 0 local $_;
4159 0         0 require Image::ExifTool::Shortcuts;
4160 0         0 return sort keys %Image::ExifTool::Shortcuts::Main;
4161             }
4162              
4163             #------------------------------------------------------------------------------
4164             # Get file type for specified extension
4165             # Inputs: 0) file name or extension (case is not significant),
4166             # or FileType value if a description is requested
4167             # 1) flag to return long description instead of type ('0' to return any recognized type)
4168             # Returns: File type (or desc) or undef if extension not supported or if
4169             # description is the same as the input FileType. In list context,
4170             # may return more than one file type if the file may be different formats.
4171             # Returns list of all supported extensions if no file specified
4172             sub GetFileType(;$$)
4173             {
4174 1010     1010 1 2509 local $_;
4175 1010         2947 my ($file, $desc) = @_;
4176 1010 50       3039 unless (defined $file) {
4177 0         0 my @types;
4178 0 0 0     0 if (defined $desc and $desc eq '0') {
4179             # return all recognized types
4180 0         0 @types = sort keys %fileTypeLookup;
4181             } else {
4182             # return all supported types
4183 0         0 foreach (sort keys %fileTypeLookup) {
4184 0         0 my $module = $moduleName{$_};
4185 0 0       0 $module = $moduleName{$fileTypeLookup{$_}} unless defined $module;
4186 0 0 0     0 push @types, $_ unless defined $module and $module eq '0';
4187             }
4188             }
4189 0         0 return @types;
4190             }
4191 1010         2143 my ($fileType, $subType);
4192 1010         2392 my $fileExt = GetFileExtension($file);
4193 1010 100       3886 unless ($fileExt) {
4194 73 50       363 if ($file =~ s/ \((.*)\)$//) {
4195 0         0 $subType = $1;
4196 0         0 $fileExt = GetFileExtension($file);
4197             }
4198 73 50       304 $fileExt = uc($file) unless $fileExt;
4199             }
4200 1010 100       4638 $fileExt and $fileType = $fileTypeLookup{$fileExt}; # look up the file type
4201 1010   100     6512 $fileType = $fileTypeLookup{$fileType} while $fileType and not ref $fileType;
4202             # return description if specified
4203             # (allow input $file to be a FileType for this purpose)
4204 1010 50 33     7673 if ($desc) {
    100 66        
4205 0 0       0 if ($fileType) {
4206 0 0 0     0 if ($static_vars{OverrideFileDescription} and $static_vars{OverrideFileDescription}{$fileExt}) {
4207 0         0 $desc = $static_vars{OverrideFileDescription}{$fileExt};
4208             } else {
4209 0         0 $desc = $$fileType[1];
4210             }
4211             } else {
4212 0   0     0 $desc = $fileDescription{$file} || $file;
4213             }
4214 0 0       0 $desc .= ", $subType" if $subType;
4215 0         0 return $desc;
4216             } elsif ($fileType and (not defined $desc or $desc ne '0')) {
4217             # return only supported file types
4218 955         4266 my $mod = $moduleName{$$fileType[0]};
4219 955 50 66     5210 undef $fileType if defined $mod and $mod eq '0';
4220             }
4221 1010 100       3364 $fileType or return ();
4222 955         2274 $fileType = $$fileType[0]; # get file type (or list of types)
4223 955 100       3256 if (wantarray) {
    50          
4224 716 100       2391 return @$fileType if ref $fileType eq 'ARRAY';
4225             } elsif ($fileType) {
4226 239 50       915 $fileType = $fileExt if ref $fileType eq 'ARRAY';
4227             }
4228 951         3334 return $fileType;
4229             }
4230              
4231             #------------------------------------------------------------------------------
4232             # Return true if we can write the specified file type
4233             # Inputs: 0) file name or ext
4234             # Returns: true if writable, 0 if not writable, '' if not writable due to extension,
4235             # undef if unrecognized
4236             sub CanWrite($)
4237             {
4238 0     0 1 0 local $_;
4239 0 0       0 my $file = shift or return undef;
4240 0 0       0 my ($type) = GetFileType($file) or return undef;
4241 0 0       0 if ($noWriteFile{$type}) {
4242             # can't write TIFF files with certain extensions (various RAW formats)
4243 0   0     0 my $ext = GetFileExtension($file) || uc($file);
4244 0 0       0 return grep(/^$ext$/, @{$noWriteFile{$type}}) ? '' : 1 if $ext;
  0 0       0  
4245             }
4246 0 0       0 if ($onlyWriteFile{$type}) {
4247 0   0     0 my $ext = GetFileExtension($file) || uc($file);
4248 0 0       0 return grep(/^$ext$/, @{$onlyWriteFile{$type}}) ? 1 : 0 if $ext;
  0 0       0  
4249             }
4250 0 0       0 unless (%writeTypes) {
4251 0         0 $writeTypes{$_} = 1 foreach @writeTypes;
4252             }
4253 0         0 return $writeTypes{$type};
4254             }
4255              
4256             #------------------------------------------------------------------------------
4257             # Return true if we can create the specified file type
4258             # Inputs: 0) file name or ext
4259             # Returns: true if creatable, 0 if not writable, undef if unrecognized
4260             sub CanCreate($)
4261             {
4262 24     24 1 85 local $_;
4263 24 50       113 my $file = shift or return undef;
4264 24   33     73 my $ext = GetFileExtension($file) || uc($file);
4265 24 50       105 my $type = GetFileType($file) or return undef;
4266 24 50 33     219 return 1 if $createTypes{$ext} or $createTypes{$type};
4267 0         0 return 0;
4268             }
4269              
4270             #------------------------------------------------------------------------------
4271             # Return list of ordered keys if available, otherwise just sort alphabetically
4272             # Inputs: 0) hash ref
4273             # Returns: List of ordered/sorted keys
4274             sub OrderedKeys($)
4275             {
4276 357     357 1 1865 my $hash = shift;
4277 357 100       1666 return $$hash{_ordered_keys_} ? @{$$hash{_ordered_keys_}} : sort keys %$hash;
  111         412  
4278             }
4279              
4280             #==============================================================================
4281             # Functions below this are not part of the public API
4282              
4283             # Initialize member variables before reading or writing a new file
4284             # Inputs: 0) ExifTool object reference
4285             sub Init($)
4286             {
4287 818     818 0 1920 local $_;
4288 818         2027 my $self = shift;
4289             # delete all DataMember variables (lower-case names)
4290 818         25644 delete $$self{$_} foreach grep /[a-z]/, keys %$self;
4291             # reset static variables
4292             %static_vars = (
4293             KeepUTCTime => $$self{OPTIONS}{KeepUTCTime},
4294             SystemTimeRes => $$self{OPTIONS}{SystemTimeRes},
4295 818         7255 );
4296 818         2602 delete $$self{FOUND_TAGS}; # list of found tags
4297 818         1993 delete $$self{EXIF_DATA}; # the EXIF data block
4298 818         2000 delete $$self{EXIF_POS}; # EXIF position in file
4299 818         1726 delete $$self{FIRST_EXIF_POS}; # position of first EXIF in file
4300 818         1861 delete $$self{HTML_DUMP}; # html dump information
4301 818         1731 delete $$self{SET_GROUP0}; # group0 name override
4302 818         1607 delete $$self{SET_GROUP1}; # group1 name override
4303 818         1631 delete $$self{DOC_NUM}; # current embedded document number
4304 818         2425 $$self{DOC_COUNT} = 0; # count of embedded documents processed
4305 818         2323 $$self{BASE} = 0; # base for offsets from start of file
4306 818         5544 $$self{FILE_ORDER} = { }; # * hash of tag order in file ('*' = based on tag key)
4307 818         6010 $$self{VALUE} = { }; # * hash of raw tag values
4308 818         2708 $$self{BOTH} = { }; # * hash for Value/PrintConv values of Require'd tags
4309 818         4986 $$self{TAG_INFO} = { }; # * hash of tag information
4310 818         8143 $$self{TAG_EXTRA} = { }; # * hash of extra tag information (dynamic group names)
4311 818         2987 $$self{PRIORITY} = { }; # * priority of current tags
4312 818         2422 $$self{LIST_TAGS} = { }; # hash of tagInfo refs for active List-type tags
4313 818         3445 $$self{PROCESSED} = { }; # hash of processed directory start positions
4314 818         2558 $$self{DIR_COUNT} = { }; # count various types of directories
4315 818         2566 $$self{DUPL_TAG} = { }; # last-used index for duplicate-tag keys
4316 818         2258 $$self{WAS_WARNED} = { }; # number of times each warning was issued
4317 818         2449 $$self{WRITTEN} = { }; # list of tags written (selected tags only)
4318 818         2225 $$self{FORCE_WRITE}= { }; # ForceWrite lookup (set from ForceWrite tag)
4319 818         2785 $$self{FOUND_DIR} = { }; # hash of directory names found in file
4320 818         7743 $$self{COMP_KEYS} = { }; # lookup for tag keys used in Composite tags
4321 818         2418 $$self{PATH} = [ ]; # current subdirectory path in file when reading
4322 818         2158 $$self{NUM_FOUND} = 0; # total number of tags found (incl. duplicates)
4323 818         1925 $$self{CHANGED} = 0; # number of tags changed (writer only)
4324 818         2229 $$self{INDENT} = ' '; # initial indent for verbose messages
4325 818         2112 $$self{PRIORITY_DIR} = ''; # the priority directory name
4326 818         3887 $$self{LOW_PRIORITY_DIR} = { PreviewIFD => 1 }; # names of priority 0 directories
4327 818         2354 $$self{TIFF_TYPE} = ''; # type of TIFF data (APP1, TIFF, NEF, etc...)
4328 818         2214 $$self{FMT_EXPR} = undef; # current advanced formatting expression
4329 818         2151 $$self{HAS_DOC} = { }; # lookup for all document numbers in this file
4330 818         2999 $$self{Make} = ''; # camera make
4331 818         2434 $$self{Model} = ''; # camera model
4332 818         2373 $$self{CameraType} = ''; # Olympus camera type
4333 818         2148 $$self{FileType} = ''; # identified file type
4334 818 50       3309 if ($self->Options('HtmlDump')) {
4335 0         0 require Image::ExifTool::HtmlDump;
4336 0         0 $$self{HTML_DUMP} = Image::ExifTool::HtmlDump->new;
4337             }
4338             # make sure our TextOut is a file reference
4339 818 50       3942 $$self{OPTIONS}{TextOut} = \*STDOUT unless ref $$self{OPTIONS}{TextOut};
4340             }
4341              
4342             #------------------------------------------------------------------------------
4343             # Combine information from a list of info hashes
4344             # Unless Duplicates is enabled, first entry found takes priority
4345             # Inputs: 0) ExifTool object reference, 1-N) list of info hash references
4346             # Returns: Combined information hash reference
4347             sub CombineInfo($;@)
4348             {
4349 2     2 0 2270 local $_;
4350 2         5 my $self = shift;
4351 2         4 my (%combinedInfo, $info, $tag, %haveInfo);
4352              
4353 2 50       10 if ($$self{OPTIONS}{Duplicates}) {
4354 0         0 while ($info = shift) {
4355 0         0 foreach $tag (keys %$info) {
4356 0         0 $combinedInfo{$tag} = $$info{$tag};
4357             }
4358             }
4359             } else {
4360 2         8 while ($info = shift) {
4361 4         46 foreach $tag (keys %$info) {
4362 266         255 my $tagName = GetTagName($tag);
4363 266 100       334 next if $haveInfo{$tagName};
4364 252         289 $haveInfo{$tagName} = 1;
4365 252         412 $combinedInfo{$tag} = $$info{$tag};
4366             }
4367             }
4368             }
4369 2         39 return \%combinedInfo;
4370             }
4371              
4372             #------------------------------------------------------------------------------
4373             # Finish generating tags after extracting information from a file
4374             # Inputs: 0) ExifTool ref
4375             # Notes: The sequencing here is a bit tricky because tags from the main file
4376             # may be used in the names of alternate files, so we finish generating
4377             # all main file tags first (including all Composite tags which don't
4378             # rely on alternate files) before extracting tags from alternate files,
4379             # then we finish by generating the remaingin Composite tags.
4380             sub DoneExtract($)
4381             {
4382 550     550 0 1277 my $self = shift;
4383             # extract information from alternate files if necessary
4384 550         1292 my ($g8, $altExifTool);
4385 550         1632 my $opts = $$self{OPTIONS};
4386              
4387             # generate ImageDataHash if requested
4388 550 50       3917 if ($$self{ImageDataHash}) {
4389 0         0 my $digest = $$self{ImageDataHash}->hexdigest;
4390             # (don't store empty digest)
4391 0 0 0     0 $self->FoundTag(ImageDataHash => $digest) unless
      0        
4392             $digest eq 'd41d8cd98f00b204e9800998ecf8427e' or
4393             $digest eq 'e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855' or
4394             $digest eq 'cf83e1357eefb8bdf1542850d66d8007d620e4050b5715dc83f4a921d36ce9ce47d0d13c5d85f2b0ff8318d2877eec2f63b931bd47417a81a538327af927da3e';
4395             }
4396             # generate Validate tag if requested
4397 550 100       2028 if ($$opts{Validate}) {
4398 1         14 Image::ExifTool::Validate::FinishValidate($self, $$self{REQ_TAG_LOOKUP}{validate});
4399             }
4400             # generate geolocation tags if requested
4401 550 100       3619 if ($$opts{Geolocation}) {
4402 4         9 my ($arg, @defaults, @tags, $tag, @coord, @ref, @city, $doneCity, $both);
4403 4         11 my $geoOpt = $$opts{Geolocation};
4404 4         38 my @args = split /\s*,\s*/, $$opts{Geolocation};
4405 4         14 foreach $arg (@args) {
4406 8 50       21 lc $arg eq 'both' and $both = 1, next;
4407 8 50       36 $arg !~ s/^\$// and push(@defaults, $arg), next;
4408 0         0 push @tags, $arg; # argument is a tag name
4409             }
4410 4 50       1738 unless (@tags) {
4411             # default tags to read if not specified
4412 4         32 @tags = qw(GPSLatitude GPSLongitude GPSLatitudeRef GPSLongitudeRef
4413             GPSCoordinates LocationShownGPSLatitude LocationShownGPSLongitude
4414             XMP:City State CountryCode Country
4415             IPTC:City Province-State Country-PrimaryLocationCode Country-PrimaryLocationName
4416             LocationShownCity LocationShownProvinceState LocationShownCountryCode LocationShownCountryName);
4417             }
4418             # get information for specified tags
4419 4         44 my $info = $self->GetInfo(\@tags, { PrintConv => 0, Duplicates => 0 }); # (returns tags in proper case)
4420 4         15 $opts = $$self{OPTIONS}; # (necessary because GetInfo changes the OPTIONS hash)
4421 4         10 foreach $tag (@tags) {
4422 76         104 my $val = $$info{$tag};
4423 76 100       129 next unless defined $val;
4424 7         42 $self->VPrint(0, "Found $tag ($val)\n");
4425 7 50       22 if ($tag =~ /Coordinates/) {
4426 0 0 0     0 next if defined $coord[0] and defined $coord[1];
4427 0         0 @coord = split ' ', $val;
4428 0         0 next;
4429             }
4430 7 100       23 my $n = $tag =~ /Latitude/ ? 0 : ($tag =~ /Longitude/ ? 1 : undef);
    100          
4431 7 100       16 if (defined $n) {
4432 4 100       12 if ($tag =~ /Ref$/) {
4433 2 50       9 $ref[$n] = $val unless $ref[$n];
4434             } else {
4435 2 50       6 $coord[$n] = $val unless defined $coord[$n];
4436             }
4437 4         7 next;
4438             }
4439             # handle city tags (save info for first city found)
4440 3 100       69 if ($tag =~ /City/) {
    50          
4441 1 50       4 @city and $doneCity = 1, next;
4442 1         3 push @city, $val;
4443             } elsif (@city) {
4444 2 50       26 push @city, $val unless $doneCity;
4445 2 50       8 next if $doneCity;
4446             }
4447             }
4448 4 100 66     26 if (defined $coord[0] and defined $coord[1]) {
    50          
4449 1 50 33     11 $coord[0] = -$coord[0] if $ref[0] and $coord[0] > 0 and $ref[0] eq 'S';
      33        
4450 1 50 33     9 $coord[1] = -$coord[1] if $ref[1] and $coord[1] > 0 and $ref[1] eq 'W';
      33        
4451 1         14 $arg = join ',', @coord;
4452             } elsif (@city) {
4453 0         0 $arg = join ',', @city;
4454             }
4455 4 100       27 if (not defined $arg) {
4456             # use specified default values if no tags found
4457 3         11 $arg = join ',', @defaults;
4458 3 50       9 undef $arg if $arg eq '1';
4459 3         5 $both = 1; # use 'both' GPS and place names if provided
4460             }
4461 4 50       12 if ($arg) {
4462 4 100       12 $arg .= ',both' if $both;
4463 4         18 $arg = $self->Encode($arg, 'UTF8');
4464 4         31 require Image::ExifTool::Geolocation;
4465 4 50       12 if ($$opts{Verbose}) {
4466 0 0       0 if ($Image::ExifTool::Geolocation::dbInfo) {
4467 0         0 print "Loaded $Image::ExifTool::Geolocation::dbInfo\n";
4468             } else {
4469 0         0 print "Error loading Geolocation.dat\n";
4470             }
4471             }
4472 4         29 local $SIG{'__WARN__'} = \&SetWarning;
4473 4         9 undef $evalWarning;
4474 4         11 $$opts{GeolocMulti} = $$opts{Duplicates};
4475 4         27 $self->VPrint(0, "Geolocation arguments: '${arg}'\n");
4476 4         24 my ($cities, $dist) = Image::ExifTool::Geolocation::Geolocate($arg, $opts);
4477 4         24 delete $$opts{GeolocMulti};
4478 4 50 33     73 if ($cities and (@$cities < 2 or $dist or not $self->Warn('Multiple Geolocation cities are possible',2))) {
    0 33        
4479 4 100       26 $self->FoundTag(GeolocationWarning => 'Search matched '.scalar(@$cities).' cities') if @$cities > 1;
4480 4         9 my $city;
4481 4         12 foreach $city (@$cities) {
4482 5 100       21 $$self{DOC_NUM} = ++$$self{DOC_COUNT} unless $city eq $$cities[0];
4483 5         32 my @geo = Image::ExifTool::Geolocation::GetEntry($city, $$opts{Lang});
4484 5         36 $self->FoundTag(GeolocationCity => $geo[0]);
4485 5 50       31 $self->FoundTag(GeolocationRegion => $geo[1]) if $geo[1];
4486 5 50       21 $self->FoundTag(GeolocationSubregion => $geo[2]) if $geo[2];
4487 5         21 $self->FoundTag(GeolocationCountryCode => $geo[3]);
4488 5 50       27 $self->FoundTag(GeolocationCountry => $geo[4]) if $geo[4];
4489 5 50       27 $self->FoundTag(GeolocationTimeZone => $geo[5]) if $geo[5];
4490 5         32 $self->FoundTag(GeolocationFeatureCode => $geo[6]);
4491 5 100       23 $self->FoundTag(GeolocationFeatureType => $geo[10]) if $geo[10];
4492 5         19 $self->FoundTag(GeolocationPopulation => $geo[7]);
4493 5         25 $self->FoundTag(GeolocationPosition => "$geo[8] $geo[9]");
4494 5 100       19 if ($dist) {
4495 4         20 $self->FoundTag(GeolocationDistance => $$dist[0][0]);
4496 4         18 $self->FoundTag(GeolocationBearing => $$dist[0][1]);
4497 4         11 shift @$dist;
4498             }
4499 5 50       50 last unless $$opts{Duplicates};
4500             }
4501 4         72 delete $$self{DOC_NUM};
4502             } elsif ($evalWarning) {
4503 0         0 $self->Warn(CleanWarning());
4504             }
4505             }
4506             }
4507             # generate tags for user-defined parameters that ended with '#'
4508 550 50       1073 if (%{$$opts{UserParam}}) {
  550         2560  
4509 0         0 my $doMsg = $$opts{Verbose};
4510 0         0 my $table = GetTagTable('Image::ExifTool::UserParam');
4511 0         0 foreach (sort keys %{$$opts{UserParam}}) {
  0         0  
4512 0 0       0 next unless /#$/;
4513 0 0       0 if ($doMsg) {
4514 0         0 $self->VPrint(0, "UserParam tags:\n");
4515 0         0 undef $doMsg;
4516             }
4517 0         0 $self->HandleTag($table, $_, $$opts{UserParam}{$_});
4518             }
4519             }
4520 550 50 66     4455 if ($$opts{Composite} and (not $$opts{FastScan} or $$opts{FastScan} < 5)) {
      100        
4521             # build all composite tags except those requiring tags from alternate files
4522 540         3044 $self->BuildCompositeTags();
4523             }
4524 550         1418 foreach $g8 (sort keys %{$$self{ALT_EXIFTOOL}}) {
  550         3451  
4525 8         53 $altExifTool = $$self{ALT_EXIFTOOL}{$g8};
4526 8 100       42 next if $$altExifTool{DID_EXTRACT}; # avoid extracting twice
4527 6         266 $$altExifTool{OPTIONS} = $$self{OPTIONS};
4528 6         25 $$altExifTool{GLOBAL_TIME_OFFSET} = $$self{GLOBAL_TIME_OFFSET};
4529 6         23 $$altExifTool{REQ_TAG_LOOKUP} = $$self{REQ_TAG_LOOKUP};
4530 6         20 $$altExifTool{ReqTagAlreadySet} = 1;
4531 6         21 my $fileName = $$altExifTool{ALT_FILE};
4532             # allow tags from the main file to be used in the alternate file names
4533             # (eg. -file1 '$originalfilename')
4534 6 50       29 if ($fileName =~ /\$/) {
4535 0         0 my @tags = reverse sort keys %{$$self{VALUE}};
  0         0  
4536 0         0 $fileName = $self->InsertTagValues($fileName, \@tags, 'Warn');
4537 0 0       0 next unless defined $fileName;
4538             }
4539 6         87 $altExifTool->ExtractInfo($fileName);
4540 6         21 my $err = $$altExifTool{VALUE}{Error};
4541 6 50       17 $err and $self->Warn(qq{$err "$fileName"});
4542             # set family 8 group name for all tags
4543 6         13 $$altExifTool{TAG_EXTRA}{$_}{G8} = $g8 foreach keys %{$$altExifTool{VALUE}};
  6         670  
4544             # prepare our sorted list of found tags
4545 6         95 $$altExifTool{FoundTags} = $altExifTool->SetFoundTags();
4546 6         25 $$altExifTool{DID_EXTRACT} = 1;
4547             }
4548             # if necessary, build composite tags that rely on tags from alternate files
4549 550 100       3136 $self->BuildCompositeTags(1) if $$self{DoAltComposite};
4550             }
4551              
4552             #------------------------------------------------------------------------------
4553             # Get tag table name
4554             # Inputs: 0) ExifTool object reference, 1) tag key
4555             # Returns: Table name if available, otherwise ''
4556             sub GetTableName($$)
4557             {
4558 0     0 0 0 my ($self, $tag) = @_;
4559 0 0       0 my $tagInfo = $$self{TAG_INFO}{$tag} or return '';
4560 0         0 return $$tagInfo{Table}{SHORT_NAME};
4561             }
4562              
4563             #------------------------------------------------------------------------------
4564             # Get tag index number
4565             # Inputs: 0) ExifTool object reference, 1) tag key
4566             # Returns: Table index number, or undefined if this tag isn't indexed
4567             sub GetTagIndex($$)
4568             {
4569 0     0 0 0 my ($self, $tag) = @_;
4570 0 0       0 my $tagInfo = $$self{TAG_INFO}{$tag} or return undef;
4571 0         0 return $$tagInfo{Index};
4572             }
4573              
4574             #------------------------------------------------------------------------------
4575             # Find value for specified tag
4576             # Inputs: 0) ExifTool ref, 1) tag name, 2) tag group (family 1)
4577             # Returns: value or undef
4578             sub FindValue($$$)
4579             {
4580 72     72 0 174 my ($et, $tag, $grp) = @_;
4581 72         104 my ($i, $val);
4582 72         113 my $value = $$et{VALUE};
4583 72         108 for ($i=0; ; ++$i) {
4584 144 100       323 my $key = $tag . ($i ? " ($i)" : '');
4585 144 100       366 last unless defined $$value{$key};
4586 142 100       268 if ($et->GetGroup($key, 1) eq $grp) {
4587 70         138 $val = $$value{$key};
4588 70         196 last;
4589             }
4590             }
4591 72         220 return $val;
4592             }
4593              
4594             #------------------------------------------------------------------------------
4595             # Get tag key for next existing tag
4596             # Inputs: 0) ExifTool ref, 1) tag key or case-sensitive tag name
4597             # Returns: Key of next existing tag, or undef if no more
4598             # Notes: This routine is provided for iterating through duplicate tags in the
4599             # ValueConv of Composite tags.
4600             sub NextTagKey($$)
4601             {
4602 23     23 0 87 my ($self, $tag) = @_;
4603 23 50       146 my $i = ($tag =~ s/ \((\d+)\)$//) ? $1 + 1 : 1;
4604 23         90 $tag = "$tag ($i)";
4605 23 50       121 return $tag if defined $$self{VALUE}{$tag};
4606 23         674 return undef;
4607             }
4608              
4609             #------------------------------------------------------------------------------
4610             # Does a string contain valid UTF-8 characters?
4611             # Inputs: 0) string reference, 1) true to allow last character to be truncated
4612             # Returns: 0=regular ASCII, -1=invalid UTF-8, 1=valid UTF-8 with maximum 16-bit
4613             # wide characters, 2=valid UTF-8 requiring 32-bit wide characters
4614             # Notes: Changes current string position
4615             # (see http://www.fileformat.info/info/unicode/utf8.htm for help understanding this)
4616             sub IsUTF8($;$)
4617             {
4618 125     125 0 326 my ($strPt, $trunc) = @_;
4619 125         560 pos($$strPt) = 0; # start at beginning of string
4620 125 100       767 return 0 unless $$strPt =~ /([\x80-\xff])/g;
4621 56         115 my $rtnVal = 1;
4622 56         82 for (;;) {
4623 198         401 my $ch = ord($1);
4624             # minimum lead byte for 2-byte sequence is 0xc2 (overlong sequences
4625             # not allowed), 0xf8-0xfd are restricted by RFC 3629 (no 5 or 6 byte
4626             # sequences), and 0xfe and 0xff are not valid in UTF-8 strings
4627 198 100 100     742 return -1 if $ch < 0xc2 or $ch >= 0xf8;
4628             # determine number of bytes remaining in sequence
4629 153         226 my $n;
4630 153 100       347 if ($ch < 0xe0) {
    50          
4631 75         132 $n = 1;
4632             } elsif ($ch < 0xf0) {
4633 78         128 $n = 2;
4634             } else {
4635 0         0 $n = 3;
4636             # character code is greater than 0xffff if more than 2 extra bytes
4637             # were required in the UTF-8 character
4638 0         0 $rtnVal = 2;
4639             }
4640 153         225 my $pos = pos $$strPt;
4641 153 100       1137 unless ($$strPt =~ /\G([\x80-\xbf]{$n})/g) {
4642 1 50 33     8 return $rtnVal if $trunc and $pos + $n > length $$strPt;
4643 1         6 return -1;
4644             }
4645             # the following is ref https://www.cl.cam.ac.uk/%7Emgk25/ucs/utf8_check.c
4646 152 100       321 if ($n == 2) {
4647 77 50 66     578 return -1 if ($ch == 0xe0 and (ord($1) & 0xe0) == 0x80) or
      33        
      33        
      66        
      33        
      33        
4648             ($ch == 0xed and (ord($1) & 0xe0) == 0xa0) or
4649             ($ch == 0xef and ord($1) == 0xbf and
4650             (ord(substr $1, 1) & 0xfe) == 0xbe);
4651             } else {
4652 75 50 33     448 return -1 if ($ch == 0xf0 and (ord($1) & 0xf0) == 0x80) or
      33        
      33        
      33        
4653             ($ch == 0xf4 and ord($1) > 0x8f) or $ch > 0xf4;
4654             }
4655 152 100       424 last unless $$strPt =~ /([\x80-\xff])/g;
4656             }
4657 10         44 return $rtnVal;
4658             }
4659              
4660             #------------------------------------------------------------------------------
4661             # Split file name into directory and name parts
4662             # Inptus: 0) file name
4663             # Returns: 0) directory, 1) filename
4664             sub SplitFileName($)
4665             {
4666 505     505 0 1199 my $file = shift;
4667 505         1238 my ($dir, $name);
4668 505 50       1372 if (eval { require File::Basename }) {
  505         6133  
4669 505         29940 $dir = File::Basename::dirname($file);
4670 505         13662 $name = File::Basename::basename($file);
4671             } else {
4672 0         0 ($name = $file) =~ tr/\\/\//;
4673             # remove path
4674 0 0       0 if ($name =~ s/(.*)\///) {
4675 0 0       0 $dir = length($1) ? $1 : '/';
4676             } else {
4677 0         0 $dir = '.';
4678             }
4679             }
4680 505         2286 return ($dir, $name);
4681             }
4682              
4683             #------------------------------------------------------------------------------
4684             # Encode file name for calls to system i/o routines
4685             # Inputs: 0) ExifTool ref, 1) file name in CharsetFileName encoding,
4686             # 2) flag to force conversion even if no special characters
4687             # Returns: true if Windows Unicode routines should be used (in which case
4688             # the file name will be encoded as a null-terminated UTF-16LE string)
4689             sub EncodeFileName($$;$)
4690             {
4691 1198     1198 0 3485 my ($self, $file, $force) = @_;
4692 1198 50       3537 return 0 if $file eq '-'; # special case for stdin pipe
4693 1198         2958 my $enc = $$self{OPTIONS}{CharsetFileName};
4694 1198         2186 my $hasSpecialChars;
4695 1198 50       4911 if ($file =~ /[\x80-\xff]/) {
4696 0         0 $hasSpecialChars = 1;
4697 0 0 0     0 if (not $enc and $^O eq 'MSWin32') {
4698 0 0       0 if (IsUTF8(\$file) < 0) {
4699 0 0       0 $self->Warn('FileName encoding must be specified') if not defined $enc;
4700 0         0 return 0;
4701             } else {
4702 0         0 $enc = 'UTF8'; # assume UTF8
4703             }
4704             }
4705             }
4706 1198 50 33     10262 if ($hasSpecialChars or $force or $$self{OPTIONS}{WindowsLongPath} or $$self{OPTIONS}{WindowsWideFile}) {
      33        
      33        
4707 1198 50       3427 $enc or $enc = 'UTF8';
4708 1198 50       5969 if ($^O eq 'MSWin32') {
    50          
4709 0         0 local $SIG{'__WARN__'} = \&SetWarning;
4710 0 0       0 if (eval { require Win32API::File }) {
  0         0  
4711 0 0       0 $file = $self->WindowsLongPath($file) if $$self{OPTIONS}{WindowsLongPath};
4712             # recode as UTF-16LE and add null terminator
4713 0         0 $_[1] = $self->Decode($file, $enc, undef, 'UTF16', 'II') . "\0\0";
4714 0         0 return 1;
4715             }
4716 0         0 $self->Warn('Install Win32API::File for Windows wide/long file name support');
4717             } elsif ($enc ne 'UTF8') {
4718             # recode as UTF-8 for other platforms if necessary
4719 0         0 $_[1] = $self->Decode($file, $enc, undef, 'UTF8');
4720             }
4721             }
4722 1198         4401 return 0;
4723             }
4724              
4725             #------------------------------------------------------------------------------
4726             # Rebuild a path as an absolute long path to be usable in Windows system calls
4727             # Inputs: 0) ExifTool ref, 1) path string (CharsetFileName)
4728             # Returns: normalized long path (CharsetFileName)
4729             # Note: this should only be called for Windows systems
4730             # References:
4731             # - https://learn.microsoft.com/en-us/dotnet/standard/io/file-path-formats
4732             # - https://learn.microsoft.com/en-us/windows/win32/fileio/maximum-file-path-limitation
4733             # GetFullPathName supported by Windows XP and later. It handles:
4734             # full path names EG: c:\foto\sub\abc.jpg
4735             # relative EG: .\abc.jpg, ..\abc.jpg
4736             # full UNC paths EG: \\server\share\abc.jpg
4737             # relative UNC paths EG: .\abc.jpg, ..\abc.jpg
4738             # Dos device paths EG: \\.\c:\fotoabc.jpg
4739             # relative path on other drives EG: z:abc.jpg (working dir on z: z:\foto called from c:\foto)
4740             # Wide chars EG: Chars that need UTF8.
4741             my $k32GetFullPathName;
4742             sub WindowsLongPath($$)
4743             {
4744 0     0 1 0 my ($self, $path) = @_;
4745 0         0 my $debug = $$self{OPTIONS}{Debug};
4746 0         0 my $out = $$self{OPTIONS}{TextOut};
4747 0         0 my $suffix = '';
4748 0         0 my $longPath;
4749              
4750             # remove common suffixes to make cache more effective
4751 0 0       0 if ($path =~ s/(_original|_exiftool_tmp|:Zone\.Identifier)$//) {
4752 0         0 $suffix = $1;
4753 0 0 0     0 if (not length $path or $path =~ m([:./\\]$)) {
4754             # don't remove suffix if it could be the whole file name
4755 0         0 $path .= $suffix;
4756 0         0 $suffix = '';
4757             }
4758             }
4759 0 0 0     0 return $$self{LONG_PATH_OUT}.$suffix if defined $$self{LONG_PATH_IN} and $$self{LONG_PATH_IN} eq $path;
4760              
4761 0 0       0 $debug and print $out "WindowsLongPath input : $path$suffix\n";
4762              
4763 0         0 for (;;) { # (cheap goto)
4764 0         0 ($longPath = $path) =~ tr(/)(\\); # convert slashes to backslashes
4765 0 0       0 last if $longPath =~ /^\\\\\?\\/; # already a device path in the format we want
4766              
4767 0 0       0 unless ($k32GetFullPathName) { # need to import (once) GetFullPathNameW
4768 0 0       0 last if defined $k32GetFullPathName;
4769 0 0       0 unless (eval { require Win32::API }) {
  0         0  
4770 0         0 $self->Warn('Install Win32::API to use WindowsLongPath option');
4771 0         0 last;
4772             }
4773 0         0 $k32GetFullPathName = Win32::API->new('KERNEL32', 'GetFullPathNameW', 'PNPP', 'I');
4774 0 0       0 unless ($k32GetFullPathName) {
4775 0         0 $k32GetFullPathName = 0;
4776 0         0 $self->Warn('Error loading Win32::API GetFullPathNameW');
4777 0         0 last;
4778             }
4779             }
4780 0   0     0 my $enc = $$self{OPTIONS}{CharsetFileName} || 'UTF8';
4781 0         0 my $encPath = $self->Decode($longPath, $enc, undef, 'UTF16', 'II');# need to encode to UTF16
4782 0         0 my $lenReq = $k32GetFullPathName->Call($encPath,0,0,0) + 1; # first pass gets length required, +1 for safety (null?)
4783 0         0 my $fullPath = "\0" x $lenReq x 2; # create buffer to hold full path
4784 0         0 $k32GetFullPathName->Call($encPath, $lenReq, $fullPath, 0); # fullPath is UTF16 now
4785 0         0 $longPath = $self->Decode($fullPath, 'UTF16', 'II', $enc);
4786              
4787 0 0       0 last if length($longPath) <= 247 - length($suffix);
4788              
4789 0 0       0 if ($longPath =~ /^\\\\/) {
4790 0         0 $longPath = '\\\\?\\UNC' . substr($longPath, 1);
4791             } else {
4792 0         0 $longPath = '\\\\?\\' . $longPath;
4793             }
4794 0         0 last;
4795             }
4796             # this may be called repeatedly for the same file file (exists, stat, open),
4797             # so cache the last return value (without any of the suffixes that we use)
4798 0         0 $$self{LONG_PATH_IN} = $path;
4799 0         0 $$self{LONG_PATH_OUT} = $longPath;
4800 0 0       0 $debug and print $out "WindowsLongPath return: $longPath$suffix\n";
4801 0         0 return $longPath . $suffix;
4802             }
4803              
4804             #------------------------------------------------------------------------------
4805             # Modified perl open() routine to properly handle special characters in file names
4806             # Inputs: 0) ExifTool ref, 1) filehandle, 2) filename,
4807             # 3) mode: '<' or undef = read, '>' = write, '+<' = update
4808             # Returns: true on success
4809             # Note: Must call like "$et->Open(\*FH,$file)", not "$et->Open(FH,$file)" to avoid
4810             # "unopened filehandle" errors due to a change in scope of the filehandle
4811             sub Open($*$;$)
4812             {
4813 960     960 0 3574 my ($self, $fh, $file, $mode) = @_;
4814              
4815 960         4130 $file =~ s/^([\s&])/.\/$1/; # protect leading whitespace or ampersand
4816             # default to read mode ('<') unless input is a trusted pipe
4817 960 50 33     5480 $mode = (($file =~ /\|$/ and $$self{TRUST_PIPE}) ? '' : '<') unless $mode;
    100          
4818 960         2575 delete $$self{TRUST_PIPE};
4819 960 50       2792 if ($mode) {
4820 960 50       4145 if ($self->EncodeFileName($file)) {
4821             # handle Windows Unicode file name
4822 0         0 local $SIG{'__WARN__'} = \&SetWarning;
4823 0         0 my ($access, $create);
4824 0 0 0     0 if ($mode eq '>' or $mode eq '>>') {
4825 0         0 eval {
4826 0         0 $access = Win32API::File::GENERIC_WRITE();
4827 0 0       0 if ($mode eq '>>') {
4828 0         0 $access |= Win32API::File::FILE_APPEND_DATA();
4829 0         0 $create = Win32API::File::OPEN_ALWAYS();
4830             } else {
4831 0         0 $create = Win32API::File::CREATE_ALWAYS();
4832             }
4833             }
4834             } else {
4835 0         0 eval {
4836 0         0 $access = Win32API::File::GENERIC_READ();
4837 0 0       0 $access |= Win32API::File::GENERIC_WRITE() if $mode eq '+<'; # update
4838 0         0 $create = Win32API::File::OPEN_EXISTING();
4839             }
4840             }
4841 0         0 my $share = 0;
4842 0         0 eval {
4843 0 0       0 unless ($access & Win32API::File::GENERIC_WRITE()) {
4844 0         0 $share = Win32API::File::FILE_SHARE_READ() | Win32API::File::FILE_SHARE_WRITE();
4845             }
4846             };
4847 0         0 my $wh = eval { Win32API::File::CreateFileW($file, $access, $share, [], $create, 0, []) };
  0         0  
4848 0 0       0 return undef unless $wh;
4849 0         0 my $fd = eval { Win32API::File::OsFHandleOpenFd($wh, 0) };
  0         0  
4850 0 0 0     0 if (not defined $fd or $fd < 0) {
4851 0         0 eval { Win32API::File::CloseHandle($wh) };
  0         0  
4852 0         0 return undef;
4853             }
4854 0         0 $file = "&=$fd"; # specify file by descriptor
4855             } else {
4856             # add leading space to protect against leading characters like '>'
4857             # in file name, and trailing "\0" to protect trailing spaces
4858 960         2611 $file = " $file\0";
4859             }
4860             }
4861 960         102507 return open $fh, "$mode$file";
4862             }
4863              
4864             #------------------------------------------------------------------------------
4865             # Check to see if a file exists (with Windows Unicode support)
4866             # Inputs: 0) ExifTool ref, 1) file name, 2) flag if we are writing this file
4867             # Returns: true if file exists
4868             sub Exists($$;$)
4869             {
4870 231     231 0 859 my ($self, $file, $writing) = @_;
4871              
4872 231 50       964 if ($self->EncodeFileName($file)) {
    50          
4873 0         0 local $SIG{'__WARN__'} = \&SetWarning;
4874 0         0 my $wh = eval { Win32API::File::CreateFileW($file,
  0         0  
4875             Win32API::File::GENERIC_READ(),
4876             Win32API::File::FILE_SHARE_READ(), [],
4877             Win32API::File::OPEN_EXISTING(), 0, []) };
4878 0 0       0 return 0 unless $wh;
4879 0         0 eval { Win32API::File::CloseHandle($wh) };
  0         0  
4880             } elsif ($writing) {
4881             # (named pipes already exist, but we pretend that they don't
4882             # so we will be able to write them, so test for pipe with -p)
4883 231   33     18821 return(-e $file and not -p $file);
4884             } else {
4885 0         0 return(-e $file);
4886             }
4887 0         0 return 1;
4888             }
4889              
4890             #------------------------------------------------------------------------------
4891             # Return true if file is a directory (with Windows Unicode support)
4892             # Inputs: 0) ExifTool ref, 1) file name
4893             # Returns: true if file is a directory (false if file isn't, or doesn't exist)
4894             sub IsDirectory($$)
4895             {
4896 1     1 0 3 my ($et, $file) = @_;
4897 1 50       3 if ($et->EncodeFileName($file)) {
4898 0         0 local $SIG{'__WARN__'} = \&SetWarning;
4899 0         0 my $attrs = eval { Win32API::File::GetFileAttributesW($file) };
  0         0  
4900 0   0     0 my $dirBit = eval { Win32API::File::FILE_ATTRIBUTE_DIRECTORY() } || 0;
4901 0 0 0     0 return 1 if $attrs and $attrs != 0xffffffff and $attrs & $dirBit;
      0        
4902             } else {
4903 1         16 return -d $file;
4904             }
4905 0         0 return 0;
4906             }
4907              
4908             #------------------------------------------------------------------------------
4909             # Create directory for specified file
4910             # Inputs: 0) ExifTool ref, 1) complete file name including path
4911             # Returns: '' = directory created, undef = nothing done, otherwise error string
4912             my $k32CreateDir;
4913             sub CreateDirectory($$)
4914             {
4915 1     1 0 1 local $_;
4916 1         4 my ($self, $file) = @_;
4917 1         2 my ($err, $dir);
4918 1         7 ($dir = $file) =~ s/[^\/]*$//; # remove filename from path specification
4919 1 50 33     7 if ($dir and not $self->IsDirectory($dir)) {
4920 0         0 my @parts = split /\//, $dir;
4921 0         0 $dir = '';
4922 0         0 foreach (@parts) {
4923 0         0 $dir .= $_;
4924 0 0 0     0 if (length and not $self->IsDirectory($dir) and
      0        
      0        
4925             # don't try to create a network drive root directory
4926             not (IsPC() and $dir =~ m{^//[^/]*$}))
4927             {
4928 0         0 my $success;
4929             # create directory since it doesn't exist
4930 0         0 my $d2 = $dir; # (must make a copy in case EncodeFileName recodes it)
4931 0 0       0 if ($self->EncodeFileName($d2)) {
4932             # handle Windows Unicode directory names
4933 0 0       0 unless (defined $k32CreateDir) {
4934 0 0       0 unless (eval { require Win32::API }) {
  0         0  
4935 0         0 $err = 'Install Win32::API to create directories with Unicode names';
4936 0         0 last;
4937             }
4938 0         0 $k32CreateDir = Win32::API->new('KERNEL32', 'CreateDirectoryW', 'PP', 'I');
4939 0 0       0 unless ($k32CreateDir) {
4940 0         0 $k32CreateDir = 0;
4941             # give this error once, then just "Error creating" for subsequent attempts
4942 0         0 return 'Error loading Win32::API CreateDirectoryW';
4943             }
4944             }
4945 0 0       0 $success = $k32CreateDir->Call($d2, 0) if $k32CreateDir;
4946             } else {
4947 0         0 $success = mkdir($d2, 0777);
4948             }
4949 0 0       0 $success or $err = "Error creating directory $dir", last;
4950 0         0 $err = '';
4951             }
4952 0         0 $dir .= '/';
4953             }
4954             }
4955 1         3 return $err;
4956             }
4957              
4958             #------------------------------------------------------------------------------
4959             # Get file times (Unix seconds since the epoch)
4960             # Inputs: 0) ExifTool ref, 1) file name or ref
4961             # Returns: 0) access time, 1) modification time, 2) creation time (or undefs on error)
4962             my $k32GetFileTime;
4963             sub GetFileTime($$)
4964             {
4965 0     0 0 0 my ($self, $file) = @_;
4966              
4967             # open file by name if necessary
4968 0 0       0 unless (ref $file) {
4969 0         0 local *FH;
4970 0 0       0 unless ($self->Open(\*FH, $file)) {
4971 0 0       0 if ($self->IsDirectory($file)) {
4972 0         0 my @rtn = (stat $file)[8, 9, 10];
4973 0 0       0 return @rtn if defined $rtn[0];
4974             }
4975 0         0 $self->Warn("GetFileTime error for '${file}'");
4976 0         0 return ();
4977             }
4978 0         0 $file = *FH; # (not \*FH, so *FH will be kept open until $file goes out of scope)
4979             }
4980             # on Windows, try to work around incorrect file times when daylight saving time is in effect
4981 0 0       0 if ($^O eq 'MSWin32') {
4982 0 0       0 if (not eval { require Win32::API }) {
  0 0       0  
4983 0         0 $self->Warn('Install Win32::API for proper handling of Windows file times', 1);
4984 0         0 } elsif (not eval { require Win32API::File }) {
4985 0         0 $self->Warn('Install Win32API::File for proper handling of Windows file times', 1);
4986             } else {
4987             # get Win32 handle, needed for GetFileTime
4988 0         0 my $win32Handle = eval { Win32API::File::GetOsFHandle($file) };
  0         0  
4989 0 0       0 unless ($win32Handle) {
4990 0         0 $self->Warn("Win32API::File::GetOsFHandle returned invalid handle");
4991 0         0 return ();
4992             }
4993             # get FILETIME structs
4994 0         0 my ($atime, $mtime, $ctime, $time);
4995 0         0 $atime = $mtime = $ctime = pack 'LL', 0, 0;
4996 0 0       0 unless ($k32GetFileTime) {
4997 0 0       0 return () if defined $k32GetFileTime;
4998 0         0 $k32GetFileTime = Win32::API->new('KERNEL32', 'GetFileTime', 'NPPP', 'I');
4999 0 0       0 unless ($k32GetFileTime) {
5000 0         0 $self->Warn('Error loading Win32::API GetFileTime');
5001 0         0 $k32GetFileTime = 0;
5002 0         0 return ();
5003             }
5004             }
5005 0 0       0 unless ($k32GetFileTime->Call($win32Handle, $ctime, $atime, $mtime)) {
5006 0         0 $self->Warn("Win32::API GetFileTime returned " . Win32::GetLastError());
5007 0         0 return ();
5008             }
5009             # convert FILETIME structs to Unix seconds
5010 0         0 foreach $time ($atime, $mtime, $ctime) {
5011 0         0 my ($lo, $hi) = unpack 'LL', $time; # unpack FILETIME struct
5012             # FILETIME is in 100 ns intervals since 0:00 UTC Jan 1, 1601
5013             # (89 leap years between 1601 and 1970)
5014 0         0 $time = ($hi * 4294967296 + $lo) * 1e-7 - (((1970-1601)*365+89)*24*3600);
5015             }
5016 0         0 return ($atime, $mtime, $ctime);
5017             }
5018             }
5019             # other os (or Windows fallback)
5020 0         0 return (stat $file)[8, 9, 10];
5021             }
5022              
5023             #------------------------------------------------------------------------------
5024             # Parse function arguments and set member variables accordingly
5025             # Inputs: Same as ImageInfo()
5026             # - sets REQUESTED_TAGS, REQ_TAG_LOOKUP, IO_TAG_LIST, FILENAME, RAF, OPTIONS
5027             sub ParseArguments($;@)
5028             {
5029 725     725 0 1673 my $self = shift;
5030 725         2224 my $options = $$self{OPTIONS};
5031 725         1549 my @oldGroupOpts = grep /^Group/, keys %{$$self{OPTIONS}};
  725         23089  
5032 725         5219 my (@exclude, $wasExcludeOpt);
5033              
5034 725         2873 $$self{REQUESTED_TAGS} = [ ];
5035 725 100       4411 $$self{REQ_TAG_LOOKUP} = { } unless $$self{ReqTagAlreadySet};
5036 725         2289 $$self{EXCL_TAG_LOOKUP} = { };
5037 725         2009 $$self{IO_TAG_LIST} = undef;
5038 725         1782 delete $$self{EXCL_XMP_LOOKUP};
5039              
5040             # handle our input arguments
5041 725         2639 while (@_) {
5042 1591         3181 my $arg = shift;
5043 1591 100 66     7238 if (ref $arg and not overload::Method($arg, q[""])) {
    100          
5044 171 100 100     6613 if (ref $arg eq 'ARRAY') {
    100          
    100          
    50          
5045 10         35 $$self{IO_TAG_LIST} = $arg;
5046 10         41 foreach (@$arg) {
5047 91 100       177 if (/^-(.*)/) {
5048 2         9 push @exclude, $1;
5049             } else {
5050 89         124 push @{$$self{REQUESTED_TAGS}}, $_;
  89         234  
5051             }
5052             }
5053             } elsif (ref $arg eq 'HASH') {
5054 116         979 my $opt;
5055 116         477 foreach $opt (keys %$arg) {
5056             # a single new group option overrides all old group options
5057 189 100 100     1446 if (@oldGroupOpts and $opt =~ /^Group/) {
5058 28         135 foreach (@oldGroupOpts) {
5059 28         100 delete $$options{$_};
5060             }
5061 28         91 undef @oldGroupOpts;
5062             }
5063 189         888 $self->Options($opt, $$arg{$opt});
5064 189 50       861 $opt eq 'Exclude' and $wasExcludeOpt = 1;
5065             }
5066             } elsif (ref $arg eq 'SCALAR' or UNIVERSAL::isa($arg,'GLOB')) {
5067 26 50       110 next if defined $$self{RAF};
5068             # convert image data from UTF-8 to character stream if necessary
5069             # (patches RHEL 3 UTF8 LANG problem)
5070 26 50 66     336 if (ref $arg eq 'SCALAR' and $] >= 5.006 and ($$self{OPTIONS}{EncodeHangs} or
      33        
      66        
5071             eval { require Encode; Encode::is_utf8($$arg) } or $@))
5072             {
5073 0         0 local $SIG{'__WARN__'} = \&SetWarning;
5074             # repack by hand if Encode isn't available
5075 0 0 0     0 my $buff = ($$self{OPTIONS}{EncodeHangs} or $@) ? pack('C*',unpack($] < 5.010000 ?
    0          
5076             'U0C*' : 'C0C*', $$arg)) : Encode::encode('utf8', $$arg);
5077 0         0 $arg = \$buff;
5078             }
5079 26         253 $$self{RAF} = File::RandomAccess->new($arg);
5080             # set filename to empty string to indicate that
5081             # we have a file but we didn't open it
5082 26         114 $$self{FILENAME} = '';
5083             } elsif (UNIVERSAL::isa($arg, 'File::RandomAccess')) {
5084 19         65 $$self{RAF} = $arg;
5085 19         85 $$self{FILENAME} = '';
5086             } else {
5087 0         0 warn "Don't understand ImageInfo argument $arg\n";
5088             }
5089             } elsif (defined $$self{FILENAME}) {
5090 915 100       2362 if ($arg =~ /^-(.*)/) {
5091 58         308 push @exclude, $1;
5092             } else {
5093 857         1334 push @{$$self{REQUESTED_TAGS}}, $arg;
  857         2862  
5094             }
5095             } else {
5096 505         1871 $$self{FILENAME} = $arg;
5097             }
5098             }
5099             # add additional requested tags to lookup
5100 725 100       2636 if ($$options{RequestTags}) {
5101 46         125 $$self{REQ_TAG_LOOKUP}{$_} = 1 foreach @{$$options{RequestTags}};
  46         333  
5102             }
5103             # expand shortcuts in tag arguments if provided
5104 725 100       1328 if (@{$$self{REQUESTED_TAGS}}) {
  725         2798  
5105 367         2081 ExpandShortcuts($$self{REQUESTED_TAGS});
5106             # initialize lookup for requested tags
5107 367         732 foreach (@{$$self{REQUESTED_TAGS}}) {
  367         1293  
5108 989 50       5027 /^(.*:)?([-\w?*]*)#?$/ or next;
5109 989 50       4934 $$self{REQ_TAG_LOOKUP}{lc($2)} = 1 if $2;
5110 989 100       2787 next unless $1;
5111 255         1622 $$self{REQ_TAG_LOOKUP}{lc($_).':'} = 1 foreach split /:/, $1;
5112             }
5113             }
5114 725 100 66     4580 if (@exclude or $wasExcludeOpt) {
5115             # must add existing excluded tags
5116 45 100       174 push @exclude, @{$$options{Exclude}} if $$options{Exclude};
  1         5  
5117 45         695 $$options{Exclude} = \@exclude;
5118             # expand shortcuts in new exclude list
5119 45         225 ExpandShortcuts($$options{Exclude}, 1); # (also remove '#' suffix)
5120             }
5121             # generate lookup for excluded tags
5122 725 100       3433 if ($$options{Exclude}) {
5123 52         140 foreach (@{$$options{Exclude}}) {
  52         179  
5124 69 100       855 /([-\w]+)#?$/ and $$self{EXCL_TAG_LOOKUP}{lc $1} = 1;
5125 69 50       352 if (/(xmp-.*:[-\w]+)#?/i) {
5126 0 0       0 $$self{EXCL_XMP_LOOKUP} or $$self{EXCL_XMP_LOOKUP} = { };
5127 0         0 $$self{EXCL_XMP_LOOKUP}{lc $1} = 1;
5128             }
5129             }
5130             # exclude list is used only for EXCL_TAG_LOOKUP when TAGS_FROM_FILE is set
5131 52 100       328 undef $$options{Exclude} if $$self{TAGS_FROM_FILE};
5132             }
5133             }
5134              
5135             #------------------------------------------------------------------------------
5136             # Does group name match the tag ID?
5137             # Inputs: 0) tag ID, 1) group name (with "ID-" removed)
5138             # Returns: true on success
5139             sub IsSameID($$)
5140             {
5141 2     2 0 9 my ($id, $grp) = @_;
5142 2         5 for (;;) {
5143 2 100       11 return 1 if $grp eq $id; # decimal ID's or raw ID's
5144 1 50       9 if ($id =~ /^\d+$/) { # numerical numerical ID's may be in hex
5145 0 0 0     0 return 1 if $grp =~ s/^0x0*// and $grp eq sprintf('%x', $id);
5146             } else { # other ID's may conform to ExifTool group name conventions
5147 1         3 my $tmp = $id;
5148 1 50 33     9 return 1 if $tmp =~ s/([^-_A-Za-z0-9])/sprintf('%.2x',ord $1)/ge and $grp eq $tmp;
  1         19  
5149             }
5150 1 50       7 last unless $id =~ s/-.*//; # remove language code if it exists
5151             }
5152 1         6 return 0;
5153             }
5154              
5155             #------------------------------------------------------------------------------
5156             # Get list of tags in specified group
5157             # Inputs: 0) ExifTool ref, 1) group spec (case insensitive), 2) tag key or reference to list of tag keys
5158             # Returns: list of matching tags in list context, or first match in scalar context
5159             # Notes: Group spec may contain multiple groups separated by colons, each
5160             # possibly with a leading family number
5161             sub GroupMatches($$$)
5162             {
5163 28413     28413 0 54754 my ($self, $group, $tagList) = @_;
5164 28413 50       53831 $tagList = [ $tagList ] unless ref $tagList;
5165 28413         40540 my ($tag, @matches);
5166             # check each group name individually (eg. "Author:1IPTC")
5167 28413         68255 my @grps = split ':', $group;
5168 28413         42594 my (@fmys, $g);
5169 28413         65598 for ($g=0; $g<@grps; ++$g) {
5170 29004 50       125709 if ($grps[$g] =~ s/^(\d*)(id-)?//i) {
5171 29004 100       68017 $fmys[$g] = $1 if length $1;
5172 29004 50       64489 if ($2) {
5173 0         0 $fmys[$g] = 7;
5174 0         0 next; # (don't convert tag ID's to lower case)
5175             }
5176             }
5177 29004         57826 $grps[$g] = lc $grps[$g];
5178 29004 50       81989 $grps[$g] = '' if $grps[$g] eq 'copy0'; # accept 'Copy0' for primary tag
5179             }
5180 28413         53679 foreach $tag (@$tagList) {
5181 18486         50340 my @groups = $self->GetGroup($tag, -1);
5182 18486         43104 for ($g=0; $g<@grps; ++$g) {
5183 18951         32615 my $grp = $grps[$g];
5184 18951 50 33     61475 next if $grp eq '*' or $grp eq 'all';
5185 18951         26593 my $f;
5186 18951 100       38208 if (defined($f = $fmys[$g])) {
5187 3 50       13 last unless defined $groups[$f];
5188 3 50       10 if ($f == 7) {
5189 0 0       0 next if IsSameID($self->GetTagID($tag), $grp);
5190             } else {
5191 3 100       13 next if $grp eq lc $groups[$f];
5192             }
5193 1         3 last;
5194             } else {
5195 18948 100       271574 last unless grep /^$grp$/i, @groups;
5196             }
5197             }
5198 18486 100       55138 if ($g == @grps) {
5199 4729 100       16616 return $tag unless wantarray;
5200 2567         7612 push @matches, $tag;
5201             }
5202             }
5203 26251 100       78741 return wantarray ? @matches : $matches[0];
5204             }
5205              
5206             #------------------------------------------------------------------------------
5207             # Remove specified tags from returned tag list, updating indices in other lists
5208             # Inputs: 0) tag list ref, 1) index list ref, 2) index list ref, 3) hash ref,
5209             # 4) true to include tags from hash instead of excluding
5210             # Returns: nothing, but updates input lists
5211             sub RemoveTagsFromList($$$$;$)
5212             {
5213 73     73 0 275 local $_;
5214 73         261 my ($tags, $list1, $list2, $exclude, $inv) = @_;
5215 73         158 my @filteredTags;
5216              
5217 73 100 100     432 if (@$list1 or @$list2) {
5218 6         30 while (@$tags) {
5219 229         492 my $tag = pop @$tags;
5220 229         365 my $i = @$tags;
5221 229 100 50     800 if ($$exclude{$tag} xor $inv) {
5222             # remove index of excluded tag from each list
5223 150 100       342 @$list1 = map { $_ < $i ? $_ : $_ == $i ? () : $_ - 1 } @$list1;
  12 100       37  
5224 150 100       298 @$list2 = map { $_ < $i ? $_ : $_ == $i ? () : $_ - 1 } @$list2;
  8211 100       14101  
5225             } else {
5226 79         253 unshift @filteredTags, $tag;
5227             }
5228             }
5229             } else {
5230 67         213 foreach (@$tags) {
5231 6950 100 100     22396 push @filteredTags, $_ unless $$exclude{$_} xor $inv;
5232             }
5233             }
5234 73         797 $_[0] = \@filteredTags; # update tag list
5235             }
5236              
5237             #------------------------------------------------------------------------------
5238             # Copy tags from alternate input file
5239             # Inputs: 0) ExifTool ref, 1) family 8 group, 2) list ref for tag keys to copy
5240             # - updates tag key list to match keys newly added to $self
5241             sub CopyAltInfo($$$)
5242             {
5243 8     8 0 28 my ($self, $g8, $tags) = @_;
5244 8         22 my ($tag, $vtag);
5245 8 50       62 return unless $g8 =~ /(\d+)/;
5246 8 50       46 my $et = $$self{ALT_EXIFTOOL}{$g8} or return;
5247 8         38 my $altOrder = ($1 + 1) * 100000; # increment file order
5248 8         23 foreach $tag (@$tags) {
5249 9         85 ($vtag = $tag) =~ s/( |$)/ #[$g8]/;
5250 9 100       50 unless (defined $$self{VALUE}{$vtag}) {
5251 8         44 $$self{VALUE}{$vtag} = $$et{VALUE}{$tag};
5252 8         37 $$self{TAG_INFO}{$vtag} = $$et{TAG_INFO}{$tag};
5253 8   50     46 $$self{TAG_EXTRA}{$vtag} = $$et{TAG_EXTRA}{$tag} || { };
5254 8   50     42 $$self{FILE_ORDER}{$vtag} = ($$et{FILE_ORDER}{$tag} || 0) + $altOrder;
5255             }
5256 9         39 $tag = $vtag;
5257             }
5258             }
5259              
5260             #------------------------------------------------------------------------------
5261             # Set list of found tags from previously requested tags
5262             # Inputs: 0) ExifTool object reference
5263             # Returns: 0) Reference to list of found tag keys (in order of requested tags)
5264             # 1) Reference to list of indices for tags requested by value
5265             # 2) Reference to list of indices for tags specified by wildcard or "all"
5266             # Notes: index lists are returned in increasing order
5267             sub SetFoundTags($)
5268             {
5269 720     720 0 1481 local $_;
5270 720         1553 my $self = shift;
5271 720         2110 my $options = $$self{OPTIONS};
5272 720   50     2850 my $reqTags = $$self{REQUESTED_TAGS} || [ ];
5273 720         2302 my $duplicates = $$options{Duplicates};
5274 720         2088 my $exclude = $$options{Exclude};
5275 720         3059 my $fileOrder = $$self{FILE_ORDER};
5276 720         1479 my @groupOptions;
5277             # ignore empty group options
5278 720   100     38729 $$options{$_} and push @groupOptions, $_ foreach sort grep /^Group/, keys %$options;
5279 720   100     6674 my $doDups = $duplicates || $exclude || @groupOptions;
5280 720         2104 my ($tag, $rtnTags, @byValue, @wildTags);
5281              
5282             # only return requested tags if specified
5283 720 100       2739 if (@$reqTags) {
5284 367 50       1430 $rtnTags or $rtnTags = [ ];
5285             # scan through the requested tags and generate a list of tags we found
5286 367         968 my $tagHash = $$self{VALUE};
5287 367         830 my $reqTag;
5288 367         1077 foreach $reqTag (@$reqTags) {
5289 989         2162 my (@matches, $group, $allGrp, $allTag, $byValue, $g8);
5290 989         1889 my $et = $self;
5291 989 100       4208 if ($reqTag =~ /^(.*):(.+)/) {
5292 255         1370 ($group, $tag) = ($1, $2);
5293 255 50       2785 if ($group =~ /^(\*|all)$/i) {
    100          
    50          
5294 0         0 $allGrp = 1;
5295             } elsif ($reqTag =~ /\bfile(\d+):/i) {
5296 6         32 $g8 = "File$1";
5297 6   33     37 $et = $$self{ALT_EXIFTOOL}{$g8} || $self;
5298 6         16 $fileOrder = $$et{FILE_ORDER};
5299 6         20 $tagHash = $$et{VALUE};
5300             } elsif ($group !~ /^[-\w:]*$/) {
5301 0         0 $self->Warn("Invalid group name '${group}'");
5302 0         0 $group = 'invalid';
5303             }
5304             } else {
5305 734         1922 $tag = $reqTag;
5306             }
5307 989 50 66     3286 $byValue = 1 if $tag =~ s/#$// and $$options{PrintConv};
5308 989 100 100     9111 if (defined $$tagHash{$reqTag} and not $doDups) {
    100 100        
    100          
    100          
    50          
5309 6         11 $matches[0] = $tag;
5310             } elsif ($tag =~ /^(\*|all)$/i) {
5311             # tag name of '*' or 'all' matches all tags
5312 164 100 66     761 if ($doDups or $allGrp) {
5313 163         8062 @matches = grep(!/#/, keys %$tagHash);
5314             } else {
5315 1         48 @matches = grep(!/ /, keys %$tagHash);
5316             }
5317 164 50       1253 next unless @matches; # don't want entry in list for '*' tag
5318 164         361 $allTag = 1;
5319             } elsif ($tag =~ /[*?]/) {
5320             # allow wildcards in tag names
5321 9         37 $tag =~ tr/-_A-Za-z0-9*?//dc; # sterilize
5322 9         42 $tag =~ s/\*/[-\\w]*/g;
5323 9         31 $tag =~ s/\?/[-\\w]/g;
5324 9 50 33     51 $tag .= '( \\(.*)?' if $doDups or $allGrp;
5325 9         2883 @matches = grep(/^$tag$/i, keys %$tagHash);
5326 9 50       131 next unless @matches; # don't want entry in list for wildcard tags
5327 9         27 $allTag = 1;
5328             } elsif ($doDups or defined $group) {
5329 748         2098 $tag =~ tr/-_A-Za-z0-9//dc; # sterilize
5330             # must also look for tags like "Tag (1)"
5331             # (but be sure not to match temporary ValueConv entries like "Tag #")
5332 748         87510 @matches = grep(/^$tag( \(|$)/i, keys %$tagHash);
5333             } elsif ($tag =~ /^[-\w]+$/) {
5334             # find first matching value
5335             # (use in list context to return value instead of count)
5336 62         1911 ($matches[0]) = grep /^$tag$/i, keys %$tagHash;
5337 62 50       235 defined $matches[0] or undef @matches;
5338             } else {
5339 0         0 $self->Warn("Invalid tag name '${tag}'");
5340             }
5341 989 100 66     8784 if (defined $group and not $allGrp) {
5342             # keep only specified group
5343 255         1148 @matches = $et->GroupMatches($group, \@matches);
5344 255 100 100     1364 next unless @matches or not $allTag;
5345             }
5346 969 100       3650 if (@matches > 1) {
    100          
5347             # maintain original file order for multiple tags
5348 162         1303 @matches = sort { $$fileOrder{$a} <=> $$fileOrder{$b} } @matches;
  8173         12782  
5349             # return only the highest priority tag unless duplicates wanted
5350 162 50 66     754 unless ($doDups or $allTag or $allGrp) {
      33        
5351 0         0 $tag = shift @matches;
5352 0   0     0 my $oldPriority = $$et{PRIORITY}{$tag} || 1;
5353 0         0 foreach (@matches) {
5354 0         0 my $priority = $$et{PRIORITY}{$_};
5355 0 0       0 $priority = 1 unless defined $priority;
5356 0 0       0 next unless $priority >= $oldPriority;
5357 0         0 $tag = $_;
5358 0   0     0 $oldPriority = $priority || 1;
5359             }
5360 0         0 @matches = ( $tag );
5361             }
5362             } elsif (not @matches) {
5363             # put entry in return list even without value (value is undef)
5364 532 100       1862 $matches[0] = $byValue ? "$tag #(0)" : "$tag (0)";
5365             # bogus file order entry to avoid warning if sorting in file order
5366 532         2144 $$self{FILE_ORDER}{$matches[0]} = 9999;
5367             }
5368             # copy over necessary information for tags from alternate files
5369 969 100       2465 if ($g8) {
5370 6         36 $self->CopyAltInfo($g8, \@matches);
5371             # restore variables to original values for main file
5372 6         17 $fileOrder = $$self{FILE_ORDER};
5373 6         18 $tagHash = $$self{VALUE};
5374             }
5375             # save indices of tags extracted by value
5376 969 100       2396 push @byValue, scalar(@$rtnTags) .. (scalar(@$rtnTags)+scalar(@matches)-1) if $byValue;
5377             # save indices of wildcard tags
5378 969 100       3040 push @wildTags, scalar(@$rtnTags) .. (scalar(@$rtnTags)+scalar(@matches)-1) if $allTag;
5379 969         4186 push @$rtnTags, @matches;
5380             }
5381             } else {
5382             # no requested tags, so we want all tags
5383 353         787 my @allTags;
5384 353 50       1242 if ($doDups) {
5385 353         733 @allTags = keys %{$$self{VALUE}};
  353         12209  
5386             } else {
5387             # only include tag if it doesn't end in a copy number
5388 0         0 @allTags = grep(!/ /, keys %{$$self{VALUE}});
  0         0  
5389             }
5390 353         1373 $rtnTags = \@allTags;
5391             }
5392              
5393             # filter excluded tags and group options
5394 720   100     5340 while (($exclude or @groupOptions) and @$rtnTags) {
      66        
5395 72 100       266 if ($exclude) {
5396 45         128 my ($pat, %exclude);
5397 45         148 foreach $pat (@$exclude) {
5398 61         147 my $group;
5399 61 100       394 if ($pat =~ /^(.*):(.+)/) {
5400 34         178 ($group, $tag) = ($1, $2);
5401 34 50       347 if ($group =~ /^(\*|all)$/i) {
    50          
5402 0         0 undef $group;
5403             } elsif ($group !~ /^[-\w:]*$/) {
5404 0         0 $self->Warn("Invalid group name '${group}'");
5405 0         0 $group = 'invalid';
5406             }
5407             } else {
5408 27         60 $tag = $pat;
5409             }
5410 61         159 my @matches;
5411 61 100       366 if ($tag =~ /^(\*|all)$/i) {
5412 34         273 @matches = @$rtnTags;
5413             } else {
5414             # allow wildcards in tag names
5415 27         70 $tag =~ s/\*/[-\\w]*/g;
5416 27         93 $tag =~ s/\?/[-\\w]/g;
5417 27         4561 @matches = grep(/^$tag( |$)/i, @$rtnTags);
5418             }
5419 61 100 66     449 @matches = $self->GroupMatches($group, \@matches) if $group and @matches;
5420 61         615 $exclude{$_} = 1 foreach @matches;
5421             }
5422 45 50       210 if (%exclude) {
5423             # remove excluded tags from return list(s)
5424 45         280 RemoveTagsFromList($rtnTags, \@byValue, \@wildTags, \%exclude);
5425 45 50       198 last unless @$rtnTags; # all done if nothing left
5426             }
5427 45 100 66     404 last if $duplicates and not @groupOptions;
5428             }
5429             # filter groups if requested, or to remove duplicates
5430 28         71 my (%keepTags, %wantGroup, $family, $groupOpt);
5431 28         67 my $allGroups = 1;
5432             # build hash of requested/excluded group names for each group family
5433 28         59 my $wantOrder = 0;
5434 28         89 foreach $groupOpt (@groupOptions) {
5435 29 50       224 $groupOpt =~ /^Group(\d*(:\d+)*)/ or next;
5436 29   100     146 $family = $1 || 0;
5437 29 50       172 $wantGroup{$family} or $wantGroup{$family} = { };
5438 29         59 my $groupList;
5439 29 100       100 if (ref $$options{$groupOpt} eq 'ARRAY') {
5440 4         11 $groupList = $$options{$groupOpt};
5441             } else {
5442 25         1445 $groupList = [ $$options{$groupOpt} ];
5443             }
5444 29         89 foreach (@$groupList) {
5445             # groups have priority in order they were specified
5446 33         60 ++$wantOrder;
5447 33         57 my ($groupName, $want);
5448 33 100       134 if (/^-(.*)/) {
5449             # excluded group begins with '-'
5450 2         6 $groupName = $1;
5451 2         5 $want = 0; # we don't want tags in this group
5452             } else {
5453 31         61 $groupName = $_;
5454 31         49 $want = $wantOrder; # we want tags in this group
5455 31         54 $allGroups = 0; # don't want all groups if we requested one
5456             }
5457 33         146 $wantGroup{$family}{$groupName} = $want;
5458             }
5459             }
5460             # loop through all tags and decide which ones we want
5461 28         86 my (@tags, %bestTag);
5462 28         59 GR_TAG: foreach $tag (@$rtnTags) {
5463 4505         6137 my $wantTag = $allGroups; # want tag by default if want all groups
5464 4505         7784 foreach $family (keys %wantGroup) {
5465 4676         8978 my $group = $self->GetGroup($tag, $family);
5466 4676         9701 my $wanted = $wantGroup{$family}{$group};
5467 4676 100       9233 next unless defined $wanted;
5468 1212 100       2570 next GR_TAG unless $wanted; # skip tag if group excluded
5469             # take lowest non-zero want flag
5470 1035 50 33     1735 next if $wantTag and $wantTag < $wanted;
5471 1035         1616 $wantTag = $wanted;
5472             }
5473 4328 100       8854 next unless $wantTag;
5474 1047 100       2082 $duplicates and $keepTags{$tag} = 1, next;
5475             # determine which tag we want to keep
5476 665         994 my $tagName = GetTagName($tag);
5477 665         1037 my $bestTag = $bestTag{$tagName};
5478 665 100       1175 if (defined $bestTag) {
5479 28 100       84 next if $wantTag > $keepTags{$bestTag};
5480 11 50       32 if ($wantTag == $keepTags{$bestTag}) {
5481             # want two tags with the same name -- keep the latest one
5482 0 0       0 if ($tag =~ / \((\d+)\)$/) {
5483 0         0 my $tagNum = $1;
5484 0 0 0     0 next if $bestTag !~ / \((\d+)\)$/ or $1 > $tagNum;
5485             }
5486             }
5487             # this tag is better, so delete old best tag
5488 11         41 delete $keepTags{$bestTag};
5489             }
5490 648         1187 $keepTags{$tag} = $wantTag; # keep this tag (for now...)
5491 648         1190 $bestTag{$tagName} = $tag; # this is our current best tag
5492             }
5493             # include only tags we want to keep in return lists
5494 28         177 RemoveTagsFromList($rtnTags, \@byValue, \@wildTags, \%keepTags, 1);
5495 28         322 last;
5496             }
5497 720         2669 $$self{FOUND_TAGS} = $rtnTags; # save found tags
5498              
5499             # return reference to found tag keys (and list of indices of tags to extract by value)
5500 720 100       4863 return wantarray ? ($rtnTags, \@byValue, \@wildTags) : $rtnTags;
5501             }
5502              
5503             #------------------------------------------------------------------------------
5504             # Utility to load our write routines if required (called via AUTOLOAD)
5505             # Inputs: 0) autoload function, 1-N) function arguments
5506             # Returns: result of function or dies if function not available
5507             sub DoAutoLoad(@)
5508             {
5509 763     763 0 2392 my $autoload = shift;
5510 763         4543 my @callInfo = split(/::/, $autoload);
5511 763         2155 my $file = 'Image/ExifTool/Write';
5512              
5513 763 100       217385 return if $callInfo[$#callInfo] eq 'DESTROY';
5514 255 100       1252 if (@callInfo == 4) {
    100          
5515             # load Image/ExifTool/WriteMODULE.pl
5516 193         618 $file .= "$callInfo[2].pl";
5517             } elsif ($callInfo[-1] eq 'ShiftTime') {
5518 1         4 $file = 'Image/ExifTool/Shift.pl'; # load Shift.pl
5519             } else {
5520             # load Image/ExifTool/Writer.pl
5521 61         236 $file .= 'r.pl';
5522             }
5523             # attempt to load the package
5524 255 50       732 eval { require $file } or die "Error while attempting to call $autoload\n$@\n";
  255         337145  
5525 255 50       2521 unless (defined &$autoload) {
5526 0         0 my @caller = caller(0);
5527             # reproduce Perl's standard 'undefined subroutine' message:
5528 0         0 die "Undefined subroutine $autoload called at $caller[1] line $caller[2]\n";
5529             }
5530 113     113   1558 no strict 'refs';
  113         288  
  113         198798  
5531 255         1809 return &$autoload(@_); # call the function
5532             }
5533              
5534             #------------------------------------------------------------------------------
5535             # AutoLoad our writer routines when necessary
5536             #
5537             sub AUTOLOAD
5538             {
5539 570     570   605127 return DoAutoLoad($AUTOLOAD, @_);
5540             }
5541              
5542             #------------------------------------------------------------------------------
5543             # Add cleanup routine to call before returning from Extract
5544             # Inputs: 0) ExifTool ref, 1) code ref to routine with ExifTool ref as an argument
5545             sub AddCleanup($)
5546             {
5547 0     0 0 0 my ($self, $sub) = @_;
5548 0 0       0 $$self{Cleanup} or $$self{Cleanup} = [ ];
5549 0         0 push @{$$self{Cleanup}}, $sub;
  0         0  
5550             }
5551              
5552             #------------------------------------------------------------------------------
5553             # Add warning tag
5554             # Inputs: 0) ExifTool object reference, 1) warning message
5555             # 2) 0=normal warning, 1=minor, 2=minor with behavioural change when
5556             # ignored, 3=warning shouldn't be issued with Validate option,
5557             # bit 0x04 set causes warning count to not be incremented
5558             # Returns: true if warning tag was added
5559             sub Warn($$;$)
5560             {
5561 95     95 0 341 my ($self, $str, $ignorable) = @_;
5562 95         334 my $noWarn = $$self{OPTIONS}{NoWarning};
5563 95         185 my $noCount;
5564 95         350 while ($ignorable) {
5565 40 100       194 if ($ignorable & 0x04) {
5566 1         2 $noCount = 1;
5567 1 50       221 $ignorable &= 0x03 or last;
5568             }
5569 40         107 my $ignorable = $ignorable & 0x03;
5570 40 100       144 return 0 if $$self{OPTIONS}{IgnoreMinorErrors};
5571 39 50 66     124 return 0 if $ignorable eq '3' and $$self{OPTIONS}{Validate};
5572 39 50 33     183 return 1 if defined $noWarn and eval { $str =~ /$noWarn/ };
  0         0  
5573 39 100       163 $str = $ignorable eq '2' ? "[Minor] $str" : "[minor] $str";
5574 39         98 last;
5575             }
5576 94 50 33     393 unless (defined $noWarn and eval { $str =~ /$noWarn/ }) {
  0         0  
5577             # add each warning only once but count number of occurrences
5578 94 100       331 if ($$self{WAS_WARNED}{$str}) {
5579 10 50       35 ++$$self{WAS_WARNED}{$str} unless $noCount;
5580             } else {
5581 84         419 $self->FoundTag('Warning', $str);
5582 84         333 $$self{WAS_WARNED}{$str} = 1;
5583             }
5584             }
5585 94         377 return 1;
5586             }
5587              
5588             #------------------------------------------------------------------------------
5589             # Add error tag
5590             # Inputs: 0) ExifTool object reference, 1) error message, 2) true if minor
5591             # Returns: true if error tag was added, otherwise warning was added
5592             sub Error($$;$)
5593             {
5594 4     4 0 14 my ($self, $str, $ignorable) = @_;
5595 4 50       28 if ($$self{DemoteErrors}) {
    100          
5596 0 0       0 $self->Warn($str) and ++$$self{DemoteErrors};
5597 0         0 return 1;
5598             } elsif ($ignorable) {
5599 1 50       10 $$self{OPTIONS}{IgnoreMinorErrors} and $self->Warn($str), return 0;
5600 0         0 $str = "[minor] $str";
5601             }
5602 3         15 $self->FoundTag('Error', $str);
5603 3         10 return 1;
5604             }
5605              
5606             #------------------------------------------------------------------------------
5607             # Expand shortcuts
5608             # Inputs: 0) reference to list of tags, 1) set to remove trailing '#'
5609             # Notes: Handles leading '-' for excluded tags, trailing '#' for ValueConv,
5610             # multiple group names, and redirected tags
5611             sub ExpandShortcuts($;$)
5612             {
5613 528     528 0 1549 my ($tagList, $removeSuffix) = @_;
5614 528 50 33     3002 return unless $tagList and @$tagList;
5615              
5616 528         39985 require Image::ExifTool::Shortcuts;
5617              
5618             # expand shortcuts
5619 528 100       1935 my $suffix = $removeSuffix ? '' : '#';
5620 528         1043 my @expandedTags;
5621 528         1166 my ($entry, $tag, $excl);
5622 528         1431 foreach $entry (@$tagList) {
5623             # skip things like options hash references in list
5624 1174 100       2904 if (ref $entry) {
5625 1         2 push @expandedTags, $entry;
5626 1         3 next;
5627             }
5628             # remove leading '-'
5629 1173         6620 ($excl, $tag) = $entry =~ /^(-?)(.*)/s;
5630 1173         2578 my ($post, @post, $pre, $v);
5631             # handle redirection
5632 1173 100 100     14483 if (not $excl and $tag =~ /(.+?)([-+]?[<>].+)/s) {
5633 31         112 ($tag, $post) = ($1, $2);
5634 31 100 100     224 if ($post =~ /^[-+]?>/ or $post !~ /\$/) {
5635             # expand shortcuts in postfix (rhs of redirection)
5636 23         134 my ($op, $p2, $t2) = ($post =~ /([-+]?[<>])(.+:)?(.+)/);
5637 23 100       87 $p2 = '' unless defined $p2;
5638 23 50       108 $v = ($t2 =~ s/#$//) ? $suffix : ''; # ValueConv suffix
5639 23         565 my ($match) = grep /^\Q$t2\E$/i, keys %Image::ExifTool::Shortcuts::Main;
5640 23 50       117 if ($match) {
5641 0         0 foreach (@{$Image::ExifTool::Shortcuts::Main{$match}}) {
  0         0  
5642 0 0       0 /^-/ and next; # ignore excluded tags
5643 0 0 0     0 if ($p2 and /(.+:)(.+)/) {
5644 0         0 push @post, "$op$_$v";
5645             } else {
5646 0         0 push @post, "$op$p2$_$v";
5647             }
5648             }
5649 0 0       0 next unless @post;
5650 0         0 $post = shift @post;
5651             }
5652             }
5653             } else {
5654 1142         2168 $post = '';
5655             }
5656             # handle group names
5657 1173 100       3939 if ($tag =~ /(.+:)(.+)/) {
5658 328         1334 ($pre, $tag) = ($1, $2);
5659             } else {
5660 845         1389 $pre = '';
5661             }
5662 1173 100       3195 $v = ($tag =~ s/#$//) ? $suffix : ''; # ValueConv suffix
5663             # loop over all postfixes
5664 1173         1858 for (;;) {
5665             # expand the tag name
5666 1173         33023 my ($match) = grep /^\Q$tag\E$/i, keys %Image::ExifTool::Shortcuts::Main;
5667 1173 100       3987 if ($match) {
5668 17 50 66     199 if ($excl) {
    100 66        
5669             # entry starts with '-', so exclude all tags in this shortcut
5670 0         0 foreach (@{$Image::ExifTool::Shortcuts::Main{$match}}) {
  0         0  
5671 0 0       0 /^-/ and next; # ignore excluded exclude tags
5672             # group of expanded tag takes precedence
5673 0 0 0     0 if ($pre and /(.+:)(.+)/) {
5674 0         0 push @expandedTags, "$excl$_";
5675             } else {
5676 0         0 push @expandedTags, "$excl$pre$_";
5677             }
5678             }
5679             } elsif (length $pre or length $post or $v) {
5680 1         3 foreach (@{$Image::ExifTool::Shortcuts::Main{$match}}) {
  1         7  
5681 12         46 /(-?)(.+:)?(.+)/;
5682 12 50       29 if ($2) {
5683             # group from expanded tag takes precedence
5684 0         0 push @expandedTags, "$_$v$post";
5685             } else {
5686 12         47 push @expandedTags, "$1$pre$3$v$post";
5687             }
5688             }
5689             } else {
5690 16         45 push @expandedTags, @{$Image::ExifTool::Shortcuts::Main{$match}};
  16         90  
5691             }
5692             } else {
5693 1156         3393 push @expandedTags, "$excl$pre$tag$v$post";
5694             }
5695 1173 50       4128 last unless @post;
5696 0         0 $post = shift @post;
5697             }
5698             }
5699 528         2458 @$tagList = @expandedTags;
5700             }
5701              
5702             #------------------------------------------------------------------------------
5703             # Add hash of Composite tags to our composites
5704             # Inputs: 0) hash reference to table of Composite tags to add or module name,
5705             # 1) override existing tag definition
5706             sub AddCompositeTags($;$)
5707             {
5708 636     636 0 2111 local $_;
5709 636         2454 my ($add, $override) = @_;
5710 636         1855 my ($module, $prefix, $tagID);
5711 636 50       3283 unless (ref $add) {
5712 636         6924 ($prefix = $add) =~ s/.*:://;
5713 636         1736 $module = $add;
5714 636         2391 $add .= '::Composite';
5715 113     113   1150 no strict 'refs';
  113         310  
  113         1448344  
5716 636         4390 $add = \%$add;
5717 636         1722 $prefix .= '-';
5718             } else {
5719 0         0 $prefix = 'UserDefined-';
5720             }
5721 636         2313 my $defaultGroups = $$add{GROUPS};
5722 636         3756 my $compTable = GetTagTable('Image::ExifTool::Composite');
5723              
5724             # make sure default groups are defined in families 0 and 1
5725 636 100       2023 if ($defaultGroups) {
5726 525 100       2625 $$defaultGroups{0} or $$defaultGroups{0} = 'Composite';
5727 525 100       1937 $$defaultGroups{1} or $$defaultGroups{1} = 'Composite';
5728 525 50       1876 $$defaultGroups{2} or $$defaultGroups{2} = 'Other';
5729             } else {
5730 111         927 $defaultGroups = $$add{GROUPS} = { 0 => 'Composite', 1 => 'Composite', 2 => 'Other' };
5731             }
5732 636         2865 SetupTagTable($add); # generate Name, TagID, etc
5733 636         5727 foreach $tagID (sort keys %$add) {
5734 6298 100       14844 next if $specialTags{$tagID}; # must skip special tags
5735 5659         9415 my $tagInfo = $$add{$tagID};
5736 5659         10852 my $new = $prefix . $tagID; # new tag ID for Composite table
5737 5659 100       13031 $$tagInfo{Module} = $module if $$tagInfo{Writable};
5738 5659 50 33     12212 $$tagInfo{Override} = 1 if $override and not defined $$tagInfo{Override};
5739 5659         11608 $$tagInfo{IsComposite} = 1;
5740             # handle Composite tags with the same name
5741 5659 100       12765 if ($compositeID{$tagID}) {
5742             # determine if we want to override this tag
5743             # (=0 keep both, >0 override, <0 keep existing)
5744 364   50     4158 my $over = ($$tagInfo{Override} || 0) - ($$compTable{$compositeID{$tagID}[0]}{Override} || 0);
      50        
5745 364 50       1081 next if $over < 0;
5746 364 50       1327 if ($over) {
5747             # remove existing tags with this ID
5748 0         0 delete $$compTable{$_} foreach @{$compositeID{$tagID}};
  0         0  
5749 0         0 delete $compositeID{$tagID};
5750             }
5751             }
5752             # make sure new TagID is unique by adding index if necessary
5753             # (could only happen for UserDefined tags now that module name is added to tag ID)
5754 5659         8471 my $n = 0;
5755 5659         14128 while ($$compTable{$new}) {
5756 0 0       0 $new =~ s/-\d+$// if $n++;
5757 0         0 $new .= "-$n";
5758             }
5759             # use new ID and save it so we can use it in TagLookup
5760 5659 50       16127 $$tagInfo{NewTagID} = $new unless $tagID eq $new;
5761              
5762             # add new ID to lookup of Composite tag ID's
5763 5659 100       16890 $compositeID{$tagID} = [ ] unless $compositeID{$tagID};
5764 5659         8716 unshift @{$compositeID{$tagID}}, $new; # (most recent one first)
  5659         15254  
5765              
5766             # convert scalar Require/Desire/Inhibit entries
5767 5659         9504 my ($type, @hashes, @scalars, %used);
5768 5659         9405 foreach $type ('Require','Desire','Inhibit') {
5769 16977 100       40229 my $req = $$tagInfo{$type} or next;
5770 7480 100       10106 push @{ref($req) eq 'HASH' ? \@hashes : \@scalars}, $type;
  7480         20371  
5771             }
5772 5659 100       10763 if (@scalars) {
5773             # make lookup for indices that are used
5774 1012         1960 foreach $type (@hashes) {
5775 113         397 $used{$_} = 1 foreach keys %{$$tagInfo{$type}};
  113         2042  
5776             }
5777 1012         1740 my $next = 0;
5778 1012         1818 foreach $type (@scalars) {
5779 1012         2640 ++$next while $used{$next};
5780 1012         4155 $$tagInfo{$type} = { $next++ => $$tagInfo{$type} };
5781             }
5782             }
5783             # add this Composite tag to our main Composite table
5784 5659         9529 $$tagInfo{Table} = $compTable;
5785             # (use the original TagID, even if we changed it, so don't do this:)
5786 5659         9373 $$tagInfo{TagID} = $new;
5787             # save tag under new ID in Composite table
5788 5659         14425 $$compTable{$new} = $tagInfo;
5789             # set all default groups in tag
5790 5659         8983 my $groups = $$tagInfo{Groups};
5791 5659 100       13448 $groups or $groups = $$tagInfo{Groups} = { };
5792             # fill in default groups
5793 5659         14584 foreach (keys %$defaultGroups) {
5794 16977 100       42163 $$groups{$_} or $$groups{$_} = $$defaultGroups{$_};
5795             }
5796             # set flag indicating group list was built
5797 5659         18401 $$tagInfo{GotGroups} = 1;
5798             }
5799             }
5800              
5801             #------------------------------------------------------------------------------
5802             # Add tags to TagLookup (used for writing)
5803             # Inputs: 0) source hash of tag definitions, 1) name of destination tag table
5804             sub AddTagsToLookup($$)
5805             {
5806 1     1 0 5 my ($tagHash, $table) = @_;
5807 1 50       9 if (defined &Image::ExifTool::TagLookup::AddTags) {
    50          
5808 0         0 Image::ExifTool::TagLookup::AddTags($tagHash, $table);
5809             } elsif (not $Image::ExifTool::pluginTags{$tagHash}) {
5810             # queue these tags until TagLookup is loaded
5811 1         22 push @Image::ExifTool::pluginTags, [ $tagHash, $table ];
5812             # set flag so we don't load same tags twice
5813 1         9 $Image::ExifTool::pluginTags{$tagHash} = 1;
5814             }
5815             }
5816              
5817             #------------------------------------------------------------------------------
5818             # Expand tagInfo Flags
5819             # Inputs: 0) tagInfo hash ref
5820             # Notes: $$tagInfo{Flags} must be defined to call this routine
5821             sub ExpandFlags($)
5822             {
5823 5048     5048 0 8918 my $tagInfo = shift;
5824 5048         9284 my $flags = $$tagInfo{Flags};
5825 5048 100       13609 if (ref $flags eq 'ARRAY') {
    50          
5826 2620         9900 foreach (@$flags) {
5827 7006         18239 $$tagInfo{$_} = 1;
5828             }
5829             } elsif (ref $flags eq 'HASH') {
5830 0         0 my $key;
5831 0         0 foreach $key (keys %$flags) {
5832 0         0 $$tagInfo{$key} = $$flags{$key};
5833             }
5834             } else {
5835 2428         7903 $$tagInfo{$flags} = 1;
5836             }
5837             }
5838              
5839             #------------------------------------------------------------------------------
5840             # Set up tag table (must be done once for each tag table used)
5841             # Inputs: 0) Reference to tag table
5842             # Notes: - generates 'Name' field from key if it doesn't exist
5843             # - stores 'Table' pointer and 'TagID' value
5844             # - expands 'Flags' for quick lookup
5845             sub SetupTagTable($)
5846             {
5847 5458     5458 0 10377 my $tagTablePtr = shift;
5848 5458         10964 my $avoid = $$tagTablePtr{AVOID};
5849 5458         10167 my ($tagID, $tagInfo);
5850 5458         16085 foreach $tagID (TagTableKeys($tagTablePtr)) {
5851 233003         370292 my @infoArray = GetTagInfoList($tagTablePtr,$tagID);
5852             # process conditional tagInfo arrays
5853 233003         339576 foreach $tagInfo (@infoArray) {
5854 255983         527505 $$tagInfo{Table} = $tagTablePtr;
5855 255983         552552 $$tagInfo{TagID} = $tagID;
5856 255983 100       500010 $$tagInfo{Name} or $$tagInfo{Name} = MakeTagName($tagID);
5857 255983 100       472225 $$tagInfo{Flags} and ExpandFlags($tagInfo);
5858 255983 100       431914 $$tagInfo{Avoid} = $avoid if defined $avoid;
5859             # calculate BitShift from Mask if necessary
5860 255983 100 100     534796 if ($$tagInfo{Mask} and not defined $$tagInfo{BitShift}) {
5861 3039         5524 my ($mask, $bitShift) = ($$tagInfo{Mask}, 0);
5862 3039         11401 ++$bitShift until $mask & (1 << $bitShift);
5863 3039         6936 $$tagInfo{BitShift} = $bitShift;
5864             }
5865             }
5866 233003 100       489891 next unless @infoArray > 1;
5867             # add an "Index" member to each tagInfo in a list
5868 3931         7169 my $index = 0;
5869 3931         6712 foreach $tagInfo (@infoArray) {
5870 26911         61399 $$tagInfo{Index} = $index++;
5871             }
5872             }
5873             }
5874              
5875             #------------------------------------------------------------------------------
5876             # Is this a PC system?
5877             # Returns: true for PC systems
5878             # uses lookup for O/S names which may use a backslash as a directory separator
5879             # (ref File::Spec of PathTools-3.2701)
5880             my %isPC = (MSWin32 => 1, os2 => 1, dos => 1, NetWare => 1, symbian => 1, cygwin => 1);
5881             sub IsPC()
5882             {
5883 0     0 0 0 return $isPC{$^O};
5884             }
5885              
5886             #------------------------------------------------------------------------------
5887             # Utilities to check for numerical types
5888             # Inputs: 0) value; Returns: true if value is a numerical type
5889             # Notes: May change commas to decimals in floats for use in other locales
5890             sub IsFloat($) {
5891 8210 100   8210 0 97122 return 1 if $_[0] =~ /^[+-]?(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/;
5892             # allow comma separators (for other locales)
5893 2520 50       19461 return 0 unless $_[0] =~ /^[+-]?(?=\d|,\d)\d*(,\d*)?([Ee]([+-]?\d+))?$/;
5894 0         0 $_[0] =~ tr/,/./; # but translate ',' to '.'
5895 0         0 return 1;
5896             }
5897 20348     20348 0 110157 sub IsInt($) { return scalar($_[0] =~ /^[+-]?\d+$/); }
5898 3370     3370 0 12763 sub IsHex($) { return scalar($_[0] =~ /^(0x)?[0-9a-f]{1,8}$/i); }
5899 16     16 0 176 sub IsRational($) { return scalar($_[0] =~ m{^[-+]?\d+/\d+$}); }
5900              
5901             # round floating point value to specified number of significant digits
5902             # Inputs: 0) value, 1) number of sig digits; Returns: rounded number
5903             sub RoundFloat($$)
5904             {
5905 3522     3522 0 6994 my ($val, $sig) = @_;
5906 3522         28670 return sprintf("%.${sig}g", $val);
5907             }
5908              
5909             # Convert strings to floating point numbers (or undef)
5910             # Inputs: 0-N) list of strings (may be undef)
5911             # Returns: last value converted
5912             sub ToFloat(@)
5913             {
5914 996     996 0 2082 local $_;
5915 996         2758 foreach (@_) {
5916 10628 100       19210 next unless defined $_;
5917             # (add 0 to convert "0.0" to "0" for tests)
5918 3974 100       23308 $_ = /((?:[+-]?)(?=\d|\.\d)\d*(?:\.\d*)?(?:[Ee](?:[+-]?\d+))?)/ ? $1 + 0 : undef;
5919             }
5920 996         11931 return $_[-1];
5921             }
5922              
5923             #------------------------------------------------------------------------------
5924             # Utility routines to for reading binary data values from file
5925              
5926             my %unpackMotorola = ( S => 'n', L => 'N', C => 'C', c => 'c' );
5927             my %unpackIntel = ( S => 'v', L => 'V', C => 'C', c => 'c' );
5928             my %unpackRev = ( N => 'V', V => 'N', C => 'C', n => 'v', v => 'n', c => 'c' );
5929              
5930             # the following 4 variables are defined in 'use vars' instead of using 'my'
5931             # because mod_perl 5.6.1 apparently has a problem with setting file-scope 'my'
5932             # variables from within subroutines (ref communication with Pavel Merdin):
5933             # $swapBytes - set if EXIF header is not native byte ordering
5934             # $swapWords - swap 32-bit words in doubles (ARM quirk)
5935             $currentByteOrder = 'MM'; # current byte ordering ('II' or 'MM')
5936             %unpackStd = %unpackMotorola;
5937              
5938             # Swap bytes in data if necessary
5939             # Inputs: 0) data, 1) number of bytes
5940             # Returns: swapped data
5941             sub SwapBytes($$)
5942             {
5943 1366 100   1366 0 6701 return $_[0] unless $swapBytes;
5944 212         518 my ($val, $bytes) = @_;
5945 212         419 my $newVal = '';
5946 212         1734 $newVal .= substr($val, $bytes, 1) while $bytes--;
5947 212         614 return $newVal;
5948             }
5949             # Swap words. Inputs: 8 bytes of data, Returns: swapped data
5950             sub SwapWords($)
5951             {
5952 1302 50 33 1302 0 7392 return $_[0] unless $swapWords and length($_[0]) == 8;
5953 0         0 return substr($_[0],4,4) . substr($_[0],0,4)
5954             }
5955              
5956             # Unpack value, letting unpack() handle byte swapping
5957             # Inputs: 0) unpack template, 1) data reference, 2) offset
5958             # Returns: unpacked number
5959             # - uses value of %unpackStd to determine the unpack template
5960             # - can only be called for 'S' or 'L' templates since these are the only
5961             # templates for which you can specify the byte ordering.
5962             sub DoUnpackStd(@)
5963             {
5964 163357 100   163357 0 433758 $_[2] and return unpack("x$_[2] $unpackStd{$_[0]}", ${$_[1]});
  158504         425333  
5965 4853         11512 return unpack($unpackStd{$_[0]}, ${$_[1]});
  4853         17939  
5966             }
5967             # same, but with reversed byte order
5968             sub DoUnpackRev(@)
5969             {
5970 12     12 0 38 my $fmt = $unpackRev{$unpackStd{$_[0]}};
5971 12 50       43 $_[2] and return unpack("x$_[2] $fmt", ${$_[1]});
  12         53  
5972 0         0 return unpack($fmt, ${$_[1]});
  0         0  
5973             }
5974             # Pack value
5975             # Inputs: 0) template, 1) value, 2) data ref (or undef), 3) offset (if data ref)
5976             # Returns: packed value
5977             sub DoPackStd(@)
5978             {
5979 31738     31738 0 75336 my $val = pack($unpackStd{$_[0]}, $_[1]);
5980 31738 100       59688 $_[2] and substr(${$_[2]}, $_[3], length($val)) = $val;
  7720         13986  
5981 31738         98714 return $val;
5982             }
5983             # same, but with reversed byte order
5984             sub DoPackRev(@)
5985             {
5986 0     0 0 0 my $val = pack($unpackRev{$unpackStd{$_[0]}}, $_[1]);
5987 0 0       0 $_[2] and substr(${$_[2]}, $_[3], length($val)) = $val;
  0         0  
5988 0         0 return $val;
5989             }
5990              
5991             # Unpack value, handling the byte swapping manually
5992             # Inputs: 0) # bytes, 1) unpack template, 2) data reference, 3) offset
5993             # Returns: unpacked number
5994             # - uses value of $swapBytes to determine byte ordering
5995             sub DoUnpack(@)
5996             {
5997 27965     27965 0 54717 my ($bytes, $template, $dataPt, $pos) = @_;
5998 27965         38847 my $val;
5999 27965 100       50120 if ($swapBytes) {
6000 5448         7903 $val = '';
6001 5448         27451 $val .= substr($$dataPt,$pos+$bytes,1) while $bytes--;
6002             } else {
6003 22517         43289 $val = substr($$dataPt,$pos,$bytes);
6004             }
6005 27965 50       55661 defined($val) or return undef;
6006 27965         72774 return unpack($template,$val);
6007             }
6008              
6009             # Unpack double value
6010             # Inputs: 0) unpack template, 1) data reference, 2) offset
6011             # Returns: unpacked number
6012             sub DoUnpackDbl(@)
6013             {
6014 1236     1236 0 2717 my ($template, $dataPt, $pos) = @_;
6015 1236         3278 my $val = substr($$dataPt,$pos,8);
6016 1236 50       3094 defined($val) or return undef;
6017             # swap bytes and 32-bit words (ARM quirk) if necessary, then unpack value
6018 1236         2893 return unpack($template, SwapWords(SwapBytes($val, 8)));
6019             }
6020              
6021             # Inputs: 0) data reference, 1) offset into data
6022 135     135 0 496 sub Get8s($$) { return DoUnpackStd('c', @_); }
6023 8004     8004 0 17283 sub Get8u($$) { return DoUnpackStd('C', @_); }
6024 14996     14996 0 30106 sub Get16s($$) { return DoUnpack(2, 's', @_); }
6025 78831     78831 0 153692 sub Get16u($$) { return DoUnpackStd('S', @_); }
6026 12274     12274 0 23699 sub Get32s($$) { return DoUnpack(4, 'l', @_); }
6027 76387     76387 0 150465 sub Get32u($$) { return DoUnpackStd('L', @_); }
6028 695     695 0 2000 sub GetFloat($$) { return DoUnpack(4, 'f', @_); }
6029 1236     1236 0 3248 sub GetDouble($$) { return DoUnpackDbl('d', @_); }
6030 12     12 0 37 sub Get16uRev($$) { return DoUnpackRev('S', @_); }
6031 0     0 0 0 sub Get32uRev($$) { return DoUnpackRev('L', @_); }
6032              
6033             # rationals may be a floating point number, 'inf' or 'undef'
6034             my ($ratNumer, $ratDenom);
6035             sub GetRational32s($$)
6036             {
6037 12     12 0 32 my ($dataPt, $pos) = @_;
6038 12         31 $ratNumer = Get16s($dataPt,$pos);
6039 12 0       42 $ratDenom = Get16s($dataPt, $pos + 2) or return $ratNumer ? 'inf' : 'undef';
    50          
6040             # round off to a reasonable number of significant figures
6041 12         55 return RoundFloat($ratNumer / $ratDenom, 7);
6042             }
6043             sub GetRational32u($$)
6044             {
6045 12     12 0 30 my ($dataPt, $pos) = @_;
6046 12         35 $ratNumer = Get16u($dataPt,$pos);
6047 12 0       33 $ratDenom = Get16u($dataPt, $pos + 2) or return $ratNumer ? 'inf' : 'undef';
    50          
6048 12         50 return RoundFloat($ratNumer / $ratDenom, 7);
6049             }
6050             sub GetRational64s($$)
6051             {
6052 690     690 0 1625 my ($dataPt, $pos) = @_;
6053 690         1744 $ratNumer = Get32s($dataPt,$pos);
6054 690 0       1731 $ratDenom = Get32s($dataPt, $pos + 4) or return $ratNumer ? 'inf' : 'undef';
    50          
6055 690         2190 return RoundFloat($ratNumer / $ratDenom, 10);
6056             }
6057             sub GetRational64u($$)
6058             {
6059 2840     2840 0 6138 my ($dataPt, $pos) = @_;
6060 2840         6233 $ratNumer = Get32u($dataPt,$pos);
6061 2840 50       7137 $ratDenom = Get32u($dataPt, $pos + 4) or return $ratNumer ? 'inf' : 'undef';
    100          
6062 2808         9559 return RoundFloat($ratNumer / $ratDenom, 10);
6063             }
6064             sub GetFixed16s($$)
6065             {
6066 18     18 0 55 my ($dataPt, $pos) = @_;
6067 18         61 my $val = Get16s($dataPt, $pos) / 0x100;
6068 18 50       113 return int($val * 1000 + ($val<0 ? -0.5 : 0.5)) / 1000;
6069             }
6070             sub GetFixed16u($$)
6071             {
6072 0     0 0 0 my ($dataPt, $pos) = @_;
6073 0         0 return int((Get16u($dataPt, $pos) / 0x100) * 1000 + 0.5) / 1000;
6074             }
6075             sub GetFixed32s($$)
6076             {
6077 1889     1889 0 3556 my ($dataPt, $pos) = @_;
6078 1889         3584 my $val = Get32s($dataPt, $pos) / 0x10000;
6079             # remove insignificant digits
6080 1889 100       6036 return int($val * 1e5 + ($val>0 ? 0.5 : -0.5)) / 1e5;
6081             }
6082             sub GetFixed32u($$)
6083             {
6084 216     216 0 470 my ($dataPt, $pos) = @_;
6085             # remove insignificant digits
6086 216         525 return int((Get32u($dataPt, $pos) / 0x10000) * 1e5 + 0.5) / 1e5;
6087             }
6088             # Inputs: 0) value, 1) data ref, 2) offset
6089 5     5 0 22 sub Set8s(@) { return DoPackStd('c', @_); }
6090 308     308 0 720 sub Set8u(@) { return DoPackStd('C', @_); }
6091 12729     12729 0 24944 sub Set16u(@) { return DoPackStd('S', @_); }
6092 18696     18696 0 36896 sub Set32u(@) { return DoPackStd('L', @_); }
6093 0     0 0 0 sub Set16uRev(@) { return DoPackRev('S', @_); }
6094              
6095             #------------------------------------------------------------------------------
6096             # Get current byte order ('II' or 'MM')
6097 14746     14746 0 46112 sub GetByteOrder() { return $currentByteOrder; }
6098              
6099             #------------------------------------------------------------------------------
6100             # Set byte ordering
6101             # Inputs: 0) 'MM'=motorola, 'II'=intel (will translate 'BigEndian', 'LittleEndian')
6102             # Returns: 1 on success
6103             sub SetByteOrder($)
6104             {
6105 16308     16308 0 34005 my $order = shift;
6106              
6107 16308 100       44866 if ($order eq 'MM') { # big endian (Motorola)
    100          
    100          
    100          
6108 8653         49796 %unpackStd = %unpackMotorola;
6109             } elsif ($order eq 'II') { # little endian (Intel)
6110 7458         44042 %unpackStd = %unpackIntel;
6111             } elsif ($order =~ /^Big/i) {
6112 16         42 $order = 'MM';
6113 16         142 %unpackStd = %unpackMotorola;
6114             } elsif ($order =~ /^Little/i) {
6115 12         36 $order = 'II';
6116 12         105 %unpackStd = %unpackIntel;
6117             } else {
6118 169         795 return 0;
6119             }
6120 16139         46599 my $val = unpack('S','A ');
6121 16139         25621 my $nativeOrder;
6122 16139 50       42203 if ($val == 0x4120) { # big endian
    50          
6123 0         0 $nativeOrder = 'MM';
6124             } elsif ($val == 0x2041) { # little endian
6125 16139         27164 $nativeOrder = 'II';
6126             } else {
6127 0         0 warn sprintf("Unknown native byte order! (pattern %x)\n",$val);
6128 0         0 return 0;
6129             }
6130 16139         27333 $currentByteOrder = $order; # save current byte order
6131              
6132             # swap bytes if our native CPU byte ordering is not the same as the EXIF
6133 16139         30946 $swapBytes = ($order ne $nativeOrder);
6134              
6135             # little-endian ARM has big-endian words for doubles (thanks Riku Voipio)
6136             # (Note: Riku's patch checked for '0ff3', but I think it should be 'f03f' since
6137             # 1 is '000000000000f03f' on an x86 -- so check for both, but which is correct?)
6138 16139         25673 my $pack1d = pack('d', 1);
6139 16139   33     58644 $swapWords = ($pack1d eq "\0\0\x0f\xf3\0\0\0\0" or
6140             $pack1d eq "\0\0\xf0\x3f\0\0\0\0");
6141 16139         39347 return 1;
6142             }
6143              
6144             #------------------------------------------------------------------------------
6145             # Change byte order
6146             sub ToggleByteOrder()
6147             {
6148 39 100   39 0 122 SetByteOrder(GetByteOrder() eq 'II' ? 'MM' : 'II');
6149             }
6150              
6151             #------------------------------------------------------------------------------
6152             # hash lookups for reading values from data
6153             my %formatSize = (
6154             int8s => 1,
6155             int8u => 1,
6156             int16s => 2,
6157             int16u => 2,
6158             int16uRev => 2,
6159             int32s => 4,
6160             int32u => 4,
6161             int32uRev => 4,
6162             int64s => 8,
6163             int64u => 8,
6164             rational32s => 4,
6165             rational32u => 4,
6166             rational64s => 8,
6167             rational64u => 8,
6168             fixed16s => 2,
6169             fixed16u => 2,
6170             fixed32s => 4,
6171             fixed32u => 4,
6172             fixed64s => 8,
6173             float => 4,
6174             double => 8,
6175             extended => 10,
6176             unicode => 2,
6177             complex => 8,
6178             string => 1,
6179             binary => 1,
6180             'undef' => 1,
6181             ifd => 4,
6182             ifd64 => 8,
6183             ue7 => 1,
6184             utf8 => 1, # (Exif 3.0)
6185             );
6186             my %readValueProc = (
6187             int8s => \&Get8s,
6188             int8u => \&Get8u,
6189             int16s => \&Get16s,
6190             int16u => \&Get16u,
6191             int16uRev => \&Get16uRev,
6192             int32s => \&Get32s,
6193             int32u => \&Get32u,
6194             int32uRev => \&Get32uRev,
6195             int64s => \&Get64s,
6196             int64u => \&Get64u,
6197             rational32s => \&GetRational32s,
6198             rational32u => \&GetRational32u,
6199             rational64s => \&GetRational64s,
6200             rational64u => \&GetRational64u,
6201             fixed16s => \&GetFixed16s,
6202             fixed16u => \&GetFixed16u,
6203             fixed32s => \&GetFixed32s,
6204             fixed32u => \&GetFixed32u,
6205             fixed64s => \&GetFixed64s,
6206             float => \&GetFloat,
6207             double => \&GetDouble,
6208             extended => \&GetExtended,
6209             ifd => \&Get32u,
6210             ifd64 => \&Get64u,
6211             );
6212             # lookup for all rational types
6213             my %isRational = (
6214             rational32u => 1,
6215             rational32s => 1,
6216             rational64u => 1,
6217             rational64s => 1,
6218             );
6219 1600     1600 0 5787 sub FormatSize($) { return $formatSize{$_[0]}; }
6220              
6221             #------------------------------------------------------------------------------
6222             # Read value from binary data (with current byte ordering)
6223             # Inputs: 0) data reference, 1) value offset, 2) format string,
6224             # 3) number of values (or undef to use all data),
6225             # 4) valid data length relative to offset (or undef to use all data),
6226             # 5) optional pointer to returned rational
6227             # Returns: converted value, or undefined if data isn't there
6228             # or list of values in list context
6229             sub ReadValue($$$;$$$)
6230             {
6231 37351     37351 0 105418 my ($dataPt, $offset, $format, $count, $size, $ratPt) = @_;
6232              
6233 37351         84646 my $len = $formatSize{$format};
6234 37351 50       80759 unless ($len) {
6235 0         0 warn "Unknown format $format";
6236 0         0 $len = 1;
6237             }
6238 37351 50       78042 $size = length($$dataPt) - $offset unless defined $size;
6239 37351 100       76792 unless ($count) {
6240 1417 100 100     6486 return '' if defined $count or $size < $len;
6241 1388         3638 $count = int($size / $len);
6242             }
6243             # make sure entry is inside data
6244 37322 100       82617 if ($len * $count > $size) {
6245 3         13 $count = int($size / $len); # shorten count if necessary
6246 3 50       35 $count < 1 and return undef; # return undefined if no data
6247             }
6248 37319         55209 my @vals;
6249 37319         70222 my $proc = $readValueProc{$format};
6250 37319 100 100     117568 if (not $proc) {
    100          
6251             # handle undef/binary/string (also unsupported unicode/complex)
6252 6621         24189 $vals[0] = substr($$dataPt, $offset, $count * $len);
6253             # truncate string at null terminator if necessary
6254 6621 100       33951 $vals[0] =~ s/\0.*//s if $format eq 'string';
6255             } elsif ($isRational{$format} and $ratPt) {
6256             # store rationals separately as string fractions
6257 3132         4828 my @rat;
6258 3132         4884 for (;;) {
6259 3466         8823 push @vals, &$proc($dataPt, $offset);
6260 3466         9992 push @rat, "$ratNumer/$ratDenom";
6261 3466 100       9089 last if --$count <= 0;
6262 334         547 $offset += $len;
6263             }
6264 3132         10477 $$ratPt = join(' ',@rat);
6265             } else {
6266 27566         41816 for (;;) {
6267 50469         102556 push @vals, &$proc($dataPt, $offset);
6268 50469 100       115964 last if --$count <= 0;
6269 22903         32290 $offset += $len;
6270             }
6271             }
6272 37319 100       82208 return @vals if wantarray;
6273 36907 100       115999 return join(' ', @vals) if @vals > 1;
6274 33194         94472 return $vals[0];
6275             }
6276              
6277             #------------------------------------------------------------------------------
6278             # Decode string with specified encoding
6279             # Inputs: 0) ExifTool object ref, 1) string to decode
6280             # 2) source character set name (undef for current Charset)
6281             # 3) optional source byte order (2-byte and 4-byte fixed-width sets only)
6282             # 4) optional destination character set (defaults to Charset setting)
6283             # 5) optional destination byte order (2-byte and 4-byte fixed-width only)
6284             # Returns: string in destination encoding
6285             # Note: ExifTool ref may be undef if character both character sets are provided
6286             # (but in this case no warnings will be issued)
6287             sub Decode($$$;$$$)
6288             {
6289 6489     6489 0 17411 my ($self, $val, $from, $fromOrder, $to, $toOrder) = @_;
6290 6489 100       13844 $from or $from = $$self{OPTIONS}{Charset};
6291 6489 100       18633 $to or $to = $$self{OPTIONS}{Charset};
6292 6489 100 100     18455 if ($from ne $to and length $val) {
6293 1164         41974 require Image::ExifTool::Charset;
6294 1164         2764 my $cs1 = $Image::ExifTool::Charset::csType{$from};
6295 1164         2128 my $cs2 = $Image::ExifTool::Charset::csType{$to};
6296 1164 50 33     6611 if ($cs1 and $cs2 and not $cs2 & 0x002) {
    0 33        
6297             # treat as straight ASCII if no character will need remapping
6298 1164 100 100     4971 if (($cs1 | $cs2) & 0x680 or $val =~ /[\x80-\xff]/) {
6299 824         3021 my $uni = Image::ExifTool::Charset::Decompose($self, $val, $from, $fromOrder);
6300 824         2485 $val = Image::ExifTool::Charset::Recompose($self, $uni, $to, $toOrder);
6301             }
6302             } elsif ($self) {
6303 0 0       0 my $set = $cs1 ? $to : $from;
6304 0 0       0 unless ($$self{"DecodeWarn$set"}) {
6305 0         0 $self->Warn("Unsupported character set ($set)");
6306 0         0 $$self{"DecodeWarn$set"} = 1;
6307             }
6308             }
6309             }
6310 6489         19598 return $val;
6311             }
6312              
6313             #------------------------------------------------------------------------------
6314             # Encode string (in Charset encoding) to specified encoding
6315             # Inputs: 0) ExifTool object ref, 1) string, 2) destination character set name,
6316             # 3) optional destination byte order (2-byte and 4-byte fixed-width sets only)
6317             # Returns: string in specified encoding
6318             sub Encode($$;$$)
6319             {
6320 110     110 0 413 my ($self, $val, $to, $toOrder) = @_;
6321 110         540 return $self->Decode($val, undef, undef, $to, $toOrder);
6322             }
6323              
6324             #------------------------------------------------------------------------------
6325             # Decode bit mask
6326             # Inputs: 0) value to decode, 1) Reference to hash for decoding (or undef)
6327             # 2) optional bits per word (defaults to 32)
6328             sub DecodeBits($$;$)
6329             {
6330 178     178 0 802 my ($vals, $lookup, $bits) = @_;
6331 178 100       668 $bits or $bits = 32;
6332 178         382 my ($val, $i, @bitList);
6333 178         349 my $num = 0;
6334 178         724 foreach $val (split ' ', $vals) {
6335 246         812 for ($i=0; $i<$bits; ++$i) {
6336 6144 100       14416 next unless $val & (1 << $i);
6337 143         308 my $n = $i + $num;
6338 143 100       738 if (not $lookup) {
    100          
6339 19         66 push @bitList, $n;
6340             } elsif ($$lookup{$n}) {
6341 118         370 push @bitList, $$lookup{$n};
6342             } else {
6343 6         20 push @bitList, "[$n]";
6344             }
6345             }
6346 246         564 $num += $bits;
6347             }
6348 178 100       951 return '(none)' unless @bitList;
6349 98 100       1063 return join($lookup ? ', ' : ',', @bitList);
6350             }
6351              
6352             #------------------------------------------------------------------------------
6353             # Validate an extracted image and repair if necessary
6354             # Inputs: 0) ExifTool object reference, 1) image reference, 2) tag name or key
6355             # Returns: image reference or undef if it wasn't valid
6356             # Note: should be called from RawConv, not ValueConv
6357             sub ValidateImage($$$)
6358             {
6359 208     208 0 746 my ($self, $imagePt, $tag) = @_;
6360 208 50       785 return undef if $$imagePt eq 'none';
6361 208 100 66     2074 unless ($$imagePt =~ /^(Binary data|\xff\xd8\xff)/ or
      100        
6362             # the first byte of the preview of some Minolta cameras is wrong,
6363             # so check for this and set it back to 0xff if necessary
6364             $$imagePt =~ s/^.(\xd8\xff\xdb)/\xff$1/s or
6365             $self->Options('IgnoreMinorErrors'))
6366             {
6367             # issue warning only if the tag was specifically requested
6368 124 50       2332 if ($$self{REQ_TAG_LOOKUP}{lc GetTagName($tag)}) {
6369 0         0 $self->Warn("$tag is not a valid JPEG image",1);
6370 0         0 return undef;
6371             }
6372             }
6373 208         2963 return $imagePt;
6374             }
6375              
6376             #------------------------------------------------------------------------------
6377             # Validate a tag name argument (including group name and wildcards, etc)
6378             # Inputs: 0) tag name
6379             # Returns: true if tag name is valid
6380             # - a tag name may contain [-_A-Za-z0-9], but may not start with [-0-9]
6381             # - tag names may contain wildcards [?*], and end with a hash [#]
6382             # - may have group name prefixes (which may have family number prefix), separated by colons
6383             # - a group name may be zero or more characters
6384             sub ValidTagName($)
6385             {
6386 54     54 0 112 my $tag = shift;
6387 54         434 return $tag =~ /^(([-\w]*|\d*\*):)*[_a-zA-Z?*][-\w?*]*#?$/;
6388             }
6389              
6390             #------------------------------------------------------------------------------
6391             # Generate a valid tag name based on the tag ID or name
6392             # Inputs: 0) tag ID or name
6393             # Returns: valid tag name
6394             sub MakeTagName($)
6395             {
6396 38961     38961 0 56689 my $name = shift;
6397 38961         74979 $name =~ tr/-_a-zA-Z0-9//dc; # remove illegal characters
6398 38961         62018 $name = ucfirst $name; # capitalize first letter
6399             # must at least 2 characters long and not start with - or 0-9-
6400 38961 100 66     158063 $name = "Tag$name" if length($name) < 2 or $name =~ /^[-0-9]/;
6401 38961         91492 return $name;
6402             }
6403              
6404             #------------------------------------------------------------------------------
6405             # Make description from a tag name
6406             # Inputs: 0) tag name 1) optional tagID to add at end of description
6407             # Returns: description
6408             sub MakeDescription($;$)
6409             {
6410 11306     11306 0 23292 my ($tag, $tagID) = @_;
6411             # start with the tag name and force first letter to be upper case
6412 11306         23227 my $desc = ucfirst($tag);
6413             # translate underlines to spaces
6414 11306         21094 $desc =~ tr/_/ /;
6415             # remove hex TagID from name (to avoid inserting spaces in the number)
6416 11306 100 66     35733 $desc =~ s/ (0x[\da-f]+)$//i and $tagID = $1 unless defined $tagID;
6417             # put a space between lower/UPPER case and lower/number combinations
6418 11306         88939 $desc =~ s/([a-z])([A-Z\d])/$1 $2/g;
6419             # put a space between acronyms and words
6420 11306         35147 $desc =~ s/([A-Z])([A-Z][a-z])/$1 $2/g;
6421             # put spaces after numbers (if more than one character follows the number)
6422 11306         21130 $desc =~ s/(\d)([A-Z]\S)/$1 $2/g;
6423             # add TagID to description
6424 11306 100       23824 $desc .= ' ' . $tagID if defined $tagID;
6425 11306         40073 return $desc;
6426             }
6427              
6428             #------------------------------------------------------------------------------
6429             # Get descriptions for all tags in an array
6430             # Inputs: 0) ExifTool ref, 1) reference to list of tag keys
6431             # Returns: reference to hash lookup for descriptions
6432             # Note: Returned descriptions are NOT escaped by ESCAPE_PROC
6433             sub GetDescriptions($$)
6434             {
6435 0     0 0 0 local $_;
6436 0         0 my ($self, $tags) = @_;
6437 0         0 my %desc;
6438 0         0 my $oldEscape = $$self{ESCAPE_PROC};
6439 0         0 delete $$self{ESCAPE_PROC};
6440 0         0 $desc{$_} = $self->GetDescription($_) foreach @$tags;
6441 0         0 $$self{ESCAPE_PROC} = $oldEscape;
6442 0         0 return \%desc;
6443             }
6444              
6445             #------------------------------------------------------------------------------
6446             # Apply filter to value(s) if necessary
6447             # Inputs: 0) ExifTool ref, 1) filter expression, 2) reference to value to filter
6448             # Returns: true unless a filter returned undef; changes value if necessary
6449             sub Filter($$$)
6450             {
6451 13298     13298 1 21257 local $_;
6452 13298         35025 my ($self, $filter, $valPt) = @_;
6453 13298 100 66     48564 return 1 unless defined $filter and defined $$valPt;
6454 463         832 my $rtnVal;
6455 463 100       1451 if (not ref $$valPt) {
    100          
    50          
    0          
6456 447         1082 $_ = $$valPt;
6457             #### eval Filter ($_, $self)
6458 447         43048 eval $filter;
6459 447 50       2325 if (defined $_) {
6460 447         1239 $$valPt = $_;
6461 447         952 $rtnVal = 1;
6462             }
6463             } elsif (ref $$valPt eq 'SCALAR') {
6464 12         35 my $val = $$$valPt; # make a copy to avoid filtering twice
6465 12         47 $rtnVal = $self->Filter($filter, \$val);
6466 12         37 $$valPt = \$val;
6467             } elsif (ref $$valPt eq 'ARRAY') {
6468 4         12 my @val = @{$$valPt}; # make a copy to avoid filtering twice
  4         22  
6469 4   33     21 $self->Filter($filter, \$_) and $rtnVal = 1 foreach @val;
6470 4         14 $$valPt = \@val;
6471             } elsif (ref $$valPt eq 'HASH') {
6472 0         0 my %val = %{$$valPt}; # make a copy to avoid filtering twice
  0         0  
6473 0   0     0 $self->Filter($filter, \$val{$_}) and $rtnVal = 1 foreach keys %val;
6474 0         0 $$valPt = \%val;
6475             } else {
6476 0         0 $rtnVal = 1;
6477             }
6478 463         1397 return $rtnVal;
6479             }
6480              
6481             #------------------------------------------------------------------------------
6482             # Return printable value
6483             # Inputs: 0) ExifTool object reference
6484             # 1) value to print, 2) line length limit (undef defaults to 60, 0=unlimited)
6485             # Returns: Printable string
6486             sub Printable($;$)
6487             {
6488 590     590 0 1370 my ($self, $outStr, $maxLen) = @_;
6489 590 50       1530 return '(undef)' unless defined $outStr;
6490 590 50       1334 ref $outStr eq 'SCALAR' and return '(Binary data '.length($$outStr).' bytes)';
6491 590         1369 $outStr =~ tr/\x01-\x1f\x7f-\xff/./;
6492 590         2028 $outStr =~ s/\x00//g;
6493 590         1494 my $verbose = $$self{OPTIONS}{Verbose};
6494 590 50       1312 if ($verbose < 4) {
6495 590 100       1317 if ($maxLen) {
    50          
6496 589 50       1445 $maxLen = 20 if $maxLen < 20; # minimum length is 20
6497             } elsif (defined $maxLen) {
6498 1         2 $maxLen = length $outStr; # 0 is unlimited
6499             } else {
6500 0         0 $maxLen = 60; # default maximum is 60
6501             }
6502             } else {
6503 0         0 $maxLen = length $outStr;
6504             # limit to 2048 characters if verbose < 5
6505 0 0 0     0 $maxLen = 2048 if $maxLen > 2048 and $verbose < 5;
6506             }
6507              
6508             # limit length if necessary
6509 590 100       1427 $outStr = substr($outStr,0,$maxLen-6) . '[snip]' if length($outStr) > $maxLen;
6510 590         2243 return $outStr;
6511             }
6512              
6513             #------------------------------------------------------------------------------
6514             # Convert date/time from Exif format
6515             # Inputs: 0) ExifTool object reference, 1) Date/time in EXIF format
6516             # Returns: Formatted date/time string
6517             sub ConvertDateTime($$)
6518             {
6519 1843     1843 0 5187 my ($self, $date) = @_;
6520 1843         5334 my $fmt = $$self{OPTIONS}{DateFormat};
6521 1843         3944 my $shift = $$self{OPTIONS}{GlobalTimeShift};
6522 1843 100       5222 if ($shift) {
6523 8         18 my $offset = $$self{GLOBAL_TIME_OFFSET};
6524 8         22 my ($g, $t, $dir, @matches);
6525 8 50       50 if ($shift =~ s/^((\d?[A-Z][-\w]*\w:)*)([A-Z][-\w]*\w)([-+])//i) {
6526 0 0       0 ($g, $t, $dir) = ($1, $3, ($4 eq '-' ? -1 : 1));
6527             } else {
6528 8 50 33     78 $dir = ($shift =~ s/^([-+])// and $1 eq '-') ? -1 : 1;
6529             }
6530 8 100       30 unless ($offset) {
6531 1         5 $offset = $$self{GLOBAL_TIME_OFFSET} = { };
6532             # (see forum16692 for a discussion about why this code was added)
6533 1 50       6 if ($t) {
6534             # determine initial shift from specified tag
6535 0         0 @matches = sort grep(/^$t( \(|$)/i, keys %{$$self{VALUE}});
  0         0  
6536 0 0 0     0 if ($g and @matches) {
6537 0         0 $g =~ s/:$//;
6538 0         0 @matches = $self->GroupMatches($g, \@matches);
6539             }
6540             }
6541 1 0 33     9 if (not @matches and $$self{TAGS_FROM_FILE} and $$self{OPTIONS}{RequestTags}) {
      33        
6542             # determine initial shift from first requested date/time tag
6543 0         0 my @reqDate = grep /date/i, @{$$self{OPTIONS}{RequestTags}};
  0         0  
6544 0         0 while (@reqDate) {
6545 0         0 $t = shift @reqDate;
6546 0         0 @matches = sort grep(/^$t( \(|$)/i, keys %{$$self{VALUE}});
  0         0  
6547 0         0 my $ti = $$self{TAG_INFO};
6548 0         0 for (; @matches; shift @matches) {
6549             # select the first tag that calls this routine in its PrintConv
6550 0 0       0 next unless $$ti{$matches[0]}{PrintConv};
6551 0 0       0 next unless $$ti{$matches[0]}{PrintConv} =~ /ConvertDateTime/;
6552 0         0 undef @reqDate;
6553 0         0 last;
6554             }
6555             }
6556             }
6557 1 50       5 if (@matches) {
6558 0         0 my $val = $self->GetValue($matches[0], 'ValueConv');
6559 0 0       0 ShiftTime($val, $shift, $dir, $offset) if defined $val;
6560             }
6561             }
6562 8         42 ShiftTime($date, $shift, $dir, $offset);
6563             }
6564             # only convert date if a format was specified and the date is recognizable
6565 1843 100       4227 if ($fmt) {
6566             # separate time zone if it exists
6567 5         7 my $tz;
6568 5 100       25 $date =~ s/([-+]\d{2}:\d{2}|Z)$// and $tz = $1;
6569             # a few cameras use incorrect date/time formatting:
6570             # - slashes instead of colons in date (RolleiD330, ImpressCam)
6571             # - date/time values separated by colon instead of space (Polariod, Sanyo, Sharp, Vivitar)
6572             # - single-digit seconds with leading space (HP scanners)
6573 5         32 my @a = reverse ($date =~ /\d+/g); # be very flexible about date/time format
6574 5 50 33     33 if (@a and $a[-1] >= 1000 and $a[-1] < 3000 and eval { require POSIX }) {
  5 0 33     30  
      33        
6575 5         13 shift @a while @a > 6; # remove superfluous entries
6576 5         12 unshift @a, 1 while @a < 3; # add month and day if necessary
6577 5         12 unshift @a, 0 while @a < 6; # add h,m,s if necessary
6578 5         10 $a[4] -= 1; # base month is 1
6579             # parse our %f fractional seconds first (and round up seconds if necessary)
6580             # - if there are multiple %f codes, they all get the same number of digits as the first
6581 5 50       22 if ($fmt =~ /%(-?)\.?(\d*)f/) {
6582 0         0 my ($neg, $dig) = ($1, $2);
6583 0 0       0 my $frac = $date =~ /(\.\d+)/ ? $1 : '';
6584 0 0       0 if (not $frac) {
    0          
6585 0 0       0 $frac = '.' . ('0' x $dig) if $dig;
6586             } elsif (length $dig) {
6587 0 0       0 if ($dig+1 > length($frac)) {
    0          
6588 0         0 $frac .= '0' x ($dig+1-length($frac));
6589             } elsif ($dig+1 < length($frac)) {
6590 0         0 $frac = sprintf("%.${dig}f", $frac);
6591 0   0     0 while ($frac =~ s/^(\d)// and $1 ne '0') {
6592             # this is a pain, but we must round up to the next second
6593 0 0       0 ++$a[0] < 60 and last;
6594 0         0 $a[0] = 0;
6595 0 0       0 ++$a[1] < 60 and last;
6596 0         0 $a[1] = 0;
6597 0 0       0 ++$a[2] < 24 and last;
6598 0         0 $a[2] = 0;
6599 0         0 require 'Image/ExifTool/Shift.pl';
6600 0 0       0 ++$a[3] <= DaysInMonth($a[4]+1, $a[5]) and last;
6601 0         0 $a[3] = 1;
6602 0 0       0 ++$a[4] < 12 and last;
6603 0         0 $a[4] = 0;
6604 0         0 ++$a[5];
6605 0         0 last; # (this was a goto)
6606             }
6607             }
6608             }
6609 0 0       0 $neg and $frac =~ s/^\.//;
6610 0         0 $fmt =~ s/(^|[^%])((%%)*)%-?\.?\d*f/$1$2$frac/g;
6611             }
6612             # parse %z and %s ourself (to handle time zones properly)
6613 5 50       18 if ($fmt =~ /%:?[sz]/) {
6614             # use system time zone unless otherwise specified
6615 0 0 0     0 $tz = TimeZoneString(\@a, TimeLocal(@a)) if not $tz and eval { require Time::Local };
  0         0  
6616             # remove colon, setting to UTC if time zone is not numeric
6617 0 0 0     0 $tz = '+00:00' unless $tz and $tz=~/^[-+]\d{2}:\d{2}$/;
6618 0         0 $fmt =~ s/(^|[^%])((%%)*)%:z/$1$2$tz/g; # convert '%:z' format codes
6619 0         0 $tz =~ s/://;
6620 0         0 $fmt =~ s/(^|[^%])((%%)*)%z/$1$2$tz/g; # convert '%z' format codes
6621 0 0 0     0 if ($fmt =~ /%s/ and eval { require Time::Local }) {
  0         0  
6622             # calculate seconds since the Epoch, UTC
6623 0         0 my $s = Time::Local::timegm(@a) - 60 * ($tz - int($tz/100) * 40);
6624 0         0 $fmt =~ s/(^|[^%])((%%)*)%s/$1$2$s/g; # convert '%s' format codes
6625             }
6626             }
6627 5         9 $a[5] -= 1900; # strftime year starts from 1900
6628 5         142 $date = POSIX::strftime($fmt, @a); # generate the formatted date/time
6629             # apparently strftime can set the UTF-8 flag (argh!), so reset this if necessary
6630 5 50       23 $self->Sanitize(\$date) if $fmt =~ /[\x80-\xff]/;
6631             } elsif ($$self{OPTIONS}{StrictDate}) {
6632 0         0 undef $date;
6633             }
6634             }
6635 1843         15346 return $date;
6636             }
6637              
6638             #------------------------------------------------------------------------------
6639             # Print conversion for time span value
6640             # Inputs: 0) time ticks, 1) number of seconds per tick (default 1)
6641             # Returns: readable time
6642             sub ConvertTimeSpan($;$)
6643             {
6644 3     3 0 11 my ($val, $mult) = @_;
6645 3 50 33     15 if (Image::ExifTool::IsFloat($val) and $val != 0) {
6646 3 100       12 $val *= $mult if $mult;
6647 3 50       45 if ($val < 60) {
    50          
    0          
6648 0         0 $val = "$val seconds";
6649             } elsif ($val < 3600) {
6650 3 100 66     19 my $fmt = ($mult and $mult >= 60) ? '%d' : '%.1f';
6651 3 100 66     17 my $s = ($val == 60 and $mult) ? '' : 's';
6652 3         24 $val = sprintf("$fmt minute$s", $val / 60);
6653             } elsif ($val < 24 * 3600) {
6654 0         0 $val = sprintf("%.1f hours", $val / 3600);
6655             } else {
6656 0         0 $val = sprintf("%.1f days", $val / (24 * 3600));
6657             }
6658             }
6659 3         30 return $val;
6660             }
6661              
6662             #------------------------------------------------------------------------------
6663             # Patched timelocal() that fixes ActivePerl timezone bug
6664             # Inputs/Returns: same as timelocal()
6665             # Notes: must 'require Time::Local' before calling this routine.
6666             # Also note that year should be full year, and not relative to 1900 as with localtime
6667             sub TimeLocal(@)
6668             {
6669 36     36 0 1697 my $tm = Time::Local::timelocal(@_);
6670 36 50       2986 if ($^O eq 'MSWin32') {
6671             # patch for ActivePerl timezone bug
6672 0         0 my @t2 = localtime($tm);
6673 0         0 $t2[5] += 1900;
6674 0         0 my $t2 = Time::Local::timelocal(@t2);
6675             # adjust timelocal() return value to be consistent with localtime()
6676 0         0 $tm += $tm - $t2;
6677             }
6678 36         119 return $tm;
6679             }
6680              
6681             #------------------------------------------------------------------------------
6682             # Get time zone in minutes
6683             # Inputs: 0) localtime array ref, 1) gmtime array ref
6684             # Returns: time zone offset in minutes
6685             sub GetTimeZone($$)
6686             {
6687 967     967 0 2478 my ($tm, $gm) = @_;
6688             # compute the number of minutes between localtime and gmtime
6689 967         3568 my $min = $$tm[2] * 60 + $$tm[1] - ($$gm[2] * 60 + $$gm[1]);
6690 967 50       3041 if ($$tm[3] != $$gm[3]) {
6691             # account for case where one date wraps to the first of the next month
6692 0 0       0 $$gm[3] = $$tm[3] - ($$tm[3]==1 ? 1 : -1) if abs($$tm[3]-$$gm[3]) != 1;
    0          
6693             # adjust for the +/- one day difference
6694 0         0 $min += ($$tm[3] - $$gm[3]) * 24 * 60;
6695             }
6696             # MirBSD patch to round to the nearest 30 minutes because
6697             # it includes leap seconds in localtime but not gmtime
6698 967 0       4192 $min = int($min / 30 + ($min > 0 ? 0.5 : -0.5)) * 30 if $^O eq 'mirbsd';
    50          
6699 967         2987 return $min;
6700             }
6701              
6702             #------------------------------------------------------------------------------
6703             # Get time zone string
6704             # Inputs: 0) time zone offset in minutes
6705             # or 0) localtime array ref, 1) corresponding time value
6706             # Returns: time zone string ("+/-HH:MM")
6707             sub TimeZoneString($;$)
6708             {
6709 1008     1008 0 2261 my $min = shift;
6710 1008 100       3015 if (ref $min) {
6711 967         4287 my @gm = gmtime(shift);
6712 967         3299 $min = GetTimeZone($min, \@gm);
6713             }
6714 1008         2726 my $sign = '+';
6715 1008 100       2673 $min < 0 and $sign = '-', $min = -$min;
6716 1008         3025 $min = int($min + 0.5); # round off to nearest minute
6717 1008         2361 my $h = int($min / 60);
6718 1008         6158 return sprintf('%s%.2d:%.2d', $sign, $h, $min - $h * 60);
6719             }
6720              
6721             #------------------------------------------------------------------------------
6722             # Convert Unix time to EXIF date/time string
6723             # Inputs: 0) Unix time value, 1) non-zero to convert to local time, 2) number of
6724             # digits after the decimal for fractional seconds, negative to trim
6725             # trailing zeros, or undef to use SystemTimeRes
6726             # Returns: EXIF date/time string (with timezone for local times)
6727             sub ConvertUnixTime($;$$)
6728             {
6729 1070     1070 0 3610 my ($time, $toLocal, $dec) = @_;
6730 1070 100       3292 return '0000:00:00 00:00:00' if $time == 0;
6731 1069         2043 my (@tm, $tz, $trim);
6732 1069 100 50     6886 $dec = $static_vars{SystemTimeRes} || 0 unless defined $dec;
6733 1069 50       2988 $dec < 0 and $dec = -$dec, $trim = 1;
6734 1069         2514 my $itime = int($time);
6735 1069         2197 my $frac = $time - $itime;
6736 1069 50       2903 $frac < 0 and $frac += 1, $itime -= 1;
6737 1069         8095 $dec = sprintf('%.*f', $dec, $frac);
6738             # remove number before decimal and increment integer time if necessary
6739 1069 100 66     9373 $dec =~ s/^(\d)// and $1 eq '1' and $itime += 1;
6740 1069 50       3143 $dec =~ s/\.?0+$// if $trim; # trim trailing zeros if specified
6741 1069 100       3988 if (not $toLocal) {
    50          
6742 164         780 @tm = gmtime($itime);
6743 164         487 $tz = '';
6744             } elsif ($static_vars{KeepUTCTime}) {
6745 0         0 @tm = gmtime($itime);
6746 0         0 $tz = 'Z';
6747             } else {
6748 905         29611 @tm = localtime($itime);
6749 905         6011 $tz = TimeZoneString(\@tm, $itime);
6750             }
6751 1069         7389 my $str = sprintf("%4d:%.2d:%.2d %.2d:%.2d:%.2d$dec%s",
6752             $tm[5]+1900, $tm[4]+1, $tm[3], $tm[2], $tm[1], $tm[0], $tz);
6753 1069         11446 return $str;
6754             }
6755              
6756             #------------------------------------------------------------------------------
6757             # Get Unix time from EXIF-formatted date/time string with optional timezone
6758             # Inputs: 0) EXIF date/time string, 1) non-zero if time is local, or 2 to assume UTC
6759             # Returns: Unix time (seconds since 0:00 GMT Jan 1, 1970) or undefined on error
6760             sub GetUnixTime($;$)
6761             {
6762 176     176 0 49334 my ($timeStr, $isLocal) = @_;
6763 176 50       558 return 0 if $timeStr eq '0000:00:00 00:00:00';
6764 176         1384 my @tm = ($timeStr =~ /^(\d+)[-:](\d+)[-:](\d+)\s+(\d+):(\d+):(\d+)(.*)/);
6765 176 50       601 return undef unless @tm == 7;
6766 176 50       333 unless (eval { require Time::Local }) {
  176         6065  
6767 0         0 warn "Time::Local is not installed\n";
6768 0         0 return undef;
6769             }
6770 176         15610 my ($tzStr, $tzSec) = (pop(@tm), 0);
6771             # use specified timezone offset (if given) instead of local system time
6772             # if we are converting a local time value
6773 176 100       535 if ($isLocal) {
6774 127 50       575 if ($tzStr =~ /(?:Z|([-+])(\d+):(\d+))/i) {
    0          
6775             # use specified timezone if one exists
6776 127 100       804 $tzSec = ($2 * 60 + $3) * ($1 eq '-' ? -60 : 60) if $1;
    100          
6777 127         226 undef $isLocal; # convert using GMT corrected for specified timezone
6778             } elsif ($isLocal eq '2') {
6779 0         0 undef $isLocal;
6780             }
6781             }
6782 176         447 $tm[1] -= 1; # convert month
6783 176         376 @tm = reverse @tm; # change to order required by timelocal()
6784 176 50       848 my $val = $isLocal ? TimeLocal(@tm) : Time::Local::timegm(@tm) - $tzSec;
6785             # handle fractional seconds
6786 174 100 100     8424 $val += $1 if $tzStr and $tzStr =~ /^(\.\d+)/;
6787 174         1733 return $val;
6788             }
6789              
6790             #------------------------------------------------------------------------------
6791             # Print conversion for file size
6792             # Inputs: 0) file size in bytes, 1) optional ExifTool ref
6793             # Returns: converted file size
6794             sub ConvertFileSize($;$)
6795             {
6796 318     318 0 1054 my ($val, $et) = @_;
6797 318 50 66     2596 if ($et and $$et{OPTIONS}{ByteUnit} eq 'Binary') {
6798 0 0       0 $val < 2048 and return "$val bytes";
6799 0 0       0 $val < 10240 and return sprintf('%.1f KiB', $val / 1024);
6800 0 0       0 $val < 2097152 and return sprintf('%.0f KiB', $val / 1024);
6801 0 0       0 $val < 10485760 and return sprintf('%.1f MiB', $val / 1048576);
6802 0 0       0 $val < 2147483648 and return sprintf('%.0f MiB', $val / 1048576);
6803 0 0       0 $val < 10737418240 and return sprintf('%.1f GiB', $val / 1073741824);
6804 0         0 return sprintf('%.0f GiB', $val / 1073741824);
6805             } else {
6806 318 100       1507 $val < 2000 and return "$val bytes";
6807 207 100       1863 $val < 10000 and return sprintf('%.1f kB', $val / 1000);
6808 54 100       454 $val < 2000000 and return sprintf('%.0f kB', $val / 1000);
6809 4 100       62 $val < 10000000 and return sprintf('%.1f MB', $val / 1000000);
6810 1 50       9 $val < 2000000000 and return sprintf('%.0f MB', $val / 1000000);
6811 0 0       0 $val < 10000000000 and return sprintf('%.1f GB', $val / 1000000000);
6812 0         0 return sprintf('%.0f GB', $val / 1000000000);
6813             }
6814             }
6815              
6816             #------------------------------------------------------------------------------
6817             # Convert seconds to duration string (handles negative durations)
6818             # Inputs: 0) floating point seconds
6819             # Returns: duration string in form "S.SS s", "H:MM:SS" or "DD days HH:MM:SS"
6820             sub ConvertDuration($)
6821             {
6822 130     130 0 309 my $time = shift;
6823 130 50       489 return $time unless IsFloat($time);
6824 130 100       951 return '0 s' if $time == 0;
6825 61 50       264 my $sign = ($time > 0 ? '' : (($time = -$time), '-'));
6826 61 100       910 return sprintf("$sign%.2f s", $time) if $time < 30;
6827 4         10 $time += 0.5; # to round off to nearest second
6828 4         29 my $h = int($time / 3600);
6829 4         12 $time -= $h * 3600;
6830 4         10 my $m = int($time / 60);
6831 4         12 $time -= $m * 60;
6832 4 50       14 if ($h > 24) {
6833 0         0 my $d = int($h / 24);
6834 0         0 $h -= $d * 24;
6835 0         0 $sign = "$sign$d days ";
6836             }
6837 4         51 return sprintf("$sign%d:%.2d:%.2d", $h, $m, int($time));
6838             }
6839              
6840             #------------------------------------------------------------------------------
6841             # Print conversion for bitrate values
6842             # Inputs: 0) bitrate in bits per second
6843             # Returns: human-readable bitrate string
6844             # Notes: returns input value without formatting if it isn't numerical
6845             sub ConvertBitrate($)
6846             {
6847 19     19 0 44 my $bitrate = shift;
6848 19 50       66 IsFloat($bitrate) or return $bitrate;
6849 19         71 my @units = ('bps', 'kbps', 'Mbps', 'Gbps');
6850 19         34 for (;;) {
6851 36         64 my $units = shift @units;
6852 36 100 66     176 $bitrate >= 1000 and @units and $bitrate /= 1000, next;
6853 19 100       62 my $fmt = $bitrate < 100 ? '%.3g' : '%.0f';
6854 19         290 return sprintf("$fmt $units", $bitrate);
6855             }
6856             }
6857              
6858             #------------------------------------------------------------------------------
6859             # Convert file name for printing
6860             # Inputs: 0) ExifTool ref, 1) file name in CharsetFileName character set
6861             # Returns: converted file name in external character set
6862             sub ConvertFileName($$)
6863             {
6864 1010     1010 0 3103 my ($self, $val) = @_;
6865 1010         2942 my $enc = $$self{OPTIONS}{CharsetFileName};
6866 1010 50       3046 $val = $self->Decode($val, $enc) if $enc;
6867 1010         9558 return $val;
6868             }
6869              
6870             #------------------------------------------------------------------------------
6871             # Inverse conversion for file name (encode in CharsetFileName)
6872             # Inputs: 0) ExifTool ref, 1) file name in external character set
6873             # Returns: file name in CharsetFileName character set
6874             sub InverseFileName($$)
6875             {
6876 1     1 0 3 my ($self, $val) = @_;
6877 1         3 my $enc = $$self{OPTIONS}{CharsetFileName};
6878 1 50       5 $val = $self->Encode($val, $enc) if $enc;
6879 1         2 $val =~ tr/\\/\//; # make sure we are using forward slashes
6880 1         8 return $val;
6881             }
6882              
6883             #------------------------------------------------------------------------------
6884             # Limit length of long values (to be used in PrintConv)
6885             # Inputs: 0) string value, 1) ExifTool ref
6886             # Returns: length-limited value
6887             sub LimitLongValues($$)
6888             {
6889 416     416 1 810 my ($str, $self) = @_;
6890 416         752 my $lim = $$self{OPTIONS}{LimitLongValues};
6891 416 100 66     1202 if (length($str) > $lim and $lim >= 5) {
6892 48         137 $str = substr($str,0,$lim-5) . "[...]";
6893             }
6894 416         827 return $str;
6895             }
6896              
6897             #------------------------------------------------------------------------------
6898             # Save information for HTML dump
6899             # Inputs: 0) ExifTool hash ref, 1) start offset, 2) data size
6900             # 3) comment string, 4) tool tip (or SAME), 5) flags, 6) IFD name
6901             sub HDump($$$$;$$$)
6902             {
6903 0     0 0 0 my $self = shift;
6904 0 0       0 $$self{HTML_DUMP} or return;
6905 0         0 my ($pos, $len, $com, $tip, $flg, $ifd) = @_;
6906 0 0       0 $pos += $$self{BASE} if $$self{BASE};
6907             # skip structural data blocks which have been removed from the middle of this dump
6908             # (SkipData list contains ordered [start,end+1] offsets to skip)
6909 0 0       0 if ($$self{SkipData}) {
6910 0         0 my $end = $pos + $len;
6911 0         0 my $skip;
6912 0         0 foreach $skip (@{$$self{SkipData}}) {
  0         0  
6913 0 0       0 $end <= $$skip[0] and last;
6914 0 0       0 $pos >= $$skip[1] and $pos += $$skip[1] - $$skip[0], next;
6915 0 0       0 if ($pos != $$skip[0]) {
6916 0         0 $$self{HTML_DUMP}->Add($pos, $$skip[0]-$pos, $com, $tip, $flg, $ifd);
6917 0         0 $len -= $$skip[0] - $pos;
6918 0         0 $tip = 'SAME';
6919             }
6920 0         0 $pos = $$skip[1];
6921             }
6922             }
6923 0         0 $$self{HTML_DUMP}->Add($pos, $len, $com, $tip, $flg, $ifd);
6924             }
6925              
6926             #------------------------------------------------------------------------------
6927             # Identify trailer ending at specified offset from end of file
6928             # Inputs: 0) RAF reference, 1) offset from end of file (0 by default)
6929             # Returns: Trailer info hash (with RAF and DirName set),
6930             # or undef if no recognized trailer was found
6931             # Notes: leaves file position unchanged
6932             sub IdentifyTrailer($$;$)
6933             {
6934 585     585 0 1895 my ($self, $raf, $offset) = @_;
6935 585 100       1668 $offset or $offset = 0;
6936 585         2437 my $pos = $raf->Tell();
6937 585         1290 my ($buff, $type, $len);
6938 585   33     2558 while ($raf->Seek(-$offset, 2) and ($len = $raf->Tell()) > 0) {
6939             # read up to 64 bytes before specified offset from end of file
6940 585 50       1887 $len = 64 if $len > 64;
6941 585 50 33     1879 $raf->Seek(-$len, 1) and $raf->Read($buff, $len) == $len or last;
6942 585 100 66     16735 if ($buff =~ /AXS(!|\*).{8}$/s) {
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    100          
    50          
    100          
6943 29         74 $type = 'AFCP';
6944             } elsif ($buff =~ /\xa1\xb2\xc3\xd4$/) {
6945 29         81 $type = 'FotoStation';
6946             } elsif ($buff =~ /cbipcbbl$/) {
6947 34         89 $type = 'PhotoMechanic';
6948             } elsif ($buff =~ /^CANON OPTIONAL DATA\0/) {
6949 41         147 $type = 'CanonVRD';
6950             } elsif ($buff =~ /~\0\x04\0zmie~\0\0\x06.{4}[\x10\x18]\x04$/s or
6951             $buff =~ /~\0\x04\0zmie~\0\0\x0a.{8}[\x10\x18]\x08$/s)
6952             {
6953 26         68 $type = 'MIE';
6954             } elsif ($buff =~ /\0\0(QDIOBS|SEFT)$/) {
6955 26         64 $type = 'Samsung';
6956             } elsif ($buff =~ /8db42d694ccc418790edff439fe026bf$/s) {
6957 0         0 $type = 'Insta360';
6958             } elsif ($buff =~ m(\0{6}/NIKON APP$)) {
6959 0         0 $type = 'NikonApp';
6960             } elsif ($buff =~ /\xff{4}\x1b\*9HWfu\x84\x93\xa2\xb1$/) {
6961 26         79 $type = 'Vivo';
6962             } elsif ($buff =~ /jxrs...\0$/s) {
6963 0         0 $type = 'OnePlus';
6964             } elsif ($$self{ProcessGoogleTrailer}) {
6965             # check for Google trailer information if specific XMP tags exist
6966 1         3 $type = 'Google';
6967             }
6968 585         1355 last;
6969             }
6970 585         2183 $raf->Seek($pos, 0); # restore original file position
6971 585 100       2930 return $type ? { RAF => $raf, DirName => $type } : undef;
6972             }
6973              
6974             #------------------------------------------------------------------------------
6975             # Read/rewrite trailer information (including multiple trailers)
6976             # Inputs: 0) ExifTool object ref, 1) DirInfo ref:
6977             # - requires RAF and DirName
6978             # - OutFile is a scalar reference for writing
6979             # - scans from current file position for each trailer if ScanForTrailer is set
6980             # (current file position is just after JPEG EOF for a JPEG image)
6981             # Returns: 1 if trailer was processed or couldn't be processed (or written OK)
6982             # 0 if trailer was recognized but offsets need fixing (or write error)
6983             # - DirName, DirLen, DataPos, Offset, Fixup and OutFile are updated
6984             # - preserves current file position and byte order
6985             sub ProcessTrailers($$)
6986             {
6987 78     78 0 239 my ($self, $dirInfo) = @_;
6988 78         220 my $dirName = $$dirInfo{DirName};
6989 78         197 my $outfile = $$dirInfo{OutFile};
6990 78   50     461 my $offset = $$dirInfo{Offset} || 0;
6991 78         174 my $fixup = $$dirInfo{Fixup};
6992 78         179 my $raf = $$dirInfo{RAF};
6993 78         240 my $pos = $raf->Tell();
6994 78         321 my $byteOrder = GetByteOrder();
6995 78         194 my $success = 1;
6996 78         188 my $path = $$self{PATH};
6997              
6998             # get position of end of file
6999 78         921 $raf->Seek(0,2);
7000 78         235 $$self{FileEnd} = $raf->Tell();
7001              
7002 78         157 for (;;) { # loop through all trailers
7003 232         881 $raf->Seek($pos);
7004 232         418 my ($proc, $outBuff);
7005             # trailer-processing procs residing in modules of a different name
7006             my $module = {
7007             Insta360 => 'QuickTimeStream.pl',
7008             NikonApp => 'Nikon.pm',
7009             Vivo => 'Trailer.pm',
7010             OnePlus => 'Trailer.pm',
7011             Google => 'Trailer.pm',
7012 232   66     2438 }->{$dirName} || "$dirName.pm";
7013 232         30201 require "Image/ExifTool/$module";
7014 232         2457 $module =~ s/(Stream)?\..*//; # remove extension and change QuickTimeStream to QuickTime
7015 232         607 $proc = "Image::ExifTool::${module}::Process$dirName";
7016 232 100       670 if ($outfile) {
7017             # write to local buffer so we can add trailer in proper order later
7018 57 100       257 $$outfile and $$dirInfo{OutFile} = \$outBuff, $outBuff = '';
7019             # must generate new fixup if necessary so we can shift
7020             # the old fixup separately after we prepend this trailer
7021 57         119 delete $$dirInfo{Fixup};
7022             }
7023 232         509 delete $$dirInfo{DirLen}; # reset trailer length
7024 232         589 $$dirInfo{Offset} = $offset; # set offset from end of file
7025 232         496 $$dirInfo{Trailer} = 1; # set Trailer flag in case proc cares
7026             # add trailer and DirName to SubDirectory PATH
7027 232         592 push @$path, 'Trailer', $dirName;
7028             #
7029             # Call proc to read or write this trailer
7030             #
7031             # Proc inputs:
7032             # 0) ExifTool ref, with FileEnd set, and TrailerStart possibly set (start of all trailers)
7033             # 1) DirInfo with the following elements:
7034             # DirName - name of this trailer
7035             # RAF - RAF reference
7036             # Offset - positive offset from end of this trailer to the end of file
7037             # OutFile - (write mode) scalar reference for output buffer consisting of an empty string
7038             # Trailer - flag set so proc knows we are processing a trailer (if it cares)
7039             # Fixup - optional fixup for pointers in trailer
7040             # ScanForTrailer - set if we should now scan for the trailer start. For JPEG
7041             # images the ExifTool TrailerStart member will also be set, but for TIFF
7042             # images TrailerStart will only be set when writing, so the proc should
7043             # scan from the current file position when reading in a TIFF image.
7044             # Proc returns in read mode (OutFile not set):
7045             # 1 = success
7046             # 0 = error processing trailer (no warning will be issued and remaining trailers will be ignored)
7047             # -1 = must scan from TrailerStart since length can not be determined
7048             # (in which case this routine will be called again later when TrailerStart is known)
7049             # Proc returns in write mode:
7050             # 1 = success (and proc updates OutFile with the trailer to write, or empty string to delete)
7051             # 0 = error processing trailer (will issue minor error)
7052             # -1 = caller to copy or delete the trailer as-is (from TrailerStart if DataPos isn't set)
7053             # - TrailerStart will always be set in write mode
7054             # - the write routine will not be called if all trailers are being deleted
7055             # Proc sets the following elements of $dirInfo in both read and write mode:
7056             # DataPos - file position for start of this trailer
7057             # DirLen - length of this trailer (subsequent trailers are not processed if this is not set)
7058             # Fixup - for any pointers in the trailer that need adjusting
7059             #
7060 113     113   1485 no strict 'refs';
  113         1213  
  113         8787  
7061 232         2480 my $result = &$proc($self, $dirInfo);
7062 113     113   884 use strict 'refs';
  113         440  
  113         2301390  
7063              
7064             # restore PATH (pop last 2 items)
7065 232         777 splice @$path, -2;
7066              
7067 232         906 my ($dataPos, $dirLen) = @$dirInfo{'DataPos','DirLen'};
7068 232 100       1012 if ($outfile) {
    100          
7069 57 100       187 if ($result < 0) {
7070             # copy or delete the trailer ourself
7071 7         18 $result = 1;
7072 7 50       28 if ($$self{TrailerStart}) {
7073 7 50       23 $dataPos or $dataPos = $$self{TrailerStart};
7074 7 50       22 $dirLen or $dirLen = $$self{FileEnd} - $offset - $dataPos;
7075             }
7076 7 50 33     79 if ($$self{DEL_GROUP}{Trailer} or $$self{DEL_GROUP}{$dirName}) {
    50 33        
7077 0 0       0 my $bytes = $dirLen ? " ($dirLen bytes)" : '';
7078 0         0 $self->VPrint(0, "Deleting $dirName trailer$bytes\n");
7079 0         0 ++$$self{CHANGED};
7080             } elsif ($dataPos and $dirLen) {
7081 7         59 $self->VPrint(0, "Copying $dirName trailer ($dirLen bytes)\n");
7082             $result = 0 unless $raf->Seek($dataPos) and
7083 7 50 33     35 $raf->Read(${$$dirInfo{OutFile}}, $dirLen) == $dirLen;
  7         29  
7084             } else {
7085 0         0 $result = 0;
7086             }
7087             }
7088 57 50       169 if ($result > 0) {
7089 57 100       184 if ($outBuff) {
7090             # write trailers to OutFile in original order
7091 40         287 $$outfile = $outBuff . $$outfile;
7092             # must adjust old fixup start if it exists
7093 40 100       163 $$fixup{Start} += length($outBuff) if $fixup;
7094 40         85 $outBuff = ''; # free memory
7095             }
7096 57 100       212 if ($$dirInfo{Fixup}) {
7097 15 100       57 if ($fixup) {
7098             # add fixup for subsequent trailers to the fixup for this trailer
7099             # (but first we must adjust for the new start position)
7100 7         21 $$fixup{Shift} += $$dirInfo{Fixup}{Start};
7101 7         15 $$fixup{Start} -= $$dirInfo{Fixup}{Start};
7102 7         28 $$dirInfo{Fixup}->AddFixup($fixup);
7103             }
7104 15         33 $fixup = $$dirInfo{Fixup}; # save fixup
7105             }
7106             } else {
7107 0 0       0 $success = 0 if $self->Error("Error rewriting $dirName trailer", 2);
7108 0         0 last;
7109             }
7110             } elsif ($result < 0) {
7111             # can't continue if we must scan for this trailer
7112 20         74 $success = 0;
7113 20         58 last;
7114             }
7115 212 100 66     1185 last unless $result > 0 and $dirLen;
7116 211         418 $offset += $dirLen;
7117 211 100 66     1659 last if $dataPos and $$self{TrailerStart} and $dataPos <= $$self{TrailerStart};
      100        
7118             # look for next trailer
7119 182         714 my $nextTrail = $self->IdentifyTrailer($raf, $offset);
7120             # process Google trailer after all others if necessary and not done already
7121 182 100       670 unless ($nextTrail) {
7122 28 50       145 last unless $$self{ProcessGoogleTrailer};
7123 0         0 $nextTrail = { DirName => 'Google', RAF => $raf };
7124             }
7125 154         692 $dirName = $$dirInfo{DirName} = $$nextTrail{DirName};
7126             }
7127 78         321 SetByteOrder($byteOrder); # restore original byte order
7128 78         336 $raf->Seek($pos); # restore original file position
7129 78         269 $$dirInfo{OutFile} = $outfile; # restore original outfile
7130 78         182 $$dirInfo{Offset} = $offset; # return offset from EOF to start of first trailer
7131 78         231 $$dirInfo{Fixup} = $fixup; # return fixup information
7132 78         486 return $success;
7133             }
7134              
7135             #------------------------------------------------------------------------------
7136             # JPEG constants
7137              
7138             # JPEG marker names
7139             %jpegMarker = (
7140             0x00 => 'NULL',
7141             0x01 => 'TEM',
7142             0xc0 => 'SOF0', # to SOF15, with a few exceptions below
7143             0xc4 => 'DHT',
7144             0xc8 => 'JPGA',
7145             0xcc => 'DAC',
7146             0xd0 => 'RST0', # to RST7
7147             0xd8 => 'SOI',
7148             0xd9 => 'EOI',
7149             0xda => 'SOS',
7150             0xdb => 'DQT',
7151             0xdc => 'DNL',
7152             0xdd => 'DRI',
7153             0xde => 'DHP',
7154             0xdf => 'EXP',
7155             0xe0 => 'APP0', # to APP15
7156             0xf0 => 'JPG0',
7157             0xfe => 'COM',
7158             );
7159              
7160             # lookup for size of JPEG marker length word
7161             # (2 bytes assumed unless specified here)
7162             my %markerLenBytes = (
7163             0x00 => 0, 0x01 => 0,
7164             0xd0 => 0, 0xd1 => 0, 0xd2 => 0, 0xd3 => 0, 0xd4 => 0, 0xd5 => 0, 0xd6 => 0, 0xd7 => 0,
7165             0xd8 => 0, 0xd9 => 0, 0xda => 0,
7166             # J2C
7167             0x30 => 0, 0x31 => 0, 0x32 => 0, 0x33 => 0, 0x34 => 0, 0x35 => 0, 0x36 => 0, 0x37 => 0,
7168             0x38 => 0, 0x39 => 0, 0x3a => 0, 0x3b => 0, 0x3c => 0, 0x3d => 0, 0x3e => 0, 0x3f => 0,
7169             0x4f => 0,
7170             0x92 => 0, 0x93 => 0,
7171             # J2C extensions
7172             0x74 => 4, 0x75 => 4, 0x77 => 4,
7173             );
7174              
7175             #------------------------------------------------------------------------------
7176             # Get JPEG marker name
7177             # Inputs: 0) Jpeg number
7178             # Returns: marker name
7179             sub JpegMarkerName($)
7180             {
7181 3200     3200 0 5842 my $marker = shift;
7182 3200         8326 my $markerName = $jpegMarker{$marker};
7183 3200 100       7621 unless ($markerName) {
7184 1180         3827 $markerName = $jpegMarker{$marker & 0xf0};
7185 1180 50 33     10012 if ($markerName and $markerName =~ /^([A-Z]+)\d+$/) {
7186 1180         5145 $markerName = $1 . ($marker & 0x0f);
7187             } else {
7188 0         0 $markerName = sprintf("marker 0x%.2x", $marker);
7189             }
7190             }
7191 3200         8622 return $markerName;
7192             }
7193              
7194             #------------------------------------------------------------------------------
7195             # Adjust directory start position
7196             # Inputs: 0) dirInfo ref, 1) start offset
7197             # 2) Base for offsets (relative to DataPos, defaults to absolute Base of 0)
7198             sub DirStart($$;$)
7199             {
7200 582     582 0 1643 my ($dirInfo, $start, $base) = @_;
7201 582         1520 $$dirInfo{DirStart} = $start;
7202 582         1409 $$dirInfo{DirLen} -= $start;
7203 582 100       1771 if (defined $base) {
7204 279         792 $$dirInfo{Base} = $$dirInfo{DataPos} + $base;
7205 279         881 $$dirInfo{DataPos} = -$base; # (relative to Base!)
7206             }
7207             }
7208              
7209             #------------------------------------------------------------------------------
7210             # Extract metadata from a jpg image
7211             # Inputs: 0) ExifTool object reference, 1) dirInfo ref with RAF set
7212             # 2) tag table ref to process JPEG-like metadata
7213             # Returns: 1 on success, 0 if this wasn't a valid JPEG file
7214             sub ProcessJPEG($$;$)
7215             {
7216 251     251 0 639 local $_;
7217 251         835 my ($self, $dirInfo, $optionalTagTable) = @_;
7218 251         740 my $options = $$self{OPTIONS};
7219 251         711 my $verbose = $$options{Verbose};
7220 251         640 my $out = $$options{TextOut};
7221 251   100     1459 my $fast = $$options{FastScan} || 0;
7222 251         642 my $raf = $$dirInfo{RAF};
7223 251         705 my $req = $$self{REQ_TAG_LOOKUP};
7224 251         696 my $htmlDump = $$self{HTML_DUMP};
7225 251         1473 my %dumpParms = ( Out => $out, Prefix => $$self{INDENT} );
7226 251         1810 my ($ch, $s, $length, $hash, $hashsize, $indent);
7227 251         0 my ($success, $wantTrailer, $trailInfo, $foundSOS, $gotSize, %jumbfChunk);
7228 251         0 my (@iccChunk, $iccChunkCount, $iccChunksTotal, @flirChunk, $flirCount, $flirTotal);
7229 251         0 my ($preview, $scalado, @dqt, $subSampling, $dumpEnd, %extendedXMP);
7230              
7231 251         1971 ($indent = $$self{INDENT}) =~ s/ $//;
7232 251 50       976 unless ($raf) {
7233 0         0 $raf = File::RandomAccess->new($$dirInfo{DataPt});
7234 0         0 $self->VerboseDir('JPEG', undef, length(${$$dirInfo{DataPt}}));
  0         0  
7235             }
7236             # get pointer to hash object if it exists and we are the top-level JPEG or JP2
7237 251 100 100     2572 if ($$self{FILE_TYPE} =~ /^(JPEG|JP2)$/ and not $$self{DOC_NUM}) {
7238 242         694 $hash = $$self{ImageDataHash};
7239 242         555 $hashsize = 0;
7240             }
7241             # check to be sure this is a valid JPG (or J2C, or EXV) file
7242 251 50 33     1044 if ($raf->Read($s, 2) == 2 and $s =~ /^\xff[\xd8\x4f\x01]/) {
7243 251         690 undef $optionalTagTable;
7244             } else {
7245 0 0 0     0 return 0 unless $optionalTagTable and $s =~ /^\xff[\xe0-\xef]/;
7246 0 0       0 $raf->Seek(-2, 1) or $self->Error('Seek error'), return 1;
7247             }
7248 251 100       1003 if ($s eq "\xff\x01") {
7249 2 50 33     27 return 0 unless $raf->Read($s, 5) == 5 and $s eq 'Exiv2';
7250 2         10 $$self{FILE_TYPE} = 'EXV';
7251             }
7252 251         551 my $appBytes = 0;
7253 251         642 my $calcImageLen = $$req{jpegimagelength};
7254 251 50 66     1414 if ($$options{RequestAll} and $$options{RequestAll} > 2) {
7255 0         0 $calcImageLen = 1;
7256             }
7257 251 100 66     1399 if (not $$self{VALUE}{FileType} or ($$self{DOC_NUM} and $$options{ExtractEmbedded})) {
      66        
7258 243         1680 $self->SetFileType(); # set FileType tag
7259 243 100       821 return 1 if $fast > 2; # don't process file when FastScan > 2
7260 242         918 $$self{LOW_PRIORITY_DIR}{IFD1} = 1; # lower priority of IFD1 tags
7261             }
7262 250 100       1139 $$raf{NoBuffer} = 1 if $self->Options('FastScan'); # disable buffering in FastScan mode
7263              
7264 250 50       1273 $dumpParms{MaxLen} = 128 if $verbose < 4;
7265 250 50 33     984 if ($htmlDump and not $optionalTagTable) {
7266 0         0 $dumpEnd = $raf->Tell();
7267 0 0       0 my ($n, $t, $m) = $s eq 'Exiv2' ? (7,'EXV','TEM') : (2,'JPEG','SOI');
7268 0         0 my $pos = $dumpEnd - $n;
7269 0 0       0 $self->HDump(0, $pos, '[unknown header]') if $pos;
7270 0         0 $self->HDump($pos, $n, "$t header", "$m Marker");
7271             }
7272 250         772 my $path = $$self{PATH};
7273 250         646 my $pn = scalar @$path;
7274              
7275             # set input record separator to 0xff (the JPEG marker) to make reading quicker
7276 250         1704 local $/ = "\xff";
7277              
7278 250         680 my ($nextMarker, $nextSegDataPt, $nextSegPos, $combinedSegData, $firstSegPos, @skipData);
7279              
7280             # read file until we reach an end of image (EOI) or start of scan (SOS)
7281 250         582 Marker: for (;;) {
7282             # set marker and data pointer for current segment
7283 2217         4895 my $marker = $nextMarker;
7284 2217 50 66     9407 last if $marker and $marker < 0;
7285 2217         3916 my $segDataPt = $nextSegDataPt;
7286 2217         3416 my $segPos = $nextSegPos;
7287 2217         3237 my $skipped;
7288 2217         4082 undef $nextMarker;
7289 2217         3773 undef $nextSegDataPt;
7290             #
7291             # read ahead to the next segment unless we have reached EOI, SOS or SOD
7292             #
7293 2217   100     16742 until ($marker and ($marker==0xd9 or ($marker==0xda and not $wantTrailer and not $hash) or
      100        
7294             $marker==0x93))
7295             {
7296             # read up to next marker (JPEG markers begin with 0xff)
7297 1946         3053 my $buff;
7298 1946 50       9749 unless ($raf->ReadLine($buff)) {
7299 0 0       0 last Marker unless $optionalTagTable;
7300 0         0 $nextMarker = -1;
7301 0         0 $success = 1;
7302 0         0 last;
7303             }
7304 1946         3940 $skipped = length($buff) - 1;
7305             # JPEG markers can be padded with unlimited 0xff's
7306 1946         3240 for (;;) {
7307 1946 50       6001 $raf->Read($ch, 1) or last Marker;
7308 1946         3923 $nextMarker = ord($ch);
7309 1946 50       5281 last unless $nextMarker == 0xff;
7310 0         0 ++$skipped;
7311             }
7312             # read segment data if it exists
7313 1946 100 33     8167 if (not defined $markerLenBytes{$nextMarker}) {
    50 0        
    50 33        
7314             # read record length word
7315 1675 50       4352 last Marker unless $raf->Read($s, 2) == 2;
7316 1675         5060 my $len = unpack('n',$s); # get data length
7317 1675 50 33     7323 last Marker unless defined($len) and $len >= 2;
7318 1675         5036 $nextSegPos = $raf->Tell();
7319 1675         2991 $len -= 2; # subtract size of length word
7320 1675 50       4111 last Marker unless $raf->Read($buff, $len) == $len;
7321 1675         3573 $nextSegDataPt = \$buff; # set pointer to our next data
7322             } elsif ($markerLenBytes{$nextMarker} == 4) {
7323             # handle J2C extensions with 4-byte length word
7324 0 0       0 last Marker unless $raf->Read($s, 4) == 4;
7325 0         0 my $len = unpack('N',$s); # get data length
7326 0 0 0     0 last Marker unless defined($len) and $len >= 4;
7327 0         0 $nextSegPos = $raf->Tell();
7328 0         0 $len -= 4; # subtract size of length word
7329 0 0       0 last Marker unless $raf->Seek($len, 1);
7330             } elsif ($hash and defined $marker and ($marker == 0x00 or $marker == 0xda or
7331             ($marker >= 0xd0 and $marker <= 0xd7)))
7332             {
7333             # calculate hash for image data (includes leading ff d9 but not trailing ff da)
7334 0         0 $hash->add("\xff" . chr($marker));
7335 0         0 my $n = $skipped - (length($buff) - 1); # number of extra 0xff's
7336 0 0       0 if (not $n) {
    0          
7337 0         0 $buff = substr($buff, 0, -1); # remove trailing 0xff
7338             } elsif ($n > 1) {
7339 0         0 $buff .= "\xff" x ($n - 1); # add back extra 0xff's
7340             }
7341 0         0 $hash->add($buff);
7342 0         0 $hashsize += $skipped + 2;
7343             }
7344             # read second segment too if this was the first
7345 1946 100       4997 next Marker unless defined $marker;
7346 1675         3248 last;
7347             }
7348             # set some useful variables for the current segment
7349 1946         5660 my $markerName = JpegMarkerName($marker);
7350 1946         4977 $$path[$pn] = $markerName;
7351             # issue warning if we skipped some garbage
7352 1946 0 33     5569 if ($skipped and not $foundSOS and $markerName ne 'SOS') {
      33        
7353 0         0 $self->Warn("Skipped unknown $skipped bytes after JPEG $markerName segment", 1);
7354 0 0       0 if ($htmlDump) {
7355 0         0 $self->HDump($nextSegPos-4-$skipped, $skipped, "[unknown $skipped bytes]", undef, 0x08);
7356 0         0 $dumpEnd = $nextSegPos - 4;
7357             }
7358             }
7359             #
7360             # parse the current segment
7361             #
7362             # handle SOF markers: SOF0-SOF15, except DHT(0xc4), JPGA(0xc8) and DAC(0xcc)
7363 1946 100 66     20824 if (($marker & 0xf0) == 0xc0 and ($marker == 0xc0 or $marker & 0x03)) {
    100 100        
    100 66        
    100 33        
    50 66        
    100          
7364 247         631 $length = length $$segDataPt;
7365 247 100       1207 if ($verbose) {
    50          
7366 2         10 print $out "${indent}JPEG $markerName ($length bytes):\n";
7367 2 100       16 HexDump($segDataPt, undef, %dumpParms, Addr=>$segPos) if $verbose>2;
7368             } elsif ($htmlDump) {
7369 0         0 $self->HDump($segPos-4, $length+4, "[JPEG $markerName]", undef, 0x08);
7370 0         0 $dumpEnd = $segPos + $length;
7371             }
7372 247 50 33     1388 next if $length < 6 or $gotSize;
7373 247         1980 $gotSize = 1; # (ignore subsequent SOF segments in probably corrupted JPEG)
7374             # extract some useful information
7375 247         1303 my ($p, $h, $w, $n) = unpack('Cn2C', $$segDataPt);
7376 247         1113 my $sof = GetTagTable('Image::ExifTool::JPEG::SOF');
7377 247         1390 $self->HandleTag($sof, 'ImageWidth', $w);
7378 247         1013 $self->HandleTag($sof, 'ImageHeight', $h);
7379 247         1049 $self->HandleTag($sof, 'EncodingProcess', $marker - 0xc0);
7380 247         976 $self->HandleTag($sof, 'BitsPerSample', $p);
7381 247         1159 $self->HandleTag($sof, 'ColorComponents', $n);
7382 247 50 33     1620 next unless $n == 3 and $length >= 15;
7383 247         631 my ($i, $hmin, $hmax, $vmin, $vmax);
7384             # loop through all components to determine sampling frequency
7385 247         666 $subSampling = '';
7386 247         1045 for ($i=0; $i<$n; ++$i) {
7387 741         2087 my $sf = Get8u($segDataPt, 7 + 3 * $i);
7388 741         2476 $subSampling .= sprintf('%.2x', $sf);
7389             # isolate horizontal and vertical components
7390 741         1723 my ($hf, $vf) = ($sf >> 4, $sf & 0x0f);
7391 741 100       1771 unless ($i) {
7392 247         583 $hmin = $hmax = $hf;
7393 247         539 $vmin = $vmax = $vf;
7394 247         987 next;
7395             }
7396             # determine min/max frequencies
7397 494 100       1221 $hmin = $hf if $hf < $hmin;
7398 494 50       1391 $hmax = $hf if $hf > $hmax;
7399 494 100       1213 $vmin = $vf if $vf < $vmin;
7400 494 50       1717 $vmax = $vf if $vf > $vmax;
7401             }
7402 247 50 33     1388 if ($hmin and $vmin) {
7403 247         918 my ($hs, $vs) = ($hmax / $hmin, $vmax / $vmin);
7404 247         2533 $self->HandleTag($sof, 'YCbCrSubSampling', "$hs $vs");
7405             }
7406 247         833 next;
7407             } elsif ($marker == 0xd9) { # EOI
7408 23         63 pop @$path;
7409 23 100       105 $verbose and print $out "${indent}JPEG EOI\n";
7410 23         87 my $pos = $raf->Tell();
7411 23 50       147 $$self{TrailerStart} = $pos unless $$self{DOC_NUM};
7412 23 50 33     104 if ($htmlDump and $dumpEnd) {
7413 0         0 $self->HDump($dumpEnd, $pos-2-$dumpEnd, '[JPEG Image Data]', undef, 0x08);
7414 0         0 $self->HDump($pos-2, 2, 'JPEG EOI', undef);
7415 0         0 $dumpEnd = 0;
7416             }
7417 23 50 66     102 if ($foundSOS or $$self{FILE_TYPE} eq 'EXV') {
7418 23         56 $success = 1;
7419             } else {
7420 0         0 $self->Warn('Missing JPEG SOS');
7421             }
7422 23 50       84 if ($$req{trailer}) {
7423             # read entire trailer into memory
7424 0 0       0 if ($raf->Seek(0,2)) {
7425 0         0 my $len = $raf->Tell() - $pos;
7426 0 0       0 if ($len) {
7427 0         0 my $buff;
7428 0         0 $raf->Seek($pos, 0);
7429 0 0       0 $self->FoundTag(Trailer => \$buff) if $raf->Read($buff,$len) == $len;
7430 0         0 $raf->Seek($pos, 0);
7431             }
7432             } else {
7433 0         0 $self->Warn('Error seeking in file');
7434             }
7435             }
7436             # we are here because we are looking for trailer information
7437 23 50       86 if ($wantTrailer) {
7438 0         0 my $start = $$self{PreviewImageStart};
7439 0 0 0     0 if ($start or $$options{ExtractEmbedded}) {
7440 0         0 my $buff;
7441             # most previews start right after the JPEG EOI, but the Olympus E-20
7442             # preview is 508 bytes into the trailer, the K-M Maxxum 7D preview is
7443             # 979 bytes in, and Sony previews can start up to 32 kB into the trailer.
7444             # (and Minolta and Sony previews can have a random first byte...)
7445 0 0       0 my $scanLen = $$self{Make} =~ /Sony/i ? 65536 : 1024;
7446 0 0       0 if ($raf->Read($buff, $scanLen)) {
7447 0 0 0     0 if ($buff =~ /^.{4}ftyp/s) {
    0 0        
7448 0         0 my $val;
7449 0 0       0 if ($raf->Seek(0,2)) {
7450 0         0 my $len = $raf->Tell() - $pos;
7451 0 0       0 if ($$options{Binary}) {
7452 0 0 0     0 $val = \$buff if $raf->Seek($pos,0) and $raf->Read($buff,$len)==$len;
7453             } else {
7454 0         0 $val = \ "Binary data $len bytes";
7455             }
7456 0 0       0 if ($val) {
7457 0         0 $self->FoundTag('EmbeddedVideo', $val);
7458             } else {
7459 0         0 $self->Warn('Error reading trailer');
7460             }
7461             } else {
7462 0         0 $self->Warn('Error seeking to end of file');
7463             }
7464             } elsif ($buff =~ /\xff\xd8\xff./g or
7465             ($$self{Make} =~ /(Minolta|Sony)/i and $buff =~ /.\xd8\xff\xdb/g))
7466             {
7467             # adjust PreviewImageStart to this location
7468 0         0 my $actual = $pos + pos($buff) - 4;
7469 0 0 0     0 if ($start and $start ne $actual and $verbose > 1) {
      0        
7470 0         0 print $out "${indent}(Fixed PreviewImage location: $start -> $actual)\n";
7471             }
7472             # update preview image offsets
7473 0 0       0 if ($start) {
7474 0 0       0 $$self{VALUE}{PreviewImageStart} = $actual if $$self{VALUE}{PreviewImageStart};
7475 0         0 $$self{PreviewImageStart} = $actual;
7476             }
7477             # load preview now if we tried and failed earlier
7478 0 0 0     0 if ($$self{PreviewError} and $$self{PreviewImageLength}) {
7479 0 0 0     0 if ($raf->Seek($actual, 0) and $raf->Read($buff, $$self{PreviewImageLength})) {
7480 0         0 $self->FoundTag('PreviewImage', $buff);
7481 0         0 delete $$self{PreviewError};
7482             }
7483             }
7484             }
7485             }
7486 0         0 $raf->Seek($pos, 0);
7487             }
7488             }
7489             # process trailer now or finish processing trailers
7490             # and scan for AFCP if necessary
7491 23         61 my $fromEnd = 0;
7492 23 100       218 if ($trailInfo) {
7493 20         76 $$trailInfo{ScanForTrailer} = 1; # scan now if necessary
7494 20         83 $self->ProcessTrailers($trailInfo);
7495             # save offset from end of file to start of first trailer
7496 20         73 $fromEnd = $$trailInfo{Offset};
7497 20         98 undef $trailInfo;
7498             }
7499 23 50       104 if ($$self{LeicaTrailer}) {
7500 0         0 $raf->Seek(0, 2);
7501 0         0 $$self{LeicaTrailer}{TrailPos} = $pos;
7502 0         0 $$self{LeicaTrailer}{TrailLen} = $raf->Tell() - $pos - $fromEnd;
7503 0         0 Image::ExifTool::Panasonic::ProcessLeicaTrailer($self);
7504             }
7505             # finally, dump remaining information in JPEG trailer
7506 23 100 66     143 if ($verbose or $htmlDump) {
7507 1         7 my $endPos = $$self{LeicaTrailerPos};
7508 1 50       5 unless ($endPos) {
7509 1         6 $raf->Seek(0, 2);
7510 1         5 $endPos = $raf->Tell() - $fromEnd;
7511             }
7512             $self->DumpUnknownTrailer({
7513 1 50       5 RAF => $raf,
7514             DataPos => $pos,
7515             DirLen => $endPos - $pos
7516             }) if $endPos > $pos;
7517             }
7518 23 50       73 $self->FoundTag('JPEGImageLength', $pos - $appBytes) if $calcImageLen;
7519 23         77 last; # all done parsing file
7520             } elsif ($marker == 0xda) { # SOS
7521 247         547 pop @$path;
7522 247         547 $foundSOS = 1;
7523             # all done with meta information unless we have a trailer
7524 247 100       799 $verbose and print $out "${indent}JPEG SOS\n";
7525             # process extended XMP now if it existed
7526             # (must do this before trailers because XMP is required to process Google trailer)
7527 247 100       767 if (%extendedXMP) {
7528 2         5 my $guid;
7529             # GUID indicated by the last main XMP segment
7530 2   50     12 my $goodGuid = $$self{VALUE}{HasExtendedXMP} || '';
7531             # GUID of the extended XMP that we will process ('2' for all)
7532 2   50     15 my $readGuid = $$options{ExtendedXMP} || 0;
7533 2 50       12 $readGuid = $goodGuid if $readGuid eq '1';
7534 2         10 foreach $guid (sort keys %extendedXMP) {
7535 2 50       11 next unless length $guid == 32; # ignore other (internal) keys
7536 2         6 my $extXMP = $extendedXMP{$guid};
7537 2         6 my ($off, @offsets, $warn);
7538             # make sure we have all chunks, and create a list of sorted offsets
7539 2         11 for ($off=0; $off<$$extXMP{Size}; ) {
7540 3 50       14 last unless defined $$extXMP{$off};
7541 3         9 push @offsets, $off;
7542 3         12 $off += length $$extXMP{$off};
7543             }
7544 2 50       10 unless ($off == $$extXMP{Size}) {
7545 0         0 $self->Warn("Incomplete extended XMP (GUID $guid)");
7546 0         0 next;
7547             }
7548 2 50 33     15 if ($guid eq $readGuid or $readGuid eq '2') {
7549 2 50       8 $warn = 'Reading non-' if $guid ne $goodGuid;
7550 2         6 my $buff = '';
7551             # assemble XMP all together
7552 2         77 $buff .= $$extXMP{$_} foreach @offsets;
7553 2         11 my $tagTablePtr = GetTagTable('Image::ExifTool::XMP::Main');
7554 2         14 my %dirInfo = (
7555             DataPt => \$buff,
7556             Parent => 'APP1',
7557             IsExtended => 1,
7558             );
7559 2         6 $$path[$pn] = 'APP1';
7560 2         16 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7561 2         11 pop @$path;
7562             } else {
7563 0         0 $warn = 'Ignored ';
7564 0 0       0 $warn .= 'non-' if $guid ne $goodGuid;
7565             }
7566 2 50       8 $self->Warn("${warn}standard extended XMP (GUID $guid)") if $warn;
7567 2         14 delete $extendedXMP{$guid};
7568             }
7569             }
7570 247 100       862 unless ($fast) {
7571 246         1576 $trailInfo = $self->IdentifyTrailer($raf);
7572             # process trailer now unless we are doing verbose dump
7573 246 50 66     1355 if ($trailInfo and $verbose < 3 and not $htmlDump) {
      66        
7574             # process trailers (keep trailInfo to finish processing later
7575             # only if we can't finish without scanning from JPEG EOF)
7576 29 100       283 $self->ProcessTrailers($trailInfo) and undef $trailInfo;
7577             }
7578 246 0 33     830 if ($wantTrailer and $$self{PreviewImageStart}) {
7579             # seek ahead and validate preview image
7580 0         0 my $buff;
7581 0         0 my $curPos = $raf->Tell();
7582 0 0 0     0 if ($raf->Seek($$self{PreviewImageStart}, 0) and
      0        
7583             $raf->Read($buff, 4) == 4 and
7584             $buff =~ /^.\xd8\xff[\xc4\xdb\xe0-\xef]/)
7585             {
7586 0         0 undef $wantTrailer;
7587             }
7588 0 0       0 $raf->Seek($curPos, 0) or last;
7589             }
7590             # seek ahead and process Leica trailer
7591 246 50 33     2740 if ($$self{LeicaTrailer}) {
    50 0        
      0        
      33        
7592 0         0 require Image::ExifTool::Panasonic;
7593 0         0 Image::ExifTool::Panasonic::ProcessLeicaTrailer($self);
7594 0 0       0 $wantTrailer = 1 if $$self{LeicaTrailer};
7595             } elsif ($$options{ExtractEmbedded} or ($$self{VALUE}{HiddenDataOffset} and
7596             $$self{VALUE}{HiddenDataLength} and ($$options{Validate} or $$req{hiddendata})))
7597             {
7598 0         0 $wantTrailer = 1;
7599             }
7600 246 100 66     2504 next if $trailInfo or $wantTrailer or $verbose > 2 or $htmlDump;
      100        
      66        
7601             }
7602             # must scan to EOI if Validate or JpegCompressionFactor used
7603 226 50 33     2649 next if $$options{Validate} or $calcImageLen or $$req{trailer} or $hash;
      33        
      33        
7604             # nothing interesting to parse after start of scan (SOS)
7605 226         508 $success = 1;
7606 226         684 last; # all done parsing file
7607             } elsif ($marker == 0x93) {
7608 1         3 pop @$path;
7609 1 50       4 $verbose and print $out "${indent}JPEG SOD\n";
7610 1         3 $success = 1;
7611 1 50 33     5 if ($hash and $$self{FILE_TYPE} eq 'JP2') {
7612 0         0 my $pos = $raf->Tell();
7613 0         0 $self->ImageDataHash($raf, undef, 'SOD');
7614 0         0 $raf->Seek($pos, 0);
7615             }
7616 1 50 33     9 next if $verbose > 2 or $htmlDump;
7617 1         3 last; # all done parsing file
7618             } elsif (defined $markerLenBytes{$marker}) {
7619             # handle other stand-alone markers and segments we skipped over
7620 0 0 0     0 if ($verbose and $marker) {
7621 0 0 0     0 next if $verbose < 4 and ($marker & 0xf8) == 0xd0;
7622 0         0 print $out "${indent}JPEG $markerName\n";
7623             }
7624 0         0 next;
7625             } elsif ($marker == 0xdb and length($$segDataPt) and # DQT
7626             # save the DQT data only if JPEGDigest has been requested
7627             # (Note: since we aren't checking the API RequestAll option here, the application
7628             # must use the RequestTags option to generate these tags if they have not been
7629             # specifically requested. The reason is that there is too much overhead involved
7630             # in the calculation of this tag to make this worth the CPU time.)
7631             ($$req{jpegdigest} or $$req{jpegqualityestimate}
7632             or ($$options{RequestAll} and $$options{RequestAll} > 2)))
7633             {
7634 1         6 my $num = unpack('C',$$segDataPt) & 0x0f; # get table index
7635 1 50       10 $dqt[$num] = $$segDataPt if $num < 4; # save for hash calculation
7636             }
7637             # handle all other markers
7638 1428         3175 my $dumpType = '';
7639 1428         2791 my ($desc, $tip, $xtra, $useJpegMain);
7640 1428         2529 $length = length $$segDataPt;
7641 1428 100       4639 $appBytes += $length + 4 if ($marker & 0xf0) == 0xe0; # total size of APP segments
7642 1428 100       3698 if ($verbose) {
7643 6         22 print $out "${indent}JPEG $markerName ($length bytes):\n";
7644 6 100       23 if ($verbose > 2) {
7645 3         12 my %extraParms = ( Addr => $segPos );
7646 3 50       10 $extraParms{MaxLen} = 128 if $verbose == 4;
7647 3         43 HexDump($segDataPt, undef, %dumpParms, %extraParms);
7648             }
7649             }
7650             # prepare dirInfo hash for processing this information
7651 1428         10687 my %dirInfo = (
7652             Parent => $markerName,
7653             DataPt => $segDataPt,
7654             DataPos => $segPos,
7655             DataLen => $length,
7656             DirStart => 0,
7657             DirLen => $length,
7658             Base => 0,
7659             );
7660 1428 100       18857 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          
7661 108 100       1057 if ($$segDataPt =~ /^JFIF\0/) {
    100          
    100          
    50          
7662 51         130 $dumpType = 'JFIF';
7663 51         272 DirStart(\%dirInfo, 5); # start at byte 5
7664 51         1278 SetByteOrder('MM');
7665 51         216 my $tagTablePtr = GetTagTable('Image::ExifTool::JFIF::Main');
7666 51         296 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7667             } elsif ($$segDataPt =~ /^JFXX\0(\x10|\x11|\x13)/) {
7668 19         67 my $tag = ord $1;
7669 19         45 $dumpType = 'JFXX';
7670 19         83 my $tagTablePtr = GetTagTable('Image::ExifTool::JFIF::Extension');
7671 19         81 my $tagInfo = $self->GetTagInfo($tagTablePtr, $tag);
7672 19         113 $self->FoundTag($tagInfo, substr($$segDataPt, 6));
7673             } elsif ($$segDataPt =~ /^(II|MM).{4}HEAPJPGM/s) {
7674 19 50       90 next if $fast > 1; # skip processing for very fast
7675 19         54 $dumpType = 'CIFF';
7676 19         141 my %dirInfo = ( RAF => File::RandomAccess->new($segDataPt) );
7677 19         90 $$self{SET_GROUP1} = 'CIFF';
7678 19         43 push @{$$self{PATH}}, 'CIFF';
  19         66  
7679 19         2362 require Image::ExifTool::CanonRaw;
7680 19         161 Image::ExifTool::CanonRaw::ProcessCRW($self, \%dirInfo);
7681 19         43 pop @{$$self{PATH}};
  19         67  
7682 19         134 delete $$self{SET_GROUP1};
7683             } elsif ($$segDataPt =~ /^(AVI1|Ocad)/) {
7684 19         85 $dumpType = $1;
7685 19         71 SetByteOrder('MM');
7686 19         100 my $tagTablePtr = GetTagTable("Image::ExifTool::JPEG::$dumpType");
7687 19         100 DirStart(\%dirInfo, 4);
7688 19         88 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7689             }
7690             } elsif ($marker == 0xe1) { # APP1 (EXIF, XMP, QVCI, PARROT)
7691             # (some Kodak cameras don't put a second "\0", and I have seen an
7692             # example where there was a second 4-byte APP1 segment header)
7693 280 100 66     3935 if ($$segDataPt =~ /^(.{0,4})Exif\0./is) {
    100          
    100          
    100          
    50          
7694 203         465 undef $dumpType; # (will be dumped here)
7695             # this is EXIF data --
7696             # get the data block (into a common variable)
7697 203         553 my $hdrLen = length($exifAPP1hdr);
7698 203 50       1527 if (length $1) {
    50          
7699 0         0 $hdrLen += length $1;
7700 0         0 $self->Warn('Unknown garbage at start of EXIF segment',1);
7701             } elsif ($$segDataPt !~ /^Exif\0/) {
7702 0         0 $self->Warn('Incorrect EXIF segment identifier',1);
7703             }
7704 203 50       683 if ($htmlDump) {
7705 0         0 $self->HDump($segPos-4, 4, 'APP1 header', "Data size: $length bytes");
7706 0         0 $self->HDump($segPos, $hdrLen, 'Exif header', 'APP1 data type: Exif');
7707 0         0 $dumpEnd = $segPos + $length;
7708             }
7709 203         461 my $dataPt = $segDataPt;
7710 203 50       652 if (defined $combinedSegData) {
7711 0         0 push @skipData, [ $segPos-4, $segPos+$hdrLen ];
7712 0         0 $combinedSegData .= substr($$segDataPt,$hdrLen);
7713 0         0 undef $$segDataPt;
7714 0         0 $dataPt = \$combinedSegData;
7715 0         0 $segPos = $firstSegPos;
7716             }
7717             # peek ahead to see if the next segment is extended EXIF
7718 203 50 66     1549 if ($nextMarker == $marker and
7719             $$nextSegDataPt =~ /^$exifAPP1hdr(?!(MM\0\x2a|II\x2a\0))/)
7720             {
7721             # initialize combined data if necessary
7722 0 0       0 unless (defined $combinedSegData) {
7723 0         0 $combinedSegData = $$segDataPt;
7724 0         0 undef $$segDataPt;
7725 0         0 $firstSegPos = $segPos;
7726 0         0 $self->Warn('File contains multi-segment EXIF',1);
7727 0         0 $$self{ExtendedEXIF} = 1;
7728             }
7729 0         0 next;
7730             }
7731 203         546 $dirInfo{DataPt} = $dataPt;
7732 203         494 $dirInfo{DataPos} = $segPos;
7733 203         618 $dirInfo{DataLen} = $dirInfo{DirLen} = length $$dataPt;
7734 203         972 DirStart(\%dirInfo, $hdrLen, $hdrLen);
7735 203 50       679 $$self{SkipData} = \@skipData if @skipData;
7736             # extract the EXIF information (it is in standard TIFF format)
7737 203 50       1058 $self->ProcessTIFF(\%dirInfo) or $self->Warn('Malformed APP1 EXIF segment');
7738             # scan for Vivo HiddenData if necessary
7739 203 0 0     1086 if ($$self{Make} eq 'vivo' and
      33        
      33        
7740             # (stored as UserComment by some models)
7741             not ($$self{VALUE}{UserComment} and $$self{VALUE}{UserComment} =~ /^filter:/) and
7742             $$dataPt =~ /(filter: .*?; \n)\0/sg)
7743             {
7744 0 0       0 if ($htmlDump) {
7745 0         0 my $n = length($1) + 1;
7746 0         0 $self->HDump($segPos+pos($$dataPt)-$n, $n, '[Vivo HiddenData]', undef, 0x08);
7747             }
7748 0         0 my $tbl = GetTagTable('Image::ExifTool::Trailer::Vivo');
7749 0         0 $self->HandleTag($tbl, HiddenData => $1);
7750             }
7751             # avoid looking for preview unless necessary because it really slows
7752             # us down -- only look for it if we found pointer, and preview is
7753             # outside EXIF, and PreviewImage is specifically requested
7754 203         1267 my $start = $self->GetValue('PreviewImageStart', 'ValueConv');
7755 203         727 my $plen = $self->GetValue('PreviewImageLength', 'ValueConv');
7756 203 100 66     1023 if (not $start or not $plen and $$self{PreviewError}) {
      66        
7757 187         486 $start = $$self{PreviewImageStart};
7758 187         485 $plen = $$self{PreviewImageLength};
7759             }
7760 203 0 100     1000 if ($start and $plen and IsInt($start) and IsInt($plen) and
      66        
      66        
      33        
      0        
      33        
7761             $start + $plen > $$self{EXIF_POS} + length($$self{EXIF_DATA}) and
7762             ($$req{previewimage} or
7763             # (extracted normally, so check Binary option)
7764             ($$options{Binary} and not $$self{EXCL_TAG_LOOKUP}{previewimage})))
7765             {
7766 0         0 $$self{PreviewImageStart} = $start;
7767 0         0 $$self{PreviewImageLength} = $plen;
7768 0         0 $wantTrailer = 1;
7769             }
7770 203 50       712 if (@skipData) {
7771 0         0 undef @skipData;
7772 0         0 delete $$self{SkipData};
7773             }
7774 203         738 undef $$dataPt;
7775 203         1327 next;
7776             } elsif ($$segDataPt =~ /^$xmpExtAPP1hdr/) {
7777             # off len -- extended XMP header (75 bytes total):
7778             # 0 35 bytes - signature
7779             # 35 32 bytes - GUID (MD5 hash of full extended XMP data in ASCII)
7780             # 67 4 bytes - total size of extended XMP data
7781             # 71 4 bytes - offset for this XMP data portion
7782 3         12 $dumpType = 'Extended XMP';
7783 3 50       14 if ($length > 75) {
7784 3         15 my ($size, $off) = unpack('x67N2', $$segDataPt);
7785 3         11 my $guid = substr($$segDataPt, 35, 32);
7786 3 50       14 if ($guid =~ /[^A-Za-z0-9]/) { # (technically, should be uppercase)
7787 0         0 $self->Warn($tip = 'Invalid extended XMP GUID');
7788             } else {
7789 3         10 my $extXMP = $extendedXMP{$guid};
7790 3 100       16 if (not $extXMP) {
    50          
7791 2         9 $extXMP = $extendedXMP{$guid} = { };
7792             } elsif ($size != $$extXMP{Size}) {
7793 0         0 $self->Warn('Inconsistent extended XMP size');
7794             }
7795 3         10 $$extXMP{Size} = $size;
7796 3         73 $$extXMP{$off} = substr($$segDataPt, 75);
7797 3         21 $tip = "Full length: $size\nChunk offset: $off\nChunk length: " .
7798             ($length - 75) . "\nGUID: $guid";
7799             # (delay processing extended XMP until after reading all segments)
7800             }
7801             } else {
7802 0         0 $self->Warn($tip = 'Invalid extended XMP segment');
7803             }
7804             } elsif ($$segDataPt =~ /^QVCI\0/) {
7805 1         3 $dumpType = 'QVCI';
7806 1         4 my $tagTablePtr = GetTagTable('Image::ExifTool::Casio::QVCI');
7807 1         7 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7808             } elsif ($$segDataPt =~ /^FLIR\0/ and $length >= 8) {
7809 1         4 $dumpType = 'FLIR';
7810             # must concatenate FLIR chunks (note: handle the case where
7811             # some software erroneously writes zeros for the chunk counts)
7812 1         4 my $chunkNum = Get8u($segDataPt, 6);
7813 1         5 my $chunksTot = Get8u($segDataPt, 7) + 1; # (note the "+ 1"!)
7814 1 50       5 $verbose and printf $out "${indent}FLIR chunk %d of %d\n",
7815             $chunkNum + 1, $chunksTot;
7816 1 50       3 if (defined $flirTotal) {
7817             # abort parsing FLIR if the total chunk count is inconsistent
7818 0 0       0 undef $flirCount if $chunksTot != $flirTotal;
7819             } else {
7820 1         18 $flirCount = 0;
7821 1         4 $flirTotal = $chunksTot;
7822             }
7823 1 50       11 if (defined $flirCount) {
7824 1 50       5 if (defined $flirChunk[$chunkNum]) {
7825 0         0 $self->Warn('Duplicate FLIR chunk number(s)');
7826 0         0 $flirChunk[$chunkNum] .= substr($$segDataPt, 8);
7827             } else {
7828 1         11 $flirChunk[$chunkNum] = substr($$segDataPt, 8);
7829             }
7830             # process the FLIR information if we have all of the chunks
7831 1 50       5 if (++$flirCount >= $flirTotal) {
7832 1         3 my $flir = '';
7833 1   33     15 defined $_ and $flir .= $_ foreach @flirChunk;
7834 1         3 undef @flirChunk; # free memory
7835 1         6 my $tagTablePtr = GetTagTable('Image::ExifTool::FLIR::FFF');
7836 1         8 my %dirInfo = (
7837             DataPt => \$flir,
7838             Parent => $markerName,
7839             DirName => 'FLIR',
7840             );
7841 1         6 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7842 1         7 undef $flirCount; # prevent reprocessing
7843             }
7844             } else {
7845 0         0 $self->Warn('Invalid or extraneous FLIR chunk(s)');
7846             }
7847             } elsif ($$segDataPt =~ /^PARROT\0(II\x2a\0|MM\0\x2a)/) {
7848             # (don't know if this could span multiple segments)
7849 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::Main');
7850 0         0 $self->HandleTag($tagTablePtr, 'APP1', $$segDataPt);
7851 0         0 $dumpType = 'Parrot';
7852             } else {
7853             # Hmmm. Could be XMP, let's see
7854 72         213 my $processed;
7855 72 50 33     620 if ($$segDataPt =~ /^(http|XMP\0)/ or $$segDataPt =~ /<(exif:|\?xpacket)/) {
7856 72         238 $dumpType = 'XMP';
7857             # also try to parse XMP with a non-standard header
7858             # (note: this non-standard XMP is ignored when writing)
7859 72 50       912 my $start = ($$segDataPt =~ /^$xmpAPP1hdr/) ? length($xmpAPP1hdr) : 0;
7860 72         297 my $tagTablePtr = GetTagTable('Image::ExifTool::XMP::Main');
7861 72         322 DirStart(\%dirInfo, $start);
7862 72 50       597 $dirInfo{DirName} = $start ? 'XMP' : 'XML',
7863             $processed = $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7864 72 50 33     572 if ($processed and not $start) {
7865 0         0 $self->Warn('Non-standard header for APP1 XMP segment');
7866             }
7867             }
7868 72 50 33     379 if ($verbose and not $processed) {
7869 0         0 $self->Warn("Ignored APP1 segment length $length (unknown header)");
7870             }
7871             }
7872             } elsif ($marker == 0xe2) { # APP2 (ICC Profile, FPXR, MPF, InfiRay, URN, PreviewImage)
7873 121 100 66     983 if ($$segDataPt =~ /^ICC_PROFILE\0/ and $length >= 14) {
    100          
    100          
    50          
    0          
    0          
    0          
7874 34         87 $dumpType = 'ICC_Profile';
7875             # must concatenate profile chunks (note: handle the case where
7876             # some software erroneously writes zeros for the chunk counts)
7877 34         190 my $chunkNum = Get8u($segDataPt, 12);
7878 34         112 my $chunksTot = Get8u($segDataPt, 13);
7879 34 50       177 $verbose and print $out "${indent}ICC_Profile chunk $chunkNum of $chunksTot\n";
7880 34 50       123 if (defined $iccChunksTotal) {
7881             # abort parsing ICC_Profile if the total chunk count is inconsistent
7882 0 0       0 undef $iccChunkCount if $chunksTot != $iccChunksTotal;
7883             } else {
7884 34         86 $iccChunkCount = 0;
7885 34         79 $iccChunksTotal = $chunksTot;
7886 34 50       118 $self->Warn('ICC_Profile chunk count is zero') if !$chunksTot;
7887             }
7888 34 50       112 if (defined $iccChunkCount) {
7889 34 50       147 if (defined $iccChunk[$chunkNum]) {
7890 0         0 $self->Warn('Duplicate ICC_Profile chunk number(s)');
7891 0         0 $iccChunk[$chunkNum] .= substr($$segDataPt, 14);
7892             } else {
7893 34         247 $iccChunk[$chunkNum] = substr($$segDataPt, 14);
7894             }
7895             # process profile if we have all of the chunks
7896 34 50       151 if (++$iccChunkCount >= $iccChunksTotal) {
7897 34         99 my $icc_profile = '';
7898 34   66     310 defined $_ and $icc_profile .= $_ foreach @iccChunk;
7899 34         99 undef @iccChunk; # free memory
7900 34         131 my $tagTablePtr = GetTagTable('Image::ExifTool::ICC_Profile::Main');
7901 34         293 my %dirInfo = (
7902             DataPt => \$icc_profile,
7903             DataPos => $segPos + 14,
7904             DataLen => length($icc_profile),
7905             DirStart => 0,
7906             DirLen => length($icc_profile),
7907             Parent => $markerName,
7908             );
7909 34         243 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7910 34         200 undef $iccChunkCount; # prevent reprocessing
7911             }
7912             } else {
7913 0         0 $self->Warn('Invalid or extraneous ICC_Profile chunk(s)');
7914             }
7915             } elsif ($$segDataPt =~ /^FPXR\0/) {
7916 67 50       187 next if $fast > 1; # skip processing for very fast
7917 67         139 $dumpType = 'FPXR';
7918 67         231 my $tagTablePtr = GetTagTable('Image::ExifTool::FlashPix::Main');
7919             # set flag if this is the last FPXR segment
7920 67   100     687 $dirInfo{LastFPXR} = not ($nextMarker==$marker and $$nextSegDataPt=~/^FPXR\0/),
7921             $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7922             } elsif ($$segDataPt =~ /^MPF\0/) {
7923 19         44 undef $dumpType; # (will be dumped here)
7924 19         89 DirStart(\%dirInfo, 4, 4);
7925 19         54 $dirInfo{Multi} = 1; # the MP Attribute IFD will be MPF1
7926 19 50       63 if ($htmlDump) {
7927 0         0 $self->HDump($segPos-4, 4, 'APP2 header', "Data size: $length bytes");
7928 0         0 $self->HDump($segPos, 4, 'MPF header', 'APP2 data type: MPF');
7929 0         0 $dumpEnd = $segPos + $length;
7930             }
7931             # extract the MPF information (it is in standard TIFF format)
7932 19         68 my $tagTablePtr = GetTagTable('Image::ExifTool::MPF::Main');
7933 19         119 $self->ProcessTIFF(\%dirInfo, $tagTablePtr);
7934             } elsif ($$segDataPt =~ /^....IJPEG\0/s) {
7935 1         3 $dumpType = 'InfiRay Version';
7936 1         5 $$self{HasIJPEG} = 1;
7937 1         5 SetByteOrder('II');
7938 1         5 my $tagTablePtr = GetTagTable('Image::ExifTool::InfiRay::Version');
7939 1         18 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7940             } elsif ($$segDataPt =~ /^(|QVGA\0|BGTH)\xff\xd8\xff[\xdb\xe0\xe1]/) {
7941             # Samsung/GE/GoPro="", BenQ DC C1220/Pentacon/Polaroid="QVGA\0",
7942             # Digilife DDC-690/Rollei="BGTH"
7943 0         0 $dumpType = 'Preview Image';
7944 0         0 $preview = substr($$segDataPt, length($1));
7945             } elsif ($$segDataPt =~ /^urn:/) { # (found in Apple HDR images)
7946 0         0 $dumpType = 'URN';
7947 0         0 $useJpegMain = 1;
7948             } elsif ($preview) {
7949 0         0 $dumpType = 'Preview Image';
7950 0         0 $preview .= $$segDataPt;
7951             }
7952 121 50 33     514 if ($preview and $nextMarker ne $marker) {
7953 0         0 $self->FoundTag('PreviewImage', $preview);
7954 0         0 undef $preview;
7955             }
7956             } elsif ($marker == 0xe3) { # APP3 (Kodak "Meta", Stim)
7957 21 100 33     170 if ($$segDataPt =~ /^(Meta|META|Exif)\0\0/) {
    50          
    100          
    50          
    0          
7958 19         40 undef $dumpType; # (will be dumped here)
7959 19         99 DirStart(\%dirInfo, 6, 6);
7960 19 50       72 if ($htmlDump) {
7961 0         0 $self->HDump($segPos-4, 10, 'APP3 Meta header');
7962 0         0 $dumpEnd = $segPos + $length;
7963             }
7964 19         109 my $tagTablePtr = GetTagTable('Image::ExifTool::Kodak::Meta');
7965 19         109 $self->ProcessTIFF(\%dirInfo, $tagTablePtr);
7966             } elsif ($$segDataPt =~ /^Stim\0/) {
7967 0         0 undef $dumpType; # (will be dumped here)
7968 0         0 DirStart(\%dirInfo, 6, 6);
7969 0 0       0 if ($htmlDump) {
7970 0         0 $self->HDump($segPos-4, 4, 'APP3 header', "Data size: $length bytes");
7971 0         0 $self->HDump($segPos, 5, 'Stim header', 'APP3 data type: Stim');
7972 0         0 $dumpEnd = $segPos + $length;
7973             }
7974             # extract the Stim information (it is in standard TIFF format)
7975 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::Stim::Main');
7976 0         0 $self->ProcessTIFF(\%dirInfo, $tagTablePtr);
7977             } elsif ($$segDataPt =~ /^_JPSJPS_/) {
7978 1         3 $dumpType = 'JPS';
7979 1 50       11 $self->OverrideFileType('JPS') if $$self{FILE_TYPE} eq 'JPEG';
7980 1         6 SetByteOrder('MM');
7981 1         5 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::JPS');
7982 1         7 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7983             } elsif ($$self{HasIJPEG} or $$self{Make} eq 'DJI') {
7984 1 50       7 $dumpType = $$self{HasIJPEG} ? 'InfiRay ImagingData' : 'DJI ThermalData';
7985             # add this data to the combined data if it exists
7986 1         3 my $dataPt = $segDataPt;
7987 1 50       4 if (defined $combinedSegData) {
7988 0         0 $combinedSegData .= $$segDataPt;
7989 0         0 $dataPt = \$combinedSegData;
7990             }
7991 1 50       4 if ($nextMarker == $marker) {
7992 0 0       0 $combinedSegData = $$segDataPt unless defined $combinedSegData;
7993             } else {
7994             # process InfiRay/DJI thermal data
7995 1         6 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::Main');
7996 1         61 $self->HandleTag($tagTablePtr, 'APP3', $$dataPt);
7997 1         3 undef $combinedSegData;
7998             }
7999             } elsif ($$segDataPt =~ /^\xff\xd8\xff\xdb/) {
8000 0         0 $dumpType = 'PreviewImage'; # (Samsung, HP, BenQ)
8001 0         0 $preview = $$segDataPt;
8002             }
8003 21 50 33     118 if ($preview and $nextMarker ne 0xe4) { # this preview continues in APP4
8004 0         0 $self->FoundTag('PreviewImage', $preview);
8005 0         0 undef $preview;
8006             }
8007             } elsif ($marker == 0xe4) { # APP4 (InfiRay, "SCALADO", FPXR, DJI, PreviewImage)
8008 1 50 33     29 if ($$segDataPt =~ /^SCALADO\0/ and $length >= 16) {
    50 33        
    50 33        
    50 33        
    50 33        
    50          
    50          
    0          
8009 0         0 $dumpType = 'SCALADO';
8010 0         0 my ($num, $idx, $len) = unpack('x8n2N', $$segDataPt);
8011             # assume that the segments are in order and just concatinate them
8012 0 0       0 $scalado = '' unless defined $scalado;
8013 0         0 $scalado .= substr($$segDataPt, 16);
8014 0 0       0 if ($idx == $num - 1) {
8015 0 0       0 if ($len != length $scalado) {
8016 0         0 $self->Warn('Possibly corrupted APP4 SCALADO data', 1);
8017             }
8018 0         0 my %dirInfo = (
8019             Parent => $markerName,
8020             DataPt => \$scalado,
8021             );
8022 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::Scalado::Main');
8023 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8024 0         0 undef $scalado;
8025             }
8026             } elsif ($$segDataPt =~ /^Qualcomm Dual Camera Attributes/) {
8027 0         0 $dumpType = 'Qualcomm Dual Camera';
8028 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::Qualcomm::DualCamera');
8029 0         0 DirStart(\%dirInfo, 31);
8030 0         0 $dirInfo{DirName} = 'Qualcomm Dual Camera';
8031 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8032             } elsif ($$segDataPt =~ /^FPXR\0/) {
8033 0 0       0 next if $fast > 1; # skip processing for very fast
8034 0         0 $dumpType = 'FPXR';
8035 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::FlashPix::Main');
8036             # set flag if this is the last FPXR segment
8037 0   0     0 $dirInfo{LastFPXR} = not ($nextMarker==$marker and $$nextSegDataPt=~/^FPXR\0/),
8038             $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8039             } elsif ($$self{Make} eq 'DJI' and $$segDataPt =~ /^\xaa\x55\x12\x06/) {
8040 0         0 $dumpType = 'DJI ThermalParams';
8041 0         0 DirStart(\%dirInfo, 0, 0);
8042 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::DJI::ThermalParams');
8043 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8044             } elsif ($$self{Make} eq 'DJI' and $$segDataPt =~ /^(.{32})?.{32}\x2c\x01\x20\0/s) {
8045 0         0 $dumpType = 'DJI ThermalParams2';
8046 0 0       0 DirStart(\%dirInfo, $1 ? 32 : 0, 0);
8047 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::DJI::ThermalParams2');
8048 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8049             } elsif ($$self{Make} eq 'DJI' and $$segDataPt =~ /^.{32}\xaa\x55\x38\0/s) {
8050 0         0 $dumpType = 'DJI ThermalParams3';
8051 0         0 DirStart(\%dirInfo, 32, 0);
8052 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::DJI::ThermalParams3');
8053 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8054             } elsif ($$self{HasIJPEG} and $length >= 120) {
8055 1         3 $dumpType = 'InfiRay Factory';
8056 1         5 SetByteOrder('II');
8057 1         4 my $tagTablePtr = GetTagTable('Image::ExifTool::InfiRay::Factory');
8058 1         8 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8059             } elsif ($preview) {
8060             # continued Samsung S1060 preview from APP3
8061 0         0 $dumpType = 'PreviewImage';
8062 0         0 $preview .= $$segDataPt;
8063             }
8064             # (also seen "QTI Debug Metadata\0" segment in some newer Samsung images)
8065             # BenQ DC E1050 continues preview in APP5
8066 1 50 33     6 if ($preview and $nextMarker ne 0xe5) {
8067 0         0 $self->FoundTag('PreviewImage', $preview);
8068 0         0 undef $preview;
8069             }
8070             } elsif ($marker == 0xe5) { # APP5 (InfiRay, Ricoh "RMETA")
8071 21 100 33     140 if ($$segDataPt =~ /^RMETA\0/) {
    50          
    50          
    50          
    0          
8072             # (NOTE: apparently these may span multiple segments, but I haven't seen
8073             # a sample like this, so multi-segment support hasn't yet been implemented)
8074 20         67 $dumpType = 'Ricoh RMETA';
8075 20         94 DirStart(\%dirInfo, 6, 6);
8076 20         71 my $tagTablePtr = GetTagTable('Image::ExifTool::Ricoh::RMETA');
8077 20         100 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8078             } elsif ($$segDataPt =~ /^ssuniqueid\0/) {
8079 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::Samsung::APP5');
8080 0         0 $self->HandleTag($tagTablePtr, 'ssuniqueid', substr($$segDataPt, 11));
8081             } elsif ($$self{Make} eq 'DJI') {
8082 0         0 $dumpType = 'DJI ThermalCal';
8083 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::Main');
8084 0         0 $self->HandleTag($tagTablePtr, 'APP5', $$segDataPt);
8085             } elsif ($$self{HasIJPEG} and $length >= 38) {
8086 1         4 $dumpType = 'InfiRay Picture';
8087 1         4 SetByteOrder('II');
8088 1         4 my $tagTablePtr = GetTagTable('Image::ExifTool::InfiRay::Picture');
8089 1         6 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8090             } elsif ($preview) {
8091 0         0 $dumpType = 'PreviewImage';
8092 0         0 $preview .= $$segDataPt;
8093 0         0 $self->FoundTag('PreviewImage', $preview);
8094 0         0 undef $preview;
8095             }
8096             } elsif ($marker == 0xe6) { # APP6 (InfiRay, Toshiba EPPIM, NITF, HP_TDHD)
8097 38 100 33     330 if ($$segDataPt =~ /^EPPIM\0/) {
    100 33        
    50          
    100          
    50          
    50          
8098 18         53 undef $dumpType; # (will be dumped here)
8099 18         87 DirStart(\%dirInfo, 6, 6);
8100 18 50       60 if ($htmlDump) {
8101 0         0 $self->HDump($segPos-4, 10, 'APP6 EPPIM header');
8102 0         0 $dumpEnd = $segPos + $length;
8103             }
8104 18         110 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::EPPIM');
8105 18         90 $self->ProcessTIFF(\%dirInfo, $tagTablePtr);
8106             } elsif ($$segDataPt =~ /^NITF\0/) {
8107 18         46 $dumpType = 'NITF';
8108 18         95 SetByteOrder('MM');
8109 18         69 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::NITF');
8110 18         113 DirStart(\%dirInfo, 5);
8111 18         87 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8112             } elsif ($$segDataPt =~ /^TDHD\x01\0\0\0/ and $length > 12) {
8113             # HP Photosmart R837 APP6 "TDHD" segment
8114 0         0 $dumpType = 'TDHD';
8115 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::HP::TDHD');
8116             # (ignore first TDHD element because size includes 12-byte tag header)
8117 0         0 DirStart(\%dirInfo, 12);
8118 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8119             } elsif ($$segDataPt =~ /^GoPro\0/) {
8120             # GoPro segment
8121 1         3 $dumpType = 'GoPro';
8122 1         18 my $tagTablePtr = GetTagTable('Image::ExifTool::GoPro::GPMF');
8123 1         5 DirStart(\%dirInfo, 6);
8124 1         4 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8125             } elsif ($$segDataPt =~ /^DTAT\0\0.\{/s) {
8126 0         0 $dumpType = 'DJI_DTAT';
8127 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::Main');
8128 0         0 $self->HandleTag($tagTablePtr, 'APP6', $$segDataPt);
8129             } elsif ($$self{HasIJPEG} and $length >= 129) {
8130 1         3 $dumpType = 'InfiRay MixMode';
8131 1         5 SetByteOrder('II');
8132 1         5 my $tagTablePtr = GetTagTable('Image::ExifTool::InfiRay::MixMode');
8133 1         5 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8134             }
8135             } elsif ($marker == 0xe7) { # APP7 (InfiRay, Pentax, Huawei, Qualcomm)
8136 20 50 33     294 if ($$segDataPt =~ /^(PENTAX |RICOH)\0(II|MM)/) {
    50          
    50          
    100          
    50          
8137             # found in K-3 and Ricoh GR_IV images (is this multi-segment??)
8138 0         0 SetByteOrder($2);
8139 0         0 undef $dumpType; # (dump this ourself)
8140 0         0 my $hdrLen = length($1) + 3;
8141 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::Pentax::Main');
8142 0         0 DirStart(\%dirInfo, $hdrLen, 0);
8143 0         0 $dirInfo{DirName} = 'Pentax APP7';
8144 0 0       0 if ($htmlDump) {
8145 0         0 $self->HDump($segPos-4, 4, 'APP7 header', "Data size: $length bytes");
8146 0         0 $self->HDump($segPos, $hdrLen, 'Pentax header', 'APP7 data type: Pentax');
8147 0         0 $dumpEnd = $segPos + $length;
8148             }
8149 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8150             } elsif ($$segDataPt =~ /^HUAWEI\0\0(II|MM)/) {
8151 0         0 SetByteOrder($1);
8152 0         0 undef $dumpType; # (dump this ourself)
8153 0         0 my $hdrLen = 16;
8154 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::Unknown::Main');
8155 0         0 DirStart(\%dirInfo, $hdrLen, 8);
8156 0         0 $dirInfo{DirName} = 'Huawei APP7';
8157 0 0       0 if ($htmlDump) {
8158 0         0 $self->HDump($segPos-4, 4, 'APP7 header', "Data size: $length bytes");
8159 0         0 $self->HDump($segPos, $hdrLen, 'Huawei header', 'APP7 data type: Huawei');
8160 0         0 $dumpEnd = $segPos + $length;
8161             }
8162 0         0 $$self{SET_GROUP0} = 'APP7';
8163 0         0 $$self{SET_GROUP1} = 'Huawei';
8164 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8165 0         0 delete $$self{SET_GROUP0};
8166 0         0 delete $$self{SET_GROUP1};
8167             } elsif ($$segDataPt =~ /^DJI-DBG\0/) {
8168 0         0 $dumpType = 'DJI Info';
8169 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::DJI::Info');
8170 0         0 DirStart(\%dirInfo, 8, 0);
8171 0         0 $$self{SET_GROUP0} = 'APP7';
8172 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8173 0         0 delete $$self{SET_GROUP0};
8174             } elsif ($$segDataPt =~ /^\x1aQualcomm Camera Attributes/) {
8175             # found in HP iPAQ_VoiceMessenger
8176 19         48 $dumpType = 'Qualcomm';
8177 19         77 my $tagTablePtr = GetTagTable('Image::ExifTool::Qualcomm::Main');
8178 19         117 DirStart(\%dirInfo, 27);
8179 19         77 $dirInfo{DirName} = 'Qualcomm';
8180 19         144 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8181             } elsif ($$self{HasIJPEG} and $length >= 32) {
8182 1         3 $dumpType = 'InfiRay OpMode';
8183 1         5 SetByteOrder('II');
8184 1         31 my $tagTablePtr = GetTagTable('Image::ExifTool::InfiRay::OpMode');
8185 1         6 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8186             }
8187             } elsif ($marker == 0xe8) { # APP8 (InfiRay, SPIFF)
8188             # my sample SPIFF has 32 bytes of data, but spec states 30
8189 20 100 66     163 if ($$segDataPt =~ /^SPIFF\0/ and $length == 32) {
    50 33        
    0          
8190 19         45 $dumpType = 'SPIFF';
8191 19         110 DirStart(\%dirInfo, 6);
8192 19         73 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::SPIFF');
8193 19         96 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8194             } elsif ($$self{HasIJPEG} and $length >= 32) {
8195 1         3 $dumpType = 'InfiRay Isothermal';
8196 1         5 SetByteOrder('II');
8197 1         3 my $tagTablePtr = GetTagTable('Image::ExifTool::InfiRay::Isothermal');
8198 1         6 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8199             } elsif ($$segDataPt =~ /^SEAL\0/) {
8200 0         0 $dumpType = 'SEAL';
8201 0         0 DirStart(\%dirInfo, 5);
8202 0         0 $self->ProcessDirectory(\%dirInfo, GetTagTable("Image::ExifTool::XMP::SEAL"));
8203             }
8204             } elsif ($marker == 0xe9) { # APP9 (InfiRay, Media Jukebox)
8205 20 100 66     184 if ($$segDataPt =~ /^Media Jukebox\0/ and $length > 22) {
    50 33        
    0          
8206 19         50 $dumpType = 'MediaJukebox';
8207             # (start parsing after the "")
8208 19         80 DirStart(\%dirInfo, 22);
8209 19         66 $dirInfo{DirName} = 'MediaJukebox';
8210 19         239 require Image::ExifTool::XMP;
8211 19         90 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::MediaJukebox');
8212 19         122 $self->ProcessDirectory(\%dirInfo, $tagTablePtr, \&Image::ExifTool::XMP::ProcessXMP);
8213             } elsif ($$self{HasIJPEG} and $length >= 768) {
8214 1         5 $dumpType = 'InfiRay Sensor';
8215 1         5 SetByteOrder('II');
8216 1         5 my $tagTablePtr = GetTagTable('Image::ExifTool::InfiRay::Sensor');
8217 1         6 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8218             } elsif ($$segDataPt =~ /^SEAL\0/) {
8219 0         0 $dumpType = 'SEAL';
8220 0         0 DirStart(\%dirInfo, 5);
8221 0         0 $self->ProcessDirectory(\%dirInfo, GetTagTable("Image::ExifTool::XMP::SEAL"));
8222             }
8223             } elsif ($marker == 0xea) { # APP10 (PhotoStudio Unicode comments, HDR gain curve)
8224 19 50       111 if ($$segDataPt =~ /^UNICODE\0/) {
    0          
8225 19         50 $dumpType = 'PhotoStudio';
8226 19         160 my $comment = $self->Decode(substr($$segDataPt,8), 'UCS2', 'MM');
8227 19         128 $self->FoundTag('Comment', $comment);
8228             } elsif ($$segDataPt =~ /^AROT\0\0.{4}/s) {
8229 0         0 $dumpType = 'AROT', # (HDR gain curve? PH guess)
8230             $useJpegMain = 1;
8231             }
8232             } elsif ($marker == 0xeb) { # APP11 (JPEG-HDR, JUMBF)
8233 38 100 33     325 if ($$segDataPt =~ /^HDR_RI /) {
    50          
8234 19         50 $dumpType = 'JPEG-HDR';
8235 19         43 my $dataPt = $segDataPt;
8236 19 50       72 if (defined $combinedSegData) {
8237 0 0       0 if ($$segDataPt =~ /~\0/g) {
8238 0         0 $combinedSegData .= substr($$segDataPt,pos($$segDataPt));
8239             } else {
8240 0         0 $self->Warn('Invalid format for JPEG-HDR extended segment');
8241             }
8242 0         0 $dataPt = \$combinedSegData;
8243             }
8244 19 50 33     153 if ($nextMarker == $marker and $$nextSegDataPt =~ /^HDR_RI /) {
8245 0 0       0 $combinedSegData = $$segDataPt unless defined $combinedSegData;
8246             } else {
8247 19         72 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::HDR');
8248 19         73 my %dirInfo = ( DataPt => $dataPt );
8249 19         104 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8250 19         76 undef $combinedSegData;
8251             }
8252             } elsif ($$segDataPt =~ /^(JP..)/s and length($$segDataPt) >= 16) {
8253             # JUMBF extension marker
8254 19         58 my $hdr = $1;
8255 19         43 $dumpType = 'JUMBF';
8256 19         91 SetByteOrder('MM');
8257             # (sequence should start from 1, but some software incorrectly writes 0)
8258 19         71 my $seq = Get32u($segDataPt, 4);
8259 19         75 my $len = Get32u($segDataPt, 8);
8260 19         65 my $type = substr($$segDataPt, 12, 4);
8261             # a Microsoft bug writes $len and $type incorrectly as little-endian
8262 19 50       81 if ($type eq 'bmuj') {
8263 0         0 $self->Warn('Wrong byte order in C2PA APP11 JUMBF header');
8264 0         0 $type = 'jumb';
8265 0         0 $len = unpack('x8V', $$segDataPt);
8266             # fix the header
8267 0         0 substr($$segDataPt, 8, 8) = Set32u($len) . $type;
8268             }
8269 19         43 my $hdrLen;
8270 19 50 33     122 if ($len == 1 and length($$segDataPt) >= 24) {
8271             # (haven't seen this with the Microsoft bug)
8272 0         0 $len = Get64u($$segDataPt, 16);
8273 0         0 $hdrLen = 16;
8274             } else {
8275 19         44 $hdrLen = 8;
8276             }
8277 19 50       511 $jumbfChunk{$type} or $jumbfChunk{$type} = [ '' ];
8278 19 50 33     140 if ($len < $hdrLen) {
    50          
8279 0         0 $self->Warn('Invalid JUMBF segment');
8280             } elsif (defined $jumbfChunk{$type}[$seq] and length $jumbfChunk{$type}[$seq]) {
8281 0         0 $self->Warn('Duplicate JUMBF sequence number');
8282             } else {
8283 19 50       68 $seq or $self->Warn('Incorrect JUMBF sequence numbering (should start from 0, not 1)');
8284             # add to list of JUMBF chunks
8285 19         93 $jumbfChunk{$type}[$seq] = substr($$segDataPt, 8 + $hdrLen);
8286             # check to see if we have a complete JUMBF box
8287 19         42 my $size = $hdrLen;
8288 19         45 foreach (@{$jumbfChunk{$type}}) {
  19         74  
8289 38 50       97 defined $_ or $size = 0, last;
8290 38         81 $size += length $_;
8291             }
8292 19 50       66 if ($size == $len) {
8293 19         53 my $buff = join '', substr($$segDataPt,8,$hdrLen), @{$jumbfChunk{$type}};
  19         95  
8294 19         62 $dirInfo{DataPt} = \$buff;
8295 19         54 $dirInfo{DataPos} = $segPos + 8; # (shows correct offsets for single-segment JUMBF)
8296 19         53 $dirInfo{DataLen} = $dirInfo{DirLen} = $size;
8297 19         58 $dirInfo{DirName} = 'JUMBF';
8298 19         74 my $tagTablePtr = GetTagTable('Image::ExifTool::Jpeg2000::Main');
8299 19         101 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8300 19         130 delete $jumbfChunk{$type};
8301             }
8302             }
8303             }
8304             } elsif ($marker == 0xec) { # APP12 (Ducky, Picture Info)
8305 40 100       227 if ($$segDataPt =~ /^Ducky/) {
8306 21         60 $dumpType = 'Ducky';
8307 21         103 DirStart(\%dirInfo, 5);
8308 21         82 my $tagTablePtr = GetTagTable('Image::ExifTool::APP12::Ducky');
8309 21         100 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8310             } else {
8311 19         76 my $tagTablePtr = GetTagTable('Image::ExifTool::APP12::PictureInfo');
8312 19 50       99 $self->ProcessDirectory(\%dirInfo, $tagTablePtr) and $dumpType = 'Picture Info';
8313             }
8314             } elsif ($marker == 0xed) { # APP13 (Photoshop, Adobe_CM)
8315 85         210 my $isOld;
8316 85 100 50     1599 if ($$segDataPt =~ /^$psAPP13hdr/ or ($$segDataPt =~ /^$psAPP13old/ and $isOld=1)) {
    50 66        
8317 66         173 $dumpType = 'Photoshop';
8318             # add this data to the combined data if it exists
8319 66         138 my $dataPt = $segDataPt;
8320 66 50       265 if (defined $combinedSegData) {
8321 0         0 $combinedSegData .= substr($$segDataPt,length($psAPP13hdr));
8322 0         0 $dataPt = \$combinedSegData;
8323             }
8324             # peek ahead to see if the next segment is photoshop data too
8325 66 50 66     411 if ($nextMarker == $marker and $$nextSegDataPt =~ /^$psAPP13hdr/) {
8326             # initialize combined data if necessary
8327 0 0       0 $combinedSegData = $$segDataPt unless defined $combinedSegData;
8328             # (will handle the Photoshop data the next time around)
8329             } else {
8330 66 50       203 my $hdrLen = $isOld ? 27 : 14;
8331             # process APP13 Photoshop record
8332 66         272 my $tagTablePtr = GetTagTable('Image::ExifTool::Photoshop::Main');
8333 66         584 my %dirInfo = (
8334             DataPt => $dataPt,
8335             DataPos => $segPos,
8336             DataLen => length $$dataPt,
8337             DirStart => $hdrLen, # directory starts after identifier
8338             DirLen => length($$dataPt) - $hdrLen,
8339             Parent => $markerName,
8340             );
8341 66         373 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8342 66         370 undef $combinedSegData;
8343             }
8344             } elsif ($$segDataPt =~ /^Adobe_CM/) {
8345 19         79 $dumpType = 'Adobe_CM';
8346 19         102 SetByteOrder('MM');
8347 19         67 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::AdobeCM');
8348 19         95 DirStart(\%dirInfo, 8);
8349 19         86 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8350             }
8351             } elsif ($marker == 0xee) { # APP14 (Adobe)
8352 45 50       309 if ($$segDataPt =~ /^Adobe/) {
8353             # extract as a block if requested, or if copying tags from file
8354 45 100 100     452 if ($$req{adobe} or
      66        
8355             # (not extracted normally, so check TAGS_FROM_FILE)
8356             ($$self{TAGS_FROM_FILE} and not $$self{EXCL_TAG_LOOKUP}{adobe}))
8357             {
8358 15         73 $self->FoundTag('Adobe', $$segDataPt);
8359             }
8360 45         120 $dumpType = 'Adobe';
8361 45         174 SetByteOrder('MM');
8362 45         155 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::Adobe');
8363 45         587 DirStart(\%dirInfo, 5);
8364 45         188 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8365             }
8366             } elsif ($marker == 0xef) { # APP15 (GraphicConverter)
8367 19 50 33     226 if ($$segDataPt =~ /^Q\s*(\d+)/ and $length == 4) {
8368 19         50 $dumpType = 'GraphicConverter';
8369 19         76 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::GraphConv');
8370 19         100 $self->HandleTag($tagTablePtr, 'Q', $1);
8371             }
8372             } elsif ($marker == 0xfe) { # COM (JPEG comment)
8373 27         72 $dumpType = 'Comment';
8374 27         110 $$segDataPt =~ s/\0+$//; # some dumb softwares add null terminators
8375 27         118 $self->FoundTag('Comment', $$segDataPt);
8376             } elsif ($marker == 0x64) { # CME (J2C comment and extension)
8377 2         6 $dumpType = 'Comment';
8378 2 50       10 if ($length > 2) {
8379 2         7 my $reg = unpack('n', $$segDataPt); # get registration value
8380 2         7 my $val = substr($$segDataPt, 2);
8381 2 50       15 $val = $self->Decode($val, 'Latin') if $reg == 1;
8382             # (actually an extension for $reg==65535, but store as binary comment)
8383 2 50 33     19 $self->FoundTag('Comment', ($reg==0 or $reg==65535) ? \$val : $val);
8384             }
8385             } elsif ($marker == 0x51) { # SIZ (J2C)
8386 1         5 my ($w, $h) = unpack('x2N2', $$segDataPt);
8387 1 50       5 unless ($gotSize) {
8388 1         3 $gotSize = 1;
8389 1         6 $self->FoundTag('ImageWidth', $w);
8390 1         3 $self->FoundTag('ImageHeight', $h);
8391             }
8392             } elsif (($marker & 0xf0) != 0xe0) {
8393 502         1246 $dumpType = "$markerName segment";
8394 502         1154 $desc = "[JPEG $markerName]"; # (other known JPEG segments)
8395             }
8396 1225 100       3905 if (defined $dumpType) {
8397 1169 50       3059 if ($useJpegMain) {
8398 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::Main');
8399 0         0 $self->HandleTag($tagTablePtr, $markerName, $$segDataPt);
8400             }
8401 1169 50 33     3222 if (not $dumpType and ($$options{Unknown} or $$options{Validate})) {
      66        
8402 0 0       0 my $str = ($$segDataPt =~ /^([\x20-\x7e]{1,20})\0/) ? " '${1}'" : '';
8403 0 0       0 $xtra = 'segment' unless $xtra;
8404 0         0 $self->Warn("Unknown $markerName$str $xtra", 1);
8405             }
8406 1169 50       3651 if ($htmlDump) {
8407 0 0       0 $desc or $desc = $markerName . ($dumpType ? " $dumpType" : '') . ' segment';
    0          
8408 0         0 $self->HDump($segPos-4, $length+4, $desc, $tip, 0x08);
8409 0         0 $dumpEnd = $segPos + $length;
8410             }
8411             }
8412 1225         6268 undef $$segDataPt;
8413             }
8414             # print verbose hash message if necessary
8415 250 50 33     1026 print $out "${indent}(ImageDataHash: $hashsize bytes of JPEG image data)\n" if $hashsize and $verbose;
8416             # calculate JPEGDigest if requested
8417 250 100       811 if (@dqt) {
8418 1         5072 require Image::ExifTool::JPEGDigest;
8419 1         6 Image::ExifTool::JPEGDigest::Calculate($self, \@dqt, $subSampling);
8420             }
8421             # issue necessary warnings
8422 250 50       848 $self->Warn('Invalid JUMBF size or missing JUMBF chunk') if %jumbfChunk;
8423 250 50       837 $self->Warn('Incomplete ICC_Profile record', 1) if defined $iccChunkCount;
8424 250 50       828 $self->Warn('Incomplete FLIR record', 1) if defined $flirCount;
8425 250 50       893 $self->Warn('Error reading PreviewImage', 1) if $$self{PreviewError};
8426 250 50       805 $success or $self->Warn('JPEG format error');
8427 250 50       948 pop @$path if @$path > $pn;
8428 250         3072 return 1;
8429             }
8430              
8431             #------------------------------------------------------------------------------
8432             # Extract metadata from an Exiv2 EXV file
8433             # Inputs: 0) ExifTool object reference, 1) dirInfo ref with RAF set
8434             # Returns: 1 on success, 0 if this wasn't a valid JPEG file
8435             sub ProcessEXV($$)
8436             {
8437 2     2 0 9 my ($self, $dirInfo) = @_;
8438 2         14 return $self->ProcessJPEG($dirInfo);
8439             }
8440              
8441             #------------------------------------------------------------------------------
8442             # Process EXIF file
8443             # Inputs/Returns: same as ProcessTIFF
8444             sub ProcessEXIF($$;$)
8445             {
8446 2     2 0 7 my ($self, $dirInfo, $tagTablePtr) = @_;
8447 2         11 return $self->ProcessTIFF($dirInfo, $tagTablePtr);
8448             }
8449              
8450             #------------------------------------------------------------------------------
8451             # Process TIFF data (wrapper for DoProcessTIFF to allow re-entry)
8452             # Inputs: 0) ExifTool object ref, 1) dirInfo ref, 2) optional tag table ref
8453             # Returns: 1 if this looked like a valid EXIF block, 0 otherwise, or -1 on write error
8454             sub ProcessTIFF($$;$)
8455             {
8456 502     502 0 1679 my ($self, $dirInfo, $tagTablePtr) = @_;
8457 502         1414 my $exifData = $$self{EXIF_DATA};
8458 502         1350 my $exifPos = $$self{EXIF_POS};
8459 502         2395 my $rtnVal = $self->DoProcessTIFF($dirInfo, $tagTablePtr);
8460             # restore original EXIF information (in case ProcessTIFF is nested)
8461 502 100       2341 if (defined $exifData) {
8462 108         355 $$self{EXIF_DATA} = $exifData;
8463 108         273 $$self{EXIF_POS} = $exifPos;
8464             }
8465 502         2763 return $rtnVal;
8466             }
8467              
8468             #------------------------------------------------------------------------------
8469             # Process TIFF as a sub-document
8470             # Inputs: 0) ExifTool object ref, 1) dirInfo ref, 2) optional tag table ref
8471             # Returns: 1 if this looked like a valid EXIF block, 0 otherwise, or -1 on write error
8472             sub ProcessSubTIFF($$;$)
8473             {
8474 0     0 0 0 my ($self, $dirInfo, $tagTablePtr) = @_;
8475 0         0 $$self{DOC_NUM} = ++$$self{DOC_COUNT};
8476 0         0 my $rtnVal = $self->ProcessTIFF($dirInfo, $tagTablePtr);
8477 0         0 delete $$self{DOC_NUM};
8478 0         0 return $rtnVal;
8479             }
8480              
8481             #------------------------------------------------------------------------------
8482             # Process TIFF data
8483             # Inputs: 0) ExifTool object ref, 1) dirInfo ref, 2) optional tag table ref
8484             # Returns: 1 if this looked like a valid EXIF block, 0 otherwise, or -1 on write error
8485             sub DoProcessTIFF($$;$)
8486             {
8487 502     502 0 1469 my ($self, $dirInfo, $tagTablePtr) = @_;
8488 502         1392 my $dataPt = $$dirInfo{DataPt};
8489 502   100     2176 my $fileType = $$dirInfo{Parent} || '';
8490 502         1286 my $raf = $$dirInfo{RAF};
8491 502   100     2088 my $base = $$dirInfo{Base} || 0;
8492 502         1305 my $outfile = $$dirInfo{OutFile};
8493 502         1379 my ($err, $sig, $canonSig, $otherSig);
8494              
8495             # attempt to read TIFF header
8496 502 100 100     3462 if ($raf) {
    100          
    50          
8497 47         166 $$self{EXIF_DATA} = '';
8498 47 100       170 if ($outfile) {
8499 14 50       68 $raf->Seek(0, 0) or return 0;
8500 14 50       58 if ($base) {
8501 0 0       0 $raf->Read($$dataPt, $base) == $base or return 0;
8502 0 0       0 Write($outfile, $$dataPt) or $err = 1;
8503             }
8504             } else {
8505 33 50       151 $raf->Seek($base, 0) or return 0;
8506             }
8507             # extract full EXIF block (for block copy) from EXIF file
8508 47 100       201 my $amount = $fileType eq 'EXIF' ? 65536 * 8 : 8;
8509 47         210 my $n = $raf->Read($$self{EXIF_DATA}, $amount);
8510 47 100       186 if ($n < 8) {
8511 1 50 33     12 return 0 if $n or not $outfile or $fileType ne 'EXIF';
      33        
8512             # create EXIF file from scratch
8513 1         3 delete $$self{EXIF_DATA};
8514 1         3 undef $raf;
8515             }
8516 47 100       178 if ($n > 8) {
8517 2         8 $raf->Seek(8, 0);
8518 2 50       9 if ($n == $amount) {
8519 0         0 $$self{EXIF_DATA} = substr($$self{EXIF_DATA}, 0, 8);
8520 0         0 $self->Warn('EXIF too large to extract as a block'); #(shouldn't happen)
8521             }
8522             }
8523             } elsif ($dataPt and length $$dataPt) {
8524             # save a copy of the EXIF data
8525 411   100     1575 my $dirStart = $$dirInfo{DirStart} || 0;
8526 411   66     1437 my $dirLen = $$dirInfo{DirLen} || (length($$dataPt) - $dirStart);
8527 411 50 33     1742 if ($dirLen > 0 or not $outfile) {
8528 411         3102 $$self{EXIF_DATA} = substr($$dataPt, $dirStart, $dirLen);
8529             } else {
8530 0         0 delete $$self{EXIF_DATA}; # create from scratch;
8531             }
8532 411 50 66     2203 $self->VerboseDir('TIFF') if $$self{OPTIONS}{Verbose} and length($$self{INDENT}) > 2;
8533             } elsif ($outfile) {
8534 44         149 delete $$self{EXIF_DATA}; # create from scratch
8535             } else {
8536 0         0 $$self{EXIF_DATA} = '';
8537             }
8538 502 100       1840 unless (defined $$self{EXIF_DATA}) {
8539             # set default byte order for creating new GPS in CR3 images
8540 45         107 my $defaultByteOrder;
8541 45 50 33     350 if ($$dirInfo{DirName} and $$dirInfo{DirName} eq 'GPS') {
8542 0         0 $defaultByteOrder = $$self{SaveExifByteOrder};
8543             }
8544             # create TIFF information from scratch
8545 45 100       357 if ($self->SetPreferredByteOrder($defaultByteOrder) eq 'MM') {
8546 36         148 $$self{EXIF_DATA} = "MM\0\x2a\0\0\0\x08";
8547             } else {
8548 9         33 $$self{EXIF_DATA} = "II\x2a\0\x08\0\0\0";
8549             }
8550             }
8551 502         1939 $$self{EXIF_POS} = $base + $$self{BASE};
8552 502 100       2270 $$self{FIRST_EXIF_POS} = $$self{EXIF_POS} unless defined $$self{FIRST_EXIF_POS};
8553 502         1271 $dataPt = \$$self{EXIF_DATA};
8554              
8555             # set byte ordering
8556 502         1635 my $byteOrder = substr($$dataPt,0,2);
8557 502 100       1873 SetByteOrder($byteOrder) or return 0;
8558              
8559             # verify the byte ordering
8560 496         1875 my $identifier = Get16u($dataPt, 2);
8561             # identifier is 0x2a for TIFF (but 0x4f52, 0x5352 or ?? for ORF)
8562             # no longer do this because various files use different values
8563             # (TIFF=0x2a, RW2/RWL=0x55, HDP=0xbc, BTF=0x2b, ORF=0x4f52/0x5352/0x????)
8564             # return 0 unless $identifier == 0x2a;
8565 496 50 66     3136 $self->Warn('Invalid magic number in EXIF TIFF header') if $fileType eq 'APP1' and $identifier != 0x2a;
8566              
8567             # get offset to IFD0
8568 496 50       2005 return 0 if length $$dataPt < 8;
8569 496         1622 my $offset = Get32u($dataPt, 4);
8570 496 50       1752 $offset >= 8 or return 0;
8571              
8572 496 100       1691 if ($raf) {
8573             # check for canon or EXIF signature
8574             # (Canon CR2 images should have an offset of 16, but it may be
8575             # greater if edited by PhotoMechanic)
8576 40 100 100     420 if ($identifier == 0x2a and $offset >= 16) {
    100 66        
    100          
    50          
8577 17 50       82 $raf->Read($sig, 8) == 8 or return 0;
8578 17         72 $$dataPt .= $sig;
8579 17 100       115 if ($sig =~ /^(CR\x02\0|\xba\xb0\xac\xbb|ExifMeta)/) {
8580 10 100       45 if ($sig eq 'ExifMeta') {
8581 1         8 $self->SetFileType($fileType = 'EXIF');
8582 1         2 $otherSig = $sig;
8583             } else {
8584 9 50       86 $fileType = $sig =~ /^CR/ ? 'CR2' : 'Canon 1D RAW';
8585 9         23 $canonSig = $sig;
8586             }
8587 10 50       50 $self->HDump($base+8, 8, "[$fileType header]") if $$self{HTML_DUMP};
8588             }
8589             } elsif ($identifier == 0x55 and $fileType =~ /^(RAW|RW2|RWL|TIFF)$/) {
8590             # panasonic RAW, RW2 or RWL file
8591 3         7 my $magic;
8592             # test for RW2/RWL magic number
8593 3 50 33     25 if ($offset >= 0x18 and $raf->Read($magic, 16) and
      33        
8594             $magic eq "\x88\xe7\x74\xd8\xf8\x25\x1d\x4d\x94\x7a\x6e\x77\x82\x2b\x5d\x6a")
8595             {
8596 3 50       17 $fileType = 'RW2' unless $fileType eq 'RWL';
8597 3 50       14 $self->HDump($base + 8, 16, '[RW2/RWL header]') if $$self{HTML_DUMP};
8598 3         9 $otherSig = $magic; # save signature for writing
8599             } else {
8600 0         0 $fileType = 'RAW';
8601             }
8602 3         15 $tagTablePtr = GetTagTable('Image::ExifTool::PanasonicRaw::Main');
8603             } elsif ($fileType eq 'TIFF') {
8604 13 50 33     136 if ($identifier == 0x2b) {
    50 33        
    50          
    50          
8605             # this looks like a BigTIFF image
8606 0         0 $raf->Seek(0);
8607 0         0 require Image::ExifTool::BigTIFF;
8608 0         0 my $result = Image::ExifTool::BigTIFF::ProcessBTF($self, $dirInfo);
8609 0 0       0 if ($result) {
8610 0 0       0 $self->FoundTag(PageCount => $$self{PageCount}) if $$self{MultiPage};
8611 0         0 return 1;
8612             }
8613             } elsif ($identifier == 0x4f52 or $identifier == 0x5352) {
8614             # Olympus ORF image (set FileType now because base type is 'ORF')
8615 0         0 $self->SetFileType($fileType = 'ORF');
8616             } elsif ($identifier == 0x4352) {
8617 0         0 $fileType = 'DCP';
8618             } elsif ($byteOrder eq 'II' and ($identifier & 0xff) == 0xbc) {
8619 0         0 $fileType = 'HDP'; # Windows HD Photo file
8620             # check version number
8621 0         0 my $ver = Get8u($dataPt, 3);
8622 0 0       0 if ($ver > 1) {
8623 0         0 $self->Error("Windows HD Photo version $ver files not yet supported");
8624 0         0 return 1;
8625             }
8626             }
8627             } elsif ($fileType eq 'ARW') {
8628 0         0 $$self{LOW_PRIORITY_DIR}{IFD1} = 1; # lower priority of IFD1 tags in ARW files
8629             }
8630             # we have a valid TIFF (or whatever) file
8631 40 100 66     331 if ($fileType and not $$self{VALUE}{FileType}) {
8632 38         173 my $lookup = $fileTypeLookup{$fileType};
8633 38 50 33     187 $lookup = $fileTypeLookup{$lookup} unless ref $lookup or not $lookup;
8634             # use file extension to pre-determine type if extension is TIFF-based or type is RAW
8635 38 50       201 my $baseType = $lookup ? (ref $$lookup[0] ? $$lookup[0][0] : $$lookup[0]) : '';
    50          
8636 38 100 66     234 my $t = ($baseType eq 'TIFF' or $fileType =~ /RAW/) ? $fileType : undef;
8637 38         1384 $self->SetFileType($t);
8638             }
8639             # don't process file if FastScan > 2
8640 40 50 66     321 return 1 if not $outfile and $$self{OPTIONS}{FastScan} and $$self{OPTIONS}{FastScan} > 2;
      33        
8641             }
8642             # (accommodate CR3 images which have a TIFF directory with ExifIFD at the top level)
8643 496 100 100     4165 my $ifdName = ($$dirInfo{DirName} and $$dirInfo{DirName} =~ /^(ExifIFD|GPS)$/) ? $1 : 'IFD0';
8644 496 100 100     3293 if (not $tagTablePtr or $$tagTablePtr{GROUPS}{0} eq 'EXIF') {
    100          
8645 420 100       2176 $self->FoundTag('ExifByteOrder', $byteOrder) unless $outfile;
8646 420         1587 $$self{ExifByteOrder} = $byteOrder;
8647             } elsif ($$tagTablePtr{GROUPS}{0} eq 'MakerNotes') { # (for writing CR3 maker notes)
8648 19         56 $ifdName = $$tagTablePtr{GROUPS}{0};
8649             } else {
8650 57         204 $ifdName = $$tagTablePtr{GROUPS}{1};
8651             }
8652 496 50       2025 if ($$self{HTML_DUMP}) {
8653 0 0       0 my $tip = sprintf("Byte order: %s endian\nIdentifier: 0x%.4x\n$ifdName offset: 0x%.4x",
8654             ($byteOrder eq 'II') ? 'Little' : 'Big', $identifier, $offset);
8655 0         0 $self->HDump($base, 8, 'TIFF header', $tip, 0);
8656             }
8657             # remember where we found the TIFF data (APP1, APP3, TIFF, NEF, etc...)
8658 496         1400 $$self{TIFF_TYPE} = $fileType;
8659              
8660             # get reference to the main EXIF table
8661 496 100       1815 $tagTablePtr or $tagTablePtr = GetTagTable('Image::ExifTool::Exif::Main');
8662              
8663             # build directory information hash
8664             my %dirInfo = (
8665             Base => $base,
8666             DataPt => $dataPt,
8667             DataLen => length $$dataPt,
8668             DataPos => 0,
8669             DirStart => $offset,
8670             DirLen => length($$dataPt) - $offset,
8671             RAF => $raf,
8672             DirName => $ifdName,
8673             Parent => $fileType,
8674             ImageData=> 'Main', # set flag to get information to copy main image data later
8675             Multi => $$dirInfo{Multi},
8676 496         7000 );
8677              
8678             # extract information from the image
8679 496 100       1793 unless ($outfile) {
8680             # process the directory
8681 370         1946 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
8682             # process GeoTiff information if available
8683 370 100       1984 if ($$self{VALUE}{GeoTiffDirectory}) {
8684 7         1211 require Image::ExifTool::GeoTiff;
8685 7         170 Image::ExifTool::GeoTiff::ProcessGeoTiff($self);
8686             }
8687             # process information in recognized trailers
8688 370 100       1441 if ($raf) {
8689 27         172 my $trailInfo = $self->IdentifyTrailer($raf);
8690 27 100       119 if ($trailInfo) {
8691             # scan to find AFCP if necessary (Note: we are scanning
8692             # from a random file position in the TIFF)
8693 3         11 $$trailInfo{ScanForTrailer} = 1;
8694 3         21 $self->ProcessTrailers($trailInfo);
8695             }
8696             # dump any other known trailer (eg. A100 RAW Data)
8697 27 0 33     153 if ($$self{HTML_DUMP} and $$self{KnownTrailer}) {
8698 0         0 my $known = $$self{KnownTrailer};
8699 0         0 $raf->Seek(0, 2);
8700 0         0 my $len = $raf->Tell() - $$known{Start};
8701 0 0       0 $len -= $$trailInfo{Offset} if $trailInfo; # account for other trailers
8702 0 0       0 $self->HDump($$known{Start}, $len, "[$$known{Name}]") if $len > 0;
8703             }
8704             }
8705             # update FileType if necessary now that we know more about the file
8706 370 50 66     1808 if ($$self{DNGVersion} and $$self{FILE_TYPE} eq 'TIFF' and $$self{FileType} !~ /^(DNG|GPR)$/) {
      66        
8707             # override whatever FileType we set since we now know it is DNG
8708 0         0 $self->OverrideFileType($$self{TIFF_TYPE} = 'DNG');
8709             }
8710 370 100 33     2724 if ($$self{TIFF_TYPE} eq 'TIFF') {
    50          
8711 10 50       44 $self->FoundTag(PageCount => $$self{PageCount}) if $$self{MultiPage};
8712             } elsif ($$self{TIFF_TYPE} eq 'NRW' and $$self{VALUE}{NEFLinearizationTable}) {
8713             # fix NEF type if misidentified as NRW
8714 0         0 $self->OverrideFileType($$self{TIFF_TYPE} = 'NEF');
8715             }
8716 370 0 33     1348 if ($$self{ImageDataHash} and $$self{A100DataOffset} and $raf->Seek($$self{A100DataOffset},0)) {
      0        
8717 0         0 $self->ImageDataHash($raf, undef, 'A100');
8718             }
8719 370         3218 return 1;
8720             }
8721             #
8722             # rewrite the image
8723             #
8724 126 100       492 if ($$dirInfo{NoTiffEnd}) {
8725 1         4 delete $$self{TIFF_END};
8726             } else {
8727             # initialize TIFF_END so it will be updated by WriteExif()
8728 125         442 $$self{TIFF_END} = 0;
8729             }
8730 126 100       455 if ($canonSig) {
8731             # write Canon CR2 specially because it has a header we want to preserve,
8732             # and possibly trailers added by the Canon utilities and/or PhotoMechanic
8733 3         11 $dirInfo{OutFile} = $outfile;
8734 3         38 require Image::ExifTool::CanonRaw;
8735 3 50       27 Image::ExifTool::CanonRaw::WriteCR2($self, \%dirInfo, $tagTablePtr) or $err = 1;
8736             } else {
8737             # write TIFF header (8 bytes [plus optional signature] followed by IFD)
8738 123 100       808 if ($fileType eq 'EXIF') {
    100          
8739 3         10 $otherSig = 'ExifMeta'; # force this signature for all EXIF files
8740             } elsif (not defined $otherSig) {
8741 119         301 $otherSig = '';
8742             }
8743 123         326 my $offset = 8 + length($otherSig);
8744             # construct tiff header
8745 123         641 my $header = substr($$dataPt, 0, 4) . Set32u($offset) . $otherSig;
8746 123         479 $dirInfo{NewDataPos} = $offset;
8747 123         413 $dirInfo{HeaderPtr} = \$header;
8748             # preserve padding between image data blocks in ORF images
8749             # (otherwise dcraw has problems because it assumes fixed block spacing)
8750 123 100 66     816 $dirInfo{PreserveImagePadding} = 1 if $fileType eq 'ORF' or $identifier != 0x2a;
8751 123         1166 my $newData = $self->WriteDirectory(\%dirInfo, $tagTablePtr);
8752 123 50       776 if (not defined $newData) {
    100          
8753 0         0 $err = 1;
8754             } elsif (length($newData)) {
8755             # update header length in case more was added
8756 117         339 my $hdrLen = length $header;
8757 117 100       436 if ($hdrLen != 8) {
8758 5         32 Set32u($hdrLen, \$header, 4);
8759             # also update preview fixup if necessary
8760 5         14 my $pi = $$self{PREVIEW_INFO};
8761 5 0 33     21 $$pi{Fixup}{Start} += $hdrLen - 8 if $pi and $$pi{Fixup};
8762             }
8763 117 50 33     807 if ($$self{TIFF_TYPE} eq 'ARW' and not $err) {
8764             # write any required ARW trailer and patch other ARW quirks
8765 0         0 require Image::ExifTool::Sony;
8766             my $errStr = Image::ExifTool::Sony::FinishARW($self, $dirInfo, \$newData,
8767 0         0 $dirInfo{ImageData});
8768 0 0       0 $errStr and $self->Error($errStr);
8769 0         0 delete $dirInfo{ImageData}; # (was copied by FinishARW)
8770             } else {
8771 117 50       796 Write($outfile, $header, $newData) or $err = 1;
8772             }
8773 117         468 undef $newData; # free memory
8774             }
8775             # copy over image data now if necessary
8776 123 100 66     789 if (ref $dirInfo{ImageData} and not $err) {
8777 10 50       172 $self->CopyImageData($dirInfo{ImageData}, $outfile) or $err = 1;
8778 10         49 delete $dirInfo{ImageData};
8779             }
8780             }
8781             # make local copy of TIFF_END now (it may be reset when processing trailers)
8782 126         478 my $tiffEnd = $$self{TIFF_END};
8783 126         344 delete $$self{TIFF_END};
8784              
8785             # rewrite trailers if they exist
8786 126 100 100     681 if ($raf and $tiffEnd and not $err) {
      66        
8787 12         25 my ($buf, $trailInfo);
8788 12 50       61 $raf->Seek(0, 2) or $err = 1;
8789 12         58 my $extra = $raf->Tell() - $tiffEnd;
8790             # check for trailer and process if possible
8791 12         27 for (;;) {
8792 12 100       41 last unless $extra > 12;
8793 3         15 $raf->Seek($tiffEnd); # seek back to end of image
8794 3         22 $trailInfo = $self->IdentifyTrailer($raf);
8795 3 50       18 last unless $trailInfo;
8796 0         0 my $tbuf = '';
8797 0         0 $$trailInfo{OutFile} = \$tbuf; # rewrite trailer(s)
8798 0         0 $$trailInfo{ScanForTrailer} = 1; # scan for AFCP if necessary
8799 0         0 $$self{TrailerStart} = $tiffEnd;
8800             # rewrite all trailers to buffer
8801 0 0       0 unless ($self->ProcessTrailers($trailInfo)) {
8802 0         0 undef $trailInfo;
8803 0         0 $err = 1;
8804 0         0 last;
8805             }
8806             # calculate unused bytes before trailer
8807 0         0 $extra = $$trailInfo{DataPos} - $tiffEnd;
8808 0         0 last; # yes, the 'for' loop was just a cheap 'goto'
8809             }
8810             # ignore a single zero byte if used for padding
8811 12 100 100     75 if ($extra > 0 and $tiffEnd & 0x01) {
8812 1 50       4 $raf->Seek($tiffEnd, 0) or $err = 1;
8813 1 50       5 $raf->Read($buf, 1) or $err = 1;
8814 1 50 33     22 defined $buf and $buf eq "\0" and --$extra, ++$tiffEnd;
8815             }
8816 12 100       41 if ($extra > 0) {
8817 3         11 my $known = $$self{KnownTrailer};
8818 3 50 33     31 if ($$self{DEL_GROUP}{Trailer} and not $known) {
    50          
8819 0         0 $self->VPrint(0, " Deleting unknown trailer ($extra bytes)\n");
8820 0         0 ++$$self{CHANGED};
8821             } elsif ($known) {
8822 0         0 $self->VPrint(0, " Copying $$known{Name} ($extra bytes)\n");
8823 0 0       0 $raf->Seek($tiffEnd, 0) or $err = 1;
8824 0 0       0 CopyBlock($raf, $outfile, $extra) or $err = 1;
8825             } else {
8826 3 50       13 $raf->Seek($tiffEnd, 0) or $err = 1;
8827             # preserve unknown trailer only if it contains non-null data
8828             # (Photoshop CS adds a trailer with 2 null bytes)
8829 3         10 my $size = $extra;
8830 3         7 for (;;) {
8831 3 50       16 my $n = $size > 65536 ? 65536 : $size;
8832 3 50       14 $raf->Read($buf, $n) == $n or $err = 1, last;
8833 3 50       23 if ($buf =~ /[^\0]/) {
8834 3         38 $self->VPrint(0, " Preserving unknown trailer ($extra bytes)\n");
8835             # copy the trailer since it contains non-null data
8836 3 50 0     14 Write($outfile, "\0"x($extra-$size)) or $err = 1, last if $size != $extra;
8837 3 50       19 Write($outfile, $buf) or $err = 1, last;
8838 3 50 0     12 CopyBlock($raf, $outfile, $size-$n) or $err = 1 if $size > $n;
8839 3         10 last;
8840             }
8841 0         0 $size -= $n;
8842 0 0       0 next if $size > 0;
8843 0         0 $self->VPrint(0, " Deleting blank trailer ($extra bytes)\n");
8844 0         0 last;
8845             }
8846             }
8847             }
8848             # write trailer buffer if necessary
8849 12 50 0     47 $self->WriteTrailerBuffer($trailInfo, $outfile) or $err = 1 if $trailInfo;
8850             # add any new trailers we are creating
8851 12         80 my $trailPt = $self->AddNewTrailers();
8852 12 100 33     86 Write($outfile, $$trailPt) or $err = 1 if $trailPt;
8853             }
8854             # check DNG version
8855 126 100       533 if ($$self{DNGVersion}) {
8856 1         2 my $ver = $$self{DNGVersion};
8857             # currently support up to DNG version 1.7
8858 1 50 33     24 unless ($ver =~ /^(\d+) (\d+)/ and "$1.$2" <= 1.7) {
8859 0         0 $ver =~ tr/ /./;
8860 0         0 $self->Error("DNG Version $ver not yet tested", 1);
8861             }
8862             }
8863 126 50       1632 return $err ? -1 : 1;
8864             }
8865              
8866             #------------------------------------------------------------------------------
8867             # Return list of tag table keys (ignoring special keys)
8868             # Inputs: 0) reference to tag table
8869             # Returns: List of table keys (unsorted)
8870             sub TagTableKeys($)
8871             {
8872 8157     8157 0 13970 local $_;
8873 8157         14820 my $tagTablePtr = shift;
8874 8157         13953 my @keyList;
8875 8157         148363 foreach (keys %$tagTablePtr) {
8876 518530 100       1115174 push(@keyList, $_) unless $specialTags{$_};
8877             }
8878 8157         116872 return @keyList;
8879             }
8880              
8881             #------------------------------------------------------------------------------
8882             # GetTagTable
8883             # Inputs: 0) table name
8884             # Returns: tag table reference, or undefined if not found
8885             # Notes: Always use this function instead of requiring module and using table
8886             # directly since this function also does the following the first time the table
8887             # is loaded:
8888             # - requires new module if necessary
8889             # - generates default GROUPS hash and Group 0 name from module name
8890             # - registers Composite tags if Composite table found
8891             # - saves descriptions for tags in specified table
8892             # - generates default TAG_PREFIX to be used for unknown tags
8893             sub GetTagTable($)
8894             {
8895 97410 100   97410 0 218205 my $tableName = shift or return undef;
8896 97406         213215 my $table = $allTables{$tableName};
8897              
8898 97406 100       177712 unless ($table) {
8899 113     113   1515 no strict 'refs';
  113         235  
  113         24722  
8900 4822 100       38965 unless (%$tableName) {
8901             # try to load module for this table
8902 919 50       8470 if ($tableName =~ /(.*)::/) {
8903 919         3940 my $module = $1;
8904 919 50       107892 if (not eval "require $module") {
    100          
8905 0 0       0 $@ and warn $@;
8906             } elsif (not %$tableName) {
8907             # load additional modules if required
8908 28 50       182 if ($module eq 'Image::ExifTool::XMP') {
    0          
8909 28         31610 require 'Image/ExifTool/XMP2.pl';
8910             } elsif ($tableName eq 'Image::ExifTool::QuickTime::Stream') {
8911 0         0 require 'Image/ExifTool/QuickTimeStream.pl';
8912             }
8913             }
8914             }
8915 919 50       8673 %$tableName or warn("Can't find table $tableName\n"), return undef;
8916             }
8917 113     113   859 no strict 'refs';
  113         266  
  113         6476  
8918 4822         14484 $table = \%$tableName;
8919 113     113   702 use strict 'refs';
  113         246  
  113         134197  
8920 4822 100       16646 &{$$table{INIT_TABLE}}($table) if $$table{INIT_TABLE};
  13         97  
8921 4822         14219 $$table{TABLE_NAME} = $tableName; # set table name
8922 4822         28962 ($$table{SHORT_NAME} = $tableName) =~ s/^Image::ExifTool:://;
8923             # set default group 0 and 1 from module name unless already specified
8924 4822         11866 my $defaultGroups = $$table{GROUPS};
8925 4822 100       12610 $defaultGroups or $defaultGroups = $$table{GROUPS} = { };
8926 4822 100 100     24664 unless ($$defaultGroups{0} and $$defaultGroups{1}) {
8927 3827 50       28101 if ($tableName =~ /Image::.*?::([^:]*)/) {
8928 3827 100       16507 $$defaultGroups{0} = $1 unless $$defaultGroups{0};
8929 3827 100       20629 $$defaultGroups{1} = $1 unless $$defaultGroups{1};
8930             } else {
8931 0 0       0 $$defaultGroups{0} = $tableName unless $$defaultGroups{0};
8932 0 0       0 $$defaultGroups{1} = $tableName unless $$defaultGroups{1};
8933             }
8934             }
8935 4822 100       13995 $$defaultGroups{2} = 'Other' unless $$defaultGroups{2};
8936 4822 100 100     23657 if ($$defaultGroups{0} eq 'XMP' or $$table{NAMESPACE}) {
8937             # initialize some XMP table defaults
8938 548         4421 require Image::ExifTool::XMP;
8939 548         3046 Image::ExifTool::XMP::RegisterNamespace($table); # register all table namespaces
8940             # set default write/check procs
8941 548 100       2038 $$table{WRITE_PROC} = \&Image::ExifTool::XMP::WriteXMP unless $$table{WRITE_PROC};
8942 548 100       1834 $$table{CHECK_PROC} = \&Image::ExifTool::XMP::CheckXMP unless $$table{CHECK_PROC};
8943 548 100       4310 $$table{LANG_INFO} = \&Image::ExifTool::XMP::GetLangInfo unless $$table{LANG_INFO};
8944             }
8945             # generate a tag prefix for unknown tags if necessary
8946 4822 100       12707 unless (defined $$table{TAG_PREFIX}) {
8947 4688         7385 my $tagPrefix;
8948 4688 50 66     34822 if ($tableName =~ /Image::.*?::(.*)::Main/ || $tableName =~ /Image::.*?::(.*)/) {
8949 4688         23546 ($tagPrefix = $1) =~ s/::/_/g;
8950             } else {
8951 0         0 $tagPrefix = $tableName;
8952             }
8953 4688         19201 $$table{TAG_PREFIX} = $tagPrefix;
8954             }
8955             # set up the new table
8956 4822         17925 SetupTagTable($table);
8957             # add any user-defined tags (except Composite tags, which are handled specially)
8958 4822 100 100     34769 if (%UserDefined and $UserDefined{$tableName} and $table ne \%Image::ExifTool::Composite) {
      66        
8959 2         6 my $tagID;
8960 2         11 foreach $tagID (TagTableKeys($UserDefined{$tableName})) {
8961 3 50       14 next if $specialTags{$tagID};
8962 3         9 delete $$table{$tagID}; # replace any existing entry
8963 3         20 AddTagToTable($table, $tagID, $UserDefined{$tableName}{$tagID}, 1);
8964             }
8965             }
8966             # remember order we loaded the tables in
8967 4822         13554 push @tableOrder, $tableName;
8968             # insert newly loaded table into list
8969 4822         29324 $allTables{$tableName} = $table;
8970             }
8971             # must check each time to add UserDefined Composite tags because the Composite table
8972             # may be loaded before the UserDefined tags are available
8973 97406 50 66     279486 if ($table eq \%Image::ExifTool::Composite and not $$table{VARS}{LOADED_USERDEFINED} and
      100        
      66        
8974             %UserDefined and $UserDefined{$tableName})
8975             {
8976 0         0 my $userComp = $UserDefined{$tableName};
8977 0         0 delete $UserDefined{$tableName}; # (must delete first to avoid infinite recursion)
8978 0         0 AddCompositeTags($userComp, 1);
8979 0         0 $UserDefined{$tableName} = $userComp; # (add back again for adding writable tags later)
8980 0         0 $$table{VARS}{LOADED_USERDEFINED} = 1; # set flag to avoid doing this again
8981             }
8982 97406         202532 return $table;
8983             }
8984              
8985             #------------------------------------------------------------------------------
8986             # Process an image directory
8987             # Inputs: 0) ExifTool object reference, 1) directory information reference
8988             # 2) tag table reference, 3) optional reference to processing procedure
8989             # Returns: Result from processing (1=success)
8990             sub ProcessDirectory($$$;$)
8991             {
8992 5229     5229 0 17396 my ($self, $dirInfo, $tagTablePtr, $proc) = @_;
8993              
8994 5229 50 33     24269 return 0 unless $tagTablePtr and $dirInfo;
8995             # use default proc from tag table or EXIF proc as fallback if no proc specified
8996 5229 100 100     24111 $proc or $proc = $$tagTablePtr{PROCESS_PROC} || \&Image::ExifTool::Exif::ProcessExif;
8997             # set directory name from default group0 name if not done already
8998 5229         11850 my $dirName = $$dirInfo{DirName};
8999 5229 100       12672 unless ($dirName) {
9000 704         2582 $dirName = $$tagTablePtr{GROUPS}{0};
9001 704 100       5470 $dirName = $$tagTablePtr{GROUPS}{1} if $dirName =~ /^APP\d+$/; # (use specific APP name)
9002 704         2025 $$dirInfo{DirName} = $dirName;
9003             }
9004              
9005             # guard against cyclical recursion into the same directory
9006 5229 100 100     32441 if (defined $$dirInfo{DirStart} and defined $$dirInfo{DataPos} and
      100        
      100        
9007             # directories don't overlap if the length is zero
9008             ($$dirInfo{DirLen} or not defined $$dirInfo{DirLen}))
9009             {
9010 4419   100     18275 my $addr = $$dirInfo{DirStart} + $$dirInfo{DataPos} + ($$dirInfo{Base}||0) + $$self{BASE};
9011 4419 50 33     18045 if ($$self{PROCESSED}{$addr} and not $$dirInfo{NotDup}) {
9012 0         0 $self->Warn("$dirName pointer references previous $$self{PROCESSED}{$addr} directory");
9013             # patch for bug in Windows phone 7.5 O/S that writes incorrect InteropIFD pointer
9014 0 0 0     0 return 0 unless $dirName eq 'GPS' and $$self{PROCESSED}{$addr} eq 'InteropIFD';
9015             }
9016 4419 50 66     24642 $$self{PROCESSED}{$addr} = $dirName unless $$tagTablePtr{VARS} and $$tagTablePtr{VARS}{ALLOW_REPROCESS};
9017             }
9018 5229         13980 my $oldOrder = GetByteOrder();
9019 5229         25724 my @save = @$self{'INDENT','DIR_NAME','Compression','SubfileType'};
9020 5229         17095 $$self{LIST_TAGS} = { }; # don't build lists across different directories
9021 5229         11681 $$self{INDENT} .= '| ';
9022 5229         10742 $$self{DIR_NAME} = $dirName;
9023 5229         8730 push @{$$self{PATH}}, $dirName;
  5229         15859  
9024 5229         18065 $$self{FOUND_DIR}{$dirName} = 1;
9025              
9026             # process the directory
9027 113     113   998 no strict 'refs';
  113         246  
  113         7278  
9028 5229         26722 my $rtnVal = &$proc($self, $dirInfo, $tagTablePtr);
9029 113     113   860 use strict 'refs';
  113         269  
  113         1270606  
9030              
9031 5229         10112 pop @{$$self{PATH}};
  5229         15492  
9032 5229         25886 @$self{'INDENT','DIR_NAME','Compression','SubfileType'} = @save;
9033 5229         17680 SetByteOrder($oldOrder);
9034 5229         32299 return $rtnVal;
9035             }
9036              
9037             #------------------------------------------------------------------------------
9038             # Get Metadata path
9039             # Inputs: 0) ExifTool object ref
9040             # Return: Metadata path string
9041             sub MetadataPath($)
9042             {
9043 742     742 0 1653 my $self = shift;
9044 742         1788 return join '-', @{$$self{PATH}}
  742         5125  
9045             }
9046              
9047             #------------------------------------------------------------------------------
9048             # Get standardized file extension
9049             # Inputs: 0) file name
9050             # Returns: standardized extension (all uppercase), or undefined if no extension
9051             sub GetFileExtension($)
9052             {
9053 2039     2039 0 4099 my $filename = shift;
9054 2039         4989 my $fileExt;
9055 2039 100 100     14903 if ($filename and $filename =~ /^.*\.([^.]+)$/s) {
9056 1897         5812 $fileExt = uc($1); # change extension to upper case
9057             # convert TIF extension to TIFF because we use the
9058             # extension for the file type tag of TIFF images
9059 1897 100       4916 $fileExt eq 'TIF' and $fileExt = 'TIFF';
9060             }
9061 2039         8138 return $fileExt;
9062             }
9063              
9064             #------------------------------------------------------------------------------
9065             # Get list of tag information hashes for given tag ID
9066             # Inputs: 0) Tag table reference, 1) tag ID
9067             # Returns: Array of tag information references
9068             # Notes: Generates tagInfo hash if necessary
9069             sub GetTagInfoList($$)
9070             {
9071 607327     607327 0 1012858 my ($tagTablePtr, $tagID) = @_;
9072 607327         1053230 my $tagInfo = $$tagTablePtr{$tagID};
9073              
9074 607327 50       1387024 if ($specialTags{$tagID}) {
    100          
    100          
    100          
9075             # (hopefully this won't happen)
9076 0         0 warn "Tag $tagID conflicts with internal ExifTool variable in $$tagTablePtr{TABLE_NAME}\n";
9077             } elsif (ref $tagInfo eq 'HASH') {
9078 553383         1120016 return ($tagInfo);
9079             } elsif (ref $tagInfo eq 'ARRAY') {
9080 11783         67375 return @$tagInfo;
9081             } elsif ($tagInfo) {
9082             # create hash with name
9083 37634         104777 $tagInfo = $$tagTablePtr{$tagID} = { Name => $tagInfo };
9084 37634         76621 return ($tagInfo);
9085             }
9086 4527         9483 return ();
9087             }
9088              
9089             #------------------------------------------------------------------------------
9090             # Find tag information, processing conditional tags
9091             # Inputs: 0) ExifTool object reference, 1) tagTable pointer, 2) tag ID
9092             # 3) optional value reference (usually reference to binary data value, but
9093             # depends on information type), 4) optional format type, 5) optional value count
9094             # Returns: pointer to tagInfo hash, undefined if none found, or '' if $valPt needed
9095             # Notes: You should always call this routine to find a tag in a table because
9096             # this routine will evaluate conditional tags.
9097             # Arguments 3-5 are only required if the information type allows $valPt, $format and/or
9098             # $count in a Condition, and if not given when needed this routine returns ''.
9099             sub GetTagInfo($$$;$$$)
9100             {
9101 114722     114722 0 247732 my ($self, $tagTablePtr, $tagID) = @_;
9102 114722         172907 my ($valPt, $format, $count);
9103              
9104 114722         251681 my @infoArray = GetTagInfoList($tagTablePtr, $tagID);
9105 114722         213511 my $options = $$self{OPTIONS};
9106             # evaluate condition
9107 114722         160388 my $tagInfo;
9108 114722         205731 foreach $tagInfo (@infoArray) {
9109 120399         243296 my $condition = $$tagInfo{Condition};
9110 120399 100       244867 if ($condition) {
9111 14284 100       35764 ($valPt, $format, $count) = splice(@_, 3) if @_ > 3;
9112 14284 100 100     86011 return '' if $condition =~ /\$(valPt|format|count)\b/ and not defined $valPt;
9113             # set old value for use in condition if needed
9114 13589         64897 local $SIG{'__WARN__'} = \&SetWarning;
9115 13589         23638 undef $evalWarning;
9116             #### eval Condition ($self, [$valPt, $format, $count])
9117 13589 100       1242665 unless (eval $condition) {
9118 11043 50       27303 $@ and $evalWarning = $@;
9119 11043 50       23207 $self->Warn("Condition $$tagInfo{Name}: " . CleanWarning()) if $evalWarning;
9120 11043         59855 next;
9121             }
9122             }
9123             # don't return Unknown tags unless that option is set or we are writing (also see forum13716)
9124 108661 100 100     294928 if ($$tagInfo{Unknown} and not $$options{Unknown} and
      100        
      100        
      66        
      100        
9125             (not $$self{IsWriting} or $$tagInfo{AddedUnknown}) and not
9126             ($$options{Verbose} or $$self{HTML_DUMP} or
9127             ($$options{Validate} and not $$tagInfo{AddedUnknown})))
9128             {
9129 1957         6910 return undef;
9130             }
9131             # return the tag information we found
9132 106704         285373 return $tagInfo;
9133             }
9134             # generate information for unknown tags (numerical only) if required
9135 5366 100 66     47889 if (not $tagInfo and ($$options{Unknown} or $$options{Verbose} or $$self{HTML_DUMP}) and
      66        
      100        
      100        
9136             $tagID =~ /^\d+$/ and not $$self{NO_UNKNOWN})
9137             {
9138 589         1019 my $printConv;
9139 589 100       1357 if (defined $$tagTablePtr{PRINT_CONV}) {
9140 155         290 $printConv = $$tagTablePtr{PRINT_CONV};
9141             } else {
9142             # limit length of printout (can be very long)
9143 434         1016 $printConv = \&LimitLongValues;
9144             }
9145 589         2194 my $hex = sprintf("0x%.4x", $tagID);
9146 589         1313 my $prefix = $$tagTablePtr{TAG_PREFIX};
9147 589         2170 $tagInfo = {
9148             Name => "${prefix}_$hex",
9149             Description => MakeDescription($prefix, $hex),
9150             Unknown => 1,
9151             Writable => 0, # can't write unknown tags
9152             PrintConv => $printConv,
9153             AddedUnknown => 1,
9154             };
9155             # add tag information to table
9156 589         1846 AddTagToTable($tagTablePtr, $tagID, $tagInfo);
9157             } else {
9158 4777         8310 undef $tagInfo;
9159             }
9160 5366         15900 return $tagInfo;
9161             }
9162              
9163             #------------------------------------------------------------------------------
9164             # Add new tag to table (must use this routine to add new tags to a table)
9165             # Inputs: 0) reference to tag table, 1) tag ID
9166             # 2) [optional] tag name or reference to tag information hash
9167             # 3) [optional] flag to avoid adding prefix when generating tag name
9168             # Returns: tagInfo ref
9169             # Notes: - will not override existing entry in table
9170             # - info need contain no entries when this routine is called
9171             # - tag name is cleaned if necessary
9172             sub AddTagToTable($$;$$)
9173             {
9174 7224     7224 0 14168 my ($tagTablePtr, $tagID, $tagInfo, $noPrefix) = @_;
9175              
9176             # generate tag info hash if necessary
9177 7224 0       15456 $tagInfo = $tagInfo ? { Name => $tagInfo } : { } unless ref $tagInfo eq 'HASH';
    50          
9178              
9179             # define necessary entries in information hash
9180 7224 100       12278 if ($$tagInfo{Groups}) {
9181             # fill in default groups from table GROUPS
9182 496         10358 foreach (keys %{$$tagTablePtr{GROUPS}}) {
  496         1663  
9183 1488 100       3217 next if $$tagInfo{Groups}{$_};
9184 534         1147 $$tagInfo{Groups}{$_} = $$tagTablePtr{GROUPS}{$_};
9185             }
9186             } else {
9187 6728         8595 $$tagInfo{Groups} = { %{$$tagTablePtr{GROUPS}} };
  6728         33424  
9188             }
9189 7224 100       16440 $$tagInfo{Flags} and ExpandFlags($tagInfo);
9190             $$tagInfo{GotGroups} = 1,
9191 7224         18124 $$tagInfo{Table} = $tagTablePtr;
9192 7224         12613 $$tagInfo{TagID} = $tagID;
9193 7224 100       14326 $$tagInfo{Hidden} = 1 unless defined $$tagInfo{Hidden};
9194 7224 100 100     16226 if (defined $$tagTablePtr{AVOID} and not defined $$tagInfo{Avoid}) {
9195 1744         2656 $$tagInfo{Avoid} = $$tagTablePtr{AVOID};
9196             }
9197              
9198 7224         11629 my $name = $$tagInfo{Name};
9199 7224 100       11675 $name = $tagID unless defined $name;
9200 7224         13173 $name =~ tr/-_a-zA-Z0-9//dc; # remove illegal characters
9201 7224         11012 $name = ucfirst $name; # capitalize first letter
9202             # add tag-name prefix if specified and tag name not provided
9203 7224 100 100     16303 unless (defined $$tagInfo{Name} or $noPrefix or not $$tagTablePtr{TAG_PREFIX}) {
      66        
9204             # make description to prevent tagID from getting mangled by MakeDescription()
9205 514         1024 $$tagInfo{Description} = MakeDescription($$tagTablePtr{TAG_PREFIX}, $name);
9206 514         1054 $name = "$$tagTablePtr{TAG_PREFIX}_$name";
9207             }
9208             # tag names must be at least 2 characters long and prefer them to start with a letter
9209 7224 100 66     29649 $name = "Tag$name" if length($name) < 2 or $name !~ /^[A-Z]/i;
9210 7224         11534 $$tagInfo{Name} = $name;
9211             # add tag to table, but never override existing entries (could potentially happen
9212             # if someone thinks there isn't any tagInfo because a condition wasn't satisfied)
9213 7224 50 66     22554 unless (defined $$tagTablePtr{$tagID} or $specialTags{$tagID}) {
9214 7157         31863 $$tagTablePtr{$tagID} = $tagInfo;
9215             }
9216 7224 100       13053 $$tagInfo{AddedUnknown} = 1 if $$tagInfo{Unknown};
9217 7224         14575 return $tagInfo;
9218             }
9219              
9220             #------------------------------------------------------------------------------
9221             # Handle simple extraction of new tag information
9222             # Inputs: 0) ExifTool object ref, 1) tag table reference, 2) tagID, 3) raw value,
9223             # 4-N) parameters hash: Index, DataPt, DataPos, Base, Start, Size, Parent,
9224             # TagInfo, ProcessProc, RAF, Format, Count, MakeTagInfo
9225             # Returns: tag key or undef if tag not found
9226             # Notes: if value is not defined, it is extracted from DataPt using TagInfo
9227             # Format and Count if provided
9228             # - set MakeTagInfo to add tag info for unknown tags with name made from tag ID
9229             sub HandleTag($$$$;%)
9230             {
9231 9769     9769 0 48657 my ($self, $tagTablePtr, $tag, $val, %parms) = @_;
9232 9769         23524 my $verbose = $$self{OPTIONS}{Verbose};
9233 9769         16705 my $pfmt = $parms{Format};
9234 9769 100       22409 my $valPt = defined $val ? \$val : undef;
9235 9769   100     45651 my $tagInfo = $parms{TagInfo} || $self->GetTagInfo($tagTablePtr, $tag, $valPt, $pfmt, $parms{Count});
9236 9769         21980 my $dataPt = $parms{DataPt};
9237 9769         16783 my ($subdir, $format, $noTagInfo, $rational, $binVal);
9238              
9239             # get binary data for Condition if necessary
9240 9769 50 66     28649 if (not $tagInfo and defined $tagInfo and $dataPt) {
      33        
9241 0   0     0 my $start = $parms{Start} || 0;
9242 0         0 my $size = $parms{Size};
9243 0 0       0 $size = length($$dataPt) - $start unless defined $size;
9244 0 0       0 return undef if $start + $size > length($$dataPt);
9245 0 0       0 $size = 1024 if $size > 1024; # max 1024 bytes available for the Condition
9246 0         0 my $dat = substr($$dataPt, $start, $size);
9247 0         0 $tagInfo = $self->GetTagInfo($tagTablePtr, $tag, \$dat, $pfmt, $parms{Count});
9248             }
9249 9769 100       21085 if ($tagInfo) {
    50          
9250 7574         14587 $subdir = $$tagInfo{SubDirectory};
9251             } elsif ($parms{MakeTagInfo}) {
9252 0 0       0 $self->VPrint(0, $$self{INDENT}, "[adding $tag]\n") if $verbose;
9253 0         0 my $name = $tag;
9254 0         0 $name =~ s/([A-Z]) ([A-Z][ A-Z])/${1}_$2/g; # underline between acronyms
9255 0         0 $name =~ s/([^A-Za-z])([a-z])/$1\u$2/g; # capitalize words
9256 0         0 $name =~ tr/-_a-zA-Z0-9//dc; # remove illegal characters
9257 0 0 0     0 $name = "Tag$name" if length($name) < 2 or $name =~ /^[-0-9]/;
9258 0         0 $tagInfo = { Name => ucfirst($name) };
9259 0         0 AddTagToTable($tagTablePtr, $tag, $tagInfo);
9260             } else {
9261 2195 50       10147 return undef unless $verbose;
9262 0         0 $tagInfo = { Name => "tag $tag" }; # create temporary tagInfo hash
9263 0         0 $noTagInfo = 1;
9264             }
9265             # read value if not done already (not necessary for subdir)
9266 7574 50 66     22528 unless (defined $val or ($subdir and not $$tagInfo{Writable} and not $$tagInfo{RawConv})) {
      66        
      100        
9267 890   100     2603 my $start = $parms{Start} || 0;
9268 890 50       2172 my $dLen = $dataPt ? length($$dataPt) : -1;
9269 890         1821 my $size = $parms{Size};
9270 890 100       1963 $size = $dLen unless defined $size;
9271             # read from data in memory if possible
9272 890 50 33     3916 if ($start >= 0 and $start + $size <= $dLen) {
9273 890   100     3590 $format = $$tagInfo{Format} || $$tagTablePtr{FORMAT};
9274 890 50 100     4587 $format = $pfmt if not $format and $pfmt and $formatSize{$pfmt};
      66        
9275 890 100       2305 if (not $format) {
    50          
9276 452         1252 $val = substr($$dataPt, $start, $size);
9277             } elsif (not $$tagInfo{ByteOrder}) {
9278 438         2333 $val = ReadValue($dataPt, $start, $format, $$tagInfo{Count}, $size, \$rational);
9279             } else {
9280 0         0 my $oldOrder = GetByteOrder(), SetByteOrder($$tagInfo{ByteOrder});
9281 0         0 $val = ReadValue($dataPt, $start, $format, $$tagInfo{Count}, $size, \$rational);
9282 0         0 SetByteOrder($oldOrder);
9283             }
9284 890 50       3577 $binVal = substr($$dataPt, $start, $size) if $$self{OPTIONS}{SaveBin};
9285             } else {
9286 0         0 $self->Warn("Error extracting value for $$tagInfo{Name}");
9287 0         0 return undef;
9288             }
9289             }
9290             # do verbose print if necessary
9291 7574 100       16294 if ($verbose) {
9292 51 50       93 undef $tagInfo if $noTagInfo;
9293 51         98 $parms{Value} = $val;
9294 51 50       110 $parms{Value} .= " ($rational)" if defined $rational;
9295 51         69 $parms{Table} = $tagTablePtr;
9296 51 50       77 if ($format) {
9297 0   0     0 my $count = int(($parms{Size} || 0) / ($formatSize{$format} || 1));
      0        
9298 0         0 $parms{Format} = $format . "[$count]";
9299             }
9300 51         189 $self->VerboseInfo($tag, $tagInfo, %parms);
9301             }
9302 7574 50       17515 if ($tagInfo) {
9303 7574 100       16340 if ($subdir) {
9304 752 50 66     2349 if ($$tagInfo{MakerNotes} and $$self{OPTIONS}{FastScan} and $$self{OPTIONS}{FastScan} > 1) {
      33        
9305 0         0 return undef; # don't process maker note directories when FastScan > 1
9306             }
9307 752         1748 my $subdirStart = $parms{Start};
9308 752         1611 my $subdirLen = $parms{Size};
9309 752 100 66     3467 if ($$tagInfo{RawConv} and not $$tagInfo{Writable}) {
    100          
9310 1         3 my $conv = $$tagInfo{RawConv};
9311 1         6 local $SIG{'__WARN__'} = \&SetWarning;
9312 1         3 undef $evalWarning;
9313 1 50       5 if (ref $conv eq 'CODE') {
9314 0         0 $val = &$conv($val, $self);
9315             } else {
9316 1         2 my ($priority, @grps);
9317             # NOTE: RawConv is evaluated in Writer.pl and twice in ExifTool.pm
9318             #### eval RawConv ($self, $val, $tag, $tagInfo, $priority, @grps)
9319 1         99 $val = eval $conv;
9320 1 50       8 $@ and $evalWarning = $@;
9321             }
9322 1 50       4 $self->Warn("RawConv $tag: " . CleanWarning()) if $evalWarning;
9323 1 50       4 return undef unless defined $val;
9324 1 50       7 $dataPt = ref $val eq 'SCALAR' ? $val : \$val;
9325 1         2 $subdirStart = 0;
9326 1         6 $subdirLen = length $$dataPt;
9327             } elsif (not $dataPt) {
9328 13 100       92 $dataPt = ref $val eq 'SCALAR' ? $val : \$val;
9329             }
9330 752 100       2377 if ($$subdir{Start}) {
9331 8         21 my $valuePtr = 0;
9332             #### eval Start ($valuePtr)
9333 8         627 my $off = eval $$subdir{Start};
9334 8         36 $subdirStart += $off;
9335 8         25 $subdirLen -= $off;
9336             }
9337             # process subdirectory information
9338             my %dirInfo = (
9339             DirName => $$subdir{DirName} || $$tagInfo{Name},
9340             DataPt => $dataPt,
9341             DataLen => length $$dataPt,
9342             DataPos => $parms{DataPos},
9343             DirStart => $subdirStart,
9344             DirLen => $subdirLen,
9345             Parent => $parms{Parent},
9346             Base => $parms{Base},
9347             Multi => $$subdir{Multi},
9348             TagInfo => $tagInfo,
9349             IgnoreProp => $$subdir{IgnoreProp},
9350             RAF => $parms{RAF},
9351 752   66     9913 );
9352 752         2371 my $oldOrder = GetByteOrder();
9353 752 100       2453 if ($$subdir{ByteOrder}) {
9354 3 100       15 if ($$subdir{ByteOrder} eq 'Unknown') {
9355 1 50       5 if ($subdirStart + 2 <= $subdirLen) {
9356             # attempt to determine the byte ordering of an IFD-style subdirectory
9357 1         5 my $num = Get16u($dataPt, $subdirStart);
9358 1 50 33     12 ToggleByteOrder if $num & 0xff00 and ($num>>8) > ($num&0xff);
9359             }
9360             } else {
9361 2         9 SetByteOrder($$subdir{ByteOrder});
9362             }
9363             }
9364 752   33     2679 my $subTablePtr = GetTagTable($$subdir{TagTable}) || $tagTablePtr;
9365 752   100     5824 $self->ProcessDirectory(\%dirInfo, $subTablePtr, $$subdir{ProcessProc} || $parms{ProcessProc});
9366 752         2254 SetByteOrder($oldOrder);
9367             # return now unless directory is writable as a block
9368 752 50       8678 return undef unless $$tagInfo{Writable};
9369             }
9370 6822         19082 my $key = $self->FoundTag($tagInfo, $val);
9371 6822 100       17627 if (defined $key) {
9372             # save original components of rational numbers and original binary value
9373 6813 100       14919 $$self{TAG_EXTRA}{$key}{Rational} = $rational if defined $rational;
9374 6813 50       14043 $$self{TAG_EXTRA}{$key}{BinVal} = $binVal if defined $binVal;
9375             }
9376 6822         30607 return $key;
9377             }
9378 0         0 return undef;
9379             }
9380              
9381             #------------------------------------------------------------------------------
9382             # Add tag to hash of extracted information
9383             # Inputs: 0) ExifTool object reference
9384             # 1) reference to tagInfo hash or tag name
9385             # 2) data value (or reference to require hash if Composite)
9386             # 3) optional family 0 group, 4) optional family 1 group
9387             # Returns: tag key or undef if no value
9388             sub FoundTag($$$;@)
9389             {
9390 61451     61451 0 106745 local $_;
9391 61451         142173 my ($self, $tagInfo, $value, @grps) = @_;
9392 61451         96979 my ($tag, $noListDel, $tbl);
9393 61451         115826 my $options = $$self{OPTIONS};
9394              
9395 61451 100       148693 if (ref $tagInfo eq 'HASH') {
9396 53646 50       169695 $tag = $$tagInfo{Name} or warn("No tag name\n"), return undef;
9397 53646         98985 $tbl = $$tagInfo{Table};
9398             } else {
9399 7805         12941 $tag = $tagInfo;
9400             # look for tag in Extra
9401 7805         18730 $tbl = GetTagTable('Image::ExifTool::Extra');
9402 7805         21261 $tagInfo = $self->GetTagInfo($tbl, $tag);
9403             # make temporary hash if tag doesn't exist in Extra
9404             # (not advised to do this since the tag won't show in list)
9405 7805 100       17022 $tagInfo or $tagInfo = { Name => $tag, Groups => \%allGroupsExifTool };
9406 7805 100       19713 $$options{Verbose} and $self->VerboseInfo(undef, $tagInfo, Value => $value);
9407             }
9408             # get tag priority
9409 61451         111017 my $priority = $$tagInfo{Priority};
9410 61451 100       127826 unless (defined $priority) {
9411 55145         95966 $priority = $$tbl{PRIORITY};
9412 55145 100 100     212705 $priority = 0 if not defined $priority and $$tagInfo{Avoid};
9413             }
9414 61451 100       155406 $grps[0] or $grps[0] = $$self{SET_GROUP0};
9415 61451 100       149069 $grps[1] or $grps[1] = $$self{SET_GROUP1};
9416 61451 50       145388 if ($$options{IgnoreGroups}) {
9417 0         0 foreach (0..1) {
9418 0   0     0 my $g = lc($grps[$_] || $$tagInfo{Groups}{$_} || $$tagInfo{Table}{GROUPS}{$_});
9419 0 0 0     0 return undef if $$options{IgnoreGroups}{$g} or $$options{IgnoreGroups}{"$_$g"};
9420             }
9421             }
9422 61451         111999 my $valueHash = $$self{VALUE};
9423              
9424 61451 100       137980 if ($$tagInfo{RawConv}) {
9425             # initialize @val for use in Composite RawConv expressions
9426 9926         15833 my @val;
9427 9926 50 66     28879 if (ref $value eq 'HASH' and $$tagInfo{IsComposite}) {
9428 1840         5307 foreach (keys %$value) { $val[$_] = $$valueHash{$$value{$_}}; }
  6164         18230  
9429             }
9430 9926         22150 my $conv = $$tagInfo{RawConv};
9431 9926         62034 local $SIG{'__WARN__'} = \&SetWarning;
9432 9926         21929 undef $evalWarning;
9433 9926 100       22932 if (ref $conv eq 'CODE') {
9434 241         1140 $value = &$conv($value, $self);
9435 241 50       1060 $$self{grps} and @grps = @{$$self{grps}}, delete $$self{grps};
  0         0  
9436             } else {
9437 9685         18490 my $val = $value; # do this so eval can use $val
9438             # NOTE: RawConv is also evaluated in Writer.pl
9439             #### eval RawConv ($self, $val, $tag, $tagInfo, $priority, @grps)
9440 9685         1189161 $value = eval $conv;
9441 9685 50       51905 $@ and $evalWarning = $@;
9442             }
9443 9926 50       23163 $self->Warn("RawConv $tag: " . CleanWarning()) if $evalWarning;
9444 9926 100       55048 return undef unless defined $value;
9445             }
9446             # ignore specified tags (AFTER doing RawConv if necessary!)
9447 58717 50       137751 if ($$options{IgnoreTags}) {
9448 0 0       0 if ($$options{IgnoreTags}{all}) {
9449 0 0       0 return undef unless $$self{REQ_TAG_LOOKUP}{lc $tag};
9450             } else {
9451 0 0       0 return undef if $$options{IgnoreTags}{lc $tag};
9452             }
9453             }
9454             # handle duplicate tag names
9455 58717 100       178951 if (defined $$valueHash{$tag}) {
    100          
9456             # add to list if there is an active list for this tag
9457 7031 100       26717 if ($$self{LIST_TAGS}{$tagInfo}) {
9458 701         1602 $tag = $$self{LIST_TAGS}{$tagInfo}; # use key from previous list tag
9459 701 100       1845 if (defined $$self{NO_LIST}) {
9460             # accumulate list in TAG_EXTRA "NoList" element
9461 65 100       302 if (defined $$self{TAG_EXTRA}{$tag}{NoList}) {
9462 31         63 push @{$$self{TAG_EXTRA}{$tag}{NoList}}, $value;
  31         145  
9463             } else {
9464 34         182 $$self{TAG_EXTRA}{$tag}{NoList} = [ $$valueHash{$tag}, $value ];
9465             }
9466 65         153 $noListDel = 1; # set flag to delete this tag if re-listed
9467             } else {
9468 636 100       1908 if (ref $$valueHash{$tag} ne 'ARRAY') {
9469 319         1280 $$valueHash{$tag} = [ $$valueHash{$tag} ];
9470             }
9471 636         1070 push @{$$valueHash{$tag}}, $value;
  636         2182  
9472 636         2669 return $tag; # return without creating a new entry
9473             }
9474             }
9475             # get next available tag key
9476 6395   100     35397 my $nextInd = $$self{DUPL_TAG}{$tag} = ($$self{DUPL_TAG}{$tag} || 0) + 1;
9477 6395         15924 my $nextTag = "$tag ($nextInd)";
9478             #
9479             # take tag with highest priority
9480             #
9481             # promote existing 0-priority tag so it takes precedence over a new 0-tag
9482             # (unless old tag was a sub-document and new tag isn't. Also, never override
9483             # a Warning tag because they may be added by ValueConv, which could be confusing)
9484 6395         14941 my $oldPriority = $$self{PRIORITY}{$tag};
9485 6395 100       16277 unless ($oldPriority) {
9486 5404 100 100     47000 if ($$self{DOC_NUM} or $tag eq 'Warning' or not $$self{TAG_EXTRA}{$tag}{G3}) {
      100        
9487 5369         9783 $oldPriority = 1;
9488             } else {
9489 35         77 $oldPriority = 0; # don't promote sub-document tag over main document
9490             }
9491             }
9492             # set priority for this tag
9493 6395 100 100     35531 if (defined $priority) {
    100 33        
9494             # increase 0-priority tags if this is the priority directory
9495             $priority = 1 if not $priority and $$self{DIR_NAME} and
9496 2134 100 100     14438 $$self{DIR_NAME} eq $$self{PRIORITY_DIR};
      100        
9497             } elsif ($$self{LOW_PRIORITY_DIR}{'*'} or
9498             ($$self{DIR_NAME} and $$self{LOW_PRIORITY_DIR}{$$self{DIR_NAME}}))
9499             {
9500 411         739 $priority = 0; # default is 0 for a LOW_PRIORITY_DIR
9501             } else {
9502 3850         6628 $priority = 1; # the normal default
9503             }
9504 6395 100 100     34521 if ($priority >= $oldPriority and (not $$self{DOC_NUM} or ($$self{TAG_EXTRA}{$tag}{G3} and
      100        
      100        
9505             $$self{DOC_NUM} eq $$self{TAG_EXTRA}{$tag}{G3})) and not $noListDel)
9506             {
9507             # move existing tag out of the way since this tag is higher priority
9508             # (NOTE: any new members added here must also be added to DeleteTag())
9509 2953         11288 $$self{PRIORITY}{$nextTag} = $$self{PRIORITY}{$tag};
9510 2953         9896 $$valueHash{$nextTag} = $$valueHash{$tag};
9511 2953         8693 $$self{FILE_ORDER}{$nextTag} = $$self{FILE_ORDER}{$tag};
9512 2953         9244 my $oldInfo = $$self{TAG_INFO}{$nextTag} = $$self{TAG_INFO}{$tag};
9513 2953         7899 $$self{TAG_EXTRA}{$nextTag} = $$self{TAG_EXTRA}{$tag};
9514 2953         7408 $$self{TAG_EXTRA}{$tag} = { };
9515 2953         7301 delete $$self{BOTH}{$tag};
9516             # update tag key for list if necessary
9517 2953 100       8854 $$self{LIST_TAGS}{$oldInfo} = $nextTag if $$self{LIST_TAGS}{$oldInfo};
9518             # update this key if used in a Composite tag
9519 2953 100       9661 if ($$self{COMP_KEYS}{$tag}) {
9520 97         177 $$_[0]{$$_[1]} = $nextTag foreach @{$$self{COMP_KEYS}{$tag}};
  97         544  
9521 97         252 $$self{COMP_KEYS}{$nextTag} = $$self{COMP_KEYS}{$tag};
9522 97         280 delete $$self{COMP_KEYS}{$tag};
9523             }
9524             } else {
9525 3442         6737 $tag = $nextTag; # don't override the existing tag
9526             }
9527 6395         18782 $$self{PRIORITY}{$tag} = $priority;
9528 6395 100       16785 $$self{TAG_EXTRA}{$tag}{NoListDel} = 1 if $noListDel;
9529             } elsif ($priority) {
9530             # set tag priority (only if exists and is non-zero)
9531 1915         6141 $$self{PRIORITY}{$tag} = $priority;
9532             }
9533              
9534             # save the raw value, file order, tagInfo ref, group1 name,
9535             # and tag key for lists if necessary
9536 58081         177426 $$valueHash{$tag} = $value;
9537 58081         156611 $$self{FILE_ORDER}{$tag} = ++$$self{NUM_FOUND};
9538 58081         140626 $$self{TAG_INFO}{$tag} = $tagInfo;
9539 58081 100       205578 $$self{TAG_EXTRA}{$tag} = { } unless $$self{TAG_EXTRA}{$tag};
9540             # set dynamic groups 0, 1 and 3 if necessary
9541 58081 100       129598 $$self{TAG_EXTRA}{$tag}{G0} = $grps[0] if $grps[0];
9542 58081 100       125221 $$self{TAG_EXTRA}{$tag}{G1} = $grps[1] if $grps[1];
9543 58081 100       132733 if ($$self{DOC_NUM}) {
9544 1798         5258 $$self{TAG_EXTRA}{$tag}{G3} = $$self{DOC_NUM};
9545 1798         4758 $$self{HAS_DOC}{$$self{DOC_NUM}} = 1;
9546 1798 50       8212 if ($$self{DOC_NUM} =~ /^(\d+)/) {
9547             # keep track of maximum 1st-level sub-document number
9548 1798 100       7335 $$self{DOC_COUNT} = $1 unless $$self{DOC_COUNT} >= $1;
9549             }
9550             }
9551             # save path if requested
9552 58081 100       122982 $$self{TAG_EXTRA}{$tag}{G5} = $self->MetadataPath() if $$options{SavePath};
9553              
9554             # remember this tagInfo if we will be accumulating values in a list
9555             # (but don't override earlier list if this may be deleted by NoListDel flag)
9556 58081 100 100     150645 if ($$tagInfo{List} and not $$self{NO_LIST} and not $noListDel) {
      100        
9557 1166         4911 $$self{LIST_TAGS}{$tagInfo} = $tag;
9558             }
9559              
9560             # validate tag if requested (but only for simple values -- could result
9561             # in infinite recursion if called for a Composite tag (HASH ref value)
9562             # because FoundTag is called in the middle of building Composite tags
9563 58081 100 100     143426 if ($$options{Validate} and not ref $value) {
9564 213         801 Image::ExifTool::Validate::ValidateRaw($self, $tag, $value);
9565             }
9566              
9567 58081         217982 return $tag;
9568             }
9569              
9570             #------------------------------------------------------------------------------
9571             # Make current directory the priority directory if not set already
9572             # Inputs: 0) ExifTool object reference
9573             sub SetPriorityDir($)
9574             {
9575 22     22 0 70 my $self = shift;
9576 22 50       530 $$self{PRIORITY_DIR} = $$self{DIR_NAME} unless $$self{PRIORITY_DIR};
9577             }
9578              
9579             #------------------------------------------------------------------------------
9580             # Set family 0 or 1 group name specific to this tag instance
9581             # Inputs: 0) ExifTool ref, 1) tag key, 2) group name, 3) family (default 1)
9582             sub SetGroup($$$;$)
9583             {
9584 13782     13782 0 35071 my ($self, $tagKey, $extra, $fam) = @_;
9585 13782 50       62411 $$self{TAG_EXTRA}{$tagKey}{defined $fam ? "G$fam" : 'G1'} = $extra;
9586             }
9587              
9588             #------------------------------------------------------------------------------
9589             # Delete specified tag
9590             # Inputs: 0) ExifTool object ref, 1) tag key
9591             sub DeleteTag($$)
9592             {
9593 224     224 0 457 my ($self, $tag) = @_;
9594 224         507 delete $$self{VALUE}{$tag};
9595 224         472 delete $$self{FILE_ORDER}{$tag};
9596 224         433 delete $$self{TAG_INFO}{$tag};
9597 224         553 delete $$self{TAG_EXTRA}{$tag};
9598 224         454 delete $$self{PRIORITY}{$tag};
9599 224         700 delete $$self{BOTH}{$tag};
9600             }
9601              
9602             #------------------------------------------------------------------------------
9603             # Escape all elements of a value
9604             # Inputs: 0) value, 1) escape proc
9605             sub DoEscape($$)
9606             {
9607 173     173 0 278 my ($val, $key);
9608 173 100       385 if (not ref $_[0]) {
    100          
    50          
9609 167         287 $_[0] = &{$_[1]}($_[0]);
  167         492  
9610             } elsif (ref $_[0] eq 'ARRAY') {
9611 4         7 foreach $val (@{$_[0]}) {
  4         10  
9612 10         26 DoEscape($val, $_[1]);
9613             }
9614             } elsif (ref $_[0] eq 'HASH') {
9615 0         0 foreach $key (keys %{$_[0]}) {
  0         0  
9616 0         0 DoEscape($_[0]{$key}, $_[1]);
9617             }
9618             }
9619             }
9620              
9621             #------------------------------------------------------------------------------
9622             # Set the FileType and MIMEType tags
9623             # Inputs: 0) ExifTool object reference
9624             # 1) Optional file type (uses FILE_TYPE if not specified)
9625             # 2) Optional MIME type (uses our lookup if not specified)
9626             # 3) Optional recommended extension (converted to lower case; uses FileType if undef)
9627             # Notes: Will NOT set file type twice (subsequent calls ignored)
9628             sub SetFileType($;$$$)
9629             {
9630 676     676 0 2502 my ($self, $fileType, $mimeType, $normExt) = @_;
9631             # use only the first FileType set if called again for the main document
9632 676 100 66     3948 unless ($$self{FileType} and not $$self{DOC_NUM}) {
9633 627         1763 my $baseType = $$self{FILE_TYPE};
9634 627         1753 my $ext = $$self{FILE_EXT};
9635 627 100       2254 $fileType or $fileType = $baseType;
9636             # handle sub-types which are identified by extension
9637 627 100 100     4837 if (defined $ext and $ext ne $fileType and not $$self{DOC_NUM}) {
      66        
9638 275         1324 my ($f,$e) = @fileTypeLookup{$fileType,$ext};
9639 275 100 100     2168 if (ref $f eq 'ARRAY' and ref $e eq 'ARRAY' and $$f[0] eq $$e[0]) {
      100        
9640             # make sure $fileType was a root type and not another sub-type
9641 10 100 66     99 $fileType = $ext if $$f[0] eq $fileType or not $fileTypeLookup{$$f[0]};
9642             }
9643             }
9644 627 100       3118 $mimeType or $mimeType = $mimeType{$fileType};
9645             # use base file type if necessary (except if 'TIFF', which is a special case)
9646 627 100 66     2559 $mimeType = $mimeType{$baseType} unless $mimeType or $baseType eq 'TIFF';
9647 627 100       2129 unless (defined $normExt) {
9648 617         2019 $normExt = $fileTypeExt{$fileType};
9649 617 100       2111 $normExt = $fileType unless defined $normExt;
9650             }
9651             # ($$self{FileType} is the file type of the main document)
9652 627 50       4217 $$self{FileType} = $fileType unless $$self{DOC_NUM};
9653 627         2919 $self->FoundTag('FileType', $fileType);
9654 627         3296 $self->FoundTag('FileTypeExtension', uc $normExt);
9655 627   100     3275 $self->FoundTag('MIMEType', $mimeType || 'application/unknown');
9656             }
9657             }
9658              
9659             #------------------------------------------------------------------------------
9660             # Override the FileType and MIMEType tags
9661             # Inputs: 0) ExifTool object ref, 1) file type, 2) MIME type, 3) normal extension (lower case)
9662             # Notes: does nothing if FileType was not previously defined (ie. when writing)
9663             sub OverrideFileType($$;$$)
9664             {
9665 18     18 0 80 my ($self, $fileType, $mimeType, $normExt) = @_;
9666 18 100 66     189 if (defined $$self{VALUE}{FileType} and $fileType ne $$self{VALUE}{FileType}) {
9667 12         43 $$self{FileType} = $fileType;
9668 12         38 $$self{VALUE}{FileType} = $fileType;
9669 12 100       44 unless (defined $normExt) {
9670 5         14 $normExt = $fileTypeExt{$fileType};
9671 5 50       25 $normExt = $fileType unless defined $normExt;
9672             }
9673 12         60 $$self{VALUE}{FileTypeExtension} = uc $normExt;
9674 12 50       62 $mimeType or $mimeType = $mimeType{$fileType};
9675 12 100       48 $$self{VALUE}{MIMEType} = $mimeType if $mimeType;
9676 12 50       182 if ($$self{OPTIONS}{Verbose}) {
9677 0         0 $self->VPrint(0,"$$self{INDENT}FileType [override] = $fileType\n");
9678 0         0 $self->VPrint(0,"$$self{INDENT}FileTypeExtension [override] = $$self{VALUE}{FileTypeExtension}\n");
9679 0 0       0 $self->VPrint(0,"$$self{INDENT}MIMEType [override] = $mimeType\n") if $mimeType;
9680             }
9681             }
9682             }
9683              
9684             #------------------------------------------------------------------------------
9685             # Modify the value of the MIMEType tag
9686             # Inputs: 0) ExifTool object reference, 1) file or MIME type
9687             # Notes: combines existing type with new type: ie) a/b + c/d => c/b-d
9688             sub ModifyMimeType($;$)
9689             {
9690 8     8 0 28 my ($self, $mime) = @_;
9691 8 50 33     51 $mime =~ m{/} or $mime = $mimeType{$mime} or return;
9692 8         36 my $old = $$self{VALUE}{MIMEType};
9693 8 50       41 if (defined $old) {
9694 8         46 my ($a, $b) = split '/', $old;
9695 8         30 my ($c, $d) = split '/', $mime;
9696 8         28 $d =~ s/^x-//;
9697 8         32 $$self{VALUE}{MIMEType} = "$c/$b-$d";
9698 8         49 $self->VPrint(0, " Modified MIMEType = $c/$b-$d\n");
9699             } else {
9700 0         0 $self->FoundTag('MIMEType', $mime);
9701             }
9702             }
9703              
9704             #------------------------------------------------------------------------------
9705             # Print verbose output
9706             # Inputs: 0) ExifTool ref, 1) verbose level (prints if level > this), 2-N) print args
9707             sub VPrint($$@)
9708             {
9709 12492     12492 0 20852 my $self = shift;
9710 12492         28149 my $level = shift;
9711 12492 100 66     48568 if ($$self{OPTIONS}{Verbose} and $$self{OPTIONS}{Verbose} > $level) {
9712 4         15 my $out = $$self{OPTIONS}{TextOut};
9713 4         34 print $out @_;
9714 4 50       38 print $out "\n" unless $_[-1] =~ /\n$/;
9715             }
9716             }
9717              
9718             #------------------------------------------------------------------------------
9719             # Print verbose directory information
9720             # Inputs: 0) ExifTool object reference, 1) directory name or dirInfo ref
9721             # 2) number of entries in directory (or 0 if unknown)
9722             # 3) optional size of directory in bytes, 4) optional byte order for -v3 output
9723             sub VerboseDir($$;$$$)
9724             {
9725 2009     2009 0 4437 my ($self, $name, $entries, $size, $byteOrder) = @_;
9726 2009 100       5860 return unless $$self{OPTIONS}{Verbose};
9727 44 50       149 if (ref $name eq 'HASH') {
9728 0 0       0 $size = $$name{DirLen} unless $size;
9729 0   0     0 $name = $$name{Name} || $$name{DirName};
9730             }
9731 44         144 my $indent = substr($$self{INDENT}, 0, -2);
9732 44         141 my $out = $$self{OPTIONS}{TextOut};
9733 44 100 66     298 my $str = ($entries or defined $entries and not $size) ? " with $entries entries" : '';
9734 44 100       185 $str .= ", $size bytes" if $size;
9735 44 100 100     224 if ($byteOrder and $$self{OPTIONS}{Verbose} > 2) {
9736 11 50       25 $str .= ', ' . (GetByteOrder() eq 'II' ? 'Little-endian' : 'Big-endian');
9737             }
9738 44         229 print $out "$indent+ [$name directory$str]\n";
9739             }
9740              
9741             #------------------------------------------------------------------------------
9742             # Verbose dump
9743             # Inputs: 0) ExifTool ref, 1) data ref, 2-N) HexDump options
9744             sub VerboseDump($$;%)
9745             {
9746 1666     1666 0 2274 my $self = shift;
9747 1666         2208 my $dataPt = shift;
9748 1666         2363 my $verbose = $$self{OPTIONS}{Verbose};
9749 1666 50 33     3693 if ($verbose and $verbose > 2) {
9750             my %parms = (
9751             Prefix => $$self{INDENT},
9752             Out => $$self{OPTIONS}{TextOut},
9753 0 0       0 MaxLen => $verbose < 4 ? 96 : $verbose < 5 ? 2048 : undef,
    0          
9754             );
9755 0         0 HexDump($dataPt, undef, %parms, @_);
9756             }
9757             }
9758              
9759             #------------------------------------------------------------------------------
9760             # Print data in hex
9761             # Inputs: 0) data
9762             # Returns: hex string
9763             # (this is a convenience function for use in debugging PrintConv statements)
9764             sub PrintHex($)
9765             {
9766 0     0 0 0 my $val = shift;
9767 0         0 return join(' ', unpack('H2' x length($val), $val));
9768             }
9769              
9770             #------------------------------------------------------------------------------
9771             # Extract binary data from file
9772             # 0) ExifTool object reference, 1) offset, 2) length, 3) tag name if conditional
9773             # Returns: binary data, or undef on error
9774             # Notes: Returns "Binary data #### bytes" instead of data unless tag is
9775             # specifically requested or the Binary option is set
9776             sub ExtractBinary($$$;$)
9777             {
9778 47     47 0 160 my ($self, $offset, $length, $tag) = @_;
9779 47         142 my ($isPreview, $buff);
9780              
9781 47 100       160 if ($tag) {
9782 43 100       177 if ($tag eq 'PreviewImage') {
9783             # save PreviewImage start/length in case we want to dump trailer
9784 29         106 $$self{PreviewImageStart} = $offset;
9785 29         99 $$self{PreviewImageLength} = $length;
9786 29         65 $isPreview = 1;
9787             }
9788 43         140 my $lcTag = lc $tag;
9789 43         138 my $options = $$self{OPTIONS};
9790 43 100 66     699 if ((not $$options{Binary} or $$self{EXCL_TAG_LOOKUP}{$lcTag}) and
      66        
      100        
      66        
9791             not $$options{Verbose} and not $$options{Validate} and
9792             not $$self{REQ_TAG_LOOKUP}{$lcTag})
9793             {
9794 32         192 return "Binary data $length bytes";
9795             }
9796             }
9797 15 100 66     101 unless ($$self{RAF}->Seek($offset,0)
9798             and $$self{RAF}->Read($buff, $length) == $length)
9799             {
9800 5 50       16 $tag or $tag = 'binary data';
9801 5 50 33     26 if ($isPreview and not $$self{BuildingComposite}) {
9802 0         0 $$self{PreviewError} = 1;
9803             } else {
9804 5         29 $self->Warn("Error reading $tag from file", $isPreview);
9805             }
9806 5         26 return undef;
9807             }
9808 10         47 return $buff;
9809             }
9810              
9811             #------------------------------------------------------------------------------
9812             # Process binary data
9813             # Inputs: 0) ExifTool object ref, 1) directory information ref, 2) tag table ref
9814             # Returns: 1 on success
9815             # Notes: dirInfo may contain VarFormatData (reference to empty list) to return
9816             # details about any variable-length-format tags in the table (used when writing)
9817             sub ProcessBinaryData($$$)
9818             {
9819 2223     2223 0 6001 my ($self, $dirInfo, $tagTablePtr) = @_;
9820 2223         5020 my $dataPt = $$dirInfo{DataPt};
9821 2223         4513 my $dataLen = length $$dataPt;
9822 2223   100     8128 my $dirStart = $$dirInfo{DirStart} || 0;
9823 2223         4615 my $maxLen = $dataLen - $dirStart;
9824 2223         5056 my $size = $$dirInfo{DirLen};
9825 2223   100     7890 my $base = $$dirInfo{Base} || 0;
9826 2223         5664 my $verbose = $$self{OPTIONS}{Verbose};
9827 2223         4939 my $unknown = $$self{OPTIONS}{Unknown};
9828 2223   100     8182 my $dataPos = $$dirInfo{DataPos} || 0;
9829              
9830 2223 100 66     9947 $size = $maxLen if not defined $size or $size > $maxLen;
9831             # get default format ('int8u' unless specified)
9832 2223   100     8858 my $defaultFormat = $$tagTablePtr{FORMAT} || 'int8u';
9833 2223         5969 my $increment = $formatSize{$defaultFormat};
9834 2223 50       5838 unless ($increment) {
9835 0         0 warn "Unknown format $defaultFormat\n";
9836 0         0 $defaultFormat = 'int8u';
9837 0         0 $increment = $formatSize{$defaultFormat};
9838             }
9839             # prepare list of tag numbers to extract
9840 2223         4497 my (@tags, $topIndex, $binVal);
9841 2223 50 33     11896 if ($unknown > 1 and defined $$tagTablePtr{FIRST_ENTRY}) {
    100          
    100          
9842             # don't create a stupid number of tags if data is huge
9843 0 0       0 my $sizeLimit = $size < 65536 ? $size : 65536;
9844             # scan through entire binary table
9845 0         0 $topIndex = int($sizeLimit/$increment);
9846 0         0 @tags = ($$tagTablePtr{FIRST_ENTRY}..($topIndex - 1));
9847             # add in floating point tag ID's if they exist
9848 0         0 my @ftags = grep /\./, TagTableKeys($tagTablePtr);
9849 0 0       0 @tags = sort { $a <=> $b } @tags, @ftags if @ftags;
  0         0  
9850             } elsif ($$dirInfo{DataMember}) {
9851 220         416 @tags = @{$$dirInfo{DataMember}};
  220         803  
9852 220         491 $verbose = 0; # no verbose output of extracted values when writing
9853             } elsif ($$dirInfo{MixedTags}) {
9854             # process sorted integer-ID tags only
9855 48         186 @tags = sort { $a <=> $b } grep /^\d+$/, TagTableKeys($tagTablePtr);
  580         1257  
9856             } else {
9857             # extract known tags in numerical order
9858 1955 50       7156 @tags = sort { ($a < 0 ? $a + 1e9 : $a) <=> ($b < 0 ? $b + 1e9 : $b) } TagTableKeys($tagTablePtr);
  58323 50       128219  
9859             }
9860 2223 100       7408 $self->VerboseDir('BinaryData', undef, $size, GetByteOrder()) if $verbose;
9861             # avoid creating unknown tags for tags that fail condition if Unknown is 1
9862 2223 50       9087 $$self{NO_UNKNOWN} = 1 if $unknown < 2;
9863 2223         4604 my ($index, %val);
9864 2223         3905 my $nextIndex = 0;
9865 2223         4450 my $varSize = 0;
9866 2223         5768 foreach $index (@tags) {
9867 18417         35878 my ($tagInfo, $val, $saveNextIndex, $len, $mask, $wasVar, $rational);
9868 18417 50 0     47289 if ($$tagTablePtr{$index}) {
    0          
9869 18417         54538 $tagInfo = $self->GetTagInfo($tagTablePtr, $index);
9870 18417 100       44186 unless ($tagInfo) {
9871 789 100       2627 next unless defined $tagInfo;
9872             # $entry = offset of value relative to directory start (or end if negative)
9873 51         210 my $entry = int($index) * $increment + $varSize;
9874 51 50       180 if ($entry < 0) {
9875 0         0 $entry += $size;
9876 0 0       0 next if $entry < 0;
9877             }
9878 51 100       225 next if $entry >= $size;
9879 7         23 my $more = $size - $entry;
9880 7 50       29 $more = 128 if $more > 128;
9881 7         27 my $v = substr($$dataPt, $entry+$dirStart, $more);
9882 7         29 $tagInfo = $self->GetTagInfo($tagTablePtr, $index, \$v);
9883 7 50       33 next unless $tagInfo;
9884             }
9885             next if $$tagInfo{Unknown} and
9886 17635 100 66     44120 ($$tagInfo{Unknown} > $unknown or $index < $nextIndex);
      66        
9887             } elsif ($topIndex and $$tagTablePtr{$index - $topIndex}) {
9888 0 0       0 $tagInfo = $self->GetTagInfo($tagTablePtr, $index - $topIndex) or next;
9889             } else {
9890             # don't generate unknown tags in binary tables unless Unknown > 1
9891 0 0       0 next unless $unknown > 1;
9892 0 0       0 next if $index < $nextIndex; # skip if data already used
9893 0 0       0 $tagInfo = $self->GetTagInfo($tagTablePtr, $index) or next;
9894 0         0 $$tagInfo{Unknown} = 2; # set unknown to 2 for binary unknowns
9895             }
9896             # get relative offset of this entry
9897 17634         36377 my $entry = int($index) * $increment + $varSize;
9898             # allow negative indices to represent bytes from end
9899 17634 50       38733 if ($entry < 0) {
9900 0         0 $entry += $size;
9901 0 0       0 next if $entry < 0;
9902             }
9903 17634         30147 my $more = $size - $entry;
9904 17634 100       38758 last if $more <= 0; # all done if we have reached the end of data
9905 17330         28140 my $count = 1;
9906 17330         35184 my $format = $$tagInfo{Format};
9907 17330 100       55599 if (not $format) {
    100          
    50          
    100          
9908 9973         18811 $format = $defaultFormat;
9909             } elsif ($format eq 'string') {
9910             # string with no specified count runs to end of block
9911 127         275 $count = $more;
9912             } elsif ($format eq 'pstring') {
9913 0         0 $format = 'string';
9914 0         0 $count = Get8u($dataPt, ($entry++)+$dirStart);
9915 0         0 --$more;
9916             } elsif (not $formatSize{$format}) {
9917 3353 100       22964 if ($format =~ /(.*)\[(.*)\]/) {
    50          
9918             # handle format count field
9919 3168         10457 $format = $1;
9920 3168         6861 $count = $2;
9921             # evaluate count to allow count to be based on previous values
9922             #### eval Format size (%val, $size, $self)
9923 3168         184637 $count = eval $count;
9924 3168 50       14266 $@ and warn("Format $$tagInfo{Name}: $@"), next;
9925 3168 50       7976 next if $count < 0;
9926             # allow a variable-length value of any format
9927             # (note: the next incremental index points to data immediately after
9928             # this value, regardless of the size of this value, even if it is zero)
9929 3168 50       9466 if ($format =~ s/^var_//) {
9930 0   0     0 $varSize += $count * ($formatSize{$format} || 1) - $increment;
9931 0         0 $wasVar = 1;
9932             # save variable size data if required for writing
9933 0 0       0 if ($$dirInfo{VarFormatData}) {
9934 0         0 push @{$$dirInfo{VarFormatData}}, [ $index, $varSize, $format ];
  0         0  
9935             }
9936             # don't extract value if large and we wanted it just to get
9937             # the variable-format information when writing
9938 0 0 0     0 next if $$tagInfo{LargeTag} and $$dirInfo{VarFormatData};
9939             }
9940             } elsif ($format =~ /^var_/) {
9941             # handle variable-length string formats
9942 185         515 $format = substr($format, 4);
9943 185         839 pos($$dataPt) = $entry + $dirStart;
9944 185         420 undef $count;
9945 185 50 100     1270 if ($format eq 'ustring') {
    50          
    100          
    100          
    100          
    50          
9946 0 0       0 $count = pos($$dataPt) - ($entry+$dirStart) if $$dataPt =~ /\G(..)*?\0\0/sg;
9947 0         0 $varSize -= 2; # ($count includes base size of 2 bytes)
9948             } elsif ($format eq 'pstring') {
9949 0         0 $count = Get8u($dataPt, ($entry++)+$dirStart);
9950 0         0 --$more;
9951             } elsif ($format eq 'pstr32' or $format eq 'ustr32') {
9952 170 50       514 last if $more < 4;
9953 170         534 $count = Get32u($dataPt, $entry + $dirStart);
9954 170 100       553 $count *= 2 if $format eq 'ustr32';
9955 170         299 $entry += 4;
9956 170         330 $more -= 4;
9957 170         450 $nextIndex += 4 / $increment; # (increment next index for int32u)
9958             } elsif ($format eq 'int16u') {
9959             # int16u size of binary data to follow
9960 10 50       32 last if $more < 2;
9961 10         48 $count = Get16u($dataPt, $entry + $dirStart) + 2;
9962 10         27 $varSize -= 2; # ($count includes size word)
9963 10         30 $format = 'undef';
9964             } elsif ($format eq 'ue7') {
9965 3         20 require Image::ExifTool::BPG;
9966 3         15 ($val, $count) = Image::ExifTool::BPG::Get_ue7($dataPt, $entry + $dirStart);
9967 3 50       7 last unless defined $val;
9968 3         5 --$varSize; # ($count includes base size of 1 byte)
9969             } elsif ($$dataPt =~ /\0/g) {
9970 2         5 $count = pos($$dataPt) - ($entry+$dirStart);
9971 2         5 --$varSize; # ($count includes base size of 1 byte)
9972             }
9973 185 50 33     848 $count = $more if not defined $count or $count > $more;
9974 185         378 $varSize += $count; # shift subsequent indices
9975 185 100       488 unless (defined $val) {
9976 182         553 $val = substr($$dataPt, $entry+$dirStart, $count);
9977 182 100 66     1133 $val = $self->Decode($val, 'UCS2') if $format eq 'ustring' or $format eq 'ustr32';
9978 182 100       689 $val =~ s/\0.*//s unless $format eq 'undef'; # truncate at null
9979             }
9980 185 50       630 $binVal = substr($$dataPt, $entry+$dirStart, $count) if $$self{OPTIONS}{SaveBin};
9981 185         347 $wasVar = 1;
9982             # save variable size data if required for writing
9983 185 100       569 if ($$dirInfo{VarFormatData}) {
9984 5         14 push @{$$dirInfo{VarFormatData}}, [ $index, $varSize, $format ];
  5         23  
9985             }
9986             }
9987             }
9988             # hook to allow format, etc to be set dynamically
9989 17330 100       43785 if (defined $$tagInfo{Hook}) {
9990 690         1158 my $oldVarSize = $varSize;
9991 690         1243 my $pos = $entry + $dirStart;
9992             #### eval Hook ($format, $varSize, $size, $dataPt, $pos)
9993 690         61776 eval $$tagInfo{Hook};
9994             # save variable size data if required for writing (in case changed by Hook)
9995 690 100 66     4796 if ($$dirInfo{VarFormatData}) {
    50          
9996 322 50       868 $#{$$dirInfo{VarFormatData}} -= 1 if $wasVar; # remove previous entry for this tag
  0         0  
9997 322         524 push @{$$dirInfo{VarFormatData}}, [ $index, $varSize, $format ];
  322         1514  
9998             } elsif ($varSize != $oldVarSize and $verbose > 2) {
9999 0         0 my ($tmp, $sign) = ($varSize, '+');
10000 0 0       0 $tmp < 0 and $tmp = -$tmp, $sign = '-';
10001 0         0 $self->VPrint(2, sprintf("$$self{INDENT}\[offsets adjusted by ${sign}0x%.4x after 0x%.4x $$tagInfo{Name}]\n", $tmp, $index));
10002             }
10003             }
10004 17330 50       39724 if ($unknown > 1) {
10005             # calculate next valid index for unknown tag
10006 0         0 my $ni = int $index;
10007 0 0 0     0 $ni += (($formatSize{$format} || 1) * $count) / $increment unless $wasVar;
10008 0         0 $saveNextIndex = $nextIndex;
10009 0 0       0 $nextIndex = $ni unless $nextIndex > $ni;
10010             }
10011             # allow large tags to be excluded from extraction
10012             # (provides a work-around for some tight memory situations)
10013 17330 50 33     45774 next if $$tagInfo{LargeTag} and $$self{EXCL_TAG_LOOKUP}{lc $$tagInfo{Name}};
10014             # read value now if necessary
10015 17330 100 66     43416 unless (defined $val and not $$tagInfo{SubDirectory}) {
10016 17145         54370 $val = ReadValue($dataPt, $entry+$dirStart, $format, $count, $more, \$rational);
10017 17145 50       39828 next unless defined $val;
10018 17145         34653 $mask = $$tagInfo{Mask};
10019 17145 100       39441 $val = ($val & $mask) >> $$tagInfo{BitShift} if $mask;
10020             }
10021 17330 100 66     43882 if ($verbose and not $$tagInfo{Hidden}) {
10022 198 50 33     890 if (not $$tagInfo{SubDirectory} or $$tagInfo{Format}) {
10023 198   50     667 $len = $count * ($formatSize{$format} || 1);
10024 198 50       569 $len = $more if $len > $more;
10025             } else {
10026 0         0 $len = $more;
10027             }
10028 198 50       1617 $self->VerboseInfo($index, $tagInfo,
10029             Table => $tagTablePtr,
10030             Value => $val,
10031             DataPt => $dataPt,
10032             Size => $len,
10033             Start => $entry+$dirStart,
10034             Addr => $entry+$dirStart+$base+$dataPos,
10035             Format => $format,
10036             Count => $count,
10037             Extra => $mask ? sprintf(', mask 0x%.2x',$mask) : undef,
10038             );
10039             }
10040             # parse nested BinaryData directories
10041 17330 100       40991 if ($$tagInfo{SubDirectory}) {
10042 14         43 my $subdir = $$tagInfo{SubDirectory};
10043 14         72 my $subTablePtr = GetTagTable($$subdir{TagTable});
10044             # use specified subdirectory length if given
10045 14 100 66     115 if ($$tagInfo{Format} and $formatSize{$format}) {
10046 12         38 $len = $count * $formatSize{$format};
10047 12 50       50 $len = $more if $len > $more;
10048             } else {
10049 2         5 $len = $more; # directory size is all of remaining data
10050 2 50 33     20 if ($$subTablePtr{PROCESS_PROC} and
10051             $$subTablePtr{PROCESS_PROC} eq \&ProcessBinaryData)
10052             {
10053             # the rest of the data will be printed in the subdirectory
10054 2         7 $nextIndex = $size / $increment;
10055             }
10056             }
10057 14         60 my $subdirBase = $base;
10058 14 50       65 if (defined $$subdir{Base}) {
10059             #### eval Base ($start,$base)
10060 0         0 my $start = $entry + $dirStart + $dataPos;
10061 0         0 $subdirBase = eval($$subdir{Base}) + $base;
10062             }
10063 14   50     86 my $start = $$subdir{Start} || 0;
10064 14         29 my $notDup;
10065 14 50       67 if ($start =~ /\$/) {
10066             # ignore directories with a zero offset (ie. missing Nikon ShotInfo entries)
10067 0 0       0 next unless $val;
10068             #### eval Start ($val, $dirStart)
10069 0         0 $start = eval($start);
10070 0 0 0     0 next if $start < $dirStart or $start > $dataLen;
10071 0         0 $len = $$subdir{DirLen};
10072 0 0 0     0 $len = $dataLen - $start unless $len and $len <= $dataLen - $start;
10073             } else {
10074 14         44 $start += $dirStart + $entry;
10075 14         33 $notDup = 1,
10076             }
10077 14         116 my %subdirInfo = (
10078             DataPt => $dataPt,
10079             DataPos => $dataPos,
10080             DataLen => $dataLen,
10081             DirStart => $start,
10082             DirLen => $len,
10083             Base => $subdirBase,
10084             NotDup => $notDup,
10085             );
10086 14         66 delete $$self{NO_UNKNOWN};
10087 14         167 $self->ProcessDirectory(\%subdirInfo, $subTablePtr, $$subdir{ProcessProc});
10088 14 50       100 $$self{NO_UNKNOWN} = 1 if $unknown < 2;
10089 14         94 next;
10090             }
10091 17316 100 66     44708 if ($$tagInfo{IsOffset} and $$tagInfo{IsOffset} ne '3') {
10092 38         72 my $et = $self;
10093             #### eval IsOffset ($val, $et)
10094 38 100       2666 $val += $base + $$self{BASE} if eval $$tagInfo{IsOffset};
10095             }
10096 17316         46578 $val{$index} = $val;
10097 17316         25718 my $oldBase;
10098 17316 50       37230 if ($$tagInfo{SetBase}) {
10099 0         0 $oldBase = $$self{BASE};
10100 0         0 $$self{BASE} += $base;
10101             }
10102 17316         57506 my $key = $self->FoundTag($tagInfo,$val);
10103 17316 50       44917 $$self{BASE} = $oldBase if defined $oldBase;
10104 17316 100       34407 if ($key) {
10105 15824 100       33325 $$self{TAG_EXTRA}{$key}{Rational} = $rational if defined $rational;
10106 15824 50       50807 $$self{TAG_EXTRA}{$key}{BinVal} = $binVal if defined $binVal;
10107             } else {
10108             # don't increment nextIndex if we didn't extract a tag
10109 1492 50       5572 $nextIndex = $saveNextIndex if defined $saveNextIndex;
10110             }
10111             }
10112 2223         5969 delete $$self{NO_UNKNOWN};
10113 2223         16938 return 1;
10114             }
10115              
10116             #..............................................................................
10117             # Load .ExifTool_config file from user's home directory
10118             # (use of noConfig is now deprecated, use configFile = '' instead)
10119             push @configFiles, $configFile if defined $configFile;
10120             until ($noConfig) {
10121             my $config = shift @configFiles;
10122             my $file;
10123             if (not defined $config) {
10124             $config = '.ExifTool_config';
10125             # get our home directory (HOMEDRIVE and HOMEPATH are used in Windows cmd shell)
10126             my $home = $ENV{EXIFTOOL_HOME} || $ENV{HOME} ||
10127             ($ENV{HOMEDRIVE} || '') . ($ENV{HOMEPATH} || '') || '.';
10128             # look for the config file in 1) the home directory, 2) the program dir
10129             $file = "$home/$config";
10130             } else {
10131             length $config or last; # filename of "" disables configuration
10132             $file = $config;
10133             }
10134             # also check executable directory unless path is absolute
10135             $exeDir = ($0 =~ /(.*)[\\\/]/) ? $1 : '.' unless defined $exeDir;
10136             -r $file or $config =~ /^\// or $file = "$exeDir/$config";
10137             unless (-r $file) {
10138             warn("Config file not found\n") if defined $Image::ExifTool::configFile;
10139             last;
10140             }
10141             unshift @INC, '.'; # look in current directory first
10142             eval { require $file }; # load the config file
10143             shift @INC;
10144             # print warning (minus "Compilation failed" part)
10145             $@ and $_=$@, s/Compilation failed.*//s, warn $_;
10146             last unless @configFiles;
10147             }
10148             # read user-defined lenses (may have been defined by script instead of config file)
10149             if (@Image::ExifTool::UserDefined::Lenses) {
10150             foreach (@Image::ExifTool::UserDefined::Lenses) {
10151             $Image::ExifTool::userLens{$_} = 1;
10152             }
10153             }
10154             # add user-defined file types
10155             if (%Image::ExifTool::UserDefined::FileTypes) {
10156             foreach (sort keys %Image::ExifTool::UserDefined::FileTypes) {
10157             my $fileInfo = $Image::ExifTool::UserDefined::FileTypes{$_};
10158             my $type = uc $_;
10159             ref $fileInfo eq 'HASH' or $fileTypeLookup{$type} = $fileInfo, next;
10160             my $baseType = $$fileInfo{BaseType};
10161             if ($baseType) {
10162             if ($$fileInfo{Description}) {
10163             $fileTypeLookup{$type} = [ $baseType, $$fileInfo{Description} ];
10164             } else {
10165             $fileTypeLookup{$type} = $baseType;
10166             }
10167             if (defined $$fileInfo{Writable} and not $$fileInfo{Writable}) {
10168             # first make sure we are using an actual base type and not a derived type
10169             $baseType = $fileTypeLookup{$baseType} while $baseType and not ref $fileTypeLookup{$baseType};
10170             # mark this type as not writable
10171             $noWriteFile{$baseType} or $noWriteFile{$baseType} = [ ];
10172             push @{$noWriteFile{$baseType}}, $type;
10173             }
10174             } else {
10175             $fileTypeLookup{$type} = [ $type, $$fileInfo{Description} || $type ];
10176             $moduleName{$type} = 0; # not supported
10177             if ($$fileInfo{Magic}) {
10178             $magicNumber{$type} = $$fileInfo{Magic};
10179             push @fileTypes, $type unless grep /^$type$/, @fileTypes;
10180             }
10181             }
10182             $mimeType{$type} = $$fileInfo{MIMEType} if defined $$fileInfo{MIMEType};
10183             }
10184             }
10185              
10186             #------------------------------------------------------------------------------
10187             1; # end