File Coverage

blib/lib/Image/ExifTool.pm
Criterion Covered Total %
statement 2853 3775 75.5
branch 1787 2890 61.8
condition 784 1436 54.6
subroutine 155 167 92.8
pod 22 150 14.6
total 5601 8418 66.5


line stmt bran cond sub pod time code
1             #------------------------------------------------------------------------------
2             # File: ExifTool.pm
3             #
4             # Description: Read and write meta information
5             #
6             # URL: https://exiftool.org/
7             #
8             # Revisions: Nov. 12/2003 - P. Harvey Created
9             # (See html/history.html for revision history)
10             #
11             # Legal: Copyright (c) 2003-2022, Phil Harvey (philharvey66 at gmail.com)
12             # This library is free software; you can redistribute it and/or
13             # modify it under the same terms as Perl itself.
14             #------------------------------------------------------------------------------
15              
16             package Image::ExifTool;
17              
18 105     105   256629 use strict;
  105         828  
  105         4346  
19             require 5.004; # require 5.004 for UNIVERSAL::isa (otherwise 5.002 would do)
20             require Exporter;
21 105     105   50334 use File::RandomAccess;
  105         296  
  105         6011  
22 105     105   128764 use overload;
  105         179817  
  105         2184  
23              
24 105         719660 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 105     105   9561 %static_vars);
  105         1796  
31              
32             $VERSION = '12.50';
33             $RELEASE = '';
34             @ISA = qw(Exporter);
35             %EXPORT_TAGS = (
36             # all public non-object-oriented functions:
37             Public => [qw(
38             ImageInfo GetTagName GetShortcuts GetAllTags GetWritableTags
39             GetAllGroups GetDeleteGroups GetFileType CanWrite CanCreate
40             AddUserDefinedTags
41             )],
42             # exports not part of the public API, but used by ExifTool modules:
43             DataAccess => [qw(
44             ReadValue GetByteOrder SetByteOrder ToggleByteOrder Get8u Get8s Get16u
45             Get16s Get32u Get32s Get64u GetFloat GetDouble GetFixed32s Write
46             WriteValue Tell Set8u Set8s Set16u Set32u Set64u Set64s
47             )],
48             Utils => [qw(GetTagTable TagTableKeys GetTagInfoList AddTagToTable HexDump)],
49             Vars => [qw(%allTables @tableOrder @fileTypes)],
50             );
51              
52             # set all of our EXPORT_TAGS in EXPORT_OK
53             Exporter::export_ok_tags(keys %EXPORT_TAGS);
54              
55             # test for problems that can arise if encoding.pm is used
56             { my $t = "\xff"; die "Incompatible encoding!\n" if ord($t) != 0xff; }
57              
58             # The following functions defined in Image::ExifTool::Writer.pl are declared
59             # here so their prototypes will be available. These Writer routines will be
60             # autoloaded when any of them is called.
61             sub SetNewValue($;$$%);
62             sub SetNewValuesFromFile($$;@);
63             sub GetNewValue($$;$);
64             sub GetNewValues($$;$);
65             sub CountNewValues($);
66             sub SaveNewValues($);
67             sub RestoreNewValues($);
68             sub WriteInfo($$;$$);
69             sub SetFileModifyDate($$;$$$);
70             sub SetFileName($$;$$$);
71             sub SetSystemTags($$);
72             sub GetAllTags(;$);
73             sub GetWritableTags(;$);
74             sub GetAllGroups($;$);
75             sub GetNewGroups($);
76             sub GetDeleteGroups();
77             sub AddUserDefinedTags($%);
78             # non-public routines below
79             sub InsertTagValues($$$;$$$);
80             sub IsWritable($);
81             sub IsSameFile($$$);
82             sub IsRawType($);
83             sub GetNewFileName($$);
84             sub LoadAllTables();
85             sub GetNewTagInfoList($;$);
86             sub GetNewTagInfoHash($@);
87             sub GetLangInfo($$);
88             sub Get64s($$);
89             sub Get64u($$);
90             sub GetFixed64s($$);
91             sub GetExtended($$);
92             sub Set64u(@);
93             sub Set64s(@);
94             sub DecodeBits($$;$);
95             sub EncodeBits($$;$$);
96             sub Filter($$$);
97             sub HexDump($;$%);
98             sub DumpTrailer($$);
99             sub DumpUnknownTrailer($$);
100             sub VerboseInfo($$$%);
101             sub VerboseValue($$$;$);
102             sub VPrint($$@);
103             sub Rationalize($;$);
104             sub Write($@);
105             sub WriteTrailerBuffer($$$);
106             sub AddNewTrailers($;@);
107             sub Tell($);
108             sub WriteValue($$;$$$$);
109             sub WriteDirectory($$$;$);
110             sub WriteBinaryData($$$);
111             sub CheckBinaryData($$$);
112             sub WriteTIFF($$$);
113             sub PackUTF8(@);
114             sub UnpackUTF8($);
115             sub SetPreferredByteOrder($;$);
116             sub CopyBlock($$$);
117             sub CopyFileAttrs($$$);
118             sub TimeNow(;$$);
119             sub NewGUID();
120             sub MakeTiffHeader($$$$;$$);
121              
122             # other subroutine definitions
123             sub SplitFileName($);
124             sub EncodeFileName($$;$);
125             sub Open($*$;$);
126             sub Exists($$);
127             sub IsDirectory($$);
128             sub Rename($$$);
129             sub Unlink($@);
130             sub SetFileTime($$;$$$$);
131             sub DoEscape($$);
132             sub ConvertFileSize($);
133             sub ParseArguments($;@); #(defined in attempt to avoid mod_perl problem)
134             sub ReadValue($$$;$$$);
135              
136             # list of main tag tables to load in LoadAllTables() (sub-tables are recursed
137             # automatically). Note: They will appear in this order in the documentation
138             # unless tweaked in BuildTagLookup::GetTableOrder().
139             @loadAllTables = qw(
140             PhotoMechanic Exif GeoTiff CanonRaw KyoceraRaw Lytro MinoltaRaw PanasonicRaw
141             SigmaRaw JPEG GIMP Jpeg2000 GIF BMP BMP::OS2 BMP::Extra BPG BPG::Extensions
142             ICO PICT PNG MNG FLIF DjVu DPX OpenEXR ZISRAW MRC LIF MRC::FEI12 MIFF PCX
143             PGF PSP PhotoCD Radiance Other::PFM PDF PostScript Photoshop::Header
144             Photoshop::Layers Photoshop::ImageData FujiFilm::RAF FujiFilm::IFD
145             Samsung::Trailer Sony::SRF2 Sony::SR2SubIFD Sony::PMP ITC ID3 ID3::Lyrics3
146             FLAC Ogg Vorbis APE APE::NewHeader APE::OldHeader Audible MPC MPEG::Audio
147             MPEG::Video MPEG::Xing M2TS QuickTime QuickTime::ImageFile QuickTime::Stream
148             QuickTime::Tags360Fly Matroska MOI MXF DV Flash Flash::FLV Real::Media
149             Real::Audio Real::Metafile Red RIFF AIFF ASF WTV DICOM FITS MIE JSON HTML
150             XMP::SVG Palm Palm::MOBI Palm::EXTH Torrent EXE EXE::PEVersion EXE::PEString
151             EXE::MachO EXE::PEF EXE::ELF EXE::AR EXE::CHM LNK Font VCard Text
152             VCard::VCalendar RSRC Rawzor ZIP ZIP::GZIP ZIP::RAR RTF OOXML iWork ISO
153             FLIR::AFF FLIR::FPF MacOS MacOS::MDItem FlashPix::DocTable
154             );
155              
156             # alphabetical list of current Lang modules
157             @langs = qw(cs de en en_ca en_gb es fi fr it ja ko nl pl ru sv tr zh_cn zh_tw);
158              
159             $defaultLang = 'en'; # default language
160              
161             # language names
162             %langName = (
163             cs => 'Czech (Čeština)',
164             de => 'German (Deutsch)',
165             en => 'English',
166             en_ca => 'Canadian English',
167             en_gb => 'British English',
168             es => 'Spanish (Español)',
169             fi => 'Finnish (Suomi)',
170             fr => 'French (Français)',
171             it => 'Italian (Italiano)',
172             ja => 'Japanese (日本語)',
173             ko => 'Korean (한국어)',
174             nl => 'Dutch (Nederlands)',
175             pl => 'Polish (Polski)',
176             ru => 'Russian (Русский)',
177             sv => 'Swedish (Svenska)',
178             'tr'=> 'Turkish (Türkçe)',
179             zh_cn => 'Simplified Chinese (简体中文)',
180             zh_tw => 'Traditional Chinese (繁體中文)',
181             );
182              
183             # recognized file types, in the order we test unknown files
184             # Notes: 1) There is no need to test for like types separately here
185             # 2) Put types with weak file signatures at end of list to avoid false matches
186             # 3) PLIST must be in this list for the binary PLIST format, although it may
187             # cause a file to be checked twice for XML
188             @fileTypes = qw(JPEG EXV CRW DR4 TIFF GIF MRW RAF X3F JP2 PNG MIE MIFF PS PDF
189             PSD XMP BMP BPG PPM RIFF AIFF ASF MOV MPEG Real SWF PSP FLV OGG
190             FLAC APE MPC MKV MXF DV PMP IND PGF ICC ITC FLIR FLIF FPF LFP
191             HTML VRD RTF FITS XCF DSS QTIF FPX PICT ZIP GZIP PLIST RAR BZ2
192             CZI TAR EXE EXR HDR CHM LNK WMF AVC DEX DPX RAW Font RSRC M2TS
193             MacOS PHP PCX DCX DWF DWG DXF WTV Torrent VCard LRI R3D AA PDB
194             PFM2 MRC LIF JXL MOI ISO ALIAS JSON MP3 DICOM PCD ICO TXT);
195              
196             # file types that we can write (edit)
197             my @writeTypes = qw(JPEG TIFF GIF CRW MRW ORF RAF RAW PNG MIE PSD XMP PPM EPS
198             X3F PS PDF ICC VRD DR4 JP2 JXL EXIF AI AIT IND MOV EXV FLIF
199             RIFF);
200             my %writeTypes; # lookup for writable file types (hash filled if required)
201              
202             # file extensions that we can't write for various base types
203             %noWriteFile = (
204             TIFF => [ qw(3FR DCR K25 KDC SRF) ],
205             XMP => [ qw(SVG INX) ],
206             JP2 => [ qw(J2C JPC) ],
207             MOV => [ qw(INSV) ],
208             );
209             # file extensions that we can only write for various base types
210             my %onlyWriteFile = ( RIFF => [ qw(WEBP) ] );
211              
212             # file types that we can create from scratch
213             # - must update CanCreate() documentation if this list is changed!
214             my %createTypes = map { $_ => 1 } qw(XMP ICC MIE VRD DR4 EXIF EXV);
215              
216             # file type lookup for all recognized file extensions (upper case)
217             # (if extension may be more than one type, the type is a list where
218             # the writable type should come first if it exists)
219             %fileTypeLookup = (
220             '360' => ['MOV', 'GoPro 360 video'],
221             '3FR' => ['TIFF', 'Hasselblad RAW format'],
222             '3G2' => ['MOV', '3rd Gen. Partnership Project 2 audio/video'],
223             '3GP' => ['MOV', '3rd Gen. Partnership Project audio/video'],
224             '3GP2'=> '3G2',
225             '3GPP'=> '3GP',
226             A => ['EXE', 'Static library'],
227             AA => ['AA', 'Audible Audiobook'],
228             AAE => ['PLIST','Apple edit information'],
229             AAX => ['MOV', 'Audible Enhanced Audiobook'],
230             ACR => ['DICOM','American College of Radiology ACR-NEMA'],
231             ACFM => ['Font', 'Adobe Composite Font Metrics'],
232             AFM => ['Font', 'Adobe Font Metrics'],
233             AMFM => ['Font', 'Adobe Multiple Master Font Metrics'],
234             AI => [['PDF','PS'], 'Adobe Illustrator'],
235             AIF => 'AIFF',
236             AIFC => ['AIFF', 'Audio Interchange File Format Compressed'],
237             AIFF => ['AIFF', 'Audio Interchange File Format'],
238             AIT => 'AI',
239             ALIAS=> ['ALIAS','MacOS file alias'],
240             APE => ['APE', "Monkey's Audio format"],
241             APNG => ['PNG', 'Animated Portable Network Graphics'],
242             ARW => ['TIFF', 'Sony Alpha RAW format'],
243             ARQ => ['TIFF', 'Sony Alpha Pixel-Shift RAW format'],
244             ASF => ['ASF', 'Microsoft Advanced Systems Format'],
245             AVC => ['AVC', 'Advanced Video Connection'], # (extensions are actually _AU,_AD,_IM,_ID)
246             AVI => ['RIFF', 'Audio Video Interleaved'],
247             AVIF => ['MOV', 'AV1 Image File Format'],
248             AZW => 'MOBI', # (see http://wiki.mobileread.com/wiki/AZW)
249             AZW3 => 'MOBI',
250             BMP => ['BMP', 'Windows Bitmap'],
251             BPG => ['BPG', 'Better Portable Graphics'],
252             BTF => ['BTF', 'Big Tagged Image File Format'], #(unofficial)
253             BZ2 => ['BZ2', 'BZIP2 archive'],
254             CHM => ['CHM', 'Microsoft Compiled HTML format'],
255             CIFF => ['CRW', 'Camera Image File Format'],
256             COS => ['COS', 'Capture One Settings'],
257             CR2 => ['TIFF', 'Canon RAW 2 format'],
258             CR3 => ['MOV', 'Canon RAW 3 format'],
259             CRM => ['MOV', 'Canon RAW Movie'],
260             CRW => ['CRW', 'Canon RAW format'],
261             CS1 => ['PSD', 'Sinar CaptureShop 1-Shot RAW'],
262             CSV => ['TXT', 'Comma-Separated Values'],
263             CUR => ['ICO', 'Windows Cursor'],
264             CZI => ['CZI', 'Zeiss Integrated Software RAW'],
265             DC3 => 'DICM',
266             DCM => 'DICM',
267             DCP => ['TIFF', 'DNG Camera Profile'],
268             DCR => ['TIFF', 'Kodak Digital Camera RAW'],
269             DCX => ['DCX', 'Multi-page PC Paintbrush'],
270             DEX => ['DEX', 'Dalvik Executable format'],
271             DFONT=> ['Font', 'Macintosh Data fork Font'],
272             DIB => ['BMP', 'Device Independent Bitmap'],
273             DIC => 'DICM',
274             DICM => ['DICOM','Digital Imaging and Communications in Medicine'],
275             DIR => ['DIR', 'Directory'],
276             DIVX => ['ASF', 'DivX media format'],
277             DJV => 'DJVU',
278             DJVU => ['AIFF', 'DjVu image'],
279             DLL => ['EXE', 'Windows Dynamic Link Library'],
280             DNG => ['TIFF', 'Digital Negative'],
281             DOC => ['FPX', 'Microsoft Word Document'],
282             DOCM => [['ZIP','FPX'], 'Office Open XML Document Macro-enabled'],
283             # Note: I have seen a password-protected DOCX file which was FPX-like, so I assume
284             # that any other MS Office file could be like this too. The only difference is
285             # that the ZIP and FPX formats are checked first, so if this is wrong, no biggie.
286             DOCX => [['ZIP','FPX'], 'Office Open XML Document'],
287             DOT => ['FPX', 'Microsoft Word Template'],
288             DOTM => [['ZIP','FPX'], 'Office Open XML Document Template Macro-enabled'],
289             DOTX => [['ZIP','FPX'], 'Office Open XML Document Template'],
290             DPX => ['DPX', 'Digital Picture Exchange' ],
291             DR4 => ['DR4', 'Canon VRD version 4 Recipe'],
292             DS2 => ['DSS', 'Digital Speech Standard 2'],
293             DSS => ['DSS', 'Digital Speech Standard'],
294             DV => ['DV', 'Digital Video'],
295             DVB => ['MOV', 'Digital Video Broadcasting'],
296             'DVR-MS'=>['ASF', 'Microsoft Digital Video recording'],
297             DWF => ['DWF', 'Autodesk drawing (Design Web Format)'],
298             DWG => ['DWG', 'AutoCAD Drawing'],
299             DYLIB=> ['EXE', 'Mach-O Dynamic Link Library'],
300             DXF => ['DXF', 'AutoCAD Drawing Exchange Format'],
301             EIP => ['ZIP', 'Capture One Enhanced Image Package'],
302             EPS => ['EPS', 'Encapsulated PostScript Format'],
303             EPS2 => 'EPS',
304             EPS3 => 'EPS',
305             EPSF => 'EPS',
306             EPUB => ['ZIP', 'Electronic Publication'],
307             ERF => ['TIFF', 'Epson Raw Format'],
308             EXE => ['EXE', 'Windows executable file'],
309             EXR => ['EXR', 'Open EXR'],
310             EXIF => ['EXIF', 'Exchangable Image File Metadata'],
311             EXV => ['EXV', 'Exiv2 metadata'],
312             F4A => ['MOV', 'Adobe Flash Player 9+ Audio'],
313             F4B => ['MOV', 'Adobe Flash Player 9+ audio Book'],
314             F4P => ['MOV', 'Adobe Flash Player 9+ Protected'],
315             F4V => ['MOV', 'Adobe Flash Player 9+ Video'],
316             FFF => [['TIFF','FLIR'], 'Hasselblad Flexible File Format'],
317             FIT => 'FITS',
318             FITS => ['FITS', 'Flexible Image Transport System'],
319             FLAC => ['FLAC', 'Free Lossless Audio Codec'],
320             FLA => ['FPX', 'Macromedia/Adobe Flash project'],
321             FLIF => ['FLIF', 'Free Lossless Image Format'],
322             FLIR => ['FLIR', 'FLIR File Format'], # (not an actual extension)
323             FLV => ['FLV', 'Flash Video'],
324             FPF => ['FPF', 'FLIR Public image Format'],
325             FPX => ['FPX', 'FlashPix'],
326             GIF => ['GIF', 'Compuserve Graphics Interchange Format'],
327             GPR => ['TIFF', 'General Purpose RAW'], # https://gopro.github.io/gpr/
328             GZ => 'GZIP',
329             GZIP => ['GZIP', 'GNU ZIP compressed archive'],
330             HDP => ['TIFF', 'Windows HD Photo'],
331             HDR => ['HDR', 'Radiance RGBE High Dynamic Range'],
332             HEIC => ['MOV', 'High Efficiency Image Format still image'],
333             HEIF => ['MOV', 'High Efficiency Image Format'],
334             HIF => 'HEIF',
335             HTM => 'HTML',
336             HTML => ['HTML', 'HyperText Markup Language'],
337             ICAL => 'ICS',
338             ICC => ['ICC', 'International Color Consortium'],
339             ICM => 'ICC',
340             ICO => ['ICO', 'Windows Icon'],
341             ICS => ['VCard','iCalendar Schedule'],
342             IDML => ['ZIP', 'Adobe InDesign Markup Language'],
343             IIQ => ['TIFF', 'Phase One Intelligent Image Quality RAW'],
344             IND => ['IND', 'Adobe InDesign'],
345             INDD => ['IND', 'Adobe InDesign Document'],
346             INDT => ['IND', 'Adobe InDesign Template'],
347             INSV => ['MOV', 'Insta360 Video'],
348             INSP => ['JPEG', 'Insta360 Picture'],
349             INX => ['XMP', 'Adobe InDesign Interchange'],
350             ISO => ['ISO', 'ISO 9660 disk image'],
351             ITC => ['ITC', 'iTunes Cover Flow'],
352             J2C => ['JP2', 'JPEG 2000 codestream'],
353             J2K => 'J2C',
354             JNG => ['PNG', 'JPG Network Graphics'],
355             JP2 => ['JP2', 'JPEG 2000 file'],
356             # JP4? - looks like a JPEG but the image data is different
357             JPC => 'J2C',
358             JPE => 'JPEG',
359             JPEG => ['JPEG', 'Joint Photographic Experts Group'],
360             JPF => 'JP2',
361             JPG => 'JPEG',
362             JPM => ['JP2', 'JPEG 2000 compound image'],
363             JPS => ['JPEG', 'JPEG Stereo image'],
364             JPX => ['JP2', 'JPEG 2000 with extensions'],
365             JSON => ['JSON', 'JavaScript Object Notation'],
366             JXL => ['JXL', 'JPEG XL'],
367             JXR => ['TIFF', 'JPEG XR'],
368             K25 => ['TIFF', 'Kodak DC25 RAW'],
369             KDC => ['TIFF', 'Kodak Digital Camera RAW'],
370             KEY => ['ZIP', 'Apple Keynote presentation'],
371             KTH => ['ZIP', 'Apple Keynote Theme'],
372             LA => ['RIFF', 'Lossless Audio'],
373             LFP => ['LFP', 'Lytro Light Field Picture'],
374             LFR => 'LFP', # (Light Field RAW)
375             LIF => ['LIF', 'Leica Image File'],
376             LNK => ['LNK', 'Windows shortcut'],
377             LRI => ['LRI', 'Light RAW'],
378             LRV => ['MOV', 'Low-Resolution Video'],
379             M2T => 'M2TS',
380             M2TS => ['M2TS', 'MPEG-2 Transport Stream'],
381             M2V => ['MPEG', 'MPEG-2 Video'],
382             M4A => ['MOV', 'MPEG-4 Audio'],
383             M4B => ['MOV', 'MPEG-4 audio Book'],
384             M4P => ['MOV', 'MPEG-4 Protected'],
385             M4V => ['MOV', 'MPEG-4 Video'],
386             MACOS=> ['MacOS','MacOS ._ sidecar file'],
387             MAX => ['FPX', '3D Studio MAX'],
388             MEF => ['TIFF', 'Mamiya (RAW) Electronic Format'],
389             MIE => ['MIE', 'Meta Information Encapsulation format'],
390             MIF => 'MIFF',
391             MIFF => ['MIFF', 'Magick Image File Format'],
392             MKA => ['MKV', 'Matroska Audio'],
393             MKS => ['MKV', 'Matroska Subtitle'],
394             MKV => ['MKV', 'Matroska Video'],
395             MNG => ['PNG', 'Multiple-image Network Graphics'],
396             MOBI => ['PDB', 'Mobipocket electronic book'],
397             MODD => ['PLIST','Sony Picture Motion metadata'],
398             MOI => ['MOI', 'MOD Information file'],
399             MOS => ['TIFF', 'Creo Leaf Mosaic'],
400             MOV => ['MOV', 'Apple QuickTime movie'],
401             MP3 => ['MP3', 'MPEG-1 Layer 3 audio'],
402             MP4 => ['MOV', 'MPEG-4 video'],
403             MPC => ['MPC', 'Musepack Audio'],
404             MPEG => ['MPEG', 'MPEG-1 or MPEG-2 audio/video'],
405             MPG => 'MPEG',
406             MPO => ['JPEG', 'Extended Multi-Picture format'],
407             MQV => ['MOV', 'Sony Mobile Quicktime Video'],
408             MRC => ['MRC', 'Medical Research Council image'],
409             MRW => ['MRW', 'Minolta RAW format'],
410             MTS => 'M2TS',
411             MXF => ['MXF', 'Material Exchange Format'],
412             # NDPI => ['TIFF', 'Hamamatsu NanoZoomer Digital Pathology Image'],
413             NEF => ['TIFF', 'Nikon (RAW) Electronic Format'],
414             NEWER => 'COS',
415             NKSC => ['XMP', 'Nikon Sidecar'],
416             NMBTEMPLATE => ['ZIP','Apple Numbers Template'],
417             NRW => ['TIFF', 'Nikon RAW (2)'],
418             NUMBERS => ['ZIP','Apple Numbers spreadsheet'],
419             O => ['EXE', 'Relocatable Object'],
420             ODB => ['ZIP', 'Open Document Database'],
421             ODC => ['ZIP', 'Open Document Chart'],
422             ODF => ['ZIP', 'Open Document Formula'],
423             ODG => ['ZIP', 'Open Document Graphics'],
424             ODI => ['ZIP', 'Open Document Image'],
425             ODP => ['ZIP', 'Open Document Presentation'],
426             ODS => ['ZIP', 'Open Document Spreadsheet'],
427             ODT => ['ZIP', 'Open Document Text file'],
428             OFR => ['RIFF', 'OptimFROG audio'],
429             OGG => ['OGG', 'Ogg Vorbis audio file'],
430             OGV => ['OGG', 'Ogg Video file'],
431             ONP => ['JSON', 'ON1 Presets'],
432             OPUS => ['OGG', 'Ogg Opus audio file'],
433             ORF => ['ORF', 'Olympus RAW format'],
434             ORI => 'ORF',
435             OTF => ['Font', 'Open Type Font'],
436             PAC => ['RIFF', 'Lossless Predictive Audio Compression'],
437             PAGES => ['ZIP', 'Apple Pages document'],
438             PBM => ['PPM', 'Portable BitMap'],
439             PCD => ['PCD', 'Kodak Photo CD Image Pac'],
440             PCT => 'PICT',
441             PCX => ['PCX', 'PC Paintbrush'],
442             PDB => ['PDB', 'Palm Database'],
443             PDF => ['PDF', 'Adobe Portable Document Format'],
444             PEF => ['TIFF', 'Pentax (RAW) Electronic Format'],
445             PFA => ['Font', 'PostScript Font ASCII'],
446             PFB => ['Font', 'PostScript Font Binary'],
447             PFM => [['Font','PFM2'], 'Printer Font Metrics'], # (description is overridden for Portable FloatMap images)
448             PGF => ['PGF', 'Progressive Graphics File'],
449             PGM => ['PPM', 'Portable Gray Map'],
450             PHP => ['PHP', 'PHP Hypertext Preprocessor'],
451             PHP3 => 'PHP',
452             PHP4 => 'PHP',
453             PHP5 => 'PHP',
454             PHPS => 'PHP',
455             PHTML=> 'PHP',
456             PICT => ['PICT', 'Apple PICTure'],
457             PLIST=> ['PLIST','Apple Property List'],
458             PMP => ['PMP', 'Sony DSC-F1 Cyber-Shot PMP'], # should stand for Proprietery Metadata Package ;)
459             PNG => ['PNG', 'Portable Network Graphics'],
460             POT => ['FPX', 'Microsoft PowerPoint Template'],
461             POTM => [['ZIP','FPX'], 'Office Open XML Presentation Template Macro-enabled'],
462             POTX => [['ZIP','FPX'], 'Office Open XML Presentation Template'],
463             PPAM => [['ZIP','FPX'], 'Office Open XML Presentation Addin Macro-enabled'],
464             PPAX => [['ZIP','FPX'], 'Office Open XML Presentation Addin'],
465             PPM => ['PPM', 'Portable Pixel Map'],
466             PPS => ['FPX', 'Microsoft PowerPoint Slideshow'],
467             PPSM => [['ZIP','FPX'], 'Office Open XML Presentation Slideshow Macro-enabled'],
468             PPSX => [['ZIP','FPX'], 'Office Open XML Presentation Slideshow'],
469             PPT => ['FPX', 'Microsoft PowerPoint Presentation'],
470             PPTM => [['ZIP','FPX'], 'Office Open XML Presentation Macro-enabled'],
471             PPTX => [['ZIP','FPX'], 'Office Open XML Presentation'],
472             PRC => ['PDB', 'Palm Database'],
473             PS => ['PS', 'PostScript'],
474             PS2 => 'PS',
475             PS3 => 'PS',
476             PSB => ['PSD', 'Photoshop Large Document'],
477             PSD => ['PSD', 'Photoshop Document'],
478             PSDT => ['PSD', 'Photoshop Document Template'],
479             PSP => ['PSP', 'Paint Shop Pro'],
480             PSPFRAME => 'PSP',
481             PSPIMAGE => 'PSP',
482             PSPSHAPE => 'PSP',
483             PSPTUBE => 'PSP',
484             QIF => 'QTIF',
485             QT => 'MOV',
486             QTI => 'QTIF',
487             QTIF => ['QTIF', 'QuickTime Image File'],
488             R3D => ['R3D', 'Redcode RAW Video'],
489             RA => ['Real', 'Real Audio'],
490             RAF => ['RAF', 'FujiFilm RAW Format'],
491             RAM => ['Real', 'Real Audio Metafile'],
492             RAR => ['RAR', 'RAR Archive'],
493             RAW => [['RAW','TIFF'], 'Kyocera Contax N Digital RAW or Panasonic RAW'],
494             RIF => 'RIFF',
495             RIFF => ['RIFF', 'Resource Interchange File Format'],
496             RM => ['Real', 'Real Media'],
497             RMVB => ['Real', 'Real Media Variable Bitrate'],
498             RPM => ['Real', 'Real Media Plug-in Metafile'],
499             RSRC => ['RSRC', 'Mac OS Resource'],
500             RTF => ['RTF', 'Rich Text Format'],
501             RV => ['Real', 'Real Video'],
502             RW2 => ['TIFF', 'Panasonic RAW 2'],
503             RWL => ['TIFF', 'Leica RAW'],
504             RWZ => ['RWZ', 'Rawzor compressed image'],
505             SEQ => ['FLIR', 'FLIR image Sequence'],
506             SKETCH => ['ZIP', 'Sketch design file'],
507             SO => ['EXE', 'Shared Object file'],
508             SR2 => ['TIFF', 'Sony RAW Format 2'],
509             SRF => ['TIFF', 'Sony RAW Format'],
510             SRW => ['TIFF', 'Samsung RAW format'],
511             SVG => ['XMP', 'Scalable Vector Graphics'],
512             SWF => ['SWF', 'Shockwave Flash'],
513             TAR => ['TAR', 'TAR archive'],
514             THM => ['JPEG', 'Thumbnail'],
515             THMX => [['ZIP','FPX'], 'Office Open XML Theme'],
516             TIF => 'TIFF',
517             TIFF => ['TIFF', 'Tagged Image File Format'],
518             TORRENT => ['Torrent', 'BitTorrent description file'],
519             TS => 'M2TS',
520             TTC => ['Font', 'True Type Font Collection'],
521             TTF => ['Font', 'True Type Font'],
522             TUB => 'PSP',
523             TXT => ['TXT', 'Text file'],
524             VCARD=> ['VCard','Virtual Card'],
525             VCF => 'VCARD',
526             VOB => ['MPEG', 'Video Object'],
527             VRD => ['VRD', 'Canon VRD Recipe Data'],
528             VSD => ['FPX', 'Microsoft Visio Drawing'],
529             WAV => ['RIFF', 'WAVeform (Windows digital audio)'],
530             WDP => ['TIFF', 'Windows Media Photo'],
531             WEBM => ['MKV', 'Google Web Movie'],
532             WEBP => ['RIFF', 'Google Web Picture'],
533             WMA => ['ASF', 'Windows Media Audio'],
534             WMF => ['WMF', 'Windows Metafile Format'],
535             WMV => ['ASF', 'Windows Media Video'],
536             WV => ['RIFF', 'WavePack lossless audio'],
537             X3F => ['X3F', 'Sigma RAW format'],
538             XCF => ['XCF', 'GIMP native image format'],
539             XHTML=> ['HTML', 'Extensible HyperText Markup Language'],
540             XLA => ['FPX', 'Microsoft Excel Add-in'],
541             XLAM => [['ZIP','FPX'], 'Office Open XML Spreadsheet Add-in Macro-enabled'],
542             XLS => ['FPX', 'Microsoft Excel Spreadsheet'],
543             XLSB => [['ZIP','FPX'], 'Office Open XML Spreadsheet Binary'],
544             XLSM => [['ZIP','FPX'], 'Office Open XML Spreadsheet Macro-enabled'],
545             XLSX => [['ZIP','FPX'], 'Office Open XML Spreadsheet'],
546             XLT => ['FPX', 'Microsoft Excel Template'],
547             XLTM => [['ZIP','FPX'], 'Office Open XML Spreadsheet Template Macro-enabled'],
548             XLTX => [['ZIP','FPX'], 'Office Open XML Spreadsheet Template'],
549             XMP => ['XMP', 'Extensible Metadata Platform'],
550             WOFF => ['Font', 'Web Open Font Format'],
551             WOFF2=> ['Font', 'Web Open Font Format2'],
552             WTV => ['WTV', 'Windows recorded TV show'],
553             ZIP => ['ZIP', 'ZIP archive'],
554             );
555              
556             # typical extension for each file type (if different than FileType)
557             # - case is not significant
558             my %fileTypeExt = (
559             'Canon 1D RAW' => 'tif',
560             DICOM => 'dcm',
561             FLIR => 'fff',
562             GZIP => 'gz',
563             JPEG => 'jpg',
564             M2TS => 'mts',
565             MPEG => 'mpg',
566             TIFF => 'tif',
567             VCard => 'vcf',
568             );
569              
570             # descriptions for file types not found in above file extension lookup
571             my %fileDescription = (
572             DICOM => 'Digital Imaging and Communications in Medicine',
573             XML => 'Extensible Markup Language',
574             'Win32 EXE' => 'Windows 32-bit Executable',
575             'Win32 DLL' => 'Windows 32-bit Dynamic Link Library',
576             'Win64 EXE' => 'Windows 64-bit Executable',
577             'Win64 DLL' => 'Windows 64-bit Dynamic Link Library',
578             );
579              
580             # MIME types for applicable file types above
581             # (missing entries default to 'application/unknown', but note that other MIME
582             # types may be specified by some modules, eg. QuickTime.pm and RIFF.pm)
583             %mimeType = (
584             '3FR' => 'image/x-hasselblad-3fr',
585             AA => 'audio/audible',
586             AAE => 'application/vnd.apple.photos',
587             AI => 'application/vnd.adobe.illustrator',
588             AIFF => 'audio/x-aiff',
589             ALIAS=> 'application/x-macos',
590             APE => 'audio/x-monkeys-audio',
591             APNG => 'image/apng',
592             ASF => 'video/x-ms-asf',
593             ARW => 'image/x-sony-arw',
594             BMP => 'image/bmp',
595             BPG => 'image/bpg',
596             BTF => 'image/x-tiff-big', #(NC) (ref http://www.asmail.be/msg0055371937.html)
597             BZ2 => 'application/bzip2',
598             'Canon 1D RAW' => 'image/x-raw', # (uses .TIF file extension)
599             CHM => 'application/x-chm',
600             COS => 'application/octet-stream', #PH (NC)
601             CR2 => 'image/x-canon-cr2',
602             CR3 => 'image/x-canon-cr3',
603             CRM => 'video/x-canon-crm',
604             CRW => 'image/x-canon-crw',
605             CSV => 'text/csv',
606             CUR => 'image/x-cursor', #PH (NC)
607             CZI => 'image/x-zeiss-czi', #PH (NC)
608             DCP => 'application/octet-stream', #PH (NC)
609             DCR => 'image/x-kodak-dcr',
610             DCX => 'image/dcx',
611             DEX => 'application/octet-stream',
612             DFONT=> 'application/x-dfont',
613             DICOM=> 'application/dicom',
614             DIVX => 'video/divx',
615             DJVU => 'image/vnd.djvu',
616             DNG => 'image/x-adobe-dng',
617             DOC => 'application/msword',
618             DOCM => 'application/vnd.ms-word.document.macroEnabled.12',
619             DOCX => 'application/vnd.openxmlformats-officedocument.wordprocessingml.document',
620             DOT => 'application/msword',
621             DOTM => 'application/vnd.ms-word.template.macroEnabledTemplate',
622             DOTX => 'application/vnd.openxmlformats-officedocument.wordprocessingml.template',
623             DPX => 'image/x-dpx',
624             DR4 => 'application/octet-stream', #PH (NC)
625             DS2 => 'audio/x-ds2',
626             DSS => 'audio/x-dss',
627             DV => 'video/x-dv',
628             'DVR-MS' => 'video/x-ms-dvr',
629             DWF => 'model/vnd.dwf',
630             DWG => 'image/vnd.dwg',
631             DXF => 'application/dxf',
632             EIP => 'application/x-captureone', #(NC)
633             EPS => 'application/postscript',
634             ERF => 'image/x-epson-erf',
635             EXE => 'application/octet-stream',
636             EXR => 'image/x-exr',
637             EXV => 'image/x-exv',
638             FFF => 'image/x-hasselblad-fff',
639             FITS => 'image/fits',
640             FLA => 'application/vnd.adobe.fla',
641             FLAC => 'audio/flac',
642             FLIF => 'image/flif',
643             FLIR => 'image/x-flir-fff', #PH (NC)
644             FLV => 'video/x-flv',
645             Font => 'application/x-font-type1', # covers PFA, PFB and PFM (not sure about PFM)
646             FPF => 'image/x-flir-fpf', #PH (NC)
647             FPX => 'image/vnd.fpx',
648             GIF => 'image/gif',
649             GPR => 'image/x-gopro-gpr',
650             GZIP => 'application/x-gzip',
651             HDP => 'image/vnd.ms-photo',
652             HDR => 'image/vnd.radiance',
653             HTML => 'text/html',
654             ICC => 'application/vnd.iccprofile',
655             ICO => 'image/x-icon', #PH (NC)
656             ICS => 'text/calendar',
657             IDML => 'application/vnd.adobe.indesign-idml-package',
658             IIQ => 'image/x-raw',
659             IND => 'application/x-indesign',
660             INX => 'application/x-indesign-interchange', #PH (NC)
661             ISO => 'application/x-iso9660-image',
662             ITC => 'application/itunes',
663             J2C => 'image/x-j2c', #PH (NC)
664             JNG => 'image/jng',
665             JP2 => 'image/jp2',
666             JPEG => 'image/jpeg',
667             JPM => 'image/jpm',
668             JPS => 'image/x-jps',
669             JPX => 'image/jpx',
670             JSON => 'application/json',
671             JXL => 'image/jxl', #PH (NC)
672             JXR => 'image/jxr',
673             K25 => 'image/x-kodak-k25',
674             KDC => 'image/x-kodak-kdc',
675             KEY => 'application/x-iwork-keynote-sffkey',
676             LFP => 'image/x-lytro-lfp', #PH (NC)
677             LIF => 'image/x-lif',
678             LNK => 'application/octet-stream',
679             LRI => 'image/x-light-lri',
680             M2T => 'video/mpeg',
681             M2TS => 'video/m2ts',
682             MAX => 'application/x-3ds',
683             MEF => 'image/x-mamiya-mef',
684             MIE => 'application/x-mie',
685             MIFF => 'application/x-magick-image',
686             MKA => 'audio/x-matroska',
687             MKS => 'application/x-matroska',
688             MKV => 'video/x-matroska',
689             MNG => 'video/mng',
690             MOBI => 'application/x-mobipocket-ebook',
691             MOI => 'application/octet-stream', #PH (NC)
692             MOS => 'image/x-raw',
693             MOV => 'video/quicktime',
694             MP3 => 'audio/mpeg',
695             MP4 => 'video/mp4',
696             MPC => 'audio/x-musepack',
697             MPEG => 'video/mpeg',
698             MRC => 'image/x-mrc',
699             MRW => 'image/x-minolta-mrw',
700             MXF => 'application/mxf',
701             NEF => 'image/x-nikon-nef',
702             NKSC => 'application/x-nikon-nxstudio',
703             NRW => 'image/x-nikon-nrw',
704             NUMBERS => 'application/x-iwork-numbers-sffnumbers',
705             ODB => 'application/vnd.oasis.opendocument.database',
706             ODC => 'application/vnd.oasis.opendocument.chart',
707             ODF => 'application/vnd.oasis.opendocument.formula',
708             ODG => 'application/vnd.oasis.opendocument.graphics',
709             ODI => 'application/vnd.oasis.opendocument.image',
710             ODP => 'application/vnd.oasis.opendocument.presentation',
711             ODS => 'application/vnd.oasis.opendocument.spreadsheet',
712             ODT => 'application/vnd.oasis.opendocument.text',
713             OGG => 'audio/ogg',
714             OGV => 'video/ogg',
715             ONP => 'application/on1',
716             ORF => 'image/x-olympus-orf',
717             OTF => 'application/x-font-otf',
718             PAGES=> 'application/x-iwork-pages-sffpages',
719             PBM => 'image/x-portable-bitmap',
720             PCD => 'image/x-photo-cd',
721             PCX => 'image/pcx',
722             PDB => 'application/vnd.palm',
723             PDF => 'application/pdf',
724             PEF => 'image/x-pentax-pef',
725             PFA => 'application/x-font-type1', # (needed if handled by PostScript module)
726             PGF => 'image/pgf',
727             PGM => 'image/x-portable-graymap',
728             PHP => 'application/x-httpd-php',
729             PICT => 'image/pict',
730             PLIST=> 'application/xml', # (binary PLIST format is 'application/x-plist', recognized at run time)
731             PMP => 'image/x-sony-pmp', #PH (NC)
732             PNG => 'image/png',
733             POT => 'application/vnd.ms-powerpoint',
734             POTM => 'application/vnd.ms-powerpoint.template.macroEnabled.12',
735             POTX => 'application/vnd.openxmlformats-officedocument.presentationml.template',
736             PPAM => 'application/vnd.ms-powerpoint.addin.macroEnabled.12',
737             PPAX => 'application/vnd.openxmlformats-officedocument.presentationml.addin', # (NC, PH invented)
738             PPM => 'image/x-portable-pixmap',
739             PPS => 'application/vnd.ms-powerpoint',
740             PPSM => 'application/vnd.ms-powerpoint.slideshow.macroEnabled.12',
741             PPSX => 'application/vnd.openxmlformats-officedocument.presentationml.slideshow',
742             PPT => 'application/vnd.ms-powerpoint',
743             PPTM => 'application/vnd.ms-powerpoint.presentation.macroEnabled.12',
744             PPTX => 'application/vnd.openxmlformats-officedocument.presentationml.presentation',
745             PS => 'application/postscript',
746             PSD => 'application/vnd.adobe.photoshop',
747             PSP => 'image/x-paintshoppro', #(NC)
748             QTIF => 'image/x-quicktime',
749             R3D => 'video/x-red-r3d', #PH (invented)
750             RA => 'audio/x-pn-realaudio',
751             RAF => 'image/x-fujifilm-raf',
752             RAM => 'audio/x-pn-realaudio',
753             RAR => 'application/x-rar-compressed',
754             RAW => 'image/x-raw',
755             RM => 'application/vnd.rn-realmedia',
756             RMVB => 'application/vnd.rn-realmedia-vbr',
757             RPM => 'audio/x-pn-realaudio-plugin',
758             RSRC => 'application/ResEdit',
759             RTF => 'text/rtf',
760             RV => 'video/vnd.rn-realvideo',
761             RW2 => 'image/x-panasonic-rw2',
762             RWL => 'image/x-leica-rwl',
763             RWZ => 'image/x-rawzor', #(duplicated in Rawzor.pm)
764             SEQ => 'image/x-flir-seq', #PH (NC)
765             SKETCH => 'application/sketch',
766             SR2 => 'image/x-sony-sr2',
767             SRF => 'image/x-sony-srf',
768             SRW => 'image/x-samsung-srw',
769             SVG => 'image/svg+xml',
770             SWF => 'application/x-shockwave-flash',
771             TAR => 'application/x-tar',
772             THMX => 'application/vnd.ms-officetheme',
773             TIFF => 'image/tiff',
774             Torrent => 'application/x-bittorrent',
775             TTC => 'application/x-font-ttf',
776             TTF => 'application/x-font-ttf',
777             TXT => 'text/plain',
778             VCard=> 'text/vcard',
779             VRD => 'application/octet-stream', #PH (NC)
780             VSD => 'application/x-visio',
781             WDP => 'image/vnd.ms-photo',
782             WEBM => 'video/webm',
783             WMA => 'audio/x-ms-wma',
784             WMF => 'application/x-wmf',
785             WMV => 'video/x-ms-wmv',
786             WTV => 'video/x-ms-wtv',
787             X3F => 'image/x-sigma-x3f',
788             XCF => 'image/x-xcf',
789             XLA => 'application/vnd.ms-excel',
790             XLAM => 'application/vnd.ms-excel.addin.macroEnabled.12',
791             XLS => 'application/vnd.ms-excel',
792             XLSB => 'application/vnd.ms-excel.sheet.binary.macroEnabled.12',
793             XLSM => 'application/vnd.ms-excel.sheet.macroEnabled.12',
794             XLSX => 'application/vnd.openxmlformats-officedocument.spreadsheetml.sheet',
795             XLT => 'application/vnd.ms-excel',
796             XLTM => 'application/vnd.ms-excel.template.macroEnabled.12',
797             XLTX => 'application/vnd.openxmlformats-officedocument.spreadsheetml.template',
798             XML => 'application/xml',
799             XMP => 'application/rdf+xml',
800             ZIP => 'application/zip',
801             );
802              
803             # module names for processing routines of each file type
804             # - undefined entries default to same module name as file type
805             # - module name '' defaults to Image::ExifTool
806             # - module name '0' indicates a recognized but unsupported file
807             my %moduleName = (
808             AA => 'Audible',
809             ALIAS=> 0,
810             AVC => 0,
811             BTF => 'BigTIFF',
812             BZ2 => 0,
813             CRW => 'CanonRaw',
814             CHM => 'EXE',
815             COS => 'CaptureOne',
816             CZI => 'ZISRAW',
817             DEX => 0,
818             DOCX => 'OOXML',
819             DCX => 0,
820             DIR => 0,
821             DR4 => 'CanonVRD',
822             DSS => 'Olympus',
823             DWF => 0,
824             DWG => 0,
825             DXF => 0,
826             EPS => 'PostScript',
827             EXIF => '',
828             EXR => 'OpenEXR',
829             EXV => '',
830             ICC => 'ICC_Profile',
831             IND => 'InDesign',
832             FLV => 'Flash',
833             FPF => 'FLIR',
834             FPX => 'FlashPix',
835             GZIP => 'ZIP',
836             HDR => 'Radiance',
837             JP2 => 'Jpeg2000',
838             JPEG => '',
839             JXL => 'Jpeg2000',
840             LFP => 'Lytro',
841             LRI => 0,
842             MOV => 'QuickTime',
843             MKV => 'Matroska',
844             MP3 => 'ID3',
845             MRW => 'MinoltaRaw',
846             OGG => 'Ogg',
847             ORF => 'Olympus',
848             PDB => 'Palm',
849             PCD => 'PhotoCD',
850             PFM2 => 'Other',
851             PHP => 0,
852             PMP => 'Sony',
853             PS => 'PostScript',
854             PSD => 'Photoshop',
855             QTIF => 'QuickTime',
856             R3D => 'Red',
857             RAF => 'FujiFilm',
858             RAR => 'ZIP',
859             RAW => 'KyoceraRaw',
860             RWZ => 'Rawzor',
861             SWF => 'Flash',
862             TAR => 0,
863             TIFF => '',
864             TXT => 'Text',
865             VRD => 'CanonVRD',
866             WMF => 0,
867             X3F => 'SigmaRaw',
868             XCF => 'GIMP',
869             );
870              
871             $testLen = 1024; # number of bytes to read when testing for magic number
872              
873             # quick "magic number" file test used to avoid loading module unnecessarily:
874             # - regular expression evaluated on first $testLen bytes of file
875             # - must match beginning at first byte in file
876             # - this test must not be more stringent than module logic
877             %magicNumber = (
878             AA => '.{4}\x57\x90\x75\x36',
879             AIFF => '(FORM....AIF[FC]|AT&TFORM)',
880             ALIAS=> "book\0\0\0\0mark\0\0\0\0",
881             APE => '(MAC |APETAGEX|ID3)',
882             ASF => '\x30\x26\xb2\x75\x8e\x66\xcf\x11\xa6\xd9\x00\xaa\x00\x62\xce\x6c',
883             AVC => '\+A\+V\+C\+',
884             Torrent => 'd\d+:\w+',
885             BMP => 'BM',
886             BPG => "BPG\xfb",
887             BTF => '(II\x2b\0|MM\0\x2b)',
888             BZ2 => 'BZh[1-9]\x31\x41\x59\x26\x53\x59',
889             CHM => 'ITSF.{20}\x10\xfd\x01\x7c\xaa\x7b\xd0\x11\x9e\x0c\0\xa0\xc9\x22\xe6\xec',
890             CRW => '(II|MM).{4}HEAP(CCDR|JPGM)',
891             CZI => 'ZISRAWFILE\0{6}',
892             DCX => '\xb1\x68\xde\x3a',
893             DEX => "dex\n035\0",
894             DICOM=> '(.{128}DICM|\0[\x02\x04\x06\x08]\0[\0-\x20]|[\x02\x04\x06\x08]\0[\0-\x20]\0)',
895             DOCX => 'PK\x03\x04',
896             DPX => '(SDPX|XPDS)',
897             DR4 => 'IIII\x04\0\x04\0',
898             DSS => '(\x02dss|\x03ds2)',
899             DV => '\x1f\x07\0[\x3f\xbf]', # (not tested if extension recognized)
900             DWF => '\(DWF V\d',
901             DWG => 'AC10\d{2}\0',
902             DXF => '\s*0\s+\0?\s*SECTION\s+2\s+HEADER',
903             EPS => '(%!PS|%!Ad|\xc5\xd0\xd3\xc6)',
904             EXE => '(MZ|\xca\xfe\xba\xbe|\xfe\xed\xfa[\xce\xcf]|[\xce\xcf]\xfa\xed\xfe|Joy!peff|\x7fELF|#!\s*/\S*bin/|!\x0a)',
905             EXIF => '(II\x2a\0|MM\0\x2a)',
906             EXR => '\x76\x2f\x31\x01',
907             EXV => '\xff\x01Exiv2',
908             FITS => 'SIMPLE = {20}T',
909             FLAC => '(fLaC|ID3)',
910             FLIF => 'FLIF[0-\x6f][0-2]',
911             FLIR => '[AF]FF\0',
912             FLV => 'FLV\x01',
913             Font => '((\0\x01\0\0|OTTO|true|typ1)[\0\x01]|ttcf\0[\x01\x02]\0\0|\0[\x01\x02]|' .
914             '(.{6})?%!(PS-(AdobeFont-|Bitstream )|FontType1-)|Start(Comp|Master)?FontMetrics|wOF[F2])',
915             FPF => 'FPF Public Image Format\0',
916             FPX => '\xd0\xcf\x11\xe0\xa1\xb1\x1a\xe1',
917             GIF => 'GIF8[79]a',
918             GZIP => '\x1f\x8b\x08',
919             HDR => '#\?(RADIANCE|RGBE)\x0a',
920             HTML => '(\xef\xbb\xbf)?\s*(?i)<(!DOCTYPE\s+HTML|HTML|\?xml)', # (case insensitive)
921             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}',
922             ICO => '\0\0[\x01\x02]\0[^0]\0', # (reasonably assume that the file contains less than 256 images)
923             IND => '\x06\x06\xed\xf5\xd8\x1d\x46\xe5\xbd\x31\xef\xe7\xfe\x74\xb7\x1d',
924             # ISO => signature is at byte 32768
925             ITC => '.{4}itch',
926             JP2 => '(\0\0\0\x0cjP( |\x1a\x1a)\x0d\x0a\x87\x0a|\xff\x4f\xff\x51\0)',
927             JPEG => '\xff\xd8\xff',
928             JSON => '(\xef\xbb\xbf)?\s*(\[\s*)?\{\s*"[^"]*"\s*:',
929             JXL => '\xff\x0a|\0\0\0\x0cJXL \x0d\x0a......ftypjxl ',
930             LFP => '\x89LFP\x0d\x0a\x1a\x0a',
931             LIF => '\x70\0{3}.{4}\x2a.{4}<\0',
932             LNK => '.{4}\x01\x14\x02\0{5}\xc0\0{6}\x46',
933             LRI => 'LELR \0',
934             M2TS => '(....)?\x47',
935             MacOS=> '\0\x05\x16\x07\0.\0\0Mac OS X ',
936             MIE => '~[\x10\x18]\x04.0MIE',
937             MIFF => 'id=ImageMagick',
938             MKV => '\x1a\x45\xdf\xa3',
939             MOV => '.{4}(free|skip|wide|ftyp|pnot|PICT|pict|moov|mdat|junk|uuid)', # (duplicated in WriteQuickTime.pl !!)
940             # MP3 => difficult to rule out
941             MPC => '(MP\+|ID3)',
942             MOI => 'V6',
943             MPEG => '\0\0\x01[\xb0-\xbf]',
944             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',
945             MRW => '\0MR[MI]',
946             MXF => '\x06\x0e\x2b\x34\x02\x05\x01\x01\x0d\x01\x02', # (not tested if extension recognized)
947             OGG => '(OggS|ID3)',
948             ORF => '(II|MM)',
949             # PCD => signature is at byte 2048
950             PCX => '\x0a[\0-\x05]\x01[\x01\x02\x04\x08].{64}[\0-\x02]',
951             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)',
952             PDF => '\s*%PDF-\d+\.\d+',
953             PFM => 'P[Ff]\x0a\d+ \d+\x0a[-+0-9.]+\x0a',
954             PGF => 'PGF',
955             PHP => '<\?php\s',
956             PICT => '(.{10}|.{522})(\x11\x01|\x00\x11)',
957             PLIST=> '(bplist0|\s*<|\xfe\xff\x00)',
958             PMP => '.{8}\0{3}\x7c.{112}\xff\xd8\xff\xdb',
959             PNG => '(\x89P|\x8aM|\x8bJ)NG\r\n\x1a\n',
960             PPM => 'P[1-6]\s+',
961             PS => '(%!PS|%!Ad|\xc5\xd0\xd3\xc6)',
962             PSD => '8BPS\0[\x01\x02]',
963             PSP => 'Paint Shop Pro Image File\x0a\x1a\0{5}',
964             QTIF => '.{4}(idsc|idat|iicc)',
965             R3D => '\0\0..RED(1|2)',
966             RAF => 'FUJIFILM',
967             RAR => 'Rar!\x1a\x07\0',
968             RAW => '(.{25}ARECOYK|II|MM)',
969             Real => '(\.RMF|\.ra\xfd|pnm://|rtsp://|http://)',
970             RIFF => '(RIFF|LA0[234]|OFR |LPAC|wvpk|RF64)', # RIFF plus other variants
971             RSRC => '(....)?\0\0\x01\0',
972             RTF => '[\n\r]*\\{[\n\r]*\\\\rtf',
973             RWZ => 'rawzor',
974             SWF => '[FC]WS[^\0]',
975             TAR => '.{257}ustar( )?\0', # (this doesn't catch old-style tar files)
976             TXT => '(\xff\xfe|(\0\0)?\xfe\xff|(\xef\xbb\xbf)?[\x07-\x0d\x20-\x7e\x80-\xfe]*$)',
977             TIFF => '(II|MM)', # don't test magic number (some raw formats are different)
978             VCard=> '(?i)BEGIN:(VCARD|VCALENDAR)\r\n',
979             VRD => 'CANON OPTIONAL DATA\0',
980             WMF => '(\xd7\xcd\xc6\x9a\0\0|\x01\0\x09\0\0\x03)',
981             WTV => '\xb7\xd8\x00\x20\x37\x49\xda\x11\xa6\x4e\x00\x07\xe9\x5e\xad\x8d',
982             X3F => 'FOVb',
983             XCF => 'gimp xcf ',
984             XMP => '\0{0,3}(\xfe\xff|\xff\xfe|\xef\xbb\xbf)?\0{0,3}\s*<',
985             ZIP => 'PK\x03\x04',
986             );
987              
988             # file types with weak magic number recognition
989             my %weakMagic = ( MP3 => 1 );
990              
991             # file types that are determined by the process proc when FastScan == 3
992             # (when done, the process proc must exit after SetFileType if FastScan is 3)
993             my %processType = map { $_ => 1 } qw(JPEG TIFF XMP AIFF EXE Font PS Real VCard TXT);
994              
995             # Compact/XMPShorthand option settings
996             my %compactOpt = (
997             nopadding => 'NoPadding', noindent => 'NoIndent', nonewline => 'NoNewline',
998             shorthand => 'Shorthand', onedesc => 'OneDesc',
999             all => ['NoPadding','NoIndent','NoNewline','Shorthand','OneDesc'],
1000             allspace => ['NoPadding','NoIndent','NoNewline'], allformat => ['Shorthand','OneDesc'],
1001             # aliases to cover anticipated user typos
1002             nonewlines => 'NoNewline', nospace => 'NoIndent', nospaces => 'NoIndent',
1003             nopad => 'NoPadding', onedescr => 'OneDesc',
1004             # allow numerical settings for backward compatibility
1005             0 => 'None',
1006             1 => 'NoPadding',
1007             2 => ['NoPadding','NoIndent'],
1008             3 => ['NoPadding','NoIndent','OneDesc'],
1009             4 => ['NoPadding','NoIndent','OneDesc','NoNewline'],
1010             5 => ['NoPadding','NoIndent','OneDesc','NoNewline','Shorthand'],
1011             );
1012             my %xmpShorthandOpt = ( 0 => 'None', 1 => 'Shorthand', 2 => ['Shorthand','OneDesc'] );
1013              
1014             # lookup for valid character set names (keys are all lower case)
1015             %charsetName = (
1016             # Charset setting alias(es)
1017             # ------------------------- --------------------------------------------
1018             utf8 => 'UTF8', cp65001 => 'UTF8', 'utf-8' => 'UTF8',
1019             latin => 'Latin', cp1252 => 'Latin', latin1 => 'Latin',
1020             latin2 => 'Latin2', cp1250 => 'Latin2',
1021             cyrillic => 'Cyrillic', cp1251 => 'Cyrillic', russian => 'Cyrillic',
1022             greek => 'Greek', cp1253 => 'Greek',
1023             turkish => 'Turkish', cp1254 => 'Turkish',
1024             hebrew => 'Hebrew', cp1255 => 'Hebrew',
1025             arabic => 'Arabic', cp1256 => 'Arabic',
1026             baltic => 'Baltic', cp1257 => 'Baltic',
1027             vietnam => 'Vietnam', cp1258 => 'Vietnam',
1028             thai => 'Thai', cp874 => 'Thai',
1029             doslatinus => 'DOSLatinUS', cp437 => 'DOSLatinUS',
1030             doslatin1 => 'DOSLatin1', cp850 => 'DOSLatin1',
1031             doscyrillic => 'DOSCyrillic', cp866 => 'DOSCyrillic',
1032             macroman => 'MacRoman', cp10000 => 'MacRoman', mac => 'MacRoman', roman => 'MacRoman',
1033             maclatin2 => 'MacLatin2', cp10029 => 'MacLatin2',
1034             maccyrillic => 'MacCyrillic', cp10007 => 'MacCyrillic',
1035             macgreek => 'MacGreek', cp10006 => 'MacGreek',
1036             macturkish => 'MacTurkish', cp10081 => 'MacTurkish',
1037             macromanian => 'MacRomanian', cp10010 => 'MacRomanian',
1038             maciceland => 'MacIceland', cp10079 => 'MacIceland',
1039             maccroatian => 'MacCroatian', cp10082 => 'MacCroatian',
1040             );
1041              
1042             # default family 0 group priority for writing
1043             # (NOTE: tags in groups not specified here will not be written unless
1044             # overridden by the module or specified when writing)
1045             my @defaultWriteGroups = qw(
1046             EXIF IPTC XMP MakerNotes QuickTime Photoshop ICC_Profile CanonVRD Adobe
1047             );
1048              
1049             # group hash for ExifTool-generated tags
1050             my %allGroupsExifTool = ( 0 => 'ExifTool', 1 => 'ExifTool', 2 => 'ExifTool' );
1051              
1052             # special tag names (not used for tag info)
1053             %specialTags = map { $_ => 1 } qw(
1054             TABLE_NAME SHORT_NAME PROCESS_PROC WRITE_PROC CHECK_PROC
1055             GROUPS FORMAT FIRST_ENTRY TAG_PREFIX PRINT_CONV
1056             WRITABLE TABLE_DESC NOTES IS_OFFSET IS_SUBDIR
1057             EXTRACT_UNKNOWN NAMESPACE PREFERRED SRC_TABLE PRIORITY
1058             AVOID WRITE_GROUP LANG_INFO VARS DATAMEMBER
1059             SET_GROUP1 PERMANENT INIT_TABLE
1060             );
1061              
1062             # headers for various segment types
1063             $exifAPP1hdr = "Exif\0\0";
1064             $xmpAPP1hdr = "http://ns.adobe.com/xap/1.0/\0";
1065             $xmpExtAPP1hdr = "http://ns.adobe.com/xmp/extension/\0";
1066             $psAPP13hdr = "Photoshop 3.0\0";
1067             $psAPP13old = 'Adobe_Photoshop2.5:';
1068              
1069 752     752 0 2726 sub DummyWriteProc { return 1; }
1070              
1071             # lookup for user lenses defined in @Image::ExifTool::UserDefined::Lenses
1072             %Image::ExifTool::userLens = ( );
1073              
1074             # queued plug-in tags to add to lookup
1075             @Image::ExifTool::pluginTags = ( );
1076             %Image::ExifTool::pluginTags = ( );
1077              
1078             my %systemTagsNotes = (
1079             Notes => q{
1080             extracted only if specifically requested or the L or L API
1081             option is set
1082             },
1083             );
1084              
1085             # tag information for preview image -- this should be used for all
1086             # PreviewImage tags so they are handled properly when reading/writing
1087             %Image::ExifTool::previewImageTagInfo = (
1088             Name => 'PreviewImage',
1089             Writable => 'undef',
1090             # a value of 'none' is ok...
1091             WriteCheck => '$val eq "none" ? undef : $self->CheckImage(\$val)',
1092             DataTag => 'PreviewImage',
1093             # accept either scalar or scalar reference
1094             RawConv => '$self->ValidateImage(ref $val ? $val : \$val, $tag)',
1095             # we allow preview image to be set to '', but we don't want a zero-length value
1096             # in the IFD, so set it temporarily to 'none'. Note that the length is <= 4,
1097             # so this value will fit in the IFD so the preview fixup won't be generated.
1098             ValueConvInv => '$val eq "" and $val="none"; $val',
1099             );
1100              
1101             # extra tags that aren't truly EXIF tags, but are generated by the script
1102             # Note: any tag in this list with a name corresponding to a Group0 name is
1103             # used to write the entire corresponding directory as a block.
1104             %Image::ExifTool::Extra = (
1105             GROUPS => { 0 => 'File', 1 => 'File', 2 => 'Image' },
1106             VARS => { NO_ID => 1 }, # tag ID's aren't meaningful for these tags
1107             WRITE_PROC => \&DummyWriteProc,
1108             Error => {
1109             Priority => 0,
1110             Groups => \%allGroupsExifTool,
1111             Notes => q{
1112             returns errors that may have occurred while reading or writing a file. Any
1113             Error will prevent the file from being processed. Minor errors may be
1114             downgraded to warnings with the -m or L option
1115             },
1116             },
1117             Warning => {
1118             Priority => 0,
1119             Groups => \%allGroupsExifTool,
1120             Notes => q{
1121             returns warnings that may have occurred while reading or writing a file.
1122             Use the -a or L option to see all warnings if more than one
1123             occurred. Minor warnings may be ignored with the -m or L
1124             option. Minor warnings with a capital "M" in the "[Minor]" designation
1125             indicate that the processing is affected by ignoring the warning
1126             },
1127             },
1128             Comment => {
1129             Notes => 'comment embedded in JPEG, GIF89a or PPM/PGM/PBM image',
1130             Writable => 1,
1131             WriteGroup => 'Comment',
1132             Priority => 0, # to preserve order of JPEG COM segments
1133             },
1134             Directory => {
1135             Groups => { 1 => 'System', 2 => 'Other' },
1136             Notes => q{
1137             the directory of the file as specified in the call to ExifTool, or "." if no
1138             directory was specified. May be written to move the file to another
1139             directory that will be created if doesn't already exist
1140             },
1141             Writable => 1,
1142             WritePseudo => 1,
1143             DelCheck => q{"Can't delete"},
1144             Protected => 1,
1145             RawConv => '$self->ConvertFileName($val)',
1146             # translate backslashes in directory names and add trailing '/'
1147             ValueConvInv => '$_ = $self->InverseFileName($val); m{[^/]$} and $_ .= "/"; $_',
1148             },
1149             FileName => {
1150             Groups => { 1 => 'System', 2 => 'Other' },
1151             Writable => 1,
1152             WritePseudo => 1,
1153             DelCheck => q{"Can't delete"},
1154             Protected => 1,
1155             Notes => q{
1156             may be written with a full path name to set FileName and Directory in one
1157             operation. This is such a powerful feature that a TestName tag is provided
1158             to allow dry-run tests before actually writing the file name. See
1159             L for more information on writing the
1160             FileName, Directory and TestName tags
1161             },
1162             RawConv => '$self->ConvertFileName($val)',
1163             ValueConvInv => '$self->InverseFileName($val)',
1164             },
1165             BaseName => {
1166             Groups => { 1 => 'System', 2 => 'Other' },
1167             Notes => q{
1168             file name without extension. Not generated unless specifically requested or
1169             the API L option is set
1170             },
1171             },
1172             FilePath => {
1173             Groups => { 1 => 'System', 2 => 'Other' },
1174             Notes => q{
1175             absolute path of source file. Not generated unless specifically requested or
1176             the API L option is set. Does not support Windows Unicode file
1177             names
1178             },
1179             },
1180             TestName => {
1181             Writable => 1,
1182             WritePseudo => 1,
1183             DelCheck => q{"Can't delete"},
1184             Protected => 1,
1185             WriteOnly => 1,
1186             Notes => q{
1187             this write-only tag may be used instead of FileName for dry-run tests of the
1188             file renaming feature. Writing this tag prints the old and new file names
1189             to the console, but does not affect the file itself
1190             },
1191             ValueConvInv => '$self->InverseFileName($val)',
1192             },
1193             FileSequence => {
1194             Groups => { 0 => 'ExifTool', 1 => 'ExifTool', 2 => 'Other' },
1195             Notes => q{
1196             sequence number for each source file when extracting or copying information,
1197             including files that fail the -if condition of the command-line application,
1198             beginning at 0 for the first file. Not generated unless specifically
1199             requested or the API L option is set
1200             },
1201             },
1202             FileSize => {
1203             Groups => { 1 => 'System', 2 => 'Other' },
1204             Notes => q{
1205             note that the print conversion for this tag uses historic prefixes: 1 kB =
1206             1024 bytes, etc.
1207             },
1208             PrintConv => \&ConvertFileSize,
1209             },
1210             ResourceForkSize => {
1211             Groups => { 1 => 'System', 2 => 'Other' },
1212             Notes => q{
1213             size of the file's resource fork if it contains data. Mac OS only. If this
1214             tag is generated the L option may be used to extract
1215             resource-fork information as a sub-document. When writing, the resource
1216             fork is preserved by default, but it may be deleted with C<-rsrc:all=> on
1217             the command line
1218             },
1219             PrintConv => \&ConvertFileSize,
1220             },
1221             ZoneIdentifier => {
1222             Groups => { 1 => 'System', 2 => 'Other' },
1223             Notes => q{
1224             Windows only. Existence indicates that the file has a Zone.Identifier
1225             alternate data stream, which is used by some Windows browsers to mark
1226             downloaded files as possibly unsafe to run. May be deleted to remove this
1227             stream. Requires Win32API::File
1228             },
1229             Writable => 1,
1230             WritePseudo => 1,
1231             Protected => 1,
1232             },
1233             FileType => {
1234             Groups => { 2 => 'Other' },
1235             Notes => q{
1236             a short description of the file type. For many file types this is the just
1237             the uppercase file extension
1238             },
1239             },
1240             FileTypeExtension => {
1241             Groups => { 2 => 'Other' },
1242             Notes => q{
1243             a common lowercase extension for this file type, or uppercase with the -n
1244             option
1245             },
1246             PrintConv => 'lc $val',
1247             },
1248             FileModifyDate => {
1249             Description => 'File Modification Date/Time',
1250             Notes => q{
1251             the filesystem modification date/time. Note that ExifTool may not be able
1252             to handle filesystem dates before 1970 depending on the limitations of the
1253             system's standard libraries
1254             },
1255             Groups => { 1 => 'System', 2 => 'Time' },
1256             Writable => 1,
1257             WritePseudo => 1,
1258             DelCheck => q{"Can't delete"},
1259             # all writable pseudo-tags must be protected so -tagsfromfile fails with
1260             # unrecognized files unless a pseudo tag is specified explicitly
1261             Protected => 1,
1262             Shift => 'Time',
1263             ValueConv => 'ConvertUnixTime($val,1)',
1264             ValueConvInv => 'GetUnixTime($val,1)',
1265             PrintConv => '$self->ConvertDateTime($val)',
1266             PrintConvInv => '$self->InverseDateTime($val)',
1267             },
1268             FileAccessDate => {
1269             Description => 'File Access Date/Time',
1270             Notes => q{
1271             the date/time of last access of the file. Note that this access time is
1272             updated whenever any software, including ExifTool, reads the file
1273             },
1274             Groups => { 1 => 'System', 2 => 'Time' },
1275             ValueConv => 'ConvertUnixTime($val,1)',
1276             PrintConv => '$self->ConvertDateTime($val)',
1277             },
1278             FileCreateDate => {
1279             Description => 'File Creation Date/Time',
1280             Notes => q{
1281             the filesystem creation date/time. Windows/Mac only. In Windows, the file
1282             creation date/time is preserved by default when writing if Win32API::File
1283             and Win32::API are available. On Mac, this tag is extracted only if it or
1284             the MacOS group is specifically requested or the API L option is
1285             set to 2 or higher. Requires "setfile" for writing on Mac, which may be
1286             installed by typing C in the Terminal
1287             },
1288             Groups => { 1 => 'System', 2 => 'Time' },
1289             Writable => 1,
1290             WritePseudo => 1,
1291             DelCheck => q{"Can't delete"},
1292             Protected => 1, # all writable pseudo-tags must be protected!
1293             Shift => 'Time',
1294             ValueConv => '$^O eq "darwin" ? $val : ConvertUnixTime($val,1)',
1295             ValueConvInv => q{
1296             return GetUnixTime($val,1) if $^O eq 'MSWin32';
1297             return $val if $^O eq 'darwin';
1298             warn "This tag is Windows/Mac only\n";
1299             return undef;
1300             },
1301             PrintConv => '$self->ConvertDateTime($val)',
1302             PrintConvInv => '$self->InverseDateTime($val)',
1303             },
1304             FileInodeChangeDate => {
1305             Description => 'File Inode Change Date/Time',
1306             Notes => q{
1307             the date/time when the file's directory information was last changed.
1308             Non-Windows systems only
1309             },
1310             Groups => { 1 => 'System', 2 => 'Time' },
1311             ValueConv => 'ConvertUnixTime($val,1)',
1312             PrintConv => '$self->ConvertDateTime($val)',
1313             },
1314             FilePermissions => {
1315             Groups => { 1 => 'System', 2 => 'Other' },
1316             Notes => q{
1317             r=read, w=write and x=execute permissions for the file owner, group and
1318             others. The ValueConv value is an octal number so bit test operations on
1319             this value should be done in octal, eg. 'oct($filePermissions#) & 0200'
1320             },
1321             Writable => 1,
1322             WritePseudo => 1,
1323             DelCheck => q{"Can't delete"},
1324             Protected => 1, # all writable pseudo-tags must be protected!
1325             ValueConv => 'sprintf("%.3o", $val)',
1326             ValueConvInv => 'oct($val & 07777)',
1327             PrintConv => sub {
1328             my ($mask, $val) = (0400, oct(shift));
1329             my %types = (
1330             0010000 => 'p',
1331             0020000 => 'c',
1332             0040000 => 'd',
1333             0060000 => 'b',
1334             0120000 => 'l',
1335             0140000 => 's',
1336             );
1337             my $str = $types{$val & 0170000} || '-';
1338             while ($mask) {
1339             foreach (qw(r w x)) {
1340             $str .= $val & $mask ? $_ : '-';
1341             $mask >>= 1;
1342             }
1343             }
1344             return $str;
1345             },
1346             PrintConvInv => sub {
1347             my ($bit, $val, $str) = (8, 0, shift);
1348             $str = substr($str, 1) if length($str) == 10;
1349             return undef if length($str) != 9;
1350             while ($bit >= 0) {
1351             foreach (qw(r w x)) {
1352             $val |= (1 << $bit) if substr($str, 8-$bit, 1) eq $_;
1353             --$bit;
1354             }
1355             }
1356             return sprintf('%.3o', $val);
1357             },
1358             },
1359             FileAttributes => {
1360             Groups => { 1 => 'System', 2 => 'Other' },
1361             Notes => q{
1362             extracted only if specifically requested or the L or L API
1363             option is set. 2 or 3 values: 0. File type, 1. Attribute bits, 2. Windows
1364             attribute bits if Win32API::File is available
1365             },
1366             PrintHex => 1,
1367             PrintConvColumns => 2,
1368             PrintConv => [{ # stat device types (bitmask 0xf000)
1369             0x0000 => 'Unknown',
1370             0x1000 => 'FIFO',
1371             0x2000 => 'Character',
1372             0x3000 => 'Mux Character',
1373             0x4000 => 'Directory',
1374             0x5000 => 'XENIX Named',
1375             0x6000 => 'Block',
1376             0x7000 => 'Mux Block',
1377             0x8000 => 'Regular',
1378             0x9000 => 'VxFS Compressed',
1379             0xa000 => 'Symbolic Link',
1380             0xb000 => 'Solaris Shadow Inode',
1381             0xc000 => 'Socket',
1382             0xd000 => 'Solaris Door',
1383             0xe000 => 'BSD Whiteout',
1384             },{ BITMASK => { # stat attribute bits (bitmask 0x0e00)
1385             9 => 'Sticky',
1386             10 => 'Set Group ID',
1387             11 => 'Set User ID',
1388             }},{ BITMASK => { # Windows attribute bits
1389             0 => 'Read Only',
1390             1 => 'Hidden',
1391             2 => 'System',
1392             3 => 'Volume Label',
1393             4 => 'Directory',
1394             5 => 'Archive',
1395             6 => 'Device',
1396             7 => 'Normal',
1397             8 => 'Temporary',
1398             9 => 'Sparse File',
1399             10 => 'Reparse Point',
1400             11 => 'Compressed',
1401             12 => 'Offline',
1402             13 => 'Not Content Indexed',
1403             14 => 'Encrypted',
1404             }}],
1405             },
1406             FileDeviceID => {
1407             Groups => { 1 => 'System', 2 => 'Other' },
1408             %systemTagsNotes,
1409             PrintConv => '(($val >> 24) & 0xff) . "." . ($val & 0xffffff)', # (major.minor)
1410             },
1411             FileDeviceNumber => { Groups => { 1 => 'System', 2 => 'Other' }, %systemTagsNotes },
1412             FileInodeNumber => { Groups => { 1 => 'System', 2 => 'Other' }, %systemTagsNotes },
1413             FileHardLinks => { Groups => { 1 => 'System', 2 => 'Other' }, %systemTagsNotes },
1414             FileUserID => {
1415             Groups => { 1 => 'System', 2 => 'Other' },
1416             Notes => q{
1417             extracted only if specifically requested or the L or L API
1418             option is set. Returns user ID number with the -n option, or name
1419             otherwise. May be written with either user name or number
1420             },
1421             Writable => 1,
1422             WritePseudo => 1,
1423             DelCheck => q{"Can't delete"},
1424             Protected => 1, # all writable pseudo-tags must be protected!
1425             PrintConv => 'eval { getpwuid($val) } || $val',
1426             PrintConvInv => 'eval { getpwnam($val) } || ($val=~/[^0-9]/ ? undef : $val)',
1427             },
1428             FileGroupID => {
1429             Groups => { 1 => 'System', 2 => 'Other' },
1430             Notes => q{
1431             extracted only if specifically requested or the L or L API
1432             option is set. Returns group ID number with the -n option, or name
1433             otherwise. May be written with either group name or number
1434             },
1435             Writable => 1,
1436             WritePseudo => 1,
1437             DelCheck => q{"Can't delete"},
1438             Protected => 1, # all writable pseudo-tags must be protected!
1439             PrintConv => 'eval { getgrgid($val) } || $val',
1440             PrintConvInv => 'eval { getgrnam($val) } || ($val=~/[^0-9]/ ? undef : $val)',
1441             },
1442             FileBlockSize => { Groups => { 1 => 'System', 2 => 'Other' }, %systemTagsNotes },
1443             FileBlockCount => { Groups => { 1 => 'System', 2 => 'Other' }, %systemTagsNotes },
1444             HardLink => {
1445             Writable => 1,
1446             DelCheck => q{"Can't delete"},
1447             WriteOnly => 1,
1448             WritePseudo => 1,
1449             Protected => 1,
1450             Notes => q{
1451             this write-only tag is used to create a hard link with the specified name to
1452             the source file. If the source file is edited, copied, renamed or moved in
1453             the same operation as writing HardLink, then the link is made to the updated
1454             file. Note that subsequent editing of either hard-linked file by exiftool
1455             will break the link unless the -overwrite_original_in_place option is used
1456             },
1457             ValueConvInv => '$val=~tr/\\\\/\//; $val',
1458             },
1459             SymLink => {
1460             Writable => 1,
1461             DelCheck => q{"Can't delete"},
1462             WriteOnly => 1,
1463             WritePseudo => 1,
1464             Protected => 1,
1465             Notes => q{
1466             this write-only tag is used to create a symbolic link with the specified
1467             name to the source file. If the source file is edited, copied, renamed or
1468             moved in the same operation as writing SymLink, then the link is made to the
1469             updated file. The link uses an absolute path unless it is created in the
1470             current working directory. Valid only for file systems that support
1471             symbolic links. Note that subsequent editing of the file via the symbolic
1472             link by exiftool will cause the link to be replaced by the edited file
1473             without changing the original unless the -overwrite_original_in_place option
1474             is used
1475             },
1476             ValueConvInv => '$val=~tr/\\\\/\//; $val',
1477             },
1478             MIMEType => { Notes => 'the MIME type of the source file', Groups => { 2 => 'Other' } },
1479             ImageWidth => { Notes => 'the width of the image in number of pixels' },
1480             ImageHeight => { Notes => 'the height of the image in number of pixels' },
1481             XResolution => { Notes => 'the horizontal pixel resolution' },
1482             YResolution => { Notes => 'the vertical pixel resolution' },
1483             MaxVal => { Notes => 'maximum pixel value in PPM or PGM image' },
1484             EXIF => {
1485             Notes => q{
1486             the full EXIF data block from JPEG, PNG, JP2, MIE and MIFF images. This tag
1487             is generated only if specifically requested
1488             },
1489             Groups => { 0 => 'EXIF', 1 => 'EXIF' },
1490             Flags => ['Writable' ,'Protected', 'Binary', 'DelGroup'],
1491             WriteCheck => q{
1492             return undef if $val =~ /^(II\x2a\0|MM\0\x2a)/;
1493             return 'Invalid EXIF data';
1494             },
1495             },
1496             IPTC => {
1497             Notes => q{
1498             the full IPTC data block. This tag is generated only if specifically
1499             requested
1500             },
1501             Groups => { 0 => 'IPTC', 1 => 'IPTC' },
1502             Flags => ['Writable', 'Protected', 'Binary', 'DelGroup'],
1503             Priority => 0, # so main IPTC (which hopefully comes first) takes priority
1504             WriteCheck => q{
1505             return undef if $val =~ /^(\x1c|\0+$)/;
1506             return 'Invalid IPTC data';
1507             },
1508             },
1509             XMP => {
1510             Notes => q{
1511             the XMP data block, but note that extended XMP in JPEG images may be split
1512             into multiple blocks. This tag is generated only if specifically requested
1513             },
1514             Groups => { 0 => 'XMP', 1 => 'XMP' },
1515             Flags => ['Writable', 'Protected', 'Binary', 'DelGroup'],
1516             Priority => 0, # so main xmp (which usually comes first) takes priority
1517             WriteCheck => q{
1518             require Image::ExifTool::XMP;
1519             return Image::ExifTool::XMP::CheckXMP($self, $tagInfo, \$val);
1520             },
1521             },
1522             XML => {
1523             Notes => 'the XML data block, extracted for some file types',
1524             Groups => { 0 => 'XML', 1 => 'XML' },
1525             Binary => 1,
1526             },
1527             ICC_Profile => {
1528             Notes => q{
1529             the full ICC_Profile data block. This tag is generated only if specifically
1530             requested
1531             },
1532             Groups => { 0 => 'ICC_Profile', 1 => 'ICC_Profile' },
1533             Flags => ['Writable' ,'Protected', 'Binary', 'DelGroup'],
1534             WriteCheck => q{
1535             require Image::ExifTool::ICC_Profile;
1536             return Image::ExifTool::ICC_Profile::ValidateICC(\$val);
1537             },
1538             },
1539             CanonVRD => {
1540             Notes => q{
1541             the full Canon DPP VRD trailer block. This tag is generated only if
1542             specifically requested
1543             },
1544             Groups => { 0 => 'CanonVRD', 1 => 'CanonVRD' },
1545             Flags => ['Writable' ,'Protected', 'Binary', 'DelGroup'],
1546             Permanent => 0, # (this is 1 by default for MakerNotes tags)
1547             WriteCheck => q{
1548             return undef if $val =~ /^CANON OPTIONAL DATA\0/;
1549             return 'Invalid CanonVRD data';
1550             },
1551             },
1552             CanonDR4 => {
1553             Notes => q{
1554             the full Canon DPP version 4 DR4 block. This tag is generated only if
1555             specifically requested
1556             },
1557             Groups => { 0 => 'CanonVRD', 1 => 'CanonVRD' },
1558             Flags => ['Writable' ,'Protected', 'Binary'],
1559             Permanent => 0, # (this is 1 by default for MakerNotes tags)
1560             WriteCheck => q{
1561             return undef if $val =~ /^IIII\x04\0\x04\0/;
1562             return 'Invalid CanonDR4 data';
1563             },
1564             },
1565             Adobe => {
1566             Notes => q{
1567             the JPEG APP14 Adobe segment. Extracted only if specified. See the
1568             L for more information
1569             },
1570             Groups => { 0 => 'APP14', 1 => 'Adobe' },
1571             WriteGroup => 'Adobe',
1572             Flags => ['Writable' ,'Protected', 'Binary'],
1573             },
1574             CurrentIPTCDigest => {
1575             Notes => q{
1576             MD5 digest of existing IPTC data. All zeros if IPTC exists but Digest::MD5
1577             is not installed. Only calculated for IPTC in the standard location as
1578             specified by the L. ExifTool
1579             automates the handling of this tag in the MWG module -- see the
1580             L for details
1581             },
1582             ValueConv => 'unpack("H*", $val)',
1583             },
1584             PreviewImage => {
1585             Notes => 'JPEG-format embedded preview image',
1586             Groups => { 2 => 'Preview' },
1587             Writable => 1,
1588             WriteCheck => '$self->CheckImage(\$val)',
1589             WriteGroup => 'All',
1590             # can't delete, so set to empty string and return no error
1591             DelCheck => '$val = ""; return undef',
1592             # accept either scalar or scalar reference
1593             RawConv => '$self->ValidateImage(ref $val ? $val : \$val, $tag)',
1594             },
1595             ThumbnailImage => {
1596             Groups => { 2 => 'Preview' },
1597             Notes => 'JPEG-format embedded thumbnail image',
1598             RawConv => '$self->ValidateImage(ref $val ? $val : \$val, $tag)',
1599             },
1600             OtherImage => {
1601             Groups => { 2 => 'Preview' },
1602             Notes => 'other JPEG-format embedded image',
1603             RawConv => '$self->ValidateImage(ref $val ? $val : \$val, $tag)',
1604             },
1605             PreviewPNG => {
1606             Groups => { 2 => 'Preview' },
1607             Notes => 'PNG-format embedded preview image',
1608             Binary => 1,
1609             },
1610             PreviewWMF => {
1611             Groups => { 2 => 'Preview' },
1612             Notes => 'WMF-format embedded preview image',
1613             Binary => 1,
1614             },
1615             PreviewTIFF => {
1616             Groups => { 2 => 'Preview' },
1617             Notes => 'TIFF-format embedded preview image',
1618             Binary => 1,
1619             },
1620             PreviewPDF => {
1621             Groups => { 2 => 'Preview' },
1622             Notes => 'PDF-format embedded preview image',
1623             Binary => 1,
1624             },
1625             ExifByteOrder => {
1626             Writable => 1,
1627             DelCheck => q{"Can't delete"},
1628             Notes => q{
1629             represents the byte order of EXIF information. May be written to set the
1630             byte order only for newly created EXIF segments
1631             },
1632             PrintConv => {
1633             II => 'Little-endian (Intel, II)',
1634             MM => 'Big-endian (Motorola, MM)',
1635             },
1636             },
1637             ExifUnicodeByteOrder => {
1638             Writable => 1,
1639             WriteOnly => 1,
1640             DelCheck => q{"Can't delete"},
1641             Notes => q{
1642             specifies the byte order to use when writing EXIF Unicode text. The EXIF
1643             specification is particularly vague about this byte ordering, and different
1644             applications use different conventions. By default ExifTool writes Unicode
1645             text in EXIF byte order, but this write-only tag may be used to force a
1646             specific order. Applies to the EXIF UserComment tag when writing special
1647             characters
1648             },
1649             PrintConv => {
1650             II => 'Little-endian (Intel, II)',
1651             MM => 'Big-endian (Motorola, MM)',
1652             },
1653             },
1654             ExifToolVersion => {
1655             Description => 'ExifTool Version Number',
1656             Groups => \%allGroupsExifTool,
1657             Notes => 'the version of ExifTool currently running',
1658             },
1659             ProcessingTime => {
1660             Groups => { 0 => 'ExifTool', 1 => 'ExifTool', 2 => 'Other' },
1661             Notes => q{
1662             the clock time in seconds taken by ExifTool to extract information from this
1663             file. Not generated unless specifically requested or the L API
1664             option is set. Requires Time::HiRes
1665             },
1666             PrintConv => 'sprintf("%.3g s", $val)',
1667             },
1668             RAFVersion => { Notes => 'RAF file version number' },
1669             JPEGDigest => {
1670             Notes => q{
1671             an MD5 digest of the JPEG quantization tables is combined with the component
1672             sub-sampling values to generate the value of this tag. The result is
1673             compared to known values in an attempt to deduce the originating software
1674             based only on the JPEG image data. For performance reasons, this tag is
1675             generated only if specifically requested or the API L option is set
1676             to 3 or higher
1677             },
1678             },
1679             JPEGQualityEstimate => {
1680             Notes => q{
1681             an estimate of the IJG JPEG quality setting for the image, calculated from
1682             the quantization tables. For performance reasons, this tag is generated
1683             only if specifically requested or the API L option is set to 3 or
1684             higher
1685             },
1686             },
1687             JPEGImageLength => {
1688             Notes => q{
1689             byte length of JPEG image without metadata. For performance reasons, this
1690             tag is generated only if specifically requested or the API L option
1691             is set to 3 or higher
1692             },
1693             },
1694             # Validate (added from Validate.pm)
1695             Now => {
1696             Groups => { 0 => 'ExifTool', 1 => 'ExifTool', 2 => 'Time' },
1697             Notes => q{
1698             the current date/time. Useful when setting the tag values, eg.
1699             C<"-modifydate. Not generated unless specifically requested or the
1700             API L option is set
1701             },
1702             PrintConv => '$self->ConvertDateTime($val)',
1703             },
1704             NewGUID => {
1705             Groups => { 0 => 'ExifTool', 1 => 'ExifTool', 2 => 'Other' },
1706             Notes => q{
1707             generates a new, random GUID with format
1708             YYYYmmdd-HHMM-SSNN-PPPP-RRRRRRRRRRRR, where Y=year, m=month, d=day, H=hour,
1709             M=minute, S=second, N=file sequence number in hex, P=process ID in hex, and
1710             R=random hex number; without dashes with the -n option. Not generated
1711             unless specifically requested or the API L option is set
1712             },
1713             PrintConv => '$val =~ s/(.{8})(.{4})(.{4})(.{4})/$1-$2-$3-$4-/; $val',
1714             },
1715             ID3Size => { Notes => 'size of the ID3 data block' },
1716             Geotag => {
1717             Writable => 1,
1718             WriteOnly => 1,
1719             WriteNothing => 1,
1720             AllowGroup => '(exif|gps|xmp|xmp-exif)',
1721             Notes => q{
1722             this write-only tag is used to define the GPS track log data or track log
1723             file name. Currently supported track log formats are GPX, NMEA RMC/GGA/GLL,
1724             KML, IGC, Garmin XML and TCX, Magellan PMGNTRK, Honeywell PTNTHPR, Winplus
1725             Beacon text, and Bramor gEO log files. May be set to the special value of
1726             "DATETIMEONLY" (all caps) to set GPS date/time tags if no input track points
1727             are available. See L for details
1728             },
1729             DelCheck => q{
1730             require Image::ExifTool::Geotag;
1731             # delete associated tags
1732             Image::ExifTool::Geotag::SetGeoValues($self, undef, $wantGroup);
1733             },
1734             ValueConvInv => q{
1735             require Image::ExifTool::Geotag;
1736             # always warn because this tag is never set (warning is "\n" on success)
1737             my $result = Image::ExifTool::Geotag::LoadTrackLog($self, $val);
1738             return '' if not defined $result; # deleting geo tags
1739             return $result if ref $result; # geotag data hash reference
1740             warn "$result\n"; # error string
1741             },
1742             },
1743             Geotime => {
1744             Writable => 1,
1745             WriteOnly => 1,
1746             AllowGroup => '(exif|gps|xmp|xmp-exif)',
1747             Notes => q{
1748             this write-only tag is used to define a date/time for interpolating a
1749             position in the GPS track specified by the Geotag tag. Writing this tag
1750             causes GPS information to be written into the EXIF or XMP of the target
1751             files. The local system timezone is assumed if the date/time value does not
1752             contain a timezone. May be deleted to delete associated GPS tags. A group
1753             name of "EXIF" or "XMP" may be specified to write or delete only EXIF or XMP
1754             GPS tags
1755             },
1756             DelCheck => q{
1757             require Image::ExifTool::Geotag;
1758             # delete associated tags
1759             Image::ExifTool::Geotag::SetGeoValues($self, undef, $wantGroup);
1760             },
1761             ValueConvInv => q{
1762             require Image::ExifTool::Geotag;
1763             warn Image::ExifTool::Geotag::SetGeoValues($self, $val, $wantGroup) . "\n";
1764             return undef;
1765             },
1766             },
1767             Geosync => {
1768             Writable => 1,
1769             WriteOnly => 1,
1770             WriteNothing => 1,
1771             AllowGroup => '(exif|gps|xmp|xmp-exif)',
1772             Shift => 'Time', # enables "+=" syntax as well as "=+"
1773             Notes => q{
1774             this write-only tag specifies a time difference to add to Geotime for
1775             synchronization with the GPS clock. For example, set this to "-12" if the
1776             camera clock is 12 seconds faster than GPS time. Input format is
1777             "[+-][[[DD ]HH:]MM:]SS[.ss]". Additional features allow calculation of time
1778             differences and time drifts, and extraction of synchronization times from
1779             image files. See the L for details
1780             },
1781             ValueConvInv => q{
1782             require Image::ExifTool::Geotag;
1783             return Image::ExifTool::Geotag::ConvertGeosync($self, $val);
1784             },
1785             },
1786             ForceWrite => {
1787             Groups => { 0 => '*', 1 => '*', 2 => '*' },
1788             Writable => 1,
1789             WriteOnly => 1,
1790             Notes => q{
1791             write-only tag used to force metadata in a file to be rewritten even if no
1792             tag values are changed. May be set to "EXIF", "IPTC", "XMP" or "PNG" to
1793             force the corresponding metadata type to be rewritten, "FixBase" to cause
1794             EXIF to be rewritten only if the MakerNotes offset base was fixed, or "All"
1795             to rewrite all of these metadata types. Values are case insensitive, and
1796             multiple values may be separated with commas, eg. C<-ForceWrite=exif,xmp>
1797             },
1798             },
1799             EmbeddedVideo => { Groups => { 0 => 'Trailer', 2 => 'Video' } },
1800             Trailer => {
1801             Groups => { 0 => 'Trailer' },
1802             Notes => q{
1803             the full JPEG trailer data block. Extracted only if specifically requested
1804             or the API RequestAll option is set to 3 or higher
1805             },
1806             Writable => 1,
1807             Protected => 1,
1808             },
1809             PageCount => { Notes => 'the number of pages in a multi-page TIFF document' },
1810             );
1811              
1812             # tags defined by UserParam option (added at runtime)
1813             %Image::ExifTool::UserParam = (
1814             GROUPS => { 0 => 'UserParam', 1 => 'UserParam', 2 => 'Other' },
1815             PRIORITY => 0,
1816             );
1817              
1818             # YCbCrSubSampling values (used by JPEG SOF, EXIF and XMP)
1819             %Image::ExifTool::JPEG::yCbCrSubSampling = (
1820             '1 1' => 'YCbCr4:4:4 (1 1)', #PH
1821             '2 1' => 'YCbCr4:2:2 (2 1)', #14 in Exif.pm
1822             '2 2' => 'YCbCr4:2:0 (2 2)', #14 in Exif.pm
1823             '4 1' => 'YCbCr4:1:1 (4 1)', #14 in Exif.pm
1824             '4 2' => 'YCbCr4:1:0 (4 2)', #PH
1825             '1 2' => 'YCbCr4:4:0 (1 2)', #PH
1826             '1 4' => 'YCbCr4:4:1 (1 4)', #JD
1827             '2 4' => 'YCbCr4:2:1 (2 4)', #JD
1828             );
1829              
1830             # define common JPEG segments here to avoid overhead of loading JPEG module
1831              
1832             # JPEG SOF (start of frame) tags
1833             # (ref http://www.w3.org/Graphics/JPEG/itu-t81.pdf)
1834             %Image::ExifTool::JPEG::SOF = (
1835             GROUPS => { 0 => 'File', 1 => 'File', 2 => 'Image' },
1836             NOTES => 'This information is extracted from the JPEG Start Of Frame segment.',
1837             VARS => { NO_ID => 1 }, # tag ID's aren't meaningful for these tags
1838             EncodingProcess => {
1839             PrintHex => 1,
1840             PrintConv => {
1841             0x0 => 'Baseline DCT, Huffman coding',
1842             0x1 => 'Extended sequential DCT, Huffman coding',
1843             0x2 => 'Progressive DCT, Huffman coding',
1844             0x3 => 'Lossless, Huffman coding',
1845             0x5 => 'Sequential DCT, differential Huffman coding',
1846             0x6 => 'Progressive DCT, differential Huffman coding',
1847             0x7 => 'Lossless, Differential Huffman coding',
1848             0x9 => 'Extended sequential DCT, arithmetic coding',
1849             0xa => 'Progressive DCT, arithmetic coding',
1850             0xb => 'Lossless, arithmetic coding',
1851             0xd => 'Sequential DCT, differential arithmetic coding',
1852             0xe => 'Progressive DCT, differential arithmetic coding',
1853             0xf => 'Lossless, differential arithmetic coding',
1854             }
1855             },
1856             BitsPerSample => { },
1857             ImageHeight => { },
1858             ImageWidth => { },
1859             ColorComponents => { },
1860             YCbCrSubSampling => {
1861             Notes => 'calculated from components table',
1862             PrintConv => \%Image::ExifTool::JPEG::yCbCrSubSampling,
1863             },
1864             );
1865              
1866             # JPEG JFIF APP0 definitions
1867             %Image::ExifTool::JFIF::Main = (
1868             PROCESS_PROC => \&Image::ExifTool::ProcessBinaryData,
1869             WRITE_PROC => \&Image::ExifTool::WriteBinaryData,
1870             CHECK_PROC => \&Image::ExifTool::CheckBinaryData,
1871             GROUPS => { 0 => 'JFIF', 1 => 'JFIF', 2 => 'Image' },
1872             DATAMEMBER => [ 2, 3, 5 ],
1873             0 => {
1874             Name => 'JFIFVersion',
1875             Format => 'int8u[2]',
1876             PrintConv => 'sprintf("%d.%.2d", split(" ",$val))',
1877             Mandatory => 1,
1878             },
1879             2 => {
1880             Name => 'ResolutionUnit',
1881             Writable => 1,
1882             RawConv => '$$self{JFIFResolutionUnit} = $val',
1883             PrintConv => {
1884             0 => 'None',
1885             1 => 'inches',
1886             2 => 'cm',
1887             },
1888             Priority => -1,
1889             Mandatory => 1,
1890             },
1891             3 => {
1892             Name => 'XResolution',
1893             Format => 'int16u',
1894             Writable => 1,
1895             Priority => -1,
1896             RawConv => '$$self{JFIFXResolution} = $val',
1897             Mandatory => 1,
1898             },
1899             5 => {
1900             Name => 'YResolution',
1901             Format => 'int16u',
1902             Writable => 1,
1903             Priority => -1,
1904             RawConv => '$$self{JFIFYResolution} = $val',
1905             Mandatory => 1,
1906             },
1907             7 => {
1908             Name => 'ThumbnailWidth',
1909             RawConv => '$val ? $$self{JFIFThumbnailWidth} = $val : undef',
1910             },
1911             8 => {
1912             Name => 'ThumbnailHeight',
1913             RawConv => '$val ? $$self{JFIFThumbnailHeight} = $val : undef',
1914             },
1915             9 => {
1916             Name => 'ThumbnailTIFF',
1917             Groups => { 2 => 'Preview' },
1918             Format => 'undef[3*($val{7}||0)*($val{8}||0)]',
1919             Notes => 'raw RGB thumbnail data, extracted as a TIFF image',
1920             RawConv => 'length($val) ? $val : undef',
1921             ValueConv => sub {
1922             my ($val, $et) = @_;
1923             my $len = length $val;
1924             return \ "Binary data $len bytes" unless $et->Options('Binary');
1925             my $img = MakeTiffHeader($$et{JFIFThumbnailWidth},$$et{JFIFThumbnailHeight},3,8) . $val;
1926             return \$img;
1927             },
1928             },
1929             );
1930             %Image::ExifTool::JFIF::Extension = (
1931             GROUPS => { 0 => 'JFIF', 1 => 'JFXX', 2 => 'Image' },
1932             NOTES => 'Thumbnail images extracted from the JFXX segment.',
1933             0x10 => {
1934             Name => 'ThumbnailImage',
1935             Groups => { 2 => 'Preview' },
1936             Notes => 'JPEG-format thumbnail image',
1937             RawConv => '$self->ValidateImage(\$val,$tag)',
1938             },
1939             0x11 => { # (untested)
1940             Name => 'ThumbnailTIFF',
1941             Groups => { 2 => 'Preview' },
1942             Notes => 'raw palette-color thumbnail data, extracted as a TIFF image',
1943             RawConv => '(length $val > 770 and $val !~ /^\0\0/) ? $val : undef',
1944             ValueConv => sub {
1945             my ($val, $et) = @_;
1946             my $len = length $val;
1947             return \ "Binary data $len bytes" unless $et->Options('Binary');
1948             my ($w, $h) = unpack('CC', $val);
1949             my $img = MakeTiffHeader($w,$h,1,8,undef,substr($val,2,768)) . substr($val,770);
1950             return \$img;
1951             },
1952             },
1953             0x13 => {
1954             Name => 'ThumbnailTIFF',
1955             Groups => { 2 => 'Preview' },
1956             Notes => 'raw RGB thumbnail data, extracted as a TIFF image',
1957             RawConv => '(length $val > 2 and $val !~ /^\0\0/) ? $val : undef',
1958             ValueConv => sub {
1959             my ($val, $et) = @_;
1960             my $len = length $val;
1961             return \ "Binary data $len bytes" unless $et->Options('Binary');
1962             my ($w, $h) = unpack('CC', $val);
1963             my $img = MakeTiffHeader($w,$h,3,8) . substr($val,2);
1964             return \$img;
1965             },
1966             },
1967             # Apple may add "AMPF" to the end of the JFIF record,
1968             # possibly indicating the existence of MPF images (ref forum12677)
1969             );
1970              
1971             # Composite tags (accumulation of all Composite tag tables)
1972             %Image::ExifTool::Composite = (
1973             GROUPS => { 0 => 'Composite', 1 => 'Composite' },
1974             TABLE_NAME => 'Image::ExifTool::Composite',
1975             SHORT_NAME => 'Composite',
1976             VARS => { NO_ID => 1 }, # want empty tagID's for Composite tags
1977             WRITE_PROC => \&DummyWriteProc,
1978             );
1979              
1980             my %compositeID; # lookup for new ID's of Composite tags based on original ID
1981              
1982             # static private ExifTool variables
1983              
1984             %allTables = ( ); # list of all tables loaded (except Composite tags)
1985             @tableOrder = ( ); # order the tables were loaded
1986              
1987             #------------------------------------------------------------------------------
1988             # Warning handler routines (warning string stored in $evalWarning)
1989             #
1990             # Set warning message
1991             # Inputs: 0) warning string (undef to reset warning)
1992 38     38 0 576 sub SetWarning($) { $evalWarning = $_[0]; }
1993              
1994             # Get warning message
1995 17     17 0 69 sub GetWarning() { return $evalWarning; }
1996              
1997             # Clean unnecessary information (line number, LF) from warning
1998             # Inputs: 0) warning string or undef to use $evalWarning
1999             # Returns: cleaned warning
2000             sub CleanWarning(;$)
2001             {
2002 223     223 0 457 my $str = shift;
2003 223 50       621 unless (defined $str) {
2004 223 50       539 return undef unless defined $evalWarning;
2005 223         452 $str = $evalWarning;
2006             }
2007 223 100       1499 $str = $1 if $str =~ /(.*) at /s;
2008 223         829 $str =~ s/\s+$//s;
2009 223         1062 return $str;
2010             }
2011              
2012             #==============================================================================
2013             # New - create new ExifTool object
2014             # Inputs: 0) reference to exiftool object or ExifTool class name
2015             # Returns: blessed ExifTool object ref
2016             sub new
2017             {
2018 475     475 1 132048 local $_;
2019 475         1349 my $that = shift;
2020 475   50     3836 my $class = ref($that) || $that || 'Image::ExifTool';
2021 475         1723 my $self = bless {}, $class;
2022              
2023             # make sure our main Exif tag table has been loaded
2024 475         2123 GetTagTable("Image::ExifTool::Exif::Main");
2025              
2026 475         3187 $self->ClearOptions(); # create default options hash
2027 475         1432 $$self{VALUE} = { }; # must initialize this for warning messages
2028 475         1589 $$self{PATH} = [ ]; # (this too)
2029 475         1410 $$self{DEL_GROUP} = { }; # lookup for groups to delete when writing
2030 475         1303 $$self{SAVE_COUNT} = 0; # count calls to SaveNewValues()
2031 475         1258 $$self{FILE_SEQUENCE} = 0; # sequence number for files when reading
2032              
2033             # initialize our new groups for writing
2034 475         2573 $self->SetNewGroups(@defaultWriteGroups);
2035              
2036 475         2309 return $self;
2037             }
2038              
2039             #------------------------------------------------------------------------------
2040             # ImageInfo - return specified information from image file
2041             # Inputs: 0) [optional] ExifTool object reference
2042             # 1) filename, file reference, or scalar data reference
2043             # 2-N) list of tag names to find (or tag list reference or options reference)
2044             # Returns: reference to hash of tag/value pairs (with "Error" entry on error)
2045             # Notes:
2046             # - if no tags names are specified, the values of all tags are returned
2047             # - tags may be specified with leading '-' to exclude, or trailing '#' for ValueConv
2048             # - can pass a reference to list of tags to find, in which case the list will
2049             # be updated with the tags found in the proper case and in the specified order.
2050             # - can pass reference to hash specifying options
2051             # - returned tag values may be scalar references indicating binary data
2052             # - see ClearOptions() below for a list of options and their default values
2053             # Examples:
2054             # use Image::ExifTool 'ImageInfo';
2055             # my $info = ImageInfo($file, 'DateTimeOriginal', 'ImageSize');
2056             # - or -
2057             # my $et = new Image::ExifTool;
2058             # my $info = $et->ImageInfo($file, \@tagList, {Sort=>'Group0'} );
2059             sub ImageInfo($;@)
2060             {
2061 510     510 1 30240 local $_;
2062             # get our ExifTool object ($self) or create one if necessary
2063 510         1117 my $self;
2064 510 100 100     5928 if (ref $_[0] and UNIVERSAL::isa($_[0],'Image::ExifTool')) {
2065 501         1518 $self = shift;
2066             } else {
2067 9         75 $self = new Image::ExifTool;
2068             }
2069 510         1213 my %saveOptions = %{$$self{OPTIONS}}; # save original options
  510         22555  
2070              
2071             # initialize file information
2072 510         4111 $$self{FILENAME} = $$self{RAF} = undef;
2073              
2074 510         3067 $self->ParseArguments(@_); # parse our function arguments
2075 510         3000 $self->ExtractInfo(undef); # extract meta information from image
2076 510         2751 my $info = $self->GetInfo(undef); # get requested information
2077              
2078 510         8042 $$self{OPTIONS} = \%saveOptions; # restore original options
2079              
2080 510         3391 return $info; # return requested information
2081             }
2082              
2083             #------------------------------------------------------------------------------
2084             # Get/set ExifTool options
2085             # Inputs: 0) ExifTool object reference,
2086             # 1) Parameter name (case insensitive), 2) Value to set the option
2087             # 3-N) More parameter/value pairs
2088             # Returns: original value of last option specified
2089             sub Options($$;@)
2090             {
2091 17518     17518 1 43136 local $_;
2092 17518         25665 my $self = shift;
2093 17518         28681 my $options = $$self{OPTIONS};
2094 17518         24373 my $oldVal;
2095              
2096 17518         38260 while (@_) {
2097 20224         32776 my $param = shift;
2098             # fix parameter case if necessary
2099 20224 100       45469 unless (exists $$options{$param}) {
2100 376         23242 my ($fixed) = grep /^$param$/i, keys %$options;
2101 376 50       2746 if ($fixed) {
2102 0         0 $param = $fixed;
2103             } else {
2104 376         1759 $param =~ s/^Group(\d*)$/Group$1/i;
2105             }
2106             }
2107 20224         33624 $oldVal = $$options{$param};
2108 20224 50 33     42219 if (ref $oldVal eq 'HASH' and ($param eq 'Compact' or $param eq 'XMPShorthand')) {
      66        
2109             # get previous Compact/XMPShorthand setting
2110 0         0 $oldVal = $$oldVal{$param};
2111             }
2112 20224 100       43498 last unless @_;
2113 4838         7476 my $newVal = shift;
2114 4838 100 66     39180 if ($param eq 'Lang') {
    100 100        
    100 66        
    100          
    100          
    100          
    100          
    100          
    100          
2115             # allow this to be set to undef to select the default language
2116 76 50       379 $newVal = $defaultLang unless defined $newVal;
2117 76 100       313 if ($newVal eq $defaultLang) {
2118 58         169 $$options{$param} = $newVal;
2119 58         204 delete $$self{CUR_LANG};
2120             # make sure the language is available
2121             } else {
2122 18         61 my %langs = map { $_ => 1 } @langs;
  324         647  
2123 18 50 33     1373 if ($langs{$newVal} and eval "require Image::ExifTool::Lang::$newVal") {
2124 18         116 my $xlat = "Image::ExifTool::Lang::${newVal}::Translate";
2125 105     105   1046 no strict 'refs';
  105         282  
  105         437710  
2126 18 50       135 if (%$xlat) {
2127 18         87 $$self{CUR_LANG} = \%$xlat;
2128 18         172 $$options{$param} = $newVal;
2129             }
2130             }
2131             } # else don't change Lang
2132             } elsif ($param eq 'Exclude' and defined $newVal) {
2133             # clone Exclude list and expand shortcuts
2134 7         21 my @exclude;
2135 7 100       40 if (ref $newVal eq 'ARRAY') {
2136 6         28 @exclude = @$newVal;
2137             } else {
2138 1         4 @exclude = ($newVal);
2139             }
2140 7         35 ExpandShortcuts(\@exclude, 1); # (also remove '#' suffix)
2141 7         37 $$options{$param} = \@exclude;
2142             } elsif ($param =~ /^Charset/ or $param eq 'IPTCCharset') {
2143             # only allow valid character sets to be set
2144 358 100 66     1554 if ($newVal) {
    50 33        
    0          
2145 241         681 my $charset = $charsetName{lc $newVal};
2146 241 50       527 if ($charset) {
2147 241         458 $$options{$param} = $charset;
2148             # maintain backward-compatibility with old IPTCCharset option
2149 241 100       752 $$options{CharsetIPTC} = $charset if $param eq 'IPTCCharset';
2150             } else {
2151 0         0 warn "Invalid Charset $newVal\n";
2152             }
2153             } elsif ($param eq 'CharsetEXIF' or $param eq 'CharsetFileName' or $param eq 'CharsetRIFF') {
2154 117         388 $$options{$param} = $newVal; # only these may be set to a false value
2155             } elsif ($param eq 'CharsetQuickTime') {
2156 0         0 $$options{$param} = 'MacRoman'; # QuickTime defaults to MacRoman
2157             } else {
2158 0         0 $$options{$param} = 'Latin'; # all others default to Latin
2159             }
2160             } elsif ($param eq 'UserParam') {
2161             # clear options if $newVal is undef
2162 58 50       289 defined $newVal or $$options{$param} = {}, next;
2163 58         248 my $table = GetTagTable('Image::ExifTool::UserParam');
2164             # allow initialization of entire UserParam hash
2165 58 50       352 if (ref $newVal eq 'HASH') {
2166 58         140 my %newParams;
2167 58         344 foreach (sort keys %$newVal) {
2168 0         0 my $lcTag = lc $_;
2169 0         0 $newParams{$lcTag} = $$newVal{$_};
2170 0         0 delete $$table{$lcTag};
2171 0         0 AddTagToTable($table, $lcTag, $_);
2172             }
2173 58         205 $$options{$param} = \%newParams;
2174 58         229 next;
2175             }
2176 0         0 my ($force, $paramName);
2177             # set/reset single UserParam parameter
2178 0 0       0 if ($newVal =~ /(.*?)=(.*)/s) {
2179 0         0 $paramName = $1;
2180 0         0 $newVal = $2;
2181 0 0       0 $force = 1 if $paramName =~ s/\^$//;
2182 0         0 $paramName =~ tr/-_a-zA-Z0-9#//dc;
2183 0         0 $param = lc $paramName;
2184             } else {
2185 0         0 ($param = lc $newVal) =~ tr/-_a-zA-Z0-9#//dc;
2186 0         0 undef $newVal;
2187             }
2188 0         0 delete $$table{$param};
2189 0         0 $oldVal = $$options{UserParam}{$param};
2190 0 0       0 if (defined $newVal) {
2191 0 0 0     0 if (length $newVal or $force) {
2192 0         0 $$options{UserParam}{$param} = $newVal;
2193 0         0 AddTagToTable($table, $param, $paramName);
2194             } else {
2195 0         0 delete $$options{UserParam}{$param};
2196             }
2197             }
2198             # remove alternate version of tag
2199 0 0       0 $param .= '#' unless $param =~ s/#$//;
2200 0         0 delete $$table{$param};
2201 0         0 delete $$options{UserParam}{$param};
2202             } elsif ($param eq 'RequestTags') {
2203 100 100       511 if (defined $newVal) {
2204             # parse list from delimited string if necessary
2205 42 50       363 my @reqList = (ref $newVal eq 'ARRAY') ? @$newVal : ($newVal =~ /[-\w?*:]+/g);
2206 42         198 ExpandShortcuts(\@reqList);
2207             # add to existing list
2208 42 50       346 $$options{$param} or $$options{$param} = [ ];
2209 42         166 foreach (@reqList) {
2210 56 50       425 /^(.*:)?([-\w?*]*)#?$/ or next;
2211 56 50       256 push @{$$options{$param}}, lc($2) if $2;
  56         261  
2212 56 50       319 next unless $1;
2213             # add requested groups with trailing colon
2214 0         0 push @{$$options{$param}}, lc($_).':' foreach split /:/, $1;
  0         0  
2215             }
2216             } else {
2217 58         205 $$options{$param} = undef; # clear the list
2218             }
2219             } elsif ($param eq 'IgnoreTags') {
2220 58 50       349 if (defined $newVal) {
2221             # parse list from delimited string if necessary
2222 0 0       0 my @ignoreList = (ref $newVal eq 'ARRAY') ? @$newVal : ($newVal =~ /[-\w?*:]+/g);
2223 0         0 ExpandShortcuts(\@ignoreList);
2224             # add to existing tags to ignore
2225 0 0       0 $$options{$param} or $$options{$param} = { };
2226 0         0 foreach (@ignoreList) {
2227 0 0       0 /^(.*:)?([-\w?*]+)#?$/ or next;
2228 0         0 $$options{$param}{lc $2} = 1;
2229             }
2230             } else {
2231 58         223 $$options{$param} = undef; # clear the option
2232             }
2233             } elsif ($param eq 'ListJoin') {
2234 10         43 $$options{$param} = $newVal;
2235             # set the old List and ListSep options for backward compatibility
2236 10 100       50 if (defined $newVal) {
2237 4         17 $$options{List} = 0;
2238 4         17 $$options{ListSep} = $newVal;
2239             } else {
2240 6         24 $$options{List} = 1;
2241             # (ListSep must be defined)
2242             }
2243             } elsif ($param eq 'List') {
2244 77         290 $$options{$param} = $newVal;
2245             # set the new ListJoin option for forward compatibility
2246 77 50       391 $$options{ListJoin} = $newVal ? undef : $$options{ListSep};
2247             } elsif ($param eq 'Compact' or $param eq 'XMPShorthand') {
2248             # set Compact and XMPShorthand options, preserving backward compatibility
2249 1         4 my ($p, %compact);
2250 1         4 foreach $p ('Compact','XMPShorthand') {
2251 2 100       21 my $val = $param eq $p ? $newVal : $$options{Compact}{$p};
2252 2 100       6 if (defined $val) {
2253 1         9 my @v = ($val =~ /\w+/g);
2254 1 50       5 my $opt = ($p eq 'Compact') ? \%compactOpt : \%xmpShorthandOpt;
2255 1         3 foreach (@v) {
2256 1 50       7 my $set = $$opt{lc $_} or warn("Invalid $p setting '${_}'\n"), return $oldVal;
2257 1 50       8 ref $set or $compact{$set} = 1, next;
2258 0         0 $compact{$_} = 1 foreach @$set;
2259             }
2260             }
2261 2         7 $compact{$p} = $val; # preserve most recent setting
2262             }
2263 1         6 $$options{Compact} = $$options{XMPShorthand} = \%compact;
2264             } else {
2265 4093 100 66     16721 if ($param eq 'Escape') {
    100 33        
    50          
    100          
2266             # set ESCAPE_PROC
2267 64 50 66     710 if (defined $newVal and $newVal eq 'XML') {
    100 66        
2268 0         0 require Image::ExifTool::XMP;
2269 0         0 $$self{ESCAPE_PROC} = \&Image::ExifTool::XMP::EscapeXML;
2270             } elsif (defined $newVal and $newVal eq 'HTML') {
2271 5         1771 require Image::ExifTool::HTML;
2272 5         26 $$self{ESCAPE_PROC} = \&Image::ExifTool::HTML::EscapeHTML;
2273             } else {
2274 59         169 delete $$self{ESCAPE_PROC};
2275             }
2276             # must forget saved values since they depend on Escape method
2277 64         261 $$self{BOTH} = { };
2278             } elsif ($param eq 'GlobalTimeShift') {
2279 59         204 delete $$self{GLOBAL_TIME_OFFSET}; # reset our calculated offset
2280             } elsif ($param eq 'TimeZone' and defined $newVal and length $newVal) {
2281 0         0 $ENV{TZ} = $newVal;
2282 0         0 eval { require POSIX; POSIX::tzset() };
  0         0  
  0         0  
2283             } elsif ($param eq 'Validate') {
2284             # load Validate module if Validate option enabled
2285 59 100       1087 $newVal and require Image::ExifTool::Validate;
2286             }
2287 4093         10706 $$options{$param} = $newVal;
2288             }
2289             }
2290 17518         54226 return $oldVal;
2291             }
2292              
2293             #------------------------------------------------------------------------------
2294             # ClearOptions - set options to default values
2295             # Inputs: 0) ExifTool object reference
2296             sub ClearOptions($)
2297             {
2298 475     475 1 1099 local $_;
2299 475         1168 my $self = shift;
2300              
2301             # create options hash with default values
2302             # +-----------------------------------------------------+
2303             # ! DON'T FORGET!! When adding any new option, must !
2304             # ! decide how it is handled in SetNewValuesFromFile() !
2305             # +-----------------------------------------------------+
2306             # (Note: All options must exist in this lookup, even if undefined,
2307             # to facilitate case-insensitive options. 'Group#' is handled specially)
2308             $$self{OPTIONS} = {
2309 475         41279 Binary => undef, # flag to extract binary values even if tag not specified
2310             ByteOrder => undef, # default byte order when creating EXIF information
2311             Charset => 'UTF8', # character set for converting Unicode characters
2312             CharsetEXIF => undef, # internal EXIF "ASCII" string encoding
2313             CharsetFileName => undef, # external encoding for file names
2314             CharsetID3 => 'Latin', # internal ID3v1 character set
2315             CharsetIPTC => 'Latin', # fallback IPTC character set if no CodedCharacterSet
2316             CharsetPhotoshop => 'Latin', # internal encoding for Photoshop resource names
2317             CharsetQuickTime => 'MacRoman', # internal QuickTime string encoding
2318             CharsetRIFF => 0, # internal RIFF string encoding (0=default to Latin)
2319             Compact => { }, # write compact XMP
2320             Composite => 1, # flag to calculate Composite tags
2321             Compress => undef, # flag to write new values as compressed if possible
2322             CoordFormat => undef, # GPS lat/long coordinate format
2323             DateFormat => undef, # format for date/time
2324             Duplicates => 1, # flag to save duplicate tag values
2325             Escape => undef, # escape special characters
2326             Exclude => undef, # tags to exclude
2327             ExtendedXMP => 1, # strategy for reading extended XMP
2328             ExtractEmbedded =>undef,# flag to extract information from embedded documents
2329             FastScan => undef, # flag to avoid scanning for trailer
2330             Filter => undef, # output filter for all tag values
2331             FilterW => undef, # input filter when writing tag values
2332             FixBase => undef, # fix maker notes base offsets
2333             GeoMaxIntSecs => 1800, # geotag maximum interpolation time (secs)
2334             GeoMaxExtSecs => 1800, # geotag maximum extrapolation time (secs)
2335             GeoMaxHDOP => undef, # geotag maximum HDOP
2336             GeoMaxPDOP => undef, # geotag maximum PDOP
2337             GeoMinSats => undef, # geotag minimum satellites
2338             GeoSpeedRef => undef, # geotag GPSSpeedRef
2339             GlobalTimeShift => undef, # apply time shift to all extracted date/time values
2340             # Group# => undef, # return tags for specified groups in family #
2341             HexTagIDs => 0, # use hex tag ID's in family 7 group names
2342             HtmlDump => 0, # HTML dump (0-3, higher # = bigger limit)
2343             HtmlDumpBase => undef, # base address for HTML dump
2344             IgnoreMinorErrors => undef, # ignore minor errors when reading/writing
2345             IgnoreTags => undef, # list of tags to ignore when extracting
2346             Lang => $defaultLang,# localized language for descriptions etc
2347             LargeFileSupport => undef, # flag indicating support of 64-bit file offsets
2348             List => undef, # extract lists of PrintConv values into arrays [no longer documented]
2349             ListItem => undef, # used to return a specific item from lists
2350             ListJoin => ', ', # join lists together with this separator
2351             ListSep => ', ', # list item separator [no longer documented]
2352             ListSplit => undef, # regex for splitting list-type tag values when writing
2353             MakerNotes => undef, # extract maker notes as a block
2354             MDItemTags => undef, # extract MacOS metadata item tags
2355             MissingTagValue =>undef,# value for missing tags when expanded in expressions
2356             NoMultiExif => undef, # raise error when writing multi-segment EXIF
2357             NoPDFList => undef, # flag to avoid splitting PDF List-type tag values
2358             Password => undef, # password for password-protected PDF documents
2359             PrintConv => 1, # flag to enable print conversion
2360             QuickTimeHandler => 1, # flag to add mdir Handler to newly created Meta box
2361             QuickTimePad=> undef, # flag to preserve padding of QuickTime CR3 tags
2362             QuickTimeUTC=> undef, # assume that QuickTime date/time tags are stored as UTC
2363             RequestAll => undef, # extract all tags that must be specifically requested
2364             RequestTags => undef, # extra tags to request (on top of those in the tag list)
2365             SaveFormat => undef, # save family 6 tag TIFF format
2366             SavePath => undef, # save family 5 location path
2367             ScanForXMP => undef, # flag to scan for XMP information in all files
2368             Sort => 'Input', # order to sort found tags (Input, File, Tag, Descr, Group#)
2369             Sort2 => 'File', # secondary sort order for tags in a group (File, Tag, Descr)
2370             StrictDate => undef, # flag to return undef for invalid date conversions
2371             Struct => undef, # return structures as hash references
2372             SystemTags => undef, # extract additional File System tags
2373             TextOut => \*STDOUT,# file for Verbose/HtmlDump output
2374             TimeZone => undef, # local time zone
2375             Unknown => 0, # flag to get values of unknown tags (0-2)
2376             UserParam => { }, # user parameters for additional user-defined tag values
2377             Validate => undef, # perform additional validation
2378             Verbose => 0, # print verbose messages (0-5, higher # = more verbose)
2379             WriteMode => 'wcg', # enable all write modes by default
2380             XAttrTags => undef, # extract MacOS extended attribute tags
2381             XMPAutoConv => 1, # automatic conversion of unknown XMP tag values
2382             XMPShorthand=> 0, # (unused, but needed for backward compatibility)
2383             };
2384             # keep necessary member variables in sync with options
2385 475         1833 delete $$self{CUR_LANG};
2386 475         1079 delete $$self{ESCAPE_PROC};
2387              
2388             # load user-defined default options
2389 475 50       2345 if (%Image::ExifTool::UserDefined::Options) {
2390 0         0 foreach (keys %Image::ExifTool::UserDefined::Options) {
2391 0         0 $self->Options($_, $Image::ExifTool::UserDefined::Options{$_});
2392             }
2393             }
2394             }
2395              
2396             #------------------------------------------------------------------------------
2397             # Extract meta information from image
2398             # Inputs: 0) ExifTool object reference
2399             # 1-N) Same as ImageInfo()
2400             # Returns: 1 if this was a valid image, 0 otherwise
2401             # Notes: pass an undefined value to avoid parsing arguments
2402             # Internal 'ReEntry' option allows this routine to be called recursively
2403             sub ExtractInfo($;@)
2404             {
2405 517     517 1 1600 local $_;
2406 517         1087 my $self = shift;
2407 517         1409 my $options = $$self{OPTIONS}; # pointer to current options
2408 517   100     2754 my $fast = $$options{FastScan} || 0;
2409 517         1354 my $req = $$self{REQ_TAG_LOOKUP};
2410 517   100     2550 my $reqAll = $$options{RequestAll} || 0;
2411 517         1578 my (%saveOptions, $reEntry, $rsize, $zid, $type, @startTime, $saveOrder, $isDir);
2412              
2413             # check for internal ReEntry option to allow recursive calls to ExtractInfo
2414 517 100 100     3082 if (ref $_[1] eq 'HASH' and $_[1]{ReEntry} and
      33        
      66        
2415             (ref $_[0] eq 'SCALAR' or ref $_[0] eq 'GLOB'))
2416             {
2417             # save necessary members for restoring later
2418             $reEntry = {
2419             RAF => $$self{RAF},
2420             PROCESSED => $$self{PROCESSED},
2421             EXIF_DATA => $$self{EXIF_DATA},
2422             EXIF_POS => $$self{EXIF_POS},
2423             FILE_TYPE => $$self{FILE_TYPE},
2424 2         19 };
2425             $saveOrder = GetByteOrder(),
2426 2         8 $$self{RAF} = new File::RandomAccess($_[0]);
2427 2         7 $$self{PROCESSED} = { };
2428 2         5 delete $$self{EXIF_DATA};
2429 2         4 delete $$self{EXIF_POS};
2430             } else {
2431 515 100 66     4714 if (defined $_[0] or $$options{HtmlDump} or $$req{validate}) {
      66        
2432 6         215 %saveOptions = %$options; # save original options
2433              
2434             # require duplicates for html dump
2435 6 50       69 $self->Options(Duplicates => 1) if $$options{HtmlDump};
2436             # enable Validate option if Validate tag is requested
2437 6 100       30 $self->Options(Validate => 1) if $$req{validate};
2438              
2439 6 100       21 if (defined $_[0]) {
2440             # only initialize filename if called with arguments
2441 5         14 $$self{FILENAME} = undef; # name of file (or '' if we didn't open it)
2442 5         14 $$self{RAF} = undef; # RandomAccess object reference
2443              
2444 5         24 $self->ParseArguments(@_); # initialize from our arguments
2445             }
2446             }
2447             # initialize ExifTool object members
2448 515         2633 $self->Init();
2449              
2450 515         1495 delete $$self{MAKER_NOTE_FIXUP}; # fixup information for extracted maker notes
2451 515         1266 delete $$self{MAKER_NOTE_BYTE_ORDER};
2452              
2453             # return our version number
2454 515         3627 $self->FoundTag('ExifToolVersion', "$VERSION$RELEASE");
2455 515 100 66     3807 $self->FoundTag('Now', $self->TimeNow()) if $$req{now} or $reqAll;
2456 515 100 66     3585 $self->FoundTag('NewGUID', NewGUID()) if $$req{newguid} or $reqAll;
2457             # generate sequence number if necessary
2458 515 100 66     3163 $self->FoundTag('FileSequence', $$self{FILE_SEQUENCE}) if $$req{filesequence} or $reqAll;
2459              
2460 515 100 66     3000 if ($$req{processingtime} or $reqAll) {
2461 58         204 eval { require Time::HiRes; @startTime = Time::HiRes::gettimeofday() };
  58         9912  
  58         23854  
2462 58 0 33     301 if (not @startTime and $$req{processingtime}) {
2463 0         0 $self->WarnOnce('Install Time::HiRes to generate ProcessingTime');
2464             }
2465             }
2466              
2467 515         1489 ++$$self{FILE_SEQUENCE}; # count files read
2468             }
2469              
2470 517         1526 my $filename = $$self{FILENAME}; # image file name ('' if already open)
2471 517         1232 my $raf = $$self{RAF}; # RandomAccess object
2472              
2473 517         1922 local *EXIFTOOL_FILE; # avoid clashes with global namespace
2474              
2475 517         1183 my $realname = $filename;
2476 517 100       1728 unless ($raf) {
2477             # save file name
2478 473 50 33     2857 if (defined $filename and $filename ne '') {
2479 473 50       1872 unless ($filename eq '-') {
2480             # extract file name from pipe if necessary
2481 473 50       2145 $realname =~ /\|$/ and $realname =~ s/^.*?"(.*?)".*/$1/s;
2482 473         2345 my ($dir, $name) = SplitFileName($realname);
2483 473         2106 $self->FoundTag('FileName', $name);
2484 473 100 66     4537 if ($$req{basename} or
      66        
2485             ($reqAll and not $$self{EXCL_TAG_LOOKUP}{basename}))
2486             {
2487 58 50       509 $self->FoundTag('BaseName', $name =~ /(.*)\./ ? $1 : $name);
2488             }
2489 473 50 33     4084 $self->FoundTag('Directory', $dir) if defined $dir and length $dir;
2490 473 100 66     4959 if ($$req{filepath} or
      66        
2491             ($reqAll and not $$self{EXCL_TAG_LOOKUP}{filepath}))
2492             {
2493 58         346 local $SIG{'__WARN__'} = \&SetWarning;
2494 58 50       175 if (eval { require Cwd }) {
  58 0       517  
2495 58         173 my $path = eval { Cwd::abs_path($filename) };
  58         2856  
2496 58 50       510 $self->FoundTag('FilePath', $path) if defined $path;
2497             } elsif ($$req{filepath}) {
2498 0         0 $self->WarnOnce('The Perl Cwd module must be installed to use FilePath');
2499             }
2500             }
2501             # get size of resource fork on Mac OS
2502 473 50 33     3211 $rsize = -s "$filename/..namedfork/rsrc" if $^O eq 'darwin' and not $$self{IN_RESOURCE};
2503             # check to see if Zone.Identifier file exists in Windows
2504 473 50 33     2269 if ($^O eq 'MSWin32' and eval { require Win32API::File }) {
  0         0  
2505 0         0 my $wattr;
2506 0         0 my $zfile = "${filename}:Zone.Identifier";
2507 0 0       0 if ($self->EncodeFileName($zfile)) {
2508 0         0 $wattr = eval { Win32API::File::GetFileAttributesW($zfile) };
  0         0  
2509             } else {
2510 0         0 $wattr = eval { Win32API::File::GetFileAttributes($zfile) };
  0         0  
2511             }
2512 0 0       0 $zid = 1 unless $wattr == Win32API::File::INVALID_FILE_ATTRIBUTES();
2513             }
2514             }
2515             # open the file
2516 473 50       2723 if ($self->Open(\*EXIFTOOL_FILE, $filename)) {
    0          
2517             # create random access file object
2518 473         5959 $raf = new File::RandomAccess(\*EXIFTOOL_FILE);
2519             # patch to force pipe to be buffered because seek returns success
2520             # in Windows cmd shell pipe even though it really failed
2521 473 50 33     4159 $$raf{TESTED} = -1 if $filename eq '-' or $filename =~ /\|$/;
2522 473         1641 $$self{RAF} = $raf;
2523             } elsif ($self->IsDirectory($filename)) {
2524 0         0 $isDir = 1;
2525             } else {
2526 0         0 $self->Error('Error opening file');
2527             }
2528             } else {
2529 0         0 $self->Error('No file specified');
2530             }
2531             }
2532              
2533 517   33     2533 while ($raf or $isDir) {
2534 517         1400 my (@stat, $plainFile);
2535 517 100       8667 if ($reEntry) {
    50          
    100          
    50          
2536             # we already set these tags
2537             } elsif (not $raf) {
2538 0         0 @stat = stat $filename;
2539             } elsif (not $$raf{FILE_PT}) {
2540             # get file size from image in memory
2541 22         74 $self->FoundTag('FileSize', length ${$$raf{BUFF_PT}});
  22         110  
2542             } elsif (-f $$raf{FILE_PT}) {
2543             # get file tags if this is a plain file
2544 493         2939 @stat = stat _;
2545 493         1372 $plainFile = 1;
2546             # hack to patch Windows daylight savings time bug
2547 493 50       2424 @stat[8,9,10] = $self->GetFileTime($$raf{FILE_PT}) if $^O eq 'MSWin32';
2548             } else {
2549             # (note that Windows directories will still show the
2550             # daylight savings time bug -- should fix this sometime)
2551 0         0 @stat = stat $$raf{FILE_PT};
2552             }
2553 517         1348 my $fileSize = $stat[7];
2554 517 100       3286 $self->FoundTag('FileSize', $stat[7]) if defined $stat[7];
2555 517 50       2554 $self->FoundTag('ResourceForkSize', $rsize) if $rsize;
2556 517 50       1854 $self->FoundTag('ZoneIdentifier', 'Exists') if $zid;
2557 517 100       2941 $self->FoundTag('FileModifyDate', $stat[9]) if defined $stat[9];
2558 517 100       3492 $self->FoundTag('FileAccessDate', $stat[8]) if defined $stat[8];
2559 517 50       3198 my $cTag = $^O eq 'MSWin32' ? 'FileCreateDate' : 'FileInodeChangeDate';
2560 517 100       3082 $self->FoundTag($cTag, $stat[10]) if defined $stat[10];
2561 517 100       3669 $self->FoundTag('FilePermissions', $stat[2]) if defined $stat[2];
2562             # extract more system info if SystemTags option is set
2563 517 100       2542 if (@stat) {
2564 493   66     3735 my $sys = $$options{SystemTags} || ($reqAll and not defined $$options{SystemTags});
2565 493 100 66     3096 if ($sys or $$req{fileattributes}) {
2566 58         299 my @attr = ($stat[2] & 0xf000, $stat[2] & 0x0e00);
2567             # add Windows file attributes if available
2568 58 0 33     350 if ($^O eq 'MSWin32' and defined $filename and $filename ne '' and $filename ne '-') {
      33        
      0        
2569 0         0 local $SIG{'__WARN__'} = \&SetWarning;
2570 0 0       0 if (eval { require Win32API::File }) {
  0         0  
2571 0         0 my $wattr;
2572 0         0 my $file = $filename;
2573 0 0       0 if ($self->EncodeFileName($file)) {
2574 0         0 $wattr = eval { Win32API::File::GetFileAttributesW($file) };
  0         0  
2575             } else {
2576 0         0 $wattr = eval { Win32API::File::GetFileAttributes($file) };
  0         0  
2577             }
2578 0 0 0     0 push @attr, $wattr if defined $wattr and $wattr != 0xffffffff;
2579             }
2580             }
2581 58         434 $self->FoundTag('FileAttributes', "@attr");
2582             }
2583 493 100 66     3206 $self->FoundTag('FileDeviceNumber', $stat[0]) if $sys or $$req{filedevicenumber};
2584 493 100 66     3035 $self->FoundTag('FileInodeNumber', $stat[1]) if $sys or $$req{fileinodenumber};
2585 493 100 66     3157 $self->FoundTag('FileHardLinks', $stat[3]) if $sys or $$req{filehardlinks};
2586 493 100 66     3167 $self->FoundTag('FileUserID', $stat[4]) if $sys or $$req{fileuserid};
2587 493 100 66     3610 $self->FoundTag('FileGroupID', $stat[5]) if $sys or $$req{filegroupid};
2588 493 100 66     2996 $self->FoundTag('FileDeviceID', $stat[6]) if $sys or $$req{filedeviceid};
2589 493 100 66     2941 $self->FoundTag('FileBlockSize', $stat[11]) if $sys or $$req{fileblocksize};
2590 493 100 66     3809 $self->FoundTag('FileBlockCount', $stat[12]) if $sys or $$req{fileblockcount};
2591             }
2592             # extract MDItem tags if requested (only on plain files)
2593 517 0 33     2637 if ($^O eq 'darwin' and defined $filename and $filename ne '' and defined $fileSize) {
      33        
      0        
2594 0   0     0 my $reqMacOS = ($reqAll > 1 or $$req{'macos:'});
2595 0   0     0 my $crDate = ($reqMacOS || $$req{filecreatedate});
2596 0   0     0 my $mdItem = ($reqMacOS || $$options{MDItemTags} || grep /^mditem/, keys %$req);
2597 0   0     0 my $xattr = ($reqMacOS || $$options{XAttrTags} || grep /^xattr/, keys %$req);
2598 0 0 0     0 if ($crDate or $mdItem or $xattr) {
      0        
2599 0         0 require Image::ExifTool::MacOS;
2600 0 0       0 Image::ExifTool::MacOS::GetFileCreateDate($self, $filename) if $crDate;
2601 0 0 0     0 Image::ExifTool::MacOS::ExtractMDItemTags($self, $filename) if $mdItem and $plainFile;
2602 0 0       0 Image::ExifTool::MacOS::ExtractXAttrTags($self, $filename) if $xattr;
2603             }
2604             }
2605             # do whatever else we can with directories, then return
2606 517 50 66     5135 if ($isDir or (defined $stat[2] and ($stat[2] & 0170000) == 0040000)) {
      33        
2607 0         0 $self->FoundTag('FileType', 'DIR');
2608 0         0 $self->FoundTag('FileTypeExtension', '');
2609 0 0       0 $self->BuildCompositeTags() if $$options{Composite};
2610 0 0       0 $raf->Close() if $raf;
2611 0         0 return 1;
2612             }
2613             # get list of file types to check
2614 517         2217 my ($tiffType, %noMagic, $recognizedExt);
2615 517         2087 my $ext = $$self{FILE_EXT} = GetFileExtension($realname);
2616             # set $recognizedExt if this file type is recognized by extension only
2617             $recognizedExt = $ext if defined $ext and not defined $magicNumber{$ext} and
2618 517 50 100     5067 defined $moduleName{$ext} and not $moduleName{$ext};
      100        
      66        
2619 517         2397 my @fileTypeList = GetFileType($realname);
2620 517 50       2071 if ($fast >= 4) {
2621 0 0       0 if (@fileTypeList) {
2622 0         0 $type = shift @fileTypeList;
2623 0         0 $self->SetFileType($$self{FILE_TYPE} = $type);
2624             } else {
2625 0         0 $self->Error('Unknown file type');
2626             }
2627 0 0 0     0 $self->BuildCompositeTags() if $fast == 4 and $$options{Composite};
2628 0         0 last; # don't read the file
2629             }
2630 517 100       1861 if (@fileTypeList) {
2631             # add remaining types to end of list so we test them all
2632 470         1820 my $pat = join '|', @fileTypeList;
2633 470         42227 push @fileTypeList, grep(!/^($pat)$/, @fileTypes);
2634 470         2040 $tiffType = $$self{FILE_EXT};
2635 470 100       2893 unless ($fast == 3) {
2636 469         2474 $noMagic{MXF} = 1; # don't do magic number test on MXF or DV files
2637 469         1536 $noMagic{DV} = 1;
2638             }
2639             } else {
2640             # scan through all recognized file types
2641 47         887 @fileTypeList = @fileTypes;
2642 47         137 $tiffType = 'TIFF';
2643             }
2644 517         1773 push @fileTypeList, ''; # end of list marker
2645             # initialize the input file for seeking in binary data
2646 517         3124 $raf->BinMode(); # set binary mode before we start reading
2647 517         2095 my $pos = $raf->Tell(); # get file position so we can rewind
2648             # loop through list of file types to test
2649 517         1589 my ($buff, $seekErr);
2650 517         3015 my %dirInfo = ( RAF => $raf, Base => $pos, TestBuff => \$buff );
2651             # read start of file for testing
2652 517 50       2492 $raf->Read($buff, $testLen) or $buff = '';
2653 517 50       3015 $raf->Seek($pos, 0) or $seekErr = 1;
2654 517         2881 until ($seekErr) {
2655 1912         3436 my $unkHeader;
2656 1912         3592 $type = shift @fileTypeList;
2657 1912 50       4131 if ($type) {
    0          
    0          
2658 1912 100       5293 if ($magicNumber{$type}) {
2659             # do quick test for this file type to avoid loading module unnecessarily
2660 1876 100 100     38433 next if $buff !~ /^$magicNumber{$type}/s and not $noMagic{$type};
2661             } else {
2662             # keep checking for other types if we recognize this file only by extension
2663 36 50 66     218 next if defined $moduleName{$type} and not $moduleName{$type};
2664 36 50       119 next if $fast > 2; # keep checking if we aren't processing the file
2665             }
2666 557 50 66     3365 next if $weakMagic{$type} and defined $recognizedExt;
2667             } elsif (not defined $type) {
2668 0         0 last;
2669             } elsif ($recognizedExt) {
2670 0         0 $type = $recognizedExt; # set type from recognized file extension only
2671             } else {
2672             # last ditch effort to scan past unknown header for JPEG/TIFF
2673 0 0       0 next unless $buff =~ /(\xff\xd8\xff|MM\0\x2a|II\x2a\0)/g;
2674 0 0       0 $type = ($1 eq "\xff\xd8\xff") ? 'JPEG' : 'TIFF';
2675 0         0 my $skip = pos($buff) - length($1);
2676 0         0 $dirInfo{Base} = $pos + $skip;
2677 0 0       0 $raf->Seek($pos + $skip, 0) or $seekErr = 1, last;
2678 0         0 $self->Warn("Processing $type-like data after unknown $skip-byte header");
2679 0 0       0 $unkHeader = 1 unless $$self{DOC_NUM};
2680             }
2681             # save file type in member variable
2682 557         1738 $$self{FILE_TYPE} = $type;
2683 557 100       2699 $dirInfo{Parent} = ($type eq 'TIFF') ? $tiffType : $type;
2684             # don't process the file when FastScan == 3
2685 557 50 66     2525 if ($fast == 3 and not $processType{$type}) {
2686 0 0 0     0 unless ($weakMagic{$type} and (not $ext or $ext ne $type)) {
      0        
2687 0         0 $self->SetFileType($dirInfo{Parent});
2688             }
2689 0         0 last;
2690             }
2691 557         1460 my $module = $moduleName{$type};
2692 557 100       1890 $module = $type unless defined $module;
2693 557         1878 my $func = "Process$type";
2694              
2695             # load module if necessary
2696 557 100       2172 if ($module) {
    50          
2697 305         23653 require "Image/ExifTool/$module.pm";
2698 305         1371 $func = "Image::ExifTool::${module}::$func";
2699             } elsif ($module eq '0') {
2700 0         0 $self->SetFileType();
2701 0         0 $self->Warn('Unsupported file type');
2702 0         0 last;
2703             }
2704 557         1204 push @{$$self{PATH}}, $type; # save file type in metadata PATH
  557         2146  
2705              
2706             # process the file
2707 105     105   2634 no strict 'refs';
  105         279  
  105         5897  
2708 557         4755 my $result = &$func($self, \%dirInfo);
2709 105     105   736 use strict 'refs';
  105         248  
  105         1542276  
2710              
2711 557         1387 pop @{$$self{PATH}};
  557         1943  
2712              
2713 557 100       2054 if ($result) { # all done if successful
2714 517 50       1824 if ($unkHeader) {
2715 0         0 $self->DeleteTag('FileType');
2716 0         0 $self->DeleteTag('FileTypeExtension');
2717 0         0 $self->DeleteTag('MIMEType');
2718 0         0 $self->VPrint(0,"Reset file type due to unknown header\n");
2719             }
2720 517         1472 last;
2721             }
2722             # seek back to try again from the same position in the file
2723 40 50       116 $raf->Seek($pos, 0) or $seekErr = 1, last;
2724             }
2725 517 0 33     2040 if (not defined $type and not $$self{DOC_NUM}) {
2726             # if we were given a single image with a known type there
2727             # must be a format error since we couldn't read it, otherwise
2728             # it is likely we don't support images of this type
2729 0   0     0 my $fileType = GetFileType($realname) || '';
2730 0         0 my $err;
2731 0 0       0 if (not length $buff) {
2732 0         0 $err = 'File is empty';
2733             } else {
2734 0         0 my $ch = substr($buff, 0, 1);
2735 0 0 0     0 if (length $buff < 16 or $buff =~ /[^\Q$ch\E]/) {
2736 0 0       0 if ($fileType eq 'RAW') {
    0          
2737 0         0 $err = 'Unsupported RAW file type';
2738             } elsif ($fileType) {
2739 0         0 $err = 'File format error';
2740             } else {
2741 0         0 $err = 'Unknown file type';
2742             }
2743             } else {
2744             # provide some insight into the content of some corrupted files
2745 0 0       0 if ($$self{OPTIONS}{FastScan}) {
2746 0         0 $err = 'File header is all';
2747             } else {
2748 0         0 my $num = 0;
2749 0         0 for (;;) {
2750 0 0       0 $raf->Read($buff, 65536) or undef($num), last;
2751 0 0       0 $buff =~ /[^\Q$ch\E]/g and $num += pos($buff) - 1, last;
2752 0         0 $num += length($buff);
2753             }
2754 0 0       0 if ($num) {
2755 0         0 $err = 'First ' . ConvertFileSize($num) . ' of file is';
2756             } else {
2757 0         0 $err = 'Entire file is';
2758             }
2759             }
2760 0 0       0 if ($ch eq "\0") {
    0          
    0          
2761 0         0 $err .= ' binary zeros';
2762             } elsif ($ch eq ' ') {
2763 0         0 $err .= ' ASCII spaces';
2764             } elsif ($ch =~ /[a-zA-Z0-9]/) {
2765 0         0 $err .= " ASCII '${ch}' characters";
2766             } else {
2767 0         0 $err .= sprintf(" binary 0x%.2x's", ord $ch);
2768             }
2769             }
2770             }
2771 0         0 $self->Error($err);
2772             }
2773 517 50 0     2706 if ($seekErr) {
    50 33        
2774 0         0 $self->Error('Error seeking in file');
2775             } elsif ($self->Options('ScanForXMP') and (not defined $type or
2776             (not $fast and not $$self{FoundXMP})))
2777             {
2778             # scan for XMP
2779 0         0 $raf->Seek($pos, 0);
2780 0         0 require Image::ExifTool::XMP;
2781 0 0       0 Image::ExifTool::XMP::ScanForXMP($self, $raf) and $type = '';
2782             }
2783             # extract binary EXIF data block only if requested
2784 517 100 100     5030 if (defined $$self{EXIF_DATA} and length $$self{EXIF_DATA} > 16 and
      100        
      100        
2785             ($$req{exif} or
2786             # (not extracted normally, so check TAGS_FROM_FILE)
2787             ($$self{TAGS_FROM_FILE} and not $$self{EXCL_TAG_LOOKUP}{exif})))
2788             {
2789 36         168 $self->FoundTag('EXIF', $$self{EXIF_DATA});
2790             }
2791 517 100       2002 unless ($reEntry) {
2792 515         1898 $$self{PATH} = [ ]; # reset PATH
2793             # calculate Composite tags
2794 515 100       3742 $self->BuildCompositeTags() if $$options{Composite};
2795             # do our HTML dump if requested
2796 515 50       2540 if ($$self{HTML_DUMP}) {
2797 0         0 $raf->Seek(0, 2); # seek to end of file
2798 0         0 $$self{HTML_DUMP}->FinishTiffDump($self, $raf->Tell());
2799 0         0 my $pos = $$options{HtmlDumpBase};
2800 0 0 0     0 $pos = ($$self{FIRST_EXIF_POS} || 0) unless defined $pos;
2801 0 0       0 my $dataPt = defined $$self{EXIF_DATA} ? \$$self{EXIF_DATA} : undef;
2802 0 0 0     0 undef $dataPt if defined $$self{EXIF_POS} and $pos != $$self{EXIF_POS};
2803 0 0       0 undef $dataPt if $$self{ExtendedEXIF}; # can't use EXIF block if not contiguous
2804             my $success = $$self{HTML_DUMP}->Print($raf, $dataPt, $pos,
2805             $$options{TextOut}, $$options{HtmlDump},
2806 0 0       0 $$self{FILENAME} ? "HTML Dump ($$self{FILENAME})" : 'HTML Dump');
2807 0 0       0 $self->Warn("Error reading $$self{HTML_DUMP}{ERROR}") if $success < 0;
2808             }
2809             }
2810 517 100       2033 if ($filename) {
2811 475         3288 $raf->Close(); # close the file if we opened it
2812             # process the resource fork as an embedded file on Mac filesystems
2813 475 0 33     1937 if ($rsize and $$options{ExtractEmbedded}) {
2814 0         0 local *RESOURCE_FILE;
2815 0 0       0 if ($self->Open(\*RESOURCE_FILE, "$filename/..namedfork/rsrc")) {
2816 0         0 $$self{DOC_NUM} = $$self{DOC_COUNT} + 1;
2817 0         0 $$self{IN_RESOURCE} = 1;
2818 0         0 $self->ExtractInfo(\*RESOURCE_FILE, { ReEntry => 1 });
2819 0         0 close RESOURCE_FILE;
2820 0         0 delete $$self{IN_RESOURCE};
2821             } else {
2822 0         0 $self->Warn('Error opening resource fork');
2823             }
2824             }
2825             }
2826 517         9438 last; # (loop was a cheap "goto")
2827             }
2828              
2829             # generate Validate tag if requested
2830 517 100 66     2590 if ($$options{Validate} and not $reEntry) {
2831 1         10 Image::ExifTool::Validate::FinishValidate($self, $$req{validate});
2832             }
2833              
2834 517 100       2235 @startTime and $self->FoundTag('ProcessingTime', Time::HiRes::tv_interval(\@startTime));
2835              
2836             # add user-defined parameters that ended with '!'
2837 517 50       1328 if (%{$$options{UserParam}}) {
  517         2355  
2838 0         0 my $doMsg = $$options{Verbose};
2839 0         0 my $table = GetTagTable('Image::ExifTool::UserParam');
2840 0         0 foreach (sort keys %{$$options{UserParam}}) {
  0         0  
2841 0 0       0 next unless /#$/;
2842 0 0       0 if ($doMsg) {
2843 0         0 $self->VPrint(0, "UserParam tags:\n");
2844 0         0 undef $doMsg;
2845             }
2846 0         0 $self->HandleTag($table, $_, $$options{UserParam}{$_});
2847             }
2848             }
2849              
2850             # restore original options
2851 517 100       2690 %saveOptions and $$self{OPTIONS} = \%saveOptions;
2852              
2853 517 100       1738 if ($reEntry) {
2854             # restore necessary members when exiting re-entrant code
2855 2         20 $$self{$_} = $$reEntry{$_} foreach keys %$reEntry;
2856 2         10 SetByteOrder($saveOrder);
2857             }
2858              
2859             # ($type may be undef without an Error when processing sub-documents)
2860 517 50 33     3833 return 0 if not defined $type or exists $$self{VALUE}{Error};
2861 517         3034 return 1;
2862             }
2863              
2864             #------------------------------------------------------------------------------
2865             # Get hash of extracted meta information
2866             # Inputs: 0) ExifTool object reference
2867             # 1-N) options hash reference, tag list reference or tag names
2868             # Returns: Reference to information hash
2869             # Notes: - pass an undefined value to avoid parsing arguments
2870             # - If groups are specified, first groups take precedence if duplicate
2871             # tags found but Duplicates option not set.
2872             # - tag names may end in '#' to extract ValueConv value
2873             sub GetInfo($;@)
2874             {
2875 690     690 1 4650 local $_;
2876 690         1587 my $self = shift;
2877 690         1381 my %saveOptions;
2878              
2879 690 100 66     4232 unless (@_ and not defined $_[0]) {
2880 180         447 %saveOptions = %{$$self{OPTIONS}}; # save original options
  180         12132  
2881             # must set FILENAME so it isn't parsed from the arguments
2882 180 100       1798 $$self{FILENAME} = '' unless defined $$self{FILENAME};
2883 180         1097 $self->ParseArguments(@_);
2884             }
2885              
2886             # get reference to list of tags for which we will return info
2887 690         3537 my ($rtnTags, $byValue, $wildTags) = $self->SetFoundTags();
2888              
2889             # build hash of tag information
2890 690         1615 my (%info, %ignored);
2891 690 100       2704 my $conv = $$self{OPTIONS}{PrintConv} ? 'PrintConv' : 'ValueConv';
2892 690         2126 foreach (@$rtnTags) {
2893 35139         69196 my $val = $self->GetValue($_, $conv);
2894 35139 100       69450 defined $val or $ignored{$_} = 1, next;
2895 34180         83323 $info{$_} = $val;
2896             }
2897              
2898             # override specified tags with ValueConv value if necessary
2899 690 100       3390 if (@$byValue) {
2900             # first determine the number of times each non-ValueConv value is used
2901 4         9 my %nonVal;
2902 4   100     88 $nonVal{$_} = ($nonVal{$_} || 0) + 1 foreach @$rtnTags;
2903 4         27 --$nonVal{$$rtnTags[$_]} foreach @$byValue;
2904             # loop through ValueConv tags, updating tag keys and returned values
2905 4         12 foreach (@$byValue) {
2906 25         39 my $tag = $$rtnTags[$_];
2907 25         51 my $val = $self->GetValue($tag, 'ValueConv');
2908 25 100       57 next unless defined $val;
2909 16         30 my $vtag = $tag;
2910             # generate a new tag key like "Tag #" or "Tag #(1)"
2911 16         101 $vtag =~ s/( |$)/ #/;
2912 16 50       46 unless (defined $$self{VALUE}{$vtag}) {
2913 16         70 $$self{VALUE}{$vtag} = $$self{VALUE}{$tag};
2914 16         35 $$self{TAG_INFO}{$vtag} = $$self{TAG_INFO}{$tag};
2915 16         37 $$self{TAG_EXTRA}{$vtag} = $$self{TAG_EXTRA}{$tag};
2916 16         31 $$self{FILE_ORDER}{$vtag} = $$self{FILE_ORDER}{$tag};
2917             # remove existing PrintConv entry unless we are using it too
2918 16 100       51 delete $info{$tag} unless $nonVal{$tag};
2919             }
2920 16         31 $$rtnTags[$_] = $vtag; # store ValueConv value with new tag key
2921 16         47 $info{$vtag} = $val; # return ValueConv value
2922             }
2923             }
2924              
2925             # remove ignored tags from the list
2926 690   50     2938 my $reqTags = $$self{REQUESTED_TAGS} || [ ];
2927 690 100       2230 if (%ignored) {
2928 408 100       1952 if (not @$reqTags) {
    100          
2929 192         407 my @goodTags;
2930 192         661 foreach (@$rtnTags) {
2931 22555 100       44935 push @goodTags, $_ unless $ignored{$_};
2932             }
2933 192         1790 $rtnTags = $$self{FOUND_TAGS} = \@goodTags;
2934             } elsif (@$wildTags) {
2935             # only remove tags specified by wildcard
2936 41         78 my @goodTags;
2937 41         62 my $i = 0;
2938 41         99 foreach (@$rtnTags) {
2939 356 100 100     901 if (@$wildTags and $i == $$wildTags[0]) {
2940 197         270 shift @$wildTags;
2941 197 50       450 push @goodTags, $_ unless $ignored{$_};
2942             } else {
2943 159         268 push @goodTags, $_;
2944             }
2945 356         568 ++$i;
2946             }
2947 41         216 $rtnTags = $$self{FOUND_TAGS} = \@goodTags;
2948             }
2949             }
2950              
2951             # return sorted tag list if provided with a list reference
2952 690 100       2874 if ($$self{IO_TAG_LIST}) {
2953             # use file order by default if no tags specified
2954             # (no such thing as 'Input' order in this case)
2955 4         12 my $sort = $$self{OPTIONS}{Sort};
2956 4 50 33     30 $sort = 'File' unless @$reqTags or ($sort and $sort ne 'Input');
      66        
2957             # return tags in specified sort order
2958 4         25 @{$$self{IO_TAG_LIST}} = $self->GetTagList($rtnTags, $sort, $$self{OPTIONS}{Sort2});
  4         26  
2959             }
2960              
2961             # restore original options
2962 690 100       3902 %saveOptions and $$self{OPTIONS} = \%saveOptions;
2963              
2964 690         3589 return \%info;
2965             }
2966              
2967             #------------------------------------------------------------------------------
2968             # Inputs: 0) ExifTool object reference
2969             # 1) [optional] reference to info hash or tag list ref (default is found tags)
2970             # 2) [optional] sort order ('File', 'Input', ...)
2971             # 3) [optional] secondary sort order
2972             # Returns: List of tags in specified order
2973             sub GetTagList($;$$$)
2974             {
2975 429     429 1 79572 local $_;
2976 429         1807 my ($self, $info, $sort, $sort2) = @_;
2977              
2978 429         993 my $foundTags;
2979 429 100       2071 if (ref $info eq 'HASH') {
    50          
2980 424         6144 my @tags = keys %$info;
2981 424         1497 $foundTags = \@tags;
2982             } elsif (ref $info eq 'ARRAY') {
2983 5         13 $foundTags = $info;
2984             }
2985 429         1352 my $fileOrder = $$self{FILE_ORDER};
2986              
2987 429 50       1481 if ($foundTags) {
2988             # make sure a FILE_ORDER entry exists for all tags
2989             # (note: already generated bogus entries for FOUND_TAGS case below)
2990 429         1457 foreach (@$foundTags) {
2991 23977 50       46108 next if defined $$fileOrder{$_};
2992 0         0 $$fileOrder{$_} = 999;
2993             }
2994             } else {
2995 0 0 0     0 $sort = $info if $info and not $sort;
2996 0 0 0     0 $foundTags = $$self{FOUND_TAGS} || $self->SetFoundTags() or return undef;
2997             }
2998 429 100       1939 $sort or $sort = $$self{OPTIONS}{Sort};
2999              
3000             # return original list if no sort order specified
3001 429 100 66     3531 return @$foundTags unless $sort and $sort ne 'Input';
3002              
3003 411 50 33     5180 if ($sort eq 'Tag' or $sort eq 'Alpha') {
    100          
    50          
3004 0         0 return sort @$foundTags;
3005             } elsif ($sort =~ /^Group(\d*(:\d+)*)/) {
3006 409   50     2639 my $family = $1 || 0;
3007             # want to maintain a basic file order with the groups
3008             # ordered in the way they appear in the file
3009 409         1033 my (%groupCount, %groupOrder);
3010 409         866 my $numGroups = 0;
3011 409         806 my $tag;
3012 409         2667 foreach $tag (sort { $$fileOrder{$a} <=> $$fileOrder{$b} } @$foundTags) {
  130261         175621  
3013 23269         40908 my $group = $self->GetGroup($tag, $family);
3014 23269         38811 my $num = $groupCount{$group};
3015 23269 100       40069 $num or $num = $groupCount{$group} = ++$numGroups;
3016 23269         44796 $groupOrder{$tag} = $num;
3017             }
3018 409 50       3353 $sort2 or $sort2 = $$self{OPTIONS}{Sort2};
3019 409 50       1647 if ($sort2) {
3020 409 50 33     3435 if ($sort2 eq 'Tag' or $sort2 eq 'Alpha') {
    50          
3021 0 0       0 return sort { $groupOrder{$a} <=> $groupOrder{$b} or $a cmp $b } @$foundTags;
  0         0  
3022             } elsif ($sort2 eq 'Descr') {
3023 0         0 my $desc = $self->GetDescriptions($foundTags);
3024 0         0 return sort { $groupOrder{$a} <=> $groupOrder{$b} or
3025 0 0       0 $$desc{$a} cmp $$desc{$b} } @$foundTags;
3026             }
3027             }
3028 409         2159 return sort { $groupOrder{$a} <=> $groupOrder{$b} or
3029 130269 50       233800 $$fileOrder{$a} <=> $$fileOrder{$b} } @$foundTags;
3030             } elsif ($sort eq 'Descr') {
3031 0         0 my $desc = $self->GetDescriptions($foundTags);
3032 0         0 return sort { $$desc{$a} cmp $$desc{$b} } @$foundTags;
  0         0  
3033             } else {
3034 2         15 return sort { $$fileOrder{$a} <=> $$fileOrder{$b} } @$foundTags;
  3697         4930  
3035             }
3036             }
3037              
3038             #------------------------------------------------------------------------------
3039             # Get list of found tags in specified sort order
3040             # Inputs: 0) ExifTool object reference, 1) sort order ('File', 'Input', ...)
3041             # 2) secondary sort order
3042             # Returns: List of tag keys in specified order
3043             # Notes: If not specified, sort order is taken from OPTIONS
3044             sub GetFoundTags($;$$)
3045             {
3046 1     1 1 160 local $_;
3047 1         4 my ($self, $sort, $sort2) = @_;
3048 1 50 33     8 my $foundTags = $$self{FOUND_TAGS} || $self->SetFoundTags() or return undef;
3049 1         5 return $self->GetTagList($foundTags, $sort, $sort2);
3050             }
3051              
3052             #------------------------------------------------------------------------------
3053             # Get list of requested tags
3054             # Inputs: 0) ExifTool object reference
3055             # Returns: List of requested tag keys
3056             sub GetRequestedTags($)
3057             {
3058 2     2 1 5 local $_;
3059 2         6 return @{$_[0]{REQUESTED_TAGS}};
  2         12  
3060             }
3061              
3062             #------------------------------------------------------------------------------
3063             # Get tag value
3064             # Inputs: 0) ExifTool object reference
3065             # 1) tag key or tag name with optional group names (case sensitive)
3066             # (or flattened tagInfo for getting field values, not part of public API)
3067             # 2) [optional] Value type: PrintConv, ValueConv, Both, Raw or Rational, the default
3068             # is PrintConv or ValueConv, depending on the PrintConv option setting
3069             # 3) raw field value (not part of public API)
3070             # Returns: Scalar context: tag value or undefined
3071             # List context: list of values or empty list
3072             sub GetValue($$;$)
3073             {
3074 52905     52905 1 71977 local $_;
3075 52905         94322 my ($self, $tag, $type) = @_; # plus: ($fieldValue)
3076 52905         72555 my (@convTypes, $tagInfo, $valueConv, $both);
3077 52905         76305 my $rawValue = $$self{VALUE};
3078              
3079             # get specific tag key if tag has a group name
3080 52905 50       113338 if ($tag =~ /^(.*):(.+)/) {
3081 0         0 my ($gp, $tg) = ($1, $2);
3082 0         0 my ($i, $key, @keys);
3083             # build list of tag keys in the order of priority (no index
3084             # is top priority, otherwise higher index is higher priority)
3085 0   0     0 for ($key=$tg, $i=$$self{DUPL_TAG}{$tg} || 0; ; --$i) {
3086 0 0       0 push @keys, $key if defined $$rawValue{$key};
3087 0 0       0 last if $i <= 0;
3088 0         0 $key = "$tg ($i)";
3089             }
3090 0 0       0 if (@keys) {
3091 0         0 $key = $self->GroupMatches($gp, \@keys);
3092 0 0       0 $tag = $key if $key;
3093             }
3094             }
3095             # figure out what conversions to do
3096 52905 100       87487 if ($type) {
3097 52890 50       92360 return $$self{RATIONAL}{$tag} if $type eq 'Rational';
3098             } else {
3099 15 50       83 $type = $$self{OPTIONS}{PrintConv} ? 'PrintConv' : 'ValueConv';
3100             }
3101              
3102             # start with the raw value
3103 52905         99075 my $value = $$rawValue{$tag};
3104 52905 100       88872 if (not defined $value) {
3105 10093 100       28880 return () unless ref $tag;
3106             # get the value of a structure field
3107 194         279 $tagInfo = $tag;
3108 194         378 $tag = $$tagInfo{Name};
3109 194         304 $value = $_[3];
3110             # (note: type "Both" is not allowed for structure fields)
3111 194 50       367 if ($type ne 'Raw') {
3112 194         325 push @convTypes, 'ValueConv';
3113 194 100       424 push @convTypes, 'PrintConv' unless $type eq 'ValueConv';
3114             }
3115             } else {
3116 42812         80419 $tagInfo = $$self{TAG_INFO}{$tag};
3117 42812 100 66     102992 if ($$tagInfo{Struct} and ref $value) {
3118             # must load XMPStruct.pl just in case (should already be loaded if
3119             # a structure was extracted, but we could also arrive here if a simple
3120             # list of values was stored incorrectly in a Struct tag)
3121 53         1025 require 'Image/ExifTool/XMPStruct.pl';
3122             # convert strucure field values
3123 53 100       187 unless ($type eq 'Both') {
3124             # (note: ConvertStruct handles the filtering and escaping too if necessary)
3125 48         255 return Image::ExifTool::XMP::ConvertStruct($self,$tagInfo,$value,$type);
3126             }
3127 5         30 $valueConv = Image::ExifTool::XMP::ConvertStruct($self,$tagInfo,$value,'ValueConv');
3128 5         36 $value = Image::ExifTool::XMP::ConvertStruct($self,$tagInfo,$value,'PrintConv');
3129             # (must not save these in $$self{BOTH} because the values may have been escaped)
3130 5         47 return ($valueConv, $value);
3131             }
3132 42759 50       76628 if ($type ne 'Raw') {
3133             # use values we calculated already if we stored them
3134 42759         67707 $both = $$self{BOTH}{$tag};
3135 42759 100       68984 if ($both) {
3136 6438 100       14012 if ($type eq 'PrintConv') {
    100          
3137 2135         4689 $value = $$both[1];
3138             } elsif ($type eq 'ValueConv') {
3139 96         170 $value = $$both[0];
3140 96 100       195 $value = $$both[1] unless defined $value;
3141             } else {
3142 4207         8346 ($valueConv, $value) = @$both;
3143             }
3144             } else {
3145 36321         57949 push @convTypes, 'ValueConv';
3146 36321 100       74596 push @convTypes, 'PrintConv' unless $type eq 'ValueConv';
3147             }
3148             }
3149             }
3150              
3151             # do the conversions
3152 42953         62494 my (@val, @prt, @raw, $convType);
3153 42953         66407 foreach $convType (@convTypes) {
3154             # don't convert a scalar reference or structure
3155 70265 100 66     137349 last if ref $value eq 'SCALAR' and not $$tagInfo{ConvertBinary};
3156 69619         128218 my $conv = $$tagInfo{$convType};
3157 69619 100       118695 unless (defined $conv) {
3158 45448 100       73223 if ($convType eq 'ValueConv') {
3159 28885 100       66317 next unless $$tagInfo{Binary};
3160 400         904 $conv = '\$val'; # return scalar reference for binary values
3161             } else {
3162             # use PRINT_CONV from tag table if PrintConv doesn't exist
3163 16563 100       50331 next unless defined($conv = $$tagInfo{Table}{PRINT_CONV});
3164 201 100       576 next if exists $$tagInfo{$convType};
3165             }
3166             }
3167             # save old ValueConv value if we want Both
3168 24723 100 100     56048 $valueConv = $value if $type eq 'Both' and $convType eq 'PrintConv';
3169 24723         36749 my ($i, $val, $vals, @values, $convList);
3170             # split into list if conversion is an array
3171 24723 100       48216 if (ref $conv eq 'ARRAY') {
3172 124         343 $convList = $conv;
3173 124         417 $conv = $$convList[0];
3174 124 50       699 my @valList = (ref $value eq 'ARRAY') ? @$value : split ' ', $value;
3175             # reorganize list if specified (Note: The writer currently doesn't
3176             # relist values, so they may be grouped but the order must not change)
3177 124         327 my $relist = $$tagInfo{Relist};
3178 124 100       359 if ($relist) {
3179 7         21 my (@newList, $oldIndex);
3180 7         39 foreach $oldIndex (@$relist) {
3181 14         30 my ($newVal, @join);
3182 14 100       45 if (ref $oldIndex) {
3183 7         23 foreach (@$oldIndex) {
3184 16 50       59 push @join, $valList[$_] if defined $valList[$_];
3185             }
3186 7 50       46 $newVal = join(' ', @join) if @join;
3187             } else {
3188 7         19 $newVal = $valList[$oldIndex];
3189             }
3190 14 100       54 push @newList, $newVal if defined $newVal;
3191             }
3192 7         29 $value = \@newList;
3193             } else {
3194 117         304 $value = \@valList;
3195             }
3196 124 50       468 return () unless @$value;
3197             }
3198             # initialize array so we can iterate over values in list
3199 24723 100       43801 if (ref $value eq 'ARRAY') {
3200 155 100       514 if (defined $$tagInfo{RawJoin}) {
3201 7         1416 $val = join ' ', @$value;
3202             } else {
3203 148         297 $i = 0;
3204 148         278 $vals = $value;
3205 148         327 $val = $$vals[0];
3206             }
3207             } else {
3208 24568         36816 $val = $value;
3209             }
3210             # loop through all values in list
3211 24723         33079 for (;;) {
3212 24936 100       41378 if (defined $conv) {
3213             # get values of required tags if this is a Composite tag
3214 24917 100 66     56491 if (ref $val eq 'HASH' and not @val) {
3215             # disable escape of source values so we don't double escape them
3216 2906         5171 my $oldEscape = $$self{ESCAPE_PROC};
3217 2906         4834 delete $$self{ESCAPE_PROC};
3218             # temporarily delete filter so it isn't applied to the Require'd values
3219 2906         4682 my $oldFilter = $$self{OPTIONS}{Filter};
3220 2906         4808 delete $$self{OPTIONS}{Filter};
3221 2906         10175 foreach (keys %$val) {
3222 17017 50       33544 next unless defined $$val{$_};
3223 17017         40672 $raw[$_] = $$rawValue{$$val{$_}};
3224 17017         34721 ($val[$_], $prt[$_]) = $self->GetValue($$val{$_}, 'Both');
3225 17017 100 100     53689 next if defined $val[$_] or not $$tagInfo{Require}{$_};
3226 382 50       1135 $$self{OPTIONS}{Filter} = $oldFilter if defined $oldFilter;
3227 382         746 $$self{ESCAPE_PROC} = $oldEscape;
3228 382         1625 return ();
3229             }
3230 2524 100       7314 $$self{OPTIONS}{Filter} = $oldFilter if defined $oldFilter;
3231 2524         5117 $$self{ESCAPE_PROC} = $oldEscape;
3232             # set $val to $val[0], or \@val for a CODE ref conversion
3233 2524 50       6935 $val = ref $conv eq 'CODE' ? \@val : $val[0];
3234             }
3235 24535 100       42939 if (ref $conv eq 'HASH') {
3236             # look up converted value in hash
3237 7547 100       29834 if (not defined($value = $$conv{$val})) {
3238 440 100       1910 if ($$conv{BITMASK}) {
3239 124         829 $value = DecodeBits($val, $$conv{BITMASK}, $$tagInfo{BitsPerWord});
3240             } else {
3241             # use alternate conversion routine if available
3242 316 100       1132 if ($$conv{OTHER}) {
3243 245         1327 local $SIG{'__WARN__'} = \&SetWarning;
3244 245         733 undef $evalWarning;
3245 245         575 $value = &{$$conv{OTHER}}($val, undef, $conv);
  245         1221  
3246 245 50       1067 $self->Warn("$convType $tag: " . CleanWarning()) if $evalWarning;
3247             }
3248 316 100       1146 if (not defined $value) {
3249 71 50 66     385 if ($$tagInfo{PrintHex} and $val and IsInt($val) and
      66        
      33        
3250             $convType eq 'PrintConv')
3251             {
3252 0         0 $value = sprintf('Unknown (0x%x)',$val);
3253             } else {
3254 71         232 $value = "Unknown ($val)";
3255             }
3256             }
3257             }
3258             }
3259             # override with our localized language PrintConv if available
3260 7547         11043 my $tmp;
3261 7547 100 66     18669 if ($$self{CUR_LANG} and $convType eq 'PrintConv' and
      100        
      66        
3262             # (no need to check for lang-alt tag names -- they won't have a PrintConv)
3263             ref($tmp = $$self{CUR_LANG}{$$tagInfo{Name}}) eq 'HASH' and
3264             ($tmp = $$tmp{PrintConv}))
3265             {
3266 244 50 33     920 if ($$conv{BITMASK} and not defined $$conv{$val}) {
    100          
3267 0         0 my @vals = split ', ', $value;
3268 0         0 foreach (@vals) {
3269 0 0       0 $_ = $$tmp{$_} if defined $$tmp{$_};
3270             }
3271 0         0 $value = join ', ', @vals;
3272             } elsif (defined($tmp = $$tmp{$value})) {
3273 200         442 $value = $self->Decode($tmp, 'UTF8');
3274             }
3275             }
3276             } else {
3277             # call subroutine or do eval to convert value
3278 16988         67696 local $SIG{'__WARN__'} = \&SetWarning;
3279 16988         29807 undef $evalWarning;
3280 16988 100       30325 if (ref $conv eq 'CODE') {
3281 835         4080 $value = &$conv($val, $self);
3282             } else {
3283             #### eval ValueConv/PrintConv ($val, $self, @val, @prt, @raw)
3284 16153         1036596 $value = eval $conv;
3285 16153 50       63865 $@ and $evalWarning = $@;
3286             }
3287 16988 50       57785 $self->Warn("$convType $tag: " . CleanWarning()) if $evalWarning;
3288             }
3289             } else {
3290 19         37 $value = $val;
3291             }
3292 24554 100       53022 last unless $vals;
3293             # must store a separate copy of each binary data value in the list
3294 361 100       950 if (ref $value eq 'SCALAR') {
3295 3         7 my $tval = $$value;
3296 3         8 $value = \$tval;
3297             }
3298             # save this converted value and step to next value in list
3299 361 50       1037 push @values, $value if defined $value;
3300 361 100       900 if (++$i >= scalar(@$vals)) {
3301 148 50       581 $value = \@values if @values;
3302 148         302 last;
3303             }
3304 213         432 $val = $$vals[$i];
3305 213 100       523 if ($convList) {
3306 132         269 my $nextConv = $$convList[$i];
3307 132 50 66     694 if ($nextConv and $nextConv eq 'REPEAT') {
3308 0         0 undef $convList;
3309             } else {
3310 132         335 $conv = $nextConv;
3311             }
3312             }
3313             }
3314             # return undefined now if no value
3315 24341 100       48935 return () unless defined $value;
3316             # join back into single value if split for conversion list
3317 23775 100 66     63441 if ($convList and ref $value eq 'ARRAY') {
3318 124 100       808 $value = join($convType eq 'PrintConv' ? '; ' : ' ', @$value);
3319             }
3320             }
3321 42005 100       79746 if ($type eq 'Both') {
3322             # save both (unescaped) values because we often need them again
3323             # (Composite tags need "Both" and often Require one tag for various Composite tags)
3324 7484 100       21251 $$self{BOTH}{$tag} = [ $valueConv, $value ] unless $both;
3325             # escape values if necessary
3326 7484 50       19605 if ($$self{ESCAPE_PROC}) {
    100          
3327 0         0 DoEscape($value, $$self{ESCAPE_PROC});
3328 0 0       0 if (defined $valueConv) {
3329 0         0 DoEscape($valueConv, $$self{ESCAPE_PROC});
3330             } else {
3331 0         0 $valueConv = $value;
3332             }
3333             } elsif (not defined $valueConv) {
3334             # $valueConv is undefined if there was no print conversion done
3335 3771         5783 $valueConv = $value;
3336             }
3337 7484         28666 $self->Filter($$self{OPTIONS}{Filter}, \$value);
3338             # return Both values as a list (ValueConv, PrintConv)
3339 7484         31826 return ($valueConv, $value);
3340             }
3341             # escape value if necessary
3342 34521 100       65326 DoEscape($value, $$self{ESCAPE_PROC}) if $$self{ESCAPE_PROC};
3343              
3344             # filter if necessary
3345 34521 100 100     73320 $self->Filter($$self{OPTIONS}{Filter}, \$value) if $$self{OPTIONS}{Filter} and $type eq 'PrintConv';
3346              
3347 34521 100       61996 if (ref $value eq 'ARRAY') {
3348 289 100 100     2992 if (defined $$self{OPTIONS}{ListItem}) {
    100 100        
    100          
3349 3         8 $value = $$value[$$self{OPTIONS}{ListItem}];
3350             } elsif (wantarray) {
3351             # return array if requested
3352 1         18 return @$value;
3353             } elsif ($type eq 'PrintConv' and not $$self{OPTIONS}{List} and not ref $$value[0]) {
3354             # join PrintConv values in comma-separated string if List option not used
3355             # and list contains simple scalars (otherwise return ARRAY ref)
3356 162         804 $value = join $$self{OPTIONS}{ListSep}, @$value;
3357             }
3358             }
3359 34520         87480 return $value;
3360             }
3361              
3362             #------------------------------------------------------------------------------
3363             # Get tag identification number
3364             # Inputs: 0) ExifTool object reference, 1) tag key
3365             # Returns: Scalar context: tag ID if available, otherwise ''
3366             # List context: 0) tag ID (or ''), 1) language code (or undef)
3367             sub GetTagID($$)
3368             {
3369 23282     23282 1 138318 my ($self, $tag) = @_;
3370 23282         39625 my $tagInfo = $$self{TAG_INFO}{$tag};
3371 23282 100 66     76684 return '' unless $tagInfo and defined $$tagInfo{TagID};
3372 23280   100     61923 my $id = $$tagInfo{KeysID} || $$tagInfo{TagID};
3373 23280 50       42336 return ($id, $$tagInfo{LangCode}) if wantarray;
3374 23280         48206 return $id;
3375             }
3376              
3377             #------------------------------------------------------------------------------
3378             # Get description for specified tag
3379             # Inputs: 0) ExifTool object reference, 1) tag key
3380             # Returns: Tag description
3381             # Notes: Will always return a defined value, even if description isn't available
3382             sub GetDescription($$)
3383             {
3384 23282     23282 1 67361 local $_;
3385 23282         38616 my ($self, $tag) = @_;
3386 23282         32379 my ($desc, $name);
3387 23282         37056 my $tagInfo = $$self{TAG_INFO}{$tag};
3388             # ($tagInfo won't be defined for missing tags extracted with -f)
3389 23282 50       43492 if ($tagInfo) {
3390             # use alternate language description if available
3391 23282         46049 while ($$self{CUR_LANG}) {
3392 800         1987 $desc = $$self{CUR_LANG}{$$tagInfo{Name}};
3393 800 100       1464 if ($desc) {
3394             # must look up Description if this tag also has a PrintConv
3395 671 100 100     1726 $desc = $$desc{Description} or last if ref $desc;
3396             } else {
3397             # look up default language of lang-alt tag
3398             last unless $$tagInfo{LangCode} and
3399             ($name = $$tagInfo{Name}) =~ s/-$$tagInfo{LangCode}$// and
3400 129 50 66     366 $desc = $$self{CUR_LANG}{$name};
      66        
3401 1 50 0     5 $desc = $$desc{Description} or last if ref $desc;
3402 1         4 $desc .= " ($$tagInfo{LangCode})";
3403             }
3404             # escape description if necessary
3405 663 50       1195 DoEscape($desc, $$self{ESCAPE_PROC}) if $$self{ESCAPE_PROC};
3406             # return description in proper Charset
3407 663         1402 return $self->Decode($desc, 'UTF8');
3408             }
3409 22619         42472 $desc = $$tagInfo{Description};
3410             }
3411             # just make the tag more readable if description doesn't exist
3412 22619 100       40723 unless ($desc) {
3413 9412         17310 $desc = MakeDescription(GetTagName($tag));
3414             # save description in tag information
3415 9412 50       28033 $$tagInfo{Description} = $desc if $tagInfo;
3416             }
3417 22619         47699 return $desc;
3418             }
3419              
3420             #------------------------------------------------------------------------------
3421             # Get group name for specified tag
3422             # Inputs: 0) ExifTool object reference
3423             # 1) tag key (or reference to tagInfo hash, not part of the public API)
3424             # 2) [optional] group family (-1 to get extended group list, or multiple
3425             # families separated by colons to return multiple groups as a string)
3426             # Returns: Scalar context: group name (for family 0 if not otherwise specified)
3427             # List context: group name if family specified, otherwise list of
3428             # group names for each family. Returns '' for undefined tag.
3429             # Notes: Multiple families may be specified with ':' in family argument (eg. '1:2')
3430             sub GetGroup($$;$)
3431             {
3432 190519     190519 1 688326 local $_;
3433 190519         328424 my ($self, $tag, $family) = @_;
3434 190519         281027 my ($tagInfo, @groups, @families, $simplify, $byTagInfo, $ex, $noID);
3435 190519 100       357363 if (ref $tag eq 'HASH') {
3436 120618         165222 $tagInfo = $tag;
3437 120618         232015 $tag = $$tagInfo{Name};
3438             # set flag so we don't get extra information for an extracted tag
3439 120618         165569 $byTagInfo = 1;
3440             } else {
3441 69901   50     163337 $tagInfo = $$self{TAG_INFO}{$tag} || { };
3442 69901         112692 $ex = $$self{TAG_EXTRA}{$tag};
3443             }
3444 190519         367132 my $groups = $$tagInfo{Groups};
3445             # fill in default groups unless already done
3446             # (after this, Groups 0-2 in tagInfo are guaranteed to be defined)
3447 190519 100       378771 unless ($$tagInfo{GotGroups}) {
3448 35640   50     72925 my $tagTablePtr = $$tagInfo{Table} || { GROUPS => { } };
3449             # construct our group list
3450 35640 100       87128 $groups or $groups = $$tagInfo{Groups} = { };
3451             # fill in default groups
3452 35640         66320 foreach (0..2) {
3453 106920 100 50     376632 $$groups{$_} = $$tagTablePtr{GROUPS}{$_} || '' unless $$groups{$_};
3454             }
3455             # set flag indicating group list was built
3456 35640         74833 $$tagInfo{GotGroups} = 1;
3457             }
3458 190519 100 100     509426 if (defined $family and $family ne '-1') {
3459 98724 100       217710 if ($family =~ /[^\d]/) {
3460 2736         8910 @families = ($family =~ /\d+/g);
3461 2736 50 0     5599 return(($ex && $$ex{G0}) || $$groups{0}) unless @families;
3462 2736 50       5713 $simplify = 1 unless $family =~ /^:/;
3463 2736         3855 undef $family;
3464 2736         4688 foreach (0..2) { $groups[$_] = $$groups{$_}; }
  8208         15680  
3465 2736 50 33     5834 $noID = 1 if @families == 1 and $families[0] != 7;
3466             } else {
3467 95988 100 66     513152 return(($ex && $$ex{"G$family"}) || $$groups{$family}) if $family == 0 or $family == 2;
      100        
3468 28485         91372 $groups[1] = $$groups{1};
3469             }
3470             } else {
3471 91795 100 33     169131 return(($ex && $$ex{G0}) || $$groups{0}) unless wantarray;
3472 91415         154020 foreach (0..2) { $groups[$_] = $$groups{$_}; }
  274245         614990  
3473             }
3474 122636         200090 $groups[3] = 'Main';
3475 122636 100       285375 $groups[4] = ($tag =~ /\((\d+)\)$/) ? "Copy$1" : '';
3476             # handle dynamic group names if necessary
3477 122636 100       233819 unless ($byTagInfo) {
3478 44337 100       78391 if ($ex) {
3479 17255 100       37017 $groups[0] = $$ex{G0} if $$ex{G0};
3480 17255 100       50082 $groups[1] = $$ex{G1} =~ /^\+(.*)/ ? "$groups[1]$1" : $$ex{G1} if $$ex{G1};
    100          
3481 17255 100       33517 $groups[3] = 'Doc' . $$ex{G3} if $$ex{G3};
3482 17255 100 66     33226 $groups[5] = $$ex{G5} || $groups[1] if defined $$ex{G5};
3483 17255 50       31790 if (defined $$ex{G6}) {
3484 0 0       0 $groups[5] = '' unless defined $groups[5]; # (can't leave a hole in the array)
3485 0         0 $groups[6] = $$ex{G6};
3486             }
3487             }
3488             # generate tag ID group names unless obviously not needed
3489 44337 50       76013 unless ($noID) {
3490 44337   100     146752 my $id = $$tagInfo{KeysID} || $$tagInfo{TagID};
3491 44337 100       137231 if (not defined $id) {
    100          
3492 2         4 $id = ''; # (just to be safe)
3493             } elsif ($id =~ /^\d+$/) {
3494 27915 50       62381 $id = sprintf('0x%x', $id) if $$self{OPTIONS}{HexTagIDs};
3495             } else {
3496 16420         34630 $id =~ s/([^-_A-Za-z0-9])/sprintf('%.2x',ord $1)/ge;
  1282         6125  
3497             }
3498 44337         89994 $groups[7] = 'ID-' . $id;
3499 44337   100     154236 defined $groups[$_] or $groups[$_] = '' foreach (5,6);
3500             }
3501             }
3502 122636 100       230816 if ($family) {
3503 43626 100 50     183748 return $groups[$family] || '' if $family > 0;
3504             # add additional matching group names to list
3505             # eg) for MIE-Doc, also add MIE1, MIE1-Doc, MIE-Doc1 and MIE1-Doc1
3506             # and for MIE2-Doc3, also add MIE2, MIE-Doc3, MIE2-Doc and MIE-Doc
3507 15141 100       29406 if ($groups[1] =~ /^MIE(\d*)-(.+?)(\d*)$/) {
3508 31   50     185 push @groups, 'MIE' . ($1 || '1');
3509 31 50       151 push @groups, 'MIE' . ($1 ? '' : '1') . "-$2$3";
3510 31 50       169 push @groups, "MIE$1-$2" . ($3 ? '' : '1');
3511 31 50       162 push @groups, 'MIE' . ($1 ? '' : '1') . "-$2" . ($3 ? '' : '1');
    50          
3512             }
3513             }
3514 94151 100       182451 if (@families) {
3515 2736         3421 my @grps;
3516             # create list of group names (without identical adjacent groups if simplifying)
3517 2736         4305 foreach (@families) {
3518 5472         8554 my $grp = $groups[$_];
3519 5472 50       8964 unless ($grp) {
3520 0 0       0 next if $simplify;
3521 0         0 $grp = '';
3522             }
3523 5472 100 66     21856 push @grps, $grp unless $simplify and @grps and $grp eq $grps[-1];
      100        
3524             }
3525             # remove leading "Main:" if simplifying
3526 2736 50 66     10513 shift @grps if $simplify and @grps > 1 and $grps[0] eq 'Main';
      66        
3527             # return colon-separated string of group names
3528 2736         10153 return join ':', @grps;
3529             }
3530 91415         363052 return @groups;
3531             }
3532              
3533             #------------------------------------------------------------------------------
3534             # Get group names for specified tags
3535             # Inputs: 0) ExifTool object reference
3536             # 1) [optional] information hash reference (default all extracted info)
3537             # 2) [optional] group family (default 0)
3538             # Returns: List of group names in alphabetical order
3539             sub GetGroups($;$$)
3540             {
3541 3     3 1 76 local $_;
3542 3         7 my $self = shift;
3543 3         6 my $info = shift;
3544 3         7 my $family;
3545              
3546             # figure out our arguments
3547 3 100       15 if (ref $info ne 'HASH') {
3548 2         4 $family = $info;
3549 2         4 $info = $$self{VALUE};
3550             } else {
3551 1         4 $family = shift;
3552             }
3553 3 50       10 $family = 0 unless defined $family;
3554              
3555             # get a list of all groups in specified information
3556 3         7 my ($tag, %groups);
3557 3         62 foreach $tag (keys %$info) {
3558 383         770 $groups{ $self->GetGroup($tag, $family) } = 1;
3559             }
3560 3         62 return sort keys %groups;
3561             }
3562              
3563             #------------------------------------------------------------------------------
3564             # Set priority for group where new values are written
3565             # Inputs: 0) ExifTool object reference,
3566             # 1-N) group names (reset to default if no groups specified)
3567             # - used when new tag values are set (ie. before files are written)
3568             sub SetNewGroups($;@)
3569             {
3570 475     475 1 1036 local $_;
3571 475         2513 my ($self, @groups) = @_;
3572 475 50       1754 @groups or @groups = @defaultWriteGroups;
3573 475         1412 my $count = @groups * 10;
3574 475         957 my %priority;
3575 475         1471 foreach (@groups) {
3576 4275         9213 $priority{lc($_)} = $count;
3577 4275         6497 $count -= 10;
3578             }
3579 475         1735 $priority{file} = 500; # 'File' group is always written (Comment)
3580 475         1241 $priority{composite} = 500; # 'Composite' group is always written
3581             # set write priority (higher # is higher priority)
3582 475         1403 $$self{WRITE_PRIORITY} = \%priority;
3583 475         1967 $$self{WRITE_GROUPS} = \@groups;
3584             }
3585              
3586             #------------------------------------------------------------------------------
3587             # Build Composite tags from Require'd/Desire'd tags
3588             # Inputs: 0) ExifTool object reference
3589             # Note: Tag values are calculated in alphabetical order unless a tag Require's
3590             # or Desire's another Composite tag, in which case the calculation is
3591             # deferred until after the other tag is calculated.
3592             sub BuildCompositeTags($)
3593             {
3594 506     506 1 1182 local $_;
3595 506         1050 my $self = shift;
3596              
3597 506         6166 $$self{BuildingComposite} = 1;
3598              
3599 506         1686 my $compTable = GetTagTable('Image::ExifTool::Composite');
3600 506         33297 my @tagList = sort keys %$compTable;
3601 506         3010 my $rawValue = $$self{VALUE};
3602 506         2579 my $compKeys = $$self{COMP_KEYS};
3603 506         1345 my (%cache, $allBuilt);
3604              
3605 506         1202 for (;;) {
3606 2214         4132 my (%notBuilt, $tag, @deferredTags);
3607 2214         4770 foreach (@tagList) {
3608 42980 100       136741 $notBuilt{$$compTable{$_}{Name}} = 1 unless $specialTags{$_};
3609             }
3610             COMPOSITE_TAG:
3611 2214         4288 foreach $tag (@tagList) {
3612 42980 100       87791 next if $specialTags{$tag};
3613 39944         82343 my $tagInfo = $self->GetTagInfo($compTable, $tag);
3614 39944 100       76487 next unless $tagInfo;
3615 39695         65851 my $tagName = $$compTable{$tag}{Name};
3616             # put required tags into array and make sure they all exist
3617 39695   100     83158 my $subDoc = ($$tagInfo{SubDoc} and $$self{DOC_COUNT});
3618 39695   100     98334 my $require = $$tagInfo{Require} || { };
3619 39695   100     101101 my $desire = $$tagInfo{Desire} || { };
3620 39695   100     100260 my $inhibit = $$tagInfo{Inhibit} || { };
3621             # loop through sub-documents if necessary
3622 39695         55676 my $docNum = 0;
3623 39695         52577 for (;;) {
3624 39695         56723 my (%tagKey, $found, $index);
3625             # save Require'd and Desire'd tag values in list
3626 39695         56956 for ($index=0; ; ++$index) {
3627 94633   100     321260 my $reqTag = $$require{$index} || $$desire{$index} || $$inhibit{$index};
3628 94633 100       159790 unless ($reqTag) {
3629             # allow Composite with no Require'd or Desire'd tags
3630 8843 50       17789 $found = 1 if $index == 0;
3631 8843         14022 last;
3632             }
3633 85790 100 66     300050 if ($subDoc) {
    100          
    100          
3634             # handle SubDoc tags specially to cache tag keys for faster
3635             # processing when there are a large number of sub-documents
3636             # - get document number from the tag groups if specified,
3637             # otherwise we are looping through all documents for this tag
3638 285 50 0     900 my $doc = $reqTag =~ s/\b(Main|Doc(\d+)):// ? ($2 || 0) : $docNum;
3639             # make fast lookup for keys of this tag with specified groups other than doc group
3640             # (similar to code in InsertTagValues(), but this is case-sensitive)
3641 285         489 my $cacheTag = $cache{$reqTag};
3642 285 50       538 unless ($cacheTag) {
3643 285         868 $cacheTag = $cache{$reqTag} = [ ];
3644 285         445 my $reqGroup;
3645 285 50       1505 $reqTag =~ s/^(.*):// and $reqGroup = $1;
3646 285         558 my ($i, $key, @keys);
3647             # build list of tag keys in order of precedence
3648 285   50     1053 for ($key=$reqTag, $i=$$self{DUPL_TAG}{$reqTag} || 0; ; --$i) {
3649 285 50       684 push @keys, $key if defined $$rawValue{$key};
3650 285 50       635 last if $i <= 0;
3651 0         0 $key = "$reqTag ($i)";
3652             }
3653 285 50       880 @keys = $self->GroupMatches($reqGroup, \@keys) if defined $reqGroup;
3654 285 50       684 if (@keys) {
3655 0         0 my $ex = $$self{TAG_EXTRA};
3656             # loop through tags in reverse order of precedence so the higher
3657             # priority tag will win in the case of duplicates within a doc
3658 0 0 0     0 $$cacheTag[$$ex{$_} ? $$ex{$_}{G3} || 0 : 0] = $_ foreach reverse @keys;
3659             }
3660             }
3661             # (set $reqTag to a bogus key if not found)
3662 285   33     1100 $reqTag = $$cacheTag[$doc] || "$reqTag (0)";
3663             } elsif ($reqTag =~ /^(.*):(.+)/) {
3664 26553         74566 my ($reqGroup, $name) = ($1, $2);
3665 26553 100 100     59864 if ($reqGroup eq 'Composite' and $notBuilt{$name}) {
3666             # defer only until all other tags are built if
3667             # we are inhibiting based on another Composite tag
3668 2095 100 100     8628 unless ($$inhibit{$index} and $allBuilt) {
3669 1655         3268 push @deferredTags, $tag;
3670 1655         6211 next COMPOSITE_TAG;
3671             }
3672             }
3673             # (CAREFUL! keys may not be sequential if one was deleted)
3674 24898         36257 my ($i, $key, @keys);
3675 24898   100     80627 for ($key=$name, $i=$$self{DUPL_TAG}{$name} || 0; ; --$i) {
3676 25537 100       55590 push @keys, $key if defined $$rawValue{$key};
3677 25537 100       50720 last if $i <= 0;
3678 639         1900 $key = "$name ($i)";
3679             }
3680             # find first matching tag
3681 24898         56515 $key = $self->GroupMatches($reqGroup, \@keys);
3682 24898   66     84903 $reqTag = $key || "$name (0)";
3683             } elsif ($notBuilt{$reqTag} and not $$inhibit{$index}) {
3684             # calculate this tag later if it relies on another
3685             # Composite tag which hasn't been calculated yet
3686 4895         9142 push @deferredTags, $tag;
3687 4895         13205 next COMPOSITE_TAG;
3688             }
3689 79240 100       182047 if (defined $$rawValue{$reqTag}) {
    100          
3690 15763 100       25677 if ($$inhibit{$index}) {
3691 66         244 $found = 0;
3692 66         178 last;
3693             } else {
3694 15697         22674 $found = 1;
3695             }
3696             } elsif ($$require{$index}) {
3697 24236         32246 $found = 0;
3698 24236         36838 last; # don't continue since we require this tag
3699             }
3700 54938         113961 $tagKey{$index} = $reqTag;
3701             }
3702 33145 50       80742 if ($docNum) {
    100          
    100          
3703 0 0       0 if ($found) {
3704 0         0 $$self{DOC_NUM} = $docNum;
3705             # save pointers to all used tag keys
3706 0         0 foreach (keys %tagKey) {
3707 0 0       0 $$compKeys{$_} or $$compKeys{$_} = [ ];
3708 0         0 push @{$$compKeys{$tagKey{$_}}}, [ \%tagKey, $_ ];
  0         0  
3709             }
3710 0         0 $self->FoundTag($tagInfo, \%tagKey);
3711 0         0 delete $$self{DOC_NUM};
3712             }
3713 0 0       0 next if ++$docNum <= $$self{DOC_COUNT};
3714 0         0 last;
3715             } elsif ($found) {
3716 5135         10507 delete $notBuilt{$tagName}; # this tag is OK to build now
3717             # keep track of all Require'd tag keys
3718 5135         19151 foreach (keys %tagKey) {
3719             # only tag keys with same name as a Composite tag
3720             # can be replaced (also eliminates keys with
3721             # instance numbers which can't be replaced either)
3722 22807 100       51695 next unless $compositeID{$tagKey{$_}};
3723             }
3724             # save pointers to all used tag keys
3725 5135         12858 foreach (keys %tagKey) {
3726 22807 100       48424 $$compKeys{$_} or $$compKeys{$_} = [ ];
3727 22807         29466 push @{$$compKeys{$tagKey{$_}}}, [ \%tagKey, $_ ];
  22807         84070  
3728             }
3729             # save reference to tag key lookup as value for Composite tag
3730 5135         17514 my $key = $self->FoundTag($tagInfo, \%tagKey);
3731             } elsif (not defined $found) {
3732 3708         8104 delete $notBuilt{$tagName}; # tag can't be built anyway
3733             }
3734 33145 100       95371 last unless $subDoc;
3735             # don't process sub-documents if there is no chance to build this tag
3736             # (can be very time-consuming if there are many docs)
3737 195 100       493 if (%$require) {
3738 165         615 foreach (keys %$require) {
3739 165         383 my $reqTag = $$require{$_};
3740 165         623 $reqTag =~ s/.*://;
3741 165 50       720 next COMPOSITE_TAG unless defined $$rawValue{$reqTag};
3742             }
3743 0         0 $docNum = 1; # go ahead and process the 1st sub-document
3744             } else {
3745 30 50       155 my @try = ref $$tagInfo{SubDoc} ? @{$$tagInfo{SubDoc}} : keys %$desire;
  30         128  
3746             # at least one of the specified desire tags must exist
3747 30         111 foreach (@try) {
3748 60 50       216 my $desTag = $$desire{$_} or next;
3749 60         265 $desTag =~ s/.*://;
3750 60 50       272 defined $$rawValue{$desTag} and $docNum = 1, last;
3751             }
3752 30 50       193 last unless $docNum;
3753             }
3754             }
3755             }
3756 2214 100       6882 last unless @deferredTags;
3757 1708 100       5700 if (@deferredTags == @tagList) {
3758 440 50       1731 if ($allBuilt) {
3759             # everything was deferred in the last pass,
3760             # must be a circular dependency
3761 0         0 warn "Circular dependency in Composite tags\n";
3762 0         0 last;
3763             }
3764 440         1050 $allBuilt = 1; # try once more, ignoring Composite Inhibit tags
3765             }
3766 1708         10112 @tagList = @deferredTags; # calculate deferred tags now
3767             }
3768 506         2472 delete $$self{BuildingComposite};
3769             }
3770              
3771             #------------------------------------------------------------------------------
3772             # Get reference to Composite tag info hash
3773             # Inputs: 0) case-sensitive Composite tag name
3774             # Returns: tagInfo hash or undef
3775             sub GetCompositeTagInfo($)
3776             {
3777 11     11 0 36 my $tag = shift;
3778 11 50       60 return undef unless $compositeID{$tag};
3779 11         60 return $Image::ExifTool::Composite{$compositeID{$tag}[0]};
3780             }
3781              
3782             #------------------------------------------------------------------------------
3783             # Get tag name (removes copy index)
3784             # Inputs: 0) Tag key
3785             # Returns: Tag name
3786             sub GetTagName($)
3787             {
3788 16738     16738 1 22898 local $_;
3789 16738         40885 $_[0] =~ /^(\S+)/;
3790 16738         48777 return $1;
3791             }
3792              
3793             #------------------------------------------------------------------------------
3794             # Get list of shortcuts
3795             # Returns: Shortcut list (sorted alphabetically)
3796             sub GetShortcuts()
3797             {
3798 0     0 1 0 local $_;
3799 0         0 require Image::ExifTool::Shortcuts;
3800 0         0 return sort keys %Image::ExifTool::Shortcuts::Main;
3801             }
3802              
3803             #------------------------------------------------------------------------------
3804             # Get file type for specified extension
3805             # Inputs: 0) file name or extension (case is not significant),
3806             # or FileType value if a description is requested
3807             # 1) flag to return long description instead of type ('0' to return any recognized type)
3808             # Returns: File type (or desc) or undef if extension not supported or if
3809             # description is the same as the input FileType. In list context,
3810             # may return more than one file type if the file may be different formats.
3811             # Returns list of all supported extensions if no file specified
3812             sub GetFileType(;$$)
3813             {
3814 953     953 1 2098 local $_;
3815 953         2636 my ($file, $desc) = @_;
3816 953 50       3795 unless (defined $file) {
3817 0         0 my @types;
3818 0 0 0     0 if (defined $desc and $desc eq '0') {
3819             # return all recognized types
3820 0         0 @types = sort keys %fileTypeLookup;
3821             } else {
3822             # return all supported types
3823 0         0 foreach (sort keys %fileTypeLookup) {
3824 0         0 my $module = $moduleName{$_};
3825 0 0       0 $module = $moduleName{$fileTypeLookup{$_}} unless defined $module;
3826 0 0 0     0 push @types, $_ unless defined $module and $module eq '0';
3827             }
3828             }
3829 0         0 return @types;
3830             }
3831 953         2129 my ($fileType, $subType);
3832 953         2357 my $fileExt = GetFileExtension($file);
3833 953 100       3487 unless ($fileExt) {
3834 66 50       294 if ($file =~ s/ \((.*)\)$//) {
3835 0         0 $subType = $1;
3836 0         0 $fileExt = GetFileExtension($file);
3837             }
3838 66 50       308 $fileExt = uc($file) unless $fileExt;
3839             }
3840 953 100       4044 $fileExt and $fileType = $fileTypeLookup{$fileExt}; # look up the file type
3841 953   100     6644 $fileType = $fileTypeLookup{$fileType} while $fileType and not ref $fileType;
3842             # return description if specified
3843             # (allow input $file to be a FileType for this purpose)
3844 953 50 33     6579 if ($desc) {
    100 66        
3845 0 0       0 if ($fileType) {
3846 0 0 0     0 if ($static_vars{OverrideFileDescription} and $static_vars{OverrideFileDescription}{$fileExt}) {
3847 0         0 $desc = $static_vars{OverrideFileDescription}{$fileExt};
3848             } else {
3849 0         0 $desc = $$fileType[1];
3850             }
3851             } else {
3852 0         0 $desc = $fileDescription{$file};
3853             }
3854 0 0       0 $desc .= ", $subType" if $subType;
3855 0         0 return $desc;
3856             } elsif ($fileType and (not defined $desc or $desc ne '0')) {
3857             # return only supported file types
3858 904         3309 my $mod = $moduleName{$$fileType[0]};
3859 904 50 66     4205 undef $fileType if defined $mod and $mod eq '0';
3860             }
3861 953 100       2771 $fileType or return ();
3862 904         1921 $fileType = $$fileType[0]; # get file type (or list of types)
3863 904 100       2937 if (wantarray) {
    50          
3864 675 100       2289 return @$fileType if ref $fileType eq 'ARRAY';
3865             } elsif ($fileType) {
3866 229 50       925 $fileType = $fileExt if ref $fileType eq 'ARRAY';
3867             }
3868 900         3063 return $fileType;
3869             }
3870              
3871             #------------------------------------------------------------------------------
3872             # Return true if we can write the specified file type
3873             # Inputs: 0) file name or ext
3874             # Returns: true if writable, 0 if not writable, undef if unrecognized
3875             sub CanWrite($)
3876             {
3877 0     0 1 0 local $_;
3878 0 0       0 my $file = shift or return undef;
3879 0 0       0 my ($type) = GetFileType($file) or return undef;
3880 0 0       0 if ($noWriteFile{$type}) {
3881             # can't write TIFF files with certain extensions (various RAW formats)
3882 0   0     0 my $ext = GetFileExtension($file) || uc($file);
3883 0 0       0 return grep(/^$ext$/, @{$noWriteFile{$type}}) ? 0 : 1 if $ext;
  0 0       0  
3884             }
3885 0 0       0 if ($onlyWriteFile{$type}) {
3886 0   0     0 my $ext = GetFileExtension($file) || uc($file);
3887 0 0       0 return grep(/^$ext$/, @{$onlyWriteFile{$type}}) ? 1 : 0 if $ext;
  0 0       0  
3888             }
3889 0 0       0 unless (%writeTypes) {
3890 0         0 $writeTypes{$_} = 1 foreach @writeTypes;
3891             }
3892 0         0 return $writeTypes{$type};
3893             }
3894              
3895             #------------------------------------------------------------------------------
3896             # Return true if we can create the specified file type
3897             # Inputs: 0) file name or ext
3898             # Returns: true if creatable, 0 if not writable, undef if unrecognized
3899             sub CanCreate($)
3900             {
3901 23     23 1 57 local $_;
3902 23 50       107 my $file = shift or return undef;
3903 23   33     88 my $ext = GetFileExtension($file) || uc($file);
3904 23 50       104 my $type = GetFileType($file) or return undef;
3905 23 50 33     224 return 1 if $createTypes{$ext} or $createTypes{$type};
3906 0         0 return 0;
3907             }
3908              
3909             #==============================================================================
3910             # Functions below this are not part of the public API
3911              
3912             # Initialize member variables for reading or writing a new file
3913             # Inputs: 0) ExifTool object reference
3914             sub Init($)
3915             {
3916 770     770 0 1833 local $_;
3917 770         1900 my $self = shift;
3918             # delete all DataMember variables (lower-case names)
3919 770         7468 foreach (keys %$self) {
3920 23182 100       49923 /[a-z]/ and delete $$self{$_};
3921             }
3922 770         3837 undef %static_vars; # clear all static variables
3923 770         2378 delete $$self{FOUND_TAGS}; # list of found tags
3924 770         1979 delete $$self{EXIF_DATA}; # the EXIF data block
3925 770         1913 delete $$self{EXIF_POS}; # EXIF position in file
3926 770         1784 delete $$self{FIRST_EXIF_POS}; # position of first EXIF in file
3927 770         1636 delete $$self{HTML_DUMP}; # html dump information
3928 770         1589 delete $$self{SET_GROUP0}; # group0 name override
3929 770         1626 delete $$self{SET_GROUP1}; # group1 name override
3930 770         1754 delete $$self{DOC_NUM}; # current embedded document number
3931 770         2047 $$self{DOC_COUNT} = 0; # count of embedded documents processed
3932 770         2531 $$self{BASE} = 0; # base for offsets from start of file
3933 770         4160 $$self{FILE_ORDER} = { }; # * hash of tag order in file ('*' = based on tag key)
3934 770         4916 $$self{VALUE} = { }; # * hash of raw tag values
3935 770         2543 $$self{BOTH} = { }; # * hash for Value/PrintConv values of Require'd tags
3936 770         2522 $$self{RATIONAL} = { }; # * hash of original rational components
3937 770         4796 $$self{TAG_INFO} = { }; # * hash of tag information
3938 770         4041 $$self{TAG_EXTRA} = { }; # * hash of extra tag information (dynamic group names)
3939 770         2648 $$self{PRIORITY} = { }; # * priority of current tags
3940 770         2325 $$self{LIST_TAGS} = { }; # hash of tagInfo refs for active List-type tags
3941 770         2596 $$self{PROCESSED} = { }; # hash of processed directory start positions
3942 770         2010 $$self{DIR_COUNT} = { }; # count various types of directories
3943 770         2053 $$self{DUPL_TAG} = { }; # last-used index for duplicate-tag keys
3944 770         1950 $$self{WARNED_ONCE}= { }; # WarnOnce() warnings already issued
3945 770         2008 $$self{WRITTEN} = { }; # list of tags written (selected tags only)
3946 770         1918 $$self{FORCE_WRITE}= { }; # ForceWrite lookup (set from ForceWrite tag)
3947 770         2206 $$self{FOUND_DIR} = { }; # hash of directory names found in file
3948 770         5426 $$self{COMP_KEYS} = { }; # lookup for tag keys used in Composite tags
3949 770         2314 $$self{PATH} = [ ]; # current subdirectory path in file when reading
3950 770         2183 $$self{NUM_FOUND} = 0; # total number of tags found (incl. duplicates)
3951 770         1851 $$self{CHANGED} = 0; # number of tags changed (writer only)
3952 770         2082 $$self{INDENT} = ' '; # initial indent for verbose messages
3953 770         1929 $$self{PRIORITY_DIR} = ''; # the priority directory name
3954 770         2875 $$self{LOW_PRIORITY_DIR} = { PreviewIFD => 1 }; # names of priority 0 directories
3955 770         2090 $$self{TIFF_TYPE} = ''; # type of TIFF data (APP1, TIFF, NEF, etc...)
3956 770         2138 $$self{FMT_EXPR} = undef; # current advanced formatting expression
3957 770         2011 $$self{Make} = ''; # camera make
3958 770         1899 $$self{Model} = ''; # camera model
3959 770         1894 $$self{CameraType} = ''; # Olympus camera type
3960 770         1993 $$self{FileType} = ''; # identified file type
3961 770 50       2862 if ($self->Options('HtmlDump')) {
3962 0         0 require Image::ExifTool::HtmlDump;
3963 0         0 $$self{HTML_DUMP} = new Image::ExifTool::HtmlDump;
3964             }
3965             # make sure our TextOut is a file reference
3966 770 50       3892 $$self{OPTIONS}{TextOut} = \*STDOUT unless ref $$self{OPTIONS}{TextOut};
3967             }
3968              
3969             #------------------------------------------------------------------------------
3970             # Combine information from a list of info hashes
3971             # Unless Duplicates is enabled, first entry found takes priority
3972             # Inputs: 0) ExifTool object reference, 1-N) list of info hash references
3973             # Returns: Combined information hash reference
3974             sub CombineInfo($;@)
3975             {
3976 2     2 0 1491 local $_;
3977 2         6 my $self = shift;
3978 2         5 my (%combinedInfo, $info, $tag, %haveInfo);
3979              
3980 2 50       8 if ($$self{OPTIONS}{Duplicates}) {
3981 0         0 while ($info = shift) {
3982 0         0 foreach $tag (keys %$info) {
3983 0         0 $combinedInfo{$tag} = $$info{$tag};
3984             }
3985             }
3986             } else {
3987 2         7 while ($info = shift) {
3988 4         47 foreach $tag (keys %$info) {
3989 266         413 my $tagName = GetTagName($tag);
3990 266 100       500 next if $haveInfo{$tagName};
3991 252         373 $haveInfo{$tagName} = 1;
3992 252         463 $combinedInfo{$tag} = $$info{$tag};
3993             }
3994             }
3995             }
3996 2         36 return \%combinedInfo;
3997             }
3998              
3999             #------------------------------------------------------------------------------
4000             # Get tag table name
4001             # Inputs: 0) ExifTool object reference, 1) tag key
4002             # Returns: Table name if available, otherwise ''
4003             sub GetTableName($$)
4004             {
4005 0     0 0 0 my ($self, $tag) = @_;
4006 0 0       0 my $tagInfo = $$self{TAG_INFO}{$tag} or return '';
4007 0         0 return $$tagInfo{Table}{SHORT_NAME};
4008             }
4009              
4010             #------------------------------------------------------------------------------
4011             # Get tag index number
4012             # Inputs: 0) ExifTool object reference, 1) tag key
4013             # Returns: Table index number, or undefined if this tag isn't indexed
4014             sub GetTagIndex($$)
4015             {
4016 0     0 0 0 my ($self, $tag) = @_;
4017 0 0       0 my $tagInfo = $$self{TAG_INFO}{$tag} or return undef;
4018 0         0 return $$tagInfo{Index};
4019             }
4020              
4021             #------------------------------------------------------------------------------
4022             # Find value for specified tag
4023             # Inputs: 0) ExifTool ref, 1) tag name, 2) tag group (family 1)
4024             # Returns: value or undef
4025             sub FindValue($$$)
4026             {
4027 72     72 0 178 my ($et, $tag, $grp) = @_;
4028 72         97 my ($i, $val);
4029 72         122 my $value = $$et{VALUE};
4030 72         111 for ($i=0; ; ++$i) {
4031 144 100       357 my $key = $tag . ($i ? " ($i)" : '');
4032 144 100       333 last unless defined $$value{$key};
4033 142 100       264 if ($et->GetGroup($key, 1) eq $grp) {
4034 70         147 $val = $$value{$key};
4035 70         107 last;
4036             }
4037             }
4038 72         209 return $val;
4039             }
4040              
4041             #------------------------------------------------------------------------------
4042             # Get tag key for next existing tag
4043             # Inputs: 0) ExifTool ref, 1) tag key or case-sensitive tag name
4044             # Returns: Key of next existing tag, or undef if no more
4045             # Notes: This routine is provided for iterating through duplicate tags in the
4046             # ValueConv of Composite tags.
4047             sub NextTagKey($$)
4048             {
4049 18     18 0 95 my ($self, $tag) = @_;
4050 18 50       87 my $i = ($tag =~ s/ \((\d+)\)$//) ? $1 + 1 : 1;
4051 18         94 $tag = "$tag ($i)";
4052 18 50       74 return $tag if defined $$self{VALUE}{$tag};
4053 18         458 return undef;
4054             }
4055              
4056             #------------------------------------------------------------------------------
4057             # Does a string contain valid UTF-8 characters?
4058             # Inputs: 0) string reference, 1) true to allow last character to be truncated
4059             # Returns: 0=regular ASCII, -1=invalid UTF-8, 1=valid UTF-8 with maximum 16-bit
4060             # wide characters, 2=valid UTF-8 requiring 32-bit wide characters
4061             # Notes: Changes current string position
4062             # (see http://www.fileformat.info/info/unicode/utf8.htm for help understanding this)
4063             sub IsUTF8($;$)
4064             {
4065 103     103 0 218 my ($strPt, $trunc) = @_;
4066 103         351 pos($$strPt) = 0; # start at beginning of string
4067 103 100       557 return 0 unless $$strPt =~ /([\x80-\xff])/g;
4068 41         88 my $rtnVal = 1;
4069 41         72 for (;;) {
4070 183         334 my $ch = ord($1);
4071             # minimum lead byte for 2-byte sequence is 0xc2 (overlong sequences
4072             # not allowed), 0xf8-0xfd are restricted by RFC 3629 (no 5 or 6 byte
4073             # sequences), and 0xfe and 0xff are not valid in UTF-8 strings
4074 183 100 100     610 return -1 if $ch < 0xc2 or $ch >= 0xf8;
4075             # determine number of bytes remaining in sequence
4076 153         175 my $n;
4077 153 100       264 if ($ch < 0xe0) {
    50          
4078 75         95 $n = 1;
4079             } elsif ($ch < 0xf0) {
4080 78         104 $n = 2;
4081             } else {
4082 0         0 $n = 3;
4083             # character code is greater than 0xffff if more than 2 extra bytes
4084             # were required in the UTF-8 character
4085 0         0 $rtnVal = 2;
4086             }
4087 153         198 my $pos = pos $$strPt;
4088 153 100       688 unless ($$strPt =~ /\G([\x80-\xbf]{$n})/g) {
4089 1 50 33     8 return $rtnVal if $trunc and $pos + $n > length $$strPt;
4090 1         5 return -1;
4091             }
4092             # the following is ref https://www.cl.cam.ac.uk/%7Emgk25/ucs/utf8_check.c
4093 152 100       291 if ($n == 2) {
4094 77 50 66     381 return -1 if ($ch == 0xe0 and (ord($1) & 0xe0) == 0x80) or
      33        
      33        
      66        
      33        
      33        
4095             ($ch == 0xed and (ord($1) & 0xe0) == 0xa0) or
4096             ($ch == 0xef and ord($1) == 0xbf and
4097             (ord(substr $1, 1) & 0xfe) == 0xbe);
4098             } else {
4099 75 50 33     358 return -1 if ($ch == 0xf0 and (ord($1) & 0xf0) == 0x80) or
      33        
      33        
      33        
4100             ($ch == 0xf4 and ord($1) > 0x8f) or $ch > 0xf4;
4101             }
4102 152 100       392 last unless $$strPt =~ /([\x80-\xff])/g;
4103             }
4104 10         34 return $rtnVal;
4105             }
4106              
4107             #------------------------------------------------------------------------------
4108             # Split file name into directory and name parts
4109             # Inptus: 0) file name
4110             # Returns: 0) directory, 1) filename
4111             sub SplitFileName($)
4112             {
4113 473     473 0 1187 my $file = shift;
4114 473         1186 my ($dir, $name);
4115 473 50       1128 if (eval { require File::Basename }) {
  473         4818  
4116 473         27394 $dir = File::Basename::dirname($file);
4117 473         12414 $name = File::Basename::basename($file);
4118             } else {
4119 0         0 ($name = $file) =~ tr/\\/\//;
4120             # remove path
4121 0 0       0 $dir = length($1) ? $1 : '/' if $name =~ s/(.*)\///;
    0          
4122             }
4123 473         2107 return ($dir, $name);
4124             }
4125              
4126             #------------------------------------------------------------------------------
4127             # Encode file name for calls to system i/o routines
4128             # Inputs: 0) ExifTool ref, 1) file name in CharSetFileName, 2) flag to force conversion
4129             # Returns: true if Windows Unicode routines should be used (in which case
4130             # the file name will be encoded as a null-terminated UTF-16LE string)
4131             sub EncodeFileName($$;$)
4132             {
4133 1136     1136 0 2891 my ($self, $file, $force) = @_;
4134 1136         2715 my $enc = $$self{OPTIONS}{CharsetFileName};
4135 1136 50 33     6571 if ($enc) {
    50 33        
4136 0 0 0     0 if ($file =~ /[\x80-\xff]/ or $force) {
4137             # encode for use in Windows Unicode functions if necessary
4138 0 0       0 if ($^O eq 'MSWin32') {
4139 0         0 local $SIG{'__WARN__'} = \&SetWarning;
4140 0 0       0 if (eval { require Win32API::File }) {
  0         0  
4141             # recode as UTF-16LE and add null terminator
4142 0         0 $_[1] = $self->Decode($file, $enc, undef, 'UTF16', 'II') . "\0\0";
4143 0         0 return 1;
4144             }
4145 0         0 $self->WarnOnce('Install Win32API::File for Windows Unicode file support');
4146             } else {
4147             # recode as UTF-8 for other platforms if necessary
4148 0 0       0 $_[1] = $self->Decode($file, $enc, undef, 'UTF8') unless $enc eq 'UTF8';
4149             }
4150             }
4151             } elsif ($^O eq 'MSWin32' and $file =~ /[\x80-\xff]/ and not defined $enc) {
4152 0 0       0 $self->WarnOnce('FileName encoding not specified') if IsUTF8(\$file) < 0;
4153             }
4154 1136         3532 return 0;
4155             }
4156              
4157             #------------------------------------------------------------------------------
4158             # Modified perl open() routine to properly handle special characters in file names
4159             # Inputs: 0) ExifTool ref, 1) filehandle, 2) filename,
4160             # 3) mode: '<' or undef = read, '>' = write, '+<' = update
4161             # Returns: true on success
4162             # Note: Must call like "$et->Open(\*FH,$file)", not "$et->Open(FH,$file)" to avoid
4163             # "unopened filehandle" errors due to a change in scope of the filehandle
4164             sub Open($*$;$)
4165             {
4166 908     908 0 3654 my ($self, $fh, $file, $mode) = @_;
4167              
4168 908         3446 $file =~ s/^([\s&])/.\/$1/; # protect leading whitespace or ampersand
4169             # default to read mode ('<') unless input is a trusted pipe
4170 908 50 33     4971 $mode = (($file =~ /\|$/ and $$self{TRUST_PIPE}) ? '' : '<') unless $mode;
    100          
4171 908         2103 delete $$self{TRUST_PIPE};
4172 908 50       2690 if ($mode) {
4173 908 50       3569 if ($self->EncodeFileName($file)) {
4174             # handle Windows Unicode file name
4175 0         0 local $SIG{'__WARN__'} = \&SetWarning;
4176 0         0 my ($access, $create);
4177 0 0       0 if ($mode eq '>') {
4178 0         0 eval {
4179 0         0 $access = Win32API::File::GENERIC_WRITE();
4180 0         0 $create = Win32API::File::CREATE_ALWAYS();
4181             }
4182             } else {
4183 0         0 eval {
4184 0         0 $access = Win32API::File::GENERIC_READ();
4185 0 0       0 $access |= Win32API::File::GENERIC_WRITE() if $mode eq '+<'; # update
4186 0         0 $create = Win32API::File::OPEN_EXISTING();
4187             }
4188             }
4189 0         0 my $share = 0;
4190 0         0 eval {
4191 0 0       0 unless ($access & Win32API::File::GENERIC_WRITE()) {
4192 0         0 $share = Win32API::File::FILE_SHARE_READ() | Win32API::File::FILE_SHARE_WRITE();
4193             }
4194             };
4195 0         0 my $wh = eval { Win32API::File::CreateFileW($file, $access, $share, [], $create, 0, []) };
  0         0  
4196 0 0       0 return undef unless $wh;
4197 0         0 my $fd = eval { Win32API::File::OsFHandleOpenFd($wh, 0) };
  0         0  
4198 0 0 0     0 if (not defined $fd or $fd < 0) {
4199 0         0 eval { Win32API::File::CloseHandle($wh) };
  0         0  
4200 0         0 return undef;
4201             }
4202 0         0 $file = "&=$fd"; # specify file by descriptor
4203             } else {
4204             # add leading space to protect against leading characters like '>'
4205             # in file name, and trailing "\0" to protect trailing spaces
4206 908         3071 $file = " $file\0";
4207             }
4208             }
4209 908         62960 return open $fh, "$mode$file";
4210             }
4211              
4212             #------------------------------------------------------------------------------
4213             # Check to see if a file exists (with Windows Unicode support)
4214             # Inputs: 0) ExifTool ref, 1) file name
4215             # Returns: true if file exists
4216             sub Exists($$)
4217             {
4218 221     221 0 868 my ($self, $file) = @_;
4219              
4220 221 50       934 if ($self->EncodeFileName($file)) {
4221 0         0 local $SIG{'__WARN__'} = \&SetWarning;
4222 0         0 my $wh = eval { Win32API::File::CreateFileW($file,
  0         0  
4223             Win32API::File::GENERIC_READ(),
4224             Win32API::File::FILE_SHARE_READ(), [],
4225             Win32API::File::OPEN_EXISTING(), 0, []) };
4226 0 0       0 return 0 unless $wh;
4227 0         0 eval { Win32API::File::CloseHandle($wh) };
  0         0  
4228             } else {
4229             # (named pipes already exist, but we pretend that they don't
4230             # so we will be able to write them, so test with for pipe -p)
4231 221   33     5463 return(-e $file and not -p $file);
4232             }
4233 0         0 return 1;
4234             }
4235              
4236             #------------------------------------------------------------------------------
4237             # Return true if file is a directory (with Windows Unicode support)
4238             # Inputs: 0) ExifTool ref, 1) file name
4239             # Returns: true if file is a directory (false if file isn't, or doesn't exist)
4240             sub IsDirectory($$)
4241             {
4242 1     1 0 5 my ($et, $file) = @_;
4243 1 50       4 if ($et->EncodeFileName($file)) {
4244 0         0 local $SIG{'__WARN__'} = \&SetWarning;
4245 0         0 my $attrs = eval { Win32API::File::GetFileAttributesW($file) };
  0         0  
4246 0   0     0 my $dirBit = eval { Win32API::File::FILE_ATTRIBUTE_DIRECTORY() } || 0;
4247 0 0 0     0 return 1 if $attrs and $attrs != 0xffffffff and $attrs & $dirBit;
      0        
4248             } else {
4249 1         31 return -d $file;
4250             }
4251 0         0 return 0;
4252             }
4253              
4254             #------------------------------------------------------------------------------
4255             # Get file times (Unix seconds since the epoch)
4256             # Inputs: 0) ExifTool ref, 1) file name or ref
4257             # Returns: 0) access time, 1) modification time, 2) creation time (or undefs on error)
4258             my $k32GetFileTime;
4259             sub GetFileTime($$)
4260             {
4261 0     0 0 0 my ($self, $file) = @_;
4262              
4263             # open file by name if necessary
4264 0 0       0 unless (ref $file) {
4265 0         0 local *FH;
4266 0 0       0 unless ($self->Open(\*FH, $file)) {
4267 0 0       0 if ($self->IsDirectory($file)) {
4268 0         0 my @rtn = (stat $file)[8, 9, 10];
4269 0 0       0 return @rtn if defined $rtn[0];
4270             }
4271 0         0 $self->Warn("GetFileTime error for '${file}'");
4272 0         0 return ();
4273             }
4274 0         0 $file = *FH; # (not \*FH, so *FH will be kept open until $file goes out of scope)
4275             }
4276             # on Windows, try to work around incorrect file times when daylight saving time is in effect
4277 0 0       0 if ($^O eq 'MSWin32') {
4278 0 0       0 if (not eval { require Win32::API }) {
  0 0       0  
4279 0         0 $self->WarnOnce('Install Win32::API for proper handling of Windows file times');
4280 0         0 } elsif (not eval { require Win32API::File }) {
4281 0         0 $self->WarnOnce('Install Win32API::File for proper handling of Windows file times');
4282             } else {
4283             # get Win32 handle, needed for GetFileTime
4284 0         0 my $win32Handle = eval { Win32API::File::GetOsFHandle($file) };
  0         0  
4285 0 0       0 unless ($win32Handle) {
4286 0         0 $self->Warn("Win32API::File::GetOsFHandle returned invalid handle");
4287 0         0 return ();
4288             }
4289             # get FILETIME structs
4290 0         0 my ($atime, $mtime, $ctime, $time);
4291 0         0 $atime = $mtime = $ctime = pack 'LL', 0, 0;
4292 0 0       0 unless ($k32GetFileTime) {
4293 0 0       0 return () if defined $k32GetFileTime;
4294 0         0 $k32GetFileTime = new Win32::API('KERNEL32', 'GetFileTime', 'NPPP', 'I');
4295 0 0       0 unless ($k32GetFileTime) {
4296 0         0 $self->Warn('Error calling Win32::API::GetFileTime');
4297 0         0 $k32GetFileTime = 0;
4298 0         0 return ();
4299             }
4300             }
4301 0 0       0 unless ($k32GetFileTime->Call($win32Handle, $ctime, $atime, $mtime)) {
4302 0         0 $self->Warn("Win32::API::GetFileTime returned " . Win32::GetLastError());
4303 0         0 return ();
4304             }
4305             # convert FILETIME structs to Unix seconds
4306 0         0 foreach $time ($atime, $mtime, $ctime) {
4307 0         0 my ($lo, $hi) = unpack 'LL', $time; # unpack FILETIME struct
4308             # FILETIME is in 100 ns intervals since 0:00 UTC Jan 1, 1601
4309             # (89 leap years between 1601 and 1970)
4310 0         0 $time = ($hi * 4294967296 + $lo) * 1e-7 - (((1970-1601)*365+89)*24*3600);
4311             }
4312 0         0 return ($atime, $mtime, $ctime);
4313             }
4314             }
4315             # other os (or Windows fallback)
4316 0         0 return (stat $file)[8, 9, 10];
4317             }
4318              
4319             #------------------------------------------------------------------------------
4320             # Parse function arguments and set member variables accordingly
4321             # Inputs: Same as ImageInfo()
4322             # - sets REQUESTED_TAGS, REQ_TAG_LOOKUP, IO_TAG_LIST, FILENAME, RAF, OPTIONS
4323             sub ParseArguments($;@)
4324             {
4325 695     695 0 1758 my $self = shift;
4326 695         1789 my $options = $$self{OPTIONS};
4327 695         1466 my @oldGroupOpts = grep /^Group/, keys %{$$self{OPTIONS}};
  695         13959  
4328 695         3506 my (@exclude, $wasExcludeOpt);
4329              
4330 695         2543 $$self{REQUESTED_TAGS} = [ ];
4331 695         2398 $$self{REQ_TAG_LOOKUP} = { };
4332 695         2221 $$self{EXCL_TAG_LOOKUP} = { };
4333 695         1869 $$self{IO_TAG_LIST} = undef;
4334 695         1663 delete $$self{EXCL_XMP_LOOKUP};
4335              
4336             # handle our input arguments
4337 695         3072 while (@_) {
4338 1496         2987 my $arg = shift;
4339 1496 100 66     6647 if (ref $arg and not overload::Method($arg, q[""])) {
    100          
4340 153 100 100     7451 if (ref $arg eq 'ARRAY') {
    100          
    100          
    50          
4341 4         20 $$self{IO_TAG_LIST} = $arg;
4342 4         34 foreach (@$arg) {
4343 12 100       66 if (/^-(.*)/) {
4344 2         10 push @exclude, $1;
4345             } else {
4346 10         14 push @{$$self{REQUESTED_TAGS}}, $_;
  10         24  
4347             }
4348             }
4349             } elsif (ref $arg eq 'HASH') {
4350 107         259 my $opt;
4351 107         492 foreach $opt (keys %$arg) {
4352             # a single new group option overrides all old group options
4353 171 50 33     669 if (@oldGroupOpts and $opt =~ /^Group/) {
4354 0         0 foreach (@oldGroupOpts) {
4355 0         0 delete $$options{$_};
4356             }
4357 0         0 undef @oldGroupOpts;
4358             }
4359 171         730 $self->Options($opt, $$arg{$opt});
4360 171 50       728 $opt eq 'Exclude' and $wasExcludeOpt = 1;
4361             }
4362             } elsif (ref $arg eq 'SCALAR' or UNIVERSAL::isa($arg,'GLOB')) {
4363 23 50       119 next if defined $$self{RAF};
4364             # convert image data from UTF-8 to character stream if necessary
4365             # (patches RHEL 3 UTF8 LANG problem)
4366 23 50 66     227 if (ref $arg eq 'SCALAR' and $] >= 5.006 and
      33        
      66        
4367             (eval { require Encode; Encode::is_utf8($$arg) } or $@))
4368             {
4369             # repack by hand if Encode isn't available
4370 0 0       0 my $buff = $@ ? pack('C*',unpack($] < 5.010000 ? 'U0C*' : 'C0C*',$$arg)) : Encode::encode('utf8',$$arg);
    0          
4371 0         0 $arg = \$buff;
4372             }
4373 23         193 $$self{RAF} = new File::RandomAccess($arg);
4374             # set filename to empty string to indicate that
4375             # we have a file but we didn't open it
4376 23         122 $$self{FILENAME} = '';
4377             } elsif (UNIVERSAL::isa($arg, 'File::RandomAccess')) {
4378 19         50 $$self{RAF} = $arg;
4379 19         66 $$self{FILENAME} = '';
4380             } else {
4381 0         0 warn "Don't understand ImageInfo argument $arg\n";
4382             }
4383             } elsif (defined $$self{FILENAME}) {
4384 870 100       2334 if ($arg =~ /^-(.*)/) {
4385 54         270 push @exclude, $1;
4386             } else {
4387 816         1313 push @{$$self{REQUESTED_TAGS}}, $arg;
  816         2738  
4388             }
4389             } else {
4390 473         1827 $$self{FILENAME} = $arg;
4391             }
4392             }
4393             # add additional requested tags to lookup
4394 695 100       2732 if ($$options{RequestTags}) {
4395 42         147 $$self{REQ_TAG_LOOKUP}{$_} = 1 foreach @{$$options{RequestTags}};
  42         303  
4396             }
4397             # expand shortcuts in tag arguments if provided
4398 695 100       1492 if (@{$$self{REQUESTED_TAGS}}) {
  695         2763  
4399 356         1805 ExpandShortcuts($$self{REQUESTED_TAGS});
4400             # initialize lookup for requested tags
4401 356         836 foreach (@{$$self{REQUESTED_TAGS}}) {
  356         1318  
4402 869 50       4695 /^(.*:)?([-\w?*]*)#?$/ or next;
4403 869 50       4529 $$self{REQ_TAG_LOOKUP}{lc($2)} = 1 if $2;
4404 869 100       2596 next unless $1;
4405 234         1480 $$self{REQ_TAG_LOOKUP}{lc($_).':'} = 1 foreach split /:/, $1;
4406             }
4407             }
4408 695 100 66     4304 if (@exclude or $wasExcludeOpt) {
4409             # must add existing excluded tags
4410 41 100       189 push @exclude, @{$$options{Exclude}} if $$options{Exclude};
  1         4  
4411 41         138 $$options{Exclude} = \@exclude;
4412             # expand shortcuts in new exclude list
4413 41         181 ExpandShortcuts($$options{Exclude}, 1); # (also remove '#' suffix)
4414             }
4415             # generate lookup for excluded tags
4416 695 100       2886 if ($$options{Exclude}) {
4417 47         149 foreach (@{$$options{Exclude}}) {
  47         208  
4418 64 100       649 /([-\w]+)#?$/ and $$self{EXCL_TAG_LOOKUP}{lc $1} = 1;
4419 64 50       286 if (/(xmp-.*:[-\w]+)#?/i) {
4420 0 0       0 $$self{EXCL_XMP_LOOKUP} or $$self{EXCL_XMP_LOOKUP} = { };
4421 0         0 $$self{EXCL_XMP_LOOKUP}{lc $1} = 1;
4422             }
4423             }
4424             # exclude list is used only for EXCL_TAG_LOOKUP when TAGS_FROM_FILE is set
4425 47 100       233 undef $$options{Exclude} if $$self{TAGS_FROM_FILE};
4426             }
4427             }
4428              
4429             #------------------------------------------------------------------------------
4430             # Does group name match the tag ID?
4431             # Inputs: 0) tag ID, 1) group name (with "ID-" removed)
4432             # Returns: true on success
4433             sub IsSameID($$)
4434             {
4435 2     2 0 16 my ($id, $grp) = @_;
4436 2 100       15 return 1 if $grp eq $id; # decimal ID's or raw ID's
4437 1 50       5 if ($id =~ /^\d+$/) { # numerical numerical ID's may be in hex
4438 0 0 0     0 return 1 if $grp =~ s/^0x0*// and $grp eq sprintf('%x', $id);
4439             } else { # other ID's may conform to ExifTool group name conventions
4440 1 50 33     8 return 1 if $id =~ s/([^-_A-Za-z0-9])/sprintf('%.2x',ord $1)/ge and $grp eq $id;
  1         17  
4441             }
4442 1         4 return 0;
4443             }
4444              
4445             #------------------------------------------------------------------------------
4446             # Get list of tags in specified group
4447             # Inputs: 0) ExifTool ref, 1) group spec, 2) tag key or reference to list of tag keys
4448             # Returns: list of matching tags in list context, or first match in scalar context
4449             # Notes: Group spec may contain multiple groups separated by colons, each
4450             # possibly with a leading family number
4451             sub GroupMatches($$$)
4452             {
4453 25450     25450 0 45965 my ($self, $group, $tagList) = @_;
4454 25450 50       50029 $tagList = [ $tagList ] unless ref $tagList;
4455 25450         35966 my ($tag, @matches);
4456             # check each group name individually (eg. "Author:1IPTC")
4457 25450         60483 my @grps = split ':', $group;
4458 25450         37905 my (@fmys, $g);
4459 25450         56613 for ($g=0; $g<@grps; ++$g) {
4460 26019 50       112695 if ($grps[$g] =~ s/^(\d*)(id-)?//i) {
4461 26019 100       61909 $fmys[$g] = $1 if length $1;
4462 26019 50       52502 if ($2) {
4463 0         0 $fmys[$g] = 7;
4464 0         0 next; # (don't convert tag ID's to lower case)
4465             }
4466             }
4467 26019         51242 $grps[$g] = lc $grps[$g];
4468 26019 50       70870 $grps[$g] = '' if $grps[$g] eq 'copy0'; # accept 'Copy0' for primary tag
4469             }
4470 25450         47358 foreach $tag (@$tagList) {
4471 15141         33814 my @groups = $self->GetGroup($tag, -1);
4472 15141         35219 for ($g=0; $g<@grps; ++$g) {
4473 15605         24675 my $grp = $grps[$g];
4474 15605 50 33     46708 next if $grp eq '*' or $grp eq 'all';
4475 15605         20355 my $f;
4476 15605 100       27950 if (defined($f = $fmys[$g])) {
4477 3 50       9 last unless defined $groups[$f];
4478 3 50       8 if ($f == 7) {
4479 0 0       0 next if IsSameID($self->GetTagID($tag), $grp);
4480             } else {
4481 3 100       10 next if $grp eq lc $groups[$f];
4482             }
4483 1         3 last;
4484             } else {
4485 15602 100       151263 last unless grep /^$grp$/i, @groups;
4486             }
4487             }
4488 15141 100       41224 if ($g == @grps) {
4489 4368 100       12419 return $tag unless wantarray;
4490 2407         5843 push @matches, $tag;
4491             }
4492             }
4493 23489 100       61763 return wantarray ? @matches : $matches[0];
4494             }
4495              
4496             #------------------------------------------------------------------------------
4497             # Remove specified tags from returned tag list, updating indices in other lists
4498             # Inputs: 0) tag list ref, 1) index list ref, 2) index list ref, 3) hash ref,
4499             # 4) true to include tags from hash instead of excluding
4500             # Returns: nothing, but updates input lists
4501             sub RemoveTagsFromList($$$$;$)
4502             {
4503 69     69 0 140 local $_;
4504 69         211 my ($tags, $list1, $list2, $exclude, $inv) = @_;
4505 69         135 my @filteredTags;
4506              
4507 69 100 100     410 if (@$list1 or @$list2) {
4508 6         34 while (@$tags) {
4509 233         340 my $tag = pop @$tags;
4510 233         314 my $i = @$tags;
4511 233 100 50     617 if ($$exclude{$tag} xor $inv) {
4512             # remove index of excluded tag from each list
4513 154 100       236 @$list1 = map { $_ < $i ? $_ : $_ == $i ? () : $_ - 1 } @$list1;
  12 100       29  
4514 154 100       239 @$list2 = map { $_ < $i ? $_ : $_ == $i ? () : $_ - 1 } @$list2;
  8245 100       12868  
4515             } else {
4516 79         223 unshift @filteredTags, $tag;
4517             }
4518             }
4519             } else {
4520 63         195 foreach (@$tags) {
4521 6864 100 100     19534 push @filteredTags, $_ unless $$exclude{$_} xor $inv;
4522             }
4523             }
4524 69         637 $_[0] = \@filteredTags; # update tag list
4525             }
4526              
4527             #------------------------------------------------------------------------------
4528             # Set list of found tags from previously requested tags
4529             # Inputs: 0) ExifTool object reference
4530             # Returns: 0) Reference to list of found tag keys (in order of requested tags)
4531             # 1) Reference to list of indices for tags requested by value
4532             # 2) Reference to list of indices for tags specified by wildcard or "all"
4533             # Notes: index lists are returned in increasing order
4534             sub SetFoundTags($)
4535             {
4536 690     690 0 1607 my $self = shift;
4537 690         1900 my $options = $$self{OPTIONS};
4538 690   50     2470 my $reqTags = $$self{REQUESTED_TAGS} || [ ];
4539 690         1625 my $duplicates = $$options{Duplicates};
4540 690         1503 my $exclude = $$options{Exclude};
4541 690         1693 my $fileOrder = $$self{FILE_ORDER};
4542 690         18725 my @groupOptions = sort grep /^Group/, keys %$options;
4543 690   100     5111 my $doDups = $duplicates || $exclude || @groupOptions;
4544 690         1809 my ($tag, $rtnTags, @byValue, @wildTags);
4545              
4546             # only return requested tags if specified
4547 690 100       2310 if (@$reqTags) {
4548 356 50       1392 $rtnTags or $rtnTags = [ ];
4549             # scan through the requested tags and generate a list of tags we found
4550 356         867 my $tagHash = $$self{VALUE};
4551 356         809 my $reqTag;
4552 356         1171 foreach $reqTag (@$reqTags) {
4553 869         1936 my (@matches, $group, $allGrp, $allTag, $byValue);
4554 869 100       3118 if ($reqTag =~ /^(.*):(.+)/) {
4555 234         1010 ($group, $tag) = ($1, $2);
4556 234 50       1758 if ($group =~ /^(\*|all)$/i) {
    50          
4557 0         0 $allGrp = 1;
4558             } elsif ($group !~ /^[-\w:]*$/) {
4559 0         0 $self->Warn("Invalid group name '${group}'");
4560 0         0 $group = 'invalid';
4561             }
4562             } else {
4563 635         1184 $tag = $reqTag;
4564             }
4565 869 50 66     2675 $byValue = 1 if $tag =~ s/#$// and $$options{PrintConv};
4566 869 50 66     6887 if (defined $$tagHash{$reqTag} and not $doDups) {
    100 66        
    100          
    50          
    0          
4567 0         0 $matches[0] = $tag;
4568             } elsif ($tag =~ /^(\*|all)$/i) {
4569             # tag name of '*' or 'all' matches all tags
4570 138 100 66     570 if ($doDups or $allGrp) {
4571 137         4729 @matches = grep(!/#/, keys %$tagHash);
4572             } else {
4573 1         110 @matches = grep(!/ /, keys %$tagHash);
4574             }
4575 138 50       906 next unless @matches; # don't want entry in list for '*' tag
4576 138         322 $allTag = 1;
4577             } elsif ($tag =~ /[*?]/) {
4578             # allow wildcards in tag names
4579 3         15 $tag =~ s/\*/[-\\w]*/g;
4580 3         16 $tag =~ s/\?/[-\\w]/g;
4581 3 50 33     19 $tag .= '( \\(.*)?' if $doDups or $allGrp;
4582 3         737 @matches = grep(/^$tag$/i, keys %$tagHash);
4583 3 50       38 next unless @matches; # don't want entry in list for wildcard tags
4584 3         22 $allTag = 1;
4585             } elsif ($doDups or defined $group) {
4586             # must also look for tags like "Tag (1)"
4587             # (but be sure not to match temporary ValueConv entries like "Tag #")
4588 728         52737 @matches = grep(/^$tag( \(|$)/i, keys %$tagHash);
4589             } elsif ($tag =~ /^[-\w]+$/) {
4590             # find first matching value
4591             # (use in list context to return value instead of count)
4592 0         0 ($matches[0]) = grep /^$tag$/i, keys %$tagHash;
4593 0 0       0 defined $matches[0] or undef @matches;
4594             } else {
4595 0         0 $self->Warn("Invalid tag name '${tag}'");
4596             }
4597 869 100 66     5900 if (defined $group and not $allGrp) {
4598             # keep only specified group
4599 234         861 @matches = $self->GroupMatches($group, \@matches);
4600 234 100 100     1125 next unless @matches or not $allTag;
4601             }
4602 854 100       3273 if (@matches > 1) {
    100          
4603             # maintain original file order for multiple tags
4604 143         914 @matches = sort { $$fileOrder{$a} <=> $$fileOrder{$b} } @matches;
  7692         10877  
4605             # return only the highest priority tag unless duplicates wanted
4606 143 50 66     705 unless ($doDups or $allTag or $allGrp) {
      33        
4607 0         0 $tag = shift @matches;
4608 0   0     0 my $oldPriority = $$self{PRIORITY}{$tag} || 1;
4609 0         0 foreach (@matches) {
4610 0         0 my $priority = $$self{PRIORITY}{$_};
4611 0 0       0 $priority = 1 unless defined $priority;
4612 0 0       0 next unless $priority >= $oldPriority;
4613 0         0 $tag = $_;
4614 0   0     0 $oldPriority = $priority || 1;
4615             }
4616 0         0 @matches = ( $tag );
4617             }
4618             } elsif (not @matches) {
4619             # put entry in return list even without value (value is undef)
4620 443 100       1654 $matches[0] = $byValue ? "$tag #(0)" : "$tag (0)";
4621             # bogus file order entry to avoid warning if sorting in file order
4622 443         1557 $$self{FILE_ORDER}{$matches[0]} = 9999;
4623             }
4624             # save indices of tags extracted by value
4625 854 100       2331 push @byValue, scalar(@$rtnTags) .. (scalar(@$rtnTags)+scalar(@matches)-1) if $byValue;
4626             # save indices of wildcard tags
4627 854 100       2580 push @wildTags, scalar(@$rtnTags) .. (scalar(@$rtnTags)+scalar(@matches)-1) if $allTag;
4628 854         3094 push @$rtnTags, @matches;
4629             }
4630             } else {
4631             # no requested tags, so we want all tags
4632 334         717 my @allTags;
4633 334 50       1331 if ($doDups) {
4634 334         811 @allTags = keys %{$$self{VALUE}};
  334         8861  
4635             } else {
4636             # only include tag if it doesn't end in a copy number
4637 0         0 @allTags = grep(!/ /, keys %{$$self{VALUE}});
  0         0  
4638             }
4639 334         1350 $rtnTags = \@allTags;
4640             }
4641              
4642             # filter excluded tags and group options
4643 690   100     5366 while (($exclude or @groupOptions) and @$rtnTags) {
      66        
4644 68 100       243 if ($exclude) {
4645 41         93 my ($pat, %exclude);
4646 41         166 foreach $pat (@$exclude) {
4647 57         106 my $group;
4648 57 100       330 if ($pat =~ /^(.*):(.+)/) {
4649 30         158 ($group, $tag) = ($1, $2);
4650 30 50       260 if ($group =~ /^(\*|all)$/i) {
    50          
4651 0         0 undef $group;
4652             } elsif ($group !~ /^[-\w:]*$/) {
4653 0         0 $self->Warn("Invalid group name '${group}'");
4654 0         0 $group = 'invalid';
4655             }
4656             } else {
4657 27         61 $tag = $pat;
4658             }
4659 57         115 my @matches;
4660 57 100       259 if ($tag =~ /^(\*|all)$/i) {
4661 30         226 @matches = @$rtnTags;
4662             } else {
4663             # allow wildcards in tag names
4664 27         70 $tag =~ s/\*/[-\\w]*/g;
4665 27         59 $tag =~ s/\?/[-\\w]/g;
4666 27         2761 @matches = grep(/^$tag( |$)/i, @$rtnTags);
4667             }
4668 57 100 66     417 @matches = $self->GroupMatches($group, \@matches) if $group and @matches;
4669 57         534 $exclude{$_} = 1 foreach @matches;
4670             }
4671 41 50       175 if (%exclude) {
4672             # remove excluded tags from return list(s)
4673 41         258 RemoveTagsFromList($rtnTags, \@byValue, \@wildTags, \%exclude);
4674 41 50       181 last unless @$rtnTags; # all done if nothing left
4675             }
4676 41 100 66     310 last if $duplicates and not @groupOptions;
4677             }
4678             # filter groups if requested, or to remove duplicates
4679 28         71 my (%keepTags, %wantGroup, $family, $groupOpt);
4680 28         59 my $allGroups = 1;
4681             # build hash of requested/excluded group names for each group family
4682 28         58 my $wantOrder = 0;
4683 28         64 foreach $groupOpt (@groupOptions) {
4684 29 50       191 $groupOpt =~ /^Group(\d*(:\d+)*)/ or next;
4685 29   100     138 $family = $1 || 0;
4686 29 50       127 $wantGroup{$family} or $wantGroup{$family} = { };
4687 29         53 my $groupList;
4688 29 100       101 if (ref $$options{$groupOpt} eq 'ARRAY') {
4689 4         12 $groupList = $$options{$groupOpt};
4690             } else {
4691 25         69 $groupList = [ $$options{$groupOpt} ];
4692             }
4693 29         81 foreach (@$groupList) {
4694             # groups have priority in order they were specified
4695 33         62 ++$wantOrder;
4696 33         64 my ($groupName, $want);
4697 33 100       103 if (/^-(.*)/) {
4698             # excluded group begins with '-'
4699 2         6 $groupName = $1;
4700 2         5 $want = 0; # we don't want tags in this group
4701             } else {
4702 31         54 $groupName = $_;
4703 31         46 $want = $wantOrder; # we want tags in this group
4704 31         60 $allGroups = 0; # don't want all groups if we requested one
4705             }
4706 33         126 $wantGroup{$family}{$groupName} = $want;
4707             }
4708             }
4709             # loop through all tags and decide which ones we want
4710 28         54 my (@tags, %bestTag);
4711 28         68 GR_TAG: foreach $tag (@$rtnTags) {
4712 4505         5649 my $wantTag = $allGroups; # want tag by default if want all groups
4713 4505         8580 foreach $family (keys %wantGroup) {
4714 4591         8071 my $group = $self->GetGroup($tag, $family);
4715 4591         7948 my $wanted = $wantGroup{$family}{$group};
4716 4591 100       9030 next unless defined $wanted;
4717 1153 100       1924 next GR_TAG unless $wanted; # skip tag if group excluded
4718             # take lowest non-zero want flag
4719 976 50 33     1774 next if $wantTag and $wantTag < $wanted;
4720 976         1567 $wantTag = $wanted;
4721             }
4722 4328 100       8102 next unless $wantTag;
4723 1047 100       1966 $duplicates and $keepTags{$tag} = 1, next;
4724             # determine which tag we want to keep
4725 665         1031 my $tagName = GetTagName($tag);
4726 665         1116 my $bestTag = $bestTag{$tagName};
4727 665 100       1132 if (defined $bestTag) {
4728 28 100       86 next if $wantTag > $keepTags{$bestTag};
4729 16 50       47 if ($wantTag == $keepTags{$bestTag}) {
4730             # want two tags with the same name -- keep the latest one
4731 0 0       0 if ($tag =~ / \((\d+)\)$/) {
4732 0         0 my $tagNum = $1;
4733 0 0 0     0 next if $bestTag !~ / \((\d+)\)$/ or $1 > $tagNum;
4734             }
4735             }
4736             # this tag is better, so delete old best tag
4737 16         46 delete $keepTags{$bestTag};
4738             }
4739 653         1029 $keepTags{$tag} = $wantTag; # keep this tag (for now...)
4740 653         1177 $bestTag{$tagName} = $tag; # this is our current best tag
4741             }
4742             # include only tags we want to keep in return lists
4743 28         155 RemoveTagsFromList($rtnTags, \@byValue, \@wildTags, \%keepTags, 1);
4744 28         222 last;
4745             }
4746 690         2554 $$self{FOUND_TAGS} = $rtnTags; # save found tags
4747              
4748             # return reference to found tag keys (and list of indices of tags to extract by value)
4749 690 50       4509 return wantarray ? ($rtnTags, \@byValue, \@wildTags) : $rtnTags;
4750             }
4751              
4752             #------------------------------------------------------------------------------
4753             # Utility to load our write routines if required (called via AUTOLOAD)
4754             # Inputs: 0) autoload function, 1-N) function arguments
4755             # Returns: result of function or dies if function not available
4756             sub DoAutoLoad(@)
4757             {
4758 721     721 0 2134 my $autoload = shift;
4759 721         4478 my @callInfo = split(/::/, $autoload);
4760 721         2071 my $file = 'Image/ExifTool/Write';
4761              
4762 721 100       143193 return if $callInfo[$#callInfo] eq 'DESTROY';
4763 246 100       1183 if (@callInfo == 4) {
    100          
4764             # load Image/ExifTool/WriteMODULE.pl
4765 187         661 $file .= "$callInfo[2].pl";
4766             } elsif ($callInfo[-1] eq 'ShiftTime') {
4767 1         3 $file = 'Image/ExifTool/Shift.pl'; # load Shift.pl
4768             } else {
4769             # load Image/ExifTool/Writer.pl
4770 58         204 $file .= 'r.pl';
4771             }
4772             # attempt to load the package
4773 246 50       657 eval { require $file } or die "Error while attempting to call $autoload\n$@\n";
  246         249665  
4774 246 50       2074 unless (defined &$autoload) {
4775 0         0 my @caller = caller(0);
4776             # reproduce Perl's standard 'undefined subroutine' message:
4777 0         0 die "Undefined subroutine $autoload called at $caller[1] line $caller[2]\n";
4778             }
4779 105     105   1259 no strict 'refs';
  105         271  
  105         134446  
4780 246         1691 return &$autoload(@_); # call the function
4781             }
4782              
4783             #------------------------------------------------------------------------------
4784             # AutoLoad our writer routines when necessary
4785             #
4786             sub AUTOLOAD
4787             {
4788 534     534   362727 return DoAutoLoad($AUTOLOAD, @_);
4789             }
4790              
4791             #------------------------------------------------------------------------------
4792             # Add warning tag
4793             # Inputs: 0) ExifTool object reference, 1) warning message
4794             # 2) true if minor (2 if behaviour changes when warning is ignored,
4795             # or 3 if warning shouldn't be issued when Validate option is used)
4796             # Returns: true if warning tag was added
4797             sub Warn($$;$)
4798             {
4799 87     87 0 298 my ($self, $str, $ignorable) = @_;
4800 87 100       334 if ($ignorable) {
4801 32 100       145 return 0 if $$self{OPTIONS}{IgnoreMinorErrors};
4802 31 50 66     165 return 0 if $ignorable eq '3' and $$self{OPTIONS}{Validate};
4803 31 100       180 $str = $ignorable eq '2' ? "[Minor] $str" : "[minor] $str";
4804             }
4805 86         420 $self->FoundTag('Warning', $str);
4806 86         336 return 1;
4807             }
4808              
4809             #------------------------------------------------------------------------------
4810             # Add warning tag only once per processed file
4811             # Inputs: 0) ExifTool object reference, 1) warning message, 2) true if minor
4812             # Returns: true if warning tag was added
4813             sub WarnOnce($$;$)
4814             {
4815 48     48 0 167 my ($self, $str, $ignorable) = @_;
4816 48 50 66     234 return 0 if $ignorable and $$self{OPTIONS}{IgnoreMinorErrors};
4817 48 100       251 unless ($$self{WARNED_ONCE}{$str}) {
4818 41         280 $self->Warn($str, $ignorable);
4819 41         176 $$self{WARNED_ONCE}{$str} = 1;
4820             }
4821 48         174 return 1;
4822             }
4823              
4824             #------------------------------------------------------------------------------
4825             # Add error tag
4826             # Inputs: 0) ExifTool object reference, 1) error message, 2) true if minor
4827             # Returns: true if error tag was added, otherwise warning was added
4828             sub Error($$;$)
4829             {
4830 1     1 0 4 my ($self, $str, $ignorable) = @_;
4831 1 50       9 if ($$self{DemoteErrors}) {
    50          
4832 0 0       0 $self->Warn($str) and ++$$self{DemoteErrors};
4833 0         0 return 1;
4834             } elsif ($ignorable) {
4835 1 50       8 $$self{OPTIONS}{IgnoreMinorErrors} and $self->Warn($str), return 0;
4836 0         0 $str = "[minor] $str";
4837             }
4838 0         0 $self->FoundTag('Error', $str);
4839 0         0 return 1;
4840             }
4841              
4842             #------------------------------------------------------------------------------
4843             # Expand shortcuts
4844             # Inputs: 0) reference to list of tags, 1) set to remove trailing '#'
4845             # Notes: Handles leading '-' for excluded tags, trailing '#' for ValueConv,
4846             # multiple group names, and redirected tags
4847             sub ExpandShortcuts($;$)
4848             {
4849 504     504 0 1471 my ($tagList, $removeSuffix) = @_;
4850 504 50 33     2664 return unless $tagList and @$tagList;
4851              
4852 504         30226 require Image::ExifTool::Shortcuts;
4853              
4854             # expand shortcuts
4855 504 100       1867 my $suffix = $removeSuffix ? '' : '#';
4856 504         1082 my @expandedTags;
4857 504         1119 my ($entry, $tag, $excl);
4858 504         1357 foreach $entry (@$tagList) {
4859             # skip things like options hash references in list
4860 1025 100       2558 if (ref $entry) {
4861 1         4 push @expandedTags, $entry;
4862 1         3 next;
4863             }
4864             # remove leading '-'
4865 1024         5568 ($excl, $tag) = $entry =~ /^(-?)(.*)/s;
4866 1024         2199 my ($post, @post, $pre, $v);
4867             # handle redirection
4868 1024 100 100     10744 if (not $excl and $tag =~ /(.+?)([-+]?[<>].+)/s) {
4869 23         116 ($tag, $post) = ($1, $2);
4870 23 100 100     192 if ($post =~ /^[-+]?>/ or $post !~ /\$/) {
4871             # expand shortcuts in postfix (rhs of redirection)
4872 18         124 my ($op, $p2, $t2) = ($post =~ /([-+]?[<>])(.+:)?(.+)/);
4873 18 100       81 $p2 = '' unless defined $p2;
4874 18 50       81 $v = ($t2 =~ s/#$//) ? $suffix : ''; # ValueConv suffix
4875 18         371 my ($match) = grep /^\Q$t2\E$/i, keys %Image::ExifTool::Shortcuts::Main;
4876 18 50       94 if ($match) {
4877 0         0 foreach (@{$Image::ExifTool::Shortcuts::Main{$match}}) {
  0         0  
4878 0 0       0 /^-/ and next; # ignore excluded tags
4879 0 0 0     0 if ($p2 and /(.+:)(.+)/) {
4880 0         0 push @post, "$op$_$v";
4881             } else {
4882 0         0 push @post, "$op$p2$_$v";
4883             }
4884             }
4885 0 0       0 next unless @post;
4886 0         0 $post = shift @post;
4887             }
4888             }
4889             } else {
4890 1001         2105 $post = '';
4891             }
4892             # handle group names
4893 1024 100       3323 if ($tag =~ /(.+:)(.+)/) {
4894 298         1204 ($pre, $tag) = ($1, $2);
4895             } else {
4896 726         1322 $pre = '';
4897             }
4898 1024 100       2862 $v = ($tag =~ s/#$//) ? $suffix : ''; # ValueConv suffix
4899             # loop over all postfixes
4900 1024         1801 for (;;) {
4901             # expand the tag name
4902 1024         20959 my ($match) = grep /^\Q$tag\E$/i, keys %Image::ExifTool::Shortcuts::Main;
4903 1024 100       3581 if ($match) {
4904 17 50 66     172 if ($excl) {
    100 66        
4905             # entry starts with '-', so exclude all tags in this shortcut
4906 0         0 foreach (@{$Image::ExifTool::Shortcuts::Main{$match}}) {
  0         0  
4907 0 0       0 /^-/ and next; # ignore excluded exclude tags
4908             # group of expanded tag takes precedence
4909 0 0 0     0 if ($pre and /(.+:)(.+)/) {
4910 0         0 push @expandedTags, "$excl$_";
4911             } else {
4912 0         0 push @expandedTags, "$excl$pre$_";
4913             }
4914             }
4915             } elsif (length $pre or length $post or $v) {
4916 1         3 foreach (@{$Image::ExifTool::Shortcuts::Main{$match}}) {
  1         5  
4917 12         35 /(-?)(.+:)?(.+)/;
4918 12 50       25 if ($2) {
4919             # group from expanded tag takes precedence
4920 0         0 push @expandedTags, "$_$v$post";
4921             } else {
4922 12         38 push @expandedTags, "$1$pre$3$v$post";
4923             }
4924             }
4925             } else {
4926 16         32 push @expandedTags, @{$Image::ExifTool::Shortcuts::Main{$match}};
  16         60  
4927             }
4928             } else {
4929 1007         3431 push @expandedTags, "$excl$pre$tag$v$post";
4930             }
4931 1024 50       3750 last unless @post;
4932 0         0 $post = shift @post;
4933             }
4934             }
4935 504         2325 @$tagList = @expandedTags;
4936             }
4937              
4938             #------------------------------------------------------------------------------
4939             # Add hash of Composite tags to our composites
4940             # Inputs: 0) hash reference to table of Composite tags to add or module name,
4941             # 1) override existing tag definition
4942             sub AddCompositeTags($;$)
4943             {
4944 584     584 0 1855 local $_;
4945 584         2414 my ($add, $override) = @_;
4946 584         1563 my ($module, $prefix, $tagID);
4947 584 50       2873 unless (ref $add) {
4948 584         7297 ($prefix = $add) =~ s/.*:://;
4949 584         1676 $module = $add;
4950 584         2051 $add .= '::Composite';
4951 105     105   931 no strict 'refs';
  105         315  
  105         960675  
4952 584         3221 $add = \%$add;
4953 584         1776 $prefix .= '-';
4954             } else {
4955 0         0 $prefix = 'UserDefined-';
4956             }
4957 584         1929 my $defaultGroups = $$add{GROUPS};
4958 584         2787 my $compTable = GetTagTable('Image::ExifTool::Composite');
4959              
4960             # make sure default groups are defined in families 0 and 1
4961 584 100       2043 if ($defaultGroups) {
4962 490 100       2482 $$defaultGroups{0} or $$defaultGroups{0} = 'Composite';
4963 490 100       2069 $$defaultGroups{1} or $$defaultGroups{1} = 'Composite';
4964 490 50       1954 $$defaultGroups{2} or $$defaultGroups{2} = 'Other';
4965             } else {
4966 94         632 $defaultGroups = $$add{GROUPS} = { 0 => 'Composite', 1 => 'Composite', 2 => 'Other' };
4967             }
4968 584         2370 SetupTagTable($add); # generate Name, TagID, etc
4969 584         6046 foreach $tagID (sort keys %$add) {
4970 5678 100       12156 next if $specialTags{$tagID}; # must skip special tags
4971 5091         7751 my $tagInfo = $$add{$tagID};
4972 5091         11290 my $new = $prefix . $tagID; # new tag ID for Composite table
4973 5091 100       10373 $$tagInfo{Module} = $module if $$tagInfo{Writable};
4974 5091 50 33     10046 $$tagInfo{Override} = 1 if $override and not defined $$tagInfo{Override};
4975 5091         9448 $$tagInfo{IsComposite} = 1;
4976             # handle Composite tags with the same name
4977 5091 100       11002 if ($compositeID{$tagID}) {
4978             # determine if we want to override this tag
4979             # (=0 keep both, >0 override, <0 keep existing)
4980 337   50     3767 my $over = ($$tagInfo{Override} || 0) - ($$compTable{$compositeID{$tagID}[0]}{Override} || 0);
      50        
4981 337 50       1153 next if $over < 0;
4982 337 50       1491 if ($over) {
4983             # remove existing tags with this ID
4984 0         0 delete $$compTable{$_} foreach @{$compositeID{$tagID}};
  0         0  
4985 0         0 delete $compositeID{$tagID};
4986             }
4987             }
4988             # make sure new TagID is unique by adding index if necessary
4989             # (could only happen for UserDefined tags now that module name is added to tag ID)
4990 5091         6926 my $n = 0;
4991 5091         11303 while ($$compTable{$new}) {
4992 0 0       0 $new =~ s/-\d+$// if $n++;
4993 0         0 $new .= "-$n";
4994             }
4995             # use new ID and save it so we can use it in TagLookup
4996 5091 50       13111 $$tagInfo{NewTagID} = $new unless $tagID eq $new;
4997              
4998             # add new ID to lookup of Composite tag ID's
4999 5091 100       13886 $compositeID{$tagID} = [ ] unless $compositeID{$tagID};
5000 5091         7284 unshift @{$compositeID{$tagID}}, $new; # (most recent one first)
  5091         12692  
5001              
5002             # convert scalar Require/Desire/Inhibit entries
5003 5091         8344 my ($type, @hashes, @scalars, %used);
5004 5091         8083 foreach $type ('Require','Desire','Inhibit') {
5005 15273 100       32146 my $req = $$tagInfo{$type} or next;
5006 6568 100       8482 push @{ref($req) eq 'HASH' ? \@hashes : \@scalars}, $type;
  6568         17791  
5007             }
5008 5091 100       10181 if (@scalars) {
5009             # make lookup for indices that are used
5010 949         2068 foreach $type (@hashes) {
5011 105         369 $used{$_} = 1 foreach keys %{$$tagInfo{$type}};
  105         1548  
5012             }
5013 949         1596 my $next = 0;
5014 949         1769 foreach $type (@scalars) {
5015 949         2424 ++$next while $used{$next};
5016 949         3592 $$tagInfo{$type} = { $next++ => $$tagInfo{$type} };
5017             }
5018             }
5019             # add this Composite tag to our main Composite table
5020 5091         8198 $$tagInfo{Table} = $compTable;
5021             # (use the original TagID, even if we changed it, so don't do this:)
5022 5091         7692 $$tagInfo{TagID} = $new;
5023             # save tag under new ID in Composite table
5024 5091         13275 $$compTable{$new} = $tagInfo;
5025             # set all default groups in tag
5026 5091         7647 my $groups = $$tagInfo{Groups};
5027 5091 100       11521 $groups or $groups = $$tagInfo{Groups} = { };
5028             # fill in default groups
5029 5091         12257 foreach (keys %$defaultGroups) {
5030 15273 100       33865 $$groups{$_} or $$groups{$_} = $$defaultGroups{$_};
5031             }
5032             # set flag indicating group list was built
5033 5091         14307 $$tagInfo{GotGroups} = 1;
5034             }
5035             }
5036              
5037             #------------------------------------------------------------------------------
5038             # Add tags to TagLookup (used for writing)
5039             # Inputs: 0) source hash of tag definitions, 1) name of destination tag table
5040             sub AddTagsToLookup($$)
5041             {
5042 1     1 0 4 my ($tagHash, $table) = @_;
5043 1 50       7 if (defined &Image::ExifTool::TagLookup::AddTags) {
    50          
5044 0         0 Image::ExifTool::TagLookup::AddTags($tagHash, $table);
5045             } elsif (not $Image::ExifTool::pluginTags{$tagHash}) {
5046             # queue these tags until TagLookup is loaded
5047 1         3 push @Image::ExifTool::pluginTags, [ $tagHash, $table ];
5048             # set flag so we don't load same tags twice
5049 1         4 $Image::ExifTool::pluginTags{$tagHash} = 1;
5050             }
5051             }
5052              
5053             #------------------------------------------------------------------------------
5054             # Expand tagInfo Flags
5055             # Inputs: 0) tagInfo hash ref
5056             # Notes: $$tagInfo{Flags} must be defined to call this routine
5057             sub ExpandFlags($)
5058             {
5059 4660     4660 0 7131 my $tagInfo = shift;
5060 4660         7298 my $flags = $$tagInfo{Flags};
5061 4660 100       10810 if (ref $flags eq 'ARRAY') {
    50          
5062 2352         5057 foreach (@$flags) {
5063 6247         13891 $$tagInfo{$_} = 1;
5064             }
5065             } elsif (ref $flags eq 'HASH') {
5066 0         0 my $key;
5067 0         0 foreach $key (keys %$flags) {
5068 0         0 $$tagInfo{$key} = $$flags{$key};
5069             }
5070             } else {
5071 2308         5693 $$tagInfo{$flags} = 1;
5072             }
5073             }
5074              
5075             #------------------------------------------------------------------------------
5076             # Set up tag table (must be done once for each tag table used)
5077             # Inputs: 0) Reference to tag table
5078             # Notes: - generates 'Name' field from key if it doesn't exist
5079             # - stores 'Table' pointer and 'TagID' value
5080             # - expands 'Flags' for quick lookup
5081             sub SetupTagTable($)
5082             {
5083 5096     5096 0 8948 my $tagTablePtr = shift;
5084 5096         9342 my $avoid = $$tagTablePtr{AVOID};
5085 5096         9204 my ($tagID, $tagInfo);
5086 5096         11646 foreach $tagID (TagTableKeys($tagTablePtr)) {
5087 203828         315545 my @infoArray = GetTagInfoList($tagTablePtr,$tagID);
5088             # process conditional tagInfo arrays
5089 203828         296987 foreach $tagInfo (@infoArray) {
5090 224183         398816 $$tagInfo{Table} = $tagTablePtr;
5091 224183         346334 $$tagInfo{TagID} = $tagID;
5092 224183 100       426359 $$tagInfo{Name} or $$tagInfo{Name} = MakeTagName($tagID);
5093 224183 100       381505 $$tagInfo{Flags} and ExpandFlags($tagInfo);
5094 224183 100       362542 $$tagInfo{Avoid} = $avoid if defined $avoid;
5095             # calculate BitShift from Mask if necessary
5096 224183 100 100     438905 if ($$tagInfo{Mask} and not defined $$tagInfo{BitShift}) {
5097 3027         5279 my ($mask, $bitShift) = ($$tagInfo{Mask}, 0);
5098 3027         9462 ++$bitShift until $mask & (1 << $bitShift);
5099 3027         6170 $$tagInfo{BitShift} = $bitShift;
5100             }
5101             }
5102 203828 100       413062 next unless @infoArray > 1;
5103             # add an "Index" member to each tagInfo in a list
5104 3679         6381 my $index = 0;
5105 3679         5855 foreach $tagInfo (@infoArray) {
5106 24034         39226 $$tagInfo{Index} = $index++;
5107             }
5108             }
5109             }
5110              
5111             #------------------------------------------------------------------------------
5112             # Utilities to check for numerical types
5113             # Inputs: 0) value; Returns: true if value is a numerical type
5114             # Notes: May change commas to decimals in floats for use in other locales
5115             sub IsFloat($) {
5116 7788 100   7788 0 83170 return 1 if $_[0] =~ /^[+-]?(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/;
5117             # allow comma separators (for other locales)
5118 2185 50       17516 return 0 unless $_[0] =~ /^[+-]?(?=\d|,\d)\d*(,\d*)?([Ee]([+-]?\d+))?$/;
5119 0         0 $_[0] =~ tr/,/./; # but translate ',' to '.'
5120 0         0 return 1;
5121             }
5122 19683     19683 0 98561 sub IsInt($) { return scalar($_[0] =~ /^[+-]?\d+$/); }
5123 3047     3047 0 12736 sub IsHex($) { return scalar($_[0] =~ /^(0x)?[0-9a-f]{1,8}$/i); }
5124 16     16 0 837 sub IsRational($) { return scalar($_[0] =~ m{^[-+]?\d+/\d+$}); }
5125              
5126             # round floating point value to specified number of significant digits
5127             # Inputs: 0) value, 1) number of sig digits; Returns: rounded number
5128             sub RoundFloat($$)
5129             {
5130 3364     3364 0 6410 my ($val, $sig) = @_;
5131 3364         23454 return sprintf("%.${sig}g", $val);
5132             }
5133              
5134             # Convert strings to floating point numbers (or undef)
5135             # Inputs: 0-N) list of strings (may be undef)
5136             # Returns: last value converted
5137             sub ToFloat(@)
5138             {
5139 968     968 0 1973 local $_;
5140 968         2503 foreach (@_) {
5141 10463 100       19488 next unless defined $_;
5142             # (add 0 to convert "0.0" to "0" for tests)
5143 3909 100       22405 $_ = /((?:[+-]?)(?=\d|\.\d)\d*(?:\.\d*)?(?:[Ee](?:[+-]?\d+))?)/ ? $1 + 0 : undef;
5144             }
5145 968         10320 return $_[-1];
5146             }
5147              
5148             #------------------------------------------------------------------------------
5149             # Utility routines to for reading binary data values from file
5150              
5151             my %unpackMotorola = ( S => 'n', L => 'N', C => 'C', c => 'c' );
5152             my %unpackIntel = ( S => 'v', L => 'V', C => 'C', c => 'c' );
5153             my %unpackRev = ( N => 'V', V => 'N', C => 'C', n => 'v', v => 'n', c => 'c' );
5154              
5155             # the following 4 variables are defined in 'use vars' instead of using 'my'
5156             # because mod_perl 5.6.1 apparently has a problem with setting file-scope 'my'
5157             # variables from within subroutines (ref communication with Pavel Merdin):
5158             # $swapBytes - set if EXIF header is not native byte ordering
5159             # $swapWords - swap 32-bit words in doubles (ARM quirk)
5160             $currentByteOrder = 'MM'; # current byte ordering ('II' or 'MM')
5161             %unpackStd = %unpackMotorola;
5162              
5163             # Swap bytes in data if necessary
5164             # Inputs: 0) data, 1) number of bytes
5165             # Returns: swapped data
5166             sub SwapBytes($$)
5167             {
5168 1360 100   1360 0 3749 return $_[0] unless $swapBytes;
5169 206         508 my ($val, $bytes) = @_;
5170 206         385 my $newVal = '';
5171 206         1478 $newVal .= substr($val, $bytes, 1) while $bytes--;
5172 206         590 return $newVal;
5173             }
5174             # Swap words. Inputs: 8 bytes of data, Returns: swapped data
5175             sub SwapWords($)
5176             {
5177 1299 50 33 1299 0 4911 return $_[0] unless $swapWords and length($_[0]) == 8;
5178 0         0 return substr($_[0],4,4) . substr($_[0],0,4)
5179             }
5180              
5181             # Unpack value, letting unpack() handle byte swapping
5182             # Inputs: 0) unpack template, 1) data reference, 2) offset
5183             # Returns: unpacked number
5184             # - uses value of %unpackStd to determine the unpack template
5185             # - can only be called for 'S' or 'L' templates since these are the only
5186             # templates for which you can specify the byte ordering.
5187             sub DoUnpackStd(@)
5188             {
5189 156736 100   156736 0 390856 $_[2] and return unpack("x$_[2] $unpackStd{$_[0]}", ${$_[1]});
  152348         395471  
5190 4388         8163 return unpack($unpackStd{$_[0]}, ${$_[1]});
  4388         14327  
5191             }
5192             # same, but with reversed byte order
5193             sub DoUnpackRev(@)
5194             {
5195 12     12 0 26 my $fmt = $unpackRev{$unpackStd{$_[0]}};
5196 12 50       38 $_[2] and return unpack("x$_[2] $fmt", ${$_[1]});
  12         35  
5197 0         0 return unpack($fmt, ${$_[1]});
  0         0  
5198             }
5199             # Pack value
5200             # Inputs: 0) template, 1) value, 2) data ref (or undef), 3) offset (if data ref)
5201             # Returns: packed value
5202             sub DoPackStd(@)
5203             {
5204 32029     32029 0 65873 my $val = pack($unpackStd{$_[0]}, $_[1]);
5205 32029 100       56844 $_[2] and substr(${$_[2]}, $_[3], length($val)) = $val;
  7739         13975  
5206 32029         79341 return $val;
5207             }
5208             # same, but with reversed byte order
5209             sub DoPackRev(@)
5210             {
5211 0     0 0 0 my $val = pack($unpackRev{$unpackStd{$_[0]}}, $_[1]);
5212 0 0       0 $_[2] and substr(${$_[2]}, $_[3], length($val)) = $val;
  0         0  
5213 0         0 return $val;
5214             }
5215              
5216             # Unpack value, handling the byte swapping manually
5217             # Inputs: 0) # bytes, 1) unpack template, 2) data reference, 3) offset
5218             # Returns: unpacked number
5219             # - uses value of $swapBytes to determine byte ordering
5220             sub DoUnpack(@)
5221             {
5222 27150     27150 0 47056 my ($bytes, $template, $dataPt, $pos) = @_;
5223 27150         34054 my $val;
5224 27150 100       43608 if ($swapBytes) {
5225 5384         7522 $val = '';
5226 5384         23020 $val .= substr($$dataPt,$pos+$bytes,1) while $bytes--;
5227             } else {
5228 21766         37362 $val = substr($$dataPt,$pos,$bytes);
5229             }
5230 27150 50       48770 defined($val) or return undef;
5231 27150         63844 return unpack($template,$val);
5232             }
5233              
5234             # Unpack double value
5235             # Inputs: 0) unpack template, 1) data reference, 2) offset
5236             # Returns: unpacked number
5237             sub DoUnpackDbl(@)
5238             {
5239 1236     1236 0 2223 my ($template, $dataPt, $pos) = @_;
5240 1236         2325 my $val = substr($$dataPt,$pos,8);
5241 1236 50       2251 defined($val) or return undef;
5242             # swap bytes and 32-bit words (ARM quirk) if necessary, then unpack value
5243 1236         2309 return unpack($template, SwapWords(SwapBytes($val, 8)));
5244             }
5245              
5246             # Inputs: 0) data reference, 1) offset into data
5247 129     129 0 394 sub Get8s($$) { return DoUnpackStd('c', @_); }
5248 7706     7706 0 14829 sub Get8u($$) { return DoUnpackStd('C', @_); }
5249 14471     14471 0 27150 sub Get16s($$) { return DoUnpack(2, 's', @_); }
5250 75822     75822 0 136001 sub Get16u($$) { return DoUnpackStd('S', @_); }
5251 12036     12036 0 21393 sub Get32s($$) { return DoUnpack(4, 'l', @_); }
5252 73079     73079 0 126951 sub Get32u($$) { return DoUnpackStd('L', @_); }
5253 643     643 0 1732 sub GetFloat($$) { return DoUnpack(4, 'f', @_); }
5254 1236     1236 0 2517 sub GetDouble($$) { return DoUnpackDbl('d', @_); }
5255 12     12 0 31 sub Get16uRev($$) { return DoUnpackRev('S', @_); }
5256 0     0 0 0 sub Get32uRev($$) { return DoUnpackRev('L', @_); }
5257              
5258             # rationals may be a floating point number, 'inf' or 'undef'
5259             my ($ratNumer, $ratDenom);
5260             sub GetRational32s($$)
5261             {
5262 12     12 0 30 my ($dataPt, $pos) = @_;
5263 12         31 $ratNumer = Get16s($dataPt,$pos);
5264 12 0       29 $ratDenom = Get16s($dataPt, $pos + 2) or return $ratNumer ? 'inf' : 'undef';
    50          
5265             # round off to a reasonable number of significant figures
5266 12         35 return RoundFloat($ratNumer / $ratDenom, 7);
5267             }
5268             sub GetRational32u($$)
5269             {
5270 12     12 0 25 my ($dataPt, $pos) = @_;
5271 12         31 $ratNumer = Get16u($dataPt,$pos);
5272 12 0       34 $ratDenom = Get16u($dataPt, $pos + 2) or return $ratNumer ? 'inf' : 'undef';
    50          
5273 12         45 return RoundFloat($ratNumer / $ratDenom, 7);
5274             }
5275             sub GetRational64s($$)
5276             {
5277 654     654 0 1713 my ($dataPt, $pos) = @_;
5278 654         1537 $ratNumer = Get32s($dataPt,$pos);
5279 654 0       2195 $ratDenom = Get32s($dataPt, $pos + 4) or return $ratNumer ? 'inf' : 'undef';
    50          
5280 654         2042 return RoundFloat($ratNumer / $ratDenom, 10);
5281             }
5282             sub GetRational64u($$)
5283             {
5284 2703     2703 0 5180 my ($dataPt, $pos) = @_;
5285 2703         4956 $ratNumer = Get32u($dataPt,$pos);
5286 2703 50       6346 $ratDenom = Get32u($dataPt, $pos + 4) or return $ratNumer ? 'inf' : 'undef';
    100          
5287 2686         8665 return RoundFloat($ratNumer / $ratDenom, 10);
5288             }
5289             sub GetFixed16s($$)
5290             {
5291 13     13 0 41 my ($dataPt, $pos) = @_;
5292 13         44 my $val = Get16s($dataPt, $pos) / 0x100;
5293 13 50       83 return int($val * 1000 + ($val<0 ? -0.5 : 0.5)) / 1000;
5294             }
5295             sub GetFixed16u($$)
5296             {
5297 0     0 0 0 my ($dataPt, $pos) = @_;
5298 0         0 return int((Get16u($dataPt, $pos) / 0x100) * 1000 + 0.5) / 1000;
5299             }
5300             sub GetFixed32s($$)
5301             {
5302 1754     1754 0 3023 my ($dataPt, $pos) = @_;
5303 1754         2965 my $val = Get32s($dataPt, $pos) / 0x10000;
5304             # remove insignificant digits
5305 1754 100       5222 return int($val * 1e5 + ($val>0 ? 0.5 : -0.5)) / 1e5;
5306             }
5307             sub GetFixed32u($$)
5308             {
5309 156     156 0 426 my ($dataPt, $pos) = @_;
5310             # remove insignificant digits
5311 156         404 return int((Get32u($dataPt, $pos) / 0x10000) * 1e5 + 0.5) / 1e5;
5312             }
5313             # Inputs: 0) value, 1) data ref, 2) offset
5314 5     5 0 18 sub Set8s(@) { return DoPackStd('c', @_); }
5315 291     291 0 664 sub Set8u(@) { return DoPackStd('C', @_); }
5316 12887     12887 0 22827 sub Set16u(@) { return DoPackStd('S', @_); }
5317 18846     18846 0 33640 sub Set32u(@) { return DoPackStd('L', @_); }
5318 0     0 0 0 sub Set16uRev(@) { return DoPackRev('S', @_); }
5319              
5320             #------------------------------------------------------------------------------
5321             # Get current byte order ('II' or 'MM')
5322 14005     14005 0 37999 sub GetByteOrder() { return $currentByteOrder; }
5323              
5324             #------------------------------------------------------------------------------
5325             # Set byte ordering
5326             # Inputs: 0) 'MM'=motorola, 'II'=intel (will translate 'BigEndian', 'LittleEndian')
5327             # Returns: 1 on success
5328             sub SetByteOrder($)
5329             {
5330 15159     15159 0 28970 my $order = shift;
5331              
5332 15159 100       35629 if ($order eq 'MM') { # big endian (Motorola)
    100          
    100          
    100          
5333 7856         36338 %unpackStd = %unpackMotorola;
5334             } elsif ($order eq 'II') { # little endian (Intel)
5335 7112         33172 %unpackStd = %unpackIntel;
5336             } elsif ($order =~ /^Big/i) {
5337 15         34 $order = 'MM';
5338 15         100 %unpackStd = %unpackMotorola;
5339             } elsif ($order =~ /^Little/i) {
5340 11         43 $order = 'II';
5341 11         84 %unpackStd = %unpackIntel;
5342             } else {
5343 165         641 return 0;
5344             }
5345 14994         38824 my $val = unpack('S','A ');
5346 14994         22440 my $nativeOrder;
5347 14994 50       33556 if ($val == 0x4120) { # big endian
    50          
5348 0         0 $nativeOrder = 'MM';
5349             } elsif ($val == 0x2041) { # little endian
5350 14994         23424 $nativeOrder = 'II';
5351             } else {
5352 0         0 warn sprintf("Unknown native byte order! (pattern %x)\n",$val);
5353 0         0 return 0;
5354             }
5355 14994         22252 $currentByteOrder = $order; # save current byte order
5356              
5357             # swap bytes if our native CPU byte ordering is not the same as the EXIF
5358 14994         24770 $swapBytes = ($order ne $nativeOrder);
5359              
5360             # little-endian ARM has big-endian words for doubles (thanks Riku Voipio)
5361             # (Note: Riku's patch checked for '0ff3', but I think it should be 'f03f' since
5362             # 1 is '000000000000f03f' on an x86 -- so check for both, but which is correct?)
5363 14994         22303 my $pack1d = pack('d', 1);
5364 14994   33     45825 $swapWords = ($pack1d eq "\0\0\x0f\xf3\0\0\0\0" or
5365             $pack1d eq "\0\0\xf0\x3f\0\0\0\0");
5366 14994         31666 return 1;
5367             }
5368              
5369             #------------------------------------------------------------------------------
5370             # Change byte order
5371             sub ToggleByteOrder()
5372             {
5373 39 100   39 0 131 SetByteOrder(GetByteOrder() eq 'II' ? 'MM' : 'II');
5374             }
5375              
5376             #------------------------------------------------------------------------------
5377             # hash lookups for reading values from data
5378             my %formatSize = (
5379             int8s => 1,
5380             int8u => 1,
5381             int16s => 2,
5382             int16u => 2,
5383             int16uRev => 2,
5384             int32s => 4,
5385             int32u => 4,
5386             int32uRev => 4,
5387             int64s => 8,
5388             int64u => 8,
5389             rational32s => 4,
5390             rational32u => 4,
5391             rational64s => 8,
5392             rational64u => 8,
5393             fixed16s => 2,
5394             fixed16u => 2,
5395             fixed32s => 4,
5396             fixed32u => 4,
5397             fixed64s => 8,
5398             float => 4,
5399             double => 8,
5400             extended => 10,
5401             unicode => 2,
5402             complex => 8,
5403             string => 1,
5404             binary => 1,
5405             'undef' => 1,
5406             ifd => 4,
5407             ifd64 => 8,
5408             ue7 => 1,
5409             );
5410             my %readValueProc = (
5411             int8s => \&Get8s,
5412             int8u => \&Get8u,
5413             int16s => \&Get16s,
5414             int16u => \&Get16u,
5415             int16uRev => \&Get16uRev,
5416             int32s => \&Get32s,
5417             int32u => \&Get32u,
5418             int32uRev => \&Get32uRev,
5419             int64s => \&Get64s,
5420             int64u => \&Get64u,
5421             rational32s => \&GetRational32s,
5422             rational32u => \&GetRational32u,
5423             rational64s => \&GetRational64s,
5424             rational64u => \&GetRational64u,
5425             fixed16s => \&GetFixed16s,
5426             fixed16u => \&GetFixed16u,
5427             fixed32s => \&GetFixed32s,
5428             fixed32u => \&GetFixed32u,
5429             fixed64s => \&GetFixed64s,
5430             float => \&GetFloat,
5431             double => \&GetDouble,
5432             extended => \&GetExtended,
5433             ifd => \&Get32u,
5434             ifd64 => \&Get64u,
5435             );
5436             # lookup for all rational types
5437             my %isRational = (
5438             rational32u => 1,
5439             rational32s => 1,
5440             rational64u => 1,
5441             rational64s => 1,
5442             );
5443 1515     1515 0 4518 sub FormatSize($) { return $formatSize{$_[0]}; }
5444              
5445             #------------------------------------------------------------------------------
5446             # Read value from binary data (with current byte ordering)
5447             # Inputs: 0) data reference, 1) value offset, 2) format string,
5448             # 3) number of values (or undef to use all data),
5449             # 4) valid data length relative to offset (or undef to use all data),
5450             # 5) optional pointer to returned rational
5451             # Returns: converted value, or undefined if data isn't there
5452             # or list of values in list context
5453             sub ReadValue($$$;$$$)
5454             {
5455 35372     35372 0 77747 my ($dataPt, $offset, $format, $count, $size, $ratPt) = @_;
5456              
5457 35372         64921 my $len = $formatSize{$format};
5458 35372 50       65536 unless ($len) {
5459 0         0 warn "Unknown format $format";
5460 0         0 $len = 1;
5461             }
5462 35372 50       65318 $size = length($$dataPt) - $offset unless defined $size;
5463 35372 100       62237 unless ($count) {
5464 1359 100 100     4933 return '' if defined $count or $size < $len;
5465 1330         2792 $count = int($size / $len);
5466             }
5467             # make sure entry is inside data
5468 35343 100       69192 if ($len * $count > $size) {
5469 3         14 $count = int($size / $len); # shorten count if necessary
5470 3 50       27 $count < 1 and return undef; # return undefined if no data
5471             }
5472 35340         49186 my @vals;
5473 35340         59211 my $proc = $readValueProc{$format};
5474 35340 100 100     99392 if (not $proc) {
    100          
5475             # handle undef/binary/string (also unsupported unicode/complex)
5476 6162         19205 $vals[0] = substr($$dataPt, $offset, $count * $len);
5477             # truncate string at null terminator if necessary
5478 6162 100       30406 $vals[0] =~ s/\0.*//s if $format eq 'string';
5479             } elsif ($isRational{$format} and $ratPt) {
5480             # store rationals separately as string fractions
5481 2994         4509 my @rat;
5482 2994         4663 for (;;) {
5483 3293         8082 push @vals, &$proc($dataPt, $offset);
5484 3293         9278 push @rat, "$ratNumer/$ratDenom";
5485 3293 100       8521 last if --$count <= 0;
5486 299         484 $offset += $len;
5487             }
5488 2994         8207 $$ratPt = join(' ',@rat);
5489             } else {
5490 26184         36673 for (;;) {
5491 48379         89140 push @vals, &$proc($dataPt, $offset);
5492 48379 100       101851 last if --$count <= 0;
5493 22195         29304 $offset += $len;
5494             }
5495             }
5496 35340 100       70622 return @vals if wantarray;
5497 34928 100       93885 return join(' ', @vals) if @vals > 1;
5498 31370         75399 return $vals[0];
5499             }
5500              
5501             #------------------------------------------------------------------------------
5502             # Decode string with specified encoding
5503             # Inputs: 0) ExifTool object ref, 1) string to decode
5504             # 2) source character set name (undef for current Charset)
5505             # 3) optional source byte order (2-byte and 4-byte fixed-width sets only)
5506             # 4) optional destination character set (defaults to Charset setting)
5507             # 5) optional destination byte order (2-byte and 4-byte fixed-width only)
5508             # Returns: string in destination encoding
5509             # Note: ExifTool ref may be undef if character both character sets are provided
5510             # (but in this case no warnings will be issued)
5511             sub Decode($$$;$$$)
5512             {
5513 6171     6171 0 14410 my ($self, $val, $from, $fromOrder, $to, $toOrder) = @_;
5514 6171 100       12409 $from or $from = $$self{OPTIONS}{Charset};
5515 6171 100       15848 $to or $to = $$self{OPTIONS}{Charset};
5516 6171 100 100     16455 if ($from ne $to and length $val) {
5517 1089         29233 require Image::ExifTool::Charset;
5518 1089         2583 my $cs1 = $Image::ExifTool::Charset::csType{$from};
5519 1089         1857 my $cs2 = $Image::ExifTool::Charset::csType{$to};
5520 1089 50 33     5450 if ($cs1 and $cs2 and not $cs2 & 0x002) {
    0 33        
5521             # treat as straight ASCII if no character will need remapping
5522 1089 100 100     4060 if (($cs1 | $cs2) & 0x680 or $val =~ /[\x80-\xff]/) {
5523 776         2445 my $uni = Image::ExifTool::Charset::Decompose($self, $val, $from, $fromOrder);
5524 776         2258 $val = Image::ExifTool::Charset::Recompose($self, $uni, $to, $toOrder);
5525             }
5526             } elsif ($self) {
5527 0 0       0 my $set = $cs1 ? $to : $from;
5528 0 0       0 unless ($$self{"DecodeWarn$set"}) {
5529 0         0 $self->Warn("Unsupported character set ($set)");
5530 0         0 $$self{"DecodeWarn$set"} = 1;
5531             }
5532             }
5533             }
5534 6171         16317 return $val;
5535             }
5536              
5537             #------------------------------------------------------------------------------
5538             # Encode string with specified encoding
5539             # Inputs: 0) ExifTool object ref, 1) string, 2) destination character set name,
5540             # 3) optional destination byte order (2-byte and 4-byte fixed-width sets only)
5541             # Returns: string in specified encoding
5542             sub Encode($$$;$)
5543             {
5544 59     59 0 206 my ($self, $val, $to, $toOrder) = @_;
5545 59         247 return $self->Decode($val, undef, undef, $to, $toOrder);
5546             }
5547              
5548             #------------------------------------------------------------------------------
5549             # Decode bit mask
5550             # Inputs: 0) value to decode, 1) Reference to hash for decoding (or undef)
5551             # 2) optional bits per word (defaults to 32)
5552             sub DecodeBits($$;$)
5553             {
5554 171     171 0 744 my ($vals, $lookup, $bits) = @_;
5555 171 100       614 $bits or $bits = 32;
5556 171         386 my ($val, $i, @bitList);
5557 171         372 my $num = 0;
5558 171         648 foreach $val (split ' ', $vals) {
5559 239         767 for ($i=0; $i<$bits; ++$i) {
5560 5952 100       12712 next unless $val & (1 << $i);
5561 139         313 my $n = $i + $num;
5562 139 100       550 if (not $lookup) {
    100          
5563 19         63 push @bitList, $n;
5564             } elsif ($$lookup{$n}) {
5565 114         363 push @bitList, $$lookup{$n};
5566             } else {
5567 6         20 push @bitList, "[$n]";
5568             }
5569             }
5570 239         713 $num += $bits;
5571             }
5572 171 100       940 return '(none)' unless @bitList;
5573 95 100       853 return join($lookup ? ', ' : ',', @bitList);
5574             }
5575              
5576             #------------------------------------------------------------------------------
5577             # Validate an extracted image and repair if necessary
5578             # Inputs: 0) ExifTool object reference, 1) image reference, 2) tag name or key
5579             # Returns: image reference or undef if it wasn't valid
5580             # Note: should be called from RawConv, not ValueConv
5581             sub ValidateImage($$$)
5582             {
5583 199     199 0 737 my ($self, $imagePt, $tag) = @_;
5584 199 50       778 return undef if $$imagePt eq 'none';
5585 199 100 66     1856 unless ($$imagePt =~ /^(Binary data|\xff\xd8\xff)/ or
      100        
5586             # the first byte of the preview of some Minolta cameras is wrong,
5587             # so check for this and set it back to 0xff if necessary
5588             $$imagePt =~ s/^.(\xd8\xff\xdb)/\xff$1/s or
5589             $self->Options('IgnoreMinorErrors'))
5590             {
5591             # issue warning only if the tag was specifically requested
5592 113 50       576 if ($$self{REQ_TAG_LOOKUP}{lc GetTagName($tag)}) {
5593 0         0 $self->Warn("$tag is not a valid JPEG image",1);
5594 0         0 return undef;
5595             }
5596             }
5597 199         2189 return $imagePt;
5598             }
5599              
5600             #------------------------------------------------------------------------------
5601             # Validate a tag name argument (including group name and wildcards, etc)
5602             # Inputs: 0) tag name
5603             # Returns: true if tag name is valid
5604             # - a tag name may contain [-_A-Za-z0-9], but may not start with [-0-9]
5605             # - tag names may contain wildcards [?*], and end with a hash [#]
5606             # - may have group name prefixes (which may have family number prefix), separated by colons
5607             # - a group name may be zero or more characters
5608             sub ValidTagName($)
5609             {
5610 41     41 0 96 my $tag = shift;
5611 41         399 return $tag =~ /^(([-\w]*|\d*\*):)*[_a-zA-Z?*][-\w?*]*#?$/;
5612             }
5613              
5614             #------------------------------------------------------------------------------
5615             # Generate a valid tag name based on the tag ID or name
5616             # Inputs: 0) tag ID or name
5617             # Returns: valid tag name
5618             sub MakeTagName($)
5619             {
5620 34363     34363 0 47731 my $name = shift;
5621 34363         62173 $name =~ tr/-_a-zA-Z0-9//dc; # remove illegal characters
5622 34363         56286 $name = ucfirst $name; # capitalize first letter
5623 34363 50       62835 $name = "Tag$name" if length($name) < 2; # must at least 2 characters long
5624 34363         63924 return $name;
5625             }
5626              
5627             #------------------------------------------------------------------------------
5628             # Make description from a tag name
5629             # Inputs: 0) tag name 1) optional tagID to add at end of description
5630             # Returns: description
5631             sub MakeDescription($;$)
5632             {
5633 10215     10215 0 19582 my ($tag, $tagID) = @_;
5634             # start with the tag name and force first letter to be upper case
5635 10215         19301 my $desc = ucfirst($tag);
5636             # translate underlines to spaces
5637 10215         17736 $desc =~ tr/_/ /;
5638             # remove hex TagID from name (to avoid inserting spaces in the number)
5639 10215 100 66     31343 $desc =~ s/ (0x[\da-f]+)$//i and $tagID = $1 unless defined $tagID;
5640             # put a space between lower/UPPER case and lower/number combinations
5641 10215         62835 $desc =~ s/([a-z])([A-Z\d])/$1 $2/g;
5642             # put a space between acronyms and words
5643 10215         27787 $desc =~ s/([A-Z])([A-Z][a-z])/$1 $2/g;
5644             # put spaces after numbers (if more than one character follows the number)
5645 10215         17113 $desc =~ s/(\d)([A-Z]\S)/$1 $2/g;
5646             # add TagID to description
5647 10215 100       19959 $desc .= ' ' . $tagID if defined $tagID;
5648 10215         27090 return $desc;
5649             }
5650              
5651             #------------------------------------------------------------------------------
5652             # Get descriptions for all tags in an array
5653             # Inputs: 0) ExifTool ref, 1) reference to list of tag keys
5654             # Returns: reference to hash lookup for descriptions
5655             # Note: Returned descriptions are NOT escaped by ESCAPE_PROC
5656             sub GetDescriptions($$)
5657             {
5658 0     0 0 0 local $_;
5659 0         0 my ($self, $tags) = @_;
5660 0         0 my %desc;
5661 0         0 my $oldEscape = $$self{ESCAPE_PROC};
5662 0         0 delete $$self{ESCAPE_PROC};
5663 0         0 $desc{$_} = $self->GetDescription($_) foreach @$tags;
5664 0         0 $$self{ESCAPE_PROC} = $oldEscape;
5665 0         0 return \%desc;
5666             }
5667              
5668             #------------------------------------------------------------------------------
5669             # Apply filter to value(s) if necessary
5670             # Inputs: 0) ExifTool ref, 1) filter expression, 2) reference to value to filter
5671             # Returns: true unless a filter returned undef; changes value if necessary
5672             sub Filter($$$)
5673             {
5674 13073     13073 1 20066 local $_;
5675 13073         29958 my ($self, $filter, $valPt) = @_;
5676 13073 100 66     44011 return 1 unless defined $filter and defined $$valPt;
5677 462         701 my $rtnVal;
5678 462 100       987 if (not ref $$valPt) {
    100          
    50          
    0          
5679 446         785 $_ = $$valPt;
5680             #### eval Filter ($_, $self)
5681 446         25025 eval $filter;
5682 446 50       1667 if (defined $_) {
5683 446         850 $$valPt = $_;
5684 446         677 $rtnVal = 1;
5685             }
5686             } elsif (ref $$valPt eq 'SCALAR') {
5687 12         23 my $val = $$$valPt; # make a copy to avoid filtering twice
5688 12         28 $rtnVal = $self->Filter($filter, \$val);
5689 12         30 $$valPt = \$val;
5690             } elsif (ref $$valPt eq 'ARRAY') {
5691 4         5 my @val = @{$$valPt}; # make a copy to avoid filtering twice
  4         24  
5692 4   50     13 $self->Filter($filter, \$_) and $rtnVal = 1 foreach @val;
5693 4         9 $$valPt = \@val;
5694             } elsif (ref $$valPt eq 'HASH') {
5695 0         0 my %val = %{$$valPt}; # make a copy to avoid filtering twice
  0         0  
5696 0   0     0 $self->Filter($filter, \$val{$_}) and $rtnVal = 1 foreach keys %val;
5697 0         0 $$valPt = \%val;
5698             } else {
5699 0         0 $rtnVal = 1;
5700             }
5701 462         858 return $rtnVal;
5702             }
5703              
5704             #------------------------------------------------------------------------------
5705             # Return printable value
5706             # Inputs: 0) ExifTool object reference
5707             # 1) value to print, 2) line length limit (undef defaults to 60, 0=unlimited)
5708             sub Printable($;$)
5709             {
5710 593     593 0 1192 my ($self, $outStr, $maxLen) = @_;
5711 593 50       1222 return '(undef)' unless defined $outStr;
5712 593         1233 $outStr =~ tr/\x01-\x1f\x7f-\xff/./;
5713 593         1760 $outStr =~ s/\x00//g;
5714 593         1009 my $verbose = $$self{OPTIONS}{Verbose};
5715 593 50       1161 if ($verbose < 4) {
5716 593 100       1102 if ($maxLen) {
    50          
5717 592 50       1237 $maxLen = 20 if $maxLen < 20; # minimum length is 20
5718             } elsif (defined $maxLen) {
5719 1         2 $maxLen = length $outStr; # 0 is unlimited
5720             } else {
5721 0         0 $maxLen = 60; # default maximum is 60
5722             }
5723             } else {
5724 0         0 $maxLen = length $outStr;
5725             # limit to 2048 characters if verbose < 5
5726 0 0 0     0 $maxLen = 2048 if $maxLen > 2048 and $verbose < 5;
5727             }
5728              
5729             # limit length if necessary
5730 593 100       1228 $outStr = substr($outStr,0,$maxLen-6) . '[snip]' if length($outStr) > $maxLen;
5731 593         1821 return $outStr;
5732             }
5733              
5734             #------------------------------------------------------------------------------
5735             # Convert date/time from Exif format
5736             # Inputs: 0) ExifTool object reference, 1) Date/time in EXIF format
5737             # Returns: Formatted date/time string
5738             sub ConvertDateTime($$)
5739             {
5740 1779     1779 0 4939 my ($self, $date) = @_;
5741 1779         4216 my $fmt = $$self{OPTIONS}{DateFormat};
5742 1779         3225 my $shift = $$self{OPTIONS}{GlobalTimeShift};
5743 1779 100       4685 if ($shift) {
5744 8 50 33     59 my $dir = ($shift =~ s/^([-+])// and $1 eq '-') ? -1 : 1;
5745 8         20 my $offset = $$self{GLOBAL_TIME_OFFSET};
5746 8 100       21 $offset or $offset = $$self{GLOBAL_TIME_OFFSET} = { };
5747 8         34 ShiftTime($date, $shift, $dir, $offset);
5748             }
5749             # only convert date if a format was specified and the date is recognizable
5750 1779 100       3966 if ($fmt) {
5751             # separate time zone if it exists
5752 5         9 my $tz;
5753 5 100       36 $date =~ s/([-+]\d{2}:\d{2}|Z)$// and $tz = $1;
5754             # a few cameras use incorrect date/time formatting:
5755             # - slashes instead of colons in date (RolleiD330, ImpressCam)
5756             # - date/time values separated by colon instead of space (Polariod, Sanyo, Sharp, Vivitar)
5757             # - single-digit seconds with leading space (HP scanners)
5758 5         38 my @a = reverse ($date =~ /\d+/g); # be very flexible about date/time format
5759 5 50 33     51 if (@a and $a[-1] >= 1000 and $a[-1] < 3000 and eval { require POSIX }) {
  5 0 33     36  
      33        
5760 5         16 shift @a while @a > 6; # remove superfluous entries
5761 5         17 unshift @a, 1 while @a < 3; # add month and day if necessary
5762 5         13 unshift @a, 0 while @a < 6; # add h,m,s if necessary
5763 5         14 $a[4] -= 1; # base month is 1
5764             # parse our %f fractional seconds first (and round up seconds if necessary)
5765             # - if there are multiple %f codes, they all get the same number of digits as the first
5766 5 50       28 if ($fmt =~ /%(-?)\.?(\d*)f/) {
5767 0         0 my ($neg, $dig) = ($1, $2);
5768 0 0       0 my $frac = $date =~ /(\.\d+)/ ? $1 : '';
5769 0 0       0 if (not $frac) {
    0          
5770 0 0       0 $frac = '.' . ('0' x $dig) if $dig;
5771             } elsif (length $dig) {
5772 0 0       0 if ($dig+1 > length($frac)) {
    0          
5773 0         0 $frac .= '0' x ($dig+1-length($frac));
5774             } elsif ($dig+1 < length($frac)) {
5775 0         0 $frac = sprintf("%.${dig}f", $frac);
5776 0   0     0 while ($frac =~ s/^(\d)// and $1 ne '0') {
5777             # this is a pain, but we must round up to the next second
5778 0 0       0 ++$a[0] < 60 and last;
5779 0         0 $a[0] = 0;
5780 0 0       0 ++$a[1] < 60 and last;
5781 0         0 $a[1] = 0;
5782 0 0       0 ++$a[2] < 24 and last;
5783 0         0 $a[2] = 0;
5784 0         0 require 'Image/ExifTool/Shift.pl';
5785 0 0       0 ++$a[3] <= DaysInMonth($a[4]+1, $a[5]) and last;
5786 0         0 $a[3] = 1;
5787 0 0       0 ++$a[4] < 12 and last;
5788 0         0 $a[4] = 0;
5789 0         0 ++$a[5];
5790 0         0 last; # (this was a goto)
5791             }
5792             }
5793             }
5794 0 0       0 $neg and $frac =~ s/^\.//;
5795 0         0 $fmt =~ s/(^|[^%])((%%)*)%-?\.?\d*f/$1$2$frac/g;
5796             }
5797             # parse %z and %s ourself (to handle time zones properly)
5798 5 50       24 if ($fmt =~ /%[sz]/) {
5799             # use system time zone unless otherwise specified
5800 0 0 0     0 $tz = TimeZoneString(\@a, TimeLocal(@a)) if not $tz and eval { require Time::Local };
  0         0  
5801             # remove colon, setting to UTC if time zone is not numeric
5802 0 0 0     0 $tz = ($tz and $tz=~/^([-+]\d{2}):(\d{2})$/) ? "$1$2" : '+0000';
5803 0         0 $fmt =~ s/(^|[^%])((%%)*)%z/$1$2$tz/g; # convert '%z' format codes
5804 0 0 0     0 if ($fmt =~ /%s/ and eval { require Time::Local }) {
  0         0  
5805             # calculate seconds since the Epoch, UTC
5806 0         0 my $s = Time::Local::timegm(@a) - 60 * ($tz - int($tz/100) * 40);
5807 0         0 $fmt =~ s/(^|[^%])((%%)*)%s/$1$2$s/g; # convert '%s' format codes
5808             }
5809             }
5810 5         9 $a[5] -= 1900; # strftime year starts from 1900
5811 5         234 $date = POSIX::strftime($fmt, @a); # generate the formatted date/time
5812             } elsif ($$self{OPTIONS}{StrictDate}) {
5813 0         0 undef $date;
5814             }
5815             }
5816 1779         11582 return $date;
5817             }
5818              
5819             #------------------------------------------------------------------------------
5820             # Print conversion for time span value
5821             # Inputs: 0) time ticks, 1) number of seconds per tick (default 1)
5822             # Returns: readable time
5823             sub ConvertTimeSpan($;$)
5824             {
5825 3     3 0 15 my ($val, $mult) = @_;
5826 3 50 33     13 if (Image::ExifTool::IsFloat($val) and $val != 0) {
5827 3 100       13 $val *= $mult if $mult;
5828 3 50       30 if ($val < 60) {
    50          
    0          
5829 0         0 $val = "$val seconds";
5830             } elsif ($val < 3600) {
5831 3 100 66     28 my $fmt = ($mult and $mult >= 60) ? '%d' : '%.1f';
5832 3 100 66     19 my $s = ($val == 60 and $mult) ? '' : 's';
5833 3         34 $val = sprintf("$fmt minute$s", $val / 60);
5834             } elsif ($val < 24 * 3600) {
5835 0         0 $val = sprintf("%.1f hours", $val / 3600);
5836             } else {
5837 0         0 $val = sprintf("%.1f days", $val / (24 * 3600));
5838             }
5839             }
5840 3         25 return $val;
5841             }
5842              
5843             #------------------------------------------------------------------------------
5844             # Patched timelocal() that fixes ActivePerl timezone bug
5845             # Inputs/Returns: same as timelocal()
5846             # Notes: must 'require Time::Local' before calling this routine
5847             sub TimeLocal(@)
5848             {
5849 36     36 0 1608 my $tm = Time::Local::timelocal(@_);
5850 36 50       2957 if ($^O eq 'MSWin32') {
5851             # patch for ActivePerl timezone bug
5852 0         0 my @t2 = localtime($tm);
5853 0         0 my $t2 = Time::Local::timelocal(@t2);
5854             # adjust timelocal() return value to be consistent with localtime()
5855 0         0 $tm += $tm - $t2;
5856             }
5857 36         139 return $tm;
5858             }
5859              
5860             #------------------------------------------------------------------------------
5861             # Get time zone in minutes
5862             # Inputs: 0) localtime array ref, 1) gmtime array ref
5863             # Returns: time zone offset in minutes
5864             sub GetTimeZone($$)
5865             {
5866 930     930 0 2219 my ($tm, $gm) = @_;
5867             # compute the number of minutes between localtime and gmtime
5868 930         3340 my $min = $$tm[2] * 60 + $$tm[1] - ($$gm[2] * 60 + $$gm[1]);
5869 930 50       2630 if ($$tm[3] != $$gm[3]) {
5870             # account for case where one date wraps to the first of the next month
5871 0 0       0 $$gm[3] = $$tm[3] - ($$tm[3]==1 ? 1 : -1) if abs($$tm[3]-$$gm[3]) != 1;
    0          
5872             # adjust for the +/- one day difference
5873 0         0 $min += ($$tm[3] - $$gm[3]) * 24 * 60;
5874             }
5875             # MirBSD patch to round to the nearest 30 minutes because
5876             # it includes leap seconds in localtime but not gmtime
5877 930 0       3879 $min = int($min / 30 + ($min > 0 ? 0.5 : -0.5)) * 30 if $^O eq 'mirbsd';
    50          
5878 930         2817 return $min;
5879             }
5880              
5881             #------------------------------------------------------------------------------
5882             # Get time zone string
5883             # Inputs: 0) time zone offset in minutes
5884             # or 0) localtime array ref, 1) corresponding time value
5885             # Returns: time zone string ("+/-HH:MM")
5886             sub TimeZoneString($;$)
5887             {
5888 971     971 0 2362 my $min = shift;
5889 971 100       3211 if (ref $min) {
5890 930         5248 my @gm = gmtime(shift);
5891 930         3022 $min = GetTimeZone($min, \@gm);
5892             }
5893 971         2786 my $sign = '+';
5894 971 100       2648 $min < 0 and $sign = '-', $min = -$min;
5895 971         2768 $min = int($min + 0.5); # round off to nearest minute
5896 971         2366 my $h = int($min / 60);
5897 971         6117 return sprintf('%s%.2d:%.2d', $sign, $h, $min - $h * 60);
5898             }
5899              
5900             #------------------------------------------------------------------------------
5901             # Convert Unix time to EXIF date/time string
5902             # Inputs: 0) Unix time value, 1) non-zero to convert to local time,
5903             # 2) number of digits after the decimal for fractional seconds
5904             # Returns: EXIF date/time string (with timezone for local times)
5905             sub ConvertUnixTime($;$$)
5906             {
5907 1036     1036 0 3481 my ($time, $toLocal, $dec) = @_;
5908 1036 100       3056 return '0000:00:00 00:00:00' if $time == 0;
5909 1035         2012 my (@tm, $tz);
5910 1035 50       2465 if ($dec) {
5911 0         0 my $frac = $time - int($time);
5912 0         0 $time = int($time);
5913 0 0       0 $frac < 0 and $frac += 1, $time -= 1;
5914 0         0 $dec = sprintf('%.*f', $dec, $frac);
5915             # remove number before decimal and increment integer time if it was rounded up
5916 0 0 0     0 $dec =~ s/^(\d)// and $1 eq '1' and $time += 1;
5917             } else {
5918 1035 100       2863 $time = int($time + 1e-6) if $time != int($time); # avoid round-off errors
5919 1035         1982 $dec = '';
5920             }
5921 1035 100       2352 if ($toLocal) {
5922 871         31547 @tm = localtime($time);
5923 871         4375 $tz = TimeZoneString(\@tm, $time);
5924             } else {
5925 164         1117 @tm = gmtime($time);
5926 164         365 $tz = '';
5927             }
5928 1035         7489 my $str = sprintf("%4d:%.2d:%.2d %.2d:%.2d:%.2d$dec%s",
5929             $tm[5]+1900, $tm[4]+1, $tm[3], $tm[2], $tm[1], $tm[0], $tz);
5930 1035         9572 return $str;
5931             }
5932              
5933             #------------------------------------------------------------------------------
5934             # Get Unix time from EXIF-formatted date/time string with optional timezone
5935             # Inputs: 0) EXIF date/time string, 1) non-zero if time is local, or 2 to assume UTC
5936             # Returns: Unix time (seconds since 0:00 GMT Jan 1, 1970) or undefined on error
5937             sub GetUnixTime($;$)
5938             {
5939 162     162 0 37014 my ($timeStr, $isLocal) = @_;
5940 162 50       502 return 0 if $timeStr eq '0000:00:00 00:00:00';
5941 162         1132 my @tm = ($timeStr =~ /^(\d+)[-:](\d+)[-:](\d+)\s+(\d+):(\d+):(\d+)(.*)/);
5942 162 50       500 return undef unless @tm == 7;
5943 162 50       287 unless (eval { require Time::Local }) {
  162         5856  
5944 0         0 warn "Time::Local is not installed\n";
5945 0         0 return undef;
5946             }
5947 162         19810 my ($tzStr, $tzSec) = (pop(@tm), 0);
5948             # use specified timezone offset (if given) instead of local system time
5949             # if we are converting a local time value
5950 162 100       446 if ($isLocal) {
5951 113 50       427 if ($tzStr =~ /(?:Z|([-+])(\d+):(\d+))/i) {
    0          
5952             # use specified timezone if one exists
5953 113 100       550 $tzSec = ($2 * 60 + $3) * ($1 eq '-' ? -60 : 60) if $1;
    100          
5954 113         211 undef $isLocal; # convert using GMT corrected for specified timezone
5955             } elsif ($isLocal eq '2') {
5956 0         0 undef $isLocal;
5957             }
5958             }
5959 162         384 $tm[1] -= 1; # convert month
5960 162         325 @tm = reverse @tm; # change to order required by timelocal()
5961 162 50       643 my $val = $isLocal ? TimeLocal(@tm) : Time::Local::timegm(@tm) - $tzSec;
5962             # handle fractional seconds
5963 160 100 100     5723 $val += $1 if $tzStr and $tzStr =~ /^(\.\d+)/;
5964 160         1332 return $val;
5965             }
5966              
5967             #------------------------------------------------------------------------------
5968             # Print conversion for file size
5969             # Inputs: 0) file size in bytes
5970             # Returns: converted file size
5971             sub ConvertFileSize($)
5972             {
5973 300     300 0 858 my $val = shift;
5974 300 100       1556 $val < 2000 and return "$val bytes";
5975 194 100       1941 $val < 10000 and return sprintf('%.1f kB', $val / 1000);
5976 52 100       471 $val < 2000000 and return sprintf('%.0f kB', $val / 1000);
5977 4 100       56 $val < 10000000 and return sprintf('%.1f MB', $val / 1000000);
5978 1 50       9 $val < 2000000000 and return sprintf('%.0f MB', $val / 1000000);
5979 0 0       0 $val < 10000000000 and return sprintf('%.1f GB', $val / 1000000000);
5980 0         0 return sprintf('%.0f GB', $val / 1000000000);
5981             }
5982              
5983             #------------------------------------------------------------------------------
5984             # Convert seconds to duration string (handles negative durations)
5985             # Inputs: 0) floating point seconds
5986             # Returns: duration string in form "S.SS s", "H:MM:SS" or "DD days HH:MM:SS"
5987             sub ConvertDuration($)
5988             {
5989 130     130 0 310 my $time = shift;
5990 130 50       327 return $time unless IsFloat($time);
5991 130 100       819 return '0 s' if $time == 0;
5992 61 50       193 my $sign = ($time > 0 ? '' : (($time = -$time), '-'));
5993 61 100       844 return sprintf("$sign%.2f s", $time) if $time < 30;
5994 4         9 $time += 0.5; # to round off to nearest second
5995 4         14 my $h = int($time / 3600);
5996 4         13 $time -= $h * 3600;
5997 4         11 my $m = int($time / 60);
5998 4         7 $time -= $m * 60;
5999 4 50       14 if ($h > 24) {
6000 0         0 my $d = int($h / 24);
6001 0         0 $h -= $d * 24;
6002 0         0 $sign = "$sign$d days ";
6003             }
6004 4         50 return sprintf("$sign%d:%.2d:%.2d", $h, $m, int($time));
6005             }
6006              
6007             #------------------------------------------------------------------------------
6008             # Print conversion for bitrate values
6009             # Inputs: 0) bitrate in bits per second
6010             # Returns: human-readable bitrate string
6011             # Notes: returns input value without formatting if it isn't numerical
6012             sub ConvertBitrate($)
6013             {
6014 19     19 0 52 my $bitrate = shift;
6015 19 50       65 IsFloat($bitrate) or return $bitrate;
6016 19         88 my @units = ('bps', 'kbps', 'Mbps', 'Gbps');
6017 19         70 for (;;) {
6018 36         74 my $units = shift @units;
6019 36 100 66     162 $bitrate >= 1000 and @units and $bitrate /= 1000, next;
6020 19 100       69 my $fmt = $bitrate < 100 ? '%.3g' : '%.0f';
6021 19         313 return sprintf("$fmt $units", $bitrate);
6022             }
6023             }
6024              
6025             #------------------------------------------------------------------------------
6026             # Convert file name for printing
6027             # Inputs: 0) ExifTool ref, 1) file name in CharsetFileName character set
6028             # Returns: converted file name in external character set
6029             sub ConvertFileName($$)
6030             {
6031 946     946 0 2988 my ($self, $val) = @_;
6032 946         2397 my $enc = $$self{OPTIONS}{CharsetFileName};
6033 946 50       2773 $val = $self->Decode($val, $enc) if $enc;
6034 946         7726 return $val;
6035             }
6036              
6037             #------------------------------------------------------------------------------
6038             # Inverse conversion for file name (encode in CharsetFileName)
6039             # Inputs: 0) ExifTool ref, 1) file name in external character set
6040             # Returns: file name in CharsetFileName character set
6041             sub InverseFileName($$)
6042             {
6043 1     1 0 4 my ($self, $val) = @_;
6044 1         4 my $enc = $$self{OPTIONS}{CharsetFileName};
6045 1 50       6 $val = $self->Encode($val, $enc) if $enc;
6046 1         4 $val =~ tr/\\/\//; # make sure we are using forward slashes
6047 1         11 return $val;
6048             }
6049              
6050             #------------------------------------------------------------------------------
6051             # Save information for HTML dump
6052             # Inputs: 0) ExifTool hash ref, 1) start offset, 2) data size
6053             # 3) comment string, 4) tool tip (or SAME), 5) flags, 6) IFD name
6054             sub HDump($$$$;$$$)
6055             {
6056 0     0 0 0 my $self = shift;
6057 0 0       0 $$self{HTML_DUMP} or return;
6058 0         0 my ($pos, $len, $com, $tip, $flg, $ifd) = @_;
6059 0 0       0 $pos += $$self{BASE} if $$self{BASE};
6060             # skip structural data blocks which have been removed from the middle of this dump
6061             # (SkipData list contains ordered [start,end+1] offsets to skip)
6062 0 0       0 if ($$self{SkipData}) {
6063 0         0 my $end = $pos + $len;
6064 0         0 my $skip;
6065 0         0 foreach $skip (@{$$self{SkipData}}) {
  0         0  
6066 0 0       0 $end <= $$skip[0] and last;
6067 0 0       0 $pos >= $$skip[1] and $pos += $$skip[1] - $$skip[0], next;
6068 0 0       0 if ($pos != $$skip[0]) {
6069 0         0 $$self{HTML_DUMP}->Add($pos, $$skip[0]-$pos, $com, $tip, $flg, $ifd);
6070 0         0 $len -= $$skip[0] - $pos;
6071 0         0 $tip = 'SAME';
6072             }
6073 0         0 $pos = $$skip[1];
6074             }
6075             }
6076 0         0 $$self{HTML_DUMP}->Add($pos, $len, $com, $tip, $flg, $ifd);
6077             }
6078              
6079             #------------------------------------------------------------------------------
6080             # Identify trailer ending at specified offset from end of file
6081             # Inputs: 0) RAF reference, 1) offset from end of file (0 by default)
6082             # Returns: Trailer info hash (with RAF and DirName set),
6083             # or undef if no recognized trailer was found
6084             # Notes: leaves file position unchanged
6085             sub IdentifyTrailer($;$)
6086             {
6087 566     566 0 1239 my $raf = shift;
6088 566   100     2210 my $offset = shift || 0;
6089 566         2065 my $pos = $raf->Tell();
6090 566         1485 my ($buff, $type, $len);
6091 566   33     2439 while ($raf->Seek(-$offset, 2) and ($len = $raf->Tell()) > 0) {
6092             # read up to 64 bytes before specified offset from end of file
6093 566 50       2295 $len = 64 if $len > 64;
6094 566 50 33     2059 $raf->Seek(-$len, 1) and $raf->Read($buff, $len) == $len or last;
6095 566 100 66     11867 if ($buff =~ /AXS(!|\*).{8}$/s) {
    100          
    100          
    100          
    100          
    100          
    50          
    50          
6096 29         104 $type = 'AFCP';
6097             } elsif ($buff =~ /\xa1\xb2\xc3\xd4$/) {
6098 29         137 $type = 'FotoStation';
6099             } elsif ($buff =~ /cbipcbbl$/) {
6100 34         142 $type = 'PhotoMechanic';
6101             } elsif ($buff =~ /^CANON OPTIONAL DATA\0/) {
6102 41         136 $type = 'CanonVRD';
6103             } elsif ($buff =~ /~\0\x04\0zmie~\0\0\x06.{4}[\x10\x18]\x04$/s or
6104             $buff =~ /~\0\x04\0zmie~\0\0\x0a.{8}[\x10\x18]\x08$/s)
6105             {
6106 26         107 $type = 'MIE';
6107             } elsif ($buff =~ /\0\0(QDIOBS|SEFT)$/) {
6108 26         89 $type = 'Samsung';
6109             } elsif ($buff =~ /8db42d694ccc418790edff439fe026bf$/s) {
6110 0         0 $type = 'Insta360';
6111             } elsif ($buff =~ m(\0{6}/NIKON APP$)) {
6112 0         0 $type = 'NikonApp';
6113             }
6114 566         1339 last;
6115             }
6116 566         2291 $raf->Seek($pos, 0); # restore original file position
6117 566 100       3409 return $type ? { RAF => $raf, DirName => $type } : undef;
6118             }
6119              
6120             #------------------------------------------------------------------------------
6121             # Read/rewrite trailer information (including multiple trailers)
6122             # Inputs: 0) ExifTool object ref, 1) DirInfo ref:
6123             # - requires RAF and DirName
6124             # - OutFile is a scalar reference for writing
6125             # - scans from current file position if ScanForAFCP is set
6126             # Returns: 1 if trailer was processed or couldn't be processed (or written OK)
6127             # 0 if trailer was recognized but offsets need fixing (or write error)
6128             # - DirName, DirLen, DataPos, Offset, Fixup and OutFile are updated
6129             # - preserves current file position and byte order
6130             sub ProcessTrailers($$)
6131             {
6132 57     57 0 200 my ($self, $dirInfo) = @_;
6133 57         174 my $dirName = $$dirInfo{DirName};
6134 57         135 my $outfile = $$dirInfo{OutFile};
6135 57   50     408 my $offset = $$dirInfo{Offset} || 0;
6136 57         188 my $fixup = $$dirInfo{Fixup};
6137 57         150 my $raf = $$dirInfo{RAF};
6138 57         210 my $pos = $raf->Tell();
6139 57         235 my $byteOrder = GetByteOrder();
6140 57         136 my $success = 1;
6141 57         150 my $path = $$self{PATH};
6142              
6143 57         152 for (;;) { # loop through all trailers
6144 185         387 my ($proc, $outBuff);
6145 185 50       671 if ($dirName eq 'Insta360') {
    50          
6146 0         0 require 'Image/ExifTool/QuickTimeStream.pl';
6147 0         0 $proc = 'Image::ExifTool::QuickTime::ProcessInsta360';
6148             } elsif ($dirName eq 'NikonApp') {
6149 0         0 require Image::ExifTool::Nikon;
6150 0         0 $proc = 'Image::ExifTool::Nikon::ProcessNikonApp';
6151             } else {
6152 185         16933 require "Image/ExifTool/$dirName.pm";
6153 185         640 $proc = "Image::ExifTool::${dirName}::Process$dirName";
6154             }
6155 185 100       564 if ($outfile) {
6156             # write to local buffer so we can add trailer in proper order later
6157 50 100       212 $$outfile and $$dirInfo{OutFile} = \$outBuff, $outBuff = '';
6158             # must generate new fixup if necessary so we can shift
6159             # the old fixup separately after we prepend this trailer
6160 50         124 delete $$dirInfo{Fixup};
6161             }
6162 185         416 delete $$dirInfo{DirLen}; # reset trailer length
6163 185         387 $$dirInfo{Offset} = $offset; # set offset from end of file
6164 185         404 $$dirInfo{Trailer} = 1; # set Trailer flag in case proc cares
6165             # add trailer and DirName to SubDirectory PATH
6166 185         476 push @$path, 'Trailer', $dirName;
6167              
6168             # read or write this trailer
6169             # (proc takes Offset as positive offset from end of trailer to end of file,
6170             # and returns DataPos and DirLen, and Fixup if applicable, and updates
6171             # OutFile when writing)
6172 105     105   1117 no strict 'refs';
  105         275  
  105         5626  
6173 185         2029 my $result = &$proc($self, $dirInfo);
6174 105     105   764 use strict 'refs';
  105         340  
  105         1386462  
6175              
6176             # restore PATH (pop last 2 items)
6177 185         583 splice @$path, -2;
6178              
6179             # check result
6180 185 100       676 if ($outfile) {
    50          
6181 50 50       143 if ($result > 0) {
6182 50 100       152 if ($outBuff) {
6183             # write trailers to OutFile in original order
6184 33         328 $$outfile = $outBuff . $$outfile;
6185             # must adjust old fixup start if it exists
6186 33 50       143 $$fixup{Start} += length($outBuff) if $fixup;
6187 33         61 $outBuff = ''; # free memory
6188             }
6189 50 100       174 if ($$dirInfo{Fixup}) {
6190 15 100       51 if ($fixup) {
6191             # add fixup for subsequent trailers to the fixup for this trailer
6192             # (but first we must adjust for the new start position)
6193 7         22 $$fixup{Shift} += $$dirInfo{Fixup}{Start};
6194 7         31 $$fixup{Start} -= $$dirInfo{Fixup}{Start};
6195 7         32 $$dirInfo{Fixup}->AddFixup($fixup);
6196             }
6197 15         48 $fixup = $$dirInfo{Fixup}; # save fixup
6198             }
6199             } else {
6200 0 0       0 $success = 0 if $self->Error("Error rewriting $dirName trailer", 2);
6201 0         0 last;
6202             }
6203             } elsif ($result < 0) {
6204             # can't continue if we must scan for this trailer
6205 0         0 $success = 0;
6206 0         0 last;
6207             }
6208 185 50 33     1082 last unless $result > 0 and $$dirInfo{DirLen};
6209             # look for next trailer
6210 185         412 $offset += $$dirInfo{DirLen};
6211 185 100       530 my $nextTrail = IdentifyTrailer($raf, $offset) or last;
6212 128         412 $dirName = $$dirInfo{DirName} = $$nextTrail{DirName};
6213 128         413 $raf->Seek($pos, 0);
6214             }
6215 57         306 SetByteOrder($byteOrder); # restore original byte order
6216 57         393 $raf->Seek($pos, 0); # restore original file position
6217 57         244 $$dirInfo{OutFile} = $outfile; # restore original outfile
6218 57         209 $$dirInfo{Offset} = $offset; # return offset from EOF to start of first trailer
6219 57         294 $$dirInfo{Fixup} = $fixup; # return fixup information
6220 57         370 return $success;
6221             }
6222              
6223             #------------------------------------------------------------------------------
6224             # JPEG constants
6225              
6226             # JPEG marker names
6227             %jpegMarker = (
6228             0x00 => 'NULL',
6229             0x01 => 'TEM',
6230             0xc0 => 'SOF0', # to SOF15, with a few exceptions below
6231             0xc4 => 'DHT',
6232             0xc8 => 'JPGA',
6233             0xcc => 'DAC',
6234             0xd0 => 'RST0', # to RST7
6235             0xd8 => 'SOI',
6236             0xd9 => 'EOI',
6237             0xda => 'SOS',
6238             0xdb => 'DQT',
6239             0xdc => 'DNL',
6240             0xdd => 'DRI',
6241             0xde => 'DHP',
6242             0xdf => 'EXP',
6243             0xe0 => 'APP0', # to APP15
6244             0xf0 => 'JPG0',
6245             0xfe => 'COM',
6246             );
6247              
6248             # lookup for size of JPEG marker length word
6249             # (2 bytes assumed unless specified here)
6250             my %markerLenBytes = (
6251             0x00 => 0, 0x01 => 0,
6252             0xd0 => 0, 0xd1 => 0, 0xd2 => 0, 0xd3 => 0, 0xd4 => 0, 0xd5 => 0, 0xd6 => 0, 0xd7 => 0,
6253             0xd8 => 0, 0xd9 => 0, 0xda => 0,
6254             # J2C
6255             0x30 => 0, 0x31 => 0, 0x32 => 0, 0x33 => 0, 0x34 => 0, 0x35 => 0, 0x36 => 0, 0x37 => 0,
6256             0x38 => 0, 0x39 => 0, 0x3a => 0, 0x3b => 0, 0x3c => 0, 0x3d => 0, 0x3e => 0, 0x3f => 0,
6257             0x4f => 0,
6258             0x92 => 0, 0x93 => 0,
6259             # J2C extensions
6260             0x74 => 4, 0x75 => 4, 0x77 => 4,
6261             );
6262              
6263             #------------------------------------------------------------------------------
6264             # Get JPEG marker name
6265             # Inputs: 0) Jpeg number
6266             # Returns: marker name
6267             sub JpegMarkerName($)
6268             {
6269 3055     3055 0 5637 my $marker = shift;
6270 3055         7479 my $markerName = $jpegMarker{$marker};
6271 3055 100       6678 unless ($markerName) {
6272 1157         3569 $markerName = $jpegMarker{$marker & 0xf0};
6273 1157 50 33     9171 if ($markerName and $markerName =~ /^([A-Z]+)\d+$/) {
6274 1157         4276 $markerName = $1 . ($marker & 0x0f);
6275             } else {
6276 0         0 $markerName = sprintf("marker 0x%.2x", $marker);
6277             }
6278             }
6279 3055         7630 return $markerName;
6280             }
6281              
6282             #------------------------------------------------------------------------------
6283             # Adjust directory start position
6284             # Inputs: 0) dirInfo ref, 1) start offset
6285             # 2) Base for offsets (relative to DataPos, defaults to absolute Base of 0)
6286             sub DirStart($$;$)
6287             {
6288 560     560 0 1531 my ($dirInfo, $start, $base) = @_;
6289 560         1163 $$dirInfo{DirStart} = $start;
6290 560         1207 $$dirInfo{DirLen} -= $start;
6291 560 100       1831 if (defined $base) {
6292 263         684 $$dirInfo{Base} = $$dirInfo{DataPos} + $base;
6293 263         686 $$dirInfo{DataPos} = -$base; # (relative to Base!)
6294             }
6295             }
6296              
6297             #------------------------------------------------------------------------------
6298             # Extract metadata from a jpg image
6299             # Inputs: 0) ExifTool object reference, 1) dirInfo ref with RAF set
6300             # Returns: 1 on success, 0 if this wasn't a valid JPEG file
6301             sub ProcessJPEG($$)
6302             {
6303 233     233 0 527 local $_;
6304 233         666 my ($self, $dirInfo) = @_;
6305 233         529 my ($ch, $s, $length);
6306 233         693 my $options = $$self{OPTIONS};
6307 233         588 my $verbose = $$options{Verbose};
6308 233         587 my $out = $$options{TextOut};
6309 233   100     1241 my $fast = $$options{FastScan} || 0;
6310 233         568 my $raf = $$dirInfo{RAF};
6311 233         592 my $req = $$self{REQ_TAG_LOOKUP};
6312 233         525 my $htmlDump = $$self{HTML_DUMP};
6313 233         832 my %dumpParms = ( Out => $out );
6314 233         1422 my ($success, $wantTrailer, $trailInfo, $foundSOS, %jumbfChunk);
6315 233         0 my (@iccChunk, $iccChunkCount, $iccChunksTotal, @flirChunk, $flirCount, $flirTotal);
6316 233         0 my ($preview, $scalado, @dqt, $subSampling, $dumpEnd, %extendedXMP);
6317              
6318             # check to be sure this is a valid JPG (or J2C, or EXV) file
6319 233 50 33     945 return 0 unless $raf->Read($s, 2) == 2 and $s =~ /^\xff[\xd8\x4f\x01]/;
6320 233 100       1137 if ($s eq "\xff\x01") {
6321 2 50 33     16 return 0 unless $raf->Read($s, 5) == 5 and $s eq 'Exiv2';
6322 2         11 $$self{FILE_TYPE} = 'EXV';
6323             }
6324 233         535 my $appBytes = 0;
6325 233         574 my $calcImageLen = $$req{jpegimagelength};
6326 233 50 66     2132 if ($$options{RequestAll} and $$options{RequestAll} > 2) {
6327 0         0 $calcImageLen = 1;
6328             }
6329 233 100 66     1209 if (not $$self{VALUE}{FileType} or ($$self{DOC_NUM} and $$options{ExtractEmbedded})) {
      66        
6330 225         1238 $self->SetFileType(); # set FileType tag
6331 225 100       1969 return 1 if $fast == 3; # don't process file when FastScan == 3
6332 224         837 $$self{LOW_PRIORITY_DIR}{IFD1} = 1; # lower priority of IFD1 tags
6333             }
6334 232 100       848 $$raf{NoBuffer} = 1 if $self->Options('FastScan'); # disable buffering in FastScan mode
6335              
6336 232 50       1554 $dumpParms{MaxLen} = 128 if $verbose < 4;
6337 232 50       861 if ($htmlDump) {
6338 0         0 $dumpEnd = $raf->Tell();
6339 0 0       0 my ($n, $t, $m) = $s eq 'Exiv2' ? (7,'EXV','TEM') : (2,'JPEG','SOI');
6340 0         0 my $pos = $dumpEnd - $n;
6341 0 0       0 $self->HDump(0, $pos, '[unknown header]') if $pos;
6342 0         0 $self->HDump($pos, $n, "$t header", "$m Marker");
6343             }
6344 232         714 my $path = $$self{PATH};
6345 232         550 my $pn = scalar @$path;
6346              
6347             # set input record separator to 0xff (the JPEG marker) to make reading quicker
6348 232         1383 local $/ = "\xff";
6349              
6350 232         679 my ($nextMarker, $nextSegDataPt, $nextSegPos, $combinedSegData, $firstSegPos, @skipData);
6351              
6352             # read file until we reach an end of image (EOI) or start of scan (SOS)
6353 232         792 Marker: for (;;) {
6354             # set marker and data pointer for current segment
6355 2053         3807 my $marker = $nextMarker;
6356 2053         3183 my $segDataPt = $nextSegDataPt;
6357 2053         3117 my $segPos = $nextSegPos;
6358 2053         2936 my $skipped;
6359 2053         3396 undef $nextMarker;
6360 2053         3210 undef $nextSegDataPt;
6361             #
6362             # read ahead to the next segment unless we have reached EOI, SOS or SOD
6363             #
6364 2053 100 100     13715 unless ($marker and ($marker==0xd9 or ($marker==0xda and not $wantTrailer) or $marker==0x93)) {
      100        
6365             # read up to next marker (JPEG markers begin with 0xff)
6366 1820         2775 my $buff;
6367 1820 50       6684 $raf->ReadLine($buff) or last;
6368 1820         3478 $skipped = length($buff) - 1;
6369             # JPEG markers can be padded with unlimited 0xff's
6370 1820         3627 for (;;) {
6371 1820 50       4771 $raf->Read($ch, 1) or last Marker;
6372 1820         3626 $nextMarker = ord($ch);
6373 1820 50       4660 last unless $nextMarker == 0xff;
6374 0         0 ++$skipped;
6375             }
6376             # read segment data if it exists
6377 1820 100       6388 if (not defined $markerLenBytes{$nextMarker}) {
    50          
6378             # read record length word
6379 1587 50       4107 last unless $raf->Read($s, 2) == 2;
6380 1587         4961 my $len = unpack('n',$s); # get data length
6381 1587 50 33     6640 last unless defined($len) and $len >= 2;
6382 1587         4278 $nextSegPos = $raf->Tell();
6383 1587         2727 $len -= 2; # subtract size of length word
6384 1587 50       3799 last unless $raf->Read($buff, $len) == $len;
6385 1587         3443 $nextSegDataPt = \$buff; # set pointer to our next data
6386             } elsif ($markerLenBytes{$nextMarker} == 4) {
6387             # handle J2C extensions with 4-byte length word
6388 0 0       0 last unless $raf->Read($s, 4) == 4;
6389 0         0 my $len = unpack('N',$s); # get data length
6390 0 0 0     0 last unless defined($len) and $len >= 4;
6391 0         0 $nextSegPos = $raf->Tell();
6392 0         0 $len -= 4; # subtract size of length word
6393 0 0       0 last unless $raf->Seek($len, 1);
6394             }
6395             # read second segment too if this was the first
6396 1820 100       4510 next unless defined $marker;
6397             }
6398             # set some useful variables for the current segment
6399 1820         4702 my $markerName = JpegMarkerName($marker);
6400 1820         3915 $$path[$pn] = $markerName;
6401             # issue warning if we skipped some garbage
6402 1820 0 33     4755 if ($skipped and not $foundSOS and $markerName ne 'SOS') {
      33        
6403 0         0 $self->Warn("Skipped unknown $skipped bytes after JPEG $markerName segment", 1);
6404 0 0       0 if ($htmlDump) {
6405 0         0 $self->HDump($nextSegPos-4-$skipped, $skipped, "[unknown $skipped bytes]", undef, 0x08);
6406 0         0 $dumpEnd = $nextSegPos - 4;
6407             }
6408             }
6409             #
6410             # parse the current segment
6411             #
6412             # handle SOF markers: SOF0-SOF15, except DHT(0xc4), JPGA(0xc8) and DAC(0xcc)
6413 1820 100 66     17670 if (($marker & 0xf0) == 0xc0 and ($marker == 0xc0 or $marker & 0x03)) {
    100 100        
    100 66        
    100 33        
    50 66        
    100          
6414 229         599 $length = length $$segDataPt;
6415 229 100       1108 if ($verbose) {
    50          
6416 2         11 print $out "JPEG $markerName ($length bytes):\n";
6417 2 100       14 HexDump($segDataPt, undef, %dumpParms, Addr=>$segPos) if $verbose>2;
6418             } elsif ($htmlDump) {
6419 0         0 $self->HDump($segPos-4, $length+4, "[JPEG $markerName]", undef, 0x08);
6420 0         0 $dumpEnd = $segPos + $length;
6421             }
6422 229 50       878 next unless $length >= 6;
6423             # extract some useful information
6424 229         1071 my ($p, $h, $w, $n) = unpack('Cn2C', $$segDataPt);
6425 229         847 my $sof = GetTagTable('Image::ExifTool::JPEG::SOF');
6426 229         1347 $self->HandleTag($sof, 'ImageWidth', $w);
6427 229         1043 $self->HandleTag($sof, 'ImageHeight', $h);
6428 229         1338 $self->HandleTag($sof, 'EncodingProcess', $marker - 0xc0);
6429 229         1244 $self->HandleTag($sof, 'BitsPerSample', $p);
6430 229         1185 $self->HandleTag($sof, 'ColorComponents', $n);
6431 229 50 33     1977 next unless $n == 3 and $length >= 15;
6432 229         603 my ($i, $hmin, $hmax, $vmin, $vmax);
6433             # loop through all components to determine sampling frequency
6434 229         607 $subSampling = '';
6435 229         1013 for ($i=0; $i<$n; ++$i) {
6436 687         1781 my $sf = Get8u($segDataPt, 7 + 3 * $i);
6437 687         2591 $subSampling .= sprintf('%.2x', $sf);
6438             # isolate horizontal and vertical components
6439 687         1736 my ($hf, $vf) = ($sf >> 4, $sf & 0x0f);
6440 687 100       1682 unless ($i) {
6441 229         577 $hmin = $hmax = $hf;
6442 229         505 $vmin = $vmax = $vf;
6443 229         687 next;
6444             }
6445             # determine min/max frequencies
6446 458 100       1478 $hmin = $hf if $hf < $hmin;
6447 458 50       1246 $hmax = $hf if $hf > $hmax;
6448 458 100       1201 $vmin = $vf if $vf < $vmin;
6449 458 50       1506 $vmax = $vf if $vf > $vmax;
6450             }
6451 229 50 33     1524 if ($hmin and $vmin) {
6452 229         812 my ($hs, $vs) = ($hmax / $hmin, $vmax / $vmin);
6453 229         2233 $self->HandleTag($sof, 'YCbCrSubSampling', "$hs $vs");
6454             }
6455 229         908 next;
6456             } elsif ($marker == 0xd9) { # EOI
6457 3         13 pop @$path;
6458 3 100       18 $verbose and print $out "JPEG EOI\n";
6459 3         19 my $pos = $raf->Tell();
6460 3 50 33     25 if ($htmlDump and $dumpEnd) {
6461 0         0 $self->HDump($dumpEnd, $pos-2-$dumpEnd, '[JPEG Image Data]', undef, 0x08);
6462 0         0 $self->HDump($pos-2, 2, 'JPEG EOI', undef);
6463 0         0 $dumpEnd = 0;
6464             }
6465 3 50 66     26 if ($foundSOS or $$self{FILE_TYPE} eq 'EXV') {
6466 3         12 $success = 1;
6467             } else {
6468 0         0 $self->Warn('Missing JPEG SOS');
6469             }
6470 3 50       19 if ($$req{trailer}) {
6471             # read entire trailer into memory
6472 0 0       0 if ($raf->Seek(0,2)) {
6473 0         0 my $len = $raf->Tell() - $pos;
6474 0 0       0 if ($len) {
6475 0         0 my $buff;
6476 0         0 $raf->Seek($pos, 0);
6477 0 0       0 $self->FoundTag(Trailer => \$buff) if $raf->Read($buff,$len) == $len;
6478 0         0 $raf->Seek($pos, 0);
6479             }
6480             } else {
6481 0         0 $self->Warn('Error seeking in file');
6482             }
6483             }
6484             # we are here because we are looking for trailer information
6485 3 50       18 if ($wantTrailer) {
6486 0         0 my $start = $$self{PreviewImageStart};
6487 0 0 0     0 if ($start or $$options{ExtractEmbedded}) {
6488 0         0 my $buff;
6489             # most previews start right after the JPEG EOI, but the Olympus E-20
6490             # preview is 508 bytes into the trailer, the K-M Maxxum 7D preview is
6491             # 979 bytes in, and Sony previews can start up to 32 kB into the trailer.
6492             # (and Minolta and Sony previews can have a random first byte...)
6493 0 0       0 my $scanLen = $$self{Make} =~ /Sony/i ? 65536 : 1024;
6494 0 0       0 if ($raf->Read($buff, $scanLen)) {
6495 0 0 0     0 if ($buff =~ /^.{4}ftyp/s) {
    0 0        
6496 0         0 my $val;
6497 0 0       0 if ($raf->Seek(0,2)) {
6498 0         0 my $len = $raf->Tell() - $pos;
6499 0 0       0 if ($$options{Binary}) {
6500 0 0 0     0 $val = \$buff if $raf->Seek($pos,0) and $raf->Read($buff,$len)==$len;
6501             } else {
6502 0         0 $val = \ "Binary data $len bytes";
6503             }
6504 0 0       0 if ($val) {
6505 0         0 $self->FoundTag('EmbeddedVideo', $val);
6506             } else {
6507 0         0 $self->Warn('Error reading trailer');
6508             }
6509             } else {
6510 0         0 $self->Warn('Error seeking to end of file');
6511             }
6512             } elsif ($buff =~ /\xff\xd8\xff./g or
6513             ($$self{Make} =~ /(Minolta|Sony)/i and $buff =~ /.\xd8\xff\xdb/g))
6514             {
6515             # adjust PreviewImageStart to this location
6516 0         0 my $actual = $pos + pos($buff) - 4;
6517 0 0 0     0 if ($start and $start ne $actual and $verbose > 1) {
      0        
6518 0         0 print $out "(Fixed PreviewImage location: $start -> $actual)\n";
6519             }
6520             # update preview image offsets
6521 0 0       0 if ($start) {
6522 0 0       0 $$self{VALUE}{PreviewImageStart} = $actual if $$self{VALUE}{PreviewImageStart};
6523 0         0 $$self{PreviewImageStart} = $actual;
6524             }
6525             # load preview now if we tried and failed earlier
6526 0 0 0     0 if ($$self{PreviewError} and $$self{PreviewImageLength}) {
6527 0 0 0     0 if ($raf->Seek($actual, 0) and $raf->Read($buff, $$self{PreviewImageLength})) {
6528 0         0 $self->FoundTag('PreviewImage', $buff);
6529 0         0 delete $$self{PreviewError};
6530             }
6531             }
6532             }
6533             }
6534 0         0 $raf->Seek($pos, 0);
6535             }
6536             }
6537             # process trailer now or finish processing trailers
6538             # and scan for AFCP if necessary
6539 3         10 my $fromEnd = 0;
6540 3 50       15 if ($trailInfo) {
6541 0         0 $$trailInfo{ScanForAFCP} = 1; # scan now if necessary
6542 0         0 $self->ProcessTrailers($trailInfo);
6543             # save offset from end of file to start of first trailer
6544 0         0 $fromEnd = $$trailInfo{Offset};
6545 0         0 undef $trailInfo;
6546             }
6547 3 50       15 if ($$self{LeicaTrailer}) {
6548 0         0 $raf->Seek(0, 2);
6549 0         0 $$self{LeicaTrailer}{TrailPos} = $pos;
6550 0         0 $$self{LeicaTrailer}{TrailLen} = $raf->Tell() - $pos - $fromEnd;
6551 0         0 Image::ExifTool::Panasonic::ProcessLeicaTrailer($self);
6552             }
6553             # finally, dump remaining information in JPEG trailer
6554 3 100 66     26 if ($verbose or $htmlDump) {
6555 1         4 my $endPos = $$self{LeicaTrailerPos};
6556 1 50       3 unless ($endPos) {
6557 1         4 $raf->Seek(0, 2);
6558 1         4 $endPos = $raf->Tell() - $fromEnd;
6559             }
6560             $self->DumpUnknownTrailer({
6561 1 50       4 RAF => $raf,
6562             DataPos => $pos,
6563             DirLen => $endPos - $pos
6564             }) if $endPos > $pos;
6565             }
6566 3 50       15 $self->FoundTag('JPEGImageLength', $pos - $appBytes) if $calcImageLen;
6567 3         8 last; # all done parsing file
6568             } elsif ($marker == 0xda) { # SOS
6569 229         1106 pop @$path;
6570 229         619 $foundSOS = 1;
6571             # all done with meta information unless we have a trailer
6572 229 100       858 $verbose and print $out "JPEG SOS\n";
6573 229 100       986 unless ($fast) {
6574 228         946 $trailInfo = IdentifyTrailer($raf);
6575             # process trailer now unless we are doing verbose dump
6576 228 50 66     1452 if ($trailInfo and $verbose < 3 and not $htmlDump) {
      66        
6577             # process trailers (keep trailInfo to finish processing later
6578             # only if we can't finish without scanning from end of file)
6579 28 50       166 $self->ProcessTrailers($trailInfo) and undef $trailInfo;
6580             }
6581 228 0 33     921 if ($wantTrailer and $$self{PreviewImageStart}) {
6582             # seek ahead and validate preview image
6583 0         0 my $buff;
6584 0         0 my $curPos = $raf->Tell();
6585 0 0 0     0 if ($raf->Seek($$self{PreviewImageStart}, 0) and
      0        
6586             $raf->Read($buff, 4) == 4 and
6587             $buff =~ /^.\xd8\xff[\xc4\xdb\xe0-\xef]/)
6588             {
6589 0         0 undef $wantTrailer;
6590             }
6591 0 0       0 $raf->Seek($curPos, 0) or last;
6592             }
6593             # seek ahead and process Leica trailer
6594 228 50       940 if ($$self{LeicaTrailer}) {
6595 0         0 require Image::ExifTool::Panasonic;
6596 0         0 Image::ExifTool::Panasonic::ProcessLeicaTrailer($self);
6597 0 0       0 $wantTrailer = 1 if $$self{LeicaTrailer};
6598             } else {
6599 228 50       889 $wantTrailer = 1 if $$options{ExtractEmbedded};
6600             }
6601 228 100 33     2522 next if $trailInfo or $wantTrailer or $verbose > 2 or $htmlDump;
      66        
      66        
6602             }
6603             # must scan to EOI if Validate or JpegCompressionFactor used
6604 228 50 33     1925 next if $$options{Validate} or $calcImageLen or $$req{trailer};
      33        
6605             # nothing interesting to parse after start of scan (SOS)
6606 228         547 $success = 1;
6607 228         607 last; # all done parsing file
6608             } elsif ($marker == 0x93) {
6609 1         2 pop @$path;
6610 1 50       5 $verbose and print $out "JPEG SOD\n";
6611 1         3 $success = 1;
6612 1 50 33     12 next if $verbose > 2 or $htmlDump;
6613 1         3 last; # all done parsing file
6614             } elsif (defined $markerLenBytes{$marker}) {
6615             # handle other stand-alone markers and segments we skipped over
6616 0 0 0     0 $verbose and $marker and print $out "JPEG $markerName\n";
6617 0         0 next;
6618             } elsif ($marker == 0xdb and length($$segDataPt) and # DQT
6619             # save the DQT data only if JPEGDigest has been requested
6620             # (Note: since we aren't checking the API RequestAll option here, the application
6621             # must use the RequestTags option to generate these tags if they have not been
6622             # specifically requested. The reason is that there is too much overhead involved
6623             # in the calculation of this tag to make this worth the CPU time.)
6624             ($$req{jpegdigest} or $$req{jpegqualityestimate}
6625             or ($$options{RequestAll} and $$options{RequestAll} > 2)))
6626             {
6627 1         4 my $num = unpack('C',$$segDataPt) & 0x0f; # get table index
6628 1 50       5 $dqt[$num] = $$segDataPt if $num < 4; # save for MD5 calculation
6629             }
6630             # handle all other markers
6631 1358         2633 my $dumpType = '';
6632 1358         2315 my ($desc, $tip, $xtra);
6633 1358         2384 $length = length $$segDataPt;
6634 1358 100       3784 $appBytes += $length + 4 if ($marker & 0xf0) == 0xe0; # total size of APP segments
6635 1358 100       3142 if ($verbose) {
6636 6         30 print $out "JPEG $markerName ($length bytes):\n";
6637 6 100       20 if ($verbose > 2) {
6638 3         10 my %extraParms = ( Addr => $segPos );
6639 3 50       11 $extraParms{MaxLen} = 128 if $verbose == 4;
6640 3         18 HexDump($segDataPt, undef, %dumpParms, %extraParms);
6641             }
6642             }
6643             # prepare dirInfo hash for processing this information
6644 1358         8133 my %dirInfo = (
6645             Parent => $markerName,
6646             DataPt => $segDataPt,
6647             DataPos => $segPos,
6648             DataLen => $length,
6649             DirStart => 0,
6650             DirLen => $length,
6651             Base => 0,
6652             );
6653 1358 100       16172 if ($marker == 0xe0) { # APP0 (JFIF, JFXX, CIFF, AVI1, Ocad)
    100          
    100          
    100          
    50          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
6654 106 100       1166 if ($$segDataPt =~ /^JFIF\0/) {
    100          
    100          
    50          
6655 49         133 $dumpType = 'JFIF';
6656 49         234 DirStart(\%dirInfo, 5); # start at byte 5
6657 49         209 SetByteOrder('MM');
6658 49         228 my $tagTablePtr = GetTagTable('Image::ExifTool::JFIF::Main');
6659 49         317 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
6660             } elsif ($$segDataPt =~ /^JFXX\0(\x10|\x11|\x13)/) {
6661 19         85 my $tag = ord $1;
6662 19         63 $dumpType = 'JFXX';
6663 19         72 my $tagTablePtr = GetTagTable('Image::ExifTool::JFIF::Extension');
6664 19         124 my $tagInfo = $self->GetTagInfo($tagTablePtr, $tag);
6665 19         118 $self->FoundTag($tagInfo, substr($$segDataPt, 6));
6666             } elsif ($$segDataPt =~ /^(II|MM).{4}HEAPJPGM/s) {
6667 19 50       89 next if $fast > 1; # skip processing for very fast
6668 19         49 $dumpType = 'CIFF';
6669 19         115 my %dirInfo = ( RAF => new File::RandomAccess($segDataPt) );
6670 19         96 $$self{SET_GROUP1} = 'CIFF';
6671 19         47 push @{$$self{PATH}}, 'CIFF';
  19         76  
6672 19         1489 require Image::ExifTool::CanonRaw;
6673 19         156 Image::ExifTool::CanonRaw::ProcessCRW($self, \%dirInfo);
6674 19         58 pop @{$$self{PATH}};
  19         71  
6675 19         109 delete $$self{SET_GROUP1};
6676             } elsif ($$segDataPt =~ /^(AVI1|Ocad)/) {
6677 19         81 $dumpType = $1;
6678 19         88 SetByteOrder('MM');
6679 19         148 my $tagTablePtr = GetTagTable("Image::ExifTool::JPEG::$dumpType");
6680 19         102 DirStart(\%dirInfo, 4);
6681 19         90 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
6682             }
6683             } elsif ($marker == 0xe1) { # APP1 (EXIF, XMP, QVCI, PARROT)
6684             # (some Kodak cameras don't put a second "\0", and I have seen an
6685             # example where there was a second 4-byte APP1 segment header)
6686 259 100 66     3184 if ($$segDataPt =~ /^(.{0,4})Exif\0/is) {
    100          
    100          
    100          
    50          
6687 187         473 undef $dumpType; # (will be dumped here)
6688             # this is EXIF data --
6689             # get the data block (into a common variable)
6690 187         503 my $hdrLen = length($exifAPP1hdr);
6691 187 50       1443 if (length $1) {
    50          
6692 0         0 $hdrLen += length $1;
6693 0         0 $self->Warn('Unknown garbage at start of EXIF segment',1);
6694             } elsif ($$segDataPt !~ /^Exif\0/) {
6695 0         0 $self->Warn('Incorrect EXIF segment identifier',1);
6696             }
6697 187 50       692 if ($htmlDump) {
6698 0         0 $self->HDump($segPos-4, 4, 'APP1 header', "Data size: $length bytes");
6699 0         0 $self->HDump($segPos, $hdrLen, 'Exif header', 'APP1 data type: Exif');
6700 0         0 $dumpEnd = $segPos + $length;
6701             }
6702 187         413 my $dataPt = $segDataPt;
6703 187 50       667 if (defined $combinedSegData) {
6704 0         0 push @skipData, [ $segPos-4, $segPos+$hdrLen ];
6705 0         0 $combinedSegData .= substr($$segDataPt,$hdrLen);
6706 0         0 undef $$segDataPt;
6707 0         0 $dataPt = \$combinedSegData;
6708 0         0 $segPos = $firstSegPos;
6709             }
6710             # peek ahead to see if the next segment is extended EXIF
6711 187 50 66     1301 if ($nextMarker == $marker and
6712             $$nextSegDataPt =~ /^$exifAPP1hdr(?!(MM\0\x2a|II\x2a\0))/)
6713             {
6714             # initialize combined data if necessary
6715 0 0       0 unless (defined $combinedSegData) {
6716 0         0 $combinedSegData = $$segDataPt;
6717 0         0 undef $$segDataPt;
6718 0         0 $firstSegPos = $segPos;
6719 0         0 $self->Warn('File contains multi-segment EXIF',1);
6720 0         0 $$self{ExtendedEXIF} = 1;
6721             }
6722 0         0 next;
6723             }
6724 187         581 $dirInfo{DataPt} = $dataPt;
6725 187         491 $dirInfo{DataPos} = $segPos;
6726 187         573 $dirInfo{DataLen} = $dirInfo{DirLen} = length $$dataPt;
6727 187         860 DirStart(\%dirInfo, $hdrLen, $hdrLen);
6728 187 50       671 $$self{SkipData} = \@skipData if @skipData;
6729             # extract the EXIF information (it is in standard TIFF format)
6730 187 50       1815 $self->ProcessTIFF(\%dirInfo) or $self->Warn('Malformed APP1 EXIF segment');
6731             # avoid looking for preview unless necessary because it really slows
6732             # us down -- only look for it if we found pointer, and preview is
6733             # outside EXIF, and PreviewImage is specifically requested
6734 187         983 my $start = $self->GetValue('PreviewImageStart', 'ValueConv');
6735 187         705 my $plen = $self->GetValue('PreviewImageLength', 'ValueConv');
6736 187 100 66     1280 if (not $start or not $plen and $$self{PreviewError}) {
      66        
6737 171         424 $start = $$self{PreviewImageStart};
6738 171         463 $plen = $$self{PreviewImageLength};
6739             }
6740 187 0 100     821 if ($start and $plen and IsInt($start) and IsInt($plen) and
      66        
      66        
      33        
      0        
      33        
6741             $start + $plen > $$self{EXIF_POS} + length($$self{EXIF_DATA}) and
6742             ($$req{previewimage} or
6743             # (extracted normally, so check Binary option)
6744             ($$options{Binary} and not $$self{EXCL_TAG_LOOKUP}{previewimage})))
6745             {
6746 0         0 $$self{PreviewImageStart} = $start;
6747 0         0 $$self{PreviewImageLength} = $plen;
6748 0         0 $wantTrailer = 1;
6749             }
6750 187 50       747 if (@skipData) {
6751 0         0 undef @skipData;
6752 0         0 delete $$self{SkipData};
6753             }
6754 187         483 undef $$dataPt;
6755 187         905 next;
6756             } elsif ($$segDataPt =~ /^$xmpExtAPP1hdr/) {
6757             # off len -- extended XMP header (75 bytes total):
6758             # 0 35 bytes - signature
6759             # 35 32 bytes - GUID (MD5 hash of full extended XMP data in ASCII)
6760             # 67 4 bytes - total size of extended XMP data
6761             # 71 4 bytes - offset for this XMP data portion
6762 2         6 $dumpType = 'Extended XMP';
6763 2 50       9 if ($length > 75) {
6764 2         13 my ($size, $off) = unpack('x67N2', $$segDataPt);
6765 2         7 my $guid = substr($$segDataPt, 35, 32);
6766 2 50       9 if ($guid =~ /[^A-Za-z0-9]/) { # (technically, should be uppercase)
6767 0         0 $self->WarnOnce($tip = 'Invalid extended XMP GUID');
6768             } else {
6769 2         6 my $extXMP = $extendedXMP{$guid};
6770 2 100       15 if (not $extXMP) {
    50          
6771 1         6 $extXMP = $extendedXMP{$guid} = { };
6772             } elsif ($size != $$extXMP{Size}) {
6773 0         0 $self->WarnOnce('Inconsistent extended XMP size');
6774             }
6775 2         6 $$extXMP{Size} = $size;
6776 2         8 $$extXMP{$off} = substr($$segDataPt, 75);
6777 2         15 $tip = "Full length: $size\nChunk offset: $off\nChunk length: " .
6778             ($length - 75) . "\nGUID: $guid";
6779             # (delay processing extended XMP until after reading all segments)
6780             }
6781             } else {
6782 0         0 $self->WarnOnce($tip = 'Invalid extended XMP segment');
6783             }
6784             } elsif ($$segDataPt =~ /^QVCI\0/) {
6785 1         3 $dumpType = 'QVCI';
6786 1         4 my $tagTablePtr = GetTagTable('Image::ExifTool::Casio::QVCI');
6787 1         5 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
6788             } elsif ($$segDataPt =~ /^FLIR\0/ and $length >= 8) {
6789 1         4 $dumpType = 'FLIR';
6790             # must concatenate FLIR chunks (note: handle the case where
6791             # some software erroneously writes zeros for the chunk counts)
6792 1         3 my $chunkNum = Get8u($segDataPt, 6);
6793 1         3 my $chunksTot = Get8u($segDataPt, 7) + 1; # (note the "+ 1"!)
6794 1 50       4 $verbose and printf $out "$$self{INDENT}FLIR chunk %d of %d\n",
6795             $chunkNum + 1, $chunksTot;
6796 1 50       4 if (defined $flirTotal) {
6797             # abort parsing FLIR if the total chunk count is inconsistent
6798 0 0       0 undef $flirCount if $chunksTot != $flirTotal;
6799             } else {
6800 1         2 $flirCount = 0;
6801 1         3 $flirTotal = $chunksTot;
6802             }
6803 1 50       3 if (defined $flirCount) {
6804 1 50       19 if (defined $flirChunk[$chunkNum]) {
6805 0         0 $self->WarnOnce('Duplicate FLIR chunk number(s)');
6806 0         0 $flirChunk[$chunkNum] .= substr($$segDataPt, 8);
6807             } else {
6808 1         14 $flirChunk[$chunkNum] = substr($$segDataPt, 8);
6809             }
6810             # process the FLIR information if we have all of the chunks
6811 1 50       4 if (++$flirCount >= $flirTotal) {
6812 1         2 my $flir = '';
6813 1   33     12 defined $_ and $flir .= $_ foreach @flirChunk;
6814 1         4 undef @flirChunk; # free memory
6815 1         3 my $tagTablePtr = GetTagTable('Image::ExifTool::FLIR::FFF');
6816 1         8 my %dirInfo = (
6817             DataPt => \$flir,
6818             Parent => $markerName,
6819             DirName => 'FLIR',
6820             );
6821 1         5 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
6822 1         6 undef $flirCount; # prevent reprocessing
6823             }
6824             } else {
6825 0         0 $self->WarnOnce('Invalid or extraneous FLIR chunk(s)');
6826             }
6827             } elsif ($$segDataPt =~ /^PARROT\0(II\x2a\0|MM\0\x2a)/) {
6828             # (don't know if this could span multiple segments)
6829 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::Main');
6830 0         0 $self->HandleTag($tagTablePtr, 'APP1', $$segDataPt);
6831 0         0 $dumpType = 'Parrot';
6832             } else {
6833             # Hmmm. Could be XMP, let's see
6834 68         196 my $processed;
6835 68 50 33     540 if ($$segDataPt =~ /^(http|XMP\0)/ or $$segDataPt =~ /<(exif:|\?xpacket)/) {
6836 68         181 $dumpType = 'XMP';
6837             # also try to parse XMP with a non-standard header
6838             # (note: this non-standard XMP is ignored when writing)
6839 68 50       714 my $start = ($$segDataPt =~ /^$xmpAPP1hdr/) ? length($xmpAPP1hdr) : 0;
6840 68         307 my $tagTablePtr = GetTagTable('Image::ExifTool::XMP::Main');
6841 68         391 DirStart(\%dirInfo, $start);
6842 68 50       592 $dirInfo{DirName} = $start ? 'XMP' : 'XML',
6843             $processed = $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
6844 68 50 33     601 if ($processed and not $start) {
6845 0         0 $self->Warn('Non-standard header for APP1 XMP segment');
6846             }
6847             }
6848 68 50 33     365 if ($verbose and not $processed) {
6849 0         0 $self->Warn("Ignored APP1 segment length $length (unknown header)");
6850             }
6851             }
6852             } elsif ($marker == 0xe2) { # APP2 (ICC Profile, FPXR, MPF, PreviewImage)
6853 120 100 66     1085 if ($$segDataPt =~ /^ICC_PROFILE\0/ and $length >= 14) {
    100          
    50          
    0          
    0          
6854 34         108 $dumpType = 'ICC_Profile';
6855             # must concatenate profile chunks (note: handle the case where
6856             # some software erroneously writes zeros for the chunk counts)
6857 34         168 my $chunkNum = Get8u($segDataPt, 12);
6858 34         133 my $chunksTot = Get8u($segDataPt, 13);
6859 34 50       192 $verbose and print $out "$$self{INDENT}ICC_Profile chunk $chunkNum of $chunksTot\n";
6860 34 50       119 if (defined $iccChunksTotal) {
6861             # abort parsing ICC_Profile if the total chunk count is inconsistent
6862 0 0       0 undef $iccChunkCount if $chunksTot != $iccChunksTotal;
6863             } else {
6864 34         76 $iccChunkCount = 0;
6865 34         73 $iccChunksTotal = $chunksTot;
6866 34 50       119 $self->Warn('ICC_Profile chunk count is zero') if !$chunksTot;
6867             }
6868 34 50       129 if (defined $iccChunkCount) {
6869 34 50       142 if (defined $iccChunk[$chunkNum]) {
6870 0         0 $self->WarnOnce('Duplicate ICC_Profile chunk number(s)');
6871 0         0 $iccChunk[$chunkNum] .= substr($$segDataPt, 14);
6872             } else {
6873 34         228 $iccChunk[$chunkNum] = substr($$segDataPt, 14);
6874             }
6875             # process profile if we have all of the chunks
6876 34 50       162 if (++$iccChunkCount >= $iccChunksTotal) {
6877 34         80 my $icc_profile = '';
6878 34   66     298 defined $_ and $icc_profile .= $_ foreach @iccChunk;
6879 34         105 undef @iccChunk; # free memory
6880 34         122 my $tagTablePtr = GetTagTable('Image::ExifTool::ICC_Profile::Main');
6881 34         310 my %dirInfo = (
6882             DataPt => \$icc_profile,
6883             DataPos => $segPos + 14,
6884             DataLen => length($icc_profile),
6885             DirStart => 0,
6886             DirLen => length($icc_profile),
6887             Parent => $markerName,
6888             );
6889 34         192 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
6890 34         177 undef $iccChunkCount; # prevent reprocessing
6891             }
6892             } else {
6893 0         0 $self->WarnOnce('Invalid or extraneous ICC_Profile chunk(s)');
6894             }
6895             } elsif ($$segDataPt =~ /^FPXR\0/) {
6896 67 50       213 next if $fast > 1; # skip processing for very fast
6897 67         130 $dumpType = 'FPXR';
6898 67         207 my $tagTablePtr = GetTagTable('Image::ExifTool::FlashPix::Main');
6899             # set flag if this is the last FPXR segment
6900 67   100     583 $dirInfo{LastFPXR} = not ($nextMarker==$marker and $$nextSegDataPt=~/^FPXR\0/),
6901             $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
6902             } elsif ($$segDataPt =~ /^MPF\0/) {
6903 19         59 undef $dumpType; # (will be dumped here)
6904 19         89 DirStart(\%dirInfo, 4, 4);
6905 19         59 $dirInfo{Multi} = 1; # the MP Attribute IFD will be MPF1
6906 19 50       72 if ($htmlDump) {
6907 0         0 $self->HDump($segPos-4, 4, 'APP2 header', "Data size: $length bytes");
6908 0         0 $self->HDump($segPos, 4, 'MPF header', 'APP2 data type: MPF');
6909 0         0 $dumpEnd = $segPos + $length;
6910             }
6911             # extract the MPF information (it is in standard TIFF format)
6912 19         74 my $tagTablePtr = GetTagTable('Image::ExifTool::MPF::Main');
6913 19         128 $self->ProcessTIFF(\%dirInfo, $tagTablePtr);
6914             } elsif ($$segDataPt =~ /^(|QVGA\0|BGTH)\xff\xd8\xff[\xdb\xe0\xe1]/) {
6915             # Samsung/GE/GoPro="", BenQ DC C1220/Pentacon/Polaroid="QVGA\0",
6916             # Digilife DDC-690/Rollei="BGTH"
6917 0         0 $dumpType = 'Preview Image';
6918 0         0 $preview = substr($$segDataPt, length($1));
6919             } elsif ($preview) {
6920 0         0 $dumpType = 'Preview Image';
6921 0         0 $preview .= $$segDataPt;
6922             }
6923 120 50 33     429 if ($preview and $nextMarker ne $marker) {
6924 0         0 $self->FoundTag('PreviewImage', $preview);
6925 0         0 undef $preview;
6926             }
6927             } elsif ($marker == 0xe3) { # APP3 (Kodak "Meta", Stim)
6928 20 100       218 if ($$segDataPt =~ /^(Meta|META|Exif)\0\0/) {
    50          
    50          
    0          
    0          
6929 19         53 undef $dumpType; # (will be dumped here)
6930 19         91 DirStart(\%dirInfo, 6, 6);
6931 19 50       100 if ($htmlDump) {
6932 0         0 $self->HDump($segPos-4, 10, 'APP3 Meta header');
6933 0         0 $dumpEnd = $segPos + $length;
6934             }
6935 19         72 my $tagTablePtr = GetTagTable('Image::ExifTool::Kodak::Meta');
6936 19         111 $self->ProcessTIFF(\%dirInfo, $tagTablePtr);
6937             } elsif ($$segDataPt =~ /^Stim\0/) {
6938 0         0 undef $dumpType; # (will be dumped here)
6939 0         0 DirStart(\%dirInfo, 6, 6);
6940 0 0       0 if ($htmlDump) {
6941 0         0 $self->HDump($segPos-4, 4, 'APP3 header', "Data size: $length bytes");
6942 0         0 $self->HDump($segPos, 5, 'Stim header', 'APP3 data type: Stim');
6943 0         0 $dumpEnd = $segPos + $length;
6944             }
6945             # extract the Stim information (it is in standard TIFF format)
6946 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::Stim::Main');
6947 0         0 $self->ProcessTIFF(\%dirInfo, $tagTablePtr);
6948             } elsif ($$segDataPt =~ /^_JPSJPS_/) {
6949 1         4 $dumpType = 'JPS';
6950 1 50       11 $self->OverrideFileType('JPS') if $$self{FILE_TYPE} eq 'JPEG';
6951 1         5 SetByteOrder('MM');
6952 1         3 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::JPS');
6953 1         6 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
6954             } elsif ($$self{Make} eq 'DJI') {
6955 0         0 $dumpType = 'DJI ThermalData';
6956             # add this data to the combined data if it exists
6957 0         0 my $dataPt = $segDataPt;
6958 0 0       0 if (defined $combinedSegData) {
6959 0         0 $combinedSegData .= $$segDataPt;
6960 0         0 $dataPt = \$combinedSegData;
6961             }
6962 0 0       0 if ($nextMarker == $marker) {
6963 0 0       0 $combinedSegData = $$segDataPt unless defined $combinedSegData;
6964             } else {
6965             # process DJI FLIR thermal data
6966 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::Main');
6967 0         0 $self->HandleTag($tagTablePtr, 'APP3', $$dataPt);
6968 0         0 undef $combinedSegData;
6969             }
6970             } elsif ($$segDataPt =~ /^\xff\xd8\xff\xdb/) {
6971 0         0 $dumpType = 'PreviewImage'; # (Samsung, HP, BenQ)
6972 0         0 $preview = $$segDataPt;
6973             }
6974 20 50 33     149 if ($preview and $nextMarker ne 0xe4) { # this preview continues in APP4
6975 0         0 $self->FoundTag('PreviewImage', $preview);
6976 0         0 undef $preview;
6977             }
6978             } elsif ($marker == 0xe4) { # APP4 ("SCALADO", FPXR, PreviewImage)
6979 0 0 0     0 if ($$segDataPt =~ /^SCALADO\0/ and $length >= 16) {
    0 0        
    0          
    0          
6980 0         0 $dumpType = 'SCALADO';
6981 0         0 my ($num, $idx, $len) = unpack('x8n2N', $$segDataPt);
6982             # assume that the segments are in order and just concatinate them
6983 0 0       0 $scalado = '' unless defined $scalado;
6984 0         0 $scalado .= substr($$segDataPt, 16);
6985 0 0       0 if ($idx == $num - 1) {
6986 0 0       0 if ($len != length $scalado) {
6987 0         0 $self->Warn('Possibly corrupted APP4 SCALADO data', 1);
6988             }
6989 0         0 my %dirInfo = (
6990             Parent => $markerName,
6991             DataPt => \$scalado,
6992             );
6993 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::Scalado::Main');
6994 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
6995 0         0 undef $scalado;
6996             }
6997             } elsif ($$segDataPt =~ /^FPXR\0/) {
6998 0 0       0 next if $fast > 1; # skip processing for very fast
6999 0         0 $dumpType = 'FPXR';
7000 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::FlashPix::Main');
7001             # set flag if this is the last FPXR segment
7002 0   0     0 $dirInfo{LastFPXR} = not ($nextMarker==$marker and $$nextSegDataPt=~/^FPXR\0/),
7003             $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7004             } elsif ($$self{Make} eq 'DJI' and $$segDataPt =~ /^\xaa\x55\x12\x06/) {
7005 0         0 $dumpType = 'DJI ThermalParams';
7006 0         0 DirStart(\%dirInfo, 0, 0);
7007 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::DJI::ThermalParams');
7008 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7009             } elsif ($preview) {
7010             # continued Samsung S1060 preview from APP3
7011 0         0 $dumpType = 'PreviewImage';
7012 0         0 $preview .= $$segDataPt;
7013             }
7014             # (also seen "QTI Debug Metadata\0" segment in some newer Samsung images)
7015             # BenQ DC E1050 continues preview in APP5
7016 0 0 0     0 if ($preview and $nextMarker ne 0xe5) {
7017 0         0 $self->FoundTag('PreviewImage', $preview);
7018 0         0 undef $preview;
7019             }
7020             } elsif ($marker == 0xe5) { # APP5 (Ricoh "RMETA")
7021 20 50       138 if ($$segDataPt =~ /^RMETA\0/) {
    0          
    0          
    0          
7022             # (NOTE: apparently these may span multiple segments, but I haven't seen
7023             # a sample like this, so multi-segment support hasn't yet been implemented)
7024 20         66 $dumpType = 'Ricoh RMETA';
7025 20         124 DirStart(\%dirInfo, 6, 6);
7026 20         114 my $tagTablePtr = GetTagTable('Image::ExifTool::Ricoh::RMETA');
7027 20         107 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7028             } elsif ($$segDataPt =~ /^ssuniqueid\0/) {
7029 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::Samsung::APP5');
7030 0         0 $self->HandleTag($tagTablePtr, 'ssuniqueid', substr($$segDataPt, 11));
7031             } elsif ($$self{Make} eq 'DJI') {
7032 0         0 $dumpType = 'DJI ThermalCal';
7033 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::Main');
7034 0         0 $self->HandleTag($tagTablePtr, 'APP5', $$segDataPt);
7035             } elsif ($preview) {
7036 0         0 $dumpType = 'PreviewImage';
7037 0         0 $preview .= $$segDataPt;
7038 0         0 $self->FoundTag('PreviewImage', $preview);
7039 0         0 undef $preview;
7040             }
7041             } elsif ($marker == 0xe6) { # APP6 (Toshiba EPPIM, NITF, HP_TDHD)
7042 37 100 33     342 if ($$segDataPt =~ /^EPPIM\0/) {
    100          
    50          
    50          
    0          
7043 18         61 undef $dumpType; # (will be dumped here)
7044 18         90 DirStart(\%dirInfo, 6, 6);
7045 18 50       99 if ($htmlDump) {
7046 0         0 $self->HDump($segPos-4, 10, 'APP6 EPPIM header');
7047 0         0 $dumpEnd = $segPos + $length;
7048             }
7049 18         65 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::EPPIM');
7050 18         101 $self->ProcessTIFF(\%dirInfo, $tagTablePtr);
7051             } elsif ($$segDataPt =~ /^NITF\0/) {
7052 18         53 $dumpType = 'NITF';
7053 18         72 SetByteOrder('MM');
7054 18         123 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::NITF');
7055 18         105 DirStart(\%dirInfo, 5);
7056 18         113 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7057             } elsif ($$segDataPt =~ /^TDHD\x01\0\0\0/ and $length > 12) {
7058             # HP Photosmart R837 APP6 "TDHD" segment
7059 0         0 $dumpType = 'TDHD';
7060 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::HP::TDHD');
7061             # (ignore first TDHD element because size includes 12-byte tag header)
7062 0         0 DirStart(\%dirInfo, 12);
7063 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7064             } elsif ($$segDataPt =~ /^GoPro\0/) {
7065             # GoPro segment
7066 1         2 $dumpType = 'GoPro';
7067 1         4 my $tagTablePtr = GetTagTable('Image::ExifTool::GoPro::GPMF');
7068 1         4 DirStart(\%dirInfo, 6);
7069 1         5 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7070             } elsif ($$segDataPt =~ /^DTAT\0\0.\{/s) {
7071 0         0 $dumpType = 'DJI_DTAT';
7072 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::Main');
7073 0         0 $self->HandleTag($tagTablePtr, 'APP6', $$segDataPt);
7074             }
7075             } elsif ($marker == 0xe7) { # APP7 (Pentax, Huawei, Qualcomm)
7076 19 50       230 if ($$segDataPt =~ /^PENTAX \0(II|MM)/) {
    50          
    50          
7077             # found in K-3 images (is this multi-segment??)
7078 0         0 SetByteOrder($1);
7079 0         0 undef $dumpType; # (dump this ourself)
7080 0         0 my $hdrLen = 10;
7081 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::Pentax::Main');
7082 0         0 DirStart(\%dirInfo, $hdrLen, 0);
7083 0         0 $dirInfo{DirName} = 'Pentax APP7';
7084 0 0       0 if ($htmlDump) {
7085 0         0 $self->HDump($segPos-4, 4, 'APP7 header', "Data size: $length bytes");
7086 0         0 $self->HDump($segPos, $hdrLen, 'Pentax header', 'APP7 data type: Pentax');
7087 0         0 $dumpEnd = $segPos + $length;
7088             }
7089 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7090             } elsif ($$segDataPt =~ /^HUAWEI\0\0(II|MM)/) {
7091 0         0 SetByteOrder($1);
7092 0         0 undef $dumpType; # (dump this ourself)
7093 0         0 my $hdrLen = 16;
7094 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::Unknown::Main');
7095 0         0 DirStart(\%dirInfo, $hdrLen, 8);
7096 0         0 $dirInfo{DirName} = 'Huawei APP7';
7097 0 0       0 if ($htmlDump) {
7098 0         0 $self->HDump($segPos-4, 4, 'APP7 header', "Data size: $length bytes");
7099 0         0 $self->HDump($segPos, $hdrLen, 'Huawei header', 'APP7 data type: Huawei');
7100 0         0 $dumpEnd = $segPos + $length;
7101             }
7102 0         0 $$self{SET_GROUP0} = 'APP7';
7103 0         0 $$self{SET_GROUP1} = 'Huawei';
7104 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7105 0         0 delete $$self{SET_GROUP0};
7106 0         0 delete $$self{SET_GROUP1};
7107             } elsif ($$segDataPt =~ /^\x1aQualcomm Camera Attributes/) {
7108             # found in HP iPAQ_VoiceMessenger
7109 19         58 $dumpType = 'Qualcomm';
7110 19         78 my $tagTablePtr = GetTagTable('Image::ExifTool::Qualcomm::Main');
7111 19         100 DirStart(\%dirInfo, 27);
7112 19         83 $dirInfo{DirName} = 'Qualcomm';
7113 19         103 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7114             }
7115             } elsif ($marker == 0xe8) { # APP8 (SPIFF)
7116             # my sample SPIFF has 32 bytes of data, but spec states 30
7117 19 50 33     169 if ($$segDataPt =~ /^SPIFF\0/ and $length == 32) {
7118 19         50 $dumpType = 'SPIFF';
7119 19         77 DirStart(\%dirInfo, 6);
7120 19         91 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::SPIFF');
7121 19         102 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7122             }
7123             } elsif ($marker == 0xe9) { # APP9 (Media Jukebox)
7124 19 50 33     203 if ($$segDataPt =~ /^Media Jukebox\0/ and $length > 22) {
7125 19         59 $dumpType = 'MediaJukebox';
7126             # (start parsing after the "")
7127 19         85 DirStart(\%dirInfo, 22);
7128 19         79 $dirInfo{DirName} = 'MediaJukebox';
7129 19         175 require Image::ExifTool::XMP;
7130 19         74 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::MediaJukebox');
7131 19         123 $self->ProcessDirectory(\%dirInfo, $tagTablePtr, \&Image::ExifTool::XMP::ProcessXMP);
7132             }
7133             } elsif ($marker == 0xea) { # APP10 (PhotoStudio Unicode comments)
7134 19 50 0     129 if ($$segDataPt =~ /^UNICODE\0/) {
    0          
7135 19         51 $dumpType = 'PhotoStudio';
7136 19         118 my $comment = $self->Decode(substr($$segDataPt,8), 'UCS2', 'MM');
7137 19         111 $self->FoundTag('Comment', $comment);
7138             } elsif ($$segDataPt =~ /^AROT\0/ and $length > 10) {
7139             # iPhone "AROT" segment containing integrated intensity per 16 scan lines
7140             # (with number of elements N = ImageHeight / 16 - 1, ref PH/NealKrawetz)
7141 0         0 $xtra = 'segment (N=' . unpack('x6N', $$segDataPt) . ')';
7142             }
7143             } elsif ($marker == 0xeb) { # APP11 (JPEG-HDR, JUMBF)
7144 38 100 33     390 if ($$segDataPt =~ /^HDR_RI /) {
    50          
7145 19         55 $dumpType = 'JPEG-HDR';
7146 19         56 my $dataPt = $segDataPt;
7147 19 50       73 if (defined $combinedSegData) {
7148 0 0       0 if ($$segDataPt =~ /~\0/g) {
7149 0         0 $combinedSegData .= substr($$segDataPt,pos($$segDataPt));
7150             } else {
7151 0         0 $self->Warn('Invalid format for JPEG-HDR extended segment');
7152             }
7153 0         0 $dataPt = \$combinedSegData;
7154             }
7155 19 50 33     147 if ($nextMarker == $marker and $$nextSegDataPt =~ /^HDR_RI /) {
7156 0 0       0 $combinedSegData = $$segDataPt unless defined $combinedSegData;
7157             } else {
7158 19         75 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::HDR');
7159 19         86 my %dirInfo = ( DataPt => $dataPt );
7160 19         95 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7161 19         101 undef $combinedSegData;
7162             }
7163             } elsif ($$segDataPt =~ /^(JP..)/s and length($$segDataPt) >= 16) {
7164             # JUMBF extension marker
7165 19         66 my $hdr = $1;
7166 19         84 $dumpType = 'JUMBF';
7167 19         100 SetByteOrder('MM');
7168 19         112 my $seq = Get32u($segDataPt, 4) - 1; # (start from 0)
7169 19         70 my $len = Get32u($segDataPt, 8);
7170 19         85 my $type = substr($$segDataPt, 12, 4);
7171 19         51 my $hdrLen;
7172 19 50 33     92 if ($len == 1 and length($$segDataPt) >= 24) {
7173 0         0 $len = Get64u($$segDataPt, 16);
7174 0         0 $hdrLen = 16;
7175             } else {
7176 19         45 $hdrLen = 8;
7177             }
7178 19 50       106 $jumbfChunk{$type} or $jumbfChunk{$type} = [ ];
7179 19 50       126 if ($len < $hdrLen) {
    50          
    50          
7180 0         0 $self->Warn('Invalid JUMBF segment');
7181             } elsif ($seq < 0) {
7182 0         0 $self->Warn('Invalid JUMBF sequence number');
7183             } elsif (defined $jumbfChunk{$type}[$seq]) {
7184 0         0 $self->Warn('Duplicate JUMBF sequence number');
7185             } else {
7186             # add to list of JUMBF chunks
7187 19         83 $jumbfChunk{$type}[$seq] = substr($$segDataPt, 8 + $hdrLen);
7188             # check to see if we have a complete JUMBF box
7189 19         45 my $size = $hdrLen;
7190 19         45 foreach (@{$jumbfChunk{$type}}) {
  19         73  
7191 19 50       71 defined $_ or $size = 0, last;
7192 19         52 $size += length $_;
7193             }
7194 19 50       66 if ($size == $len) {
7195 19         58 my $buff = join '', substr($$segDataPt,8,$hdrLen), @{$jumbfChunk{$type}};
  19         82  
7196 19         60 $dirInfo{DataPt} = \$buff;
7197 19         60 $dirInfo{DataPos} = $segPos + 8; # (shows correct offsets for single-segment JUMBF)
7198 19         61 $dirInfo{DataLen} = $dirInfo{DirLen} = $size;
7199 19         66 my $tagTablePtr = GetTagTable('Image::ExifTool::Jpeg2000::Main');
7200 19         120 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7201 19         129 delete $jumbfChunk{$type};
7202             }
7203             }
7204             }
7205             } elsif ($marker == 0xec) { # APP12 (Ducky, Picture Info)
7206 40 100       217 if ($$segDataPt =~ /^Ducky/) {
7207 21         78 $dumpType = 'Ducky';
7208 21         108 DirStart(\%dirInfo, 5);
7209 21         99 my $tagTablePtr = GetTagTable('Image::ExifTool::APP12::Ducky');
7210 21         126 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7211             } else {
7212 19         79 my $tagTablePtr = GetTagTable('Image::ExifTool::APP12::PictureInfo');
7213 19 50       137 $self->ProcessDirectory(\%dirInfo, $tagTablePtr) and $dumpType = 'Picture Info';
7214             }
7215             } elsif ($marker == 0xed) { # APP13 (Photoshop, Adobe_CM)
7216 82         210 my $isOld;
7217 82 100 50     1312 if ($$segDataPt =~ /^$psAPP13hdr/ or ($$segDataPt =~ /^$psAPP13old/ and $isOld=1)) {
    50 66        
7218 63         185 $dumpType = 'Photoshop';
7219             # add this data to the combined data if it exists
7220 63         157 my $dataPt = $segDataPt;
7221 63 50       252 if (defined $combinedSegData) {
7222 0         0 $combinedSegData .= substr($$segDataPt,length($psAPP13hdr));
7223 0         0 $dataPt = \$combinedSegData;
7224             }
7225             # peek ahead to see if the next segment is photoshop data too
7226 63 50 66     464 if ($nextMarker == $marker and $$nextSegDataPt =~ /^$psAPP13hdr/) {
7227             # initialize combined data if necessary
7228 0 0       0 $combinedSegData = $$segDataPt unless defined $combinedSegData;
7229             # (will handle the Photoshop data the next time around)
7230             } else {
7231 63 50       210 my $hdrLen = $isOld ? 27 : 14;
7232             # process APP13 Photoshop record
7233 63         256 my $tagTablePtr = GetTagTable('Image::ExifTool::Photoshop::Main');
7234 63         637 my %dirInfo = (
7235             DataPt => $dataPt,
7236             DataPos => $segPos,
7237             DataLen => length $$dataPt,
7238             DirStart => $hdrLen, # directory starts after identifier
7239             DirLen => length($$dataPt) - $hdrLen,
7240             Parent => $markerName,
7241             );
7242 63         323 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7243 63         423 undef $combinedSegData;
7244             }
7245             } elsif ($$segDataPt =~ /^Adobe_CM/) {
7246 19         63 $dumpType = 'Adobe_CM';
7247 19         85 SetByteOrder('MM');
7248 19         99 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::AdobeCM');
7249 19         97 DirStart(\%dirInfo, 8);
7250 19         92 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7251             }
7252             } elsif ($marker == 0xee) { # APP14 (Adobe)
7253 45 50       304 if ($$segDataPt =~ /^Adobe/) {
7254             # extract as a block if requested, or if copying tags from file
7255 45 100 66     419 if ($$req{adobe} or
      66        
7256             # (not extracted normally, so check TAGS_FROM_FILE)
7257             ($$self{TAGS_FROM_FILE} and not $$self{EXCL_TAG_LOOKUP}{adobe}))
7258             {
7259 16         73 $self->FoundTag('Adobe', $$segDataPt);
7260             }
7261 45         190 $dumpType = 'Adobe';
7262 45         182 SetByteOrder('MM');
7263 45         296 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::Adobe');
7264 45         214 DirStart(\%dirInfo, 5);
7265 45         247 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7266             }
7267             } elsif ($marker == 0xef) { # APP15 (GraphicConverter)
7268 19 50 33     207 if ($$segDataPt =~ /^Q\s*(\d+)/ and $length == 4) {
7269 19         55 $dumpType = 'GraphicConverter';
7270 19         94 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::GraphConv');
7271 19         97 $self->HandleTag($tagTablePtr, 'Q', $1);
7272             }
7273             } elsif ($marker == 0xfe) { # COM (JPEG comment)
7274 27         80 $dumpType = 'Comment';
7275 27         102 $$segDataPt =~ s/\0+$//; # some dumb softwares add null terminators
7276 27         98 $self->FoundTag('Comment', $$segDataPt);
7277             } elsif ($marker == 0x64) { # CME (J2C comment and extension)
7278 2         7 $dumpType = 'Comment';
7279 2 50       11 if ($length > 2) {
7280 2         7 my $reg = unpack('n', $$segDataPt); # get registration value
7281 2         11 my $val = substr($$segDataPt, 2);
7282 2 50       11 $val = $self->Decode($val, 'Latin') if $reg == 1;
7283             # (actually an extension for $reg==65535, but store as binary comment)
7284 2 50 33     15 $self->FoundTag('Comment', ($reg==0 or $reg==65535) ? \$val : $val);
7285             }
7286             } elsif ($marker == 0x51) { # SIZ (J2C)
7287 1         6 my ($w, $h) = unpack('x2N2', $$segDataPt);
7288 1         5 $self->FoundTag('ImageWidth', $w);
7289 1         3 $self->FoundTag('ImageHeight', $h);
7290             } elsif (($marker & 0xf0) != 0xe0) {
7291 466         1155 $dumpType = "$markerName segment";
7292 466         1257 $desc = "[JPEG $markerName]"; # (other known JPEG segments)
7293             }
7294 1171 100       3308 if (defined $dumpType) {
7295 1115 50 33     3023 if (not $dumpType and ($$options{Unknown} or $$options{Validate})) {
      66        
7296 0 0       0 my $str = ($$segDataPt =~ /^([\x20-\x7e]{1,20})\0/) ? " '${1}'" : '';
7297 0 0       0 $xtra = 'segment' unless $xtra;
7298 0         0 $self->Warn("Unknown $markerName$str $xtra", 1);
7299             }
7300 1115 50       2655 if ($htmlDump) {
7301 0 0       0 $desc or $desc = $markerName . ($dumpType ? " $dumpType" : '') . ' segment';
    0          
7302 0         0 $self->HDump($segPos-4, $length+4, $desc, $tip, 0x08);
7303 0         0 $dumpEnd = $segPos + $length;
7304             }
7305             }
7306 1171         4350 undef $$segDataPt;
7307             }
7308             # process extended XMP now if it existed
7309 232 100       871 if (%extendedXMP) {
7310 1         7 my $guid;
7311             # GUID indicated by the last main XMP segment
7312 1   50     9 my $goodGuid = $$self{VALUE}{HasExtendedXMP} || '';
7313             # GUID of the extended XMP that we will process ('2' for all)
7314 1   50     11 my $readGuid = $$options{ExtendedXMP} || 0;
7315 1 50       6 $readGuid = $goodGuid if $readGuid eq '1';
7316 1         7 foreach $guid (sort keys %extendedXMP) {
7317 1 50       6 next unless length $guid == 32; # ignore other (internal) keys
7318 1         4 my $extXMP = $extendedXMP{$guid};
7319 1         4 my ($off, @offsets, $warn);
7320             # make sure we have all chunks, and create a list of sorted offsets
7321 1         6 for ($off=0; $off<$$extXMP{Size}; ) {
7322 2 50       7 last unless defined $$extXMP{$off};
7323 2         6 push @offsets, $off;
7324 2         6 $off += length $$extXMP{$off};
7325             }
7326 1 50       6 unless ($off == $$extXMP{Size}) {
7327 0         0 $self->Warn("Incomplete extended XMP (GUID $guid)");
7328 0         0 next;
7329             }
7330 1 50 33     8 if ($guid eq $readGuid or $readGuid eq '2') {
7331 1 50       4 $warn = 'Reading non-' if $guid ne $goodGuid;
7332 1         3 my $buff = '';
7333             # assemble XMP all together
7334 1         7 $buff .= $$extXMP{$_} foreach @offsets;
7335 1         4 my $tagTablePtr = GetTagTable('Image::ExifTool::XMP::Main');
7336 1         6 my %dirInfo = (
7337             DataPt => \$buff,
7338             Parent => 'APP1',
7339             IsExtended => 1,
7340             );
7341 1         5 $$path[$pn] = 'APP1';
7342 1         5 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7343 1         15 pop @$path;
7344             } else {
7345 0         0 $warn = 'Ignored ';
7346 0 0       0 $warn .= 'non-' if $guid ne $goodGuid;
7347             }
7348 1 50       22 $self->Warn("${warn}standard extended XMP (GUID $guid)") if $warn;
7349 1         8 delete $extendedXMP{$guid};
7350             }
7351             }
7352             # calculate JPEGDigest if requested
7353 232 100       852 if (@dqt) {
7354 1         1425 require Image::ExifTool::JPEGDigest;
7355 1         23 Image::ExifTool::JPEGDigest::Calculate($self, \@dqt, $subSampling);
7356             }
7357             # issue necessary warnings
7358 232 50       794 $self->Warn('Invalid JUMBF size or missing JUMBF chunk') if %jumbfChunk;
7359 232 50       859 $self->Warn('Incomplete ICC_Profile record', 1) if defined $iccChunkCount;
7360 232 50       697 $self->Warn('Incomplete FLIR record', 1) if defined $flirCount;
7361 232 50       829 $self->Warn('Error reading PreviewImage', 1) if $$self{PreviewError};
7362 232 50       661 $success or $self->Warn('JPEG format error');
7363 232 50       889 pop @$path if @$path > $pn;
7364 232         2023 return 1;
7365             }
7366              
7367             #------------------------------------------------------------------------------
7368             # Extract metadata from an Exiv2 EXV file
7369             # Inputs: 0) ExifTool object reference, 1) dirInfo ref with RAF set
7370             # Returns: 1 on success, 0 if this wasn't a valid JPEG file
7371             sub ProcessEXV($$)
7372             {
7373 2     2 0 9 my ($self, $dirInfo) = @_;
7374 2         14 return $self->ProcessJPEG($dirInfo);
7375             }
7376              
7377             #------------------------------------------------------------------------------
7378             # Process EXIF file
7379             # Inputs/Returns: same as ProcessTIFF
7380             sub ProcessEXIF($$;$)
7381             {
7382 2     2 0 10 my ($self, $dirInfo, $tagTablePtr) = @_;
7383 2         9 return $self->ProcessTIFF($dirInfo, $tagTablePtr);
7384             }
7385              
7386             #------------------------------------------------------------------------------
7387             # Process TIFF data (wrapper for DoProcessTIFF to allow re-entry)
7388             # Inputs: 0) ExifTool object ref, 1) dirInfo ref, 2) optional tag table ref
7389             # Returns: 1 if this looked like a valid EXIF block, 0 otherwise, or -1 on write error
7390             sub ProcessTIFF($$;$)
7391             {
7392 483     483 0 2332 my ($self, $dirInfo, $tagTablePtr) = @_;
7393 483         1211 my $exifData = $$self{EXIF_DATA};
7394 483         1215 my $exifPos = $$self{EXIF_POS};
7395 483         2216 my $rtnVal = $self->DoProcessTIFF($dirInfo, $tagTablePtr);
7396             # restore original EXIF information (in case ProcessTIFF is nested)
7397 483 100       1704 if (defined $exifData) {
7398 108         286 $$self{EXIF_DATA} = $exifData;
7399 108         228 $$self{EXIF_POS} = $exifPos;
7400             }
7401 483         2084 return $rtnVal;
7402             }
7403              
7404             #------------------------------------------------------------------------------
7405             # Process TIFF data
7406             # Inputs: 0) ExifTool object ref, 1) dirInfo ref, 2) optional tag table ref
7407             # Returns: 1 if this looked like a valid EXIF block, 0 otherwise, or -1 on write error
7408             sub DoProcessTIFF($$;$)
7409             {
7410 483     483 0 1417 my ($self, $dirInfo, $tagTablePtr) = @_;
7411 483         1223 my $dataPt = $$dirInfo{DataPt};
7412 483   100     1831 my $fileType = $$dirInfo{Parent} || '';
7413 483         1117 my $raf = $$dirInfo{RAF};
7414 483   100     2713 my $base = $$dirInfo{Base} || 0;
7415 483         1206 my $outfile = $$dirInfo{OutFile};
7416 483         1133 my ($err, $sig, $canonSig, $otherSig);
7417              
7418             # attempt to read TIFF header
7419 483         1486 $$self{EXIF_DATA} = '';
7420 483 100 100     3249 if ($raf) {
    100          
    50          
7421 47 100       166 if ($outfile) {
7422 14 50       3496 $raf->Seek(0, 0) or return 0;
7423 14 50       98 if ($base) {
7424 0 0       0 $raf->Read($$dataPt, $base) == $base or return 0;
7425 0 0       0 Write($outfile, $$dataPt) or $err = 1;
7426             }
7427             } else {
7428 33 50       206 $raf->Seek($base, 0) or return 0;
7429             }
7430             # extract full EXIF block (for block copy) from EXIF file
7431 47 100       253 my $amount = $fileType eq 'EXIF' ? 65536 * 8 : 8;
7432 47         246 my $n = $raf->Read($$self{EXIF_DATA}, $amount);
7433 47 100       274 if ($n < 8) {
7434 1 50 33     13 return 0 if $n or not $outfile or $fileType ne 'EXIF';
      33        
7435             # create EXIF file from scratch
7436 1         4 delete $$self{EXIF_DATA};
7437 1         3 undef $raf;
7438             }
7439 47 100       564 if ($n > 8) {
7440 2         14 $raf->Seek(8, 0);
7441 2 50       18 if ($n == $amount) {
7442 0         0 $$self{EXIF_DATA} = substr($$self{EXIF_DATA}, 0, 8);
7443 0         0 $self->Warn('EXIF too large to extract as a block'); #(shouldn't happen)
7444             }
7445             }
7446             } elsif ($dataPt and length $$dataPt) {
7447             # save a copy of the EXIF data
7448 394   100     1880 my $dirStart = $$dirInfo{DirStart} || 0;
7449 394   66     1391 my $dirLen = $$dirInfo{DirLen} || (length($$dataPt) - $dirStart);
7450 394         2515 $$self{EXIF_DATA} = substr($$dataPt, $dirStart, $dirLen);
7451 394 50 66     1999 $self->VerboseDir('TIFF') if $$self{OPTIONS}{Verbose} and length($$self{INDENT}) > 2;
7452             } elsif ($outfile) {
7453 42         145 delete $$self{EXIF_DATA}; # create from scratch
7454             } else {
7455 0         0 $$self{EXIF_DATA} = '';
7456             }
7457 483 100       1795 unless (defined $$self{EXIF_DATA}) {
7458             # set default byte order for creating new GPS in CR3 images
7459 43         113 my $defaultByteOrder;
7460 43 50 33     337 if ($$dirInfo{DirName} and $$dirInfo{DirName} eq 'GPS') {
7461 0         0 $defaultByteOrder = $$self{SaveExifByteOrder};
7462             }
7463             # create TIFF information from scratch
7464 43 100       321 if ($self->SetPreferredByteOrder($defaultByteOrder) eq 'MM') {
7465 34         135 $$self{EXIF_DATA} = "MM\0\x2a\0\0\0\x08";
7466             } else {
7467 9         42 $$self{EXIF_DATA} = "II\x2a\0\x08\0\0\0";
7468             }
7469             }
7470 483         1674 $$self{EXIF_POS} = $base + $$self{BASE};
7471 483 100       2035 $$self{FIRST_EXIF_POS} = $$self{EXIF_POS} unless defined $$self{FIRST_EXIF_POS};
7472 483         1236 $dataPt = \$$self{EXIF_DATA};
7473              
7474             # set byte ordering
7475 483         1565 my $byteOrder = substr($$dataPt,0,2);
7476 483 100       1623 SetByteOrder($byteOrder) or return 0;
7477              
7478             # verify the byte ordering
7479 477         1995 my $identifier = Get16u($dataPt, 2);
7480             # identifier is 0x2a for TIFF (but 0x4f52, 0x5352 or ?? for ORF)
7481             # no longer do this because various files use different values
7482             # (TIFF=0x2a, RW2/RWL=0x55, HDP=0xbc, BTF=0x2b, ORF=0x4f52/0x5352/0x????)
7483             # return 0 unless $identifier == 0x2a;
7484 477 50 66     2690 $self->Warn('Invalid magic number in EXIF TIFF header') if $fileType eq 'APP1' and $identifier != 0x2a;
7485              
7486             # get offset to IFD0
7487 477 50       1642 return 0 if length $$dataPt < 8;
7488 477         2271 my $offset = Get32u($dataPt, 4);
7489 477 50       1858 $offset >= 8 or return 0;
7490              
7491 477 100       1633 if ($raf) {
7492             # check for canon or EXIF signature
7493             # (Canon CR2 images should have an offset of 16, but it may be
7494             # greater if edited by PhotoMechanic)
7495 40 100 100     393 if ($identifier == 0x2a and $offset >= 16) {
    100 66        
    100          
7496 17 50       80 $raf->Read($sig, 8) == 8 or return 0;
7497 17         86 $$dataPt .= $sig;
7498 17 100       129 if ($sig =~ /^(CR\x02\0|\xba\xb0\xac\xbb|ExifMeta)/) {
7499 10 100       54 if ($sig eq 'ExifMeta') {
7500 1         15 $self->SetFileType($fileType = 'EXIF');
7501 1         3 $otherSig = $sig;
7502             } else {
7503 9 50       58 $fileType = $sig =~ /^CR/ ? 'CR2' : 'Canon 1D RAW';
7504 9         25 $canonSig = $sig;
7505             }
7506 10 50       45 $self->HDump($base+8, 8, "[$fileType header]") if $$self{HTML_DUMP};
7507             }
7508             } elsif ($identifier == 0x55 and $fileType =~ /^(RAW|RW2|RWL|TIFF)$/) {
7509             # panasonic RAW, RW2 or RWL file
7510 3         7 my $magic;
7511             # test for RW2/RWL magic number
7512 3 50 33     25 if ($offset >= 0x18 and $raf->Read($magic, 16) and
      33        
7513             $magic eq "\x88\xe7\x74\xd8\xf8\x25\x1d\x4d\x94\x7a\x6e\x77\x82\x2b\x5d\x6a")
7514             {
7515 3 50       14 $fileType = 'RW2' unless $fileType eq 'RWL';
7516 3 50       223 $self->HDump($base + 8, 16, '[RW2/RWL header]') if $$self{HTML_DUMP};
7517 3         11 $otherSig = $magic; # save signature for writing
7518             } else {
7519 0         0 $fileType = 'RAW';
7520             }
7521 3         11 $tagTablePtr = GetTagTable('Image::ExifTool::PanasonicRaw::Main');
7522             } elsif ($fileType eq 'TIFF') {
7523 13 50 33     145 if ($identifier == 0x2b) {
    50 33        
    50          
    50          
7524             # this looks like a BigTIFF image
7525 0         0 $raf->Seek(0);
7526 0         0 require Image::ExifTool::BigTIFF;
7527 0         0 my $result = Image::ExifTool::BigTIFF::ProcessBTF($self, $dirInfo);
7528 0 0       0 if ($result) {
7529 0 0       0 $self->FoundTag(PageCount => $$self{PageCount}) if $$self{MultiPage};
7530 0         0 return 1;
7531             }
7532             } elsif ($identifier == 0x4f52 or $identifier == 0x5352) {
7533             # Olympus ORF image (set FileType now because base type is 'ORF')
7534 0         0 $self->SetFileType($fileType = 'ORF');
7535             } elsif ($identifier == 0x4352) {
7536 0         0 $fileType = 'DCP';
7537             } elsif ($byteOrder eq 'II' and ($identifier & 0xff) == 0xbc) {
7538 0         0 $fileType = 'HDP'; # Windows HD Photo file
7539             # check version number
7540 0         0 my $ver = Get8u($dataPt, 3);
7541 0 0       0 if ($ver > 1) {
7542 0         0 $self->Error("Windows HD Photo version $ver files not yet supported");
7543 0         0 return 1;
7544             }
7545             }
7546             }
7547             # we have a valid TIFF (or whatever) file
7548 40 100 66     301 if ($fileType and not $$self{VALUE}{FileType}) {
7549 38         116 my $lookup = $fileTypeLookup{$fileType};
7550 38 50 33     192 $lookup = $fileTypeLookup{$lookup} unless ref $lookup or not $lookup;
7551             # use file extension to pre-determine type if extension is TIFF-based or type is RAW
7552 38 50       197 my $baseType = $lookup ? (ref $$lookup[0] ? $$lookup[0][0] : $$lookup[0]) : '';
    50          
7553 38 100 66     216 my $t = ($baseType eq 'TIFF' or $fileType =~ /RAW/) ? $fileType : undef;
7554 38         208 $self->SetFileType($t);
7555             }
7556             # don't process file if FastScan == 3
7557 40 50 66     388 return 1 if not $outfile and $$self{OPTIONS}{FastScan} and $$self{OPTIONS}{FastScan} == 3;
      33        
7558             }
7559             # (accommodate CR3 images which have a TIFF directory with ExifIFD at the top level)
7560 477 100 100     3580 my $ifdName = ($$dirInfo{DirName} and $$dirInfo{DirName} =~ /^(ExifIFD|GPS)$/) ? $1 : 'IFD0';
7561 477 100 100     3074 if (not $tagTablePtr or $$tagTablePtr{GROUPS}{0} eq 'EXIF') {
    100          
7562 401 100       1824 $self->FoundTag('ExifByteOrder', $byteOrder) unless $outfile;
7563             } elsif ($$tagTablePtr{GROUPS}{0} eq 'MakerNotes') { # (for writing CR3 maker notes)
7564 19         66 $ifdName = $$tagTablePtr{GROUPS}{0};
7565             } else {
7566 57         145 $ifdName = $$tagTablePtr{GROUPS}{1};
7567             }
7568 477 50       2421 if ($$self{HTML_DUMP}) {
7569 0 0       0 my $tip = sprintf("Byte order: %s endian\nIdentifier: 0x%.4x\n$ifdName offset: 0x%.4x",
7570             ($byteOrder eq 'II') ? 'Little' : 'Big', $identifier, $offset);
7571 0         0 $self->HDump($base, 8, 'TIFF header', $tip, 0);
7572             }
7573             # remember where we found the TIFF data (APP1, APP3, TIFF, NEF, etc...)
7574 477         1326 $$self{TIFF_TYPE} = $fileType;
7575              
7576             # get reference to the main EXIF table
7577 477 100       1666 $tagTablePtr or $tagTablePtr = GetTagTable('Image::ExifTool::Exif::Main');
7578              
7579             # build directory information hash
7580             my %dirInfo = (
7581             Base => $base,
7582             DataPt => $dataPt,
7583             DataLen => length $$dataPt,
7584             DataPos => 0,
7585             DirStart => $offset,
7586             DirLen => length($$dataPt) - $offset,
7587             RAF => $raf,
7588             DirName => $ifdName,
7589             Parent => $fileType,
7590             ImageData=> 'Main', # set flag to get information to copy main image data later
7591             Multi => $$dirInfo{Multi},
7592 477         5432 );
7593              
7594             # extract information from the image
7595 477 100       1775 unless ($outfile) {
7596             # process the directory
7597 353         5117 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7598             # process GeoTiff information if available
7599 353 100       1925 if ($$self{VALUE}{GeoTiffDirectory}) {
7600 7         1007 require Image::ExifTool::GeoTiff;
7601 7         80 Image::ExifTool::GeoTiff::ProcessGeoTiff($self);
7602             }
7603             # process information in recognized trailers
7604 353 100       1202 if ($raf) {
7605 27         136 my $trailInfo = IdentifyTrailer($raf);
7606 27 100       184 if ($trailInfo) {
7607 3         12 $$trailInfo{ScanForAFCP} = 1; # scan to find AFCP if necessary
7608 3         19 $self->ProcessTrailers($trailInfo);
7609             }
7610             # dump any other known trailer (eg. A100 RAW Data)
7611 27 0 33     159 if ($$self{HTML_DUMP} and $$self{KnownTrailer}) {
7612 0         0 my $known = $$self{KnownTrailer};
7613 0         0 $raf->Seek(0, 2);
7614 0         0 my $len = $raf->Tell() - $$known{Start};
7615 0 0       0 $len -= $$trailInfo{Offset} if $trailInfo; # account for other trailers
7616 0 0       0 $self->HDump($$known{Start}, $len, "[$$known{Name}]") if $len > 0;
7617             }
7618             }
7619             # update FileType if necessary now that we know more about the file
7620 353 50 66     1485 if ($$self{DNGVersion} and $$self{VALUE}{FileType} !~ /^(DNG|GPR)$/) {
7621             # override whatever FileType we set since we now know it is DNG
7622 0         0 $self->OverrideFileType($$self{TIFF_TYPE} = 'DNG');
7623             }
7624 353 100       1333 if ($$self{TIFF_TYPE} eq 'TIFF') {
7625 10 50       35 $self->FoundTag(PageCount => $$self{PageCount}) if $$self{MultiPage};
7626             }
7627 353         1985 return 1;
7628             }
7629             #
7630             # rewrite the image
7631             #
7632 124 100       525 if ($$dirInfo{NoTiffEnd}) {
7633 1         4 delete $$self{TIFF_END};
7634             } else {
7635             # initialize TIFF_END so it will be updated by WriteExif()
7636 123         399 $$self{TIFF_END} = 0;
7637             }
7638 124 100       395 if ($canonSig) {
7639             # write Canon CR2 specially because it has a header we want to preserve,
7640             # and possibly trailers added by the Canon utilities and/or PhotoMechanic
7641 3         10 $dirInfo{OutFile} = $outfile;
7642 3         26 require Image::ExifTool::CanonRaw;
7643 3 50       23 Image::ExifTool::CanonRaw::WriteCR2($self, \%dirInfo, $tagTablePtr) or $err = 1;
7644             } else {
7645             # write TIFF header (8 bytes [plus optional signature] followed by IFD)
7646 121 100       1014 if ($fileType eq 'EXIF') {
    100          
7647 3         9 $otherSig = 'ExifMeta'; # force this signature for all EXIF files
7648             } elsif (not defined $otherSig) {
7649 117         491 $otherSig = '';
7650             }
7651 121         405 my $offset = 8 + length($otherSig);
7652             # construct tiff header
7653 121         618 my $header = substr($$dataPt, 0, 4) . Set32u($offset) . $otherSig;
7654 121         421 $dirInfo{NewDataPos} = $offset;
7655 121         419 $dirInfo{HeaderPtr} = \$header;
7656             # preserve padding between image data blocks in ORF images
7657             # (otherwise dcraw has problems because it assumes fixed block spacing)
7658 121 100 66     827 $dirInfo{PreserveImagePadding} = 1 if $fileType eq 'ORF' or $identifier != 0x2a;
7659 121         1016 my $newData = $self->WriteDirectory(\%dirInfo, $tagTablePtr);
7660 121 50       855 if (not defined $newData) {
    100          
7661 0         0 $err = 1;
7662             } elsif (length($newData)) {
7663             # update header length in case more was added
7664 115         327 my $hdrLen = length $header;
7665 115 100       510 if ($hdrLen != 8) {
7666 5         29 Set32u($hdrLen, \$header, 4);
7667             # also update preview fixup if necessary
7668 5         23 my $pi = $$self{PREVIEW_INFO};
7669 5 0 33     41 $$pi{Fixup}{Start} += $hdrLen - 8 if $pi and $$pi{Fixup};
7670             }
7671 115 50 33     699 if ($$self{TIFF_TYPE} eq 'ARW' and not $err) {
7672             # write any required ARW trailer and patch other ARW quirks
7673 0         0 require Image::ExifTool::Sony;
7674             my $errStr = Image::ExifTool::Sony::FinishARW($self, $dirInfo, \$newData,
7675 0         0 $dirInfo{ImageData});
7676 0 0       0 $errStr and $self->Error($errStr);
7677 0         0 delete $dirInfo{ImageData}; # (was copied by FinishARW)
7678             } else {
7679 115 50       617 Write($outfile, $header, $newData) or $err = 1;
7680             }
7681 115         399 undef $newData; # free memory
7682             }
7683             # copy over image data now if necessary
7684 121 100 66     820 if (ref $dirInfo{ImageData} and not $err) {
7685 10 50       76 $self->CopyImageData($dirInfo{ImageData}, $outfile) or $err = 1;
7686 10         51 delete $dirInfo{ImageData};
7687             }
7688             }
7689             # make local copy of TIFF_END now (it may be reset when processing trailers)
7690 124         374 my $tiffEnd = $$self{TIFF_END};
7691 124         342 delete $$self{TIFF_END};
7692              
7693             # rewrite trailers if they exist
7694 124 100 100     638 if ($raf and $tiffEnd and not $err) {
      66        
7695 12         34 my ($buf, $trailInfo);
7696 12 50       50 $raf->Seek(0, 2) or $err = 1;
7697 12         73 my $extra = $raf->Tell() - $tiffEnd;
7698             # check for trailer and process if possible
7699 12         29 for (;;) {
7700 12 100       60 last unless $extra > 12;
7701 3         14 $raf->Seek($tiffEnd); # seek back to end of image
7702 3         19 $trailInfo = IdentifyTrailer($raf);
7703 3 50       19 last unless $trailInfo;
7704 0         0 my $tbuf = '';
7705 0         0 $$trailInfo{OutFile} = \$tbuf; # rewrite trailer(s)
7706 0         0 $$trailInfo{ScanForAFCP} = 1; # scan for AFCP if necessary
7707             # rewrite all trailers to buffer
7708 0 0       0 unless ($self->ProcessTrailers($trailInfo)) {
7709 0         0 undef $trailInfo;
7710 0         0 $err = 1;
7711 0         0 last;
7712             }
7713             # calculate unused bytes before trailer
7714 0         0 $extra = $$trailInfo{DataPos} - $tiffEnd;
7715 0         0 last; # yes, the 'for' loop was just a cheap 'goto'
7716             }
7717             # ignore a single zero byte if used for padding
7718 12 100 100     88 if ($extra > 0 and $tiffEnd & 0x01) {
7719 1 50       6 $raf->Seek($tiffEnd, 0) or $err = 1;
7720 1 50       5 $raf->Read($buf, 1) or $err = 1;
7721 1 50 33     14 defined $buf and $buf eq "\0" and --$extra, ++$tiffEnd;
7722             }
7723 12 100       65 if ($extra > 0) {
7724 3         24 my $known = $$self{KnownTrailer};
7725 3 50 33     24 if ($$self{DEL_GROUP}{Trailer} and not $known) {
    50          
7726 0         0 $self->VPrint(0, " Deleting unknown trailer ($extra bytes)\n");
7727 0         0 ++$$self{CHANGED};
7728             } elsif ($known) {
7729 0         0 $self->VPrint(0, " Copying $$known{Name} ($extra bytes)\n");
7730 0 0       0 $raf->Seek($tiffEnd, 0) or $err = 1;
7731 0 0       0 CopyBlock($raf, $outfile, $extra) or $err = 1;
7732             } else {
7733 3 50       24 $raf->Seek($tiffEnd, 0) or $err = 1;
7734             # preserve unknown trailer only if it contains non-null data
7735             # (Photoshop CS adds a trailer with 2 null bytes)
7736 3         10 my $size = $extra;
7737 3         7 for (;;) {
7738 3 50       25 my $n = $size > 65536 ? 65536 : $size;
7739 3 50       14 $raf->Read($buf, $n) == $n or $err = 1, last;
7740 3 50       26 if ($buf =~ /[^\0]/) {
7741 3         26 $self->VPrint(0, " Preserving unknown trailer ($extra bytes)\n");
7742             # copy the trailer since it contains non-null data
7743 3 50 0     16 Write($outfile, "\0"x($extra-$size)) or $err = 1, last if $size != $extra;
7744 3 50       17 Write($outfile, $buf) or $err = 1, last;
7745 3 50 0     18 CopyBlock($raf, $outfile, $size-$n) or $err = 1 if $size > $n;
7746 3         9 last;
7747             }
7748 0         0 $size -= $n;
7749 0 0       0 next if $size > 0;
7750 0         0 $self->VPrint(0, " Deleting blank trailer ($extra bytes)\n");
7751 0         0 last;
7752             }
7753             }
7754             }
7755             # write trailer buffer if necessary
7756 12 50 0     55 $self->WriteTrailerBuffer($trailInfo, $outfile) or $err = 1 if $trailInfo;
7757             # add any new trailers we are creating
7758 12         75 my $trailPt = $self->AddNewTrailers();
7759 12 100 50     59 Write($outfile, $$trailPt) or $err = 1 if $trailPt;
7760             }
7761             # check DNG version
7762 124 100       535 if ($$self{DNGVersion}) {
7763 1         3 my $ver = $$self{DNGVersion};
7764             # currently support up to DNG version 1.6
7765 1 50 33     22 unless ($ver =~ /^(\d+) (\d+)/ and "$1.$2" <= 1.6) {
7766 0         0 $ver =~ tr/ /./;
7767 0         0 $self->Error("DNG Version $ver not yet tested", 1);
7768             }
7769             }
7770 124 50       1109 return $err ? -1 : 1;
7771             }
7772              
7773             #------------------------------------------------------------------------------
7774             # Return list of tag table keys (ignoring special keys)
7775             # Inputs: 0) reference to tag table
7776             # Returns: List of table keys (unsorted)
7777             sub TagTableKeys($)
7778             {
7779 7602     7602 0 12725 local $_;
7780 7602         12157 my $tagTablePtr = shift;
7781 7602         11394 my @keyList;
7782 7602         117129 foreach (keys %$tagTablePtr) {
7783 450762 100       844073 push(@keyList, $_) unless $specialTags{$_};
7784             }
7785 7602         75421 return @keyList;
7786             }
7787              
7788             #------------------------------------------------------------------------------
7789             # GetTagTable
7790             # Inputs: 0) table name
7791             # Returns: tag table reference, or undefined if not found
7792             # Notes: Always use this function instead of requiring module and using table
7793             # directly since this function also does the following the first time the table
7794             # is loaded:
7795             # - requires new module if necessary
7796             # - generates default GROUPS hash and Group 0 name from module name
7797             # - registers Composite tags if Composite table found
7798             # - saves descriptions for tags in specified table
7799             # - generates default TAG_PREFIX to be used for unknown tags
7800             sub GetTagTable($)
7801             {
7802 89510 100   89510 0 197629 my $tableName = shift or return undef;
7803 89506         205673 my $table = $allTables{$tableName};
7804              
7805 89506 100       164892 unless ($table) {
7806 105     105   1279 no strict 'refs';
  105         327  
  105         22189  
7807 4512 100       32870 unless (%$tableName) {
7808             # try to load module for this table
7809 872 50       6943 if ($tableName =~ /(.*)::/) {
7810 872         3255 my $module = $1;
7811 872 50       71424 if (eval "require $module") {
7812             # load additional modules if required
7813 872 100       7444 if (not %$tableName) {
7814 28 50       182 if ($module eq 'Image::ExifTool::XMP') {
    0          
7815 28         24301 require 'Image/ExifTool/XMP2.pl';
7816             } elsif ($tableName eq 'Image::ExifTool::QuickTime::Stream') {
7817 0         0 require 'Image/ExifTool/QuickTimeStream.pl';
7818             }
7819             }
7820             } else {
7821 0 0       0 $@ and warn $@;
7822             }
7823             }
7824 872 50       5695 unless (%$tableName) {
7825 0         0 warn "Can't find table $tableName\n";
7826 0         0 return undef;
7827             }
7828             }
7829 105     105   924 no strict 'refs';
  105         291  
  105         5466  
7830 4512         11892 $table = \%$tableName;
7831 105     105   748 use strict 'refs';
  105         303  
  105         94270  
7832 4512 100       14276 &{$$table{INIT_TABLE}}($table) if $$table{INIT_TABLE};
  13         266  
7833 4512         11887 $$table{TABLE_NAME} = $tableName; # set table name
7834 4512         27478 ($$table{SHORT_NAME} = $tableName) =~ s/^Image::ExifTool:://;
7835             # set default group 0 and 1 from module name unless already specified
7836 4512         11810 my $defaultGroups = $$table{GROUPS};
7837 4512 100       10771 $defaultGroups or $defaultGroups = $$table{GROUPS} = { };
7838 4512 100 100     21130 unless ($$defaultGroups{0} and $$defaultGroups{1}) {
7839 3599 50       21420 if ($tableName =~ /Image::.*?::([^:]*)/) {
7840 3599 100       12564 $$defaultGroups{0} = $1 unless $$defaultGroups{0};
7841 3599 100       14147 $$defaultGroups{1} = $1 unless $$defaultGroups{1};
7842             } else {
7843 0 0       0 $$defaultGroups{0} = $tableName unless $$defaultGroups{0};
7844 0 0       0 $$defaultGroups{1} = $tableName unless $$defaultGroups{1};
7845             }
7846             }
7847 4512 100       12710 $$defaultGroups{2} = 'Other' unless $$defaultGroups{2};
7848 4512 100 100     19133 if ($$defaultGroups{0} eq 'XMP' or $$table{NAMESPACE}) {
7849             # initialize some XMP table defaults
7850 510         3547 require Image::ExifTool::XMP;
7851 510         2625 Image::ExifTool::XMP::RegisterNamespace($table); # register all table namespaces
7852             # set default write/check procs
7853 510 100       1786 $$table{WRITE_PROC} = \&Image::ExifTool::XMP::WriteXMP unless $$table{WRITE_PROC};
7854 510 100       1724 $$table{CHECK_PROC} = \&Image::ExifTool::XMP::CheckXMP unless $$table{CHECK_PROC};
7855 510 100       1554 $$table{LANG_INFO} = \&Image::ExifTool::XMP::GetLangInfo unless $$table{LANG_INFO};
7856             }
7857             # generate a tag prefix for unknown tags if necessary
7858 4512 100       11028 unless (defined $$table{TAG_PREFIX}) {
7859 4412         6977 my $tagPrefix;
7860 4412 50 66     28053 if ($tableName =~ /Image::.*?::(.*)::Main/ || $tableName =~ /Image::.*?::(.*)/) {
7861 4412         20564 ($tagPrefix = $1) =~ s/::/_/g;
7862             } else {
7863 0         0 $tagPrefix = $tableName;
7864             }
7865 4412         13518 $$table{TAG_PREFIX} = $tagPrefix;
7866             }
7867             # set up the new table
7868 4512         14044 SetupTagTable($table);
7869             # add any user-defined tags (except Composite tags, which are handled specially)
7870 4512 100 100     21690 if (%UserDefined and $UserDefined{$tableName} and $table ne \%Image::ExifTool::Composite) {
      66        
7871 2         5 my $tagID;
7872 2         7 foreach $tagID (TagTableKeys($UserDefined{$tableName})) {
7873 3 50       12 next if $specialTags{$tagID};
7874 3         5 delete $$table{$tagID}; # replace any existing entry
7875 3         14 AddTagToTable($table, $tagID, $UserDefined{$tableName}{$tagID}, 1);
7876             }
7877             }
7878             # remember order we loaded the tables in
7879 4512         10910 push @tableOrder, $tableName;
7880             # insert newly loaded table into list
7881 4512         16030 $allTables{$tableName} = $table;
7882             }
7883             # must check each time to add UserDefined Composite tags because the Composite table
7884             # may be loaded before the UserDefined tags are available
7885 89506 50 66     255250 if ($table eq \%Image::ExifTool::Composite and not $$table{VARS}{LOADED_USERDEFINED} and
      100        
      66        
7886             %UserDefined and $UserDefined{$tableName})
7887             {
7888 0         0 my $userComp = $UserDefined{$tableName};
7889 0         0 delete $UserDefined{$tableName}; # (must delete first to avoid infinite recursion)
7890 0         0 AddCompositeTags($userComp, 1);
7891 0         0 $UserDefined{$tableName} = $userComp; # (add back again for adding writable tags later)
7892 0         0 $$table{VARS}{LOADED_USERDEFINED} = 1; # set flag to avoid doing this again
7893             }
7894 89506         208649 return $table;
7895             }
7896              
7897             #------------------------------------------------------------------------------
7898             # Process an image directory
7899             # Inputs: 0) ExifTool object reference, 1) directory information reference
7900             # 2) tag table reference, 3) optional reference to processing procedure
7901             # Returns: Result from processing (1=success)
7902             sub ProcessDirectory($$$;$)
7903             {
7904 4885     4885 0 13565 my ($self, $dirInfo, $tagTablePtr, $proc) = @_;
7905              
7906 4885 50 33     19078 return 0 unless $tagTablePtr and $dirInfo;
7907             # use default proc from tag table or EXIF proc as fallback if no proc specified
7908 4885 100 100     19573 $proc or $proc = $$tagTablePtr{PROCESS_PROC} || \&Image::ExifTool::Exif::ProcessExif;
7909             # set directory name from default group0 name if not done already
7910 4885         9062 my $dirName = $$dirInfo{DirName};
7911 4885 100       11444 unless ($dirName) {
7912 701         2640 $dirName = $$tagTablePtr{GROUPS}{0};
7913 701 100       2766 $dirName = $$tagTablePtr{GROUPS}{1} if $dirName =~ /^APP\d+$/; # (use specific APP name)
7914 701         1738 $$dirInfo{DirName} = $dirName;
7915             }
7916              
7917             # guard against cyclical recursion into the same directory
7918 4885 100 100     25622 if (defined $$dirInfo{DirStart} and defined $$dirInfo{DataPos} and
      100        
      100        
7919             # directories don't overlap if the length is zero
7920             ($$dirInfo{DirLen} or not defined $$dirInfo{DirLen}))
7921             {
7922 4083   100     14568 my $addr = $$dirInfo{DirStart} + $$dirInfo{DataPos} + ($$dirInfo{Base}||0) + $$self{BASE};
7923 4083 50       11416 if ($$self{PROCESSED}{$addr}) {
7924 0         0 $self->Warn("$dirName pointer references previous $$self{PROCESSED}{$addr} directory");
7925             # patch for bug in Windows phone 7.5 O/S that writes incorrect InteropIFD pointer
7926 0 0 0     0 return 0 unless $dirName eq 'GPS' and $$self{PROCESSED}{$addr} eq 'InteropIFD';
7927             }
7928 4083         12739 $$self{PROCESSED}{$addr} = $dirName;
7929             }
7930 4885         10755 my $oldOrder = GetByteOrder();
7931 4885         18390 my @save = @$self{'INDENT','DIR_NAME','Compression','SubfileType'};
7932 4885         13135 $$self{LIST_TAGS} = { }; # don't build lists across different directories
7933 4885         10854 $$self{INDENT} .= '| ';
7934 4885         8466 $$self{DIR_NAME} = $dirName;
7935 4885         7372 push @{$$self{PATH}}, $dirName;
  4885         11939  
7936 4885         14143 $$self{FOUND_DIR}{$dirName} = 1;
7937              
7938             # process the directory
7939 105     105   928 no strict 'refs';
  105         319  
  105         5455  
7940 4885         23309 my $rtnVal = &$proc($self, $dirInfo, $tagTablePtr);
7941 105     105   711 use strict 'refs';
  105         320  
  105         842754  
7942              
7943 4885         8146 pop @{$$self{PATH}};
  4885         11271  
7944 4885         17623 @$self{'INDENT','DIR_NAME','Compression','SubfileType'} = @save;
7945 4885         13657 SetByteOrder($oldOrder);
7946 4885         19087 return $rtnVal;
7947             }
7948              
7949             #------------------------------------------------------------------------------
7950             # Get Metadata path
7951             # Inputs: 0) ExifTool object ref
7952             # Return: Metadata path string
7953             sub MetadataPath($)
7954             {
7955 724     724 0 1503 my $self = shift;
7956 724         1304 return join '-', @{$$self{PATH}}
  724         3730  
7957             }
7958              
7959             #------------------------------------------------------------------------------
7960             # Get standardized file extension
7961             # Inputs: 0) file name
7962             # Returns: standardized extension (all uppercase), or undefined if no extension
7963             sub GetFileExtension($)
7964             {
7965 1927     1927 0 3682 my $filename = shift;
7966 1927         3152 my $fileExt;
7967 1927 100 100     12557 if ($filename and $filename =~ /^.*\.([^.]+)$/s) {
7968 1796         5379 $fileExt = uc($1); # change extension to upper case
7969             # convert TIF extension to TIFF because we use the
7970             # extension for the file type tag of TIFF images
7971 1796 100       4589 $fileExt eq 'TIF' and $fileExt = 'TIFF';
7972             }
7973 1927         6768 return $fileExt;
7974             }
7975              
7976             #------------------------------------------------------------------------------
7977             # Get list of tag information hashes for given tag ID
7978             # Inputs: 0) Tag table reference, 1) tag ID
7979             # Returns: Array of tag information references
7980             # Notes: Generates tagInfo hash if necessary
7981             sub GetTagInfoList($$)
7982             {
7983 531764     531764 0 854898 my ($tagTablePtr, $tagID) = @_;
7984 531764         981820 my $tagInfo = $$tagTablePtr{$tagID};
7985              
7986 531764 50       1145127 if ($specialTags{$tagID}) {
    100          
    100          
    100          
7987             # (hopefully this won't happen)
7988 0         0 warn "Tag $tagID conflicts with internal ExifTool variable in $$tagTablePtr{TABLE_NAME}\n";
7989             } elsif (ref $tagInfo eq 'HASH') {
7990 487561         999347 return ($tagInfo);
7991             } elsif (ref $tagInfo eq 'ARRAY') {
7992 10984         44843 return @$tagInfo;
7993             } elsif ($tagInfo) {
7994             # create hash with name
7995 28780         64952 $tagInfo = $$tagTablePtr{$tagID} = { Name => $tagInfo };
7996 28780         57316 return ($tagInfo);
7997             }
7998 4439         8303 return ();
7999             }
8000              
8001             #------------------------------------------------------------------------------
8002             # Find tag information, processing conditional tags
8003             # Inputs: 0) ExifTool object reference, 1) tagTable pointer, 2) tag ID
8004             # 3) optional value reference, 4) optional format type, 5) optional value count
8005             # Returns: pointer to tagInfo hash, undefined if none found, or '' if $valPt needed
8006             # Notes: You should always call this routine to find a tag in a table because
8007             # this routine will evaluate conditional tags.
8008             # Arguments 3-5 are only required if the information type allows $valPt, $format and/or
8009             # $count in a Condition, and if not given when needed this routine returns ''.
8010             sub GetTagInfo($$$;$$$)
8011             {
8012 106490     106490 0 203482 my ($self, $tagTablePtr, $tagID) = @_;
8013 106490         153077 my ($valPt, $format, $count);
8014              
8015 106490         197064 my @infoArray = GetTagInfoList($tagTablePtr, $tagID);
8016             # evaluate condition
8017 106490         149016 my $tagInfo;
8018 106490         180208 foreach $tagInfo (@infoArray) {
8019 110846         229130 my $condition = $$tagInfo{Condition};
8020 110846 100       208809 if ($condition) {
8021 12637 100       29747 ($valPt, $format, $count) = splice(@_, 3) if @_ > 3;
8022 12637 100 100     68785 return '' if $condition =~ /\$(valPt|format|count)\b/ and not defined $valPt;
8023             # set old value for use in condition if needed
8024 11975         50608 local $SIG{'__WARN__'} = \&SetWarning;
8025 11975         22149 undef $evalWarning;
8026             #### eval Condition ($self, [$valPt, $format, $count])
8027 11975 100       879887 unless (eval $condition) {
8028 9552 50       25723 $@ and $evalWarning = $@;
8029 9552 50       18308 $self->Warn("Condition $$tagInfo{Name}: " . CleanWarning()) if $evalWarning;
8030 9552         43089 next;
8031             }
8032             }
8033             # don't return Unknown tags unless that option is set (also see forum13716)
8034 100632 100 100     253951 if ($$tagInfo{Unknown} and not $$self{OPTIONS}{Unknown} and not
      66        
      100        
8035             ($$self{OPTIONS}{Verbose} or $$self{HTML_DUMP} or
8036             ($$self{OPTIONS}{Validate} and not $$tagInfo{AddedUnknown})))
8037             {
8038 2061         5359 return undef;
8039             }
8040             # return the tag information we found
8041 98571         233028 return $tagInfo;
8042             }
8043             # generate information for unknown tags (numerical only) if required
8044 5196 100 100     34850 if (not $tagInfo and ($$self{OPTIONS}{Unknown} or $$self{OPTIONS}{Verbose}) and
      66        
      100        
      100        
8045             $tagID =~ /^\d+$/ and not $$self{NO_UNKNOWN})
8046             {
8047 599         1164 my $printConv;
8048 599 100       1308 if (defined $$tagTablePtr{PRINT_CONV}) {
8049 155         271 $printConv = $$tagTablePtr{PRINT_CONV};
8050             } else {
8051             # limit length of printout (can be very long)
8052 444         720 $printConv = 'length($val) > 60 ? substr($val,0,55) . "[...]" : $val';
8053             }
8054 599         2156 my $hex = sprintf("0x%.4x", $tagID);
8055 599         1159 my $prefix = $$tagTablePtr{TAG_PREFIX};
8056 599         1873 $tagInfo = {
8057             Name => "${prefix}_$hex",
8058             Description => MakeDescription($prefix, $hex),
8059             Unknown => 1,
8060             Writable => 0, # can't write unknown tags
8061             PrintConv => $printConv,
8062             AddedUnknown => 1,
8063             };
8064             # add tag information to table
8065 599         1664 AddTagToTable($tagTablePtr, $tagID, $tagInfo);
8066             } else {
8067 4597         7218 undef $tagInfo;
8068             }
8069 5196         12583 return $tagInfo;
8070             }
8071              
8072             #------------------------------------------------------------------------------
8073             # Add new tag to table (must use this routine to add new tags to a table)
8074             # Inputs: 0) reference to tag table, 1) tag ID
8075             # 2) [optional] tag name or reference to tag information hash
8076             # 3) [optional] flag to avoid adding prefix when generating tag name
8077             # Returns: tagInfo ref
8078             # Notes: - will not override existing entry in table
8079             # - info need contain no entries when this routine is called
8080             # - tag name is cleaned if necessary
8081             sub AddTagToTable($$;$$)
8082             {
8083 6104     6104 0 12762 my ($tagTablePtr, $tagID, $tagInfo, $noPrefix) = @_;
8084              
8085             # generate tag info hash if necessary
8086 6104 0       13597 $tagInfo = $tagInfo ? { Name => $tagInfo } : { } unless ref $tagInfo eq 'HASH';
    50          
8087              
8088             # define necessary entries in information hash
8089 6104 100       11911 if ($$tagInfo{Groups}) {
8090             # fill in default groups from table GROUPS
8091 432         781 foreach (keys %{$$tagTablePtr{GROUPS}}) {
  432         1484  
8092 1296 100       2887 next if $$tagInfo{Groups}{$_};
8093 558         1250 $$tagInfo{Groups}{$_} = $$tagTablePtr{GROUPS}{$_};
8094             }
8095             } else {
8096 5672         7949 $$tagInfo{Groups} = { %{$$tagTablePtr{GROUPS}} };
  5672         27633  
8097             }
8098 6104 100       14695 $$tagInfo{Flags} and ExpandFlags($tagInfo);
8099             $$tagInfo{GotGroups} = 1,
8100 6104         13593 $$tagInfo{Table} = $tagTablePtr;
8101 6104         13417 $$tagInfo{TagID} = $tagID;
8102 6104 100 100     16057 if (defined $$tagTablePtr{AVOID} and not defined $$tagInfo{Avoid}) {
8103 1442         2715 $$tagInfo{Avoid} = $$tagTablePtr{AVOID};
8104             }
8105              
8106 6104         10067 my $name = $$tagInfo{Name};
8107 6104 100       12509 $name = $tagID unless defined $name;
8108 6104         12527 $name =~ tr/-_a-zA-Z0-9//dc; # remove illegal characters
8109 6104         11720 $name = ucfirst $name; # capitalize first letter
8110             # add tag-name prefix if specified and tag name not provided
8111 6104 100 100     13622 unless (defined $$tagInfo{Name} or $noPrefix or not $$tagTablePtr{TAG_PREFIX}) {
      66        
8112             # make description to prevent tagID from getting mangled by MakeDescription()
8113 22         73 $$tagInfo{Description} = MakeDescription($$tagTablePtr{TAG_PREFIX}, $name);
8114 22         60 $name = "$$tagTablePtr{TAG_PREFIX}_$name";
8115             }
8116             # tag names must be at least 2 characters long and prefer them to start with a letter
8117 6104 100 100     28970 $name = "Tag$name" if length($name) < 2 or $name !~ /^[A-Z]/i;
8118 6104         11411 $$tagInfo{Name} = $name;
8119             # add tag to table, but never override existing entries (could potentially happen
8120             # if someone thinks there isn't any tagInfo because a condition wasn't satisfied)
8121 6104 50 66     21432 unless (defined $$tagTablePtr{$tagID} or $specialTags{$tagID}) {
8122 6021         17489 $$tagTablePtr{$tagID} = $tagInfo;
8123             }
8124 6104 100       11991 $$tagInfo{AddedUnknown} = 1 if $$tagInfo{Unknown};
8125 6104         13531 return $tagInfo;
8126             }
8127              
8128             #------------------------------------------------------------------------------
8129             # Handle simple extraction of new tag information
8130             # Inputs: 0) ExifTool object ref, 1) tag table reference, 2) tagID, 3) value,
8131             # 4-N) parameters hash: Index, DataPt, DataPos, Base, Start, Size, Parent,
8132             # TagInfo, ProcessProc, RAF, Format, Count
8133             # Returns: tag key or undef if tag not found
8134             # Notes: if value is not defined, it is extracted from DataPt using TagInfo
8135             # Format and Count if provided
8136             sub HandleTag($$$$;%)
8137             {
8138 9366     9366 0 36234 my ($self, $tagTablePtr, $tag, $val, %parms) = @_;
8139 9366         17551 my $verbose = $$self{OPTIONS}{Verbose};
8140 9366         14048 my $pfmt = $parms{Format};
8141 9366   100     35408 my $tagInfo = $parms{TagInfo} || $self->GetTagInfo($tagTablePtr, $tag, \$val, $pfmt, $parms{Count});
8142 9366         19269 my $dataPt = $parms{DataPt};
8143 9366         14404 my ($subdir, $format, $noTagInfo, $rational);
8144              
8145 9366 100       16899 if ($tagInfo) {
8146 7259         12739 $subdir = $$tagInfo{SubDirectory};
8147             } else {
8148 2107 50       7466 return undef unless $verbose;
8149 0         0 $tagInfo = { Name => "tag $tag" }; # create temporary tagInfo hash
8150 0         0 $noTagInfo = 1;
8151             }
8152             # read value if not done already (not necessary for subdir)
8153 7259 50 66     19784 unless (defined $val or ($subdir and not $$tagInfo{Writable} and not $$tagInfo{RawConv})) {
      66        
      100        
8154 874   100     2820 my $start = $parms{Start} || 0;
8155 874 50       2011 my $dLen = $dataPt ? length($$dataPt) : -1;
8156 874         1432 my $size = $parms{Size};
8157 874 100       1897 $size = $dLen unless defined $size;
8158             # read from data in memory if possible
8159 874 50 33     3087 if ($start >= 0 and $start + $size <= $dLen) {
8160 874   100     2964 $format = $$tagInfo{Format} || $$tagTablePtr{FORMAT};
8161 874 50 100     3402 $format = $pfmt if not $format and $pfmt and $formatSize{$pfmt};
      66        
8162 874 100       1607 if ($format) {
8163 422         1422 $val = ReadValue($dataPt, $start, $format, $$tagInfo{Count}, $size, \$rational);
8164             } else {
8165 452         1288 $val = substr($$dataPt, $start, $size);
8166             }
8167             } else {
8168 0         0 $self->Warn("Error extracting value for $$tagInfo{Name}");
8169 0         0 return undef;
8170             }
8171             }
8172             # do verbose print if necessary
8173 7259 100       15489 if ($verbose) {
8174 51 50       127 undef $tagInfo if $noTagInfo;
8175 51         101 $parms{Value} = $val;
8176 51 50       109 $parms{Value} .= " ($rational)" if defined $rational;
8177 51         82 $parms{Table} = $tagTablePtr;
8178 51 50       102 if ($format) {
8179 0   0     0 my $count = int(($parms{Size} || 0) / ($formatSize{$format} || 1));
      0        
8180 0         0 $parms{Format} = $format . "[$count]";
8181             }
8182 51         233 $self->VerboseInfo($tag, $tagInfo, %parms);
8183             }
8184 7259 50       14319 if ($tagInfo) {
8185 7259 100       13742 if ($subdir) {
8186 747         1429 my $subdirStart = $parms{Start};
8187 747         1354 my $subdirLen = $parms{Size};
8188 747 100 66     2206 if ($$tagInfo{RawConv} and not $$tagInfo{Writable}) {
8189 1         3 my $conv = $$tagInfo{RawConv};
8190 1         5 local $SIG{'__WARN__'} = \&SetWarning;
8191 1         3 undef $evalWarning;
8192 1 50       3 if (ref $conv eq 'CODE') {
8193 0         0 $val = &$conv($val, $self);
8194             } else {
8195 1         2 my ($priority, @grps);
8196             # NOTE: RawConv is evaluated in Writer.pl and twice in ExifTool.pm
8197             #### eval RawConv ($self, $val, $tag, $tagInfo, $priority, @grps)
8198 1         103 $val = eval $conv;
8199 1 50       7 $@ and $evalWarning = $@;
8200             }
8201 1 50       4 $self->Warn("RawConv $tag: " . CleanWarning()) if $evalWarning;
8202 1 50       3 return undef unless defined $val;
8203 1 50       6 $val = $$val if ref $val eq 'SCALAR';
8204 1         3 $dataPt = \$val;
8205 1         2 $subdirStart = 0;
8206 1         7 $subdirLen = length $val;
8207             }
8208 747 100       1971 if ($$subdir{Start}) {
8209 8         20 my $valuePtr = 0;
8210             #### eval Start ($valuePtr)
8211 8         436 my $off = eval $$subdir{Start};
8212 8         45 $subdirStart += $off;
8213 8         21 $subdirLen -= $off;
8214             }
8215 747 100       1845 $dataPt or $dataPt = \$val;
8216             # process subdirectory information
8217             my %dirInfo = (
8218             DirName => $$subdir{DirName} || $$tagInfo{Name},
8219             DataPt => $dataPt,
8220             DataLen => length $$dataPt,
8221             DataPos => $parms{DataPos},
8222             DirStart => $subdirStart,
8223             DirLen => $subdirLen,
8224             Parent => $parms{Parent},
8225             Base => $parms{Base},
8226             Multi => $$subdir{Multi},
8227             TagInfo => $tagInfo,
8228             RAF => $parms{RAF},
8229 747   66     7119 );
8230 747         1937 my $oldOrder = GetByteOrder();
8231 747 100       2115 if ($$subdir{ByteOrder}) {
8232 3 100       16 if ($$subdir{ByteOrder} eq 'Unknown') {
8233 1 50       4 if ($subdirStart + 2 <= $subdirLen) {
8234             # attempt to determine the byte ordering of an IFD-style subdirectory
8235 1         4 my $num = Get16u($dataPt, $subdirStart);
8236 1 50 33     13 ToggleByteOrder if $num & 0xff00 and ($num>>8) > ($num&0xff);
8237             }
8238             } else {
8239 2         7 SetByteOrder($$subdir{ByteOrder});
8240             }
8241             }
8242 747   33     2133 my $subTablePtr = GetTagTable($$subdir{TagTable}) || $tagTablePtr;
8243 747   100     4576 $self->ProcessDirectory(\%dirInfo, $subTablePtr, $$subdir{ProcessProc} || $parms{ProcessProc});
8244 747         2300 SetByteOrder($oldOrder);
8245             # return now unless directory is writable as a block
8246 747 50       5769 return undef unless $$tagInfo{Writable};
8247             }
8248 6512         14220 my $key = $self->FoundTag($tagInfo, $val);
8249             # save original components of rational numbers
8250 6512 100 66     17429 $$self{RATIONAL}{$key} = $rational if defined $rational and defined $key;
8251 6512         22184 return $key;
8252             }
8253 0         0 return undef;
8254             }
8255              
8256             #------------------------------------------------------------------------------
8257             # Add tag to hash of extracted information
8258             # Inputs: 0) ExifTool object reference
8259             # 1) reference to tagInfo hash or tag name
8260             # 2) data value (or reference to require hash if Composite)
8261             # 3) optional family 0 group, 4) optional family 1 group
8262             # Returns: tag key or undef if no value
8263             sub FoundTag($$$;@)
8264             {
8265 58147     58147 0 89915 local $_;
8266 58147         112318 my ($self, $tagInfo, $value, @grps) = @_;
8267 58147         85911 my ($tag, $noListDel, $tbl);
8268 58147         97058 my $options = $$self{OPTIONS};
8269              
8270 58147 100       123881 if (ref $tagInfo eq 'HASH') {
8271 50844 50       140570 $tag = $$tagInfo{Name} or warn("No tag name\n"), return undef;
8272 50844         88618 $tbl = $$tagInfo{Table};
8273             } else {
8274 7303         10834 $tag = $tagInfo;
8275             # look for tag in Extra
8276 7303         14761 $tbl = GetTagTable('Image::ExifTool::Extra');
8277 7303         17679 $tagInfo = $self->GetTagInfo($tbl, $tag);
8278             # make temporary hash if tag doesn't exist in Extra
8279             # (not advised to do this since the tag won't show in list)
8280 7303 100       15438 $tagInfo or $tagInfo = { Name => $tag, Groups => \%allGroupsExifTool };
8281 7303 100       15993 $$options{Verbose} and $self->VerboseInfo(undef, $tagInfo, Value => $value);
8282             }
8283             # get tag priority
8284 58147         89425 my $priority = $$tagInfo{Priority};
8285 58147 100       115516 unless (defined $priority) {
8286 53765         84686 $priority = $$tbl{PRIORITY};
8287 53765 100 100     181443 $priority = 0 if not defined $priority and $$tagInfo{Avoid};
8288             }
8289 58147 100       130715 $grps[0] or $grps[0] = $$self{SET_GROUP0};
8290 58147 100       118667 $grps[1] or $grps[1] = $$self{SET_GROUP1};
8291 58147         90093 my $valueHash = $$self{VALUE};
8292              
8293 58147 100       116987 if ($$tagInfo{RawConv}) {
8294             # initialize @val for use in Composite RawConv expressions
8295 9045         14123 my @val;
8296 9045 50 66     25214 if (ref $value eq 'HASH' and $$tagInfo{IsComposite}) {
8297 1729         4740 foreach (keys %$value) { $val[$_] = $$valueHash{$$value{$_}}; }
  5810         14441  
8298             }
8299 9045         17415 my $conv = $$tagInfo{RawConv};
8300 9045         43783 local $SIG{'__WARN__'} = \&SetWarning;
8301 9045         17440 undef $evalWarning;
8302 9045 100       18267 if (ref $conv eq 'CODE') {
8303 217         1088 $value = &$conv($value, $self);
8304 217 50       798 $$self{grps} and @grps = @{$$self{grps}}, delete $$self{grps};
  0         0  
8305             } else {
8306 8828         14732 my $val = $value; # do this so eval can use $val
8307             # NOTE: RawConv is also evaluated in Writer.pl
8308             #### eval RawConv ($self, $val, $tag, $tagInfo, $priority, @grps)
8309 8828         782889 $value = eval $conv;
8310 8828 50       38916 $@ and $evalWarning = $@;
8311             }
8312 9045 50       20022 $self->Warn("RawConv $tag: " . CleanWarning()) if $evalWarning;
8313 9045 100       40816 return undef unless defined $value;
8314             }
8315             # ignore specified tags (AFTER doing RawConv if necessary!)
8316 55633 50       113200 if ($$options{IgnoreTags}) {
8317 0 0       0 if ($$options{IgnoreTags}{all}) {
8318 0 0       0 return undef unless $$self{REQ_TAG_LOOKUP}{lc $tag};
8319             } else {
8320 0 0       0 return undef if $$options{IgnoreTags}{lc $tag};
8321             }
8322             }
8323             # handle duplicate tag names
8324 55633 100       144845 if (defined $$valueHash{$tag}) {
    100          
8325             # add to list if there is an active list for this tag
8326 6596 100       18860 if ($$self{LIST_TAGS}{$tagInfo}) {
8327 642         1582 $tag = $$self{LIST_TAGS}{$tagInfo}; # use key from previous list tag
8328 642 100       1449 if (defined $$self{NO_LIST}) {
8329             # accumulate list in TAG_EXTRA "NoList" element
8330 65 100       206 if (defined $$self{TAG_EXTRA}{$tag}{NoList}) {
8331 31         71 push @{$$self{TAG_EXTRA}{$tag}{NoList}}, $value;
  31         157  
8332             } else {
8333 34         155 $$self{TAG_EXTRA}{$tag}{NoList} = [ $$valueHash{$tag}, $value ];
8334             }
8335 65         149 $noListDel = 1; # set flag to delete this tag if re-listed
8336             } else {
8337 577 100       1724 if (ref $$valueHash{$tag} ne 'ARRAY') {
8338 298         1007 $$valueHash{$tag} = [ $$valueHash{$tag} ];
8339             }
8340 577         961 push @{$$valueHash{$tag}}, $value;
  577         1841  
8341 577         2304 return $tag; # return without creating a new entry
8342             }
8343             }
8344             # get next available tag key
8345 6019   100     25982 my $nextInd = $$self{DUPL_TAG}{$tag} = ($$self{DUPL_TAG}{$tag} || 0) + 1;
8346 6019         15944 my $nextTag = "$tag ($nextInd)";
8347             #
8348             # take tag with highest priority
8349             #
8350             # promote existing 0-priority tag so it takes precedence over a new 0-tag
8351             # (unless old tag was a sub-document and new tag isn't. Also, never override
8352             # a Warning tag because they may be added by ValueConv, which could be confusing)
8353 6019         11724 my $oldPriority = $$self{PRIORITY}{$tag};
8354 6019 100       12551 unless ($oldPriority) {
8355 5111 100 100     29799 if ($$self{DOC_NUM} or not $$self{TAG_EXTRA}{$tag} or $tag eq 'Warning' or
      66        
      100        
8356             not $$self{TAG_EXTRA}{$tag}{G3})
8357             {
8358 5076         8963 $oldPriority = 1;
8359             } else {
8360 35         61 $oldPriority = 0; # don't promote sub-document tag over main document
8361             }
8362             }
8363             # set priority for this tag
8364 6019 100 100     26428 if (defined $priority) {
    100 33        
8365             # increase 0-priority tags if this is the priority directory
8366             $priority = 1 if not $priority and $$self{DIR_NAME} and
8367 2014 100 100     11206 $$self{DIR_NAME} eq $$self{PRIORITY_DIR};
      100        
8368             } elsif ($$self{LOW_PRIORITY_DIR}{'*'} or
8369             ($$self{DIR_NAME} and $$self{LOW_PRIORITY_DIR}{$$self{DIR_NAME}}))
8370             {
8371 411         674 $priority = 0; # default is 0 for a LOW_PRIORITY_DIR
8372             } else {
8373 3594         5844 $priority = 1; # the normal default
8374             }
8375 6019 100 100     28144 if ($priority >= $oldPriority and (not $$self{DOC_NUM} or
      100        
      100        
8376             ($$self{TAG_EXTRA}{$tag} and $$self{TAG_EXTRA}{$tag}{G3} and
8377             $$self{DOC_NUM} eq $$self{TAG_EXTRA}{$tag}{G3})) and not $noListDel)
8378             {
8379             # move existing tag out of the way since this tag is higher priority
8380             # (NOTE: any new members added here must also be added to DeleteTag())
8381 2728         8807 $$self{PRIORITY}{$nextTag} = $$self{PRIORITY}{$tag};
8382 2728         7027 $$valueHash{$nextTag} = $$valueHash{$tag};
8383 2728         6416 $$self{FILE_ORDER}{$nextTag} = $$self{FILE_ORDER}{$tag};
8384 2728         7048 my $oldInfo = $$self{TAG_INFO}{$nextTag} = $$self{TAG_INFO}{$tag};
8385 2728         5860 foreach ('TAG_EXTRA','RATIONAL') {
8386 5456 100       13811 if ($$self{$_}{$tag}) {
8387 1880         4338 $$self{$_}{$nextTag} = $$self{$_}{$tag};
8388 1880         4691 delete $$self{$_}{$tag};
8389             }
8390             }
8391 2728         4637 delete $$self{BOTH}{$tag};
8392             # update tag key for list if necessary
8393 2728 100       6773 $$self{LIST_TAGS}{$oldInfo} = $nextTag if $$self{LIST_TAGS}{$oldInfo};
8394             # update this key if used in a Composite tag
8395 2728 100       7587 if ($$self{COMP_KEYS}{$tag}) {
8396 86         143 $$_[0]{$$_[1]} = $nextTag foreach @{$$self{COMP_KEYS}{$tag}};
  86         389  
8397 86         255 $$self{COMP_KEYS}{$nextTag} = $$self{COMP_KEYS}{$tag};
8398 86         213 delete $$self{COMP_KEYS}{$tag};
8399             }
8400             } else {
8401 3291         5668 $tag = $nextTag; # don't override the existing tag
8402             }
8403 6019         15080 $$self{PRIORITY}{$tag} = $priority;
8404 6019 100       13589 $$self{TAG_EXTRA}{$tag}{NoListDel} = 1 if $noListDel;
8405             } elsif ($priority) {
8406             # set tag priority (only if exists and is non-zero)
8407 209         898 $$self{PRIORITY}{$tag} = $priority;
8408             }
8409              
8410             # save the raw value, file order, tagInfo ref, group1 name,
8411             # and tag key for lists if necessary
8412 55056         149914 $$valueHash{$tag} = $value;
8413 55056         120119 $$self{FILE_ORDER}{$tag} = ++$$self{NUM_FOUND};
8414 55056         108516 $$self{TAG_INFO}{$tag} = $tagInfo;
8415             # set dynamic groups 0, 1 and 3 if necessary
8416 55056 100       105636 $$self{TAG_EXTRA}{$tag}{G0} = $grps[0] if $grps[0];
8417 55056 100       107487 $$self{TAG_EXTRA}{$tag}{G1} = $grps[1] if $grps[1];
8418 55056 100       109135 if ($$self{DOC_NUM}) {
8419 1749         4458 $$self{TAG_EXTRA}{$tag}{G3} = $$self{DOC_NUM};
8420 1749 50       7073 if ($$self{DOC_NUM} =~ /^(\d+)/) {
8421             # keep track of maximum 1st-level sub-document number
8422 1749 100       5821 $$self{DOC_COUNT} = $1 unless $$self{DOC_COUNT} >= $1;
8423             }
8424             }
8425             # save path if requested
8426 55056 100       110329 $$self{TAG_EXTRA}{$tag}{G5} = $self->MetadataPath() if $$options{SavePath};
8427              
8428             # remember this tagInfo if we will be accumulating values in a list
8429             # (but don't override earlier list if this may be deleted by NoListDel flag)
8430 55056 100 100     126305 if ($$tagInfo{List} and not $$self{NO_LIST} and not $noListDel) {
      100        
8431 1108         4076 $$self{LIST_TAGS}{$tagInfo} = $tag;
8432             }
8433              
8434             # validate tag if requested (but only for simple values -- could result
8435             # in infinite recursion if called for a Composite tag (HASH ref value)
8436             # because FoundTag is called in the middle of building Composite tags
8437 55056 100 100     117992 if ($$options{Validate} and not ref $value) {
8438 213         663 Image::ExifTool::Validate::ValidateRaw($self, $tag, $value);
8439             }
8440              
8441 55056         150411 return $tag;
8442             }
8443              
8444             #------------------------------------------------------------------------------
8445             # Make current directory the priority directory if not set already
8446             # Inputs: 0) ExifTool object reference
8447             sub SetPriorityDir($)
8448             {
8449 22     22 0 68 my $self = shift;
8450 22 50       530 $$self{PRIORITY_DIR} = $$self{DIR_NAME} unless $$self{PRIORITY_DIR};
8451             }
8452              
8453             #------------------------------------------------------------------------------
8454             # Set family 0 or 1 group name specific to this tag instance
8455             # Inputs: 0) ExifTool ref, 1) tag key, 2) group name, 3) family (default 1)
8456             sub SetGroup($$$;$)
8457             {
8458 13237     13237 0 29203 my ($self, $tagKey, $extra, $fam) = @_;
8459 13237 50       56939 $$self{TAG_EXTRA}{$tagKey}{defined $fam ? "G$fam" : 'G1'} = $extra;
8460             }
8461              
8462             #------------------------------------------------------------------------------
8463             # Delete specified tag
8464             # Inputs: 0) ExifTool object ref, 1) tag key
8465             sub DeleteTag($$)
8466             {
8467 224     224 0 451 my ($self, $tag) = @_;
8468 224         443 delete $$self{VALUE}{$tag};
8469 224         409 delete $$self{FILE_ORDER}{$tag};
8470 224         364 delete $$self{TAG_INFO}{$tag};
8471 224         452 delete $$self{TAG_EXTRA}{$tag};
8472 224         352 delete $$self{PRIORITY}{$tag};
8473 224         343 delete $$self{RATIONAL}{$tag};
8474 224         601 delete $$self{BOTH}{$tag};
8475             }
8476              
8477             #------------------------------------------------------------------------------
8478             # Escape all elements of a value
8479             # Inputs: 0) value, 1) escape proc
8480             sub DoEscape($$)
8481             {
8482 173     173 0 254 my ($val, $key);
8483 173 100       335 if (not ref $_[0]) {
    100          
    50          
8484 167         239 $_[0] = &{$_[1]}($_[0]);
  167         434  
8485             } elsif (ref $_[0] eq 'ARRAY') {
8486 4         8 foreach $val (@{$_[0]}) {
  4         17  
8487 10         28 DoEscape($val, $_[1]);
8488             }
8489             } elsif (ref $_[0] eq 'HASH') {
8490 0         0 foreach $key (keys %{$_[0]}) {
  0         0  
8491 0         0 DoEscape($_[0]{$key}, $_[1]);
8492             }
8493             }
8494             }
8495              
8496             #------------------------------------------------------------------------------
8497             # Set the FileType and MIMEType tags
8498             # Inputs: 0) ExifTool object reference
8499             # 1) Optional file type (uses FILE_TYPE if not specified)
8500             # 2) Optional MIME type (uses our lookup if not specified)
8501             # 3) Optional recommended extension (converted to lower case; uses FileType if undef)
8502             # Notes: Will NOT set file type twice (subsequent calls ignored)
8503             sub SetFileType($;$$$)
8504             {
8505 638     638 0 2416 my ($self, $fileType, $mimeType, $normExt) = @_;
8506 638 100 66     4604 unless ($$self{VALUE}{FileType} and not $$self{DOC_NUM}) {
8507 590         1566 my $baseType = $$self{FILE_TYPE};
8508 590         1458 my $ext = $$self{FILE_EXT};
8509 590 100       2051 $fileType or $fileType = $baseType;
8510             # handle sub-types which are identified by extension
8511 590 100 100     4475 if (defined $ext and $ext ne $fileType and not $$self{DOC_NUM}) {
      66        
8512 257         1111 my ($f,$e) = @fileTypeLookup{$fileType,$ext};
8513 257 100 100     2072 if (ref $f eq 'ARRAY' and ref $e eq 'ARRAY' and $$f[0] eq $$e[0]) {
      100        
8514             # make sure $fileType was a root type and not another sub-type
8515 10 100 66     77 $fileType = $ext if $$f[0] eq $fileType or not $fileTypeLookup{$$f[0]};
8516             }
8517             }
8518 590 100       2739 $mimeType or $mimeType = $mimeType{$fileType};
8519             # use base file type if necessary (except if 'TIFF', which is a special case)
8520 590 100 66     2534 $mimeType = $mimeType{$baseType} unless $mimeType or $baseType eq 'TIFF';
8521 590 100       1891 unless (defined $normExt) {
8522 580         1741 $normExt = $fileTypeExt{$fileType};
8523 580 100       2094 $normExt = $fileType unless defined $normExt;
8524             }
8525 590         1589 $$self{FileType} = $fileType;
8526 590         2528 $self->FoundTag('FileType', $fileType);
8527 590         3739 $self->FoundTag('FileTypeExtension', uc $normExt);
8528 590   100     3891 $self->FoundTag('MIMEType', $mimeType || 'application/unknown');
8529             }
8530             }
8531              
8532             #------------------------------------------------------------------------------
8533             # Override the FileType and MIMEType tags
8534             # Inputs: 0) ExifTool object ref, 1) file type, 2) MIME type, 3) normal extension (lower case)
8535             # Notes: does nothing if FileType was not previously defined (ie. when writing)
8536             sub OverrideFileType($$;$$)
8537             {
8538 18     18 0 81 my ($self, $fileType, $mimeType, $normExt) = @_;
8539 18 100 66     154 if (defined $$self{VALUE}{FileType} and $fileType ne $$self{VALUE}{FileType}) {
8540 12         48 $$self{FileType} = $fileType;
8541 12         37 $$self{VALUE}{FileType} = $fileType;
8542 12 100       49 unless (defined $normExt) {
8543 5         15 $normExt = $fileTypeExt{$fileType};
8544 5 50       23 $normExt = $fileType unless defined $normExt;
8545             }
8546 12         33 $$self{VALUE}{FileTypeExtension} = uc $normExt;
8547 12 50       56 $mimeType or $mimeType = $mimeType{$fileType};
8548 12 100       42 $$self{VALUE}{MIMEType} = $mimeType if $mimeType;
8549 12 50       141 if ($$self{OPTIONS}{Verbose}) {
8550 0         0 $self->VPrint(0,"$$self{INDENT}FileType [override] = $fileType\n");
8551 0         0 $self->VPrint(0,"$$self{INDENT}FileTypeExtension [override] = $$self{VALUE}{FileTypeExtension}\n");
8552 0 0       0 $self->VPrint(0,"$$self{INDENT}MIMEType [override] = $mimeType\n") if $mimeType;
8553             }
8554             }
8555             }
8556              
8557             #------------------------------------------------------------------------------
8558             # Modify the value of the MIMEType tag
8559             # Inputs: 0) ExifTool object reference, 1) file or MIME type
8560             # Notes: combines existing type with new type: ie) a/b + c/d => c/b-d
8561             sub ModifyMimeType($;$)
8562             {
8563 8     8 0 30 my ($self, $mime) = @_;
8564 8 50 33     58 $mime =~ m{/} or $mime = $mimeType{$mime} or return;
8565 8         31 my $old = $$self{VALUE}{MIMEType};
8566 8 50       26 if (defined $old) {
8567 8         46 my ($a, $b) = split '/', $old;
8568 8         39 my ($c, $d) = split '/', $mime;
8569 8         23 $d =~ s/^x-//;
8570 8         34 $$self{VALUE}{MIMEType} = "$c/$b-$d";
8571 8         44 $self->VPrint(0, " Modified MIMEType = $c/$b-$d\n");
8572             } else {
8573 0         0 $self->FoundTag('MIMEType', $mime);
8574             }
8575             }
8576              
8577             #------------------------------------------------------------------------------
8578             # Print verbose output
8579             # Inputs: 0) ExifTool ref, 1) verbose level (prints if level > this), 2-N) print args
8580             sub VPrint($$@)
8581             {
8582 9156     9156 0 16673 my $self = shift;
8583 9156         14070 my $level = shift;
8584 9156 100 66     34202 if ($$self{OPTIONS}{Verbose} and $$self{OPTIONS}{Verbose} > $level) {
8585 4         9 my $out = $$self{OPTIONS}{TextOut};
8586 4         20 print $out @_;
8587 4 50       28 print $out "\n" unless $_[-1] =~ /\n$/;
8588             }
8589             }
8590              
8591             #------------------------------------------------------------------------------
8592             # Print verbose directory information
8593             # Inputs: 0) ExifTool object reference, 1) directory name or dirInfo ref
8594             # 2) number of entries in directory (or 0 if unknown)
8595             # 3) optional size of directory in bytes
8596             sub VerboseDir($$;$$)
8597             {
8598 449     449 0 1215 my ($self, $name, $entries, $size) = @_;
8599 449 100       1765 return unless $$self{OPTIONS}{Verbose};
8600 44 50       120 if (ref $name eq 'HASH') {
8601 0 0       0 $size = $$name{DirLen} unless $size;
8602 0   0     0 $name = $$name{Name} || $$name{DirName};
8603             }
8604 44         104 my $indent = substr($$self{INDENT}, 0, -2);
8605 44         82 my $out = $$self{OPTIONS}{TextOut};
8606 44 100 66     196 my $str = ($entries or defined $entries and not $size) ? " with $entries entries" : '';
8607 44 100       119 $str .= ", $size bytes" if $size;
8608 44         174 print $out "$indent+ [$name directory$str]\n";
8609             }
8610              
8611             #------------------------------------------------------------------------------
8612             # Verbose dump
8613             # Inputs: 0) ExifTool ref, 1) data ref, 2-N) HexDump options
8614             sub VerboseDump($$;%)
8615             {
8616 128     128 0 240 my $self = shift;
8617 128         201 my $dataPt = shift;
8618 128         252 my $verbose = $$self{OPTIONS}{Verbose};
8619 128 50 33     420 if ($verbose and $verbose > 2) {
8620             my %parms = (
8621             Prefix => $$self{INDENT},
8622             Out => $$self{OPTIONS}{TextOut},
8623 0 0       0 MaxLen => $verbose < 4 ? 96 : $verbose < 5 ? 2048 : undef,
    0          
8624             );
8625 0         0 HexDump($dataPt, undef, %parms, @_);
8626             }
8627             }
8628              
8629             #------------------------------------------------------------------------------
8630             # Print data in hex
8631             # Inputs: 0) data
8632             # Returns: hex string
8633             # (this is a convenience function for use in debugging PrintConv statements)
8634             sub PrintHex($)
8635             {
8636 0     0 0 0 my $val = shift;
8637 0         0 return join(' ', unpack('H2' x length($val), $val));
8638             }
8639              
8640             #------------------------------------------------------------------------------
8641             # Extract binary data from file
8642             # 0) ExifTool object reference, 1) offset, 2) length, 3) tag name if conditional
8643             # Returns: binary data, or undef on error
8644             # Notes: Returns "Binary data #### bytes" instead of data unless tag is
8645             # specifically requested or the Binary option is set
8646             sub ExtractBinary($$$;$)
8647             {
8648 47     47 0 186 my ($self, $offset, $length, $tag) = @_;
8649 47         102 my ($isPreview, $buff);
8650              
8651 47 100       151 if ($tag) {
8652 43 100       176 if ($tag eq 'PreviewImage') {
8653             # save PreviewImage start/length in case we want to dump trailer
8654 29         114 $$self{PreviewImageStart} = $offset;
8655 29         104 $$self{PreviewImageLength} = $length;
8656 29         82 $isPreview = 1;
8657             }
8658 43         139 my $lcTag = lc $tag;
8659 43 50 66     475 if ((not $$self{OPTIONS}{Binary} or $$self{EXCL_TAG_LOOKUP}{$lcTag}) and
      66        
      66        
8660             not $$self{OPTIONS}{Verbose} and not $$self{REQ_TAG_LOOKUP}{$lcTag})
8661             {
8662 34         208 return "Binary data $length bytes";
8663             }
8664             }
8665 13 100 66     68 unless ($$self{RAF}->Seek($offset,0)
8666             and $$self{RAF}->Read($buff, $length) == $length)
8667             {
8668 5 50       27 $tag or $tag = 'binary data';
8669 5 50 33     47 if ($isPreview and not $$self{BuildingComposite}) {
8670 0         0 $$self{PreviewError} = 1;
8671             } else {
8672 5         46 $self->Warn("Error reading $tag from file", $isPreview);
8673             }
8674 5         65 return undef;
8675             }
8676 8         37 return $buff;
8677             }
8678              
8679             #------------------------------------------------------------------------------
8680             # Process binary data
8681             # Inputs: 0) ExifTool object ref, 1) directory information ref, 2) tag table ref
8682             # Returns: 1 on success
8683             # Notes: dirInfo may contain VarFormatData (reference to empty list) to return
8684             # details about any variable-length-format tags in the table (used when writing)
8685             sub ProcessBinaryData($$$)
8686             {
8687 2070     2070 0 4604 my ($self, $dirInfo, $tagTablePtr) = @_;
8688 2070         4262 my $dataPt = $$dirInfo{DataPt};
8689 2070   100     7154 my $offset = $$dirInfo{DirStart} || 0;
8690 2070   66     5423 my $size = $$dirInfo{DirLen} || (length($$dataPt) - $offset);
8691 2070   100     5873 my $base = $$dirInfo{Base} || 0;
8692 2070         4236 my $verbose = $$self{OPTIONS}{Verbose};
8693 2070         3753 my $unknown = $$self{OPTIONS}{Unknown};
8694 2070   100     6302 my $dataPos = $$dirInfo{DataPos} || 0;
8695              
8696             # get default format ('int8u' unless specified)
8697 2070   100     7175 my $defaultFormat = $$tagTablePtr{FORMAT} || 'int8u';
8698 2070         4330 my $increment = $formatSize{$defaultFormat};
8699 2070 50       4498 unless ($increment) {
8700 0         0 warn "Unknown format $defaultFormat\n";
8701 0         0 $defaultFormat = 'int8u';
8702 0         0 $increment = $formatSize{$defaultFormat};
8703             }
8704             # prepare list of tag numbers to extract
8705 2070         3750 my (@tags, $topIndex);
8706 2070 50 33     9580 if ($unknown > 1 and defined $$tagTablePtr{FIRST_ENTRY}) {
    100          
    100          
8707             # don't create a stupid number of tags if data is huge
8708 0 0       0 my $sizeLimit = $size < 65536 ? $size : 65536;
8709             # scan through entire binary table
8710 0         0 $topIndex = int($sizeLimit/$increment);
8711 0         0 @tags = ($$tagTablePtr{FIRST_ENTRY}..($topIndex - 1));
8712             # add in floating point tag ID's if they exist
8713 0         0 my @ftags = grep /\./, TagTableKeys($tagTablePtr);
8714 0 0       0 @tags = sort { $a <=> $b } @tags, @ftags if @ftags;
  0         0  
8715             } elsif ($$dirInfo{DataMember}) {
8716 192         345 @tags = @{$$dirInfo{DataMember}};
  192         630  
8717 192         395 $verbose = 0; # no verbose output of extracted values when writing
8718             } elsif ($$dirInfo{MixedTags}) {
8719             # process sorted integer-ID tags only
8720 38         129 @tags = sort { $a <=> $b } grep /^\d+$/, TagTableKeys($tagTablePtr);
  468         865  
8721             } else {
8722             # extract known tags in numerical order
8723 1840 50       4739 @tags = sort { ($a < 0 ? $a + 1e9 : $a) <=> ($b < 0 ? $b + 1e9 : $b) } TagTableKeys($tagTablePtr);
  54027 50       105054  
8724             }
8725 2070 100       6856 $self->VerboseDir('BinaryData', undef, $size) if $verbose;
8726             # avoid creating unknown tags for tags that fail condition if Unknown is 1
8727 2070 50       6570 $$self{NO_UNKNOWN} = 1 if $unknown < 2;
8728 2070         3471 my ($index, %val);
8729 2070         4111 my $nextIndex = 0;
8730 2070         3211 my $varSize = 0;
8731 2070         4638 foreach $index (@tags) {
8732 17209         29429 my ($tagInfo, $val, $saveNextIndex, $len, $mask, $wasVar, $rational);
8733 17209 50 0     38900 if ($$tagTablePtr{$index}) {
    0          
8734 17209         38581 $tagInfo = $self->GetTagInfo($tagTablePtr, $index);
8735 17209 100       37114 unless ($tagInfo) {
8736 718 100       1884 next unless defined $tagInfo;
8737 44         209 my $entry = int($index) * $increment + $varSize;
8738 44 50       178 if ($entry < 0) {
8739 0         0 $entry += $size;
8740 0 0       0 next if $entry < 0;
8741             }
8742 44 100       235 next if $entry >= $size;
8743 4         13 my $more = $size - $entry;
8744 4 50       18 $more = 128 if $more > 128;
8745 4         15 my $v = substr($$dataPt, $entry+$offset, $more);
8746 4         20 $tagInfo = $self->GetTagInfo($tagTablePtr, $index, \$v);
8747 4 50       19 next unless $tagInfo;
8748             }
8749             next if $$tagInfo{Unknown} and
8750 16495 100 66     34513 ($$tagInfo{Unknown} > $unknown or $index < $nextIndex);
      66        
8751             } elsif ($topIndex and $$tagTablePtr{$index - $topIndex}) {
8752 0 0       0 $tagInfo = $self->GetTagInfo($tagTablePtr, $index - $topIndex) or next;
8753             } else {
8754             # don't generate unknown tags in binary tables unless Unknown > 1
8755 0 0       0 next unless $unknown > 1;
8756 0 0       0 next if $index < $nextIndex; # skip if data already used
8757 0 0       0 $tagInfo = $self->GetTagInfo($tagTablePtr, $index) or next;
8758 0         0 $$tagInfo{Unknown} = 2; # set unknown to 2 for binary unknowns
8759             }
8760             # get relative offset of this entry
8761 16494         29892 my $entry = int($index) * $increment + $varSize;
8762             # allow negative indices to represent bytes from end
8763 16494 50       31659 if ($entry < 0) {
8764 0         0 $entry += $size;
8765 0 0       0 next if $entry < 0;
8766             }
8767 16494         24585 my $more = $size - $entry;
8768 16494 100       31239 last if $more <= 0; # all done if we have reached the end of data
8769 16235         22865 my $count = 1;
8770 16235         31378 my $format = $$tagInfo{Format};
8771 16235 100       42971 if (not $format) {
    100          
    50          
    100          
8772 9356         14994 $format = $defaultFormat;
8773             } elsif ($format eq 'string') {
8774             # string with no specified count runs to end of block
8775 104         263 $count = $more;
8776             } elsif ($format eq 'pstring') {
8777 0         0 $format = 'string';
8778 0         0 $count = Get8u($dataPt, ($entry++)+$offset);
8779 0         0 --$more;
8780             } elsif (not $formatSize{$format}) {
8781 3124 100       17582 if ($format =~ /(.*)\[(.*)\]/) {
    50          
8782             # handle format count field
8783 2939         7904 $format = $1;
8784 2939         5598 $count = $2;
8785             # evaluate count to allow count to be based on previous values
8786             #### eval Format size (%val, $size, $self)
8787 2939         132076 $count = eval $count;
8788 2939 50       11548 $@ and warn("Format $$tagInfo{Name}: $@"), next;
8789 2939 50       7053 next if $count < 0;
8790             # allow a variable-length value of any format
8791             # (note: the next incremental index points to data immediately after
8792             # this value, regardless of the size of this value, even if it is zero)
8793 2939 50       7676 if ($format =~ s/^var_//) {
8794 0   0     0 $varSize += $count * ($formatSize{$format} || 1) - $increment;
8795 0         0 $wasVar = 1;
8796             # save variable size data if required for writing
8797 0 0       0 if ($$dirInfo{VarFormatData}) {
8798 0         0 push @{$$dirInfo{VarFormatData}}, [ $index, $varSize, $format ];
  0         0  
8799             }
8800             # don't extract value if large and we wanted it just to get
8801             # the variable-format information when writing
8802 0 0 0     0 next if $$tagInfo{LargeTag} and $$dirInfo{VarFormatData};
8803             }
8804             } elsif ($format =~ /^var_/) {
8805             # handle variable-length string formats
8806 185         526 $format = substr($format, 4);
8807 185         719 pos($$dataPt) = $entry + $offset;
8808 185         447 undef $count;
8809 185 50 100     1162 if ($format eq 'ustring') {
    50          
    100          
    100          
    100          
    50          
8810 0 0       0 $count = pos($$dataPt) - ($entry+$offset) if $$dataPt =~ /\G(..)*?\0\0/sg;
8811 0         0 $varSize -= 2; # ($count includes base size of 2 bytes)
8812             } elsif ($format eq 'pstring') {
8813 0         0 $count = Get8u($dataPt, ($entry++)+$offset);
8814 0         0 --$more;
8815             } elsif ($format eq 'pstr32' or $format eq 'ustr32') {
8816 170 50       419 last if $more < 4;
8817 170         497 $count = Get32u($dataPt, $entry + $offset);
8818 170 100       572 $count *= 2 if $format eq 'ustr32';
8819 170         291 $entry += 4;
8820 170         281 $more -= 4;
8821 170         433 $nextIndex += 4 / $increment; # (increment next index for int32u)
8822             } elsif ($format eq 'int16u') {
8823             # int16u size of binary data to follow
8824 10 50       32 last if $more < 2;
8825 10         30 $count = Get16u($dataPt, $entry + $offset) + 2;
8826 10         21 $varSize -= 2; # ($count includes size word)
8827 10         21 $format = 'undef';
8828             } elsif ($format eq 'ue7') {
8829 3         15 require Image::ExifTool::BPG;
8830 3         13 ($val, $count) = Image::ExifTool::BPG::Get_ue7($dataPt, $entry + $offset);
8831 3 50       8 last unless defined $val;
8832 3         5 --$varSize; # ($count includes base size of 1 byte)
8833             } elsif ($$dataPt =~ /\0/g) {
8834 2         6 $count = pos($$dataPt) - ($entry+$offset);
8835 2         4 --$varSize; # ($count includes base size of 1 byte)
8836             }
8837 185 50 33     850 $count = $more if not defined $count or $count > $more;
8838 185         317 $varSize += $count; # shift subsequent indices
8839 185 100       462 unless (defined $val) {
8840 182         488 $val = substr($$dataPt, $entry+$offset, $count);
8841 182 100 66     1076 $val = $self->Decode($val, 'UCS2') if $format eq 'ustring' or $format eq 'ustr32';
8842 182 100       627 $val =~ s/\0.*//s unless $format eq 'undef'; # truncate at null
8843             }
8844 185         352 $wasVar = 1;
8845             # save variable size data if required for writing
8846 185 100       556 if ($$dirInfo{VarFormatData}) {
8847 5         9 push @{$$dirInfo{VarFormatData}}, [ $index, $varSize, $format ];
  5         20  
8848             }
8849             }
8850             }
8851             # hook to allow format, etc to be set dynamically
8852 16235 100       36640 if (defined $$tagInfo{Hook}) {
8853 540         838 my $oldVarSize = $varSize;
8854 540         873 my $pos = $entry + $offset;
8855             #### eval Hook ($format, $varSize, $size, $dataPt, $pos)
8856 540         34833 eval $$tagInfo{Hook};
8857             # save variable size data if required for writing (in case changed by Hook)
8858 540 100 66     2917 if ($$dirInfo{VarFormatData}) {
    50          
8859 247 50       617 $#{$$dirInfo{VarFormatData}} -= 1 if $wasVar; # remove previous entry for this tag
  0         0  
8860 247         336 push @{$$dirInfo{VarFormatData}}, [ $index, $varSize, $format ];
  247         940  
8861             } elsif ($varSize != $oldVarSize and $verbose > 2) {
8862 0         0 my ($tmp, $sign) = ($varSize, '+');
8863 0 0       0 $tmp < 0 and $tmp = -$tmp, $sign = '-';
8864 0         0 $self->VPrint(2, sprintf("$$self{INDENT}\[offsets adjusted by ${sign}0x%.4x after 0x%.4x $$tagInfo{Name}]\n", $tmp, $index));
8865             }
8866             }
8867 16235 50       32208 if ($unknown > 1) {
8868             # calculate next valid index for unknown tag
8869 0         0 my $ni = int $index;
8870 0 0 0     0 $ni += (($formatSize{$format} || 1) * $count) / $increment unless $wasVar;
8871 0         0 $saveNextIndex = $nextIndex;
8872 0 0       0 $nextIndex = $ni unless $nextIndex > $ni;
8873             }
8874             # allow large tags to be excluded from extraction
8875             # (provides a work-around for some tight memory situations)
8876 16235 50 33     34657 next if $$tagInfo{LargeTag} and $$self{EXCL_TAG_LOOKUP}{lc $$tagInfo{Name}};
8877             # read value now if necessary
8878 16235 100 66     36072 unless (defined $val and not $$tagInfo{SubDirectory}) {
8879 16050         39708 $val = ReadValue($dataPt, $entry+$offset, $format, $count, $more, \$rational);
8880 16050 50       32751 next unless defined $val;
8881 16050         28901 $mask = $$tagInfo{Mask};
8882 16050 100       30726 $val = ($val & $mask) >> $$tagInfo{BitShift} if $mask;
8883             }
8884 16235 100 66     33216 if ($verbose and not $$tagInfo{Hidden}) {
8885 198 50 33     502 if (not $$tagInfo{SubDirectory} or $$tagInfo{Format}) {
8886 198   50     455 $len = $count * ($formatSize{$format} || 1);
8887 198 50       408 $len = $more if $len > $more;
8888             } else {
8889 0         0 $len = $more;
8890             }
8891 198 50       937 $self->VerboseInfo($index, $tagInfo,
8892             Table => $tagTablePtr,
8893             Value => $val,
8894             DataPt => $dataPt,
8895             Size => $len,
8896             Start => $entry+$offset,
8897             Addr => $entry+$offset+$base+$dataPos,
8898             Format => $format,
8899             Count => $count,
8900             Extra => $mask ? sprintf(', mask 0x%.2x',$mask) : undef,
8901             );
8902             }
8903             # parse nested BinaryData directories
8904 16235 100       32494 if ($$tagInfo{SubDirectory}) {
8905 14         56 my $subdir = $$tagInfo{SubDirectory};
8906 14         75 my $subTablePtr = GetTagTable($$subdir{TagTable});
8907             # use specified subdirectory length if given
8908 14 100 66     136 if ($$tagInfo{Format} and $formatSize{$format}) {
8909 12         41 $len = $count * $formatSize{$format};
8910 12 50       47 $len = $more if $len > $more;
8911             } else {
8912 2         4 $len = $more; # directory size is all of remaining data
8913 2 50 33     18 if ($$subTablePtr{PROCESS_PROC} and
8914             $$subTablePtr{PROCESS_PROC} eq \&ProcessBinaryData)
8915             {
8916             # the rest of the data will be printed in the subdirectory
8917 2         9 $nextIndex = $size / $increment;
8918             }
8919             }
8920 14         36 my $subdirBase = $base;
8921 14 50       53 if (defined $$subdir{Base}) {
8922             #### eval Base ($start,$base)
8923 0         0 my $start = $entry + $offset + $dataPos;
8924 0         0 $subdirBase = eval($$subdir{Base}) + $base;
8925             }
8926 14   50     74 my $start = $$subdir{Start} || 0;
8927 14         105 my %subdirInfo = (
8928             DataPt => $dataPt,
8929             DataPos => $dataPos,
8930             DataLen => length $$dataPt,
8931             DirStart => $entry + $offset + $start,
8932             DirLen => $len - $start,
8933             Base => $subdirBase,
8934             );
8935 14         45 delete $$self{NO_UNKNOWN};
8936 14         139 $self->ProcessDirectory(\%subdirInfo, $subTablePtr, $$subdir{ProcessProc});
8937 14 50       91 $$self{NO_UNKNOWN} = 1 if $unknown < 2;
8938 14         58 next;
8939             }
8940 16221 100 66     37120 if ($$tagInfo{IsOffset} and $$tagInfo{IsOffset} ne '3') {
8941 38         95 my $et = $self;
8942             #### eval IsOffset ($val, $et)
8943 38 100       2317 $val += $base + $$self{BASE} if eval $$tagInfo{IsOffset};
8944             }
8945 16221         36497 $val{$index} = $val;
8946 16221         22148 my $oldBase;
8947 16221 50       30981 if ($$tagInfo{SetBase}) {
8948 0         0 $oldBase = $$self{BASE};
8949 0         0 $$self{BASE} += $base;
8950             }
8951 16221         38945 my $key = $self->FoundTag($tagInfo,$val);
8952 16221 50       35324 $$self{BASE} = $oldBase if defined $oldBase;
8953 16221 100       27874 if ($key) {
8954 14878 100       38502 $$self{RATIONAL}{$key} = $rational if defined $rational;
8955             } else {
8956             # don't increment nextIndex if we didn't extract a tag
8957 1343 50       4286 $nextIndex = $saveNextIndex if defined $saveNextIndex;
8958             }
8959             }
8960 2070         4826 delete $$self{NO_UNKNOWN};
8961 2070         10135 return 1;
8962             }
8963              
8964             #..............................................................................
8965             # Load .ExifTool_config file from user's home directory
8966             # (use of noConfig is now deprecated, use configFile = '' instead)
8967             until ($Image::ExifTool::noConfig) {
8968             my $config = $Image::ExifTool::configFile;
8969             my $file;
8970             if (not defined $config) {
8971             $config = '.ExifTool_config';
8972             # get our home directory (HOMEDRIVE and HOMEPATH are used in Windows cmd shell)
8973             my $home = $ENV{EXIFTOOL_HOME} || $ENV{HOME} ||
8974             ($ENV{HOMEDRIVE} || '') . ($ENV{HOMEPATH} || '') || '.';
8975             # look for the config file in 1) the home directory, 2) the program dir
8976             $file = "$home/$config";
8977             } else {
8978             length $config or last; # filename of "" disables configuration
8979             $file = $config;
8980             }
8981             # also check executable directory unless path is absolute
8982             $exeDir = ($0 =~ /(.*)[\\\/]/) ? $1 : '.' unless defined $exeDir;
8983             -r $file or $config =~ /^\// or $file = "$exeDir/$config";
8984             unless (-r $file) {
8985             warn("Config file not found\n") if defined $Image::ExifTool::configFile;
8986             last;
8987             }
8988             unshift @INC, '.'; # look in current directory first
8989             eval { require $file }; # load the config file
8990             shift @INC;
8991             # print warning (minus "Compilation failed" part)
8992             $@ and $_=$@, s/Compilation failed.*//s, warn $_;
8993             last;
8994             }
8995             # read user-defined lenses (may have been defined by script instead of config file)
8996             if (@Image::ExifTool::UserDefined::Lenses) {
8997             foreach (@Image::ExifTool::UserDefined::Lenses) {
8998             $Image::ExifTool::userLens{$_} = 1;
8999             }
9000             }
9001             # add user-defined file types
9002             if (%Image::ExifTool::UserDefined::FileTypes) {
9003             foreach (sort keys %Image::ExifTool::UserDefined::FileTypes) {
9004             my $fileInfo = $Image::ExifTool::UserDefined::FileTypes{$_};
9005             my $type = uc $_;
9006             ref $fileInfo eq 'HASH' or $fileTypeLookup{$type} = $fileInfo, next;
9007             my $baseType = $$fileInfo{BaseType};
9008             if ($baseType) {
9009             if ($$fileInfo{Description}) {
9010             $fileTypeLookup{$type} = [ $baseType, $$fileInfo{Description} ];
9011             } else {
9012             $fileTypeLookup{$type} = $baseType;
9013             }
9014             if (defined $$fileInfo{Writable} and not $$fileInfo{Writable}) {
9015             # first make sure we are using an actual base type and not a derived type
9016             $baseType = $fileTypeLookup{$baseType} while $baseType and not ref $fileTypeLookup{$baseType};
9017             # mark this type as not writable
9018             $noWriteFile{$baseType} or $noWriteFile{$baseType} = [ ];
9019             push @{$noWriteFile{$baseType}}, $type;
9020             }
9021             } else {
9022             $fileTypeLookup{$type} = [ $type, $$fileInfo{Description} || $type ];
9023             $moduleName{$type} = 0; # not supported
9024             if ($$fileInfo{Magic}) {
9025             $magicNumber{$type} = $$fileInfo{Magic};
9026             push @fileTypes, $type unless grep /^$type$/, @fileTypes;
9027             }
9028             }
9029             $mimeType{$type} = $$fileInfo{MIMEType} if defined $$fileInfo{MIMEType};
9030             }
9031             }
9032              
9033             #------------------------------------------------------------------------------
9034             1; # end