File Coverage

blib/lib/Image/ExifTool.pm
Criterion Covered Total %
statement 2952 3902 75.6
branch 1846 2972 62.1
condition 814 1506 54.0
subroutine 156 168 92.8
pod 22 151 14.5
total 5790 8699 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-2023, 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 106     106   255747 use strict;
  106         1254  
  106         4262  
19             require 5.004; # require 5.004 for UNIVERSAL::isa (otherwise 5.002 would do)
20             require Exporter;
21 106     106   51474 use File::RandomAccess;
  106         267  
  106         6085  
22 106     106   131842 use overload;
  106         185327  
  106         4294  
23              
24 106         738677 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 106     106   9959 %static_vars);
  106         254  
31              
32             $VERSION = '12.60';
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             sub SetAlternateFile($$$);
79             # non-public routines below
80             sub InsertTagValues($$$;$$$);
81             sub IsWritable($);
82             sub IsSameFile($$$);
83             sub IsRawType($);
84             sub GetNewFileName($$);
85             sub LoadAllTables();
86             sub GetNewTagInfoList($;$);
87             sub GetNewTagInfoHash($@);
88             sub GetLangInfo($$);
89             sub Get64s($$);
90             sub Get64u($$);
91             sub GetFixed64s($$);
92             sub GetExtended($$);
93             sub Set64u(@);
94             sub Set64s(@);
95             sub DecodeBits($$;$);
96             sub EncodeBits($$;$$);
97             sub Filter($$$);
98             sub HexDump($;$%);
99             sub DumpTrailer($$);
100             sub DumpUnknownTrailer($$);
101             sub VerboseInfo($$$%);
102             sub VerboseValue($$$;$);
103             sub VPrint($$@);
104             sub Rationalize($;$);
105             sub Write($@);
106             sub WriteTrailerBuffer($$$);
107             sub AddNewTrailers($;@);
108             sub Tell($);
109             sub WriteValue($$;$$$$);
110             sub WriteDirectory($$$;$);
111             sub WriteBinaryData($$$);
112             sub CheckBinaryData($$$);
113             sub WriteTIFF($$$);
114             sub PackUTF8(@);
115             sub UnpackUTF8($);
116             sub SetPreferredByteOrder($;$);
117             sub ImageDataMD5($$$;$$);
118             sub CopyBlock($$$);
119             sub CopyFileAttrs($$$);
120             sub TimeNow(;$$);
121             sub InverseDateTime($$;$$);
122             sub NewGUID();
123             sub MakeTiffHeader($$$$;$$);
124              
125             # other subroutine definitions
126             sub SplitFileName($);
127             sub EncodeFileName($$;$);
128             sub Open($*$;$);
129             sub Exists($$);
130             sub IsDirectory($$);
131             sub Rename($$$);
132             sub Unlink($@);
133             sub SetFileTime($$;$$$$);
134             sub DoEscape($$);
135             sub ConvertFileSize($);
136             sub ParseArguments($;@); #(defined in attempt to avoid mod_perl problem)
137             sub ReadValue($$$;$$$);
138              
139             # list of main tag tables to load in LoadAllTables() (sub-tables are recursed
140             # automatically). Note: They will appear in this order in the documentation
141             # unless tweaked in BuildTagLookup::GetTableOrder().
142             @loadAllTables = qw(
143             PhotoMechanic Exif GeoTiff CanonRaw KyoceraRaw Lytro MinoltaRaw PanasonicRaw
144             SigmaRaw JPEG GIMP Jpeg2000 GIF BMP BMP::OS2 BMP::Extra BPG BPG::Extensions
145             ICO PICT PNG MNG FLIF DjVu DPX OpenEXR ZISRAW MRC LIF MRC::FEI12 MIFF PCX
146             PGF PSP PhotoCD Radiance Other::PFM PDF PostScript Photoshop::Header
147             Photoshop::Layers Photoshop::ImageData FujiFilm::RAF FujiFilm::IFD
148             Samsung::Trailer Sony::SRF2 Sony::SR2SubIFD Sony::PMP ITC ID3 ID3::Lyrics3
149             FLAC Ogg Vorbis APE APE::NewHeader APE::OldHeader Audible MPC MPEG::Audio
150             MPEG::Video MPEG::Xing M2TS QuickTime QuickTime::ImageFile QuickTime::Stream
151             QuickTime::Tags360Fly Matroska Matroska::StdTag MOI MXF DV Flash Flash::FLV
152             Real::Media Real::Audio Real::Metafile Red RIFF AIFF ASF WTV DICOM FITS MIE
153             JSON HTML XMP::SVG Palm Palm::MOBI Palm::EXTH Torrent EXE EXE::PEVersion
154             EXE::PEString EXE::MachO EXE::PEF EXE::ELF EXE::AR EXE::CHM LNK Font VCard
155             Text VCard::VCalendar VCard::VNote RSRC Rawzor ZIP ZIP::GZIP ZIP::RAR RTF
156             OOXML iWork ISO FLIR::AFF FLIR::FPF MacOS MacOS::MDItem FlashPix::DocTable
157             );
158              
159             # alphabetical list of current Lang modules
160             @langs = qw(cs de en en_ca en_gb es fi fr it ja ko nl pl ru sk sv tr zh_cn zh_tw);
161              
162             $defaultLang = 'en'; # default language
163              
164             # language names
165             %langName = (
166             cs => 'Czech (Čeština)',
167             de => 'German (Deutsch)',
168             en => 'English',
169             en_ca => 'Canadian English',
170             en_gb => 'British English',
171             es => 'Spanish (Español)',
172             fi => 'Finnish (Suomi)',
173             fr => 'French (Français)',
174             it => 'Italian (Italiano)',
175             ja => 'Japanese (日本語)',
176             ko => 'Korean (한국어)',
177             nl => 'Dutch (Nederlands)',
178             pl => 'Polish (Polski)',
179             ru => 'Russian (Русский)',
180             sk => 'Slovak (Slovenčina)',
181             sv => 'Swedish (Svenska)',
182             'tr'=> 'Turkish (Türkçe)',
183             zh_cn => 'Simplified Chinese (简体中文)',
184             zh_tw => 'Traditional Chinese (繁體中文)',
185             );
186              
187             # recognized file types, in the order we test unknown files
188             # Notes: 1) There is no need to test for like types separately here
189             # 2) Put types with weak file signatures at end of list to avoid false matches
190             # 3) PLIST must be in this list for the binary PLIST format, although it may
191             # cause a file to be checked twice for XML
192             @fileTypes = qw(JPEG EXV CRW DR4 TIFF GIF MRW RAF X3F JP2 PNG MIE MIFF PS PDF
193             PSD XMP BMP BPG PPM RIFF AIFF ASF MOV MPEG Real SWF PSP FLV OGG
194             FLAC APE MPC MKV MXF DV PMP IND PGF ICC ITC FLIR FLIF FPF LFP
195             HTML VRD RTF FITS XCF DSS QTIF FPX PICT ZIP GZIP PLIST RAR BZ2
196             CZI TAR EXE EXR HDR CHM LNK WMF AVC DEX DPX RAW Font RSRC M2TS
197             MacOS PHP PCX DCX DWF DWG DXF WTV Torrent VCard LRI R3D AA PDB
198             PFM2 MRC LIF JXL MOI ISO ALIAS JSON MP3 DICOM PCD ICO TXT);
199              
200             # file types that we can write (edit)
201             my @writeTypes = qw(JPEG TIFF GIF CRW MRW ORF RAF RAW PNG MIE PSD XMP PPM EPS
202             X3F PS PDF ICC VRD DR4 JP2 JXL EXIF AI AIT IND MOV EXV FLIF
203             RIFF);
204             my %writeTypes; # lookup for writable file types (hash filled if required)
205              
206             # file extensions that we can't write for various base types
207             %noWriteFile = (
208             TIFF => [ qw(3FR DCR K25 KDC SRF) ],
209             XMP => [ qw(SVG INX) ],
210             JP2 => [ qw(J2C JPC) ],
211             MOV => [ qw(INSV) ],
212             );
213             # file extensions that we can only write for various base types
214             my %onlyWriteFile = ( RIFF => [ qw(WEBP) ] );
215              
216             # file types that we can create from scratch
217             # - must update CanCreate() documentation if this list is changed!
218             my %createTypes = map { $_ => 1 } qw(XMP ICC MIE VRD DR4 EXIF EXV);
219              
220             # file type lookup for all recognized file extensions (upper case)
221             # (if extension may be more than one type, the type is a list where
222             # the writable type should come first if it exists)
223             %fileTypeLookup = (
224             '360' => ['MOV', 'GoPro 360 video'],
225             '3FR' => ['TIFF', 'Hasselblad RAW format'],
226             '3G2' => ['MOV', '3rd Gen. Partnership Project 2 audio/video'],
227             '3GP' => ['MOV', '3rd Gen. Partnership Project audio/video'],
228             '3GP2'=> '3G2',
229             '3GPP'=> '3GP',
230             A => ['EXE', 'Static library'],
231             AA => ['AA', 'Audible Audiobook'],
232             AAE => ['PLIST','Apple edit information'],
233             AAX => ['MOV', 'Audible Enhanced Audiobook'],
234             ACR => ['DICOM','American College of Radiology ACR-NEMA'],
235             ACFM => ['Font', 'Adobe Composite Font Metrics'],
236             AFM => ['Font', 'Adobe Font Metrics'],
237             AMFM => ['Font', 'Adobe Multiple Master Font Metrics'],
238             AI => [['PDF','PS'], 'Adobe Illustrator'],
239             AIF => 'AIFF',
240             AIFC => ['AIFF', 'Audio Interchange File Format Compressed'],
241             AIFF => ['AIFF', 'Audio Interchange File Format'],
242             AIT => 'AI',
243             ALIAS=> ['ALIAS','MacOS file alias'],
244             APE => ['APE', "Monkey's Audio format"],
245             APNG => ['PNG', 'Animated Portable Network Graphics'],
246             ARW => ['TIFF', 'Sony Alpha RAW format'],
247             ARQ => ['TIFF', 'Sony Alpha Pixel-Shift RAW format'],
248             ASF => ['ASF', 'Microsoft Advanced Systems Format'],
249             AVC => ['AVC', 'Advanced Video Connection'], # (extensions are actually _AU,_AD,_IM,_ID)
250             AVI => ['RIFF', 'Audio Video Interleaved'],
251             AVIF => ['MOV', 'AV1 Image File Format'],
252             AZW => 'MOBI', # (see http://wiki.mobileread.com/wiki/AZW)
253             AZW3 => 'MOBI',
254             BMP => ['BMP', 'Windows Bitmap'],
255             BPG => ['BPG', 'Better Portable Graphics'],
256             BTF => ['BTF', 'Big Tagged Image File Format'], #(unofficial)
257             BZ2 => ['BZ2', 'BZIP2 archive'],
258             CHM => ['CHM', 'Microsoft Compiled HTML format'],
259             CIFF => ['CRW', 'Camera Image File Format'],
260             COS => ['COS', 'Capture One Settings'],
261             CR2 => ['TIFF', 'Canon RAW 2 format'],
262             CR3 => ['MOV', 'Canon RAW 3 format'],
263             CRM => ['MOV', 'Canon RAW Movie'],
264             CRW => ['CRW', 'Canon RAW format'],
265             CS1 => ['PSD', 'Sinar CaptureShop 1-Shot RAW'],
266             CSV => ['TXT', 'Comma-Separated Values'],
267             CUR => ['ICO', 'Windows Cursor'],
268             CZI => ['CZI', 'Zeiss Integrated Software RAW'],
269             DC3 => 'DICM',
270             DCM => 'DICM',
271             DCP => ['TIFF', 'DNG Camera Profile'],
272             DCR => ['TIFF', 'Kodak Digital Camera RAW'],
273             DCX => ['DCX', 'Multi-page PC Paintbrush'],
274             DEX => ['DEX', 'Dalvik Executable format'],
275             DFONT=> ['Font', 'Macintosh Data fork Font'],
276             DIB => ['BMP', 'Device Independent Bitmap'],
277             DIC => 'DICM',
278             DICM => ['DICOM','Digital Imaging and Communications in Medicine'],
279             DIR => ['DIR', 'Directory'],
280             DIVX => ['ASF', 'DivX media format'],
281             DJV => 'DJVU',
282             DJVU => ['AIFF', 'DjVu image'],
283             DLL => ['EXE', 'Windows Dynamic Link Library'],
284             DNG => ['TIFF', 'Digital Negative'],
285             DOC => ['FPX', 'Microsoft Word Document'],
286             DOCM => [['ZIP','FPX'], 'Office Open XML Document Macro-enabled'],
287             # Note: I have seen a password-protected DOCX file which was FPX-like, so I assume
288             # that any other MS Office file could be like this too. The only difference is
289             # that the ZIP and FPX formats are checked first, so if this is wrong, no biggie.
290             DOCX => [['ZIP','FPX'], 'Office Open XML Document'],
291             DOT => ['FPX', 'Microsoft Word Template'],
292             DOTM => [['ZIP','FPX'], 'Office Open XML Document Template Macro-enabled'],
293             DOTX => [['ZIP','FPX'], 'Office Open XML Document Template'],
294             DPX => ['DPX', 'Digital Picture Exchange' ],
295             DR4 => ['DR4', 'Canon VRD version 4 Recipe'],
296             DS2 => ['DSS', 'Digital Speech Standard 2'],
297             DSS => ['DSS', 'Digital Speech Standard'],
298             DV => ['DV', 'Digital Video'],
299             DVB => ['MOV', 'Digital Video Broadcasting'],
300             'DVR-MS'=>['ASF', 'Microsoft Digital Video recording'],
301             DWF => ['DWF', 'Autodesk drawing (Design Web Format)'],
302             DWG => ['DWG', 'AutoCAD Drawing'],
303             DYLIB=> ['EXE', 'Mach-O Dynamic Link Library'],
304             DXF => ['DXF', 'AutoCAD Drawing Exchange Format'],
305             EIP => ['ZIP', 'Capture One Enhanced Image Package'],
306             EPS => ['EPS', 'Encapsulated PostScript Format'],
307             EPS2 => 'EPS',
308             EPS3 => 'EPS',
309             EPSF => 'EPS',
310             EPUB => ['ZIP', 'Electronic Publication'],
311             ERF => ['TIFF', 'Epson Raw Format'],
312             EXE => ['EXE', 'Windows executable file'],
313             EXR => ['EXR', 'Open EXR'],
314             EXIF => ['EXIF', 'Exchangable Image File Metadata'],
315             EXV => ['EXV', 'Exiv2 metadata'],
316             F4A => ['MOV', 'Adobe Flash Player 9+ Audio'],
317             F4B => ['MOV', 'Adobe Flash Player 9+ audio Book'],
318             F4P => ['MOV', 'Adobe Flash Player 9+ Protected'],
319             F4V => ['MOV', 'Adobe Flash Player 9+ Video'],
320             FFF => [['TIFF','FLIR'], 'Hasselblad Flexible File Format'],
321             FIT => 'FITS',
322             FITS => ['FITS', 'Flexible Image Transport System'],
323             FLAC => ['FLAC', 'Free Lossless Audio Codec'],
324             FLA => ['FPX', 'Macromedia/Adobe Flash project'],
325             FLIF => ['FLIF', 'Free Lossless Image Format'],
326             FLIR => ['FLIR', 'FLIR File Format'], # (not an actual extension)
327             FLV => ['FLV', 'Flash Video'],
328             FPF => ['FPF', 'FLIR Public image Format'],
329             FPX => ['FPX', 'FlashPix'],
330             GIF => ['GIF', 'Compuserve Graphics Interchange Format'],
331             GPR => ['TIFF', 'General Purpose RAW'], # https://gopro.github.io/gpr/
332             GZ => 'GZIP',
333             GZIP => ['GZIP', 'GNU ZIP compressed archive'],
334             HDP => ['TIFF', 'Windows HD Photo'],
335             HDR => ['HDR', 'Radiance RGBE High Dynamic Range'],
336             HEIC => ['MOV', 'High Efficiency Image Format still image'],
337             HEIF => ['MOV', 'High Efficiency Image Format'],
338             HIF => 'HEIF',
339             HTM => 'HTML',
340             HTML => ['HTML', 'HyperText Markup Language'],
341             ICAL => 'ICS',
342             ICC => ['ICC', 'International Color Consortium'],
343             ICM => 'ICC',
344             ICO => ['ICO', 'Windows Icon'],
345             ICS => ['VCard','iCalendar Schedule'],
346             IDML => ['ZIP', 'Adobe InDesign Markup Language'],
347             IIQ => ['TIFF', 'Phase One Intelligent Image Quality RAW'],
348             IND => ['IND', 'Adobe InDesign'],
349             INDD => ['IND', 'Adobe InDesign Document'],
350             INDT => ['IND', 'Adobe InDesign Template'],
351             INSV => ['MOV', 'Insta360 Video'],
352             INSP => ['JPEG', 'Insta360 Picture'],
353             INX => ['XMP', 'Adobe InDesign Interchange'],
354             ISO => ['ISO', 'ISO 9660 disk image'],
355             ITC => ['ITC', 'iTunes Cover Flow'],
356             J2C => ['JP2', 'JPEG 2000 codestream'],
357             J2K => 'J2C',
358             JNG => ['PNG', 'JPG Network Graphics'],
359             JP2 => ['JP2', 'JPEG 2000 file'],
360             # JP4? - looks like a JPEG but the image data is different
361             JPC => 'J2C',
362             JPE => 'JPEG',
363             JPEG => ['JPEG', 'Joint Photographic Experts Group'],
364             JPF => 'JP2',
365             JPG => 'JPEG',
366             JPM => ['JP2', 'JPEG 2000 compound image'],
367             JPS => ['JPEG', 'JPEG Stereo image'],
368             JPX => ['JP2', 'JPEG 2000 with extensions'],
369             JSON => ['JSON', 'JavaScript Object Notation'],
370             JXL => ['JXL', 'JPEG XL'],
371             JXR => ['TIFF', 'JPEG XR'],
372             K25 => ['TIFF', 'Kodak DC25 RAW'],
373             KDC => ['TIFF', 'Kodak Digital Camera RAW'],
374             KEY => ['ZIP', 'Apple Keynote presentation'],
375             KTH => ['ZIP', 'Apple Keynote Theme'],
376             LA => ['RIFF', 'Lossless Audio'],
377             LFP => ['LFP', 'Lytro Light Field Picture'],
378             LFR => 'LFP', # (Light Field RAW)
379             LIF => ['LIF', 'Leica Image File'],
380             LNK => ['LNK', 'Windows shortcut'],
381             LRI => ['LRI', 'Light RAW'],
382             LRV => ['MOV', 'Low-Resolution Video'],
383             M2T => 'M2TS',
384             M2TS => ['M2TS', 'MPEG-2 Transport Stream'],
385             M2V => ['MPEG', 'MPEG-2 Video'],
386             M4A => ['MOV', 'MPEG-4 Audio'],
387             M4B => ['MOV', 'MPEG-4 audio Book'],
388             M4P => ['MOV', 'MPEG-4 Protected'],
389             M4V => ['MOV', 'MPEG-4 Video'],
390             MACOS=> ['MacOS','MacOS ._ sidecar file'],
391             MAX => ['FPX', '3D Studio MAX'],
392             MEF => ['TIFF', 'Mamiya (RAW) Electronic Format'],
393             MIE => ['MIE', 'Meta Information Encapsulation format'],
394             MIF => 'MIFF',
395             MIFF => ['MIFF', 'Magick Image File Format'],
396             MKA => ['MKV', 'Matroska Audio'],
397             MKS => ['MKV', 'Matroska Subtitle'],
398             MKV => ['MKV', 'Matroska Video'],
399             MNG => ['PNG', 'Multiple-image Network Graphics'],
400             MOBI => ['PDB', 'Mobipocket electronic book'],
401             MODD => ['PLIST','Sony Picture Motion metadata'],
402             MOI => ['MOI', 'MOD Information file'],
403             MOS => ['TIFF', 'Creo Leaf Mosaic'],
404             MOV => ['MOV', 'Apple QuickTime movie'],
405             MP3 => ['MP3', 'MPEG-1 Layer 3 audio'],
406             MP4 => ['MOV', 'MPEG-4 video'],
407             MPC => ['MPC', 'Musepack Audio'],
408             MPEG => ['MPEG', 'MPEG-1 or MPEG-2 audio/video'],
409             MPG => 'MPEG',
410             MPO => ['JPEG', 'Extended Multi-Picture format'],
411             MQV => ['MOV', 'Sony Mobile Quicktime Video'],
412             MRC => ['MRC', 'Medical Research Council image'],
413             MRW => ['MRW', 'Minolta RAW format'],
414             MTS => 'M2TS',
415             MXF => ['MXF', 'Material Exchange Format'],
416             # NDPI => ['TIFF', 'Hamamatsu NanoZoomer Digital Pathology Image'],
417             NEF => ['TIFF', 'Nikon (RAW) Electronic Format'],
418             NEWER => 'COS',
419             NKSC => ['XMP', 'Nikon Sidecar'],
420             NMBTEMPLATE => ['ZIP','Apple Numbers Template'],
421             NRW => ['TIFF', 'Nikon RAW (2)'],
422             NUMBERS => ['ZIP','Apple Numbers spreadsheet'],
423             O => ['EXE', 'Relocatable Object'],
424             ODB => ['ZIP', 'Open Document Database'],
425             ODC => ['ZIP', 'Open Document Chart'],
426             ODF => ['ZIP', 'Open Document Formula'],
427             ODG => ['ZIP', 'Open Document Graphics'],
428             ODI => ['ZIP', 'Open Document Image'],
429             ODP => ['ZIP', 'Open Document Presentation'],
430             ODS => ['ZIP', 'Open Document Spreadsheet'],
431             ODT => ['ZIP', 'Open Document Text file'],
432             OFR => ['RIFF', 'OptimFROG audio'],
433             OGG => ['OGG', 'Ogg Vorbis audio file'],
434             OGV => ['OGG', 'Ogg Video file'],
435             ONP => ['JSON', 'ON1 Presets'],
436             OPUS => ['OGG', 'Ogg Opus audio file'],
437             ORF => ['ORF', 'Olympus RAW format'],
438             ORI => 'ORF',
439             OTF => ['Font', 'Open Type Font'],
440             PAC => ['RIFF', 'Lossless Predictive Audio Compression'],
441             PAGES => ['ZIP', 'Apple Pages document'],
442             PBM => ['PPM', 'Portable BitMap'],
443             PCD => ['PCD', 'Kodak Photo CD Image Pac'],
444             PCT => 'PICT',
445             PCX => ['PCX', 'PC Paintbrush'],
446             PDB => ['PDB', 'Palm Database'],
447             PDF => ['PDF', 'Adobe Portable Document Format'],
448             PEF => ['TIFF', 'Pentax (RAW) Electronic Format'],
449             PFA => ['Font', 'PostScript Font ASCII'],
450             PFB => ['Font', 'PostScript Font Binary'],
451             PFM => [['Font','PFM2'], 'Printer Font Metrics'], # (description is overridden for Portable FloatMap images)
452             PGF => ['PGF', 'Progressive Graphics File'],
453             PGM => ['PPM', 'Portable Gray Map'],
454             PHP => ['PHP', 'PHP Hypertext Preprocessor'],
455             PHP3 => 'PHP',
456             PHP4 => 'PHP',
457             PHP5 => 'PHP',
458             PHPS => 'PHP',
459             PHTML=> 'PHP',
460             PICT => ['PICT', 'Apple PICTure'],
461             PLIST=> ['PLIST','Apple Property List'],
462             PMP => ['PMP', 'Sony DSC-F1 Cyber-Shot PMP'], # should stand for Proprietery Metadata Package ;)
463             PNG => ['PNG', 'Portable Network Graphics'],
464             POT => ['FPX', 'Microsoft PowerPoint Template'],
465             POTM => [['ZIP','FPX'], 'Office Open XML Presentation Template Macro-enabled'],
466             POTX => [['ZIP','FPX'], 'Office Open XML Presentation Template'],
467             PPAM => [['ZIP','FPX'], 'Office Open XML Presentation Addin Macro-enabled'],
468             PPAX => [['ZIP','FPX'], 'Office Open XML Presentation Addin'],
469             PPM => ['PPM', 'Portable Pixel Map'],
470             PPS => ['FPX', 'Microsoft PowerPoint Slideshow'],
471             PPSM => [['ZIP','FPX'], 'Office Open XML Presentation Slideshow Macro-enabled'],
472             PPSX => [['ZIP','FPX'], 'Office Open XML Presentation Slideshow'],
473             PPT => ['FPX', 'Microsoft PowerPoint Presentation'],
474             PPTM => [['ZIP','FPX'], 'Office Open XML Presentation Macro-enabled'],
475             PPTX => [['ZIP','FPX'], 'Office Open XML Presentation'],
476             PRC => ['PDB', 'Palm Database'],
477             PS => ['PS', 'PostScript'],
478             PS2 => 'PS',
479             PS3 => 'PS',
480             PSB => ['PSD', 'Photoshop Large Document'],
481             PSD => ['PSD', 'Photoshop Document'],
482             PSDT => ['PSD', 'Photoshop Document Template'],
483             PSP => ['PSP', 'Paint Shop Pro'],
484             PSPFRAME => 'PSP',
485             PSPIMAGE => 'PSP',
486             PSPSHAPE => 'PSP',
487             PSPTUBE => 'PSP',
488             QIF => 'QTIF',
489             QT => 'MOV',
490             QTI => 'QTIF',
491             QTIF => ['QTIF', 'QuickTime Image File'],
492             R3D => ['R3D', 'Redcode RAW Video'],
493             RA => ['Real', 'Real Audio'],
494             RAF => ['RAF', 'FujiFilm RAW Format'],
495             RAM => ['Real', 'Real Audio Metafile'],
496             RAR => ['RAR', 'RAR Archive'],
497             RAW => [['RAW','TIFF'], 'Kyocera Contax N Digital RAW or Panasonic RAW'],
498             RIF => 'RIFF',
499             RIFF => ['RIFF', 'Resource Interchange File Format'],
500             RM => ['Real', 'Real Media'],
501             RMVB => ['Real', 'Real Media Variable Bitrate'],
502             RPM => ['Real', 'Real Media Plug-in Metafile'],
503             RSRC => ['RSRC', 'Mac OS Resource'],
504             RTF => ['RTF', 'Rich Text Format'],
505             RV => ['Real', 'Real Video'],
506             RW2 => ['TIFF', 'Panasonic RAW 2'],
507             RWL => ['TIFF', 'Leica RAW'],
508             RWZ => ['RWZ', 'Rawzor compressed image'],
509             SEQ => ['FLIR', 'FLIR image Sequence'],
510             SKETCH => ['ZIP', 'Sketch design file'],
511             SO => ['EXE', 'Shared Object file'],
512             SR2 => ['TIFF', 'Sony RAW Format 2'],
513             SRF => ['TIFF', 'Sony RAW Format'],
514             SRW => ['TIFF', 'Samsung RAW format'],
515             SVG => ['XMP', 'Scalable Vector Graphics'],
516             SWF => ['SWF', 'Shockwave Flash'],
517             TAR => ['TAR', 'TAR archive'],
518             THM => ['JPEG', 'Thumbnail'],
519             THMX => [['ZIP','FPX'], 'Office Open XML Theme'],
520             TIF => 'TIFF',
521             TIFF => ['TIFF', 'Tagged Image File Format'],
522             TORRENT => ['Torrent', 'BitTorrent description file'],
523             TS => 'M2TS',
524             TTC => ['Font', 'True Type Font Collection'],
525             TTF => ['Font', 'True Type Font'],
526             TUB => 'PSP',
527             TXT => ['TXT', 'Text file'],
528             VCARD=> ['VCard','Virtual Card'],
529             VCF => 'VCARD',
530             VOB => ['MPEG', 'Video Object'],
531             VNT => [['FPX','VCard'], 'Scene7 Vignette or V-Note text file'],
532             VRD => ['VRD', 'Canon VRD Recipe Data'],
533             VSD => ['FPX', 'Microsoft Visio Drawing'],
534             WAV => ['RIFF', 'WAVeform (Windows digital audio)'],
535             WDP => ['TIFF', 'Windows Media Photo'],
536             WEBM => ['MKV', 'Google Web Movie'],
537             WEBP => ['RIFF', 'Google Web Picture'],
538             WMA => ['ASF', 'Windows Media Audio'],
539             WMF => ['WMF', 'Windows Metafile Format'],
540             WMV => ['ASF', 'Windows Media Video'],
541             WV => ['RIFF', 'WavePack lossless audio'],
542             X3F => ['X3F', 'Sigma RAW format'],
543             XCF => ['XCF', 'GIMP native image format'],
544             XHTML=> ['HTML', 'Extensible HyperText Markup Language'],
545             XLA => ['FPX', 'Microsoft Excel Add-in'],
546             XLAM => [['ZIP','FPX'], 'Office Open XML Spreadsheet Add-in Macro-enabled'],
547             XLS => ['FPX', 'Microsoft Excel Spreadsheet'],
548             XLSB => [['ZIP','FPX'], 'Office Open XML Spreadsheet Binary'],
549             XLSM => [['ZIP','FPX'], 'Office Open XML Spreadsheet Macro-enabled'],
550             XLSX => [['ZIP','FPX'], 'Office Open XML Spreadsheet'],
551             XLT => ['FPX', 'Microsoft Excel Template'],
552             XLTM => [['ZIP','FPX'], 'Office Open XML Spreadsheet Template Macro-enabled'],
553             XLTX => [['ZIP','FPX'], 'Office Open XML Spreadsheet Template'],
554             XMP => ['XMP', 'Extensible Metadata Platform'],
555             WOFF => ['Font', 'Web Open Font Format'],
556             WOFF2=> ['Font', 'Web Open Font Format2'],
557             WTV => ['WTV', 'Windows recorded TV show'],
558             ZIP => ['ZIP', 'ZIP archive'],
559             );
560              
561             # typical extension for each file type (if different than FileType)
562             # - case is not significant
563             my %fileTypeExt = (
564             'Canon 1D RAW' => 'tif',
565             DICOM => 'dcm',
566             FLIR => 'fff',
567             GZIP => 'gz',
568             JPEG => 'jpg',
569             M2TS => 'mts',
570             MPEG => 'mpg',
571             TIFF => 'tif',
572             VCard => 'vcf',
573             );
574              
575             # descriptions for file types not found in above file extension lookup
576             my %fileDescription = (
577             DICOM => 'Digital Imaging and Communications in Medicine',
578             XML => 'Extensible Markup Language',
579             'Win32 EXE' => 'Windows 32-bit Executable',
580             'Win32 DLL' => 'Windows 32-bit Dynamic Link Library',
581             'Win64 EXE' => 'Windows 64-bit Executable',
582             'Win64 DLL' => 'Windows 64-bit Dynamic Link Library',
583             VNote => 'V-Note document',
584             );
585              
586             # MIME types for applicable file types above
587             # (missing entries default to 'application/unknown', but note that other MIME
588             # types may be specified by some modules, eg. QuickTime.pm and RIFF.pm)
589             %mimeType = (
590             '3FR' => 'image/x-hasselblad-3fr',
591             AA => 'audio/audible',
592             AAE => 'application/vnd.apple.photos',
593             AI => 'application/vnd.adobe.illustrator',
594             AIFF => 'audio/x-aiff',
595             ALIAS=> 'application/x-macos',
596             APE => 'audio/x-monkeys-audio',
597             APNG => 'image/apng',
598             ASF => 'video/x-ms-asf',
599             ARW => 'image/x-sony-arw',
600             BMP => 'image/bmp',
601             BPG => 'image/bpg',
602             BTF => 'image/x-tiff-big', #(NC) (ref http://www.asmail.be/msg0055371937.html)
603             BZ2 => 'application/bzip2',
604             'Canon 1D RAW' => 'image/x-raw', # (uses .TIF file extension)
605             CHM => 'application/x-chm',
606             COS => 'application/octet-stream', #PH (NC)
607             CR2 => 'image/x-canon-cr2',
608             CR3 => 'image/x-canon-cr3',
609             CRM => 'video/x-canon-crm',
610             CRW => 'image/x-canon-crw',
611             CSV => 'text/csv',
612             CUR => 'image/x-cursor', #PH (NC)
613             CZI => 'image/x-zeiss-czi', #PH (NC)
614             DCP => 'application/octet-stream', #PH (NC)
615             DCR => 'image/x-kodak-dcr',
616             DCX => 'image/dcx',
617             DEX => 'application/octet-stream',
618             DFONT=> 'application/x-dfont',
619             DICOM=> 'application/dicom',
620             DIVX => 'video/divx',
621             DJVU => 'image/vnd.djvu',
622             DNG => 'image/x-adobe-dng',
623             DOC => 'application/msword',
624             DOCM => 'application/vnd.ms-word.document.macroEnabled.12',
625             DOCX => 'application/vnd.openxmlformats-officedocument.wordprocessingml.document',
626             DOT => 'application/msword',
627             DOTM => 'application/vnd.ms-word.template.macroEnabledTemplate',
628             DOTX => 'application/vnd.openxmlformats-officedocument.wordprocessingml.template',
629             DPX => 'image/x-dpx',
630             DR4 => 'application/octet-stream', #PH (NC)
631             DS2 => 'audio/x-ds2',
632             DSS => 'audio/x-dss',
633             DV => 'video/x-dv',
634             'DVR-MS' => 'video/x-ms-dvr',
635             DWF => 'model/vnd.dwf',
636             DWG => 'image/vnd.dwg',
637             DXF => 'application/dxf',
638             EIP => 'application/x-captureone', #(NC)
639             EPS => 'application/postscript',
640             ERF => 'image/x-epson-erf',
641             EXE => 'application/octet-stream',
642             EXR => 'image/x-exr',
643             EXV => 'image/x-exv',
644             FFF => 'image/x-hasselblad-fff',
645             FITS => 'image/fits',
646             FLA => 'application/vnd.adobe.fla',
647             FLAC => 'audio/flac',
648             FLIF => 'image/flif',
649             FLIR => 'image/x-flir-fff', #PH (NC)
650             FLV => 'video/x-flv',
651             Font => 'application/x-font-type1', # covers PFA, PFB and PFM (not sure about PFM)
652             FPF => 'image/x-flir-fpf', #PH (NC)
653             FPX => 'image/vnd.fpx',
654             GIF => 'image/gif',
655             GPR => 'image/x-gopro-gpr',
656             GZIP => 'application/x-gzip',
657             HDP => 'image/vnd.ms-photo',
658             HDR => 'image/vnd.radiance',
659             HTML => 'text/html',
660             ICC => 'application/vnd.iccprofile',
661             ICO => 'image/x-icon', #PH (NC)
662             ICS => 'text/calendar',
663             IDML => 'application/vnd.adobe.indesign-idml-package',
664             IIQ => 'image/x-raw',
665             IND => 'application/x-indesign',
666             INX => 'application/x-indesign-interchange', #PH (NC)
667             ISO => 'application/x-iso9660-image',
668             ITC => 'application/itunes',
669             J2C => 'image/x-j2c', #PH (NC)
670             JNG => 'image/jng',
671             JP2 => 'image/jp2',
672             JPEG => 'image/jpeg',
673             JPM => 'image/jpm',
674             JPS => 'image/x-jps',
675             JPX => 'image/jpx',
676             JSON => 'application/json',
677             JXL => 'image/jxl', #PH (NC)
678             JXR => 'image/jxr',
679             K25 => 'image/x-kodak-k25',
680             KDC => 'image/x-kodak-kdc',
681             KEY => 'application/x-iwork-keynote-sffkey',
682             LFP => 'image/x-lytro-lfp', #PH (NC)
683             LIF => 'image/x-lif',
684             LNK => 'application/octet-stream',
685             LRI => 'image/x-light-lri',
686             M2T => 'video/mpeg',
687             M2TS => 'video/m2ts',
688             MAX => 'application/x-3ds',
689             MEF => 'image/x-mamiya-mef',
690             MIE => 'application/x-mie',
691             MIFF => 'application/x-magick-image',
692             MKA => 'audio/x-matroska',
693             MKS => 'application/x-matroska',
694             MKV => 'video/x-matroska',
695             MNG => 'video/mng',
696             MOBI => 'application/x-mobipocket-ebook',
697             MOI => 'application/octet-stream', #PH (NC)
698             MOS => 'image/x-raw',
699             MOV => 'video/quicktime',
700             MP3 => 'audio/mpeg',
701             MP4 => 'video/mp4',
702             MPC => 'audio/x-musepack',
703             MPEG => 'video/mpeg',
704             MRC => 'image/x-mrc',
705             MRW => 'image/x-minolta-mrw',
706             MXF => 'application/mxf',
707             NEF => 'image/x-nikon-nef',
708             NKSC => 'application/x-nikon-nxstudio',
709             NRW => 'image/x-nikon-nrw',
710             NUMBERS => 'application/x-iwork-numbers-sffnumbers',
711             ODB => 'application/vnd.oasis.opendocument.database',
712             ODC => 'application/vnd.oasis.opendocument.chart',
713             ODF => 'application/vnd.oasis.opendocument.formula',
714             ODG => 'application/vnd.oasis.opendocument.graphics',
715             ODI => 'application/vnd.oasis.opendocument.image',
716             ODP => 'application/vnd.oasis.opendocument.presentation',
717             ODS => 'application/vnd.oasis.opendocument.spreadsheet',
718             ODT => 'application/vnd.oasis.opendocument.text',
719             OGG => 'audio/ogg',
720             OGV => 'video/ogg',
721             ONP => 'application/on1',
722             ORF => 'image/x-olympus-orf',
723             OTF => 'application/x-font-otf',
724             PAGES=> 'application/x-iwork-pages-sffpages',
725             PBM => 'image/x-portable-bitmap',
726             PCD => 'image/x-photo-cd',
727             PCX => 'image/pcx',
728             PDB => 'application/vnd.palm',
729             PDF => 'application/pdf',
730             PEF => 'image/x-pentax-pef',
731             PFA => 'application/x-font-type1', # (needed if handled by PostScript module)
732             PGF => 'image/pgf',
733             PGM => 'image/x-portable-graymap',
734             PHP => 'application/x-httpd-php',
735             PICT => 'image/pict',
736             PLIST=> 'application/xml', # (binary PLIST format is 'application/x-plist', recognized at run time)
737             PMP => 'image/x-sony-pmp', #PH (NC)
738             PNG => 'image/png',
739             POT => 'application/vnd.ms-powerpoint',
740             POTM => 'application/vnd.ms-powerpoint.template.macroEnabled.12',
741             POTX => 'application/vnd.openxmlformats-officedocument.presentationml.template',
742             PPAM => 'application/vnd.ms-powerpoint.addin.macroEnabled.12',
743             PPAX => 'application/vnd.openxmlformats-officedocument.presentationml.addin', # (NC, PH invented)
744             PPM => 'image/x-portable-pixmap',
745             PPS => 'application/vnd.ms-powerpoint',
746             PPSM => 'application/vnd.ms-powerpoint.slideshow.macroEnabled.12',
747             PPSX => 'application/vnd.openxmlformats-officedocument.presentationml.slideshow',
748             PPT => 'application/vnd.ms-powerpoint',
749             PPTM => 'application/vnd.ms-powerpoint.presentation.macroEnabled.12',
750             PPTX => 'application/vnd.openxmlformats-officedocument.presentationml.presentation',
751             PS => 'application/postscript',
752             PSD => 'application/vnd.adobe.photoshop',
753             PSP => 'image/x-paintshoppro', #(NC)
754             QTIF => 'image/x-quicktime',
755             R3D => 'video/x-red-r3d', #PH (invented)
756             RA => 'audio/x-pn-realaudio',
757             RAF => 'image/x-fujifilm-raf',
758             RAM => 'audio/x-pn-realaudio',
759             RAR => 'application/x-rar-compressed',
760             RAW => 'image/x-raw',
761             RM => 'application/vnd.rn-realmedia',
762             RMVB => 'application/vnd.rn-realmedia-vbr',
763             RPM => 'audio/x-pn-realaudio-plugin',
764             RSRC => 'application/ResEdit',
765             RTF => 'text/rtf',
766             RV => 'video/vnd.rn-realvideo',
767             RW2 => 'image/x-panasonic-rw2',
768             RWL => 'image/x-leica-rwl',
769             RWZ => 'image/x-rawzor', #(duplicated in Rawzor.pm)
770             SEQ => 'image/x-flir-seq', #PH (NC)
771             SKETCH => 'application/sketch',
772             SR2 => 'image/x-sony-sr2',
773             SRF => 'image/x-sony-srf',
774             SRW => 'image/x-samsung-srw',
775             SVG => 'image/svg+xml',
776             SWF => 'application/x-shockwave-flash',
777             TAR => 'application/x-tar',
778             THMX => 'application/vnd.ms-officetheme',
779             TIFF => 'image/tiff',
780             Torrent => 'application/x-bittorrent',
781             TTC => 'application/x-font-ttf',
782             TTF => 'application/x-font-ttf',
783             TXT => 'text/plain',
784             VCard=> 'text/vcard',
785             VRD => 'application/octet-stream', #PH (NC)
786             VSD => 'application/x-visio',
787             WDP => 'image/vnd.ms-photo',
788             WEBM => 'video/webm',
789             WMA => 'audio/x-ms-wma',
790             WMF => 'application/x-wmf',
791             WMV => 'video/x-ms-wmv',
792             WTV => 'video/x-ms-wtv',
793             X3F => 'image/x-sigma-x3f',
794             XCF => 'image/x-xcf',
795             XLA => 'application/vnd.ms-excel',
796             XLAM => 'application/vnd.ms-excel.addin.macroEnabled.12',
797             XLS => 'application/vnd.ms-excel',
798             XLSB => 'application/vnd.ms-excel.sheet.binary.macroEnabled.12',
799             XLSM => 'application/vnd.ms-excel.sheet.macroEnabled.12',
800             XLSX => 'application/vnd.openxmlformats-officedocument.spreadsheetml.sheet',
801             XLT => 'application/vnd.ms-excel',
802             XLTM => 'application/vnd.ms-excel.template.macroEnabled.12',
803             XLTX => 'application/vnd.openxmlformats-officedocument.spreadsheetml.template',
804             XML => 'application/xml',
805             XMP => 'application/rdf+xml',
806             ZIP => 'application/zip',
807             );
808              
809             # module names for processing routines of each file type
810             # - undefined entries default to same module name as file type
811             # - module name '' defaults to Image::ExifTool
812             # - module name '0' indicates a recognized but unsupported file
813             my %moduleName = (
814             AA => 'Audible',
815             ALIAS=> 0,
816             AVC => 0,
817             BTF => 'BigTIFF',
818             BZ2 => 0,
819             CRW => 'CanonRaw',
820             CHM => 'EXE',
821             COS => 'CaptureOne',
822             CZI => 'ZISRAW',
823             DEX => 0,
824             DOCX => 'OOXML',
825             DCX => 0,
826             DIR => 0,
827             DR4 => 'CanonVRD',
828             DSS => 'Olympus',
829             DWF => 0,
830             DWG => 0,
831             DXF => 0,
832             EPS => 'PostScript',
833             EXIF => '',
834             EXR => 'OpenEXR',
835             EXV => '',
836             ICC => 'ICC_Profile',
837             IND => 'InDesign',
838             FLV => 'Flash',
839             FPF => 'FLIR',
840             FPX => 'FlashPix',
841             GZIP => 'ZIP',
842             HDR => 'Radiance',
843             JP2 => 'Jpeg2000',
844             JPEG => '',
845             JXL => 'Jpeg2000',
846             LFP => 'Lytro',
847             LRI => 0,
848             MOV => 'QuickTime',
849             MKV => 'Matroska',
850             MP3 => 'ID3',
851             MRW => 'MinoltaRaw',
852             OGG => 'Ogg',
853             ORF => 'Olympus',
854             PDB => 'Palm',
855             PCD => 'PhotoCD',
856             PFM2 => 'Other',
857             PHP => 0,
858             PMP => 'Sony',
859             PS => 'PostScript',
860             PSD => 'Photoshop',
861             QTIF => 'QuickTime',
862             R3D => 'Red',
863             RAF => 'FujiFilm',
864             RAR => 'ZIP',
865             RAW => 'KyoceraRaw',
866             RWZ => 'Rawzor',
867             SWF => 'Flash',
868             TAR => 0,
869             TIFF => '',
870             TXT => 'Text',
871             VRD => 'CanonVRD',
872             WMF => 0,
873             X3F => 'SigmaRaw',
874             XCF => 'GIMP',
875             );
876              
877             $testLen = 1024; # number of bytes to read when testing for magic number
878              
879             # quick "magic number" file test used to avoid loading module unnecessarily:
880             # - regular expression evaluated on first $testLen bytes of file
881             # - must match beginning at first byte in file
882             # - this test must not be more stringent than module logic
883             %magicNumber = (
884             AA => '.{4}\x57\x90\x75\x36',
885             AIFF => '(FORM....AIF[FC]|AT&TFORM)',
886             ALIAS=> "book\0\0\0\0mark\0\0\0\0",
887             APE => '(MAC |APETAGEX|ID3)',
888             ASF => '\x30\x26\xb2\x75\x8e\x66\xcf\x11\xa6\xd9\x00\xaa\x00\x62\xce\x6c',
889             AVC => '\+A\+V\+C\+',
890             Torrent => 'd\d+:\w+',
891             BMP => 'BM',
892             BPG => "BPG\xfb",
893             BTF => '(II\x2b\0|MM\0\x2b)',
894             BZ2 => 'BZh[1-9]\x31\x41\x59\x26\x53\x59',
895             CHM => 'ITSF.{20}\x10\xfd\x01\x7c\xaa\x7b\xd0\x11\x9e\x0c\0\xa0\xc9\x22\xe6\xec',
896             CRW => '(II|MM).{4}HEAP(CCDR|JPGM)',
897             CZI => 'ZISRAWFILE\0{6}',
898             DCX => '\xb1\x68\xde\x3a',
899             DEX => "dex\n035\0",
900             DICOM=> '(.{128}DICM|\0[\x02\x04\x06\x08]\0[\0-\x20]|[\x02\x04\x06\x08]\0[\0-\x20]\0)',
901             DOCX => 'PK\x03\x04',
902             DPX => '(SDPX|XPDS)',
903             DR4 => 'IIII\x04\0\x04\0',
904             DSS => '(\x02dss|\x03ds2)',
905             DV => '\x1f\x07\0[\x3f\xbf]', # (not tested if extension recognized)
906             DWF => '\(DWF V\d',
907             DWG => 'AC10\d{2}\0',
908             DXF => '\s*0\s+\0?\s*SECTION\s+2\s+HEADER',
909             EPS => '(%!PS|%!Ad|\xc5\xd0\xd3\xc6)',
910             EXE => '(MZ|\xca\xfe\xba\xbe|\xfe\xed\xfa[\xce\xcf]|[\xce\xcf]\xfa\xed\xfe|Joy!peff|\x7fELF|#!\s*/\S*bin/|!\x0a)',
911             EXIF => '(II\x2a\0|MM\0\x2a)',
912             EXR => '\x76\x2f\x31\x01',
913             EXV => '\xff\x01Exiv2',
914             FITS => 'SIMPLE = {20}T',
915             FLAC => '(fLaC|ID3)',
916             FLIF => 'FLIF[0-\x6f][0-2]',
917             FLIR => '[AF]FF\0',
918             FLV => 'FLV\x01',
919             Font => '((\0\x01\0\0|OTTO|true|typ1)[\0\x01]|ttcf\0[\x01\x02]\0\0|\0[\x01\x02]|' .
920             '(.{6})?%!(PS-(AdobeFont-|Bitstream )|FontType1-)|Start(Comp|Master)?FontMetrics|wOF[F2])',
921             FPF => 'FPF Public Image Format\0',
922             FPX => '\xd0\xcf\x11\xe0\xa1\xb1\x1a\xe1',
923             GIF => 'GIF8[79]a',
924             GZIP => '\x1f\x8b\x08',
925             HDR => '#\?(RADIANCE|RGBE)\x0a',
926             HTML => '(\xef\xbb\xbf)?\s*(?i)<(!DOCTYPE\s+HTML|HTML|\?xml)', # (case insensitive)
927             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}',
928             ICO => '\0\0[\x01\x02]\0[^0]\0', # (reasonably assume that the file contains less than 256 images)
929             IND => '\x06\x06\xed\xf5\xd8\x1d\x46\xe5\xbd\x31\xef\xe7\xfe\x74\xb7\x1d',
930             # ISO => signature is at byte 32768
931             ITC => '.{4}itch',
932             JP2 => '(\0\0\0\x0cjP( |\x1a\x1a)\x0d\x0a\x87\x0a|\xff\x4f\xff\x51\0)',
933             JPEG => '\xff\xd8\xff',
934             JSON => '(\xef\xbb\xbf)?\s*(\[\s*)?\{\s*"[^"]*"\s*:',
935             JXL => '\xff\x0a|\0\0\0\x0cJXL \x0d\x0a......ftypjxl ',
936             LFP => '\x89LFP\x0d\x0a\x1a\x0a',
937             LIF => '\x70\0{3}.{4}\x2a.{4}<\0',
938             LNK => '.{4}\x01\x14\x02\0{5}\xc0\0{6}\x46',
939             LRI => 'LELR \0',
940             M2TS => '(....)?\x47',
941             MacOS=> '\0\x05\x16\x07\0.\0\0Mac OS X ',
942             MIE => '~[\x10\x18]\x04.0MIE',
943             MIFF => 'id=ImageMagick',
944             MKV => '\x1a\x45\xdf\xa3',
945             MOV => '.{4}(free|skip|wide|ftyp|pnot|PICT|pict|moov|mdat|junk|uuid)', # (duplicated in WriteQuickTime.pl !!)
946             # MP3 => difficult to rule out
947             MPC => '(MP\+|ID3)',
948             MOI => 'V6',
949             MPEG => '\0\0\x01[\xb0-\xbf]',
950             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',
951             MRW => '\0MR[MI]',
952             MXF => '\x06\x0e\x2b\x34\x02\x05\x01\x01\x0d\x01\x02', # (not tested if extension recognized)
953             OGG => '(OggS|ID3)',
954             ORF => '(II|MM)',
955             # PCD => signature is at byte 2048
956             PCX => '\x0a[\0-\x05]\x01[\x01\x02\x04\x08].{64}[\0-\x02]',
957             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)',
958             PDF => '\s*%PDF-\d+\.\d+',
959             PFM => 'P[Ff]\x0a\d+ \d+\x0a[-+0-9.]+\x0a',
960             PGF => 'PGF',
961             PHP => '<\?php\s',
962             PICT => '(.{10}|.{522})(\x11\x01|\x00\x11)',
963             PLIST=> '(bplist0|\s*<|\xfe\xff\x00)',
964             PMP => '.{8}\0{3}\x7c.{112}\xff\xd8\xff\xdb',
965             PNG => '(\x89P|\x8aM|\x8bJ)NG\r\n\x1a\n',
966             PPM => 'P[1-6]\s+',
967             PS => '(%!PS|%!Ad|\xc5\xd0\xd3\xc6)',
968             PSD => '8BPS\0[\x01\x02]',
969             PSP => 'Paint Shop Pro Image File\x0a\x1a\0{5}',
970             QTIF => '.{4}(idsc|idat|iicc)',
971             R3D => '\0\0..RED(1|2)',
972             RAF => 'FUJIFILM',
973             RAR => 'Rar!\x1a\x07\0',
974             RAW => '(.{25}ARECOYK|II|MM)',
975             Real => '(\.RMF|\.ra\xfd|pnm://|rtsp://|http://)',
976             RIFF => '(RIFF|LA0[234]|OFR |LPAC|wvpk|RF64)', # RIFF plus other variants
977             RSRC => '(....)?\0\0\x01\0',
978             RTF => '[\n\r]*\\{[\n\r]*\\\\rtf',
979             RWZ => 'rawzor',
980             SWF => '[FC]WS[^\0]',
981             TAR => '.{257}ustar( )?\0', # (this doesn't catch old-style tar files)
982             TXT => '(\xff\xfe|(\0\0)?\xfe\xff|(\xef\xbb\xbf)?[\x07-\x0d\x20-\x7e\x80-\xfe]*$)',
983             TIFF => '(II|MM)', # don't test magic number (some raw formats are different)
984             VCard=> '(?i)BEGIN:(VCARD|VCALENDAR|VNOTE)\r\n',
985             VRD => 'CANON OPTIONAL DATA\0',
986             WMF => '(\xd7\xcd\xc6\x9a\0\0|\x01\0\x09\0\0\x03)',
987             WTV => '\xb7\xd8\x00\x20\x37\x49\xda\x11\xa6\x4e\x00\x07\xe9\x5e\xad\x8d',
988             X3F => 'FOVb',
989             XCF => 'gimp xcf ',
990             XMP => '\0{0,3}(\xfe\xff|\xff\xfe|\xef\xbb\xbf)?\0{0,3}\s*<',
991             ZIP => 'PK\x03\x04',
992             );
993              
994             # file types with weak magic number recognition
995             my %weakMagic = ( MP3 => 1 );
996              
997             # file types that are determined by the process proc when FastScan == 3
998             # (when done, the process proc must exit after SetFileType if FastScan is 3)
999             my %processType = map { $_ => 1 } qw(JPEG TIFF XMP AIFF EXE Font PS Real VCard TXT);
1000              
1001             # Compact/XMPShorthand option settings
1002             my %compactOpt = (
1003             nopadding => 'NoPadding', noindent => 'NoIndent', nonewline => 'NoNewline',
1004             shorthand => 'Shorthand', onedesc => 'OneDesc',
1005             all => ['NoPadding','NoIndent','NoNewline','Shorthand','OneDesc'],
1006             allspace => ['NoPadding','NoIndent','NoNewline'], allformat => ['Shorthand','OneDesc'],
1007             # aliases to cover anticipated user typos
1008             nonewlines => 'NoNewline', nospace => 'NoIndent', nospaces => 'NoIndent',
1009             nopad => 'NoPadding', onedescr => 'OneDesc',
1010             # allow numerical settings for backward compatibility
1011             0 => 'None',
1012             1 => 'NoPadding',
1013             2 => ['NoPadding','NoIndent'],
1014             3 => ['NoPadding','NoIndent','OneDesc'],
1015             4 => ['NoPadding','NoIndent','OneDesc','NoNewline'],
1016             5 => ['NoPadding','NoIndent','OneDesc','NoNewline','Shorthand'],
1017             );
1018             my %xmpShorthandOpt = ( 0 => 'None', 1 => 'Shorthand', 2 => ['Shorthand','OneDesc'] );
1019              
1020             # lookup for valid character set names (keys are all lower case)
1021             %charsetName = (
1022             # Charset setting alias(es)
1023             # ------------------------- --------------------------------------------
1024             utf8 => 'UTF8', cp65001 => 'UTF8', 'utf-8' => 'UTF8',
1025             latin => 'Latin', cp1252 => 'Latin', latin1 => 'Latin',
1026             latin2 => 'Latin2', cp1250 => 'Latin2',
1027             cyrillic => 'Cyrillic', cp1251 => 'Cyrillic', russian => 'Cyrillic',
1028             greek => 'Greek', cp1253 => 'Greek',
1029             turkish => 'Turkish', cp1254 => 'Turkish',
1030             hebrew => 'Hebrew', cp1255 => 'Hebrew',
1031             arabic => 'Arabic', cp1256 => 'Arabic',
1032             baltic => 'Baltic', cp1257 => 'Baltic',
1033             vietnam => 'Vietnam', cp1258 => 'Vietnam',
1034             thai => 'Thai', cp874 => 'Thai',
1035             doslatinus => 'DOSLatinUS', cp437 => 'DOSLatinUS',
1036             doslatin1 => 'DOSLatin1', cp850 => 'DOSLatin1',
1037             doscyrillic => 'DOSCyrillic', cp866 => 'DOSCyrillic',
1038             macroman => 'MacRoman', cp10000 => 'MacRoman', mac => 'MacRoman', roman => 'MacRoman',
1039             maclatin2 => 'MacLatin2', cp10029 => 'MacLatin2',
1040             maccyrillic => 'MacCyrillic', cp10007 => 'MacCyrillic',
1041             macgreek => 'MacGreek', cp10006 => 'MacGreek',
1042             macturkish => 'MacTurkish', cp10081 => 'MacTurkish',
1043             macromanian => 'MacRomanian', cp10010 => 'MacRomanian',
1044             maciceland => 'MacIceland', cp10079 => 'MacIceland',
1045             maccroatian => 'MacCroatian', cp10082 => 'MacCroatian',
1046             );
1047              
1048             # default family 0 group priority for writing
1049             # (NOTE: tags in groups not specified here will not be written unless
1050             # overridden by the module or specified when writing)
1051             my @defaultWriteGroups = qw(
1052             EXIF IPTC XMP MakerNotes QuickTime Photoshop ICC_Profile CanonVRD Adobe
1053             );
1054              
1055             # group hash for ExifTool-generated tags
1056             my %allGroupsExifTool = ( 0 => 'ExifTool', 1 => 'ExifTool', 2 => 'ExifTool' );
1057              
1058             # special tag names (not used for tag info)
1059             %specialTags = map { $_ => 1 } qw(
1060             TABLE_NAME SHORT_NAME PROCESS_PROC WRITE_PROC CHECK_PROC
1061             GROUPS FORMAT FIRST_ENTRY TAG_PREFIX PRINT_CONV
1062             WRITABLE TABLE_DESC NOTES IS_OFFSET IS_SUBDIR
1063             EXTRACT_UNKNOWN NAMESPACE PREFERRED SRC_TABLE PRIORITY
1064             AVOID WRITE_GROUP LANG_INFO VARS DATAMEMBER
1065             SET_GROUP1 PERMANENT INIT_TABLE
1066             );
1067              
1068             # headers for various segment types
1069             $exifAPP1hdr = "Exif\0\0";
1070             $xmpAPP1hdr = "http://ns.adobe.com/xap/1.0/\0";
1071             $xmpExtAPP1hdr = "http://ns.adobe.com/xmp/extension/\0";
1072             $psAPP13hdr = "Photoshop 3.0\0";
1073             $psAPP13old = 'Adobe_Photoshop2.5:';
1074              
1075 761     761 0 2971 sub DummyWriteProc { return 1; }
1076              
1077             # lookup for user lenses defined in @Image::ExifTool::UserDefined::Lenses
1078             %Image::ExifTool::userLens = ( );
1079              
1080             # queued plug-in tags to add to lookup
1081             @Image::ExifTool::pluginTags = ( );
1082             %Image::ExifTool::pluginTags = ( );
1083              
1084             my %systemTagsNotes = (
1085             Notes => q{
1086             extracted only if specifically requested or the L or L API
1087             option is set
1088             },
1089             );
1090              
1091             # tag information for preview image -- this should be used for all
1092             # PreviewImage tags so they are handled properly when reading/writing
1093             %Image::ExifTool::previewImageTagInfo = (
1094             Name => 'PreviewImage',
1095             Writable => 'undef',
1096             # a value of 'none' is ok...
1097             WriteCheck => '$val eq "none" ? undef : $self->CheckImage(\$val)',
1098             DataTag => 'PreviewImage',
1099             # accept either scalar or scalar reference
1100             RawConv => '$self->ValidateImage(ref $val ? $val : \$val, $tag)',
1101             # we allow preview image to be set to '', but we don't want a zero-length value
1102             # in the IFD, so set it temporarily to 'none'. Note that the length is <= 4,
1103             # so this value will fit in the IFD so the preview fixup won't be generated.
1104             ValueConvInv => '$val eq "" and $val="none"; $val',
1105             );
1106              
1107             # extra tags that aren't truly EXIF tags, but are generated by the script
1108             # Note: any tag in this list with a name corresponding to a Group0 name is
1109             # used to write the entire corresponding directory as a block.
1110             %Image::ExifTool::Extra = (
1111             GROUPS => { 0 => 'File', 1 => 'File', 2 => 'Image' },
1112             VARS => { NO_ID => 1 }, # tag ID's aren't meaningful for these tags
1113             WRITE_PROC => \&DummyWriteProc,
1114             Error => {
1115             Priority => 0,
1116             Groups => \%allGroupsExifTool,
1117             Notes => q{
1118             returns errors that may have occurred while reading or writing a file. Any
1119             Error will prevent the file from being processed. Minor errors may be
1120             downgraded to warnings with the -m or L option
1121             },
1122             },
1123             Warning => {
1124             Priority => 0,
1125             Groups => \%allGroupsExifTool,
1126             Notes => q{
1127             returns warnings that may have occurred while reading or writing a file.
1128             Use the -a or L option to see all warnings if more than one
1129             occurred. Minor warnings may be ignored with the -m or L
1130             option. Minor warnings with a capital "M" in the "[Minor]" designation
1131             indicate that the processing is affected by ignoring the warning
1132             },
1133             },
1134             Comment => {
1135             Notes => 'comment embedded in JPEG, GIF89a or PPM/PGM/PBM image',
1136             Writable => 1,
1137             WriteGroup => 'Comment',
1138             Priority => 0, # to preserve order of JPEG COM segments
1139             },
1140             Directory => {
1141             Groups => { 1 => 'System', 2 => 'Other' },
1142             Notes => q{
1143             the directory of the file as specified in the call to ExifTool, or "." if no
1144             directory was specified. May be written to move the file to another
1145             directory that will be created if doesn't already exist
1146             },
1147             Writable => 1,
1148             WritePseudo => 1,
1149             DelCheck => q{"Can't delete"},
1150             Protected => 1,
1151             RawConv => '$self->ConvertFileName($val)',
1152             # translate backslashes in directory names and add trailing '/'
1153             ValueConvInv => '$_ = $self->InverseFileName($val); m{[^/]$} and $_ .= "/"; $_',
1154             },
1155             FileName => {
1156             Groups => { 1 => 'System', 2 => 'Other' },
1157             Writable => 1,
1158             WritePseudo => 1,
1159             DelCheck => q{"Can't delete"},
1160             Protected => 1,
1161             Notes => q{
1162             may be written with a full path name to set FileName and Directory in one
1163             operation. This is such a powerful feature that a TestName tag is provided
1164             to allow dry-run tests before actually writing the file name. See
1165             L for more information on writing the
1166             FileName, Directory and TestName tags
1167             },
1168             RawConv => '$self->ConvertFileName($val)',
1169             ValueConvInv => '$self->InverseFileName($val)',
1170             },
1171             BaseName => {
1172             Groups => { 1 => 'System', 2 => 'Other' },
1173             Notes => q{
1174             file name without extension. Not generated unless specifically requested or
1175             the API L option is set
1176             },
1177             },
1178             FilePath => {
1179             Groups => { 1 => 'System', 2 => 'Other' },
1180             Notes => q{
1181             absolute path of source file. Not generated unless specifically requested or
1182             the API L option is set. Does not support Windows Unicode file
1183             names
1184             },
1185             },
1186             TestName => {
1187             Writable => 1,
1188             WritePseudo => 1,
1189             DelCheck => q{"Can't delete"},
1190             Protected => 1,
1191             WriteOnly => 1,
1192             Notes => q{
1193             this write-only tag may be used instead of FileName for dry-run tests of the
1194             file renaming feature. Writing this tag prints the old and new file names
1195             to the console, but does not affect the file itself
1196             },
1197             ValueConvInv => '$self->InverseFileName($val)',
1198             },
1199             FileSequence => {
1200             Groups => { 0 => 'ExifTool', 1 => 'ExifTool', 2 => 'Other' },
1201             Notes => q{
1202             sequence number for each source file when extracting or copying information,
1203             including files that fail the -if condition of the command-line application,
1204             beginning at 0 for the first file. Not generated unless specifically
1205             requested or the API L option is set
1206             },
1207             },
1208             FileSize => {
1209             Groups => { 1 => 'System', 2 => 'Other' },
1210             Notes => q{
1211             note that the print conversion for this tag uses historic prefixes: 1 kB =
1212             1024 bytes, etc.
1213             },
1214             PrintConv => \&ConvertFileSize,
1215             },
1216             ResourceForkSize => {
1217             Groups => { 1 => 'System', 2 => 'Other' },
1218             Notes => q{
1219             size of the file's resource fork if it contains data. Mac OS only. If this
1220             tag is generated the L option may be used to extract
1221             resource-fork information as a sub-document. When writing, the resource
1222             fork is preserved by default, but it may be deleted with C<-rsrc:all=> on
1223             the command line
1224             },
1225             PrintConv => \&ConvertFileSize,
1226             },
1227             ZoneIdentifier => {
1228             Groups => { 1 => 'System', 2 => 'Other' },
1229             Notes => q{
1230             Windows only. Existence indicates that the file has a Zone.Identifier
1231             alternate data stream, which is used by some Windows browsers to mark
1232             downloaded files as possibly unsafe to run. May be deleted to remove this
1233             stream. Requires Win32API::File
1234             },
1235             Writable => 1,
1236             WritePseudo => 1,
1237             Protected => 1,
1238             },
1239             FileType => {
1240             Groups => { 2 => 'Other' },
1241             Notes => q{
1242             a short description of the file type. For many file types this is the just
1243             the uppercase file extension
1244             },
1245             },
1246             FileTypeExtension => {
1247             Groups => { 2 => 'Other' },
1248             Notes => q{
1249             a common lowercase extension for this file type, or uppercase with the -n
1250             option
1251             },
1252             PrintConv => 'lc $val',
1253             },
1254             FileModifyDate => {
1255             Description => 'File Modification Date/Time',
1256             Notes => q{
1257             the filesystem modification date/time. Note that ExifTool may not be able
1258             to handle filesystem dates before 1970 depending on the limitations of the
1259             system's standard libraries
1260             },
1261             Groups => { 1 => 'System', 2 => 'Time' },
1262             Writable => 1,
1263             WritePseudo => 1,
1264             DelCheck => q{"Can't delete"},
1265             # all writable pseudo-tags must be protected so -tagsfromfile fails with
1266             # unrecognized files unless a pseudo tag is specified explicitly
1267             Protected => 1,
1268             Shift => 'Time',
1269             ValueConv => 'ConvertUnixTime($val,1)',
1270             ValueConvInv => 'GetUnixTime($val,1)',
1271             PrintConv => '$self->ConvertDateTime($val)',
1272             PrintConvInv => '$self->InverseDateTime($val)',
1273             },
1274             FileAccessDate => {
1275             Description => 'File Access Date/Time',
1276             Notes => q{
1277             the date/time of last access of the file. Note that this access time is
1278             updated whenever any software, including ExifTool, reads the file
1279             },
1280             Groups => { 1 => 'System', 2 => 'Time' },
1281             ValueConv => 'ConvertUnixTime($val,1)',
1282             PrintConv => '$self->ConvertDateTime($val)',
1283             },
1284             FileCreateDate => {
1285             Description => 'File Creation Date/Time',
1286             Notes => q{
1287             the filesystem creation date/time. Windows/Mac only. In Windows, the file
1288             creation date/time is preserved by default when writing if Win32API::File
1289             and Win32::API are available. On Mac, this tag is extracted only if it or
1290             the MacOS group is specifically requested or the API L option is
1291             set to 2 or higher. Requires "setfile" for writing on Mac, which may be
1292             installed by typing C in the Terminal
1293             },
1294             Groups => { 1 => 'System', 2 => 'Time' },
1295             Writable => 1,
1296             WritePseudo => 1,
1297             DelCheck => q{"Can't delete"},
1298             Protected => 1, # all writable pseudo-tags must be protected!
1299             Shift => 'Time',
1300             ValueConv => '$^O eq "darwin" ? $val : ConvertUnixTime($val,1)',
1301             ValueConvInv => q{
1302             return GetUnixTime($val,1) if $^O eq 'MSWin32';
1303             return $val if $^O eq 'darwin';
1304             warn "This tag is Windows/Mac only\n";
1305             return undef;
1306             },
1307             PrintConv => '$self->ConvertDateTime($val)',
1308             PrintConvInv => '$self->InverseDateTime($val)',
1309             },
1310             FileInodeChangeDate => {
1311             Description => 'File Inode Change Date/Time',
1312             Notes => q{
1313             the date/time when the file's directory information was last changed.
1314             Non-Windows systems only
1315             },
1316             Groups => { 1 => 'System', 2 => 'Time' },
1317             ValueConv => 'ConvertUnixTime($val,1)',
1318             PrintConv => '$self->ConvertDateTime($val)',
1319             },
1320             FilePermissions => {
1321             Groups => { 1 => 'System', 2 => 'Other' },
1322             Notes => q{
1323             r=read, w=write and x=execute permissions for the file owner, group and
1324             others. The ValueConv value is an octal number so bit test operations on
1325             this value should be done in octal, eg. 'oct($filePermissions#) & 0200'
1326             },
1327             Writable => 1,
1328             WritePseudo => 1,
1329             DelCheck => q{"Can't delete"},
1330             Protected => 1, # all writable pseudo-tags must be protected!
1331             ValueConv => 'sprintf("%.3o", $val)',
1332             ValueConvInv => 'oct($val & 07777)',
1333             PrintConv => sub {
1334             my ($mask, $val) = (0400, oct(shift));
1335             my %types = (
1336             0010000 => 'p',
1337             0020000 => 'c',
1338             0040000 => 'd',
1339             0060000 => 'b',
1340             0120000 => 'l',
1341             0140000 => 's',
1342             );
1343             my $str = $types{$val & 0170000} || '-';
1344             while ($mask) {
1345             foreach (qw(r w x)) {
1346             $str .= $val & $mask ? $_ : '-';
1347             $mask >>= 1;
1348             }
1349             }
1350             return $str;
1351             },
1352             PrintConvInv => sub {
1353             my ($bit, $val, $str) = (8, 0, shift);
1354             $str = substr($str, 1) if length($str) == 10;
1355             return undef if length($str) != 9;
1356             while ($bit >= 0) {
1357             foreach (qw(r w x)) {
1358             $val |= (1 << $bit) if substr($str, 8-$bit, 1) eq $_;
1359             --$bit;
1360             }
1361             }
1362             return sprintf('%.3o', $val);
1363             },
1364             },
1365             FileAttributes => {
1366             Groups => { 1 => 'System', 2 => 'Other' },
1367             Notes => q{
1368             extracted only if specifically requested or the L or L API
1369             option is set. 2 or 3 values: 0. File type, 1. Attribute bits, 2. Windows
1370             attribute bits if Win32API::File is available
1371             },
1372             PrintHex => 1,
1373             PrintConvColumns => 2,
1374             PrintConv => [{ # stat device types (bitmask 0xf000)
1375             0x0000 => 'Unknown',
1376             0x1000 => 'FIFO',
1377             0x2000 => 'Character',
1378             0x3000 => 'Mux Character',
1379             0x4000 => 'Directory',
1380             0x5000 => 'XENIX Named',
1381             0x6000 => 'Block',
1382             0x7000 => 'Mux Block',
1383             0x8000 => 'Regular',
1384             0x9000 => 'VxFS Compressed',
1385             0xa000 => 'Symbolic Link',
1386             0xb000 => 'Solaris Shadow Inode',
1387             0xc000 => 'Socket',
1388             0xd000 => 'Solaris Door',
1389             0xe000 => 'BSD Whiteout',
1390             },{ BITMASK => { # stat attribute bits (bitmask 0x0e00)
1391             9 => 'Sticky',
1392             10 => 'Set Group ID',
1393             11 => 'Set User ID',
1394             }},{ BITMASK => { # Windows attribute bits
1395             0 => 'Read Only',
1396             1 => 'Hidden',
1397             2 => 'System',
1398             3 => 'Volume Label',
1399             4 => 'Directory',
1400             5 => 'Archive',
1401             6 => 'Device',
1402             7 => 'Normal',
1403             8 => 'Temporary',
1404             9 => 'Sparse File',
1405             10 => 'Reparse Point',
1406             11 => 'Compressed',
1407             12 => 'Offline',
1408             13 => 'Not Content Indexed',
1409             14 => 'Encrypted',
1410             }}],
1411             },
1412             FileDeviceID => {
1413             Groups => { 1 => 'System', 2 => 'Other' },
1414             %systemTagsNotes,
1415             PrintConv => '(($val >> 24) & 0xff) . "." . ($val & 0xffffff)', # (major.minor)
1416             },
1417             FileDeviceNumber => { Groups => { 1 => 'System', 2 => 'Other' }, %systemTagsNotes },
1418             FileInodeNumber => { Groups => { 1 => 'System', 2 => 'Other' }, %systemTagsNotes },
1419             FileHardLinks => { Groups => { 1 => 'System', 2 => 'Other' }, %systemTagsNotes },
1420             FileUserID => {
1421             Groups => { 1 => 'System', 2 => 'Other' },
1422             Notes => q{
1423             extracted only if specifically requested or the L or L API
1424             option is set. Returns user ID number with the -n option, or name
1425             otherwise. May be written with either user name or number
1426             },
1427             Writable => 1,
1428             WritePseudo => 1,
1429             DelCheck => q{"Can't delete"},
1430             Protected => 1, # all writable pseudo-tags must be protected!
1431             PrintConv => 'eval { getpwuid($val) } || $val',
1432             PrintConvInv => 'eval { getpwnam($val) } || ($val=~/[^0-9]/ ? undef : $val)',
1433             },
1434             FileGroupID => {
1435             Groups => { 1 => 'System', 2 => 'Other' },
1436             Notes => q{
1437             extracted only if specifically requested or the L or L API
1438             option is set. Returns group ID number with the -n option, or name
1439             otherwise. May be written with either group name or number
1440             },
1441             Writable => 1,
1442             WritePseudo => 1,
1443             DelCheck => q{"Can't delete"},
1444             Protected => 1, # all writable pseudo-tags must be protected!
1445             PrintConv => 'eval { getgrgid($val) } || $val',
1446             PrintConvInv => 'eval { getgrnam($val) } || ($val=~/[^0-9]/ ? undef : $val)',
1447             },
1448             FileBlockSize => { Groups => { 1 => 'System', 2 => 'Other' }, %systemTagsNotes },
1449             FileBlockCount => { Groups => { 1 => 'System', 2 => 'Other' }, %systemTagsNotes },
1450             HardLink => {
1451             Writable => 1,
1452             DelCheck => q{"Can't delete"},
1453             WriteOnly => 1,
1454             WritePseudo => 1,
1455             Protected => 1,
1456             Notes => q{
1457             this write-only tag is used to create a hard link with the specified name to
1458             the source file. If the source file is edited, copied, renamed or moved in
1459             the same operation as writing HardLink, then the link is made to the updated
1460             file. Note that subsequent editing of either hard-linked file by exiftool
1461             will break the link unless the -overwrite_original_in_place option is used
1462             },
1463             ValueConvInv => '$val=~tr/\\\\/\//; $val',
1464             },
1465             SymLink => {
1466             Writable => 1,
1467             DelCheck => q{"Can't delete"},
1468             WriteOnly => 1,
1469             WritePseudo => 1,
1470             Protected => 1,
1471             Notes => q{
1472             this write-only tag is used to create a symbolic link with the specified
1473             name to the source file. If the source file is edited, copied, renamed or
1474             moved in the same operation as writing SymLink, then the link is made to the
1475             updated file. The link uses an absolute path unless it is created in the
1476             current working directory. Valid only for file systems that support
1477             symbolic links. Note that subsequent editing of the file via the symbolic
1478             link by exiftool will cause the link to be replaced by the edited file
1479             without changing the original unless the -overwrite_original_in_place option
1480             is used
1481             },
1482             ValueConvInv => '$val=~tr/\\\\/\//; $val',
1483             },
1484             MIMEType => { Notes => 'the MIME type of the source file', Groups => { 2 => 'Other' } },
1485             ImageWidth => { Notes => 'the width of the image in number of pixels' },
1486             ImageHeight => { Notes => 'the height of the image in number of pixels' },
1487             XResolution => { Notes => 'the horizontal pixel resolution' },
1488             YResolution => { Notes => 'the vertical pixel resolution' },
1489             MaxVal => { Notes => 'maximum pixel value in PPM or PGM image' },
1490             EXIF => {
1491             Notes => q{
1492             the full EXIF data block from JPEG, PNG, JP2, MIE and MIFF images. This tag
1493             is generated only if specifically requested
1494             },
1495             Groups => { 0 => 'EXIF', 1 => 'EXIF' },
1496             Flags => ['Writable' ,'Protected', 'Binary', 'DelGroup'],
1497             WriteCheck => q{
1498             return undef if $val =~ /^(II\x2a\0|MM\0\x2a)/;
1499             return 'Invalid EXIF data';
1500             },
1501             },
1502             IPTC => {
1503             Notes => q{
1504             the full IPTC data block. This tag is generated only if specifically
1505             requested
1506             },
1507             Groups => { 0 => 'IPTC', 1 => 'IPTC' },
1508             Flags => ['Writable', 'Protected', 'Binary', 'DelGroup'],
1509             Priority => 0, # so main IPTC (which hopefully comes first) takes priority
1510             WriteCheck => q{
1511             return undef if $val =~ /^(\x1c|\0+$)/;
1512             return 'Invalid IPTC data';
1513             },
1514             },
1515             XMP => {
1516             Notes => q{
1517             the XMP data block, but note that extended XMP in JPEG images may be split
1518             into multiple blocks. This tag is generated only if specifically requested
1519             },
1520             Groups => { 0 => 'XMP', 1 => 'XMP' },
1521             Flags => ['Writable', 'Protected', 'Binary', 'DelGroup'],
1522             Priority => 0, # so main xmp (which usually comes first) takes priority
1523             WriteCheck => q{
1524             require Image::ExifTool::XMP;
1525             return Image::ExifTool::XMP::CheckXMP($self, $tagInfo, \$val);
1526             },
1527             },
1528             XML => {
1529             Notes => 'the XML data block, extracted for some file types',
1530             Groups => { 0 => 'XML', 1 => 'XML' },
1531             Binary => 1,
1532             },
1533             ICC_Profile => {
1534             Notes => q{
1535             the full ICC_Profile data block. This tag is generated only if specifically
1536             requested
1537             },
1538             Groups => { 0 => 'ICC_Profile', 1 => 'ICC_Profile' },
1539             Flags => ['Writable' ,'Protected', 'Binary', 'DelGroup'],
1540             WriteCheck => q{
1541             require Image::ExifTool::ICC_Profile;
1542             return Image::ExifTool::ICC_Profile::ValidateICC(\$val);
1543             },
1544             },
1545             CanonVRD => {
1546             Notes => q{
1547             the full Canon DPP VRD trailer block. This tag is generated only if
1548             specifically requested
1549             },
1550             Groups => { 0 => 'CanonVRD', 1 => 'CanonVRD' },
1551             Flags => ['Writable' ,'Protected', 'Binary', 'DelGroup'],
1552             Permanent => 0, # (this is 1 by default for MakerNotes tags)
1553             WriteCheck => q{
1554             return undef if $val =~ /^CANON OPTIONAL DATA\0/;
1555             return 'Invalid CanonVRD data';
1556             },
1557             },
1558             CanonDR4 => {
1559             Notes => q{
1560             the full Canon DPP version 4 DR4 block. This tag is generated only if
1561             specifically requested
1562             },
1563             Groups => { 0 => 'CanonVRD', 1 => 'CanonVRD' },
1564             Flags => ['Writable' ,'Protected', 'Binary'],
1565             Permanent => 0, # (this is 1 by default for MakerNotes tags)
1566             WriteCheck => q{
1567             return undef if $val =~ /^IIII\x04\0\x04\0/;
1568             return 'Invalid CanonDR4 data';
1569             },
1570             },
1571             Adobe => {
1572             Notes => q{
1573             the JPEG APP14 Adobe segment. Extracted only if specified. See the
1574             L for more information
1575             },
1576             Groups => { 0 => 'APP14', 1 => 'Adobe' },
1577             WriteGroup => 'Adobe',
1578             Flags => ['Writable' ,'Protected', 'Binary'],
1579             },
1580             CurrentIPTCDigest => {
1581             Notes => q{
1582             MD5 digest of existing IPTC data. All zeros if IPTC exists but Digest::MD5
1583             is not installed. Only calculated for IPTC in the standard location as
1584             specified by the L. ExifTool
1585             automates the handling of this tag in the MWG module -- see the
1586             L for details
1587             },
1588             ValueConv => 'unpack("H*", $val)',
1589             },
1590             PreviewImage => {
1591             Notes => 'JPEG-format embedded preview image',
1592             Groups => { 2 => 'Preview' },
1593             Writable => 1,
1594             WriteCheck => '$self->CheckImage(\$val)',
1595             WriteGroup => 'All',
1596             # can't delete, so set to empty string and return no error
1597             DelCheck => '$val = ""; return undef',
1598             # accept either scalar or scalar reference
1599             RawConv => '$self->ValidateImage(ref $val ? $val : \$val, $tag)',
1600             },
1601             ThumbnailImage => {
1602             Groups => { 2 => 'Preview' },
1603             Notes => 'JPEG-format embedded thumbnail image',
1604             RawConv => '$self->ValidateImage(ref $val ? $val : \$val, $tag)',
1605             },
1606             OtherImage => {
1607             Groups => { 2 => 'Preview' },
1608             Notes => 'other JPEG-format embedded image',
1609             RawConv => '$self->ValidateImage(ref $val ? $val : \$val, $tag)',
1610             },
1611             PreviewPNG => {
1612             Groups => { 2 => 'Preview' },
1613             Notes => 'PNG-format embedded preview image',
1614             Binary => 1,
1615             },
1616             PreviewWMF => {
1617             Groups => { 2 => 'Preview' },
1618             Notes => 'WMF-format embedded preview image',
1619             Binary => 1,
1620             },
1621             PreviewTIFF => {
1622             Groups => { 2 => 'Preview' },
1623             Notes => 'TIFF-format embedded preview image',
1624             Binary => 1,
1625             },
1626             PreviewPDF => {
1627             Groups => { 2 => 'Preview' },
1628             Notes => 'PDF-format embedded preview image',
1629             Binary => 1,
1630             },
1631             ExifByteOrder => {
1632             Writable => 1,
1633             DelCheck => q{"Can't delete"},
1634             Notes => q{
1635             represents the byte order of EXIF information. May be written to set the
1636             byte order only for newly created EXIF segments
1637             },
1638             PrintConv => {
1639             II => 'Little-endian (Intel, II)',
1640             MM => 'Big-endian (Motorola, MM)',
1641             },
1642             },
1643             ExifUnicodeByteOrder => {
1644             Writable => 1,
1645             WriteOnly => 1,
1646             DelCheck => q{"Can't delete"},
1647             Notes => q{
1648             specifies the byte order to use when writing EXIF Unicode text. The EXIF
1649             specification is particularly vague about this byte ordering, and different
1650             applications use different conventions. By default ExifTool writes Unicode
1651             text in EXIF byte order, but this write-only tag may be used to force a
1652             specific order. Applies to the EXIF UserComment tag when writing special
1653             characters
1654             },
1655             PrintConv => {
1656             II => 'Little-endian (Intel, II)',
1657             MM => 'Big-endian (Motorola, MM)',
1658             },
1659             },
1660             ExifToolVersion => {
1661             Description => 'ExifTool Version Number',
1662             Groups => \%allGroupsExifTool,
1663             Notes => 'the version of ExifTool currently running',
1664             },
1665             ProcessingTime => {
1666             Groups => { 0 => 'ExifTool', 1 => 'ExifTool', 2 => 'Other' },
1667             Notes => q{
1668             the clock time in seconds taken by ExifTool to extract information from this
1669             file. Not generated unless specifically requested or the L API
1670             option is set. Requires Time::HiRes
1671             },
1672             PrintConv => 'sprintf("%.3g s", $val)',
1673             },
1674             RAFVersion => { Notes => 'RAF file version number' },
1675             JPEGDigest => {
1676             Notes => q{
1677             an MD5 digest of the JPEG quantization tables is combined with the component
1678             sub-sampling values to generate the value of this tag. The result is
1679             compared to known values in an attempt to deduce the originating software
1680             based only on the JPEG image data. For performance reasons, this tag is
1681             generated only if specifically requested or the API L option is set
1682             to 3 or higher
1683             },
1684             },
1685             JPEGQualityEstimate => {
1686             Notes => q{
1687             an estimate of the IJG JPEG quality setting for the image, calculated from
1688             the quantization tables. For performance reasons, this tag is generated
1689             only if specifically requested or the API L option is set to 3 or
1690             higher
1691             },
1692             },
1693             JPEGImageLength => {
1694             Notes => q{
1695             byte length of JPEG image without metadata. For performance reasons, this
1696             tag is generated only if specifically requested or the API L option
1697             is set to 3 or higher
1698             },
1699             },
1700             # Validate (added from Validate.pm)
1701             Now => {
1702             Groups => { 0 => 'ExifTool', 1 => 'ExifTool', 2 => 'Time' },
1703             Notes => q{
1704             the current date/time. Useful when setting the tag values, eg.
1705             C<"-modifydate. Not generated unless specifically requested or the
1706             API L option is set
1707             },
1708             PrintConv => '$self->ConvertDateTime($val)',
1709             },
1710             NewGUID => {
1711             Groups => { 0 => 'ExifTool', 1 => 'ExifTool', 2 => 'Other' },
1712             Notes => q{
1713             generates a new, random GUID with format
1714             YYYYmmdd-HHMM-SSNN-PPPP-RRRRRRRRRRRR, where Y=year, m=month, d=day, H=hour,
1715             M=minute, S=second, N=file sequence number in hex, P=process ID in hex, and
1716             R=random hex number; without dashes with the -n option. Not generated
1717             unless specifically requested or the API L option is set
1718             },
1719             PrintConv => '$val =~ s/(.{8})(.{4})(.{4})(.{4})/$1-$2-$3-$4-/; $val',
1720             },
1721             ID3Size => { Notes => 'size of the ID3 data block' },
1722             Geotag => {
1723             Writable => 1,
1724             WriteOnly => 1,
1725             WriteNothing => 1,
1726             AllowGroup => '(exif|gps|xmp|xmp-exif)',
1727             Notes => q{
1728             this write-only tag is used to define the GPS track log data or track log
1729             file name. Currently supported track log formats are GPX, NMEA RMC/GGA/GLL,
1730             KML, IGC, Garmin XML and TCX, Magellan PMGNTRK, Honeywell PTNTHPR, Winplus
1731             Beacon text, and Bramor gEO log files. May be set to the special value of
1732             "DATETIMEONLY" (all caps) to set GPS date/time tags if no input track points
1733             are available. See L for details
1734             },
1735             DelCheck => q{
1736             require Image::ExifTool::Geotag;
1737             # delete associated tags
1738             Image::ExifTool::Geotag::SetGeoValues($self, undef, $wantGroup);
1739             },
1740             ValueConvInv => q{
1741             require Image::ExifTool::Geotag;
1742             # always warn because this tag is never set (warning is "\n" on success)
1743             my $result = Image::ExifTool::Geotag::LoadTrackLog($self, $val);
1744             return '' if not defined $result; # deleting geo tags
1745             return $result if ref $result; # geotag data hash reference
1746             warn "$result\n"; # error string
1747             },
1748             },
1749             Geotime => {
1750             Writable => 1,
1751             WriteOnly => 1,
1752             AllowGroup => '(exif|gps|xmp|xmp-exif)',
1753             Notes => q{
1754             this write-only tag is used to define a date/time for interpolating a
1755             position in the GPS track specified by the Geotag tag. Writing this tag
1756             causes GPS information to be written into the EXIF or XMP of the target
1757             files. The local system timezone is assumed if the date/time value does not
1758             contain a timezone. May be deleted to delete associated GPS tags. A group
1759             name of "EXIF" or "XMP" may be specified to write or delete only EXIF or XMP
1760             GPS tags
1761             },
1762             DelCheck => q{
1763             require Image::ExifTool::Geotag;
1764             # delete associated tags
1765             Image::ExifTool::Geotag::SetGeoValues($self, undef, $wantGroup);
1766             },
1767             ValueConvInv => q{
1768             require Image::ExifTool::Geotag;
1769             warn Image::ExifTool::Geotag::SetGeoValues($self, $val, $wantGroup) . "\n";
1770             return undef;
1771             },
1772             },
1773             Geosync => {
1774             Writable => 1,
1775             WriteOnly => 1,
1776             WriteNothing => 1,
1777             AllowGroup => '(exif|gps|xmp|xmp-exif)',
1778             Shift => 'Time', # enables "+=" syntax as well as "=+"
1779             Notes => q{
1780             this write-only tag specifies a time difference to add to Geotime for
1781             synchronization with the GPS clock. For example, set this to "-12" if the
1782             camera clock is 12 seconds faster than GPS time. Input format is
1783             "[+-][[[DD ]HH:]MM:]SS[.ss]". Additional features allow calculation of time
1784             differences and time drifts, and extraction of synchronization times from
1785             image files. See the L for details
1786             },
1787             ValueConvInv => q{
1788             require Image::ExifTool::Geotag;
1789             return Image::ExifTool::Geotag::ConvertGeosync($self, $val);
1790             },
1791             },
1792             ForceWrite => {
1793             Groups => { 0 => '*', 1 => '*', 2 => '*' },
1794             Writable => 1,
1795             WriteOnly => 1,
1796             Notes => q{
1797             write-only tag used to force metadata in a file to be rewritten even if no
1798             tag values are changed. May be set to "EXIF", "IPTC", "XMP" or "PNG" to
1799             force the corresponding metadata type to be rewritten, "FixBase" to cause
1800             EXIF to be rewritten only if the MakerNotes offset base was fixed, or "All"
1801             to rewrite all of these metadata types. Values are case insensitive, and
1802             multiple values may be separated with commas, eg. C<-ForceWrite=exif,xmp>
1803             },
1804             },
1805             EmbeddedVideo => { Groups => { 0 => 'Trailer', 2 => 'Video' } },
1806             Trailer => {
1807             Groups => { 0 => 'Trailer' },
1808             Notes => q{
1809             the full JPEG trailer data block. Extracted only if specifically requested
1810             or the API RequestAll option is set to 3 or higher
1811             },
1812             Writable => 1,
1813             Protected => 1,
1814             },
1815             PageCount => { Notes => 'the number of pages in a multi-page TIFF document' },
1816             SphericalVideoXML => {
1817             Groups => { 0 => 'QuickTime', 1 => 'GSpherical', 2 => 'Video' },
1818             # (group 1 is 'GSpherical' to trigger creation of this tag when writing,
1819             # but when reading the family 1 group is the track number)
1820             Flags => [ 'Writable', 'Binary', 'Protected' ],
1821             Notes => q{
1822             the SphericalVideoXML block from MP4/MOV videos. This tag is generated only
1823             if specifically requested
1824             },
1825             },
1826             ImageDataMD5 => {
1827             Notes => q{
1828             MD5 of image data. Generated only if specifically requested for JPEG and
1829             TIFF-based images, PNG, CRW, CR3, MRW, RAF, X3F and AVIF images, MOV/MP4
1830             videos, and some RIFF-based files. The MD5 includes the main image data,
1831             plus JpgFromRaw/OtherImage for some formats, but does not include
1832             ThumbnailImage or PreviewImage. Includes video and audio data for MOV/MP4.
1833             The L provides a place to
1834             store these values in the file.
1835             },
1836             },
1837             );
1838              
1839             # tags defined by UserParam option (added at runtime)
1840             %Image::ExifTool::UserParam = (
1841             GROUPS => { 0 => 'UserParam', 1 => 'UserParam', 2 => 'Other' },
1842             PRIORITY => 0,
1843             );
1844              
1845             # YCbCrSubSampling values (used by JPEG SOF, EXIF and XMP)
1846             %Image::ExifTool::JPEG::yCbCrSubSampling = (
1847             '1 1' => 'YCbCr4:4:4 (1 1)', #PH
1848             '2 1' => 'YCbCr4:2:2 (2 1)', #14 in Exif.pm
1849             '2 2' => 'YCbCr4:2:0 (2 2)', #14 in Exif.pm
1850             '4 1' => 'YCbCr4:1:1 (4 1)', #14 in Exif.pm
1851             '4 2' => 'YCbCr4:1:0 (4 2)', #PH
1852             '1 2' => 'YCbCr4:4:0 (1 2)', #PH
1853             '1 4' => 'YCbCr4:4:1 (1 4)', #JD
1854             '2 4' => 'YCbCr4:2:1 (2 4)', #JD
1855             );
1856              
1857             # define common JPEG segments here to avoid overhead of loading JPEG module
1858              
1859             # JPEG SOF (start of frame) tags
1860             # (ref http://www.w3.org/Graphics/JPEG/itu-t81.pdf)
1861             %Image::ExifTool::JPEG::SOF = (
1862             GROUPS => { 0 => 'File', 1 => 'File', 2 => 'Image' },
1863             NOTES => 'This information is extracted from the JPEG Start Of Frame segment.',
1864             VARS => { NO_ID => 1 }, # tag ID's aren't meaningful for these tags
1865             EncodingProcess => {
1866             PrintHex => 1,
1867             PrintConv => {
1868             0x0 => 'Baseline DCT, Huffman coding',
1869             0x1 => 'Extended sequential DCT, Huffman coding',
1870             0x2 => 'Progressive DCT, Huffman coding',
1871             0x3 => 'Lossless, Huffman coding',
1872             0x5 => 'Sequential DCT, differential Huffman coding',
1873             0x6 => 'Progressive DCT, differential Huffman coding',
1874             0x7 => 'Lossless, Differential Huffman coding',
1875             0x9 => 'Extended sequential DCT, arithmetic coding',
1876             0xa => 'Progressive DCT, arithmetic coding',
1877             0xb => 'Lossless, arithmetic coding',
1878             0xd => 'Sequential DCT, differential arithmetic coding',
1879             0xe => 'Progressive DCT, differential arithmetic coding',
1880             0xf => 'Lossless, differential arithmetic coding',
1881             }
1882             },
1883             BitsPerSample => { },
1884             ImageHeight => { },
1885             ImageWidth => { },
1886             ColorComponents => { },
1887             YCbCrSubSampling => {
1888             Notes => 'calculated from components table',
1889             PrintConv => \%Image::ExifTool::JPEG::yCbCrSubSampling,
1890             },
1891             );
1892              
1893             # JPEG JFIF APP0 definitions
1894             %Image::ExifTool::JFIF::Main = (
1895             PROCESS_PROC => \&Image::ExifTool::ProcessBinaryData,
1896             WRITE_PROC => \&Image::ExifTool::WriteBinaryData,
1897             CHECK_PROC => \&Image::ExifTool::CheckBinaryData,
1898             GROUPS => { 0 => 'JFIF', 1 => 'JFIF', 2 => 'Image' },
1899             DATAMEMBER => [ 2, 3, 5 ],
1900             0 => {
1901             Name => 'JFIFVersion',
1902             Format => 'int8u[2]',
1903             PrintConv => 'sprintf("%d.%.2d", split(" ",$val))',
1904             Mandatory => 1,
1905             },
1906             2 => {
1907             Name => 'ResolutionUnit',
1908             Writable => 1,
1909             RawConv => '$$self{JFIFResolutionUnit} = $val',
1910             PrintConv => {
1911             0 => 'None',
1912             1 => 'inches',
1913             2 => 'cm',
1914             },
1915             Priority => -1,
1916             Mandatory => 1,
1917             },
1918             3 => {
1919             Name => 'XResolution',
1920             Format => 'int16u',
1921             Writable => 1,
1922             Priority => -1,
1923             RawConv => '$$self{JFIFXResolution} = $val',
1924             Mandatory => 1,
1925             },
1926             5 => {
1927             Name => 'YResolution',
1928             Format => 'int16u',
1929             Writable => 1,
1930             Priority => -1,
1931             RawConv => '$$self{JFIFYResolution} = $val',
1932             Mandatory => 1,
1933             },
1934             7 => {
1935             Name => 'ThumbnailWidth',
1936             RawConv => '$val ? $$self{JFIFThumbnailWidth} = $val : undef',
1937             },
1938             8 => {
1939             Name => 'ThumbnailHeight',
1940             RawConv => '$val ? $$self{JFIFThumbnailHeight} = $val : undef',
1941             },
1942             9 => {
1943             Name => 'ThumbnailTIFF',
1944             Groups => { 2 => 'Preview' },
1945             Format => 'undef[3*($val{7}||0)*($val{8}||0)]',
1946             Notes => 'raw RGB thumbnail data, extracted as a TIFF image',
1947             RawConv => 'length($val) ? $val : undef',
1948             ValueConv => sub {
1949             my ($val, $et) = @_;
1950             my $len = length $val;
1951             return \ "Binary data $len bytes" unless $et->Options('Binary');
1952             my $img = MakeTiffHeader($$et{JFIFThumbnailWidth},$$et{JFIFThumbnailHeight},3,8) . $val;
1953             return \$img;
1954             },
1955             },
1956             );
1957             %Image::ExifTool::JFIF::Extension = (
1958             GROUPS => { 0 => 'JFIF', 1 => 'JFXX', 2 => 'Image' },
1959             NOTES => 'Thumbnail images extracted from the JFXX segment.',
1960             0x10 => {
1961             Name => 'ThumbnailImage',
1962             Groups => { 2 => 'Preview' },
1963             Notes => 'JPEG-format thumbnail image',
1964             RawConv => '$self->ValidateImage(\$val,$tag)',
1965             },
1966             0x11 => { # (untested)
1967             Name => 'ThumbnailTIFF',
1968             Groups => { 2 => 'Preview' },
1969             Notes => 'raw palette-color thumbnail data, extracted as a TIFF image',
1970             RawConv => '(length $val > 770 and $val !~ /^\0\0/) ? $val : undef',
1971             ValueConv => sub {
1972             my ($val, $et) = @_;
1973             my $len = length $val;
1974             return \ "Binary data $len bytes" unless $et->Options('Binary');
1975             my ($w, $h) = unpack('CC', $val);
1976             my $img = MakeTiffHeader($w,$h,1,8,undef,substr($val,2,768)) . substr($val,770);
1977             return \$img;
1978             },
1979             },
1980             0x13 => {
1981             Name => 'ThumbnailTIFF',
1982             Groups => { 2 => 'Preview' },
1983             Notes => 'raw RGB thumbnail data, extracted as a TIFF image',
1984             RawConv => '(length $val > 2 and $val !~ /^\0\0/) ? $val : undef',
1985             ValueConv => sub {
1986             my ($val, $et) = @_;
1987             my $len = length $val;
1988             return \ "Binary data $len bytes" unless $et->Options('Binary');
1989             my ($w, $h) = unpack('CC', $val);
1990             my $img = MakeTiffHeader($w,$h,3,8) . substr($val,2);
1991             return \$img;
1992             },
1993             },
1994             # Apple may add "AMPF" to the end of the JFIF record,
1995             # possibly indicating the existence of MPF images (ref forum12677)
1996             );
1997              
1998             # Composite tags (accumulation of all Composite tag tables)
1999             %Image::ExifTool::Composite = (
2000             GROUPS => { 0 => 'Composite', 1 => 'Composite' },
2001             TABLE_NAME => 'Image::ExifTool::Composite',
2002             SHORT_NAME => 'Composite',
2003             VARS => { NO_ID => 1 }, # want empty tagID's for Composite tags
2004             WRITE_PROC => \&DummyWriteProc,
2005             );
2006              
2007             my %compositeID; # lookup for new ID's of Composite tags based on original ID
2008              
2009             # static private ExifTool variables
2010              
2011             %allTables = ( ); # list of all tables loaded (except Composite tags)
2012             @tableOrder = ( ); # order the tables were loaded
2013              
2014             #------------------------------------------------------------------------------
2015             # Warning handler routines (warning string stored in $evalWarning)
2016             #
2017             # Set warning message
2018             # Inputs: 0) warning string (undef to reset warning)
2019 38     38 0 594 sub SetWarning($) { $evalWarning = $_[0]; }
2020              
2021             # Get warning message
2022 17     17 0 65 sub GetWarning() { return $evalWarning; }
2023              
2024             # Clean unnecessary information (line number, LF) from warning
2025             # Inputs: 0) warning string or undef to use $evalWarning
2026             # Returns: cleaned warning
2027             sub CleanWarning(;$)
2028             {
2029 223     223 0 462 my $str = shift;
2030 223 50       600 unless (defined $str) {
2031 223 50       615 return undef unless defined $evalWarning;
2032 223         389 $str = $evalWarning;
2033             }
2034 223 100       1538 $str = $1 if $str =~ /(.*) at /s;
2035 223         934 $str =~ s/\s+$//s;
2036 223         1082 return $str;
2037             }
2038              
2039             #==============================================================================
2040             # New - create new ExifTool object
2041             # Inputs: 0) reference to exiftool object or ExifTool class name
2042             # Returns: blessed ExifTool object ref
2043             sub new
2044             {
2045 490     490 1 129472 local $_;
2046 490         1529 my $that = shift;
2047 490   50     3992 my $class = ref($that) || $that || 'Image::ExifTool';
2048 490         1788 my $self = bless {}, $class;
2049              
2050             # make sure our main Exif tag table has been loaded
2051 490         2239 GetTagTable("Image::ExifTool::Exif::Main");
2052              
2053 490         3443 $self->ClearOptions(); # create default options hash
2054 490         1485 $$self{VALUE} = { }; # must initialize this for warning messages
2055 490         1710 $$self{PATH} = [ ]; # (this too)
2056 490         1588 $$self{DEL_GROUP} = { }; # lookup for groups to delete when writing
2057 490         1347 $$self{SAVE_COUNT} = 0; # count calls to SaveNewValues()
2058 490         1241 $$self{FILE_SEQUENCE} = 0; # sequence number for files when reading
2059 490         1300 $$self{FILES_WRITTEN} = 0; # count of files successfully written
2060 490         1656 $$self{INDENT2} = ''; # indentation of verbose messages from SetNewValue
2061 490         1424 $$self{ALT_EXIFTOOL} = { }; # alternate exiftool objects
2062              
2063             # initialize our new groups for writing
2064 490         2787 $self->SetNewGroups(@defaultWriteGroups);
2065              
2066 490         2286 return $self;
2067             }
2068              
2069             #------------------------------------------------------------------------------
2070             # ImageInfo - return specified information from image file
2071             # Inputs: 0) [optional] ExifTool object reference
2072             # 1) filename, file reference, or scalar data reference
2073             # 2-N) list of tag names to find (or tag list reference or options reference)
2074             # Returns: reference to hash of tag/value pairs (with "Error" entry on error)
2075             # Notes:
2076             # - if no tags names are specified, the values of all tags are returned
2077             # - tags may be specified with leading '-' to exclude, or trailing '#' for ValueConv
2078             # - can pass a reference to list of tags to find, in which case the list will
2079             # be updated with the tags found in the proper case and in the specified order.
2080             # - can pass reference to hash specifying options
2081             # - returned tag values may be scalar references indicating binary data
2082             # - see ClearOptions() below for a list of options and their default values
2083             # Examples:
2084             # use Image::ExifTool 'ImageInfo';
2085             # my $info = ImageInfo($file, 'DateTimeOriginal', 'ImageSize');
2086             # - or -
2087             # my $et = new Image::ExifTool;
2088             # my $info = $et->ImageInfo($file, \@tagList, {Sort=>'Group0'} );
2089             sub ImageInfo($;@)
2090             {
2091 517     517 1 28118 local $_;
2092             # get our ExifTool object ($self) or create one if necessary
2093 517         1278 my $self;
2094 517 100 100     5777 if (ref $_[0] and UNIVERSAL::isa($_[0],'Image::ExifTool')) {
2095 508         1625 $self = shift;
2096             } else {
2097 9         68 $self = new Image::ExifTool;
2098             }
2099 517         1109 my %saveOptions = %{$$self{OPTIONS}}; # save original options
  517         24244  
2100              
2101             # initialize file information
2102 517         4501 $$self{FILENAME} = $$self{RAF} = undef;
2103              
2104 517         3268 $self->ParseArguments(@_); # parse our function arguments
2105 517         2915 $self->ExtractInfo(undef); # extract meta information from image
2106 517         2948 my $info = $self->GetInfo(undef); # get requested information
2107              
2108 517         8107 $$self{OPTIONS} = \%saveOptions; # restore original options
2109              
2110 517         3751 return $info; # return requested information
2111             }
2112              
2113             #------------------------------------------------------------------------------
2114             # Get/set ExifTool options
2115             # Inputs: 0) ExifTool object reference,
2116             # 1) Parameter name (case insensitive), 2) Value to set the option
2117             # 3-N) More parameter/value pairs
2118             # Returns: original value of last option specified
2119             sub Options($$;@)
2120             {
2121 14652     14652 1 45436 local $_;
2122 14652         22652 my $self = shift;
2123 14652         25318 my $options = $$self{OPTIONS};
2124 14652         20938 my $oldVal;
2125              
2126 14652         33498 while (@_) {
2127 17407         29980 my $param = shift;
2128             # fix parameter case if necessary
2129 17407 100       40332 unless (exists $$options{$param}) {
2130 377         23702 my ($fixed) = grep /^$param$/i, keys %$options;
2131 377 50       2811 if ($fixed) {
2132 0         0 $param = $fixed;
2133             } else {
2134 377         1847 $param =~ s/^Group(\d*)$/Group$1/i;
2135             }
2136             }
2137 17407         29032 $oldVal = $$options{$param};
2138 17407 50 33     38541 if (ref $oldVal eq 'HASH' and ($param eq 'Compact' or $param eq 'XMPShorthand')) {
      66        
2139             # get previous Compact/XMPShorthand setting
2140 0         0 $oldVal = $$oldVal{$param};
2141             }
2142 17407 100       37357 last unless @_;
2143 4920         7729 my $newVal = shift;
2144 4920 100 66     40991 if ($param eq 'Lang') {
    100 100        
    100 66        
    100          
    100          
    100          
    100          
    100          
    100          
2145             # allow this to be set to undef to select the default language
2146 78 50       407 $newVal = $defaultLang unless defined $newVal;
2147 78 100       342 if ($newVal eq $defaultLang) {
2148 59         200 $$options{$param} = $newVal;
2149 59         241 delete $$self{CUR_LANG};
2150             # make sure the language is available
2151             } else {
2152 19         55 my %langs = map { $_ => 1 } @langs;
  361         860  
2153 19 50 33     1535 if ($langs{$newVal} and eval "require Image::ExifTool::Lang::$newVal") {
2154 19         121 my $xlat = "Image::ExifTool::Lang::${newVal}::Translate";
2155 106     106   1077 no strict 'refs';
  106         2144  
  106         461559  
2156 19 50       133 if (%$xlat) {
2157 19         101 $$self{CUR_LANG} = \%$xlat;
2158 19         235 $$options{$param} = $newVal;
2159             }
2160             }
2161             } # else don't change Lang
2162             } elsif ($param eq 'Exclude' and defined $newVal) {
2163             # clone Exclude list and expand shortcuts
2164 7         33 my @exclude;
2165 7 100       48 if (ref $newVal eq 'ARRAY') {
2166 6         30 @exclude = @$newVal;
2167             } else {
2168 1         3 @exclude = ($newVal);
2169             }
2170 7         32 ExpandShortcuts(\@exclude, 1); # (also remove '#' suffix)
2171 7         74 $$options{$param} = \@exclude;
2172             } elsif ($param =~ /^Charset/ or $param eq 'IPTCCharset') {
2173             # only allow valid character sets to be set
2174 364 100 66     1745 if ($newVal) {
    50 33        
    0          
2175 245         787 my $charset = $charsetName{lc $newVal};
2176 245 50       587 if ($charset) {
2177 245         498 $$options{$param} = $charset;
2178             # maintain backward-compatibility with old IPTCCharset option
2179 245 100       781 $$options{CharsetIPTC} = $charset if $param eq 'IPTCCharset';
2180             } else {
2181 0         0 warn "Invalid Charset $newVal\n";
2182             }
2183             } elsif ($param eq 'CharsetEXIF' or $param eq 'CharsetFileName' or $param eq 'CharsetRIFF') {
2184 119         374 $$options{$param} = $newVal; # only these may be set to a false value
2185             } elsif ($param eq 'CharsetQuickTime') {
2186 0         0 $$options{$param} = 'MacRoman'; # QuickTime defaults to MacRoman
2187             } else {
2188 0         0 $$options{$param} = 'Latin'; # all others default to Latin
2189             }
2190             } elsif ($param eq 'UserParam') {
2191             # clear options if $newVal is undef
2192 59 50       387 defined $newVal or $$options{$param} = {}, next;
2193 59         245 my $table = GetTagTable('Image::ExifTool::UserParam');
2194             # allow initialization of entire UserParam hash
2195 59 50       455 if (ref $newVal eq 'HASH') {
2196 59         150 my %newParams;
2197 59         341 foreach (sort keys %$newVal) {
2198 0         0 my $lcTag = lc $_;
2199 0         0 $newParams{$lcTag} = $$newVal{$_};
2200 0         0 delete $$table{$lcTag};
2201 0         0 AddTagToTable($table, $lcTag, $_);
2202             }
2203 59         224 $$options{$param} = \%newParams;
2204 59         218 next;
2205             }
2206 0         0 my ($force, $paramName);
2207             # set/reset single UserParam parameter
2208 0 0       0 if ($newVal =~ /(.*?)=(.*)/s) {
2209 0         0 $paramName = $1;
2210 0         0 $newVal = $2;
2211 0 0       0 $force = 1 if $paramName =~ s/\^$//;
2212 0         0 $paramName =~ tr/-_a-zA-Z0-9#//dc;
2213 0         0 $param = lc $paramName;
2214             } else {
2215 0         0 ($param = lc $newVal) =~ tr/-_a-zA-Z0-9#//dc;
2216 0         0 undef $newVal;
2217             }
2218 0         0 delete $$table{$param};
2219 0         0 $oldVal = $$options{UserParam}{$param};
2220 0 0       0 if (defined $newVal) {
2221 0 0 0     0 if (length $newVal or $force) {
2222 0         0 $$options{UserParam}{$param} = $newVal;
2223 0         0 AddTagToTable($table, $param, $paramName);
2224             } else {
2225 0         0 delete $$options{UserParam}{$param};
2226             }
2227             }
2228             # remove alternate version of tag
2229 0 0       0 $param .= '#' unless $param =~ s/#$//;
2230 0         0 delete $$table{$param};
2231 0         0 delete $$options{UserParam}{$param};
2232             } elsif ($param eq 'RequestTags') {
2233 102 100       512 if (defined $newVal) {
2234             # parse list from delimited string if necessary
2235 43 50       662 my @reqList = (ref $newVal eq 'ARRAY') ? @$newVal : ($newVal =~ /[-\w?*:]+/g);
2236 43         259 ExpandShortcuts(\@reqList);
2237             # add to existing list
2238 43 50       531 $$options{$param} or $$options{$param} = [ ];
2239 43         198 foreach (@reqList) {
2240 63 50       485 /^(.*:)?([-\w?*]*)#?$/ or next;
2241 63 50       266 push @{$$options{$param}}, lc($2) if $2;
  63         302  
2242 63 50       361 next unless $1;
2243             # add requested groups with trailing colon
2244 0         0 push @{$$options{$param}}, lc($_).':' foreach split /:/, $1;
  0         0  
2245             }
2246             } else {
2247 59         216 $$options{$param} = undef; # clear the list
2248             }
2249             } elsif ($param eq 'IgnoreTags') {
2250 59 50       343 if (defined $newVal) {
2251             # parse list from delimited string if necessary
2252 0 0       0 my @ignoreList = (ref $newVal eq 'ARRAY') ? @$newVal : ($newVal =~ /[-\w?*:]+/g);
2253 0         0 ExpandShortcuts(\@ignoreList);
2254             # add to existing tags to ignore
2255 0 0       0 $$options{$param} or $$options{$param} = { };
2256 0         0 foreach (@ignoreList) {
2257 0 0       0 /^(.*:)?([-\w?*]+)#?$/ or next;
2258 0         0 $$options{$param}{lc $2} = 1;
2259             }
2260             } else {
2261 59         298 $$options{$param} = undef; # clear the option
2262             }
2263             } elsif ($param eq 'ListJoin') {
2264 10         33 $$options{$param} = $newVal;
2265             # set the old List and ListSep options for backward compatibility
2266 10 100       42 if (defined $newVal) {
2267 4         12 $$options{List} = 0;
2268 4         18 $$options{ListSep} = $newVal;
2269             } else {
2270 6         28 $$options{List} = 1;
2271             # (ListSep must be defined)
2272             }
2273             } elsif ($param eq 'List') {
2274 78         374 $$options{$param} = $newVal;
2275             # set the new ListJoin option for forward compatibility
2276 78 50       433 $$options{ListJoin} = $newVal ? undef : $$options{ListSep};
2277             } elsif ($param eq 'Compact' or $param eq 'XMPShorthand') {
2278             # set Compact and XMPShorthand options, preserving backward compatibility
2279 1         7 my ($p, %compact);
2280 1         7 foreach $p ('Compact','XMPShorthand') {
2281 2 100       8 my $val = $param eq $p ? $newVal : $$options{Compact}{$p};
2282 2 100       7 if (defined $val) {
2283 1         8 my @v = ($val =~ /\w+/g);
2284 1 50       7 my $opt = ($p eq 'Compact') ? \%compactOpt : \%xmpShorthandOpt;
2285 1         4 foreach (@v) {
2286 1 50       7 my $set = $$opt{lc $_} or warn("Invalid $p setting '${_}'\n"), return $oldVal;
2287 1 50       7 ref $set or $compact{$set} = 1, next;
2288 0         0 $compact{$_} = 1 foreach @$set;
2289             }
2290             }
2291 2         7 $compact{$p} = $val; # preserve most recent setting
2292             }
2293 1         6 $$options{Compact} = $$options{XMPShorthand} = \%compact;
2294             } else {
2295 4162 100 66     17402 if ($param eq 'Escape') {
    100 33        
    50          
    100          
2296             # set ESCAPE_PROC
2297 65 50 66     833 if (defined $newVal and $newVal eq 'XML') {
    100 66        
2298 0         0 require Image::ExifTool::XMP;
2299 0         0 $$self{ESCAPE_PROC} = \&Image::ExifTool::XMP::EscapeXML;
2300             } elsif (defined $newVal and $newVal eq 'HTML') {
2301 5         1511 require Image::ExifTool::HTML;
2302 5         31 $$self{ESCAPE_PROC} = \&Image::ExifTool::HTML::EscapeHTML;
2303             } else {
2304 60         195 delete $$self{ESCAPE_PROC};
2305             }
2306             # must forget saved values since they depend on Escape method
2307 65         251 $$self{BOTH} = { };
2308             } elsif ($param eq 'GlobalTimeShift') {
2309 60         292 delete $$self{GLOBAL_TIME_OFFSET}; # reset our calculated offset
2310             } elsif ($param eq 'TimeZone' and defined $newVal and length $newVal) {
2311 0         0 $ENV{TZ} = $newVal;
2312 0         0 eval { require POSIX; POSIX::tzset() };
  0         0  
  0         0  
2313             } elsif ($param eq 'Validate') {
2314             # load Validate module if Validate option enabled
2315 60 100       1067 $newVal and require Image::ExifTool::Validate;
2316             }
2317 4162         10746 $$options{$param} = $newVal;
2318             }
2319             }
2320 14652         49616 return $oldVal;
2321             }
2322              
2323             #------------------------------------------------------------------------------
2324             # ClearOptions - set options to default values
2325             # Inputs: 0) ExifTool object reference
2326             sub ClearOptions($)
2327             {
2328 490     490 1 1202 local $_;
2329 490         1177 my $self = shift;
2330              
2331             # create options hash with default values
2332             # +-----------------------------------------------------+
2333             # ! DON'T FORGET!! When adding any new option, must !
2334             # ! decide how it is handled in SetNewValuesFromFile() !
2335             # +-----------------------------------------------------+
2336             # (Note: All options must exist in this lookup, even if undefined,
2337             # to facilitate case-insensitive options. 'Group#' is handled specially)
2338             $$self{OPTIONS} = {
2339 490         43199 Binary => undef, # flag to extract binary values even if tag not specified
2340             ByteOrder => undef, # default byte order when creating EXIF information
2341             Charset => 'UTF8', # character set for converting Unicode characters
2342             CharsetEXIF => undef, # internal EXIF "ASCII" string encoding
2343             CharsetFileName => undef, # external encoding for file names
2344             CharsetID3 => 'Latin', # internal ID3v1 character set
2345             CharsetIPTC => 'Latin', # fallback IPTC character set if no CodedCharacterSet
2346             CharsetPhotoshop => 'Latin', # internal encoding for Photoshop resource names
2347             CharsetQuickTime => 'MacRoman', # internal QuickTime string encoding
2348             CharsetRIFF => 0, # internal RIFF string encoding (0=default to Latin)
2349             Compact => { }, # write compact XMP
2350             Composite => 1, # flag to calculate Composite tags
2351             Compress => undef, # flag to write new values as compressed if possible
2352             CoordFormat => undef, # GPS lat/long coordinate format
2353             DateFormat => undef, # format for date/time
2354             Duplicates => 1, # flag to save duplicate tag values
2355             Escape => undef, # escape special characters
2356             Exclude => undef, # tags to exclude
2357             ExtendedXMP => 1, # strategy for reading extended XMP
2358             ExtractEmbedded =>undef,# flag to extract information from embedded documents
2359             FastScan => undef, # flag to avoid scanning for trailer
2360             Filter => undef, # output filter for all tag values
2361             FilterW => undef, # input filter when writing tag values
2362             FixBase => undef, # fix maker notes base offsets
2363             GeoMaxIntSecs => 1800, # geotag maximum interpolation time (secs)
2364             GeoMaxExtSecs => 1800, # geotag maximum extrapolation time (secs)
2365             GeoMaxHDOP => undef, # geotag maximum HDOP
2366             GeoMaxPDOP => undef, # geotag maximum PDOP
2367             GeoMinSats => undef, # geotag minimum satellites
2368             GeoSpeedRef => undef, # geotag GPSSpeedRef
2369             GlobalTimeShift => undef, # apply time shift to all extracted date/time values
2370             # Group# => undef, # return tags for specified groups in family #
2371             HexTagIDs => 0, # use hex tag ID's in family 7 group names
2372             HtmlDump => 0, # HTML dump (0-3, higher # = bigger limit)
2373             HtmlDumpBase => undef, # base address for HTML dump
2374             IgnoreMinorErrors => undef, # ignore minor errors when reading/writing
2375             IgnoreTags => undef, # list of tags to ignore when extracting
2376             Lang => $defaultLang,# localized language for descriptions etc
2377             LargeFileSupport => undef, # flag indicating support of 64-bit file offsets
2378             List => undef, # extract lists of PrintConv values into arrays [no longer documented]
2379             ListItem => undef, # used to return a specific item from lists
2380             ListJoin => ', ', # join lists together with this separator
2381             ListSep => ', ', # list item separator [no longer documented]
2382             ListSplit => undef, # regex for splitting list-type tag values when writing
2383             MakerNotes => undef, # extract maker notes as a block
2384             MDItemTags => undef, # extract MacOS metadata item tags
2385             MissingTagValue =>undef,# value for missing tags when expanded in expressions
2386             NoMultiExif => undef, # raise error when writing multi-segment EXIF
2387             NoPDFList => undef, # flag to avoid splitting PDF List-type tag values
2388             Password => undef, # password for password-protected PDF documents
2389             PrintConv => 1, # flag to enable print conversion
2390             QuickTimeHandler => 1, # flag to add mdir Handler to newly created Meta box
2391             QuickTimePad=> undef, # flag to preserve padding of QuickTime CR3 tags
2392             QuickTimeUTC=> undef, # assume that QuickTime date/time tags are stored as UTC
2393             RequestAll => undef, # extract all tags that must be specifically requested
2394             RequestTags => undef, # extra tags to request (on top of those in the tag list)
2395             SaveFormat => undef, # save family 6 tag TIFF format
2396             SavePath => undef, # save family 5 location path
2397             ScanForXMP => undef, # flag to scan for XMP information in all files
2398             Sort => 'Input', # order to sort found tags (Input, File, Tag, Descr, Group#)
2399             Sort2 => 'File', # secondary sort order for tags in a group (File, Tag, Descr)
2400             StrictDate => undef, # flag to return undef for invalid date conversions
2401             Struct => undef, # return structures as hash references
2402             SystemTags => undef, # extract additional File System tags
2403             TextOut => \*STDOUT,# file for Verbose/HtmlDump output
2404             TimeZone => undef, # local time zone
2405             Unknown => 0, # flag to get values of unknown tags (0-2)
2406             UserParam => { }, # user parameters for additional user-defined tag values
2407             Validate => undef, # perform additional validation
2408             Verbose => 0, # print verbose messages (0-5, higher # = more verbose)
2409             WriteMode => 'wcg', # enable all write modes by default
2410             XAttrTags => undef, # extract MacOS extended attribute tags
2411             XMPAutoConv => 1, # automatic conversion of unknown XMP tag values
2412             XMPShorthand=> 0, # (unused, but needed for backward compatibility)
2413             };
2414             # keep necessary member variables in sync with options
2415 490         1922 delete $$self{CUR_LANG};
2416 490         1149 delete $$self{ESCAPE_PROC};
2417              
2418             # load user-defined default options
2419 490 50       2412 if (%Image::ExifTool::UserDefined::Options) {
2420 0         0 foreach (keys %Image::ExifTool::UserDefined::Options) {
2421 0         0 $self->Options($_, $Image::ExifTool::UserDefined::Options{$_});
2422             }
2423             }
2424             }
2425              
2426             #------------------------------------------------------------------------------
2427             # Extract meta information from image
2428             # Inputs: 0) ExifTool object reference
2429             # 1-N) Same as ImageInfo()
2430             # Returns: 1 if this was a valid image, 0 otherwise
2431             # Notes: pass an undefined value to avoid parsing arguments
2432             # Internal 'ReEntry' option allows this routine to be called recursively
2433             sub ExtractInfo($;@)
2434             {
2435 530     530 1 1501 local $_;
2436 530         1165 my $self = shift;
2437 530         1424 my $options = $$self{OPTIONS}; # pointer to current options
2438 530   100     3036 my $fast = $$options{FastScan} || 0;
2439 530         1629 my $req = $$self{REQ_TAG_LOOKUP};
2440 530   100     2765 my $reqAll = $$options{RequestAll} || 0;
2441 530         1902 my (%saveOptions, $reEntry, $rsize, $zid, $type, @startTime, $saveOrder, $isDir);
2442              
2443             # check for internal ReEntry option to allow recursive calls to ExtractInfo
2444 530 100 100     2988 if (ref $_[1] eq 'HASH' and $_[1]{ReEntry} and
      33        
      66        
2445             (ref $_[0] eq 'SCALAR' or ref $_[0] eq 'GLOB'))
2446             {
2447             # save necessary members for restoring later
2448             $reEntry = {
2449             RAF => $$self{RAF},
2450             PROCESSED => $$self{PROCESSED},
2451             EXIF_DATA => $$self{EXIF_DATA},
2452             EXIF_POS => $$self{EXIF_POS},
2453             FILE_TYPE => $$self{FILE_TYPE},
2454 2         21 };
2455             $saveOrder = GetByteOrder(),
2456 2         925 $$self{RAF} = new File::RandomAccess($_[0]);
2457 2         146 $$self{PROCESSED} = { };
2458 2         7 delete $$self{EXIF_DATA};
2459 2         5 delete $$self{EXIF_POS};
2460             } else {
2461 528 100 66     5117 if (defined $_[0] or $$options{HtmlDump} or $$req{validate}) {
      66        
2462 12         770 %saveOptions = %$options; # save original options
2463              
2464             # require duplicates for html dump
2465 12 50       123 $self->Options(Duplicates => 1) if $$options{HtmlDump};
2466             # enable Validate option if Validate tag is requested
2467 12 100       63 $self->Options(Validate => 1) if $$req{validate};
2468              
2469 12 100       52 if (defined $_[0]) {
2470             # only initialize filename if called with arguments
2471 11         41 $$self{FILENAME} = undef; # name of file (or '' if we didn't open it)
2472 11         33 $$self{RAF} = undef; # RandomAccess object reference
2473              
2474 11         61 $self->ParseArguments(@_); # initialize from our arguments
2475             }
2476             }
2477             # initialize ExifTool object members
2478 528         2917 $self->Init();
2479              
2480 528         1662 delete $$self{MAKER_NOTE_FIXUP}; # fixup information for extracted maker notes
2481 528         1272 delete $$self{MAKER_NOTE_BYTE_ORDER};
2482              
2483             # return our version number
2484 528         3764 $self->FoundTag('ExifToolVersion', "$VERSION$RELEASE");
2485 528 100 66     4288 $self->FoundTag('Now', $self->TimeNow()) if $$req{now} or $reqAll;
2486 528 100 66     3858 $self->FoundTag('NewGUID', NewGUID()) if $$req{newguid} or $reqAll;
2487             # generate sequence number if necessary
2488 528 100 66     3390 $self->FoundTag('FileSequence', $$self{FILE_SEQUENCE}) if $$req{filesequence} or $reqAll;
2489              
2490 528 100 66     3309 if ($$req{processingtime} or $reqAll) {
2491 61         191 eval { require Time::HiRes; @startTime = Time::HiRes::gettimeofday() };
  61         9971  
  61         24013  
2492 61 0 33     343 if (not @startTime and $$req{processingtime}) {
2493 0         0 $self->WarnOnce('Install Time::HiRes to generate ProcessingTime');
2494             }
2495             }
2496            
2497             # create MD5 object if ImageDataMD5 is requested
2498 528 50 33     2451 if ($$req{imagedatamd5} and not $$self{ImageDataMD5}) {
2499 0 0       0 if (require Digest::MD5) {
2500 0         0 $$self{ImageDataMD5} = Digest::MD5->new;
2501             } else {
2502 0         0 $self->WarnOnce('Install Digest::MD5 to calculate image data MD5');
2503             }
2504             }
2505 528         1287 ++$$self{FILE_SEQUENCE}; # count files read
2506             # extract information from alternate files if necessary
2507 528         1314 my ($g8, $altExifTool);
2508 528         1161 foreach $g8 (keys %{$$self{ALT_EXIFTOOL}}) {
  528         2587  
2509 8         31 $altExifTool = $$self{ALT_EXIFTOOL}{$g8};
2510 8 100       37 next if $$altExifTool{DID_EXTRACT}; # avoid extracting twice
2511 6         90 $$altExifTool{OPTIONS} = $$self{OPTIONS};
2512 6         19 $$altExifTool{GLOBAL_TIME_OFFSET} = $$self{GLOBAL_TIME_OFFSET};
2513 6         16 $$altExifTool{REQ_TAG_LOOKUP} = $$self{REQ_TAG_LOOKUP};
2514 6         62 $altExifTool->ExtractInfo($$altExifTool{ALT_FILE});
2515             # set family 8 group name for all tags
2516 6         19 foreach (keys %{$$altExifTool{VALUE}}) {
  6         148  
2517 570         867 my $ex = $$altExifTool{TAG_EXTRA}{$_};
2518 570 100       1199 $ex or $ex = $$altExifTool{TAG_EXTRA}{$_} = { };
2519 570         1169 $$ex{G8} = $g8;
2520             }
2521 6         60 $$altExifTool{DID_EXTRACT} = 1;
2522             }
2523             }
2524              
2525 530         1802 my $filename = $$self{FILENAME}; # image file name ('' if already open)
2526 530         1340 my $raf = $$self{RAF}; # RandomAccess object
2527              
2528 530         1938 local *EXIFTOOL_FILE; # avoid clashes with global namespace
2529              
2530 530         1298 my $realname = $filename;
2531 530 100       1822 unless ($raf) {
2532             # save file name
2533 486 50 33     3200 if (defined $filename and $filename ne '') {
2534 486 50       1929 unless ($filename eq '-') {
2535             # extract file name from pipe if necessary
2536 486 50       2268 $realname =~ /\|$/ and $realname =~ s/^.*?"(.*?)".*/$1/s;
2537 486         2321 my ($dir, $name) = SplitFileName($realname);
2538 486         2230 $self->FoundTag('FileName', $name);
2539 486 100 66     5425 if ($$req{basename} or
      66        
2540             ($reqAll and not $$self{EXCL_TAG_LOOKUP}{basename}))
2541             {
2542 61 50       707 $self->FoundTag('BaseName', $name =~ /(.*)\./ ? $1 : $name);
2543             }
2544 486 50 33     4726 $self->FoundTag('Directory', $dir) if defined $dir and length $dir;
2545 486 100 66     5479 if ($$req{filepath} or
      66        
2546             ($reqAll and not $$self{EXCL_TAG_LOOKUP}{filepath}))
2547             {
2548 61         428 local $SIG{'__WARN__'} = \&SetWarning;
2549 61 50       223 if (eval { require Cwd }) {
  61 0       529  
2550 61         211 my $path = eval { Cwd::abs_path($filename) };
  61         3226  
2551 61 50       552 $self->FoundTag('FilePath', $path) if defined $path;
2552             } elsif ($$req{filepath}) {
2553 0         0 $self->WarnOnce('The Perl Cwd module must be installed to use FilePath');
2554             }
2555             }
2556             # get size of resource fork on Mac OS
2557 486 50 33     3208 $rsize = -s "$filename/..namedfork/rsrc" if $^O eq 'darwin' and not $$self{IN_RESOURCE};
2558             # check to see if Zone.Identifier file exists in Windows
2559 486 50 33     2554 if ($^O eq 'MSWin32' and eval { require Win32API::File }) {
  0         0  
2560 0         0 my $wattr;
2561 0         0 my $zfile = "${filename}:Zone.Identifier";
2562 0 0       0 if ($self->EncodeFileName($zfile)) {
2563 0         0 $wattr = eval { Win32API::File::GetFileAttributesW($zfile) };
  0         0  
2564             } else {
2565 0         0 $wattr = eval { Win32API::File::GetFileAttributes($zfile) };
  0         0  
2566             }
2567 0 0       0 $zid = 1 unless $wattr == Win32API::File::INVALID_FILE_ATTRIBUTES();
2568             }
2569             }
2570             # open the file
2571 486 50       2747 if ($self->Open(\*EXIFTOOL_FILE, $filename)) {
    0          
2572             # create random access file object
2573 486         6415 $raf = new File::RandomAccess(\*EXIFTOOL_FILE);
2574             # patch to force pipe to be buffered because seek returns success
2575             # in Windows cmd shell pipe even though it really failed
2576 486 50 33     4415 $$raf{TESTED} = -1 if $filename eq '-' or $filename =~ /\|$/;
2577 486         1657 $$self{RAF} = $raf;
2578             } elsif ($self->IsDirectory($filename)) {
2579 0         0 $isDir = 1;
2580             } else {
2581 0         0 $self->Error('Error opening file');
2582             }
2583             } else {
2584 0         0 $self->Error('No file specified');
2585             }
2586             }
2587              
2588 530   33     2967 while ($raf or $isDir) {
2589 530         1489 my (@stat, $plainFile);
2590 530 100       9198 if ($reEntry) {
    50          
    100          
    50          
2591             # we already set these tags
2592             } elsif (not $raf) {
2593 0         0 @stat = stat $filename;
2594             } elsif (not $$raf{FILE_PT}) {
2595             # get file size from image in memory
2596 22         79 $self->FoundTag('FileSize', length ${$$raf{BUFF_PT}});
  22         110  
2597             } elsif (-f $$raf{FILE_PT}) {
2598             # get file tags if this is a plain file
2599 506         3113 @stat = stat _;
2600 506         1391 $plainFile = 1;
2601             # hack to patch Windows daylight savings time bug
2602 506 50       2592 @stat[8,9,10] = $self->GetFileTime($$raf{FILE_PT}) if $^O eq 'MSWin32';
2603             } else {
2604             # (note that Windows directories will still show the
2605             # daylight savings time bug -- should fix this sometime)
2606 0         0 @stat = stat $$raf{FILE_PT};
2607             }
2608 530         1434 my $fileSize = $stat[7];
2609 530 100       3523 $self->FoundTag('FileSize', $stat[7]) if defined $stat[7];
2610 530 50       2786 $self->FoundTag('ResourceForkSize', $rsize) if $rsize;
2611 530 50       2825 $self->FoundTag('ZoneIdentifier', 'Exists') if $zid;
2612 530 100       2936 $self->FoundTag('FileModifyDate', $stat[9]) if defined $stat[9];
2613 530 100       3874 $self->FoundTag('FileAccessDate', $stat[8]) if defined $stat[8];
2614 530 50       3601 my $cTag = $^O eq 'MSWin32' ? 'FileCreateDate' : 'FileInodeChangeDate';
2615 530 100       4046 $self->FoundTag($cTag, $stat[10]) if defined $stat[10];
2616 530 100       4107 $self->FoundTag('FilePermissions', $stat[2]) if defined $stat[2];
2617             # extract more system info if SystemTags option is set
2618 530 100       3771 if (@stat) {
2619 506   66     4111 my $sys = $$options{SystemTags} || ($reqAll and not defined $$options{SystemTags});
2620 506 100 66     3499 if ($sys or $$req{fileattributes}) {
2621 61         294 my @attr = ($stat[2] & 0xf000, $stat[2] & 0x0e00);
2622             # add Windows file attributes if available
2623 61 0 33     412 if ($^O eq 'MSWin32' and defined $filename and $filename ne '' and $filename ne '-') {
      33        
      0        
2624 0         0 local $SIG{'__WARN__'} = \&SetWarning;
2625 0 0       0 if (eval { require Win32API::File }) {
  0         0  
2626 0         0 my $wattr;
2627 0         0 my $file = $filename;
2628 0 0       0 if ($self->EncodeFileName($file)) {
2629 0         0 $wattr = eval { Win32API::File::GetFileAttributesW($file) };
  0         0  
2630             } else {
2631 0         0 $wattr = eval { Win32API::File::GetFileAttributes($file) };
  0         0  
2632             }
2633 0 0 0     0 push @attr, $wattr if defined $wattr and $wattr != 0xffffffff;
2634             }
2635             }
2636 61         443 $self->FoundTag('FileAttributes', "@attr");
2637             }
2638 506 100 66     3277 $self->FoundTag('FileDeviceNumber', $stat[0]) if $sys or $$req{filedevicenumber};
2639 506 100 66     3300 $self->FoundTag('FileInodeNumber', $stat[1]) if $sys or $$req{fileinodenumber};
2640 506 100 66     3482 $self->FoundTag('FileHardLinks', $stat[3]) if $sys or $$req{filehardlinks};
2641 506 100 66     4137 $self->FoundTag('FileUserID', $stat[4]) if $sys or $$req{fileuserid};
2642 506 100 66     3514 $self->FoundTag('FileGroupID', $stat[5]) if $sys or $$req{filegroupid};
2643 506 100 66     3108 $self->FoundTag('FileDeviceID', $stat[6]) if $sys or $$req{filedeviceid};
2644 506 100 66     3093 $self->FoundTag('FileBlockSize', $stat[11]) if $sys or $$req{fileblocksize};
2645 506 100 66     3111 $self->FoundTag('FileBlockCount', $stat[12]) if $sys or $$req{fileblockcount};
2646             }
2647             # extract MDItem tags if requested (only on plain files)
2648 530 0 33     2766 if ($^O eq 'darwin' and defined $filename and $filename ne '' and defined $fileSize) {
      33        
      0        
2649 0   0     0 my $reqMacOS = ($reqAll > 1 or $$req{'macos:'});
2650 0   0     0 my $crDate = ($reqMacOS || $$req{filecreatedate});
2651 0   0     0 my $mdItem = ($reqMacOS || $$options{MDItemTags} || grep /^mditem/, keys %$req);
2652 0   0     0 my $xattr = ($reqMacOS || $$options{XAttrTags} || grep /^xattr/, keys %$req);
2653 0 0 0     0 if ($crDate or $mdItem or $xattr) {
      0        
2654 0         0 require Image::ExifTool::MacOS;
2655 0 0       0 Image::ExifTool::MacOS::GetFileCreateDate($self, $filename) if $crDate;
2656 0 0 0     0 Image::ExifTool::MacOS::ExtractMDItemTags($self, $filename) if $mdItem and $plainFile;
2657 0 0       0 Image::ExifTool::MacOS::ExtractXAttrTags($self, $filename) if $xattr;
2658             }
2659             }
2660             # do whatever else we can with directories, then return
2661 530 50 66     5374 if ($isDir or (defined $stat[2] and ($stat[2] & 0170000) == 0040000)) {
      33        
2662 0         0 $self->FoundTag('FileType', 'DIR');
2663 0         0 $self->FoundTag('FileTypeExtension', '');
2664 0 0       0 $self->BuildCompositeTags() if $$options{Composite};
2665 0 0       0 $raf->Close() if $raf;
2666 0         0 return 1;
2667             }
2668             # get list of file types to check
2669 530         1413 my ($tiffType, %noMagic, $recognizedExt);
2670 530         2059 my $ext = $$self{FILE_EXT} = GetFileExtension($realname);
2671             # set $recognizedExt if this file type is recognized by extension only
2672             $recognizedExt = $ext if defined $ext and not defined $magicNumber{$ext} and
2673 530 50 100     6227 defined $moduleName{$ext} and not $moduleName{$ext};
      100        
      66        
2674 530         3381 my @fileTypeList = GetFileType($realname);
2675 530 50       2260 if ($fast >= 4) {
2676 0 0       0 if (@fileTypeList) {
2677 0         0 $type = shift @fileTypeList;
2678 0         0 $self->SetFileType($$self{FILE_TYPE} = $type);
2679             } else {
2680 0         0 $self->Error('Unknown file type');
2681             }
2682 0 0 0     0 $self->BuildCompositeTags() if $fast == 4 and $$options{Composite};
2683 0         0 last; # don't read the file
2684             }
2685 530 100       1888 if (@fileTypeList) {
2686             # add remaining types to end of list so we test them all
2687 483         1916 my $pat = join '|', @fileTypeList;
2688 483         43410 push @fileTypeList, grep(!/^($pat)$/, @fileTypes);
2689 483         2113 $tiffType = $$self{FILE_EXT};
2690 483 100       2083 unless ($fast == 3) {
2691 482         1679 $noMagic{MXF} = 1; # don't do magic number test on MXF or DV files
2692 482         1693 $noMagic{DV} = 1;
2693             }
2694             } else {
2695             # scan through all recognized file types
2696 47         938 @fileTypeList = @fileTypes;
2697 47         152 $tiffType = 'TIFF';
2698             }
2699 530         1690 push @fileTypeList, ''; # end of list marker
2700             # initialize the input file for seeking in binary data
2701 530         3462 $raf->BinMode(); # set binary mode before we start reading
2702 530         2216 my $pos = $raf->Tell(); # get file position so we can rewind
2703             # loop through list of file types to test
2704 530         1548 my ($buff, $seekErr);
2705 530         3224 my %dirInfo = ( RAF => $raf, Base => $pos, TestBuff => \$buff );
2706             # read start of file for testing
2707 530 50       2713 $raf->Read($buff, $testLen) or $buff = '';
2708 530 50       3326 $raf->Seek($pos, 0) or $seekErr = 1;
2709 530         2968 until ($seekErr) {
2710 1925         3620 my $unkHeader;
2711 1925         3604 $type = shift @fileTypeList;
2712 1925 50       4191 if ($type) {
    0          
    0          
2713 1925 100       5747 if ($magicNumber{$type}) {
2714             # do quick test for this file type to avoid loading module unnecessarily
2715 1889 100 100     39532 next if $buff !~ /^$magicNumber{$type}/s and not $noMagic{$type};
2716             } else {
2717             # keep checking for other types if we recognize this file only by extension
2718 36 50 66     301 next if defined $moduleName{$type} and not $moduleName{$type};
2719 36 50       136 next if $fast > 2; # keep checking if we aren't processing the file
2720             }
2721 570 50 66     3306 next if $weakMagic{$type} and defined $recognizedExt;
2722             } elsif (not defined $type) {
2723 0         0 last;
2724             } elsif ($recognizedExt) {
2725 0         0 $type = $recognizedExt; # set type from recognized file extension only
2726             } else {
2727             # last ditch effort to scan past unknown header for JPEG/TIFF
2728 0 0       0 next unless $buff =~ /(\xff\xd8\xff|MM\0\x2a|II\x2a\0)/g;
2729 0 0       0 $type = ($1 eq "\xff\xd8\xff") ? 'JPEG' : 'TIFF';
2730 0         0 my $skip = pos($buff) - length($1);
2731 0         0 $dirInfo{Base} = $pos + $skip;
2732 0 0       0 $raf->Seek($pos + $skip, 0) or $seekErr = 1, last;
2733 0         0 $self->Warn("Processing $type-like data after unknown $skip-byte header");
2734 0 0       0 $unkHeader = 1 unless $$self{DOC_NUM};
2735             }
2736             # save file type in member variable
2737 570         2839 $$self{FILE_TYPE} = $type;
2738 570 100       2746 $dirInfo{Parent} = ($type eq 'TIFF') ? $tiffType : $type;
2739             # don't process the file when FastScan == 3
2740 570 50 66     2614 if ($fast == 3 and not $processType{$type}) {
2741 0 0 0     0 unless ($weakMagic{$type} and (not $ext or $ext ne $type)) {
      0        
2742 0         0 $self->SetFileType($dirInfo{Parent});
2743             }
2744 0         0 last;
2745             }
2746 570         1492 my $module = $moduleName{$type};
2747 570 100       1836 $module = $type unless defined $module;
2748 570         1756 my $func = "Process$type";
2749              
2750             # load module if necessary
2751 570 100       2189 if ($module) {
    50          
2752 305         24530 require "Image/ExifTool/$module.pm";
2753 305         1277 $func = "Image::ExifTool::${module}::$func";
2754             } elsif ($module eq '0') {
2755 0         0 $self->SetFileType();
2756 0         0 $self->Warn('Unsupported file type');
2757 0         0 last;
2758             }
2759 570         1168 push @{$$self{PATH}}, $type; # save file type in metadata PATH
  570         2244  
2760              
2761             # process the file
2762 106     106   1007 no strict 'refs';
  106         1993  
  106         5554  
2763 570         5540 my $result = &$func($self, \%dirInfo);
2764 106     106   705 use strict 'refs';
  106         261  
  106         1613268  
2765              
2766 570         1522 pop @{$$self{PATH}};
  570         1964  
2767              
2768 570 100       2051 if ($result) { # all done if successful
2769 530 50       1935 if ($unkHeader) {
2770 0         0 $self->DeleteTag('FileType');
2771 0         0 $self->DeleteTag('FileTypeExtension');
2772 0         0 $self->DeleteTag('MIMEType');
2773 0         0 $self->VPrint(0,"Reset file type due to unknown header\n");
2774             }
2775 530         1746 last;
2776             }
2777             # seek back to try again from the same position in the file
2778 40 50       140 $raf->Seek($pos, 0) or $seekErr = 1, last;
2779             }
2780 530 0 33     2024 if (not defined $type and not $$self{DOC_NUM}) {
2781             # if we were given a single image with a known type there
2782             # must be a format error since we couldn't read it, otherwise
2783             # it is likely we don't support images of this type
2784 0   0     0 my $fileType = GetFileType($realname) || '';
2785 0         0 my $err;
2786 0 0       0 if (not length $buff) {
2787 0         0 $err = 'File is empty';
2788             } else {
2789 0         0 my $ch = substr($buff, 0, 1);
2790 0 0 0     0 if (length $buff < 16 or $buff =~ /[^\Q$ch\E]/) {
2791 0 0       0 if ($fileType eq 'RAW') {
    0          
2792 0         0 $err = 'Unsupported RAW file type';
2793             } elsif ($fileType) {
2794 0         0 $err = 'File format error';
2795             } else {
2796 0         0 $err = 'Unknown file type';
2797             }
2798             } else {
2799             # provide some insight into the content of some corrupted files
2800 0 0       0 if ($$self{OPTIONS}{FastScan}) {
2801 0         0 $err = 'File header is all';
2802             } else {
2803 0         0 my $num = 0;
2804 0         0 for (;;) {
2805 0 0       0 $raf->Read($buff, 65536) or undef($num), last;
2806 0 0       0 $buff =~ /[^\Q$ch\E]/g and $num += pos($buff) - 1, last;
2807 0         0 $num += length($buff);
2808             }
2809 0 0       0 if ($num) {
2810 0         0 $err = 'First ' . ConvertFileSize($num) . ' of file is';
2811             } else {
2812 0         0 $err = 'Entire file is';
2813             }
2814             }
2815 0 0       0 if ($ch eq "\0") {
    0          
    0          
2816 0         0 $err .= ' binary zeros';
2817             } elsif ($ch eq ' ') {
2818 0         0 $err .= ' ASCII spaces';
2819             } elsif ($ch =~ /[a-zA-Z0-9]/) {
2820 0         0 $err .= " ASCII '${ch}' characters";
2821             } else {
2822 0         0 $err .= sprintf(" binary 0x%.2x's", ord $ch);
2823             }
2824             }
2825             }
2826 0         0 $self->Error($err);
2827             }
2828 530 50 0     2823 if ($seekErr) {
    50 33        
2829 0         0 $self->Error('Error seeking in file');
2830             } elsif ($self->Options('ScanForXMP') and (not defined $type or
2831             (not $fast and not $$self{FoundXMP})))
2832             {
2833             # scan for XMP
2834 0         0 $raf->Seek($pos, 0);
2835 0         0 require Image::ExifTool::XMP;
2836 0 0       0 Image::ExifTool::XMP::ScanForXMP($self, $raf) and $type = '';
2837             }
2838             # extract binary EXIF data block only if requested
2839 530 100 100     6805 if (defined $$self{EXIF_DATA} and length $$self{EXIF_DATA} > 16 and
      100        
      100        
2840             ($$req{exif} or
2841             # (not extracted normally, so check TAGS_FROM_FILE)
2842             ($$self{TAGS_FROM_FILE} and not $$self{EXCL_TAG_LOOKUP}{exif})))
2843             {
2844 37         166 $self->FoundTag('EXIF', $$self{EXIF_DATA});
2845             }
2846 530 100       2080 unless ($reEntry) {
2847 528         2194 $$self{PATH} = [ ]; # reset PATH
2848             # calculate Composite tags
2849 528 100       3877 $self->BuildCompositeTags() if $$options{Composite};
2850             # do our HTML dump if requested
2851 528 50       2723 if ($$self{HTML_DUMP}) {
2852 0         0 $raf->Seek(0, 2); # seek to end of file
2853 0         0 $$self{HTML_DUMP}->FinishTiffDump($self, $raf->Tell());
2854 0         0 my $pos = $$options{HtmlDumpBase};
2855 0 0 0     0 $pos = ($$self{FIRST_EXIF_POS} || 0) unless defined $pos;
2856 0 0       0 my $dataPt = defined $$self{EXIF_DATA} ? \$$self{EXIF_DATA} : undef;
2857 0 0 0     0 undef $dataPt if defined $$self{EXIF_POS} and $pos != $$self{EXIF_POS};
2858 0 0       0 undef $dataPt if $$self{ExtendedEXIF}; # can't use EXIF block if not contiguous
2859             my $success = $$self{HTML_DUMP}->Print($raf, $dataPt, $pos,
2860             $$options{TextOut}, $$options{HtmlDump},
2861 0 0       0 $$self{FILENAME} ? "HTML Dump ($$self{FILENAME})" : 'HTML Dump');
2862 0 0       0 $self->Warn("Error reading $$self{HTML_DUMP}{ERROR}") if $success < 0;
2863             }
2864             }
2865 530 100       2185 if ($filename) {
2866 488         3409 $raf->Close(); # close the file if we opened it
2867             # process the resource fork as an embedded file on Mac filesystems
2868 488 0 33     2024 if ($rsize and $$options{ExtractEmbedded}) {
2869 0         0 local *RESOURCE_FILE;
2870 0 0       0 if ($self->Open(\*RESOURCE_FILE, "$filename/..namedfork/rsrc")) {
2871 0         0 $$self{DOC_NUM} = $$self{DOC_COUNT} + 1;
2872 0         0 $$self{IN_RESOURCE} = 1;
2873 0         0 $self->ExtractInfo(\*RESOURCE_FILE, { ReEntry => 1 });
2874 0         0 close RESOURCE_FILE;
2875 0         0 delete $$self{IN_RESOURCE};
2876             } else {
2877 0         0 $self->Warn('Error opening resource fork');
2878             }
2879             }
2880             }
2881 530         9079 last; # (loop was a cheap "goto")
2882             }
2883              
2884             # generate Validate tag if requested
2885 530 100 66     2466 if ($$options{Validate} and not $reEntry) {
2886 1         7 Image::ExifTool::Validate::FinishValidate($self, $$req{validate});
2887             }
2888              
2889 530 100       2327 @startTime and $self->FoundTag('ProcessingTime', Time::HiRes::tv_interval(\@startTime));
2890              
2891             # add user-defined parameters that ended with '!'
2892 530 50       1233 if (%{$$options{UserParam}}) {
  530         2320  
2893 0         0 my $doMsg = $$options{Verbose};
2894 0         0 my $table = GetTagTable('Image::ExifTool::UserParam');
2895 0         0 foreach (sort keys %{$$options{UserParam}}) {
  0         0  
2896 0 0       0 next unless /#$/;
2897 0 0       0 if ($doMsg) {
2898 0         0 $self->VPrint(0, "UserParam tags:\n");
2899 0         0 undef $doMsg;
2900             }
2901 0         0 $self->HandleTag($table, $_, $$options{UserParam}{$_});
2902             }
2903             }
2904              
2905             # restore original options
2906 530 100       1883 %saveOptions and $$self{OPTIONS} = \%saveOptions;
2907              
2908 530 100       2734 if ($reEntry) {
    50          
2909             # restore necessary members when exiting re-entrant code
2910 2         17 $$self{$_} = $$reEntry{$_} foreach keys %$reEntry;
2911 2         8 SetByteOrder($saveOrder);
2912             } elsif ($$self{ImageDataMD5}) {
2913 0         0 my $digest = $$self{ImageDataMD5}->hexdigest;
2914             # (don't store empty digest)
2915 0 0       0 $self->FoundTag(ImageDataMD5 => $digest) unless $digest eq 'd41d8cd98f00b204e9800998ecf8427e';
2916             }
2917              
2918             # ($type may be undef without an Error when processing sub-documents)
2919 530 50 33     4174 return 0 if not defined $type or exists $$self{VALUE}{Error};
2920 530         3210 return 1;
2921             }
2922              
2923             #------------------------------------------------------------------------------
2924             # Get hash of extracted meta information
2925             # Inputs: 0) ExifTool object reference
2926             # 1-N) options hash reference, tag list reference or tag names
2927             # Returns: Reference to information hash
2928             # Notes: - pass an undefined value to avoid parsing arguments
2929             # - If groups are specified, first groups take precedence if duplicate
2930             # tags found but Duplicates option not set.
2931             # - tag names may end in '#' to extract ValueConv value
2932             sub GetInfo($;@)
2933             {
2934 699     699 1 4140 local $_;
2935 699         1496 my $self = shift;
2936 699         1528 my %saveOptions;
2937              
2938 699 100 66     4473 unless (@_ and not defined $_[0]) {
2939 182         431 %saveOptions = %{$$self{OPTIONS}}; # save original options
  182         12275  
2940             # must set FILENAME so it isn't parsed from the arguments
2941 182 100       1925 $$self{FILENAME} = '' unless defined $$self{FILENAME};
2942 182         1116 $self->ParseArguments(@_);
2943             }
2944              
2945             # get reference to list of tags for which we will return info
2946 699         3548 my ($rtnTags, $byValue, $wildTags) = $self->SetFoundTags();
2947              
2948             # build hash of tag information
2949 699         1712 my (%info, %ignored);
2950 699 100       2865 my $conv = $$self{OPTIONS}{PrintConv} ? 'PrintConv' : 'ValueConv';
2951 699         2280 foreach (@$rtnTags) {
2952 35699         71692 my $val = $self->GetValue($_, $conv);
2953 35699 100       70658 defined $val or $ignored{$_} = 1, next;
2954 34733         85453 $info{$_} = $val;
2955             }
2956              
2957             # override specified tags with ValueConv value if necessary
2958 699 100       3845 if (@$byValue) {
2959             # first determine the number of times each non-ValueConv value is used
2960 4         14 my %nonVal;
2961 4   100     85 $nonVal{$_} = ($nonVal{$_} || 0) + 1 foreach @$rtnTags;
2962 4         22 --$nonVal{$$rtnTags[$_]} foreach @$byValue;
2963             # loop through ValueConv tags, updating tag keys and returned values
2964 4         14 foreach (@$byValue) {
2965 25         41 my $tag = $$rtnTags[$_];
2966 25         59 my $val = $self->GetValue($tag, 'ValueConv');
2967 25 100       54 next unless defined $val;
2968 16         40 my $vtag = $tag;
2969             # generate a new tag key like "Tag #" or "Tag #(1)"
2970 16         93 $vtag =~ s/( |$)/ #/;
2971 16 50       54 unless (defined $$self{VALUE}{$vtag}) {
2972 16         43 $$self{VALUE}{$vtag} = $$self{VALUE}{$tag};
2973 16         43 $$self{TAG_INFO}{$vtag} = $$self{TAG_INFO}{$tag};
2974 16         32 $$self{TAG_EXTRA}{$vtag} = $$self{TAG_EXTRA}{$tag};
2975 16         37 $$self{FILE_ORDER}{$vtag} = $$self{FILE_ORDER}{$tag};
2976             # remove existing PrintConv entry unless we are using it too
2977 16 100       42 delete $info{$tag} unless $nonVal{$tag};
2978             }
2979 16         31 $$rtnTags[$_] = $vtag; # store ValueConv value with new tag key
2980 16         46 $info{$vtag} = $val; # return ValueConv value
2981             }
2982             }
2983              
2984             # remove ignored tags from the list
2985 699   50     3391 my $reqTags = $$self{REQUESTED_TAGS} || [ ];
2986 699 100       2421 if (%ignored) {
2987 411 100       2010 if (not @$reqTags) {
    100          
2988 194         419 my @goodTags;
2989 194         684 foreach (@$rtnTags) {
2990 22881 100       46601 push @goodTags, $_ unless $ignored{$_};
2991             }
2992 194         2043 $rtnTags = $$self{FOUND_TAGS} = \@goodTags;
2993             } elsif (@$wildTags) {
2994             # only remove tags specified by wildcard
2995 41         73 my @goodTags;
2996 41         101 my $i = 0;
2997 41         103 foreach (@$rtnTags) {
2998 356 100 100     963 if (@$wildTags and $i == $$wildTags[0]) {
2999 197         302 shift @$wildTags;
3000 197 50       500 push @goodTags, $_ unless $ignored{$_};
3001             } else {
3002 159         284 push @goodTags, $_;
3003             }
3004 356         517 ++$i;
3005             }
3006 41         264 $rtnTags = $$self{FOUND_TAGS} = \@goodTags;
3007             }
3008             }
3009              
3010             # return sorted tag list if provided with a list reference
3011 699 100       2781 if ($$self{IO_TAG_LIST}) {
3012             # use file order by default if no tags specified
3013             # (no such thing as 'Input' order in this case)
3014 6         21 my $sort = $$self{OPTIONS}{Sort};
3015 6 50 33     44 $sort = 'File' unless @$reqTags or ($sort and $sort ne 'Input');
      66        
3016             # return tags in specified sort order
3017 6         35 @{$$self{IO_TAG_LIST}} = $self->GetTagList($rtnTags, $sort, $$self{OPTIONS}{Sort2});
  6         42  
3018             }
3019              
3020             # restore original options
3021 699 100       4012 %saveOptions and $$self{OPTIONS} = \%saveOptions;
3022              
3023 699         3584 return \%info;
3024             }
3025              
3026             #------------------------------------------------------------------------------
3027             # Inputs: 0) ExifTool object reference
3028             # 1) [optional] reference to info hash or tag list ref (default is found tags)
3029             # 2) [optional] sort order ('File', 'Input', ...)
3030             # 3) [optional] secondary sort order
3031             # Returns: List of tags in specified order
3032             sub GetTagList($;$$$)
3033             {
3034 436     436 1 83544 local $_;
3035 436         1846 my ($self, $info, $sort, $sort2) = @_;
3036              
3037 436         1014 my $foundTags;
3038 436 100       2307 if (ref $info eq 'HASH') {
    50          
3039 429         6193 my @tags = keys %$info;
3040 429         1668 $foundTags = \@tags;
3041             } elsif (ref $info eq 'ARRAY') {
3042 7         19 $foundTags = $info;
3043             }
3044 436         1413 my $fileOrder = $$self{FILE_ORDER};
3045              
3046 436 50       1528 if ($foundTags) {
3047             # make sure a FILE_ORDER entry exists for all tags
3048             # (note: already generated bogus entries for FOUND_TAGS case below)
3049 436         1536 foreach (@$foundTags) {
3050 24342 50       46028 next if defined $$fileOrder{$_};
3051 0         0 $$fileOrder{$_} = 999;
3052             }
3053             } else {
3054 0 0 0     0 $sort = $info if $info and not $sort;
3055 0 0 0     0 $foundTags = $$self{FOUND_TAGS} || $self->SetFoundTags() or return undef;
3056             }
3057 436 100       2127 $sort or $sort = $$self{OPTIONS}{Sort};
3058              
3059             # return original list if no sort order specified
3060 436 100 66     3323 return @$foundTags unless $sort and $sort ne 'Input';
3061              
3062 417 50 33     5346 if ($sort eq 'Tag' or $sort eq 'Alpha') {
    100          
    50          
3063 0         0 return sort @$foundTags;
3064             } elsif ($sort =~ /^Group(\d*(:\d+)*)/) {
3065 414   50     2599 my $family = $1 || 0;
3066             # want to maintain a basic file order with the groups
3067             # ordered in the way they appear in the file
3068 414         1063 my (%groupCount, %groupOrder);
3069 414         903 my $numGroups = 0;
3070 414         877 my $tag;
3071 414         2528 foreach $tag (sort { $$fileOrder{$a} <=> $$fileOrder{$b} } @$foundTags) {
  131061         176859  
3072 23459         41075 my $group = $self->GetGroup($tag, $family);
3073 23459         38770 my $num = $groupCount{$group};
3074 23459 100       40791 $num or $num = $groupCount{$group} = ++$numGroups;
3075 23459         46297 $groupOrder{$tag} = $num;
3076             }
3077 414 50       3001 $sort2 or $sort2 = $$self{OPTIONS}{Sort2};
3078 414 50       1630 if ($sort2) {
3079 414 50 33     3574 if ($sort2 eq 'Tag' or $sort2 eq 'Alpha') {
    50          
3080 0 0       0 return sort { $groupOrder{$a} <=> $groupOrder{$b} or $a cmp $b } @$foundTags;
  0         0  
3081             } elsif ($sort2 eq 'Descr') {
3082 0         0 my $desc = $self->GetDescriptions($foundTags);
3083 0         0 return sort { $groupOrder{$a} <=> $groupOrder{$b} or
3084 0 0       0 $$desc{$a} cmp $$desc{$b} } @$foundTags;
3085             }
3086             }
3087 414         2269 return sort { $groupOrder{$a} <=> $groupOrder{$b} or
3088 131111 50       235873 $$fileOrder{$a} <=> $$fileOrder{$b} } @$foundTags;
3089             } elsif ($sort eq 'Descr') {
3090 0         0 my $desc = $self->GetDescriptions($foundTags);
3091 0         0 return sort { $$desc{$a} cmp $$desc{$b} } @$foundTags;
  0         0  
3092             } else {
3093 3         23 return sort { $$fileOrder{$a} <=> $$fileOrder{$b} } @$foundTags;
  4723         6285  
3094             }
3095             }
3096              
3097             #------------------------------------------------------------------------------
3098             # Get list of found tags in specified sort order
3099             # Inputs: 0) ExifTool object reference, 1) sort order ('File', 'Input', ...)
3100             # 2) secondary sort order
3101             # Returns: List of tag keys in specified order
3102             # Notes: If not specified, sort order is taken from OPTIONS
3103             sub GetFoundTags($;$$)
3104             {
3105 1     1 1 173 local $_;
3106 1         4 my ($self, $sort, $sort2) = @_;
3107 1 50 33     7 my $foundTags = $$self{FOUND_TAGS} || $self->SetFoundTags() or return undef;
3108 1         7 return $self->GetTagList($foundTags, $sort, $sort2);
3109             }
3110              
3111             #------------------------------------------------------------------------------
3112             # Get list of requested tags
3113             # Inputs: 0) ExifTool object reference
3114             # Returns: List of requested tag keys
3115             sub GetRequestedTags($)
3116             {
3117 2     2 1 4 local $_;
3118 2         5 return @{$_[0]{REQUESTED_TAGS}};
  2         12  
3119             }
3120              
3121             #------------------------------------------------------------------------------
3122             # Get tag value
3123             # Inputs: 0) ExifTool object reference
3124             # 1) tag key or tag name with optional group names (case sensitive)
3125             # (or flattened tagInfo for getting field values, not part of public API)
3126             # 2) [optional] Value type: PrintConv, ValueConv, Both, Raw or Rational, the default
3127             # is PrintConv or ValueConv, depending on the PrintConv option setting
3128             # 3) raw field value (not part of public API)
3129             # Returns: Scalar context: tag value or undefined
3130             # List context: list of values or empty list
3131             sub GetValue($$;$)
3132             {
3133 53826     53826 1 72652 local $_;
3134 53826         95017 my ($self, $tag, $type) = @_; # plus: ($fieldValue)
3135 53826         73429 my (@convTypes, $tagInfo, $valueConv, $both);
3136 53826         77364 my $rawValue = $$self{VALUE};
3137              
3138             # get specific tag key if tag has a group name
3139 53826 50       117105 if ($tag =~ /^(.*):(.+)/) {
3140 0         0 my ($gp, $tg) = ($1, $2);
3141 0         0 my ($i, $key, @keys);
3142             # build list of tag keys in the order of priority (no index
3143             # is top priority, otherwise higher index is higher priority)
3144 0   0     0 for ($key=$tg, $i=$$self{DUPL_TAG}{$tg} || 0; ; --$i) {
3145 0 0       0 push @keys, $key if defined $$rawValue{$key};
3146 0 0       0 last if $i <= 0;
3147 0         0 $key = "$tg ($i)";
3148             }
3149 0 0       0 if (@keys) {
3150 0         0 $key = $self->GroupMatches($gp, \@keys);
3151 0 0       0 $tag = $key if $key;
3152             }
3153             }
3154             # figure out what conversions to do
3155 53826 100       88252 if ($type) {
3156 53803 50       95462 return $$self{RATIONAL}{$tag} if $type eq 'Rational';
3157             } else {
3158 23 50       110 $type = $$self{OPTIONS}{PrintConv} ? 'PrintConv' : 'ValueConv';
3159             }
3160              
3161             # start with the raw value
3162 53826         102421 my $value = $$rawValue{$tag};
3163 53826 100       89464 if (not defined $value) {
3164 10274 100       30178 return () unless ref $tag;
3165             # get the value of a structure field
3166 194         336 $tagInfo = $tag;
3167 194         331 $tag = $$tagInfo{Name};
3168 194         307 $value = $_[3];
3169             # (note: type "Both" is not allowed for structure fields)
3170 194 50       411 if ($type ne 'Raw') {
3171 194         348 push @convTypes, 'ValueConv';
3172 194 100       428 push @convTypes, 'PrintConv' unless $type eq 'ValueConv';
3173             }
3174             } else {
3175 43552         84048 $tagInfo = $$self{TAG_INFO}{$tag};
3176 43552 100 66     109459 if ($$tagInfo{Struct} and ref $value) {
3177             # must load XMPStruct.pl just in case (should already be loaded if
3178             # a structure was extracted, but we could also arrive here if a simple
3179             # list of values was stored incorrectly in a Struct tag)
3180 53         1112 require 'Image/ExifTool/XMPStruct.pl';
3181             # convert strucure field values
3182 53 100       192 unless ($type eq 'Both') {
3183             # (note: ConvertStruct handles the filtering and escaping too if necessary)
3184 48         223 return Image::ExifTool::XMP::ConvertStruct($self,$tagInfo,$value,$type);
3185             }
3186 5         52 $valueConv = Image::ExifTool::XMP::ConvertStruct($self,$tagInfo,$value,'ValueConv');
3187 5         37 $value = Image::ExifTool::XMP::ConvertStruct($self,$tagInfo,$value,'PrintConv');
3188             # (must not save these in $$self{BOTH} because the values may have been escaped)
3189 5         24 return ($valueConv, $value);
3190             }
3191 43499 50       78912 if ($type ne 'Raw') {
3192             # use values we calculated already if we stored them
3193 43499         67056 $both = $$self{BOTH}{$tag};
3194 43499 100       68170 if ($both) {
3195 6643 100       14560 if ($type eq 'PrintConv') {
    100          
3196 2272         4757 $value = $$both[1];
3197             } elsif ($type eq 'ValueConv') {
3198 96         170 $value = $$both[0];
3199 96 100       234 $value = $$both[1] unless defined $value;
3200             } else {
3201 4275         8651 ($valueConv, $value) = @$both;
3202             }
3203             } else {
3204 36856         59663 push @convTypes, 'ValueConv';
3205 36856 100       77286 push @convTypes, 'PrintConv' unless $type eq 'ValueConv';
3206             }
3207             }
3208             }
3209              
3210             # do the conversions
3211 43693         62121 my (@val, @prt, @raw, $convType);
3212 43693         70173 foreach $convType (@convTypes) {
3213             # don't convert a scalar reference or structure
3214 71328 100 66     140247 last if ref $value eq 'SCALAR' and not $$tagInfo{ConvertBinary};
3215 70678         138786 my $conv = $$tagInfo{$convType};
3216 70678 100       122534 unless (defined $conv) {
3217 46097 100       73234 if ($convType eq 'ValueConv') {
3218 29305 100       66785 next unless $$tagInfo{Binary};
3219 402         972 $conv = '\$val'; # return scalar reference for binary values
3220             } else {
3221             # use PRINT_CONV from tag table if PrintConv doesn't exist
3222 16792 100       51185 next unless defined($conv = $$tagInfo{Table}{PRINT_CONV});
3223 201 100       644 next if exists $$tagInfo{$convType};
3224             }
3225             }
3226             # save old ValueConv value if we want Both
3227 25135 100 100     59230 $valueConv = $value if $type eq 'Both' and $convType eq 'PrintConv';
3228 25135         38138 my ($i, $val, $vals, @values, $convList);
3229             # split into list if conversion is an array
3230 25135 100       47969 if (ref $conv eq 'ARRAY') {
3231 125         349 $convList = $conv;
3232 125         449 $conv = $$convList[0];
3233 125 50       755 my @valList = (ref $value eq 'ARRAY') ? @$value : split ' ', $value;
3234             # reorganize list if specified (Note: The writer currently doesn't
3235             # relist values, so they may be grouped but the order must not change)
3236 125         340 my $relist = $$tagInfo{Relist};
3237 125 100       365 if ($relist) {
3238 7         24 my (@newList, $oldIndex);
3239 7         25 foreach $oldIndex (@$relist) {
3240 14         32 my ($newVal, @join);
3241 14 100       57 if (ref $oldIndex) {
3242 7         32 foreach (@$oldIndex) {
3243 16 50       59 push @join, $valList[$_] if defined $valList[$_];
3244             }
3245 7 50       55 $newVal = join(' ', @join) if @join;
3246             } else {
3247 7         17 $newVal = $valList[$oldIndex];
3248             }
3249 14 100       69 push @newList, $newVal if defined $newVal;
3250             }
3251 7         26 $value = \@newList;
3252             } else {
3253 118         304 $value = \@valList;
3254             }
3255 125 50       511 return () unless @$value;
3256             }
3257             # initialize array so we can iterate over values in list
3258 25135 100       43698 if (ref $value eq 'ARRAY') {
3259 156 100       575 if (defined $$tagInfo{RawJoin}) {
3260 7         53 $val = join ' ', @$value;
3261             } else {
3262 149         307 $i = 0;
3263 149         278 $vals = $value;
3264 149         323 $val = $$vals[0];
3265             }
3266             } else {
3267 24979         38427 $val = $value;
3268             }
3269             # loop through all values in list
3270 25135         33270 for (;;) {
3271 25349 100       41641 if (defined $conv) {
3272             # get values of required tags if this is a Composite tag
3273 25330 100 66     56284 if (ref $val eq 'HASH' and not @val) {
3274             # disable escape of source values so we don't double escape them
3275 2959         5289 my $oldEscape = $$self{ESCAPE_PROC};
3276 2959         5333 delete $$self{ESCAPE_PROC};
3277             # temporarily delete filter so it isn't applied to the Require'd values
3278 2959         4844 my $oldFilter = $$self{OPTIONS}{Filter};
3279 2959         4749 delete $$self{OPTIONS}{Filter};
3280 2959         10550 foreach (keys %$val) {
3281 17346 50       34282 next unless defined $$val{$_};
3282 17346         41702 $raw[$_] = $$rawValue{$$val{$_}};
3283 17346         35640 ($val[$_], $prt[$_]) = $self->GetValue($$val{$_}, 'Both');
3284 17346 100 100     54858 next if defined $val[$_] or not $$tagInfo{Require}{$_};
3285 383 50       1250 $$self{OPTIONS}{Filter} = $oldFilter if defined $oldFilter;
3286 383         821 $$self{ESCAPE_PROC} = $oldEscape;
3287 383         1734 return ();
3288             }
3289 2576 100       7133 $$self{OPTIONS}{Filter} = $oldFilter if defined $oldFilter;
3290 2576         5119 $$self{ESCAPE_PROC} = $oldEscape;
3291             # set $val to $val[0], or \@val for a CODE ref conversion
3292 2576 50       7086 $val = ref $conv eq 'CODE' ? \@val : $val[0];
3293             }
3294 24947 100       45188 if (ref $conv eq 'HASH') {
3295             # look up converted value in hash
3296 7668 100       33921 if (not defined($value = $$conv{$val})) {
3297 455 100       2028 if ($$conv{BITMASK}) {
3298 126         912 $value = DecodeBits($val, $$conv{BITMASK}, $$tagInfo{BitsPerWord});
3299             } else {
3300             # use alternate conversion routine if available
3301 329 100       1175 if ($$conv{OTHER}) {
3302 254         1305 local $SIG{'__WARN__'} = \&SetWarning;
3303 254         681 undef $evalWarning;
3304 254         604 $value = &{$$conv{OTHER}}($val, undef, $conv);
  254         1348  
3305 254 50       1162 $self->Warn("$convType $tag: " . CleanWarning()) if $evalWarning;
3306             }
3307 329 100       1097 if (not defined $value) {
3308 77 50 66     437 if ($$tagInfo{PrintHex} and $val and IsInt($val) and
      66        
      33        
3309             $convType eq 'PrintConv')
3310             {
3311 0         0 $value = sprintf('Unknown (0x%x)',$val);
3312             } else {
3313 77         300 $value = "Unknown ($val)";
3314             }
3315             }
3316             }
3317             }
3318             # override with our localized language PrintConv if available
3319 7668         10667 my $tmp;
3320 7668 100 66     19122 if ($$self{CUR_LANG} and $convType eq 'PrintConv' and
      100        
      66        
3321             # (no need to check for lang-alt tag names -- they won't have a PrintConv)
3322             ref($tmp = $$self{CUR_LANG}{$$tagInfo{Name}}) eq 'HASH' and
3323             ($tmp = $$tmp{PrintConv}))
3324             {
3325 261 50 33     1018 if ($$conv{BITMASK} and not defined $$conv{$val}) {
    100          
3326 0         0 my @vals = split ', ', $value;
3327 0         0 foreach (@vals) {
3328 0 0       0 $_ = $$tmp{$_} if defined $$tmp{$_};
3329             }
3330 0         0 $value = join ', ', @vals;
3331             } elsif (defined($tmp = $$tmp{$value})) {
3332 213         435 $value = $self->Decode($tmp, 'UTF8');
3333             }
3334             }
3335             } else {
3336             # call subroutine or do eval to convert value
3337 17279         68914 local $SIG{'__WARN__'} = \&SetWarning;
3338 17279         30837 undef $evalWarning;
3339 17279 100       31178 if (ref $conv eq 'CODE') {
3340 847         4928 $value = &$conv($val, $self);
3341             } else {
3342             #### eval ValueConv/PrintConv ($val, $self, @val, @prt, @raw)
3343 16432         1072558 $value = eval $conv;
3344 16432 50       65229 $@ and $evalWarning = $@;
3345             }
3346 17279 50       58800 $self->Warn("$convType $tag: " . CleanWarning()) if $evalWarning;
3347             }
3348             } else {
3349 19         43 $value = $val;
3350             }
3351 24966 100       54172 last unless $vals;
3352             # must store a separate copy of each binary data value in the list
3353 363 100       1067 if (ref $value eq 'SCALAR') {
3354 3         6 my $tval = $$value;
3355 3         5 $value = \$tval;
3356             }
3357             # save this converted value and step to next value in list
3358 363 50       1054 push @values, $value if defined $value;
3359 363 100       955 if (++$i >= scalar(@$vals)) {
3360 149 50       695 $value = \@values if @values;
3361 149         344 last;
3362             }
3363 214         418 $val = $$vals[$i];
3364 214 100       540 if ($convList) {
3365 133         316 my $nextConv = $$convList[$i];
3366 133 50 66     717 if ($nextConv and $nextConv eq 'REPEAT') {
3367 0         0 undef $convList;
3368             } else {
3369 133         318 $conv = $nextConv;
3370             }
3371             }
3372             }
3373             # return undefined now if no value
3374 24752 100       51183 return () unless defined $value;
3375             # join back into single value if split for conversion list
3376 24181 100 66     65243 if ($convList and ref $value eq 'ARRAY') {
3377 125 100       781 $value = join($convType eq 'PrintConv' ? '; ' : ' ', @$value);
3378             }
3379             }
3380 42739 100       81242 if ($type eq 'Both') {
3381             # save both (unescaped) values because we often need them again
3382             # (Composite tags need "Both" and often Require one tag for various Composite tags)
3383 7661 100       22707 $$self{BOTH}{$tag} = [ $valueConv, $value ] unless $both;
3384             # escape values if necessary
3385 7661 50       21324 if ($$self{ESCAPE_PROC}) {
    100          
3386 0         0 DoEscape($value, $$self{ESCAPE_PROC});
3387 0 0       0 if (defined $valueConv) {
3388 0         0 DoEscape($valueConv, $$self{ESCAPE_PROC});
3389             } else {
3390 0         0 $valueConv = $value;
3391             }
3392             } elsif (not defined $valueConv) {
3393             # $valueConv is undefined if there was no print conversion done
3394 3822         5658 $valueConv = $value;
3395             }
3396 7661         29384 $self->Filter($$self{OPTIONS}{Filter}, \$value);
3397             # return Both values as a list (ValueConv, PrintConv)
3398 7661         33632 return ($valueConv, $value);
3399             }
3400             # escape value if necessary
3401 35078 100       66311 DoEscape($value, $$self{ESCAPE_PROC}) if $$self{ESCAPE_PROC};
3402              
3403             # filter if necessary
3404 35078 100 100     75718 $self->Filter($$self{OPTIONS}{Filter}, \$value) if $$self{OPTIONS}{Filter} and $type eq 'PrintConv';
3405              
3406 35078 100       64343 if (ref $value eq 'ARRAY') {
3407 291 100 100     3130 if (defined $$self{OPTIONS}{ListItem}) {
    100 100        
    100          
3408 3         8 $value = $$value[$$self{OPTIONS}{ListItem}];
3409             } elsif (wantarray) {
3410             # return array if requested
3411 1         6 return @$value;
3412             } elsif ($type eq 'PrintConv' and not $$self{OPTIONS}{List} and not ref $$value[0]) {
3413             # join PrintConv values in comma-separated string if List option not used
3414             # and list contains simple scalars (otherwise return ARRAY ref)
3415 164         844 $value = join $$self{OPTIONS}{ListSep}, @$value;
3416             }
3417             }
3418 35077         89617 return $value;
3419             }
3420              
3421             #------------------------------------------------------------------------------
3422             # Get tag identification number
3423             # Inputs: 0) ExifTool object reference, 1) tag key
3424             # Returns: Scalar context: tag ID if available, otherwise ''
3425             # List context: 0) tag ID (or ''), 1) language code (or undef)
3426             sub GetTagID($$)
3427             {
3428 23472     23472 1 142525 my ($self, $tag) = @_;
3429 23472         40430 my $tagInfo = $$self{TAG_INFO}{$tag};
3430 23472 100 66     76841 return '' unless $tagInfo and defined $$tagInfo{TagID};
3431 23470   100     61887 my $id = $$tagInfo{KeysID} || $$tagInfo{TagID};
3432 23470 50       43267 return ($id, $$tagInfo{LangCode}) if wantarray;
3433 23470         49315 return $id;
3434             }
3435              
3436             #------------------------------------------------------------------------------
3437             # Get description for specified tag
3438             # Inputs: 0) ExifTool object reference, 1) tag key
3439             # Returns: Tag description
3440             # Notes: Will always return a defined value, even if description isn't available
3441             sub GetDescription($$)
3442             {
3443 23472     23472 1 66728 local $_;
3444 23472         37968 my ($self, $tag) = @_;
3445 23472         33458 my ($desc, $name);
3446 23472         37607 my $tagInfo = $$self{TAG_INFO}{$tag};
3447             # ($tagInfo won't be defined for missing tags extracted with -f)
3448 23472 50       44224 if ($tagInfo) {
3449             # use alternate language description if available
3450 23472         47106 while ($$self{CUR_LANG}) {
3451 847         2567 $desc = $$self{CUR_LANG}{$$tagInfo{Name}};
3452 847 100       1384 if ($desc) {
3453             # must look up Description if this tag also has a PrintConv
3454 718 100 100     2091 $desc = $$desc{Description} or last if ref $desc;
3455             } else {
3456             # look up default language of lang-alt tag
3457             last unless $$tagInfo{LangCode} and
3458             ($name = $$tagInfo{Name}) =~ s/-$$tagInfo{LangCode}$// and
3459 129 50 66     415 $desc = $$self{CUR_LANG}{$name};
      66        
3460 1 50 0     6 $desc = $$desc{Description} or last if ref $desc;
3461 1         6 $desc .= " ($$tagInfo{LangCode})";
3462             }
3463             # escape description if necessary
3464 710 50       1384 DoEscape($desc, $$self{ESCAPE_PROC}) if $$self{ESCAPE_PROC};
3465             # return description in proper Charset
3466 710         1486 return $self->Decode($desc, 'UTF8');
3467             }
3468 22762         46063 $desc = $$tagInfo{Description};
3469             }
3470             # just make the tag more readable if description doesn't exist
3471 22762 100       40716 unless ($desc) {
3472 9546         17782 $desc = MakeDescription(GetTagName($tag));
3473             # save description in tag information
3474 9546 50       28801 $$tagInfo{Description} = $desc if $tagInfo;
3475             }
3476 22762         48616 return $desc;
3477             }
3478              
3479             #------------------------------------------------------------------------------
3480             # Get group name for specified tag
3481             # Inputs: 0) ExifTool object reference
3482             # 1) tag key (or reference to tagInfo hash, not part of the public API)
3483             # 2) [optional] group family (-1 to get extended group list, or multiple
3484             # families separated by colons to return multiple groups as a string)
3485             # Returns: Scalar context: group name (for family 0 if not otherwise specified)
3486             # List context: group name if family specified, otherwise list of
3487             # group names for each family. Returns '' for undefined tag.
3488             # Notes: Multiple families may be specified with ':' in family argument (eg. '1:2')
3489             sub GetGroup($$;$)
3490             {
3491 192169     192169 1 697787 local $_;
3492 192169         327440 my ($self, $tag, $family) = @_;
3493 192169         274497 my ($tagInfo, @groups, @families, $simplify, $byTagInfo, $ex, $noID);
3494 192169 100       360657 if (ref $tag eq 'HASH') {
3495 121527         174706 $tagInfo = $tag;
3496 121527         239873 $tag = $$tagInfo{Name};
3497             # set flag so we don't get extra information for an extracted tag
3498 121527         162993 $byTagInfo = 1;
3499             } else {
3500 70642   50     166693 $tagInfo = $$self{TAG_INFO}{$tag} || { };
3501 70642         115896 $ex = $$self{TAG_EXTRA}{$tag};
3502             }
3503 192169         397932 my $groups = $$tagInfo{Groups};
3504             # fill in default groups unless already done
3505             # (after this, Groups 0-2 in tagInfo are guaranteed to be defined)
3506 192169 100       396471 unless ($$tagInfo{GotGroups}) {
3507 36088   50     74634 my $tagTablePtr = $$tagInfo{Table} || { GROUPS => { } };
3508             # construct our group list
3509 36088 100       93863 $groups or $groups = $$tagInfo{Groups} = { };
3510             # fill in default groups
3511 36088         69683 foreach (0..2) {
3512 108264 100 50     422431 $$groups{$_} = $$tagTablePtr{GROUPS}{$_} || '' unless $$groups{$_};
3513             }
3514             # set flag indicating group list was built
3515 36088         77854 $$tagInfo{GotGroups} = 1;
3516             }
3517 192169 100 100     518982 if (defined $family and $family ne '-1') {
3518 99575 100       223476 if ($family =~ /[^\d]/) {
3519 2736         8361 @families = ($family =~ /\d+/g);
3520 2736 50 0     5217 return(($ex && $$ex{G0}) || $$groups{0}) unless @families;
3521 2736 50       5849 $simplify = 1 unless $family =~ /^:/;
3522 2736         3806 undef $family;
3523 2736         4402 foreach (0..2) { $groups[$_] = $$groups{$_}; }
  8208         15703  
3524 2736 50 33     5744 $noID = 1 if @families == 1 and $families[0] != 7;
3525             } else {
3526 96839 100 66     531302 return(($ex && $$ex{"G$family"}) || $$groups{$family}) if $family == 0 or $family == 2;
      100        
3527 28855         99736 $groups[1] = $$groups{1};
3528             }
3529             } else {
3530 92594 100 33     165831 return(($ex && $$ex{G0}) || $$groups{0}) unless wantarray;
3531 92214         160108 foreach (0..2) { $groups[$_] = $$groups{$_}; }
  276642         657679  
3532             }
3533 123805         198064 $groups[3] = 'Main';
3534 123805 100       309120 $groups[4] = ($tag =~ /\((\d+)\)$/) ? "Copy$1" : '';
3535             # handle dynamic group names if necessary
3536 123805 100       235140 unless ($byTagInfo) {
3537 44888 100       80516 if ($ex) {
3538 17455 100       37585 $groups[0] = $$ex{G0} if $$ex{G0};
3539 17455 100       52657 $groups[1] = $$ex{G1} =~ /^\+(.*)/ ? "$groups[1]$1" : $$ex{G1} if $$ex{G1};
    100          
3540 17455 100       33060 $groups[3] = 'Doc' . $$ex{G3} if $$ex{G3};
3541 17455 100 66     32775 $groups[5] = $$ex{G5} || $groups[1] if defined $$ex{G5};
3542 17455 50       32047 if (defined $$ex{G6}) {
3543 0 0       0 $groups[5] = '' unless defined $groups[5]; # (can't leave a hole in the array)
3544 0         0 $groups[6] = $$ex{G6};
3545             }
3546             }
3547 44888 100       83968 if ($$ex{G8}) {
3548 16         27 $groups[7] = '';
3549 16         43 $groups[8] = $$ex{G8};
3550             }
3551             # generate tag ID group names unless obviously not needed
3552 44888 50       77193 unless ($noID) {
3553 44888   100     154955 my $id = $$tagInfo{KeysID} || $$tagInfo{TagID};
3554 44888 100       138932 if (not defined $id) {
    100          
3555 2         5 $id = ''; # (just to be safe)
3556             } elsif ($id =~ /^\d+$/) {
3557 28376 50       65154 $id = sprintf('0x%x', $id) if $$self{OPTIONS}{HexTagIDs};
3558             } else {
3559 16510         36479 $id =~ s/([^-_A-Za-z0-9])/sprintf('%.2x',ord $1)/ge;
  1282         5983  
3560             }
3561 44888         91995 $groups[7] = 'ID-' . $id;
3562 44888   100     159583 defined $groups[$_] or $groups[$_] = '' foreach (5,6);
3563             }
3564             }
3565 123805 100       229614 if ($family) {
3566 44262 100 50     183280 return $groups[$family] || '' if $family > 0;
3567             # add additional matching group names to list
3568             # eg) for MIE-Doc, also add MIE1, MIE1-Doc, MIE-Doc1 and MIE1-Doc1
3569             # and for MIE2-Doc3, also add MIE2, MIE-Doc3, MIE2-Doc and MIE-Doc
3570 15407 100       30670 if ($groups[1] =~ /^MIE(\d*)-(.+?)(\d*)$/) {
3571 34   50     192 push @groups, 'MIE' . ($1 || '1');
3572 34 50       173 push @groups, 'MIE' . ($1 ? '' : '1') . "-$2$3";
3573 34 50       137 push @groups, "MIE$1-$2" . ($3 ? '' : '1');
3574 34 50       169 push @groups, 'MIE' . ($1 ? '' : '1') . "-$2" . ($3 ? '' : '1');
    50          
3575             }
3576             }
3577 94950 100       185937 if (@families) {
3578 2736         3347 my @grps;
3579             # create list of group names (without identical adjacent groups if simplifying)
3580 2736         4032 foreach (@families) {
3581 5472         8904 my $grp = $groups[$_];
3582 5472 50       8786 unless ($grp) {
3583 0 0       0 next if $simplify;
3584 0         0 $grp = '';
3585             }
3586 5472 100 66     22754 push @grps, $grp unless $simplify and @grps and $grp eq $grps[-1];
      100        
3587             }
3588             # remove leading "Main:" if simplifying
3589 2736 50 66     10940 shift @grps if $simplify and @grps > 1 and $grps[0] eq 'Main';
      66        
3590             # return colon-separated string of group names
3591 2736         10622 return join ':', @grps;
3592             }
3593 92214         375602 return @groups;
3594             }
3595              
3596             #------------------------------------------------------------------------------
3597             # Get group names for specified tags
3598             # Inputs: 0) ExifTool object reference
3599             # 1) [optional] information hash reference (default all extracted info)
3600             # 2) [optional] group family (default 0)
3601             # Returns: List of group names in alphabetical order
3602             sub GetGroups($;$$)
3603             {
3604 3     3 1 26 local $_;
3605 3         7 my $self = shift;
3606 3         7 my $info = shift;
3607 3         5 my $family;
3608              
3609             # figure out our arguments
3610 3 100       13 if (ref $info ne 'HASH') {
3611 2         6 $family = $info;
3612 2         8 $info = $$self{VALUE};
3613             } else {
3614 1         3 $family = shift;
3615             }
3616 3 50       10 $family = 0 unless defined $family;
3617              
3618             # get a list of all groups in specified information
3619 3         10 my ($tag, %groups);
3620 3         69 foreach $tag (keys %$info) {
3621 383         741 $groups{ $self->GetGroup($tag, $family) } = 1;
3622             }
3623 3         63 return sort keys %groups;
3624             }
3625              
3626             #------------------------------------------------------------------------------
3627             # Set priority for group where new values are written
3628             # Inputs: 0) ExifTool object reference,
3629             # 1-N) group names (reset to default if no groups specified)
3630             # - used when new tag values are set (ie. before files are written)
3631             sub SetNewGroups($;@)
3632             {
3633 490     490 1 1161 local $_;
3634 490         2422 my ($self, @groups) = @_;
3635 490 50       1884 @groups or @groups = @defaultWriteGroups;
3636 490         1472 my $count = @groups * 10;
3637 490         1060 my %priority;
3638 490         1464 foreach (@groups) {
3639 4410         9686 $priority{lc($_)} = $count;
3640 4410         6647 $count -= 10;
3641             }
3642 490         2028 $priority{file} = 500; # 'File' group is always written (Comment)
3643 490         1409 $priority{composite} = 500; # 'Composite' group is always written
3644             # set write priority (higher # is higher priority)
3645 490         1463 $$self{WRITE_PRIORITY} = \%priority;
3646 490         1639 $$self{WRITE_GROUPS} = \@groups;
3647             }
3648              
3649             #------------------------------------------------------------------------------
3650             # Build Composite tags from Require'd/Desire'd tags
3651             # Inputs: 0) ExifTool object reference
3652             # Note: Tag values are calculated in alphabetical order unless a tag Require's
3653             # or Desire's another Composite tag, in which case the calculation is
3654             # deferred until after the other tag is calculated.
3655             sub BuildCompositeTags($)
3656             {
3657 519     519 1 1060 local $_;
3658 519         1132 my $self = shift;
3659              
3660 519         2672 $$self{BuildingComposite} = 1;
3661              
3662 519         1797 my $compTable = GetTagTable('Image::ExifTool::Composite');
3663 519         34800 my @tagList = sort keys %$compTable;
3664 519         3071 my $rawValue = $$self{VALUE};
3665 519         1313 my $compKeys = $$self{COMP_KEYS};
3666 519         1463 my (%cache, $allBuilt);
3667              
3668 519         1008 for (;;) {
3669 2266         5381 my (%notBuilt, $tag, @deferredTags);
3670 2266         4733 foreach (@tagList) {
3671 44252 100       142071 $notBuilt{$$compTable{$_}{Name}} = 1 unless $specialTags{$_};
3672             }
3673             COMPOSITE_TAG:
3674 2266         4622 foreach $tag (@tagList) {
3675 44252 100       90338 next if $specialTags{$tag};
3676 41138         86526 my $tagInfo = $self->GetTagInfo($compTable, $tag);
3677 41138 100       80360 next unless $tagInfo;
3678 40878         67402 my $tagName = $$compTable{$tag}{Name};
3679             # put required tags into array and make sure they all exist
3680 40878   100     89508 my $subDoc = ($$tagInfo{SubDoc} and $$self{DOC_COUNT});
3681 40878   100     106206 my $require = $$tagInfo{Require} || { };
3682 40878   100     107834 my $desire = $$tagInfo{Desire} || { };
3683 40878   100     107484 my $inhibit = $$tagInfo{Inhibit} || { };
3684             # loop through sub-documents if necessary
3685 40878         57170 my $docNum = 0;
3686 40878         53292 for (;;) {
3687 40878         58131 my (%tagKey, $found, $index);
3688             # save Require'd and Desire'd tag values in list
3689 40878         58393 for ($index=0; ; ++$index) {
3690 97636   100     342804 my $reqTag = $$require{$index} || $$desire{$index} || $$inhibit{$index};
3691 97636 100       167241 unless ($reqTag) {
3692             # allow Composite with no Require'd or Desire'd tags
3693 9154 50       18318 $found = 1 if $index == 0;
3694 9154         14797 last;
3695             }
3696 88482 100 66     311512 if ($subDoc) {
    100          
    100          
3697             # handle SubDoc tags specially to cache tag keys for faster
3698             # processing when there are a large number of sub-documents
3699             # - get document number from the tag groups if specified,
3700             # otherwise we are looping through all documents for this tag
3701 285 50 0     865 my $doc = $reqTag =~ s/\b(Main|Doc(\d+)):// ? ($2 || 0) : $docNum;
3702             # make fast lookup for keys of this tag with specified groups other than doc group
3703             # (similar to code in InsertTagValues(), but this is case-sensitive)
3704 285         498 my $cacheTag = $cache{$reqTag};
3705 285 50       578 unless ($cacheTag) {
3706 285         944 $cacheTag = $cache{$reqTag} = [ ];
3707 285         452 my $reqGroup;
3708 285 50       1534 $reqTag =~ s/^(.*):// and $reqGroup = $1;
3709 285         556 my ($i, $key, @keys);
3710             # build list of tag keys in order of precedence
3711 285   50     1076 for ($key=$reqTag, $i=$$self{DUPL_TAG}{$reqTag} || 0; ; --$i) {
3712 285 50       694 push @keys, $key if defined $$rawValue{$key};
3713 285 50       673 last if $i <= 0;
3714 0         0 $key = "$reqTag ($i)";
3715             }
3716 285 50       877 @keys = $self->GroupMatches($reqGroup, \@keys) if defined $reqGroup;
3717 285 50       739 if (@keys) {
3718 0         0 my $ex = $$self{TAG_EXTRA};
3719             # loop through tags in reverse order of precedence so the higher
3720             # priority tag will win in the case of duplicates within a doc
3721 0 0 0     0 $$cacheTag[$$ex{$_} ? $$ex{$_}{G3} || 0 : 0] = $_ foreach reverse @keys;
3722             }
3723             }
3724             # (set $reqTag to a bogus key if not found)
3725 285   33     1073 $reqTag = $$cacheTag[$doc] || "$reqTag (0)";
3726             } elsif ($reqTag =~ /^(.*):(.+)/) {
3727 27352         75512 my ($reqGroup, $name) = ($1, $2);
3728 27352 100 100     61048 if ($reqGroup eq 'Composite' and $notBuilt{$name}) {
3729             # defer only until all other tags are built if
3730             # we are inhibiting based on another Composite tag
3731 2142 100 100     9269 unless ($$inhibit{$index} and $allBuilt) {
3732 1693         3652 push @deferredTags, $tag;
3733 1693         7405 next COMPOSITE_TAG;
3734             }
3735             }
3736 25659         37440 my ($i, $key, @keys, $altFile);
3737 25659         35466 my $et = $self;
3738             # get tags from alternate file if a family 8 group was specified
3739 25659 100 100     77685 if ($reqTag =~ /\b(File\d+):/i and $$self{ALT_EXIFTOOL}{$1}) {
3740 1         11 $et = $$self{ALT_EXIFTOOL}{$1};
3741 1         2 $altFile = $1;
3742             }
3743             # (CAREFUL! keys may not be sequential if one was deleted)
3744 25659   100     88776 for ($key=$name, $i=$$et{DUPL_TAG}{$name} || 0; ; --$i) {
3745 26310 100       63293 push @keys, $key if defined $$et{VALUE}{$key};
3746 26310 100       53440 last if $i <= 0;
3747 651         2297 $key = "$name ($i)";
3748             }
3749             # make sure the necessary information is available from the alternate file
3750 25659 100       45021 $self->CopyAltInfo($altFile, \@keys) if $altFile;
3751             # find first matching tag
3752 25659         59128 $key = $self->GroupMatches($reqGroup, \@keys);
3753 25659   66     92585 $reqTag = $key || "$name (0)";
3754             } elsif ($notBuilt{$reqTag} and not $$inhibit{$index}) {
3755             # calculate this tag later if it relies on another
3756             # Composite tag which hasn't been calculated yet
3757 5063         9881 push @deferredTags, $tag;
3758 5063         13404 next COMPOSITE_TAG;
3759             }
3760 81726 100       193729 if (defined $$rawValue{$reqTag}) {
    100          
3761 16571 100       28112 if ($$inhibit{$index}) {
3762 70         265 $found = 0;
3763 70         229 last;
3764             } else {
3765 16501         23453 $found = 1;
3766             }
3767             } elsif ($$require{$index}) {
3768 24898         34704 $found = 0;
3769 24898         37142 last; # don't continue since we require this tag
3770             }
3771 56758         118760 $tagKey{$index} = $reqTag;
3772             }
3773 34122 50       84961 if ($docNum) {
    100          
    100          
3774 0 0       0 if ($found) {
3775 0         0 $$self{DOC_NUM} = $docNum;
3776             # save pointers to all used tag keys
3777 0         0 foreach (keys %tagKey) {
3778 0 0       0 $$compKeys{$_} or $$compKeys{$_} = [ ];
3779 0         0 push @{$$compKeys{$tagKey{$_}}}, [ \%tagKey, $_ ];
  0         0  
3780             }
3781 0         0 $self->FoundTag($tagInfo, \%tagKey);
3782 0         0 delete $$self{DOC_NUM};
3783             }
3784 0 0       0 next if ++$docNum <= $$self{DOC_COUNT};
3785 0         0 last;
3786             } elsif ($found) {
3787 5379         11190 delete $notBuilt{$tagName}; # this tag is OK to build now
3788             # keep track of all Require'd tag keys
3789 5379         20386 foreach (keys %tagKey) {
3790             # only tag keys with same name as a Composite tag
3791             # can be replaced (also eliminates keys with
3792             # instance numbers which can't be replaced either)
3793 23851 100       55692 next unless $compositeID{$tagKey{$_}};
3794             }
3795             # save pointers to all used tag keys
3796 5379         13360 foreach (keys %tagKey) {
3797 23851 100       51658 $$compKeys{$_} or $$compKeys{$_} = [ ];
3798 23851         30290 push @{$$compKeys{$tagKey{$_}}}, [ \%tagKey, $_ ];
  23851         92920  
3799             }
3800             # save reference to tag key lookup as value for Composite tag
3801 5379         17369 my $key = $self->FoundTag($tagInfo, \%tagKey);
3802             } elsif (not defined $found) {
3803 3775         8347 delete $notBuilt{$tagName}; # tag can't be built anyway
3804             }
3805 34122 100       98560 last unless $subDoc;
3806             # don't process sub-documents if there is no chance to build this tag
3807             # (can be very time-consuming if there are many docs)
3808 195 100       535 if (%$require) {
3809 165         695 foreach (keys %$require) {
3810 165         399 my $reqTag = $$require{$_};
3811 165         645 $reqTag =~ s/.*://;
3812 165 50       772 next COMPOSITE_TAG unless defined $$rawValue{$reqTag};
3813             }
3814 0         0 $docNum = 1; # go ahead and process the 1st sub-document
3815             } else {
3816 30 50       157 my @try = ref $$tagInfo{SubDoc} ? @{$$tagInfo{SubDoc}} : keys %$desire;
  30         128  
3817             # at least one of the specified desire tags must exist
3818 30         102 foreach (@try) {
3819 60 50       236 my $desTag = $$desire{$_} or next;
3820 60         300 $desTag =~ s/.*://;
3821 60 50       224 defined $$rawValue{$desTag} and $docNum = 1, last;
3822             }
3823 30 50       203 last unless $docNum;
3824             }
3825             }
3826             }
3827 2266 100       7311 last unless @deferredTags;
3828 1747 100       5136 if (@deferredTags == @tagList) {
3829 449 50       2204 if ($allBuilt) {
3830             # everything was deferred in the last pass,
3831             # must be a circular dependency
3832 0         0 warn "Circular dependency in Composite tags\n";
3833 0         0 last;
3834             }
3835 449         1085 $allBuilt = 1; # try once more, ignoring Composite Inhibit tags
3836             }
3837 1747         10696 @tagList = @deferredTags; # calculate deferred tags now
3838             }
3839 519         2605 delete $$self{BuildingComposite};
3840             }
3841              
3842             #------------------------------------------------------------------------------
3843             # Get reference to Composite tag info hash
3844             # Inputs: 0) case-sensitive Composite tag name
3845             # Returns: tagInfo hash or undef
3846             sub GetCompositeTagInfo($)
3847             {
3848 11     11 0 46 my $tag = shift;
3849 11 50       74 return undef unless $compositeID{$tag};
3850 11         82 return $Image::ExifTool::Composite{$compositeID{$tag}[0]};
3851             }
3852              
3853             #------------------------------------------------------------------------------
3854             # Get tag name (removes copy index)
3855             # Inputs: 0) Tag key
3856             # Returns: Tag name
3857             sub GetTagName($)
3858             {
3859 17070     17070 1 23120 local $_;
3860 17070         40977 $_[0] =~ /^(\S+)/;
3861 17070         50947 return $1;
3862             }
3863              
3864             #------------------------------------------------------------------------------
3865             # Get list of shortcuts
3866             # Returns: Shortcut list (sorted alphabetically)
3867             sub GetShortcuts()
3868             {
3869 0     0 1 0 local $_;
3870 0         0 require Image::ExifTool::Shortcuts;
3871 0         0 return sort keys %Image::ExifTool::Shortcuts::Main;
3872             }
3873              
3874             #------------------------------------------------------------------------------
3875             # Get file type for specified extension
3876             # Inputs: 0) file name or extension (case is not significant),
3877             # or FileType value if a description is requested
3878             # 1) flag to return long description instead of type ('0' to return any recognized type)
3879             # Returns: File type (or desc) or undef if extension not supported or if
3880             # description is the same as the input FileType. In list context,
3881             # may return more than one file type if the file may be different formats.
3882             # Returns list of all supported extensions if no file specified
3883             sub GetFileType(;$$)
3884             {
3885 968     968 1 2811 local $_;
3886 968         2622 my ($file, $desc) = @_;
3887 968 50       3065 unless (defined $file) {
3888 0         0 my @types;
3889 0 0 0     0 if (defined $desc and $desc eq '0') {
3890             # return all recognized types
3891 0         0 @types = sort keys %fileTypeLookup;
3892             } else {
3893             # return all supported types
3894 0         0 foreach (sort keys %fileTypeLookup) {
3895 0         0 my $module = $moduleName{$_};
3896 0 0       0 $module = $moduleName{$fileTypeLookup{$_}} unless defined $module;
3897 0 0 0     0 push @types, $_ unless defined $module and $module eq '0';
3898             }
3899             }
3900 0         0 return @types;
3901             }
3902 968         2215 my ($fileType, $subType);
3903 968         2359 my $fileExt = GetFileExtension($file);
3904 968 100       3621 unless ($fileExt) {
3905 66 50       392 if ($file =~ s/ \((.*)\)$//) {
3906 0         0 $subType = $1;
3907 0         0 $fileExt = GetFileExtension($file);
3908             }
3909 66 50       309 $fileExt = uc($file) unless $fileExt;
3910             }
3911 968 100       4605 $fileExt and $fileType = $fileTypeLookup{$fileExt}; # look up the file type
3912 968   100     6598 $fileType = $fileTypeLookup{$fileType} while $fileType and not ref $fileType;
3913             # return description if specified
3914             # (allow input $file to be a FileType for this purpose)
3915 968 50 33     6952 if ($desc) {
    100 66        
3916 0 0       0 if ($fileType) {
3917 0 0 0     0 if ($static_vars{OverrideFileDescription} and $static_vars{OverrideFileDescription}{$fileExt}) {
3918 0         0 $desc = $static_vars{OverrideFileDescription}{$fileExt};
3919             } else {
3920 0         0 $desc = $$fileType[1];
3921             }
3922             } else {
3923 0         0 $desc = $fileDescription{$file};
3924             }
3925 0 0       0 $desc .= ", $subType" if $subType;
3926 0         0 return $desc;
3927             } elsif ($fileType and (not defined $desc or $desc ne '0')) {
3928             # return only supported file types
3929 919         3346 my $mod = $moduleName{$$fileType[0]};
3930 919 50 66     4445 undef $fileType if defined $mod and $mod eq '0';
3931             }
3932 968 100       2906 $fileType or return ();
3933 919         2045 $fileType = $$fileType[0]; # get file type (or list of types)
3934 919 100       2941 if (wantarray) {
    50          
3935 689 100       2464 return @$fileType if ref $fileType eq 'ARRAY';
3936             } elsif ($fileType) {
3937 230 50       1012 $fileType = $fileExt if ref $fileType eq 'ARRAY';
3938             }
3939 915         3175 return $fileType;
3940             }
3941              
3942             #------------------------------------------------------------------------------
3943             # Return true if we can write the specified file type
3944             # Inputs: 0) file name or ext
3945             # Returns: true if writable, 0 if not writable, undef if unrecognized
3946             sub CanWrite($)
3947             {
3948 0     0 1 0 local $_;
3949 0 0       0 my $file = shift or return undef;
3950 0 0       0 my ($type) = GetFileType($file) or return undef;
3951 0 0       0 if ($noWriteFile{$type}) {
3952             # can't write TIFF files with certain extensions (various RAW formats)
3953 0   0     0 my $ext = GetFileExtension($file) || uc($file);
3954 0 0       0 return grep(/^$ext$/, @{$noWriteFile{$type}}) ? 0 : 1 if $ext;
  0 0       0  
3955             }
3956 0 0       0 if ($onlyWriteFile{$type}) {
3957 0   0     0 my $ext = GetFileExtension($file) || uc($file);
3958 0 0       0 return grep(/^$ext$/, @{$onlyWriteFile{$type}}) ? 1 : 0 if $ext;
  0 0       0  
3959             }
3960 0 0       0 unless (%writeTypes) {
3961 0         0 $writeTypes{$_} = 1 foreach @writeTypes;
3962             }
3963 0         0 return $writeTypes{$type};
3964             }
3965              
3966             #------------------------------------------------------------------------------
3967             # Return true if we can create the specified file type
3968             # Inputs: 0) file name or ext
3969             # Returns: true if creatable, 0 if not writable, undef if unrecognized
3970             sub CanCreate($)
3971             {
3972 23     23 1 70 local $_;
3973 23 50       120 my $file = shift or return undef;
3974 23   33     96 my $ext = GetFileExtension($file) || uc($file);
3975 23 50       120 my $type = GetFileType($file) or return undef;
3976 23 50 33     231 return 1 if $createTypes{$ext} or $createTypes{$type};
3977 0         0 return 0;
3978             }
3979              
3980             #==============================================================================
3981             # Functions below this are not part of the public API
3982              
3983             # Initialize member variables before reading or writing a new file
3984             # Inputs: 0) ExifTool object reference
3985             sub Init($)
3986             {
3987 787     787 0 1871 local $_;
3988 787         1810 my $self = shift;
3989             # delete all DataMember variables (lower-case names)
3990 787         8007 foreach (keys %$self) {
3991 25851 100       57786 /[a-z]/ and delete $$self{$_};
3992             }
3993 787         4505 undef %static_vars; # clear all static variables
3994 787         2894 delete $$self{FOUND_TAGS}; # list of found tags
3995 787         2060 delete $$self{EXIF_DATA}; # the EXIF data block
3996 787         1941 delete $$self{EXIF_POS}; # EXIF position in file
3997 787         1754 delete $$self{FIRST_EXIF_POS}; # position of first EXIF in file
3998 787         1708 delete $$self{HTML_DUMP}; # html dump information
3999 787         1563 delete $$self{SET_GROUP0}; # group0 name override
4000 787         1953 delete $$self{SET_GROUP1}; # group1 name override
4001 787         2080 delete $$self{DOC_NUM}; # current embedded document number
4002 787         2716 $$self{DOC_COUNT} = 0; # count of embedded documents processed
4003 787         2119 $$self{BASE} = 0; # base for offsets from start of file
4004 787         4073 $$self{FILE_ORDER} = { }; # * hash of tag order in file ('*' = based on tag key)
4005 787         5213 $$self{VALUE} = { }; # * hash of raw tag values
4006 787         3087 $$self{BOTH} = { }; # * hash for Value/PrintConv values of Require'd tags
4007 787         2571 $$self{RATIONAL} = { }; # * hash of original rational components
4008 787         4320 $$self{TAG_INFO} = { }; # * hash of tag information
4009 787         3539 $$self{TAG_EXTRA} = { }; # * hash of extra tag information (dynamic group names)
4010 787         2180 $$self{PRIORITY} = { }; # * priority of current tags
4011 787         2154 $$self{LIST_TAGS} = { }; # hash of tagInfo refs for active List-type tags
4012 787         2603 $$self{PROCESSED} = { }; # hash of processed directory start positions
4013 787         2006 $$self{DIR_COUNT} = { }; # count various types of directories
4014 787         2096 $$self{DUPL_TAG} = { }; # last-used index for duplicate-tag keys
4015 787         2178 $$self{WARNED_ONCE}= { }; # WarnOnce() warnings already issued
4016 787         2110 $$self{WRITTEN} = { }; # list of tags written (selected tags only)
4017 787         2451 $$self{FORCE_WRITE}= { }; # ForceWrite lookup (set from ForceWrite tag)
4018 787         2285 $$self{FOUND_DIR} = { }; # hash of directory names found in file
4019 787         5648 $$self{COMP_KEYS} = { }; # lookup for tag keys used in Composite tags
4020 787         2382 $$self{PATH} = [ ]; # current subdirectory path in file when reading
4021 787         2017 $$self{NUM_FOUND} = 0; # total number of tags found (incl. duplicates)
4022 787         1904 $$self{CHANGED} = 0; # number of tags changed (writer only)
4023 787         2358 $$self{INDENT} = ' '; # initial indent for verbose messages
4024 787         2072 $$self{PRIORITY_DIR} = ''; # the priority directory name
4025 787         3026 $$self{LOW_PRIORITY_DIR} = { PreviewIFD => 1 }; # names of priority 0 directories
4026 787         2008 $$self{TIFF_TYPE} = ''; # type of TIFF data (APP1, TIFF, NEF, etc...)
4027 787         1884 $$self{FMT_EXPR} = undef; # current advanced formatting expression
4028 787         1974 $$self{Make} = ''; # camera make
4029 787         1769 $$self{Model} = ''; # camera model
4030 787         2005 $$self{CameraType} = ''; # Olympus camera type
4031 787         1876 $$self{FileType} = ''; # identified file type
4032 787 50       3056 if ($self->Options('HtmlDump')) {
4033 0         0 require Image::ExifTool::HtmlDump;
4034 0         0 $$self{HTML_DUMP} = new Image::ExifTool::HtmlDump;
4035             }
4036             # make sure our TextOut is a file reference
4037 787 50       4364 $$self{OPTIONS}{TextOut} = \*STDOUT unless ref $$self{OPTIONS}{TextOut};
4038             }
4039              
4040             #------------------------------------------------------------------------------
4041             # Combine information from a list of info hashes
4042             # Unless Duplicates is enabled, first entry found takes priority
4043             # Inputs: 0) ExifTool object reference, 1-N) list of info hash references
4044             # Returns: Combined information hash reference
4045             sub CombineInfo($;@)
4046             {
4047 2     2 0 1473 local $_;
4048 2         5 my $self = shift;
4049 2         5 my (%combinedInfo, $info, $tag, %haveInfo);
4050              
4051 2 50       9 if ($$self{OPTIONS}{Duplicates}) {
4052 0         0 while ($info = shift) {
4053 0         0 foreach $tag (keys %$info) {
4054 0         0 $combinedInfo{$tag} = $$info{$tag};
4055             }
4056             }
4057             } else {
4058 2         9 while ($info = shift) {
4059 4         60 foreach $tag (keys %$info) {
4060 266         389 my $tagName = GetTagName($tag);
4061 266 100       530 next if $haveInfo{$tagName};
4062 252         391 $haveInfo{$tagName} = 1;
4063 252         442 $combinedInfo{$tag} = $$info{$tag};
4064             }
4065             }
4066             }
4067 2         34 return \%combinedInfo;
4068             }
4069              
4070             #------------------------------------------------------------------------------
4071             # Get tag table name
4072             # Inputs: 0) ExifTool object reference, 1) tag key
4073             # Returns: Table name if available, otherwise ''
4074             sub GetTableName($$)
4075             {
4076 0     0 0 0 my ($self, $tag) = @_;
4077 0 0       0 my $tagInfo = $$self{TAG_INFO}{$tag} or return '';
4078 0         0 return $$tagInfo{Table}{SHORT_NAME};
4079             }
4080              
4081             #------------------------------------------------------------------------------
4082             # Get tag index number
4083             # Inputs: 0) ExifTool object reference, 1) tag key
4084             # Returns: Table index number, or undefined if this tag isn't indexed
4085             sub GetTagIndex($$)
4086             {
4087 0     0 0 0 my ($self, $tag) = @_;
4088 0 0       0 my $tagInfo = $$self{TAG_INFO}{$tag} or return undef;
4089 0         0 return $$tagInfo{Index};
4090             }
4091              
4092             #------------------------------------------------------------------------------
4093             # Find value for specified tag
4094             # Inputs: 0) ExifTool ref, 1) tag name, 2) tag group (family 1)
4095             # Returns: value or undef
4096             sub FindValue($$$)
4097             {
4098 72     72 0 157 my ($et, $tag, $grp) = @_;
4099 72         98 my ($i, $val);
4100 72         117 my $value = $$et{VALUE};
4101 72         120 for ($i=0; ; ++$i) {
4102 144 100       424 my $key = $tag . ($i ? " ($i)" : '');
4103 144 100       323 last unless defined $$value{$key};
4104 142 100       272 if ($et->GetGroup($key, 1) eq $grp) {
4105 70         200 $val = $$value{$key};
4106 70         126 last;
4107             }
4108             }
4109 72         189 return $val;
4110             }
4111              
4112             #------------------------------------------------------------------------------
4113             # Get tag key for next existing tag
4114             # Inputs: 0) ExifTool ref, 1) tag key or case-sensitive tag name
4115             # Returns: Key of next existing tag, or undef if no more
4116             # Notes: This routine is provided for iterating through duplicate tags in the
4117             # ValueConv of Composite tags.
4118             sub NextTagKey($$)
4119             {
4120 18     18 0 82 my ($self, $tag) = @_;
4121 18 50       157 my $i = ($tag =~ s/ \((\d+)\)$//) ? $1 + 1 : 1;
4122 18         90 $tag = "$tag ($i)";
4123 18 50       84 return $tag if defined $$self{VALUE}{$tag};
4124 18         437 return undef;
4125             }
4126              
4127             #------------------------------------------------------------------------------
4128             # Does a string contain valid UTF-8 characters?
4129             # Inputs: 0) string reference, 1) true to allow last character to be truncated
4130             # Returns: 0=regular ASCII, -1=invalid UTF-8, 1=valid UTF-8 with maximum 16-bit
4131             # wide characters, 2=valid UTF-8 requiring 32-bit wide characters
4132             # Notes: Changes current string position
4133             # (see http://www.fileformat.info/info/unicode/utf8.htm for help understanding this)
4134             sub IsUTF8($;$)
4135             {
4136 103     103 0 218 my ($strPt, $trunc) = @_;
4137 103         307 pos($$strPt) = 0; # start at beginning of string
4138 103 100       535 return 0 unless $$strPt =~ /([\x80-\xff])/g;
4139 41         90 my $rtnVal = 1;
4140 41         64 for (;;) {
4141 183         312 my $ch = ord($1);
4142             # minimum lead byte for 2-byte sequence is 0xc2 (overlong sequences
4143             # not allowed), 0xf8-0xfd are restricted by RFC 3629 (no 5 or 6 byte
4144             # sequences), and 0xfe and 0xff are not valid in UTF-8 strings
4145 183 100 100     619 return -1 if $ch < 0xc2 or $ch >= 0xf8;
4146             # determine number of bytes remaining in sequence
4147 153         194 my $n;
4148 153 100       259 if ($ch < 0xe0) {
    50          
4149 75         102 $n = 1;
4150             } elsif ($ch < 0xf0) {
4151 78         107 $n = 2;
4152             } else {
4153 0         0 $n = 3;
4154             # character code is greater than 0xffff if more than 2 extra bytes
4155             # were required in the UTF-8 character
4156 0         0 $rtnVal = 2;
4157             }
4158 153         197 my $pos = pos $$strPt;
4159 153 100       657 unless ($$strPt =~ /\G([\x80-\xbf]{$n})/g) {
4160 1 50 33     9 return $rtnVal if $trunc and $pos + $n > length $$strPt;
4161 1         4 return -1;
4162             }
4163             # the following is ref https://www.cl.cam.ac.uk/%7Emgk25/ucs/utf8_check.c
4164 152 100       273 if ($n == 2) {
4165 77 50 66     396 return -1 if ($ch == 0xe0 and (ord($1) & 0xe0) == 0x80) or
      33        
      33        
      66        
      33        
      33        
4166             ($ch == 0xed and (ord($1) & 0xe0) == 0xa0) or
4167             ($ch == 0xef and ord($1) == 0xbf and
4168             (ord(substr $1, 1) & 0xfe) == 0xbe);
4169             } else {
4170 75 50 33     363 return -1 if ($ch == 0xf0 and (ord($1) & 0xf0) == 0x80) or
      33        
      33        
      33        
4171             ($ch == 0xf4 and ord($1) > 0x8f) or $ch > 0xf4;
4172             }
4173 152 100       398 last unless $$strPt =~ /([\x80-\xff])/g;
4174             }
4175 10         26 return $rtnVal;
4176             }
4177              
4178             #------------------------------------------------------------------------------
4179             # Split file name into directory and name parts
4180             # Inptus: 0) file name
4181             # Returns: 0) directory, 1) filename
4182             sub SplitFileName($)
4183             {
4184 486     486 0 1310 my $file = shift;
4185 486         1130 my ($dir, $name);
4186 486 50       1107 if (eval { require File::Basename }) {
  486         5134  
4187 486         29152 $dir = File::Basename::dirname($file);
4188 486         13414 $name = File::Basename::basename($file);
4189             } else {
4190 0         0 ($name = $file) =~ tr/\\/\//;
4191             # remove path
4192 0 0       0 if ($name =~ s/(.*)\///) {
4193 0 0       0 $dir = length($1) ? $1 : '/';
4194             } else {
4195 0         0 $dir = '.';
4196             }
4197             }
4198 486         2237 return ($dir, $name);
4199             }
4200              
4201             #------------------------------------------------------------------------------
4202             # Encode file name for calls to system i/o routines
4203             # Inputs: 0) ExifTool ref, 1) file name in CharSetFileName, 2) flag to force conversion
4204             # Returns: true if Windows Unicode routines should be used (in which case
4205             # the file name will be encoded as a null-terminated UTF-16LE string)
4206             sub EncodeFileName($$;$)
4207             {
4208 1152     1152 0 3056 my ($self, $file, $force) = @_;
4209 1152         2763 my $enc = $$self{OPTIONS}{CharsetFileName};
4210 1152 50 33     6745 if ($enc) {
    50 33        
4211 0 0 0     0 if ($file =~ /[\x80-\xff]/ or $force) {
4212             # encode for use in Windows Unicode functions if necessary
4213 0 0       0 if ($^O eq 'MSWin32') {
4214 0         0 local $SIG{'__WARN__'} = \&SetWarning;
4215 0 0       0 if (eval { require Win32API::File }) {
  0         0  
4216             # recode as UTF-16LE and add null terminator
4217 0         0 $_[1] = $self->Decode($file, $enc, undef, 'UTF16', 'II') . "\0\0";
4218 0         0 return 1;
4219             }
4220 0         0 $self->WarnOnce('Install Win32API::File for Windows Unicode file support');
4221             } else {
4222             # recode as UTF-8 for other platforms if necessary
4223 0 0       0 $_[1] = $self->Decode($file, $enc, undef, 'UTF8') unless $enc eq 'UTF8';
4224             }
4225             }
4226             } elsif ($^O eq 'MSWin32' and $file =~ /[\x80-\xff]/ and not defined $enc) {
4227 0 0       0 $self->WarnOnce('FileName encoding not specified') if IsUTF8(\$file) < 0;
4228             }
4229 1152         3687 return 0;
4230             }
4231              
4232             #------------------------------------------------------------------------------
4233             # Modified perl open() routine to properly handle special characters in file names
4234             # Inputs: 0) ExifTool ref, 1) filehandle, 2) filename,
4235             # 3) mode: '<' or undef = read, '>' = write, '+<' = update
4236             # Returns: true on success
4237             # Note: Must call like "$et->Open(\*FH,$file)", not "$et->Open(FH,$file)" to avoid
4238             # "unopened filehandle" errors due to a change in scope of the filehandle
4239             sub Open($*$;$)
4240             {
4241 923     923 0 3553 my ($self, $fh, $file, $mode) = @_;
4242              
4243 923         3513 $file =~ s/^([\s&])/.\/$1/; # protect leading whitespace or ampersand
4244             # default to read mode ('<') unless input is a trusted pipe
4245 923 50 33     5032 $mode = (($file =~ /\|$/ and $$self{TRUST_PIPE}) ? '' : '<') unless $mode;
    100          
4246 923         2202 delete $$self{TRUST_PIPE};
4247 923 50       2731 if ($mode) {
4248 923 50       3318 if ($self->EncodeFileName($file)) {
4249             # handle Windows Unicode file name
4250 0         0 local $SIG{'__WARN__'} = \&SetWarning;
4251 0         0 my ($access, $create);
4252 0 0 0     0 if ($mode eq '>' or $mode eq '>>') {
4253 0         0 eval {
4254 0         0 $access = Win32API::File::GENERIC_WRITE();
4255 0 0       0 if ($mode eq '>>') {
4256 0         0 $access |= Win32API::File::FILE_APPEND_DATA();
4257 0         0 $create = Win32API::File::OPEN_ALWAYS();
4258             } else {
4259 0         0 $create = Win32API::File::CREATE_ALWAYS();
4260             }
4261             }
4262             } else {
4263 0         0 eval {
4264 0         0 $access = Win32API::File::GENERIC_READ();
4265 0 0       0 $access |= Win32API::File::GENERIC_WRITE() if $mode eq '+<'; # update
4266 0         0 $create = Win32API::File::OPEN_EXISTING();
4267             }
4268             }
4269 0         0 my $share = 0;
4270 0         0 eval {
4271 0 0       0 unless ($access & Win32API::File::GENERIC_WRITE()) {
4272 0         0 $share = Win32API::File::FILE_SHARE_READ() | Win32API::File::FILE_SHARE_WRITE();
4273             }
4274             };
4275 0         0 my $wh = eval { Win32API::File::CreateFileW($file, $access, $share, [], $create, 0, []) };
  0         0  
4276 0 0       0 return undef unless $wh;
4277 0         0 my $fd = eval { Win32API::File::OsFHandleOpenFd($wh, 0) };
  0         0  
4278 0 0 0     0 if (not defined $fd or $fd < 0) {
4279 0         0 eval { Win32API::File::CloseHandle($wh) };
  0         0  
4280 0         0 return undef;
4281             }
4282 0         0 $file = "&=$fd"; # specify file by descriptor
4283             } else {
4284             # add leading space to protect against leading characters like '>'
4285             # in file name, and trailing "\0" to protect trailing spaces
4286 923         3195 $file = " $file\0";
4287             }
4288             }
4289 923         64818 return open $fh, "$mode$file";
4290             }
4291              
4292             #------------------------------------------------------------------------------
4293             # Check to see if a file exists (with Windows Unicode support)
4294             # Inputs: 0) ExifTool ref, 1) file name
4295             # Returns: true if file exists
4296             sub Exists($$)
4297             {
4298 222     222 0 792 my ($self, $file) = @_;
4299              
4300 222 50       854 if ($self->EncodeFileName($file)) {
4301 0         0 local $SIG{'__WARN__'} = \&SetWarning;
4302 0         0 my $wh = eval { Win32API::File::CreateFileW($file,
  0         0  
4303             Win32API::File::GENERIC_READ(),
4304             Win32API::File::FILE_SHARE_READ(), [],
4305             Win32API::File::OPEN_EXISTING(), 0, []) };
4306 0 0       0 return 0 unless $wh;
4307 0         0 eval { Win32API::File::CloseHandle($wh) };
  0         0  
4308             } else {
4309             # (named pipes already exist, but we pretend that they don't
4310             # so we will be able to write them, so test with for pipe -p)
4311 222   33     5635 return(-e $file and not -p $file);
4312             }
4313 0         0 return 1;
4314             }
4315              
4316             #------------------------------------------------------------------------------
4317             # Return true if file is a directory (with Windows Unicode support)
4318             # Inputs: 0) ExifTool ref, 1) file name
4319             # Returns: true if file is a directory (false if file isn't, or doesn't exist)
4320             sub IsDirectory($$)
4321             {
4322 1     1 0 4 my ($et, $file) = @_;
4323 1 50       5 if ($et->EncodeFileName($file)) {
4324 0         0 local $SIG{'__WARN__'} = \&SetWarning;
4325 0         0 my $attrs = eval { Win32API::File::GetFileAttributesW($file) };
  0         0  
4326 0   0     0 my $dirBit = eval { Win32API::File::FILE_ATTRIBUTE_DIRECTORY() } || 0;
4327 0 0 0     0 return 1 if $attrs and $attrs != 0xffffffff and $attrs & $dirBit;
      0        
4328             } else {
4329 1         21 return -d $file;
4330             }
4331 0         0 return 0;
4332             }
4333              
4334             #------------------------------------------------------------------------------
4335             # Get file times (Unix seconds since the epoch)
4336             # Inputs: 0) ExifTool ref, 1) file name or ref
4337             # Returns: 0) access time, 1) modification time, 2) creation time (or undefs on error)
4338             my $k32GetFileTime;
4339             sub GetFileTime($$)
4340             {
4341 0     0 0 0 my ($self, $file) = @_;
4342              
4343             # open file by name if necessary
4344 0 0       0 unless (ref $file) {
4345 0         0 local *FH;
4346 0 0       0 unless ($self->Open(\*FH, $file)) {
4347 0 0       0 if ($self->IsDirectory($file)) {
4348 0         0 my @rtn = (stat $file)[8, 9, 10];
4349 0 0       0 return @rtn if defined $rtn[0];
4350             }
4351 0         0 $self->Warn("GetFileTime error for '${file}'");
4352 0         0 return ();
4353             }
4354 0         0 $file = *FH; # (not \*FH, so *FH will be kept open until $file goes out of scope)
4355             }
4356             # on Windows, try to work around incorrect file times when daylight saving time is in effect
4357 0 0       0 if ($^O eq 'MSWin32') {
4358 0 0       0 if (not eval { require Win32::API }) {
  0 0       0  
4359 0         0 $self->WarnOnce('Install Win32::API for proper handling of Windows file times', 1);
4360 0         0 } elsif (not eval { require Win32API::File }) {
4361 0         0 $self->WarnOnce('Install Win32API::File for proper handling of Windows file times', 1);
4362             } else {
4363             # get Win32 handle, needed for GetFileTime
4364 0         0 my $win32Handle = eval { Win32API::File::GetOsFHandle($file) };
  0         0  
4365 0 0       0 unless ($win32Handle) {
4366 0         0 $self->Warn("Win32API::File::GetOsFHandle returned invalid handle");
4367 0         0 return ();
4368             }
4369             # get FILETIME structs
4370 0         0 my ($atime, $mtime, $ctime, $time);
4371 0         0 $atime = $mtime = $ctime = pack 'LL', 0, 0;
4372 0 0       0 unless ($k32GetFileTime) {
4373 0 0       0 return () if defined $k32GetFileTime;
4374 0         0 $k32GetFileTime = new Win32::API('KERNEL32', 'GetFileTime', 'NPPP', 'I');
4375 0 0       0 unless ($k32GetFileTime) {
4376 0         0 $self->Warn('Error calling Win32::API::GetFileTime');
4377 0         0 $k32GetFileTime = 0;
4378 0         0 return ();
4379             }
4380             }
4381 0 0       0 unless ($k32GetFileTime->Call($win32Handle, $ctime, $atime, $mtime)) {
4382 0         0 $self->Warn("Win32::API::GetFileTime returned " . Win32::GetLastError());
4383 0         0 return ();
4384             }
4385             # convert FILETIME structs to Unix seconds
4386 0         0 foreach $time ($atime, $mtime, $ctime) {
4387 0         0 my ($lo, $hi) = unpack 'LL', $time; # unpack FILETIME struct
4388             # FILETIME is in 100 ns intervals since 0:00 UTC Jan 1, 1601
4389             # (89 leap years between 1601 and 1970)
4390 0         0 $time = ($hi * 4294967296 + $lo) * 1e-7 - (((1970-1601)*365+89)*24*3600);
4391             }
4392 0         0 return ($atime, $mtime, $ctime);
4393             }
4394             }
4395             # other os (or Windows fallback)
4396 0         0 return (stat $file)[8, 9, 10];
4397             }
4398              
4399             #------------------------------------------------------------------------------
4400             # Parse function arguments and set member variables accordingly
4401             # Inputs: Same as ImageInfo()
4402             # - sets REQUESTED_TAGS, REQ_TAG_LOOKUP, IO_TAG_LIST, FILENAME, RAF, OPTIONS
4403             sub ParseArguments($;@)
4404             {
4405 710     710 0 1611 my $self = shift;
4406 710         1741 my $options = $$self{OPTIONS};
4407 710         1639 my @oldGroupOpts = grep /^Group/, keys %{$$self{OPTIONS}};
  710         14559  
4408 710         3801 my (@exclude, $wasExcludeOpt);
4409              
4410 710         2615 $$self{REQUESTED_TAGS} = [ ];
4411 710         2336 $$self{REQ_TAG_LOOKUP} = { };
4412 710         2419 $$self{EXCL_TAG_LOOKUP} = { };
4413 710         2026 $$self{IO_TAG_LIST} = undef;
4414 710         1635 delete $$self{EXCL_XMP_LOOKUP};
4415              
4416             # handle our input arguments
4417 710         2666 while (@_) {
4418 1522         2995 my $arg = shift;
4419 1522 100 66     7190 if (ref $arg and not overload::Method($arg, q[""])) {
    100          
4420 155 100 100     7746 if (ref $arg eq 'ARRAY') {
    100          
    100          
    50          
4421 6         18 $$self{IO_TAG_LIST} = $arg;
4422 6         28 foreach (@$arg) {
4423 15 100       42 if (/^-(.*)/) {
4424 2         9 push @exclude, $1;
4425             } else {
4426 13         22 push @{$$self{REQUESTED_TAGS}}, $_;
  13         36  
4427             }
4428             }
4429             } elsif (ref $arg eq 'HASH') {
4430 107         261 my $opt;
4431 107         477 foreach $opt (keys %$arg) {
4432             # a single new group option overrides all old group options
4433 171 50 33     733 if (@oldGroupOpts and $opt =~ /^Group/) {
4434 0         0 foreach (@oldGroupOpts) {
4435 0         0 delete $$options{$_};
4436             }
4437 0         0 undef @oldGroupOpts;
4438             }
4439 171         750 $self->Options($opt, $$arg{$opt});
4440 171 50       855 $opt eq 'Exclude' and $wasExcludeOpt = 1;
4441             }
4442             } elsif (ref $arg eq 'SCALAR' or UNIVERSAL::isa($arg,'GLOB')) {
4443 23 50       110 next if defined $$self{RAF};
4444             # convert image data from UTF-8 to character stream if necessary
4445             # (patches RHEL 3 UTF8 LANG problem)
4446 23 50 66     210 if (ref $arg eq 'SCALAR' and $] >= 5.006 and
      33        
      66        
4447             (eval { require Encode; Encode::is_utf8($$arg) } or $@))
4448             {
4449             # repack by hand if Encode isn't available
4450 0 0       0 my $buff = $@ ? pack('C*',unpack($] < 5.010000 ? 'U0C*' : 'C0C*',$$arg)) : Encode::encode('utf8',$$arg);
    0          
4451 0         0 $arg = \$buff;
4452             }
4453 23         208 $$self{RAF} = new File::RandomAccess($arg);
4454             # set filename to empty string to indicate that
4455             # we have a file but we didn't open it
4456 23         111 $$self{FILENAME} = '';
4457             } elsif (UNIVERSAL::isa($arg, 'File::RandomAccess')) {
4458 19         54 $$self{RAF} = $arg;
4459 19         79 $$self{FILENAME} = '';
4460             } else {
4461 0         0 warn "Don't understand ImageInfo argument $arg\n";
4462             }
4463             } elsif (defined $$self{FILENAME}) {
4464 881 100       2446 if ($arg =~ /^-(.*)/) {
4465 54         335 push @exclude, $1;
4466             } else {
4467 827         1279 push @{$$self{REQUESTED_TAGS}}, $arg;
  827         2814  
4468             }
4469             } else {
4470 486         1940 $$self{FILENAME} = $arg;
4471             }
4472             }
4473             # add additional requested tags to lookup
4474 710 100       3183 if ($$options{RequestTags}) {
4475 46         197 $$self{REQ_TAG_LOOKUP}{$_} = 1 foreach @{$$options{RequestTags}};
  46         327  
4476             }
4477             # expand shortcuts in tag arguments if provided
4478 710 100       1550 if (@{$$self{REQUESTED_TAGS}}) {
  710         2723  
4479 362         1925 ExpandShortcuts($$self{REQUESTED_TAGS});
4480             # initialize lookup for requested tags
4481 362         913 foreach (@{$$self{REQUESTED_TAGS}}) {
  362         1297  
4482 883 50       4675 /^(.*:)?([-\w?*]*)#?$/ or next;
4483 883 50       5046 $$self{REQ_TAG_LOOKUP}{lc($2)} = 1 if $2;
4484 883 100       2553 next unless $1;
4485 241         1674 $$self{REQ_TAG_LOOKUP}{lc($_).':'} = 1 foreach split /:/, $1;
4486             }
4487             }
4488 710 100 66     4600 if (@exclude or $wasExcludeOpt) {
4489             # must add existing excluded tags
4490 41 100       171 push @exclude, @{$$options{Exclude}} if $$options{Exclude};
  1         4  
4491 41         135 $$options{Exclude} = \@exclude;
4492             # expand shortcuts in new exclude list
4493 41         195 ExpandShortcuts($$options{Exclude}, 1); # (also remove '#' suffix)
4494             }
4495             # generate lookup for excluded tags
4496 710 100       3032 if ($$options{Exclude}) {
4497 47         137 foreach (@{$$options{Exclude}}) {
  47         230  
4498 64 100       633 /([-\w]+)#?$/ and $$self{EXCL_TAG_LOOKUP}{lc $1} = 1;
4499 64 50       353 if (/(xmp-.*:[-\w]+)#?/i) {
4500 0 0       0 $$self{EXCL_XMP_LOOKUP} or $$self{EXCL_XMP_LOOKUP} = { };
4501 0         0 $$self{EXCL_XMP_LOOKUP}{lc $1} = 1;
4502             }
4503             }
4504             # exclude list is used only for EXCL_TAG_LOOKUP when TAGS_FROM_FILE is set
4505 47 100       264 undef $$options{Exclude} if $$self{TAGS_FROM_FILE};
4506             }
4507             }
4508              
4509             #------------------------------------------------------------------------------
4510             # Does group name match the tag ID?
4511             # Inputs: 0) tag ID, 1) group name (with "ID-" removed)
4512             # Returns: true on success
4513             sub IsSameID($$)
4514             {
4515 2     2 0 10 my ($id, $grp) = @_;
4516 2         5 for (;;) {
4517 2 100       12 return 1 if $grp eq $id; # decimal ID's or raw ID's
4518 1 50       6 if ($id =~ /^\d+$/) { # numerical numerical ID's may be in hex
4519 0 0 0     0 return 1 if $grp =~ s/^0x0*// and $grp eq sprintf('%x', $id);
4520             } else { # other ID's may conform to ExifTool group name conventions
4521 1         3 my $tmp = $id;
4522 1 50 33     9 return 1 if $tmp =~ s/([^-_A-Za-z0-9])/sprintf('%.2x',ord $1)/ge and $grp eq $tmp;
  1         17  
4523             }
4524 1 50       5 last unless $id =~ s/-.*//; # remove language code if it exists
4525             }
4526 1         4 return 0;
4527             }
4528              
4529             #------------------------------------------------------------------------------
4530             # Get list of tags in specified group
4531             # Inputs: 0) ExifTool ref, 1) group spec, 2) tag key or reference to list of tag keys
4532             # Returns: list of matching tags in list context, or first match in scalar context
4533             # Notes: Group spec may contain multiple groups separated by colons, each
4534             # possibly with a leading family number
4535             sub GroupMatches($$$)
4536             {
4537 26218     26218 0 49853 my ($self, $group, $tagList) = @_;
4538 26218 50       52271 $tagList = [ $tagList ] unless ref $tagList;
4539 26218         36111 my ($tag, @matches);
4540             # check each group name individually (eg. "Author:1IPTC")
4541 26218         63408 my @grps = split ':', $group;
4542 26218         37751 my (@fmys, $g);
4543 26218         57220 for ($g=0; $g<@grps; ++$g) {
4544 26795 50       115340 if ($grps[$g] =~ s/^(\d*)(id-)?//i) {
4545 26795 100       62291 $fmys[$g] = $1 if length $1;
4546 26795 50       53340 if ($2) {
4547 0         0 $fmys[$g] = 7;
4548 0         0 next; # (don't convert tag ID's to lower case)
4549             }
4550             }
4551 26795         52525 $grps[$g] = lc $grps[$g];
4552 26795 50       72855 $grps[$g] = '' if $grps[$g] eq 'copy0'; # accept 'Copy0' for primary tag
4553             }
4554 26218         50660 foreach $tag (@$tagList) {
4555 15407         35386 my @groups = $self->GetGroup($tag, -1);
4556 15407         36824 for ($g=0; $g<@grps; ++$g) {
4557 15871         25677 my $grp = $grps[$g];
4558 15871 50 33     49924 next if $grp eq '*' or $grp eq 'all';
4559 15871         20976 my $f;
4560 15871 100       28672 if (defined($f = $fmys[$g])) {
4561 3 50       11 last unless defined $groups[$f];
4562 3 50       14 if ($f == 7) {
4563 0 0       0 next if IsSameID($self->GetTagID($tag), $grp);
4564             } else {
4565 3 100       17 next if $grp eq lc $groups[$f];
4566             }
4567 1         2 last;
4568             } else {
4569 15868 100       156135 last unless grep /^$grp$/i, @groups;
4570             }
4571             }
4572 15407 100       42548 if ($g == @grps) {
4573 4524 100       13331 return $tag unless wantarray;
4574 2462         6022 push @matches, $tag;
4575             }
4576             }
4577 24156 100       64350 return wantarray ? @matches : $matches[0];
4578             }
4579              
4580             #------------------------------------------------------------------------------
4581             # Remove specified tags from returned tag list, updating indices in other lists
4582             # Inputs: 0) tag list ref, 1) index list ref, 2) index list ref, 3) hash ref,
4583             # 4) true to include tags from hash instead of excluding
4584             # Returns: nothing, but updates input lists
4585             sub RemoveTagsFromList($$$$;$)
4586             {
4587 69     69 0 160 local $_;
4588 69         214 my ($tags, $list1, $list2, $exclude, $inv) = @_;
4589 69         130 my @filteredTags;
4590              
4591 69 100 100     454 if (@$list1 or @$list2) {
4592 6         37 while (@$tags) {
4593 233         348 my $tag = pop @$tags;
4594 233         321 my $i = @$tags;
4595 233 100 50     647 if ($$exclude{$tag} xor $inv) {
4596             # remove index of excluded tag from each list
4597 154 100       263 @$list1 = map { $_ < $i ? $_ : $_ == $i ? () : $_ - 1 } @$list1;
  12 100       31  
4598 154 100       224 @$list2 = map { $_ < $i ? $_ : $_ == $i ? () : $_ - 1 } @$list2;
  8245 100       12674  
4599             } else {
4600 79         220 unshift @filteredTags, $tag;
4601             }
4602             }
4603             } else {
4604 63         189 foreach (@$tags) {
4605 6864 100 100     20245 push @filteredTags, $_ unless $$exclude{$_} xor $inv;
4606             }
4607             }
4608 69         610 $_[0] = \@filteredTags; # update tag list
4609             }
4610              
4611             #------------------------------------------------------------------------------
4612             # Copy tags from alternate input file
4613             # Inputs: 0) ExifTool ref, 1) family 8 group, 2) list ref for tag keys to copy
4614             # - updates tag key list to match keys newly added to $self
4615             sub CopyAltInfo($$$)
4616             {
4617 7     7 0 20 my ($self, $g8, $tags) = @_;
4618 7         16 my ($tag, $vtag);
4619 7 50       38 return unless $g8 =~ /(\d+)/;
4620 7 50       31 my $et = $$self{ALT_EXIFTOOL}{$g8} or return;
4621 7         28 my $altOrder = ($1 + 1) * 100000; # increment file order
4622 7         28 foreach $tag (@$tags) {
4623 9         70 ($vtag = $tag) =~ s/( |$)/ #[$g8]/;
4624 9 100       50 unless (defined $$self{VALUE}{$vtag}) {
4625 8         37 $$self{VALUE}{$vtag} = $$et{VALUE}{$tag};
4626 8         27 $$self{TAG_INFO}{$vtag} = $$et{TAG_INFO}{$tag};
4627 8   50     32 $$self{TAG_EXTRA}{$vtag} = $$et{TAG_EXTRA}{$tag} || { };
4628 8   50     34 $$self{FILE_ORDER}{$vtag} = ($$et{FILE_ORDER}{$tag} || 0) + $altOrder;
4629             }
4630 9         28 $tag = $vtag;
4631             }
4632             }
4633              
4634             #------------------------------------------------------------------------------
4635             # Set list of found tags from previously requested tags
4636             # Inputs: 0) ExifTool object reference
4637             # Returns: 0) Reference to list of found tag keys (in order of requested tags)
4638             # 1) Reference to list of indices for tags requested by value
4639             # 2) Reference to list of indices for tags specified by wildcard or "all"
4640             # Notes: index lists are returned in increasing order
4641             sub SetFoundTags($)
4642             {
4643 699     699 0 1470 my $self = shift;
4644 699         1860 my $options = $$self{OPTIONS};
4645 699   50     2706 my $reqTags = $$self{REQUESTED_TAGS} || [ ];
4646 699         1718 my $duplicates = $$options{Duplicates};
4647 699         1640 my $exclude = $$options{Exclude};
4648 699         1716 my $fileOrder = $$self{FILE_ORDER};
4649 699         20118 my @groupOptions = sort grep /^Group/, keys %$options;
4650 699   100     5642 my $doDups = $duplicates || $exclude || @groupOptions;
4651 699         1927 my ($tag, $rtnTags, @byValue, @wildTags);
4652              
4653             # only return requested tags if specified
4654 699 100       2500 if (@$reqTags) {
4655 362 50       1361 $rtnTags or $rtnTags = [ ];
4656             # scan through the requested tags and generate a list of tags we found
4657 362         941 my $tagHash = $$self{VALUE};
4658 362         771 my $reqTag;
4659 362         1130 foreach $reqTag (@$reqTags) {
4660 883         1811 my (@matches, $group, $allGrp, $allTag, $byValue, $g8);
4661 883         1608 my $et = $self;
4662 883 100       3104 if ($reqTag =~ /^(.*):(.+)/) {
4663 241         1109 ($group, $tag) = ($1, $2);
4664 241 50       2131 if ($group =~ /^(\*|all)$/i) {
    100          
    50          
4665 0         0 $allGrp = 1;
4666             } elsif ($reqTag =~ /\bfile(\d+):/i) {
4667 6         18 $g8 = "File$1";
4668 6   33     28 $et = $$self{ALT_EXIFTOOL}{$g8} || $self;
4669 6         17 $fileOrder = $$et{FILE_ORDER};
4670 6         14 $tagHash = $$et{VALUE};
4671             } elsif ($group !~ /^[-\w:]*$/) {
4672 0         0 $self->Warn("Invalid group name '${group}'");
4673 0         0 $group = 'invalid';
4674             }
4675             } else {
4676 642         1219 $tag = $reqTag;
4677             }
4678 883 50 66     2851 $byValue = 1 if $tag =~ s/#$// and $$options{PrintConv};
4679 883 50 66     7430 if (defined $$tagHash{$reqTag} and not $doDups) {
    100 66        
    100          
    50          
    0          
4680 0         0 $matches[0] = $tag;
4681             } elsif ($tag =~ /^(\*|all)$/i) {
4682             # tag name of '*' or 'all' matches all tags
4683 139 100 66     675 if ($doDups or $allGrp) {
4684 138         4848 @matches = grep(!/#/, keys %$tagHash);
4685             } else {
4686 1         47 @matches = grep(!/ /, keys %$tagHash);
4687             }
4688 139 50       869 next unless @matches; # don't want entry in list for '*' tag
4689 139         366 $allTag = 1;
4690             } elsif ($tag =~ /[*?]/) {
4691             # allow wildcards in tag names
4692 5         30 $tag =~ s/\*/[-\\w]*/g;
4693 5         19 $tag =~ s/\?/[-\\w]/g;
4694 5 50 33     29 $tag .= '( \\(.*)?' if $doDups or $allGrp;
4695 5         1102 @matches = grep(/^$tag$/i, keys %$tagHash);
4696 5 50       64 next unless @matches; # don't want entry in list for wildcard tags
4697 5         22 $allTag = 1;
4698             } elsif ($doDups or defined $group) {
4699             # must also look for tags like "Tag (1)"
4700             # (but be sure not to match temporary ValueConv entries like "Tag #")
4701 739         53242 @matches = grep(/^$tag( \(|$)/i, keys %$tagHash);
4702             } elsif ($tag =~ /^[-\w]+$/) {
4703             # find first matching value
4704             # (use in list context to return value instead of count)
4705 0         0 ($matches[0]) = grep /^$tag$/i, keys %$tagHash;
4706 0 0       0 defined $matches[0] or undef @matches;
4707             } else {
4708 0         0 $self->Warn("Invalid tag name '${tag}'");
4709             }
4710 883 100 66     5833 if (defined $group and not $allGrp) {
4711             # keep only specified group
4712 241         938 @matches = $et->GroupMatches($group, \@matches);
4713 241 100 100     1226 next unless @matches or not $allTag;
4714             }
4715 868 100       3288 if (@matches > 1) {
    100          
4716             # maintain original file order for multiple tags
4717 146         979 @matches = sort { $$fileOrder{$a} <=> $$fileOrder{$b} } @matches;
  7915         11214  
4718             # return only the highest priority tag unless duplicates wanted
4719 146 50 66     859 unless ($doDups or $allTag or $allGrp) {
      33        
4720 0         0 $tag = shift @matches;
4721 0   0     0 my $oldPriority = $$et{PRIORITY}{$tag} || 1;
4722 0         0 foreach (@matches) {
4723 0         0 my $priority = $$et{PRIORITY}{$_};
4724 0 0       0 $priority = 1 unless defined $priority;
4725 0 0       0 next unless $priority >= $oldPriority;
4726 0         0 $tag = $_;
4727 0   0     0 $oldPriority = $priority || 1;
4728             }
4729 0         0 @matches = ( $tag );
4730             }
4731             } elsif (not @matches) {
4732             # put entry in return list even without value (value is undef)
4733 445 100       2020 $matches[0] = $byValue ? "$tag #(0)" : "$tag (0)";
4734             # bogus file order entry to avoid warning if sorting in file order
4735 445         1662 $$self{FILE_ORDER}{$matches[0]} = 9999;
4736             }
4737             # copy over necessary information for tags from alternate files
4738 868 100       2300 if ($g8) {
4739 6         34 $self->CopyAltInfo($g8, \@matches);
4740             # restore variables to original values for main file
4741 6         14 $fileOrder = $$self{FILE_ORDER};
4742 6         11 $tagHash = $$self{VALUE};
4743             }
4744             # save indices of tags extracted by value
4745 868 100       1994 push @byValue, scalar(@$rtnTags) .. (scalar(@$rtnTags)+scalar(@matches)-1) if $byValue;
4746             # save indices of wildcard tags
4747 868 100       2662 push @wildTags, scalar(@$rtnTags) .. (scalar(@$rtnTags)+scalar(@matches)-1) if $allTag;
4748 868         3319 push @$rtnTags, @matches;
4749             }
4750             } else {
4751             # no requested tags, so we want all tags
4752 337         767 my @allTags;
4753 337 50       1045 if ($doDups) {
4754 337         720 @allTags = keys %{$$self{VALUE}};
  337         8431  
4755             } else {
4756             # only include tag if it doesn't end in a copy number
4757 0         0 @allTags = grep(!/ /, keys %{$$self{VALUE}});
  0         0  
4758             }
4759 337         1352 $rtnTags = \@allTags;
4760             }
4761              
4762             # filter excluded tags and group options
4763 699   100     5718 while (($exclude or @groupOptions) and @$rtnTags) {
      66        
4764 68 100       257 if ($exclude) {
4765 41         99 my ($pat, %exclude);
4766 41         146 foreach $pat (@$exclude) {
4767 57         117 my $group;
4768 57 100       323 if ($pat =~ /^(.*):(.+)/) {
4769 30         149 ($group, $tag) = ($1, $2);
4770 30 50       327 if ($group =~ /^(\*|all)$/i) {
    50          
4771 0         0 undef $group;
4772             } elsif ($group !~ /^[-\w:]*$/) {
4773 0         0 $self->Warn("Invalid group name '${group}'");
4774 0         0 $group = 'invalid';
4775             }
4776             } else {
4777 27         52 $tag = $pat;
4778             }
4779 57         125 my @matches;
4780 57 100       291 if ($tag =~ /^(\*|all)$/i) {
4781 30         219 @matches = @$rtnTags;
4782             } else {
4783             # allow wildcards in tag names
4784 27         79 $tag =~ s/\*/[-\\w]*/g;
4785 27         58 $tag =~ s/\?/[-\\w]/g;
4786 27         2629 @matches = grep(/^$tag( |$)/i, @$rtnTags);
4787             }
4788 57 100 66     400 @matches = $self->GroupMatches($group, \@matches) if $group and @matches;
4789 57         496 $exclude{$_} = 1 foreach @matches;
4790             }
4791 41 50       160 if (%exclude) {
4792             # remove excluded tags from return list(s)
4793 41         267 RemoveTagsFromList($rtnTags, \@byValue, \@wildTags, \%exclude);
4794 41 50       185 last unless @$rtnTags; # all done if nothing left
4795             }
4796 41 100 66     345 last if $duplicates and not @groupOptions;
4797             }
4798             # filter groups if requested, or to remove duplicates
4799 28         63 my (%keepTags, %wantGroup, $family, $groupOpt);
4800 28         88 my $allGroups = 1;
4801             # build hash of requested/excluded group names for each group family
4802 28         56 my $wantOrder = 0;
4803 28         73 foreach $groupOpt (@groupOptions) {
4804 29 50       167 $groupOpt =~ /^Group(\d*(:\d+)*)/ or next;
4805 29   100     128 $family = $1 || 0;
4806 29 50       131 $wantGroup{$family} or $wantGroup{$family} = { };
4807 29         58 my $groupList;
4808 29 100       101 if (ref $$options{$groupOpt} eq 'ARRAY') {
4809 4         12 $groupList = $$options{$groupOpt};
4810             } else {
4811 25         70 $groupList = [ $$options{$groupOpt} ];
4812             }
4813 29         76 foreach (@$groupList) {
4814             # groups have priority in order they were specified
4815 33         54 ++$wantOrder;
4816 33         53 my ($groupName, $want);
4817 33 100       95 if (/^-(.*)/) {
4818             # excluded group begins with '-'
4819 2         6 $groupName = $1;
4820 2         5 $want = 0; # we don't want tags in this group
4821             } else {
4822 31         50 $groupName = $_;
4823 31         48 $want = $wantOrder; # we want tags in this group
4824 31         47 $allGroups = 0; # don't want all groups if we requested one
4825             }
4826 33         139 $wantGroup{$family}{$groupName} = $want;
4827             }
4828             }
4829             # loop through all tags and decide which ones we want
4830 28         72 my (@tags, %bestTag);
4831 28         75 GR_TAG: foreach $tag (@$rtnTags) {
4832 4505         5759 my $wantTag = $allGroups; # want tag by default if want all groups
4833 4505         7757 foreach $family (keys %wantGroup) {
4834 4676         8128 my $group = $self->GetGroup($tag, $family);
4835 4676         8121 my $wanted = $wantGroup{$family}{$group};
4836 4676 100       9352 next unless defined $wanted;
4837 1212 100       2050 next GR_TAG unless $wanted; # skip tag if group excluded
4838             # take lowest non-zero want flag
4839 1035 50 33     2193 next if $wantTag and $wantTag < $wanted;
4840 1035         1623 $wantTag = $wanted;
4841             }
4842 4328 100       8276 next unless $wantTag;
4843 1047 100       2179 $duplicates and $keepTags{$tag} = 1, next;
4844             # determine which tag we want to keep
4845 665         968 my $tagName = GetTagName($tag);
4846 665         1133 my $bestTag = $bestTag{$tagName};
4847 665 100       1143 if (defined $bestTag) {
4848 28 100       105 next if $wantTag > $keepTags{$bestTag};
4849 14 50       34 if ($wantTag == $keepTags{$bestTag}) {
4850             # want two tags with the same name -- keep the latest one
4851 0 0       0 if ($tag =~ / \((\d+)\)$/) {
4852 0         0 my $tagNum = $1;
4853 0 0 0     0 next if $bestTag !~ / \((\d+)\)$/ or $1 > $tagNum;
4854             }
4855             }
4856             # this tag is better, so delete old best tag
4857 14         26 delete $keepTags{$bestTag};
4858             }
4859 651         1132 $keepTags{$tag} = $wantTag; # keep this tag (for now...)
4860 651         1347 $bestTag{$tagName} = $tag; # this is our current best tag
4861             }
4862             # include only tags we want to keep in return lists
4863 28         208 RemoveTagsFromList($rtnTags, \@byValue, \@wildTags, \%keepTags, 1);
4864 28         214 last;
4865             }
4866 699         2615 $$self{FOUND_TAGS} = $rtnTags; # save found tags
4867              
4868             # return reference to found tag keys (and list of indices of tags to extract by value)
4869 699 50       4751 return wantarray ? ($rtnTags, \@byValue, \@wildTags) : $rtnTags;
4870             }
4871              
4872             #------------------------------------------------------------------------------
4873             # Utility to load our write routines if required (called via AUTOLOAD)
4874             # Inputs: 0) autoload function, 1-N) function arguments
4875             # Returns: result of function or dies if function not available
4876             sub DoAutoLoad(@)
4877             {
4878 737     737 0 2161 my $autoload = shift;
4879 737         4308 my @callInfo = split(/::/, $autoload);
4880 737         2125 my $file = 'Image/ExifTool/Write';
4881              
4882 737 100       136225 return if $callInfo[$#callInfo] eq 'DESTROY';
4883 247 100       1187 if (@callInfo == 4) {
    100          
4884             # load Image/ExifTool/WriteMODULE.pl
4885 187         654 $file .= "$callInfo[2].pl";
4886             } elsif ($callInfo[-1] eq 'ShiftTime') {
4887 1         4 $file = 'Image/ExifTool/Shift.pl'; # load Shift.pl
4888             } else {
4889             # load Image/ExifTool/Writer.pl
4890 59         218 $file .= 'r.pl';
4891             }
4892             # attempt to load the package
4893 247 50       632 eval { require $file } or die "Error while attempting to call $autoload\n$@\n";
  247         254162  
4894 247 50       2270 unless (defined &$autoload) {
4895 0         0 my @caller = caller(0);
4896             # reproduce Perl's standard 'undefined subroutine' message:
4897 0         0 die "Undefined subroutine $autoload called at $caller[1] line $caller[2]\n";
4898             }
4899 106     106   1230 no strict 'refs';
  106         295  
  106         135700  
4900 247         1861 return &$autoload(@_); # call the function
4901             }
4902              
4903             #------------------------------------------------------------------------------
4904             # AutoLoad our writer routines when necessary
4905             #
4906             sub AUTOLOAD
4907             {
4908 550     550   362069 return DoAutoLoad($AUTOLOAD, @_);
4909             }
4910              
4911             #------------------------------------------------------------------------------
4912             # Add warning tag
4913             # Inputs: 0) ExifTool object reference, 1) warning message
4914             # 2) true if minor (2 if behaviour changes when warning is ignored,
4915             # or 3 if warning shouldn't be issued when Validate option is used)
4916             # Returns: true if warning tag was added
4917             sub Warn($$;$)
4918             {
4919 87     87 0 300 my ($self, $str, $ignorable) = @_;
4920 87 100       344 if ($ignorable) {
4921 32 100       138 return 0 if $$self{OPTIONS}{IgnoreMinorErrors};
4922 31 50 66     136 return 0 if $ignorable eq '3' and $$self{OPTIONS}{Validate};
4923 31 100       143 $str = $ignorable eq '2' ? "[Minor] $str" : "[minor] $str";
4924             }
4925 86         391 $self->FoundTag('Warning', $str);
4926 86         336 return 1;
4927             }
4928              
4929             #------------------------------------------------------------------------------
4930             # Add warning tag only once per processed file
4931             # Inputs: 0) ExifTool object reference, 1) warning message, 2) true if minor
4932             # Returns: true if warning tag was added
4933             sub WarnOnce($$;$)
4934             {
4935 48     48 0 173 my ($self, $str, $ignorable) = @_;
4936 48 50 66     217 return 0 if $ignorable and $$self{OPTIONS}{IgnoreMinorErrors};
4937 48 100       222 unless ($$self{WARNED_ONCE}{$str}) {
4938 41         215 $self->Warn($str, $ignorable);
4939 41         236 $$self{WARNED_ONCE}{$str} = 1;
4940             }
4941 48         153 return 1;
4942             }
4943              
4944             #------------------------------------------------------------------------------
4945             # Add error tag
4946             # Inputs: 0) ExifTool object reference, 1) error message, 2) true if minor
4947             # Returns: true if error tag was added, otherwise warning was added
4948             sub Error($$;$)
4949             {
4950 1     1 0 5 my ($self, $str, $ignorable) = @_;
4951 1 50       19 if ($$self{DemoteErrors}) {
    50          
4952 0 0       0 $self->Warn($str) and ++$$self{DemoteErrors};
4953 0         0 return 1;
4954             } elsif ($ignorable) {
4955 1 50       11 $$self{OPTIONS}{IgnoreMinorErrors} and $self->Warn($str), return 0;
4956 0         0 $str = "[minor] $str";
4957             }
4958 0         0 $self->FoundTag('Error', $str);
4959 0         0 return 1;
4960             }
4961              
4962             #------------------------------------------------------------------------------
4963             # Expand shortcuts
4964             # Inputs: 0) reference to list of tags, 1) set to remove trailing '#'
4965             # Notes: Handles leading '-' for excluded tags, trailing '#' for ValueConv,
4966             # multiple group names, and redirected tags
4967             sub ExpandShortcuts($;$)
4968             {
4969 516     516 0 1485 my ($tagList, $removeSuffix) = @_;
4970 516 50 33     2760 return unless $tagList and @$tagList;
4971              
4972 516         29445 require Image::ExifTool::Shortcuts;
4973              
4974             # expand shortcuts
4975 516 100       2032 my $suffix = $removeSuffix ? '' : '#';
4976 516         965 my @expandedTags;
4977 516         1332 my ($entry, $tag, $excl);
4978 516         1465 foreach $entry (@$tagList) {
4979             # skip things like options hash references in list
4980 1057 100       2637 if (ref $entry) {
4981 1         8 push @expandedTags, $entry;
4982 1         4 next;
4983             }
4984             # remove leading '-'
4985 1056         5666 ($excl, $tag) = $entry =~ /^(-?)(.*)/s;
4986 1056         2286 my ($post, @post, $pre, $v);
4987             # handle redirection
4988 1056 100 100     11260 if (not $excl and $tag =~ /(.+?)([-+]?[<>].+)/s) {
4989 30         136 ($tag, $post) = ($1, $2);
4990 30 100 100     245 if ($post =~ /^[-+]?>/ or $post !~ /\$/) {
4991             # expand shortcuts in postfix (rhs of redirection)
4992 23         157 my ($op, $p2, $t2) = ($post =~ /([-+]?[<>])(.+:)?(.+)/);
4993 23 100       85 $p2 = '' unless defined $p2;
4994 23 50       102 $v = ($t2 =~ s/#$//) ? $suffix : ''; # ValueConv suffix
4995 23         462 my ($match) = grep /^\Q$t2\E$/i, keys %Image::ExifTool::Shortcuts::Main;
4996 23 50       117 if ($match) {
4997 0         0 foreach (@{$Image::ExifTool::Shortcuts::Main{$match}}) {
  0         0  
4998 0 0       0 /^-/ and next; # ignore excluded tags
4999 0 0 0     0 if ($p2 and /(.+:)(.+)/) {
5000 0         0 push @post, "$op$_$v";
5001             } else {
5002 0         0 push @post, "$op$p2$_$v";
5003             }
5004             }
5005 0 0       0 next unless @post;
5006 0         0 $post = shift @post;
5007             }
5008             }
5009             } else {
5010 1026         2255 $post = '';
5011             }
5012             # handle group names
5013 1056 100       3567 if ($tag =~ /(.+:)(.+)/) {
5014 309         1296 ($pre, $tag) = ($1, $2);
5015             } else {
5016 747         1304 $pre = '';
5017             }
5018 1056 100       2946 $v = ($tag =~ s/#$//) ? $suffix : ''; # ValueConv suffix
5019             # loop over all postfixes
5020 1056         1762 for (;;) {
5021             # expand the tag name
5022 1056         21778 my ($match) = grep /^\Q$tag\E$/i, keys %Image::ExifTool::Shortcuts::Main;
5023 1056 100       3713 if ($match) {
5024 17 50 66     321 if ($excl) {
    100 66        
5025             # entry starts with '-', so exclude all tags in this shortcut
5026 0         0 foreach (@{$Image::ExifTool::Shortcuts::Main{$match}}) {
  0         0  
5027 0 0       0 /^-/ and next; # ignore excluded exclude tags
5028             # group of expanded tag takes precedence
5029 0 0 0     0 if ($pre and /(.+:)(.+)/) {
5030 0         0 push @expandedTags, "$excl$_";
5031             } else {
5032 0         0 push @expandedTags, "$excl$pre$_";
5033             }
5034             }
5035             } elsif (length $pre or length $post or $v) {
5036 1         3 foreach (@{$Image::ExifTool::Shortcuts::Main{$match}}) {
  1         5  
5037 12         41 /(-?)(.+:)?(.+)/;
5038 12 50       24 if ($2) {
5039             # group from expanded tag takes precedence
5040 0         0 push @expandedTags, "$_$v$post";
5041             } else {
5042 12         36 push @expandedTags, "$1$pre$3$v$post";
5043             }
5044             }
5045             } else {
5046 16         62 push @expandedTags, @{$Image::ExifTool::Shortcuts::Main{$match}};
  16         80  
5047             }
5048             } else {
5049 1039         3548 push @expandedTags, "$excl$pre$tag$v$post";
5050             }
5051 1056 50       3887 last unless @post;
5052 0         0 $post = shift @post;
5053             }
5054             }
5055 516         2531 @$tagList = @expandedTags;
5056             }
5057              
5058             #------------------------------------------------------------------------------
5059             # Add hash of Composite tags to our composites
5060             # Inputs: 0) hash reference to table of Composite tags to add or module name,
5061             # 1) override existing tag definition
5062             sub AddCompositeTags($;$)
5063             {
5064 592     592 0 2006 local $_;
5065 592         2365 my ($add, $override) = @_;
5066 592         1605 my ($module, $prefix, $tagID);
5067 592 50       2586 unless (ref $add) {
5068 592         6705 ($prefix = $add) =~ s/.*:://;
5069 592         1676 $module = $add;
5070 592         2082 $add .= '::Composite';
5071 106     106   928 no strict 'refs';
  106         257  
  106         969327  
5072 592         3225 $add = \%$add;
5073 592         1839 $prefix .= '-';
5074             } else {
5075 0         0 $prefix = 'UserDefined-';
5076             }
5077 592         1888 my $defaultGroups = $$add{GROUPS};
5078 592         2761 my $compTable = GetTagTable('Image::ExifTool::Composite');
5079              
5080             # make sure default groups are defined in families 0 and 1
5081 592 100       1955 if ($defaultGroups) {
5082 495 100       2554 $$defaultGroups{0} or $$defaultGroups{0} = 'Composite';
5083 495 100       2068 $$defaultGroups{1} or $$defaultGroups{1} = 'Composite';
5084 495 50       1845 $$defaultGroups{2} or $$defaultGroups{2} = 'Other';
5085             } else {
5086 97         778 $defaultGroups = $$add{GROUPS} = { 0 => 'Composite', 1 => 'Composite', 2 => 'Other' };
5087             }
5088 592         2402 SetupTagTable($add); # generate Name, TagID, etc
5089 592         6336 foreach $tagID (sort keys %$add) {
5090 5730 100       12367 next if $specialTags{$tagID}; # must skip special tags
5091 5135         8159 my $tagInfo = $$add{$tagID};
5092 5135         11764 my $new = $prefix . $tagID; # new tag ID for Composite table
5093 5135 100       10673 $$tagInfo{Module} = $module if $$tagInfo{Writable};
5094 5135 50 33     10248 $$tagInfo{Override} = 1 if $override and not defined $$tagInfo{Override};
5095 5135         9430 $$tagInfo{IsComposite} = 1;
5096             # handle Composite tags with the same name
5097 5135 100       11149 if ($compositeID{$tagID}) {
5098             # determine if we want to override this tag
5099             # (=0 keep both, >0 override, <0 keep existing)
5100 344   50     5018 my $over = ($$tagInfo{Override} || 0) - ($$compTable{$compositeID{$tagID}[0]}{Override} || 0);
      50        
5101 344 50       1061 next if $over < 0;
5102 344 50       1181 if ($over) {
5103             # remove existing tags with this ID
5104 0         0 delete $$compTable{$_} foreach @{$compositeID{$tagID}};
  0         0  
5105 0         0 delete $compositeID{$tagID};
5106             }
5107             }
5108             # make sure new TagID is unique by adding index if necessary
5109             # (could only happen for UserDefined tags now that module name is added to tag ID)
5110 5135         7034 my $n = 0;
5111 5135         11335 while ($$compTable{$new}) {
5112 0 0       0 $new =~ s/-\d+$// if $n++;
5113 0         0 $new .= "-$n";
5114             }
5115             # use new ID and save it so we can use it in TagLookup
5116 5135 50       13486 $$tagInfo{NewTagID} = $new unless $tagID eq $new;
5117              
5118             # add new ID to lookup of Composite tag ID's
5119 5135 100       14182 $compositeID{$tagID} = [ ] unless $compositeID{$tagID};
5120 5135         7444 unshift @{$compositeID{$tagID}}, $new; # (most recent one first)
  5135         13056  
5121              
5122             # convert scalar Require/Desire/Inhibit entries
5123 5135         8408 my ($type, @hashes, @scalars, %used);
5124 5135         8089 foreach $type ('Require','Desire','Inhibit') {
5125 15405 100       32233 my $req = $$tagInfo{$type} or next;
5126 6729 100       9358 push @{ref($req) eq 'HASH' ? \@hashes : \@scalars}, $type;
  6729         18154  
5127             }
5128 5135 100       10363 if (@scalars) {
5129             # make lookup for indices that are used
5130 952         2172 foreach $type (@hashes) {
5131 106         448 $used{$_} = 1 foreach keys %{$$tagInfo{$type}};
  106         1566  
5132             }
5133 952         1678 my $next = 0;
5134 952         1720 foreach $type (@scalars) {
5135 952         2429 ++$next while $used{$next};
5136 952         3691 $$tagInfo{$type} = { $next++ => $$tagInfo{$type} };
5137             }
5138             }
5139             # add this Composite tag to our main Composite table
5140 5135         8335 $$tagInfo{Table} = $compTable;
5141             # (use the original TagID, even if we changed it, so don't do this:)
5142 5135         7610 $$tagInfo{TagID} = $new;
5143             # save tag under new ID in Composite table
5144 5135         13516 $$compTable{$new} = $tagInfo;
5145             # set all default groups in tag
5146 5135         7551 my $groups = $$tagInfo{Groups};
5147 5135 100       11661 $groups or $groups = $$tagInfo{Groups} = { };
5148             # fill in default groups
5149 5135         12939 foreach (keys %$defaultGroups) {
5150 15405 100       34602 $$groups{$_} or $$groups{$_} = $$defaultGroups{$_};
5151             }
5152             # set flag indicating group list was built
5153 5135         14196 $$tagInfo{GotGroups} = 1;
5154             }
5155             }
5156              
5157             #------------------------------------------------------------------------------
5158             # Add tags to TagLookup (used for writing)
5159             # Inputs: 0) source hash of tag definitions, 1) name of destination tag table
5160             sub AddTagsToLookup($$)
5161             {
5162 1     1 0 3 my ($tagHash, $table) = @_;
5163 1 50       7 if (defined &Image::ExifTool::TagLookup::AddTags) {
    50          
5164 0         0 Image::ExifTool::TagLookup::AddTags($tagHash, $table);
5165             } elsif (not $Image::ExifTool::pluginTags{$tagHash}) {
5166             # queue these tags until TagLookup is loaded
5167 1         5 push @Image::ExifTool::pluginTags, [ $tagHash, $table ];
5168             # set flag so we don't load same tags twice
5169 1         4 $Image::ExifTool::pluginTags{$tagHash} = 1;
5170             }
5171             }
5172              
5173             #------------------------------------------------------------------------------
5174             # Expand tagInfo Flags
5175             # Inputs: 0) tagInfo hash ref
5176             # Notes: $$tagInfo{Flags} must be defined to call this routine
5177             sub ExpandFlags($)
5178             {
5179 4855     4855 0 7455 my $tagInfo = shift;
5180 4855         7769 my $flags = $$tagInfo{Flags};
5181 4855 100       11417 if (ref $flags eq 'ARRAY') {
    50          
5182 2518         5448 foreach (@$flags) {
5183 6706         15502 $$tagInfo{$_} = 1;
5184             }
5185             } elsif (ref $flags eq 'HASH') {
5186 0         0 my $key;
5187 0         0 foreach $key (keys %$flags) {
5188 0         0 $$tagInfo{$key} = $$flags{$key};
5189             }
5190             } else {
5191 2337         5603 $$tagInfo{$flags} = 1;
5192             }
5193             }
5194              
5195             #------------------------------------------------------------------------------
5196             # Set up tag table (must be done once for each tag table used)
5197             # Inputs: 0) Reference to tag table
5198             # Notes: - generates 'Name' field from key if it doesn't exist
5199             # - stores 'Table' pointer and 'TagID' value
5200             # - expands 'Flags' for quick lookup
5201             sub SetupTagTable($)
5202             {
5203 5164     5164 0 8801 my $tagTablePtr = shift;
5204 5164         9619 my $avoid = $$tagTablePtr{AVOID};
5205 5164         8742 my ($tagID, $tagInfo);
5206 5164         11892 foreach $tagID (TagTableKeys($tagTablePtr)) {
5207 206255         320861 my @infoArray = GetTagInfoList($tagTablePtr,$tagID);
5208             # process conditional tagInfo arrays
5209 206255         297948 foreach $tagInfo (@infoArray) {
5210 227118         415135 $$tagInfo{Table} = $tagTablePtr;
5211 227118         356152 $$tagInfo{TagID} = $tagID;
5212 227118 100       442731 $$tagInfo{Name} or $$tagInfo{Name} = MakeTagName($tagID);
5213 227118 100       387220 $$tagInfo{Flags} and ExpandFlags($tagInfo);
5214 227118 100       367942 $$tagInfo{Avoid} = $avoid if defined $avoid;
5215             # calculate BitShift from Mask if necessary
5216 227118 100 100     447431 if ($$tagInfo{Mask} and not defined $$tagInfo{BitShift}) {
5217 2987         5238 my ($mask, $bitShift) = ($$tagInfo{Mask}, 0);
5218 2987         9802 ++$bitShift until $mask & (1 << $bitShift);
5219 2987         6003 $$tagInfo{BitShift} = $bitShift;
5220             }
5221             }
5222 206255 100       417138 next unless @infoArray > 1;
5223             # add an "Index" member to each tagInfo in a list
5224 3733         6415 my $index = 0;
5225 3733         6188 foreach $tagInfo (@infoArray) {
5226 24596         40000 $$tagInfo{Index} = $index++;
5227             }
5228             }
5229             }
5230              
5231             #------------------------------------------------------------------------------
5232             # Utilities to check for numerical types
5233             # Inputs: 0) value; Returns: true if value is a numerical type
5234             # Notes: May change commas to decimals in floats for use in other locales
5235             sub IsFloat($) {
5236 7836 100   7836 0 85054 return 1 if $_[0] =~ /^[+-]?(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/;
5237             # allow comma separators (for other locales)
5238 2212 50       17963 return 0 unless $_[0] =~ /^[+-]?(?=\d|,\d)\d*(,\d*)?([Ee]([+-]?\d+))?$/;
5239 0         0 $_[0] =~ tr/,/./; # but translate ',' to '.'
5240 0         0 return 1;
5241             }
5242 19845     19845 0 99213 sub IsInt($) { return scalar($_[0] =~ /^[+-]?\d+$/); }
5243 3070     3070 0 12941 sub IsHex($) { return scalar($_[0] =~ /^(0x)?[0-9a-f]{1,8}$/i); }
5244 16     16 0 156 sub IsRational($) { return scalar($_[0] =~ m{^[-+]?\d+/\d+$}); }
5245              
5246             # round floating point value to specified number of significant digits
5247             # Inputs: 0) value, 1) number of sig digits; Returns: rounded number
5248             sub RoundFloat($$)
5249             {
5250 3504     3504 0 6964 my ($val, $sig) = @_;
5251 3504         25109 return sprintf("%.${sig}g", $val);
5252             }
5253              
5254             # Convert strings to floating point numbers (or undef)
5255             # Inputs: 0-N) list of strings (may be undef)
5256             # Returns: last value converted
5257             sub ToFloat(@)
5258             {
5259 992     992 0 2111 local $_;
5260 992         2618 foreach (@_) {
5261 10701 100       19681 next unless defined $_;
5262             # (add 0 to convert "0.0" to "0" for tests)
5263 4048 100       23814 $_ = /((?:[+-]?)(?=\d|\.\d)\d*(?:\.\d*)?(?:[Ee](?:[+-]?\d+))?)/ ? $1 + 0 : undef;
5264             }
5265 992         10261 return $_[-1];
5266             }
5267              
5268             #------------------------------------------------------------------------------
5269             # Utility routines to for reading binary data values from file
5270              
5271             my %unpackMotorola = ( S => 'n', L => 'N', C => 'C', c => 'c' );
5272             my %unpackIntel = ( S => 'v', L => 'V', C => 'C', c => 'c' );
5273             my %unpackRev = ( N => 'V', V => 'N', C => 'C', n => 'v', v => 'n', c => 'c' );
5274              
5275             # the following 4 variables are defined in 'use vars' instead of using 'my'
5276             # because mod_perl 5.6.1 apparently has a problem with setting file-scope 'my'
5277             # variables from within subroutines (ref communication with Pavel Merdin):
5278             # $swapBytes - set if EXIF header is not native byte ordering
5279             # $swapWords - swap 32-bit words in doubles (ARM quirk)
5280             $currentByteOrder = 'MM'; # current byte ordering ('II' or 'MM')
5281             %unpackStd = %unpackMotorola;
5282              
5283             # Swap bytes in data if necessary
5284             # Inputs: 0) data, 1) number of bytes
5285             # Returns: swapped data
5286             sub SwapBytes($$)
5287             {
5288 1362 100   1362 0 3893 return $_[0] unless $swapBytes;
5289 208         510 my ($val, $bytes) = @_;
5290 208         451 my $newVal = '';
5291 208         1555 $newVal .= substr($val, $bytes, 1) while $bytes--;
5292 208         613 return $newVal;
5293             }
5294             # Swap words. Inputs: 8 bytes of data, Returns: swapped data
5295             sub SwapWords($)
5296             {
5297 1300 50 33 1300 0 5007 return $_[0] unless $swapWords and length($_[0]) == 8;
5298 0         0 return substr($_[0],4,4) . substr($_[0],0,4)
5299             }
5300              
5301             # Unpack value, letting unpack() handle byte swapping
5302             # Inputs: 0) unpack template, 1) data reference, 2) offset
5303             # Returns: unpacked number
5304             # - uses value of %unpackStd to determine the unpack template
5305             # - can only be called for 'S' or 'L' templates since these are the only
5306             # templates for which you can specify the byte ordering.
5307             sub DoUnpackStd(@)
5308             {
5309 161690 100   161690 0 409325 $_[2] and return unpack("x$_[2] $unpackStd{$_[0]}", ${$_[1]});
  157296         408611  
5310 4394         8807 return unpack($unpackStd{$_[0]}, ${$_[1]});
  4394         17601  
5311             }
5312             # same, but with reversed byte order
5313             sub DoUnpackRev(@)
5314             {
5315 12     12 0 26 my $fmt = $unpackRev{$unpackStd{$_[0]}};
5316 12 50       35 $_[2] and return unpack("x$_[2] $fmt", ${$_[1]});
  12         36  
5317 0         0 return unpack($fmt, ${$_[1]});
  0         0  
5318             }
5319             # Pack value
5320             # Inputs: 0) template, 1) value, 2) data ref (or undef), 3) offset (if data ref)
5321             # Returns: packed value
5322             sub DoPackStd(@)
5323             {
5324 32327     32327 0 65554 my $val = pack($unpackStd{$_[0]}, $_[1]);
5325 32327 100       57829 $_[2] and substr(${$_[2]}, $_[3], length($val)) = $val;
  7812         13810  
5326 32327         80677 return $val;
5327             }
5328             # same, but with reversed byte order
5329             sub DoPackRev(@)
5330             {
5331 0     0 0 0 my $val = pack($unpackRev{$unpackStd{$_[0]}}, $_[1]);
5332 0 0       0 $_[2] and substr(${$_[2]}, $_[3], length($val)) = $val;
  0         0  
5333 0         0 return $val;
5334             }
5335              
5336             # Unpack value, handling the byte swapping manually
5337             # Inputs: 0) # bytes, 1) unpack template, 2) data reference, 3) offset
5338             # Returns: unpacked number
5339             # - uses value of $swapBytes to determine byte ordering
5340             sub DoUnpack(@)
5341             {
5342 27825     27825 0 47255 my ($bytes, $template, $dataPt, $pos) = @_;
5343 27825         35006 my $val;
5344 27825 100       44518 if ($swapBytes) {
5345 5390         7643 $val = '';
5346 5390         25144 $val .= substr($$dataPt,$pos+$bytes,1) while $bytes--;
5347             } else {
5348 22435         38187 $val = substr($$dataPt,$pos,$bytes);
5349             }
5350 27825 50       49338 defined($val) or return undef;
5351 27825         64937 return unpack($template,$val);
5352             }
5353              
5354             # Unpack double value
5355             # Inputs: 0) unpack template, 1) data reference, 2) offset
5356             # Returns: unpacked number
5357             sub DoUnpackDbl(@)
5358             {
5359 1236     1236 0 2272 my ($template, $dataPt, $pos) = @_;
5360 1236         2402 my $val = substr($$dataPt,$pos,8);
5361 1236 50       2415 defined($val) or return undef;
5362             # swap bytes and 32-bit words (ARM quirk) if necessary, then unpack value
5363 1236         2406 return unpack($template, SwapWords(SwapBytes($val, 8)));
5364             }
5365              
5366             # Inputs: 0) data reference, 1) offset into data
5367 135     135 0 523 sub Get8s($$) { return DoUnpackStd('c', @_); }
5368 7847     7847 0 15656 sub Get8u($$) { return DoUnpackStd('C', @_); }
5369 14954     14954 0 28075 sub Get16s($$) { return DoUnpack(2, 's', @_); }
5370 78543     78543 0 140493 sub Get16u($$) { return DoUnpackStd('S', @_); }
5371 12182     12182 0 22167 sub Get32s($$) { return DoUnpack(4, 'l', @_); }
5372 75165     75165 0 133573 sub Get32u($$) { return DoUnpackStd('L', @_); }
5373 689     689 0 2053 sub GetFloat($$) { return DoUnpack(4, 'f', @_); }
5374 1236     1236 0 2466 sub GetDouble($$) { return DoUnpackDbl('d', @_); }
5375 12     12 0 44 sub Get16uRev($$) { return DoUnpackRev('S', @_); }
5376 0     0 0 0 sub Get32uRev($$) { return DoUnpackRev('L', @_); }
5377              
5378             # rationals may be a floating point number, 'inf' or 'undef'
5379             my ($ratNumer, $ratDenom);
5380             sub GetRational32s($$)
5381             {
5382 12     12 0 33 my ($dataPt, $pos) = @_;
5383 12         31 $ratNumer = Get16s($dataPt,$pos);
5384 12 0       31 $ratDenom = Get16s($dataPt, $pos + 2) or return $ratNumer ? 'inf' : 'undef';
    50          
5385             # round off to a reasonable number of significant figures
5386 12         35 return RoundFloat($ratNumer / $ratDenom, 7);
5387             }
5388             sub GetRational32u($$)
5389             {
5390 12     12 0 29 my ($dataPt, $pos) = @_;
5391 12         31 $ratNumer = Get16u($dataPt,$pos);
5392 12 0       41 $ratDenom = Get16u($dataPt, $pos + 2) or return $ratNumer ? 'inf' : 'undef';
    50          
5393 12         49 return RoundFloat($ratNumer / $ratDenom, 7);
5394             }
5395             sub GetRational64s($$)
5396             {
5397 681     681 0 1997 my ($dataPt, $pos) = @_;
5398 681         1637 $ratNumer = Get32s($dataPt,$pos);
5399 681 0       1875 $ratDenom = Get32s($dataPt, $pos + 4) or return $ratNumer ? 'inf' : 'undef';
    50          
5400 681         2257 return RoundFloat($ratNumer / $ratDenom, 10);
5401             }
5402             sub GetRational64u($$)
5403             {
5404 2831     2831 0 5432 my ($dataPt, $pos) = @_;
5405 2831         5475 $ratNumer = Get32u($dataPt,$pos);
5406 2831 50       6697 $ratDenom = Get32u($dataPt, $pos + 4) or return $ratNumer ? 'inf' : 'undef';
    100          
5407 2799         8823 return RoundFloat($ratNumer / $ratDenom, 10);
5408             }
5409             sub GetFixed16s($$)
5410             {
5411 13     13 0 48 my ($dataPt, $pos) = @_;
5412 13         54 my $val = Get16s($dataPt, $pos) / 0x100;
5413 13 50       76 return int($val * 1000 + ($val<0 ? -0.5 : 0.5)) / 1000;
5414             }
5415             sub GetFixed16u($$)
5416             {
5417 0     0 0 0 my ($dataPt, $pos) = @_;
5418 0         0 return int((Get16u($dataPt, $pos) / 0x100) * 1000 + 0.5) / 1000;
5419             }
5420             sub GetFixed32s($$)
5421             {
5422 1754     1754 0 3018 my ($dataPt, $pos) = @_;
5423 1754         2886 my $val = Get32s($dataPt, $pos) / 0x10000;
5424             # remove insignificant digits
5425 1754 100       5396 return int($val * 1e5 + ($val>0 ? 0.5 : -0.5)) / 1e5;
5426             }
5427             sub GetFixed32u($$)
5428             {
5429 156     156 0 375 my ($dataPt, $pos) = @_;
5430             # remove insignificant digits
5431 156         342 return int((Get32u($dataPt, $pos) / 0x10000) * 1e5 + 0.5) / 1e5;
5432             }
5433             # Inputs: 0) value, 1) data ref, 2) offset
5434 5     5 0 17 sub Set8s(@) { return DoPackStd('c', @_); }
5435 291     291 0 726 sub Set8u(@) { return DoPackStd('C', @_); }
5436 13009     13009 0 22991 sub Set16u(@) { return DoPackStd('S', @_); }
5437 19022     19022 0 34506 sub Set32u(@) { return DoPackStd('L', @_); }
5438 0     0 0 0 sub Set16uRev(@) { return DoPackRev('S', @_); }
5439              
5440             #------------------------------------------------------------------------------
5441             # Get current byte order ('II' or 'MM')
5442 14264     14264 0 39048 sub GetByteOrder() { return $currentByteOrder; }
5443              
5444             #------------------------------------------------------------------------------
5445             # Set byte ordering
5446             # Inputs: 0) 'MM'=motorola, 'II'=intel (will translate 'BigEndian', 'LittleEndian')
5447             # Returns: 1 on success
5448             sub SetByteOrder($)
5449             {
5450 15484     15484 0 28384 my $order = shift;
5451              
5452 15484 100       40375 if ($order eq 'MM') { # big endian (Motorola)
    100          
    100          
    100          
5453 7870         35794 %unpackStd = %unpackMotorola;
5454             } elsif ($order eq 'II') { # little endian (Intel)
5455 7419         34676 %unpackStd = %unpackIntel;
5456             } elsif ($order =~ /^Big/i) {
5457 15         50 $order = 'MM';
5458 15         98 %unpackStd = %unpackMotorola;
5459             } elsif ($order =~ /^Little/i) {
5460 12         37 $order = 'II';
5461 12         107 %unpackStd = %unpackIntel;
5462             } else {
5463 168         664 return 0;
5464             }
5465 15316         39499 my $val = unpack('S','A ');
5466 15316         22765 my $nativeOrder;
5467 15316 50       35512 if ($val == 0x4120) { # big endian
    50          
5468 0         0 $nativeOrder = 'MM';
5469             } elsif ($val == 0x2041) { # little endian
5470 15316         23832 $nativeOrder = 'II';
5471             } else {
5472 0         0 warn sprintf("Unknown native byte order! (pattern %x)\n",$val);
5473 0         0 return 0;
5474             }
5475 15316         24233 $currentByteOrder = $order; # save current byte order
5476              
5477             # swap bytes if our native CPU byte ordering is not the same as the EXIF
5478 15316         24405 $swapBytes = ($order ne $nativeOrder);
5479              
5480             # little-endian ARM has big-endian words for doubles (thanks Riku Voipio)
5481             # (Note: Riku's patch checked for '0ff3', but I think it should be 'f03f' since
5482             # 1 is '000000000000f03f' on an x86 -- so check for both, but which is correct?)
5483 15316         23089 my $pack1d = pack('d', 1);
5484 15316   33     49375 $swapWords = ($pack1d eq "\0\0\x0f\xf3\0\0\0\0" or
5485             $pack1d eq "\0\0\xf0\x3f\0\0\0\0");
5486 15316         32915 return 1;
5487             }
5488              
5489             #------------------------------------------------------------------------------
5490             # Change byte order
5491             sub ToggleByteOrder()
5492             {
5493 39 100   39 0 137 SetByteOrder(GetByteOrder() eq 'II' ? 'MM' : 'II');
5494             }
5495              
5496             #------------------------------------------------------------------------------
5497             # hash lookups for reading values from data
5498             my %formatSize = (
5499             int8s => 1,
5500             int8u => 1,
5501             int16s => 2,
5502             int16u => 2,
5503             int16uRev => 2,
5504             int32s => 4,
5505             int32u => 4,
5506             int32uRev => 4,
5507             int64s => 8,
5508             int64u => 8,
5509             rational32s => 4,
5510             rational32u => 4,
5511             rational64s => 8,
5512             rational64u => 8,
5513             fixed16s => 2,
5514             fixed16u => 2,
5515             fixed32s => 4,
5516             fixed32u => 4,
5517             fixed64s => 8,
5518             float => 4,
5519             double => 8,
5520             extended => 10,
5521             unicode => 2,
5522             complex => 8,
5523             string => 1,
5524             binary => 1,
5525             'undef' => 1,
5526             ifd => 4,
5527             ifd64 => 8,
5528             ue7 => 1,
5529             );
5530             my %readValueProc = (
5531             int8s => \&Get8s,
5532             int8u => \&Get8u,
5533             int16s => \&Get16s,
5534             int16u => \&Get16u,
5535             int16uRev => \&Get16uRev,
5536             int32s => \&Get32s,
5537             int32u => \&Get32u,
5538             int32uRev => \&Get32uRev,
5539             int64s => \&Get64s,
5540             int64u => \&Get64u,
5541             rational32s => \&GetRational32s,
5542             rational32u => \&GetRational32u,
5543             rational64s => \&GetRational64s,
5544             rational64u => \&GetRational64u,
5545             fixed16s => \&GetFixed16s,
5546             fixed16u => \&GetFixed16u,
5547             fixed32s => \&GetFixed32s,
5548             fixed32u => \&GetFixed32u,
5549             fixed64s => \&GetFixed64s,
5550             float => \&GetFloat,
5551             double => \&GetDouble,
5552             extended => \&GetExtended,
5553             ifd => \&Get32u,
5554             ifd64 => \&Get64u,
5555             );
5556             # lookup for all rational types
5557             my %isRational = (
5558             rational32u => 1,
5559             rational32s => 1,
5560             rational64u => 1,
5561             rational64s => 1,
5562             );
5563 1570     1570 0 4563 sub FormatSize($) { return $formatSize{$_[0]}; }
5564              
5565             #------------------------------------------------------------------------------
5566             # Read value from binary data (with current byte ordering)
5567             # Inputs: 0) data reference, 1) value offset, 2) format string,
5568             # 3) number of values (or undef to use all data),
5569             # 4) valid data length relative to offset (or undef to use all data),
5570             # 5) optional pointer to returned rational
5571             # Returns: converted value, or undefined if data isn't there
5572             # or list of values in list context
5573             sub ReadValue($$$;$$$)
5574             {
5575 36561     36561 0 80475 my ($dataPt, $offset, $format, $count, $size, $ratPt) = @_;
5576              
5577 36561         66450 my $len = $formatSize{$format};
5578 36561 50       69550 unless ($len) {
5579 0         0 warn "Unknown format $format";
5580 0         0 $len = 1;
5581             }
5582 36561 50       68734 $size = length($$dataPt) - $offset unless defined $size;
5583 36561 100       66557 unless ($count) {
5584 1360 100 100     5133 return '' if defined $count or $size < $len;
5585 1331         2864 $count = int($size / $len);
5586             }
5587             # make sure entry is inside data
5588 36532 100       75146 if ($len * $count > $size) {
5589 3         25 $count = int($size / $len); # shorten count if necessary
5590 3 50       27 $count < 1 and return undef; # return undefined if no data
5591             }
5592 36529         50431 my @vals;
5593 36529         60804 my $proc = $readValueProc{$format};
5594 36529 100 100     105977 if (not $proc) {
    100          
5595             # handle undef/binary/string (also unsupported unicode/complex)
5596 6411         20203 $vals[0] = substr($$dataPt, $offset, $count * $len);
5597             # truncate string at null terminator if necessary
5598 6411 100       29805 $vals[0] =~ s/\0.*//s if $format eq 'string';
5599             } elsif ($isRational{$format} and $ratPt) {
5600             # store rationals separately as string fractions
5601 3141         4842 my @rat;
5602 3141         4841 for (;;) {
5603 3448         8942 push @vals, &$proc($dataPt, $offset);
5604 3448         9822 push @rat, "$ratNumer/$ratDenom";
5605 3448 100       8827 last if --$count <= 0;
5606 307         511 $offset += $len;
5607             }
5608 3141         8740 $$ratPt = join(' ',@rat);
5609             } else {
5610 26977         38436 for (;;) {
5611 49437         91993 push @vals, &$proc($dataPt, $offset);
5612 49437 100       107701 last if --$count <= 0;
5613 22460         29273 $offset += $len;
5614             }
5615             }
5616 36529 100       75818 return @vals if wantarray;
5617 36117 100       94687 return join(' ', @vals) if @vals > 1;
5618 32480         77918 return $vals[0];
5619             }
5620              
5621             #------------------------------------------------------------------------------
5622             # Decode string with specified encoding
5623             # Inputs: 0) ExifTool object ref, 1) string to decode
5624             # 2) source character set name (undef for current Charset)
5625             # 3) optional source byte order (2-byte and 4-byte fixed-width sets only)
5626             # 4) optional destination character set (defaults to Charset setting)
5627             # 5) optional destination byte order (2-byte and 4-byte fixed-width only)
5628             # Returns: string in destination encoding
5629             # Note: ExifTool ref may be undef if character both character sets are provided
5630             # (but in this case no warnings will be issued)
5631             sub Decode($$$;$$$)
5632             {
5633 6237     6237 0 14401 my ($self, $val, $from, $fromOrder, $to, $toOrder) = @_;
5634 6237 100       12689 $from or $from = $$self{OPTIONS}{Charset};
5635 6237 100       16636 $to or $to = $$self{OPTIONS}{Charset};
5636 6237 100 100     17319 if ($from ne $to and length $val) {
5637 1089         28945 require Image::ExifTool::Charset;
5638 1089         2607 my $cs1 = $Image::ExifTool::Charset::csType{$from};
5639 1089         1911 my $cs2 = $Image::ExifTool::Charset::csType{$to};
5640 1089 50 33     5445 if ($cs1 and $cs2 and not $cs2 & 0x002) {
    0 33        
5641             # treat as straight ASCII if no character will need remapping
5642 1089 100 100     3960 if (($cs1 | $cs2) & 0x680 or $val =~ /[\x80-\xff]/) {
5643 776         2466 my $uni = Image::ExifTool::Charset::Decompose($self, $val, $from, $fromOrder);
5644 776         2107 $val = Image::ExifTool::Charset::Recompose($self, $uni, $to, $toOrder);
5645             }
5646             } elsif ($self) {
5647 0 0       0 my $set = $cs1 ? $to : $from;
5648 0 0       0 unless ($$self{"DecodeWarn$set"}) {
5649 0         0 $self->Warn("Unsupported character set ($set)");
5650 0         0 $$self{"DecodeWarn$set"} = 1;
5651             }
5652             }
5653             }
5654 6237         16579 return $val;
5655             }
5656              
5657             #------------------------------------------------------------------------------
5658             # Encode string with specified encoding
5659             # Inputs: 0) ExifTool object ref, 1) string, 2) destination character set name,
5660             # 3) optional destination byte order (2-byte and 4-byte fixed-width sets only)
5661             # Returns: string in specified encoding
5662             sub Encode($$$;$)
5663             {
5664 59     59 0 262 my ($self, $val, $to, $toOrder) = @_;
5665 59         250 return $self->Decode($val, undef, undef, $to, $toOrder);
5666             }
5667              
5668             #------------------------------------------------------------------------------
5669             # Decode bit mask
5670             # Inputs: 0) value to decode, 1) Reference to hash for decoding (or undef)
5671             # 2) optional bits per word (defaults to 32)
5672             sub DecodeBits($$;$)
5673             {
5674 175     175 0 988 my ($vals, $lookup, $bits) = @_;
5675 175 100       661 $bits or $bits = 32;
5676 175         384 my ($val, $i, @bitList);
5677 175         363 my $num = 0;
5678 175         677 foreach $val (split ' ', $vals) {
5679 243         860 for ($i=0; $i<$bits; ++$i) {
5680 6048 100       12925 next unless $val & (1 << $i);
5681 140         325 my $n = $i + $num;
5682 140 100       586 if (not $lookup) {
    100          
5683 19         59 push @bitList, $n;
5684             } elsif ($$lookup{$n}) {
5685 115         359 push @bitList, $$lookup{$n};
5686             } else {
5687 6         28 push @bitList, "[$n]";
5688             }
5689             }
5690 243         709 $num += $bits;
5691             }
5692 175 100       992 return '(none)' unless @bitList;
5693 95 100       1714 return join($lookup ? ', ' : ',', @bitList);
5694             }
5695              
5696             #------------------------------------------------------------------------------
5697             # Validate an extracted image and repair if necessary
5698             # Inputs: 0) ExifTool object reference, 1) image reference, 2) tag name or key
5699             # Returns: image reference or undef if it wasn't valid
5700             # Note: should be called from RawConv, not ValueConv
5701             sub ValidateImage($$$)
5702             {
5703 206     206 0 810 my ($self, $imagePt, $tag) = @_;
5704 206 50       795 return undef if $$imagePt eq 'none';
5705 206 100 66     1947 unless ($$imagePt =~ /^(Binary data|\xff\xd8\xff)/ or
      100        
5706             # the first byte of the preview of some Minolta cameras is wrong,
5707             # so check for this and set it back to 0xff if necessary
5708             $$imagePt =~ s/^.(\xd8\xff\xdb)/\xff$1/s or
5709             $self->Options('IgnoreMinorErrors'))
5710             {
5711             # issue warning only if the tag was specifically requested
5712 120 50       816 if ($$self{REQ_TAG_LOOKUP}{lc GetTagName($tag)}) {
5713 0         0 $self->Warn("$tag is not a valid JPEG image",1);
5714 0         0 return undef;
5715             }
5716             }
5717 206         2595 return $imagePt;
5718             }
5719              
5720             #------------------------------------------------------------------------------
5721             # Validate a tag name argument (including group name and wildcards, etc)
5722             # Inputs: 0) tag name
5723             # Returns: true if tag name is valid
5724             # - a tag name may contain [-_A-Za-z0-9], but may not start with [-0-9]
5725             # - tag names may contain wildcards [?*], and end with a hash [#]
5726             # - may have group name prefixes (which may have family number prefix), separated by colons
5727             # - a group name may be zero or more characters
5728             sub ValidTagName($)
5729             {
5730 53     53 0 149 my $tag = shift;
5731 53         445 return $tag =~ /^(([-\w]*|\d*\*):)*[_a-zA-Z?*][-\w?*]*#?$/;
5732             }
5733              
5734             #------------------------------------------------------------------------------
5735             # Generate a valid tag name based on the tag ID or name
5736             # Inputs: 0) tag ID or name
5737             # Returns: valid tag name
5738             sub MakeTagName($)
5739             {
5740 34815     34815 0 47731 my $name = shift;
5741 34815         64066 $name =~ tr/-_a-zA-Z0-9//dc; # remove illegal characters
5742 34815         57304 $name = ucfirst $name; # capitalize first letter
5743 34815 50       62969 $name = "Tag$name" if length($name) < 2; # must at least 2 characters long
5744 34815         65668 return $name;
5745             }
5746              
5747             #------------------------------------------------------------------------------
5748             # Make description from a tag name
5749             # Inputs: 0) tag name 1) optional tagID to add at end of description
5750             # Returns: description
5751             sub MakeDescription($;$)
5752             {
5753 10340     10340 0 19586 my ($tag, $tagID) = @_;
5754             # start with the tag name and force first letter to be upper case
5755 10340         19707 my $desc = ucfirst($tag);
5756             # translate underlines to spaces
5757 10340         17843 $desc =~ tr/_/ /;
5758             # remove hex TagID from name (to avoid inserting spaces in the number)
5759 10340 100 66     31690 $desc =~ s/ (0x[\da-f]+)$//i and $tagID = $1 unless defined $tagID;
5760             # put a space between lower/UPPER case and lower/number combinations
5761 10340         63698 $desc =~ s/([a-z])([A-Z\d])/$1 $2/g;
5762             # put a space between acronyms and words
5763 10340         28009 $desc =~ s/([A-Z])([A-Z][a-z])/$1 $2/g;
5764             # put spaces after numbers (if more than one character follows the number)
5765 10340         17811 $desc =~ s/(\d)([A-Z]\S)/$1 $2/g;
5766             # add TagID to description
5767 10340 100       20202 $desc .= ' ' . $tagID if defined $tagID;
5768 10340         28158 return $desc;
5769             }
5770              
5771             #------------------------------------------------------------------------------
5772             # Get descriptions for all tags in an array
5773             # Inputs: 0) ExifTool ref, 1) reference to list of tag keys
5774             # Returns: reference to hash lookup for descriptions
5775             # Note: Returned descriptions are NOT escaped by ESCAPE_PROC
5776             sub GetDescriptions($$)
5777             {
5778 0     0 0 0 local $_;
5779 0         0 my ($self, $tags) = @_;
5780 0         0 my %desc;
5781 0         0 my $oldEscape = $$self{ESCAPE_PROC};
5782 0         0 delete $$self{ESCAPE_PROC};
5783 0         0 $desc{$_} = $self->GetDescription($_) foreach @$tags;
5784 0         0 $$self{ESCAPE_PROC} = $oldEscape;
5785 0         0 return \%desc;
5786             }
5787              
5788             #------------------------------------------------------------------------------
5789             # Apply filter to value(s) if necessary
5790             # Inputs: 0) ExifTool ref, 1) filter expression, 2) reference to value to filter
5791             # Returns: true unless a filter returned undef; changes value if necessary
5792             sub Filter($$$)
5793             {
5794 13258     13258 1 20660 local $_;
5795 13258         31135 my ($self, $filter, $valPt) = @_;
5796 13258 100 66     44021 return 1 unless defined $filter and defined $$valPt;
5797 462         651 my $rtnVal;
5798 462 100       915 if (not ref $$valPt) {
    100          
    50          
    0          
5799 446         778 $_ = $$valPt;
5800             #### eval Filter ($_, $self)
5801 446         23907 eval $filter;
5802 446 50       1663 if (defined $_) {
5803 446         858 $$valPt = $_;
5804 446         636 $rtnVal = 1;
5805             }
5806             } elsif (ref $$valPt eq 'SCALAR') {
5807 12         24 my $val = $$$valPt; # make a copy to avoid filtering twice
5808 12         31 $rtnVal = $self->Filter($filter, \$val);
5809 12         25 $$valPt = \$val;
5810             } elsif (ref $$valPt eq 'ARRAY') {
5811 4         6 my @val = @{$$valPt}; # make a copy to avoid filtering twice
  4         23  
5812 4   50     15 $self->Filter($filter, \$_) and $rtnVal = 1 foreach @val;
5813 4         9 $$valPt = \@val;
5814             } elsif (ref $$valPt eq 'HASH') {
5815 0         0 my %val = %{$$valPt}; # make a copy to avoid filtering twice
  0         0  
5816 0   0     0 $self->Filter($filter, \$val{$_}) and $rtnVal = 1 foreach keys %val;
5817 0         0 $$valPt = \%val;
5818             } else {
5819 0         0 $rtnVal = 1;
5820             }
5821 462         853 return $rtnVal;
5822             }
5823              
5824             #------------------------------------------------------------------------------
5825             # Return printable value
5826             # Inputs: 0) ExifTool object reference
5827             # 1) value to print, 2) line length limit (undef defaults to 60, 0=unlimited)
5828             sub Printable($;$)
5829             {
5830 593     593 0 1218 my ($self, $outStr, $maxLen) = @_;
5831 593 50       1242 return '(undef)' unless defined $outStr;
5832 593         1263 $outStr =~ tr/\x01-\x1f\x7f-\xff/./;
5833 593         1711 $outStr =~ s/\x00//g;
5834 593         1023 my $verbose = $$self{OPTIONS}{Verbose};
5835 593 50       1150 if ($verbose < 4) {
5836 593 100       1113 if ($maxLen) {
    50          
5837 592 50       1219 $maxLen = 20 if $maxLen < 20; # minimum length is 20
5838             } elsif (defined $maxLen) {
5839 1         3 $maxLen = length $outStr; # 0 is unlimited
5840             } else {
5841 0         0 $maxLen = 60; # default maximum is 60
5842             }
5843             } else {
5844 0         0 $maxLen = length $outStr;
5845             # limit to 2048 characters if verbose < 5
5846 0 0 0     0 $maxLen = 2048 if $maxLen > 2048 and $verbose < 5;
5847             }
5848              
5849             # limit length if necessary
5850 593 100       1193 $outStr = substr($outStr,0,$maxLen-6) . '[snip]' if length($outStr) > $maxLen;
5851 593         2012 return $outStr;
5852             }
5853              
5854             #------------------------------------------------------------------------------
5855             # Convert date/time from Exif format
5856             # Inputs: 0) ExifTool object reference, 1) Date/time in EXIF format
5857             # Returns: Formatted date/time string
5858             sub ConvertDateTime($$)
5859             {
5860 1801     1801 0 4974 my ($self, $date) = @_;
5861 1801         4539 my $fmt = $$self{OPTIONS}{DateFormat};
5862 1801         3434 my $shift = $$self{OPTIONS}{GlobalTimeShift};
5863 1801 100       4714 if ($shift) {
5864 8 50 33     56 my $dir = ($shift =~ s/^([-+])// and $1 eq '-') ? -1 : 1;
5865 8         18 my $offset = $$self{GLOBAL_TIME_OFFSET};
5866 8 100       20 $offset or $offset = $$self{GLOBAL_TIME_OFFSET} = { };
5867 8         30 ShiftTime($date, $shift, $dir, $offset);
5868             }
5869             # only convert date if a format was specified and the date is recognizable
5870 1801 100       4170 if ($fmt) {
5871             # separate time zone if it exists
5872 5         8 my $tz;
5873 5 100       40 $date =~ s/([-+]\d{2}:\d{2}|Z)$// and $tz = $1;
5874             # a few cameras use incorrect date/time formatting:
5875             # - slashes instead of colons in date (RolleiD330, ImpressCam)
5876             # - date/time values separated by colon instead of space (Polariod, Sanyo, Sharp, Vivitar)
5877             # - single-digit seconds with leading space (HP scanners)
5878 5         41 my @a = reverse ($date =~ /\d+/g); # be very flexible about date/time format
5879 5 50 33     46 if (@a and $a[-1] >= 1000 and $a[-1] < 3000 and eval { require POSIX }) {
  5 0 33     36  
      33        
5880 5         19 shift @a while @a > 6; # remove superfluous entries
5881 5         13 unshift @a, 1 while @a < 3; # add month and day if necessary
5882 5         13 unshift @a, 0 while @a < 6; # add h,m,s if necessary
5883 5         14 $a[4] -= 1; # base month is 1
5884             # parse our %f fractional seconds first (and round up seconds if necessary)
5885             # - if there are multiple %f codes, they all get the same number of digits as the first
5886 5 50       31 if ($fmt =~ /%(-?)\.?(\d*)f/) {
5887 0         0 my ($neg, $dig) = ($1, $2);
5888 0 0       0 my $frac = $date =~ /(\.\d+)/ ? $1 : '';
5889 0 0       0 if (not $frac) {
    0          
5890 0 0       0 $frac = '.' . ('0' x $dig) if $dig;
5891             } elsif (length $dig) {
5892 0 0       0 if ($dig+1 > length($frac)) {
    0          
5893 0         0 $frac .= '0' x ($dig+1-length($frac));
5894             } elsif ($dig+1 < length($frac)) {
5895 0         0 $frac = sprintf("%.${dig}f", $frac);
5896 0   0     0 while ($frac =~ s/^(\d)// and $1 ne '0') {
5897             # this is a pain, but we must round up to the next second
5898 0 0       0 ++$a[0] < 60 and last;
5899 0         0 $a[0] = 0;
5900 0 0       0 ++$a[1] < 60 and last;
5901 0         0 $a[1] = 0;
5902 0 0       0 ++$a[2] < 24 and last;
5903 0         0 $a[2] = 0;
5904 0         0 require 'Image/ExifTool/Shift.pl';
5905 0 0       0 ++$a[3] <= DaysInMonth($a[4]+1, $a[5]) and last;
5906 0         0 $a[3] = 1;
5907 0 0       0 ++$a[4] < 12 and last;
5908 0         0 $a[4] = 0;
5909 0         0 ++$a[5];
5910 0         0 last; # (this was a goto)
5911             }
5912             }
5913             }
5914 0 0       0 $neg and $frac =~ s/^\.//;
5915 0         0 $fmt =~ s/(^|[^%])((%%)*)%-?\.?\d*f/$1$2$frac/g;
5916             }
5917             # parse %z and %s ourself (to handle time zones properly)
5918 5 50       17 if ($fmt =~ /%[sz]/) {
5919             # use system time zone unless otherwise specified
5920 0 0 0     0 $tz = TimeZoneString(\@a, TimeLocal(@a)) if not $tz and eval { require Time::Local };
  0         0  
5921             # remove colon, setting to UTC if time zone is not numeric
5922 0 0 0     0 $tz = ($tz and $tz=~/^([-+]\d{2}):(\d{2})$/) ? "$1$2" : '+0000';
5923 0         0 $fmt =~ s/(^|[^%])((%%)*)%z/$1$2$tz/g; # convert '%z' format codes
5924 0 0 0     0 if ($fmt =~ /%s/ and eval { require Time::Local }) {
  0         0  
5925             # calculate seconds since the Epoch, UTC
5926 0         0 my $s = Time::Local::timegm(@a) - 60 * ($tz - int($tz/100) * 40);
5927 0         0 $fmt =~ s/(^|[^%])((%%)*)%s/$1$2$s/g; # convert '%s' format codes
5928             }
5929             }
5930 5         13 $a[5] -= 1900; # strftime year starts from 1900
5931 5         239 $date = POSIX::strftime($fmt, @a); # generate the formatted date/time
5932             } elsif ($$self{OPTIONS}{StrictDate}) {
5933 0         0 undef $date;
5934             }
5935             }
5936 1801         11914 return $date;
5937             }
5938              
5939             #------------------------------------------------------------------------------
5940             # Print conversion for time span value
5941             # Inputs: 0) time ticks, 1) number of seconds per tick (default 1)
5942             # Returns: readable time
5943             sub ConvertTimeSpan($;$)
5944             {
5945 3     3 0 16 my ($val, $mult) = @_;
5946 3 50 33     20 if (Image::ExifTool::IsFloat($val) and $val != 0) {
5947 3 100       17 $val *= $mult if $mult;
5948 3 50       19 if ($val < 60) {
    50          
    0          
5949 0         0 $val = "$val seconds";
5950             } elsif ($val < 3600) {
5951 3 100 66     17 my $fmt = ($mult and $mult >= 60) ? '%d' : '%.1f';
5952 3 100 66     16 my $s = ($val == 60 and $mult) ? '' : 's';
5953 3         32 $val = sprintf("$fmt minute$s", $val / 60);
5954             } elsif ($val < 24 * 3600) {
5955 0         0 $val = sprintf("%.1f hours", $val / 3600);
5956             } else {
5957 0         0 $val = sprintf("%.1f days", $val / (24 * 3600));
5958             }
5959             }
5960 3         24 return $val;
5961             }
5962              
5963             #------------------------------------------------------------------------------
5964             # Patched timelocal() that fixes ActivePerl timezone bug
5965             # Inputs/Returns: same as timelocal()
5966             # Notes: must 'require Time::Local' before calling this routine.
5967             # Also note that year should be full year, and not relative to 1900 as with localtime
5968             sub TimeLocal(@)
5969             {
5970 36     36 0 1659 my $tm = Time::Local::timelocal(@_);
5971 36 50       3035 if ($^O eq 'MSWin32') {
5972             # patch for ActivePerl timezone bug
5973 0         0 my @t2 = localtime($tm);
5974 0         0 my $t2 = Time::Local::timelocal(@t2);
5975             # adjust timelocal() return value to be consistent with localtime()
5976 0         0 $tm += $tm - $t2;
5977             }
5978 36         139 return $tm;
5979             }
5980              
5981             #------------------------------------------------------------------------------
5982             # Get time zone in minutes
5983             # Inputs: 0) localtime array ref, 1) gmtime array ref
5984             # Returns: time zone offset in minutes
5985             sub GetTimeZone($$)
5986             {
5987 942     942 0 2368 my ($tm, $gm) = @_;
5988             # compute the number of minutes between localtime and gmtime
5989 942         3466 my $min = $$tm[2] * 60 + $$tm[1] - ($$gm[2] * 60 + $$gm[1]);
5990 942 50       2870 if ($$tm[3] != $$gm[3]) {
5991             # account for case where one date wraps to the first of the next month
5992 0 0       0 $$gm[3] = $$tm[3] - ($$tm[3]==1 ? 1 : -1) if abs($$tm[3]-$$gm[3]) != 1;
    0          
5993             # adjust for the +/- one day difference
5994 0         0 $min += ($$tm[3] - $$gm[3]) * 24 * 60;
5995             }
5996             # MirBSD patch to round to the nearest 30 minutes because
5997             # it includes leap seconds in localtime but not gmtime
5998 942 0       3809 $min = int($min / 30 + ($min > 0 ? 0.5 : -0.5)) * 30 if $^O eq 'mirbsd';
    50          
5999 942         2721 return $min;
6000             }
6001              
6002             #------------------------------------------------------------------------------
6003             # Get time zone string
6004             # Inputs: 0) time zone offset in minutes
6005             # or 0) localtime array ref, 1) corresponding time value
6006             # Returns: time zone string ("+/-HH:MM")
6007             sub TimeZoneString($;$)
6008             {
6009 983     983 0 2506 my $min = shift;
6010 983 100       3524 if (ref $min) {
6011 942         5189 my @gm = gmtime(shift);
6012 942         3277 $min = GetTimeZone($min, \@gm);
6013             }
6014 983         2689 my $sign = '+';
6015 983 100       2629 $min < 0 and $sign = '-', $min = -$min;
6016 983         2694 $min = int($min + 0.5); # round off to nearest minute
6017 983         2361 my $h = int($min / 60);
6018 983         5891 return sprintf('%s%.2d:%.2d', $sign, $h, $min - $h * 60);
6019             }
6020              
6021             #------------------------------------------------------------------------------
6022             # Convert Unix time to EXIF date/time string
6023             # Inputs: 0) Unix time value, 1) non-zero to convert to local time,
6024             # 2) number of digits after the decimal for fractional seconds
6025             # Returns: EXIF date/time string (with timezone for local times)
6026             sub ConvertUnixTime($;$$)
6027             {
6028 1045     1045 0 3446 my ($time, $toLocal, $dec) = @_;
6029 1045 100       3166 return '0000:00:00 00:00:00' if $time == 0;
6030 1044         1985 my (@tm, $tz);
6031 1044 50       2510 if ($dec) {
6032 0         0 my $frac = $time - int($time);
6033 0         0 $time = int($time);
6034 0 0       0 $frac < 0 and $frac += 1, $time -= 1;
6035 0         0 $dec = sprintf('%.*f', $dec, $frac);
6036             # remove number before decimal and increment integer time if it was rounded up
6037 0 0 0     0 $dec =~ s/^(\d)// and $1 eq '1' and $time += 1;
6038             } else {
6039 1044 100       3098 $time = int($time + 1e-6) if $time != int($time); # avoid round-off errors
6040 1044         2013 $dec = '';
6041             }
6042 1044 100       2383 if ($toLocal) {
6043 880         31070 @tm = localtime($time);
6044 880         4506 $tz = TimeZoneString(\@tm, $time);
6045             } else {
6046 164         1072 @tm = gmtime($time);
6047 164         354 $tz = '';
6048             }
6049 1044         8066 my $str = sprintf("%4d:%.2d:%.2d %.2d:%.2d:%.2d$dec%s",
6050             $tm[5]+1900, $tm[4]+1, $tm[3], $tm[2], $tm[1], $tm[0], $tz);
6051 1044         9187 return $str;
6052             }
6053              
6054             #------------------------------------------------------------------------------
6055             # Get Unix time from EXIF-formatted date/time string with optional timezone
6056             # Inputs: 0) EXIF date/time string, 1) non-zero if time is local, or 2 to assume UTC
6057             # Returns: Unix time (seconds since 0:00 GMT Jan 1, 1970) or undefined on error
6058             sub GetUnixTime($;$)
6059             {
6060 162     162 0 36634 my ($timeStr, $isLocal) = @_;
6061 162 50       478 return 0 if $timeStr eq '0000:00:00 00:00:00';
6062 162         1150 my @tm = ($timeStr =~ /^(\d+)[-:](\d+)[-:](\d+)\s+(\d+):(\d+):(\d+)(.*)/);
6063 162 50       562 return undef unless @tm == 7;
6064 162 50       319 unless (eval { require Time::Local }) {
  162         6048  
6065 0         0 warn "Time::Local is not installed\n";
6066 0         0 return undef;
6067             }
6068 162         20060 my ($tzStr, $tzSec) = (pop(@tm), 0);
6069             # use specified timezone offset (if given) instead of local system time
6070             # if we are converting a local time value
6071 162 100       443 if ($isLocal) {
6072 113 50       414 if ($tzStr =~ /(?:Z|([-+])(\d+):(\d+))/i) {
    0          
6073             # use specified timezone if one exists
6074 113 100       559 $tzSec = ($2 * 60 + $3) * ($1 eq '-' ? -60 : 60) if $1;
    100          
6075 113         218 undef $isLocal; # convert using GMT corrected for specified timezone
6076             } elsif ($isLocal eq '2') {
6077 0         0 undef $isLocal;
6078             }
6079             }
6080 162         387 $tm[1] -= 1; # convert month
6081 162         329 @tm = reverse @tm; # change to order required by timelocal()
6082 162 50       697 my $val = $isLocal ? TimeLocal(@tm) : Time::Local::timegm(@tm) - $tzSec;
6083             # handle fractional seconds
6084 160 100 100     5903 $val += $1 if $tzStr and $tzStr =~ /^(\.\d+)/;
6085 160         1389 return $val;
6086             }
6087              
6088             #------------------------------------------------------------------------------
6089             # Print conversion for file size
6090             # Inputs: 0) file size in bytes
6091             # Returns: converted file size
6092             sub ConvertFileSize($)
6093             {
6094 306     306 0 979 my $val = shift;
6095 306 100       1440 $val < 2000 and return "$val bytes";
6096 198 100       2080 $val < 10000 and return sprintf('%.1f kB', $val / 1000);
6097 51 100       513 $val < 2000000 and return sprintf('%.0f kB', $val / 1000);
6098 4 100       47 $val < 10000000 and return sprintf('%.1f MB', $val / 1000000);
6099 1 50       10 $val < 2000000000 and return sprintf('%.0f MB', $val / 1000000);
6100 0 0       0 $val < 10000000000 and return sprintf('%.1f GB', $val / 1000000000);
6101 0         0 return sprintf('%.0f GB', $val / 1000000000);
6102             }
6103              
6104             #------------------------------------------------------------------------------
6105             # Convert seconds to duration string (handles negative durations)
6106             # Inputs: 0) floating point seconds
6107             # Returns: duration string in form "S.SS s", "H:MM:SS" or "DD days HH:MM:SS"
6108             sub ConvertDuration($)
6109             {
6110 130     130 0 319 my $time = shift;
6111 130 50       402 return $time unless IsFloat($time);
6112 130 100       777 return '0 s' if $time == 0;
6113 61 50       206 my $sign = ($time > 0 ? '' : (($time = -$time), '-'));
6114 61 100       835 return sprintf("$sign%.2f s", $time) if $time < 30;
6115 4         24 $time += 0.5; # to round off to nearest second
6116 4         14 my $h = int($time / 3600);
6117 4         11 $time -= $h * 3600;
6118 4         8 my $m = int($time / 60);
6119 4         9 $time -= $m * 60;
6120 4 50       13 if ($h > 24) {
6121 0         0 my $d = int($h / 24);
6122 0         0 $h -= $d * 24;
6123 0         0 $sign = "$sign$d days ";
6124             }
6125 4         45 return sprintf("$sign%d:%.2d:%.2d", $h, $m, int($time));
6126             }
6127              
6128             #------------------------------------------------------------------------------
6129             # Print conversion for bitrate values
6130             # Inputs: 0) bitrate in bits per second
6131             # Returns: human-readable bitrate string
6132             # Notes: returns input value without formatting if it isn't numerical
6133             sub ConvertBitrate($)
6134             {
6135 20     20 0 61 my $bitrate = shift;
6136 20 50       62 IsFloat($bitrate) or return $bitrate;
6137 20         87 my @units = ('bps', 'kbps', 'Mbps', 'Gbps');
6138 20         52 for (;;) {
6139 38         75 my $units = shift @units;
6140 38 100 66     262 $bitrate >= 1000 and @units and $bitrate /= 1000, next;
6141 20 100       92 my $fmt = $bitrate < 100 ? '%.3g' : '%.0f';
6142 20         284 return sprintf("$fmt $units", $bitrate);
6143             }
6144             }
6145              
6146             #------------------------------------------------------------------------------
6147             # Convert file name for printing
6148             # Inputs: 0) ExifTool ref, 1) file name in CharsetFileName character set
6149             # Returns: converted file name in external character set
6150             sub ConvertFileName($$)
6151             {
6152 972     972 0 3228 my ($self, $val) = @_;
6153 972         2663 my $enc = $$self{OPTIONS}{CharsetFileName};
6154 972 50       2903 $val = $self->Decode($val, $enc) if $enc;
6155 972         7854 return $val;
6156             }
6157              
6158             #------------------------------------------------------------------------------
6159             # Inverse conversion for file name (encode in CharsetFileName)
6160             # Inputs: 0) ExifTool ref, 1) file name in external character set
6161             # Returns: file name in CharsetFileName character set
6162             sub InverseFileName($$)
6163             {
6164 1     1 0 6 my ($self, $val) = @_;
6165 1         4 my $enc = $$self{OPTIONS}{CharsetFileName};
6166 1 50       7 $val = $self->Encode($val, $enc) if $enc;
6167 1         4 $val =~ tr/\\/\//; # make sure we are using forward slashes
6168 1         9 return $val;
6169             }
6170              
6171             #------------------------------------------------------------------------------
6172             # Save information for HTML dump
6173             # Inputs: 0) ExifTool hash ref, 1) start offset, 2) data size
6174             # 3) comment string, 4) tool tip (or SAME), 5) flags, 6) IFD name
6175             sub HDump($$$$;$$$)
6176             {
6177 0     0 0 0 my $self = shift;
6178 0 0       0 $$self{HTML_DUMP} or return;
6179 0         0 my ($pos, $len, $com, $tip, $flg, $ifd) = @_;
6180 0 0       0 $pos += $$self{BASE} if $$self{BASE};
6181             # skip structural data blocks which have been removed from the middle of this dump
6182             # (SkipData list contains ordered [start,end+1] offsets to skip)
6183 0 0       0 if ($$self{SkipData}) {
6184 0         0 my $end = $pos + $len;
6185 0         0 my $skip;
6186 0         0 foreach $skip (@{$$self{SkipData}}) {
  0         0  
6187 0 0       0 $end <= $$skip[0] and last;
6188 0 0       0 $pos >= $$skip[1] and $pos += $$skip[1] - $$skip[0], next;
6189 0 0       0 if ($pos != $$skip[0]) {
6190 0         0 $$self{HTML_DUMP}->Add($pos, $$skip[0]-$pos, $com, $tip, $flg, $ifd);
6191 0         0 $len -= $$skip[0] - $pos;
6192 0         0 $tip = 'SAME';
6193             }
6194 0         0 $pos = $$skip[1];
6195             }
6196             }
6197 0         0 $$self{HTML_DUMP}->Add($pos, $len, $com, $tip, $flg, $ifd);
6198             }
6199              
6200             #------------------------------------------------------------------------------
6201             # Identify trailer ending at specified offset from end of file
6202             # Inputs: 0) RAF reference, 1) offset from end of file (0 by default)
6203             # Returns: Trailer info hash (with RAF and DirName set),
6204             # or undef if no recognized trailer was found
6205             # Notes: leaves file position unchanged
6206             sub IdentifyTrailer($;$)
6207             {
6208 580     580 0 1237 my $raf = shift;
6209 580   100     2218 my $offset = shift || 0;
6210 580         2056 my $pos = $raf->Tell();
6211 580         1747 my ($buff, $type, $len);
6212 580   33     2558 while ($raf->Seek(-$offset, 2) and ($len = $raf->Tell()) > 0) {
6213             # read up to 64 bytes before specified offset from end of file
6214 580 50       2638 $len = 64 if $len > 64;
6215 580 50 33     2024 $raf->Seek(-$len, 1) and $raf->Read($buff, $len) == $len or last;
6216 580 100 66     12658 if ($buff =~ /AXS(!|\*).{8}$/s) {
    100          
    100          
    100          
    100          
    100          
    50          
    50          
6217 29         122 $type = 'AFCP';
6218             } elsif ($buff =~ /\xa1\xb2\xc3\xd4$/) {
6219 29         138 $type = 'FotoStation';
6220             } elsif ($buff =~ /cbipcbbl$/) {
6221 34         167 $type = 'PhotoMechanic';
6222             } elsif ($buff =~ /^CANON OPTIONAL DATA\0/) {
6223 41         160 $type = 'CanonVRD';
6224             } elsif ($buff =~ /~\0\x04\0zmie~\0\0\x06.{4}[\x10\x18]\x04$/s or
6225             $buff =~ /~\0\x04\0zmie~\0\0\x0a.{8}[\x10\x18]\x08$/s)
6226             {
6227 26         103 $type = 'MIE';
6228             } elsif ($buff =~ /\0\0(QDIOBS|SEFT)$/) {
6229 26         109 $type = 'Samsung';
6230             } elsif ($buff =~ /8db42d694ccc418790edff439fe026bf$/s) {
6231 0         0 $type = 'Insta360';
6232             } elsif ($buff =~ m(\0{6}/NIKON APP$)) {
6233 0         0 $type = 'NikonApp';
6234             }
6235 580         1347 last;
6236             }
6237 580         2382 $raf->Seek($pos, 0); # restore original file position
6238 580 100       4059 return $type ? { RAF => $raf, DirName => $type } : undef;
6239             }
6240              
6241             #------------------------------------------------------------------------------
6242             # Read/rewrite trailer information (including multiple trailers)
6243             # Inputs: 0) ExifTool object ref, 1) DirInfo ref:
6244             # - requires RAF and DirName
6245             # - OutFile is a scalar reference for writing
6246             # - scans from current file position if ScanForAFCP is set
6247             # Returns: 1 if trailer was processed or couldn't be processed (or written OK)
6248             # 0 if trailer was recognized but offsets need fixing (or write error)
6249             # - DirName, DirLen, DataPos, Offset, Fixup and OutFile are updated
6250             # - preserves current file position and byte order
6251             sub ProcessTrailers($$)
6252             {
6253 57     57 0 200 my ($self, $dirInfo) = @_;
6254 57         178 my $dirName = $$dirInfo{DirName};
6255 57         150 my $outfile = $$dirInfo{OutFile};
6256 57   50     346 my $offset = $$dirInfo{Offset} || 0;
6257 57         137 my $fixup = $$dirInfo{Fixup};
6258 57         892 my $raf = $$dirInfo{RAF};
6259 57         226 my $pos = $raf->Tell();
6260 57         258 my $byteOrder = GetByteOrder();
6261 57         185 my $success = 1;
6262 57         199 my $path = $$self{PATH};
6263              
6264 57         119 for (;;) { # loop through all trailers
6265 185         413 my ($proc, $outBuff);
6266 185 50       713 if ($dirName eq 'Insta360') {
    50          
6267 0         0 require 'Image/ExifTool/QuickTimeStream.pl';
6268 0         0 $proc = 'Image::ExifTool::QuickTime::ProcessInsta360';
6269             } elsif ($dirName eq 'NikonApp') {
6270 0         0 require Image::ExifTool::Nikon;
6271 0         0 $proc = 'Image::ExifTool::Nikon::ProcessNikonApp';
6272             } else {
6273 185         16470 require "Image/ExifTool/$dirName.pm";
6274 185         671 $proc = "Image::ExifTool::${dirName}::Process$dirName";
6275             }
6276 185 100       573 if ($outfile) {
6277             # write to local buffer so we can add trailer in proper order later
6278 50 100       216 $$outfile and $$dirInfo{OutFile} = \$outBuff, $outBuff = '';
6279             # must generate new fixup if necessary so we can shift
6280             # the old fixup separately after we prepend this trailer
6281 50         113 delete $$dirInfo{Fixup};
6282             }
6283 185         363 delete $$dirInfo{DirLen}; # reset trailer length
6284 185         411 $$dirInfo{Offset} = $offset; # set offset from end of file
6285 185         366 $$dirInfo{Trailer} = 1; # set Trailer flag in case proc cares
6286             # add trailer and DirName to SubDirectory PATH
6287 185         453 push @$path, 'Trailer', $dirName;
6288              
6289             # read or write this trailer
6290             # (proc takes Offset as positive offset from end of trailer to end of file,
6291             # and returns DataPos and DirLen, and Fixup if applicable, and updates
6292             # OutFile when writing)
6293 106     106   1149 no strict 'refs';
  106         307  
  106         5657  
6294 185         2639 my $result = &$proc($self, $dirInfo);
6295 106     106   791 use strict 'refs';
  106         292  
  106         1513292  
6296              
6297             # restore PATH (pop last 2 items)
6298 185         578 splice @$path, -2;
6299              
6300             # check result
6301 185 100       681 if ($outfile) {
    50          
6302 50 50       142 if ($result > 0) {
6303 50 100       135 if ($outBuff) {
6304             # write trailers to OutFile in original order
6305 33         285 $$outfile = $outBuff . $$outfile;
6306             # must adjust old fixup start if it exists
6307 33 50       158 $$fixup{Start} += length($outBuff) if $fixup;
6308 33         67 $outBuff = ''; # free memory
6309             }
6310 50 100       166 if ($$dirInfo{Fixup}) {
6311 15 100       59 if ($fixup) {
6312             # add fixup for subsequent trailers to the fixup for this trailer
6313             # (but first we must adjust for the new start position)
6314 7         21 $$fixup{Shift} += $$dirInfo{Fixup}{Start};
6315 7         21 $$fixup{Start} -= $$dirInfo{Fixup}{Start};
6316 7         45 $$dirInfo{Fixup}->AddFixup($fixup);
6317             }
6318 15         52 $fixup = $$dirInfo{Fixup}; # save fixup
6319             }
6320             } else {
6321 0 0       0 $success = 0 if $self->Error("Error rewriting $dirName trailer", 2);
6322 0         0 last;
6323             }
6324             } elsif ($result < 0) {
6325             # can't continue if we must scan for this trailer
6326 0         0 $success = 0;
6327 0         0 last;
6328             }
6329 185 50 33     979 last unless $result > 0 and $$dirInfo{DirLen};
6330             # look for next trailer
6331 185         400 $offset += $$dirInfo{DirLen};
6332 185 100       612 my $nextTrail = IdentifyTrailer($raf, $offset) or last;
6333 128         356 $dirName = $$dirInfo{DirName} = $$nextTrail{DirName};
6334 128         408 $raf->Seek($pos, 0);
6335             }
6336 57         323 SetByteOrder($byteOrder); # restore original byte order
6337 57         470 $raf->Seek($pos, 0); # restore original file position
6338 57         291 $$dirInfo{OutFile} = $outfile; # restore original outfile
6339 57         221 $$dirInfo{Offset} = $offset; # return offset from EOF to start of first trailer
6340 57         265 $$dirInfo{Fixup} = $fixup; # return fixup information
6341 57         400 return $success;
6342             }
6343              
6344             #------------------------------------------------------------------------------
6345             # JPEG constants
6346              
6347             # JPEG marker names
6348             %jpegMarker = (
6349             0x00 => 'NULL',
6350             0x01 => 'TEM',
6351             0xc0 => 'SOF0', # to SOF15, with a few exceptions below
6352             0xc4 => 'DHT',
6353             0xc8 => 'JPGA',
6354             0xcc => 'DAC',
6355             0xd0 => 'RST0', # to RST7
6356             0xd8 => 'SOI',
6357             0xd9 => 'EOI',
6358             0xda => 'SOS',
6359             0xdb => 'DQT',
6360             0xdc => 'DNL',
6361             0xdd => 'DRI',
6362             0xde => 'DHP',
6363             0xdf => 'EXP',
6364             0xe0 => 'APP0', # to APP15
6365             0xf0 => 'JPG0',
6366             0xfe => 'COM',
6367             );
6368              
6369             # lookup for size of JPEG marker length word
6370             # (2 bytes assumed unless specified here)
6371             my %markerLenBytes = (
6372             0x00 => 0, 0x01 => 0,
6373             0xd0 => 0, 0xd1 => 0, 0xd2 => 0, 0xd3 => 0, 0xd4 => 0, 0xd5 => 0, 0xd6 => 0, 0xd7 => 0,
6374             0xd8 => 0, 0xd9 => 0, 0xda => 0,
6375             # J2C
6376             0x30 => 0, 0x31 => 0, 0x32 => 0, 0x33 => 0, 0x34 => 0, 0x35 => 0, 0x36 => 0, 0x37 => 0,
6377             0x38 => 0, 0x39 => 0, 0x3a => 0, 0x3b => 0, 0x3c => 0, 0x3d => 0, 0x3e => 0, 0x3f => 0,
6378             0x4f => 0,
6379             0x92 => 0, 0x93 => 0,
6380             # J2C extensions
6381             0x74 => 4, 0x75 => 4, 0x77 => 4,
6382             );
6383              
6384             #------------------------------------------------------------------------------
6385             # Get JPEG marker name
6386             # Inputs: 0) Jpeg number
6387             # Returns: marker name
6388             sub JpegMarkerName($)
6389             {
6390 3136     3136 0 5862 my $marker = shift;
6391 3136         8306 my $markerName = $jpegMarker{$marker};
6392 3136 100       6611 unless ($markerName) {
6393 1178         3451 $markerName = $jpegMarker{$marker & 0xf0};
6394 1178 50 33     8886 if ($markerName and $markerName =~ /^([A-Z]+)\d+$/) {
6395 1178         4447 $markerName = $1 . ($marker & 0x0f);
6396             } else {
6397 0         0 $markerName = sprintf("marker 0x%.2x", $marker);
6398             }
6399             }
6400 3136         7711 return $markerName;
6401             }
6402              
6403             #------------------------------------------------------------------------------
6404             # Adjust directory start position
6405             # Inputs: 0) dirInfo ref, 1) start offset
6406             # 2) Base for offsets (relative to DataPos, defaults to absolute Base of 0)
6407             sub DirStart($$;$)
6408             {
6409 574     574 0 1544 my ($dirInfo, $start, $base) = @_;
6410 574         1284 $$dirInfo{DirStart} = $start;
6411 574         1227 $$dirInfo{DirLen} -= $start;
6412 574 100       1810 if (defined $base) {
6413 275         801 $$dirInfo{Base} = $$dirInfo{DataPos} + $base;
6414 275         709 $$dirInfo{DataPos} = -$base; # (relative to Base!)
6415             }
6416             }
6417              
6418             #------------------------------------------------------------------------------
6419             # Extract metadata from a jpg image
6420             # Inputs: 0) ExifTool object reference, 1) dirInfo ref with RAF set
6421             # Returns: 1 on success, 0 if this wasn't a valid JPEG file
6422             sub ProcessJPEG($$)
6423             {
6424 246     246 0 615 local $_;
6425 246         788 my ($self, $dirInfo) = @_;
6426 246         773 my $options = $$self{OPTIONS};
6427 246         692 my $verbose = $$options{Verbose};
6428 246         643 my $out = $$options{TextOut};
6429 246   100     1415 my $fast = $$options{FastScan} || 0;
6430 246         645 my $raf = $$dirInfo{RAF};
6431 246         624 my $req = $$self{REQ_TAG_LOOKUP};
6432 246         585 my $htmlDump = $$self{HTML_DUMP};
6433 246         970 my %dumpParms = ( Out => $out );
6434 246         1805 my ($ch, $s, $length, $md5, $md5size);
6435 246         0 my ($success, $wantTrailer, $trailInfo, $foundSOS, %jumbfChunk);
6436 246         0 my (@iccChunk, $iccChunkCount, $iccChunksTotal, @flirChunk, $flirCount, $flirTotal);
6437 246         0 my ($preview, $scalado, @dqt, $subSampling, $dumpEnd, %extendedXMP);
6438              
6439             # get pointer to MD5 object if it exists and we are the top-level JPEG
6440 246 100 100     1834 if ($$self{FILE_TYPE} eq 'JPEG' and not $$self{DOC_NUM}) {
6441 236         610 $md5 = $$self{ImageDataMD5};
6442 236         557 $md5size = 0;
6443             }
6444              
6445             # check to be sure this is a valid JPG (or J2C, or EXV) file
6446 246 50 33     1074 return 0 unless $raf->Read($s, 2) == 2 and $s =~ /^\xff[\xd8\x4f\x01]/;
6447 246 100       2193 if ($s eq "\xff\x01") {
6448 2 50 33     8 return 0 unless $raf->Read($s, 5) == 5 and $s eq 'Exiv2';
6449 2         7 $$self{FILE_TYPE} = 'EXV';
6450             }
6451 246         621 my $appBytes = 0;
6452 246         630 my $calcImageLen = $$req{jpegimagelength};
6453 246 50 66     1564 if ($$options{RequestAll} and $$options{RequestAll} > 2) {
6454 0         0 $calcImageLen = 1;
6455             }
6456 246 100 66     1333 if (not $$self{VALUE}{FileType} or ($$self{DOC_NUM} and $$options{ExtractEmbedded})) {
      66        
6457 238         1387 $self->SetFileType(); # set FileType tag
6458 238 100       1595 return 1 if $fast == 3; # don't process file when FastScan == 3
6459 237         1236 $$self{LOW_PRIORITY_DIR}{IFD1} = 1; # lower priority of IFD1 tags
6460             }
6461 245 100       1262 $$raf{NoBuffer} = 1 if $self->Options('FastScan'); # disable buffering in FastScan mode
6462              
6463 245 50       1812 $dumpParms{MaxLen} = 128 if $verbose < 4;
6464 245 50       883 if ($htmlDump) {
6465 0         0 $dumpEnd = $raf->Tell();
6466 0 0       0 my ($n, $t, $m) = $s eq 'Exiv2' ? (7,'EXV','TEM') : (2,'JPEG','SOI');
6467 0         0 my $pos = $dumpEnd - $n;
6468 0 0       0 $self->HDump(0, $pos, '[unknown header]') if $pos;
6469 0         0 $self->HDump($pos, $n, "$t header", "$m Marker");
6470             }
6471 245         669 my $path = $$self{PATH};
6472 245         605 my $pn = scalar @$path;
6473              
6474             # set input record separator to 0xff (the JPEG marker) to make reading quicker
6475 245         1535 local $/ = "\xff";
6476              
6477 245         706 my ($nextMarker, $nextSegDataPt, $nextSegPos, $combinedSegData, $firstSegPos, @skipData);
6478              
6479             # read file until we reach an end of image (EOI) or start of scan (SOS)
6480 245         481 Marker: for (;;) {
6481             # set marker and data pointer for current segment
6482 2140         4024 my $marker = $nextMarker;
6483 2140         3169 my $segDataPt = $nextSegDataPt;
6484 2140         3113 my $segPos = $nextSegPos;
6485 2140         3181 my $skipped;
6486 2140         3381 undef $nextMarker;
6487 2140         3295 undef $nextSegDataPt;
6488             #
6489             # read ahead to the next segment unless we have reached EOI, SOS or SOD
6490             #
6491 2140 100 100     15874 unless ($marker and ($marker==0xd9 or ($marker==0xda and not $wantTrailer and not $md5) or
      100        
6492             $marker==0x93))
6493             {
6494             # read up to next marker (JPEG markers begin with 0xff)
6495 1894         3084 my $buff;
6496 1894 50       8766 $raf->ReadLine($buff) or last;
6497 1894         3692 $skipped = length($buff) - 1;
6498             # JPEG markers can be padded with unlimited 0xff's
6499 1894         2914 for (;;) {
6500 1894 50       5110 $raf->Read($ch, 1) or last Marker;
6501 1894         3854 $nextMarker = ord($ch);
6502 1894 50       4723 last unless $nextMarker == 0xff;
6503 0         0 ++$skipped;
6504             }
6505             # read segment data if it exists
6506 1894 100 33     9059 if (not defined $markerLenBytes{$nextMarker}) {
    50 0        
    50 33        
6507             # read record length word
6508 1648 50       4033 last unless $raf->Read($s, 2) == 2;
6509 1648         5197 my $len = unpack('n',$s); # get data length
6510 1648 50 33     6938 last unless defined($len) and $len >= 2;
6511 1648         4391 $nextSegPos = $raf->Tell();
6512 1648         3026 $len -= 2; # subtract size of length word
6513 1648 50       3860 last unless $raf->Read($buff, $len) == $len;
6514 1648         3555 $nextSegDataPt = \$buff; # set pointer to our next data
6515             } elsif ($markerLenBytes{$nextMarker} == 4) {
6516             # handle J2C extensions with 4-byte length word
6517 0 0       0 last unless $raf->Read($s, 4) == 4;
6518 0         0 my $len = unpack('N',$s); # get data length
6519 0 0 0     0 last unless defined($len) and $len >= 4;
6520 0         0 $nextSegPos = $raf->Tell();
6521 0         0 $len -= 4; # subtract size of length word
6522 0 0       0 last unless $raf->Seek($len, 1);
6523             } elsif ($md5 and defined $marker and ($marker == 0x00 or $marker == 0xda or
6524             ($marker >= 0xd0 and $marker <= 0xd7)))
6525             {
6526             # calculate MD5 for image data (includes leading ff d9 but not trailing ff da)
6527 0         0 $md5->add("\xff" . chr($marker));
6528 0         0 my $n = $skipped - (length($buff) - 1); # number of extra 0xff's
6529 0 0       0 if (not $n) {
    0          
6530 0         0 $buff = substr($buff, 0, -1); # remove trailing 0xff
6531             } elsif ($n > 1) {
6532 0         0 $buff .= "\xff" x ($n - 1); # add back extra 0xff's
6533             }
6534 0         0 $md5->add($buff);
6535 0         0 $md5size += $skipped + 2;
6536             }
6537             # read second segment too if this was the first
6538 1894 100       4782 next unless defined $marker;
6539             }
6540             # set some useful variables for the current segment
6541 1894         5311 my $markerName = JpegMarkerName($marker);
6542 1894         4476 $$path[$pn] = $markerName;
6543             # issue warning if we skipped some garbage
6544 1894 0 33     5073 if ($skipped and not $foundSOS and $markerName ne 'SOS') {
      33        
6545 0         0 $self->Warn("Skipped unknown $skipped bytes after JPEG $markerName segment", 1);
6546 0 0       0 if ($htmlDump) {
6547 0         0 $self->HDump($nextSegPos-4-$skipped, $skipped, "[unknown $skipped bytes]", undef, 0x08);
6548 0         0 $dumpEnd = $nextSegPos - 4;
6549             }
6550             }
6551             #
6552             # parse the current segment
6553             #
6554             # handle SOF markers: SOF0-SOF15, except DHT(0xc4), JPGA(0xc8) and DAC(0xcc)
6555 1894 100 66     20499 if (($marker & 0xf0) == 0xc0 and ($marker == 0xc0 or $marker & 0x03)) {
    100 100        
    100 66        
    100 33        
    50 66        
    100          
6556 242         695 $length = length $$segDataPt;
6557 242 100       1232 if ($verbose) {
    50          
6558 2         13 print $out "JPEG $markerName ($length bytes):\n";
6559 2 100       14 HexDump($segDataPt, undef, %dumpParms, Addr=>$segPos) if $verbose>2;
6560             } elsif ($htmlDump) {
6561 0         0 $self->HDump($segPos-4, $length+4, "[JPEG $markerName]", undef, 0x08);
6562 0         0 $dumpEnd = $segPos + $length;
6563             }
6564 242 50       818 next unless $length >= 6;
6565             # extract some useful information
6566 242         1258 my ($p, $h, $w, $n) = unpack('Cn2C', $$segDataPt);
6567 242         972 my $sof = GetTagTable('Image::ExifTool::JPEG::SOF');
6568 242         1600 $self->HandleTag($sof, 'ImageWidth', $w);
6569 242         1331 $self->HandleTag($sof, 'ImageHeight', $h);
6570 242         1742 $self->HandleTag($sof, 'EncodingProcess', $marker - 0xc0);
6571 242         1724 $self->HandleTag($sof, 'BitsPerSample', $p);
6572 242         1679 $self->HandleTag($sof, 'ColorComponents', $n);
6573 242 50 33     2601 next unless $n == 3 and $length >= 15;
6574 242         764 my ($i, $hmin, $hmax, $vmin, $vmax);
6575             # loop through all components to determine sampling frequency
6576 242         718 $subSampling = '';
6577 242         1208 for ($i=0; $i<$n; ++$i) {
6578 726         1868 my $sf = Get8u($segDataPt, 7 + 3 * $i);
6579 726         2957 $subSampling .= sprintf('%.2x', $sf);
6580             # isolate horizontal and vertical components
6581 726         1857 my ($hf, $vf) = ($sf >> 4, $sf & 0x0f);
6582 726 100       2121 unless ($i) {
6583 242         642 $hmin = $hmax = $hf;
6584 242         686 $vmin = $vmax = $vf;
6585 242         775 next;
6586             }
6587             # determine min/max frequencies
6588 484 100       1888 $hmin = $hf if $hf < $hmin;
6589 484 50       1436 $hmax = $hf if $hf > $hmax;
6590 484 100       1268 $vmin = $vf if $vf < $vmin;
6591 484 50       1738 $vmax = $vf if $vf > $vmax;
6592             }
6593 242 50 33     1814 if ($hmin and $vmin) {
6594 242         887 my ($hs, $vs) = ($hmax / $hmin, $vmax / $vmin);
6595 242         2332 $self->HandleTag($sof, 'YCbCrSubSampling', "$hs $vs");
6596             }
6597 242         1044 next;
6598             } elsif ($marker == 0xd9) { # EOI
6599 3         13 pop @$path;
6600 3 100       20 $verbose and print $out "JPEG EOI\n";
6601 3         15 my $pos = $raf->Tell();
6602 3 50 33     35 if ($htmlDump and $dumpEnd) {
6603 0         0 $self->HDump($dumpEnd, $pos-2-$dumpEnd, '[JPEG Image Data]', undef, 0x08);
6604 0         0 $self->HDump($pos-2, 2, 'JPEG EOI', undef);
6605 0         0 $dumpEnd = 0;
6606             }
6607 3 50 66     22 if ($foundSOS or $$self{FILE_TYPE} eq 'EXV') {
6608 3         8 $success = 1;
6609             } else {
6610 0         0 $self->Warn('Missing JPEG SOS');
6611             }
6612 3 50       13 if ($$req{trailer}) {
6613             # read entire trailer into memory
6614 0 0       0 if ($raf->Seek(0,2)) {
6615 0         0 my $len = $raf->Tell() - $pos;
6616 0 0       0 if ($len) {
6617 0         0 my $buff;
6618 0         0 $raf->Seek($pos, 0);
6619 0 0       0 $self->FoundTag(Trailer => \$buff) if $raf->Read($buff,$len) == $len;
6620 0         0 $raf->Seek($pos, 0);
6621             }
6622             } else {
6623 0         0 $self->Warn('Error seeking in file');
6624             }
6625             }
6626             # we are here because we are looking for trailer information
6627 3 50       15 if ($wantTrailer) {
6628 0         0 my $start = $$self{PreviewImageStart};
6629 0 0 0     0 if ($start or $$options{ExtractEmbedded}) {
6630 0         0 my $buff;
6631             # most previews start right after the JPEG EOI, but the Olympus E-20
6632             # preview is 508 bytes into the trailer, the K-M Maxxum 7D preview is
6633             # 979 bytes in, and Sony previews can start up to 32 kB into the trailer.
6634             # (and Minolta and Sony previews can have a random first byte...)
6635 0 0       0 my $scanLen = $$self{Make} =~ /Sony/i ? 65536 : 1024;
6636 0 0       0 if ($raf->Read($buff, $scanLen)) {
6637 0 0 0     0 if ($buff =~ /^.{4}ftyp/s) {
    0 0        
6638 0         0 my $val;
6639 0 0       0 if ($raf->Seek(0,2)) {
6640 0         0 my $len = $raf->Tell() - $pos;
6641 0 0       0 if ($$options{Binary}) {
6642 0 0 0     0 $val = \$buff if $raf->Seek($pos,0) and $raf->Read($buff,$len)==$len;
6643             } else {
6644 0         0 $val = \ "Binary data $len bytes";
6645             }
6646 0 0       0 if ($val) {
6647 0         0 $self->FoundTag('EmbeddedVideo', $val);
6648             } else {
6649 0         0 $self->Warn('Error reading trailer');
6650             }
6651             } else {
6652 0         0 $self->Warn('Error seeking to end of file');
6653             }
6654             } elsif ($buff =~ /\xff\xd8\xff./g or
6655             ($$self{Make} =~ /(Minolta|Sony)/i and $buff =~ /.\xd8\xff\xdb/g))
6656             {
6657             # adjust PreviewImageStart to this location
6658 0         0 my $actual = $pos + pos($buff) - 4;
6659 0 0 0     0 if ($start and $start ne $actual and $verbose > 1) {
      0        
6660 0         0 print $out "(Fixed PreviewImage location: $start -> $actual)\n";
6661             }
6662             # update preview image offsets
6663 0 0       0 if ($start) {
6664 0 0       0 $$self{VALUE}{PreviewImageStart} = $actual if $$self{VALUE}{PreviewImageStart};
6665 0         0 $$self{PreviewImageStart} = $actual;
6666             }
6667             # load preview now if we tried and failed earlier
6668 0 0 0     0 if ($$self{PreviewError} and $$self{PreviewImageLength}) {
6669 0 0 0     0 if ($raf->Seek($actual, 0) and $raf->Read($buff, $$self{PreviewImageLength})) {
6670 0         0 $self->FoundTag('PreviewImage', $buff);
6671 0         0 delete $$self{PreviewError};
6672             }
6673             }
6674             }
6675             }
6676 0         0 $raf->Seek($pos, 0);
6677             }
6678             }
6679             # process trailer now or finish processing trailers
6680             # and scan for AFCP if necessary
6681 3         7 my $fromEnd = 0;
6682 3 50       17 if ($trailInfo) {
6683 0         0 $$trailInfo{ScanForAFCP} = 1; # scan now if necessary
6684 0         0 $self->ProcessTrailers($trailInfo);
6685             # save offset from end of file to start of first trailer
6686 0         0 $fromEnd = $$trailInfo{Offset};
6687 0         0 undef $trailInfo;
6688             }
6689 3 50       13 if ($$self{LeicaTrailer}) {
6690 0         0 $raf->Seek(0, 2);
6691 0         0 $$self{LeicaTrailer}{TrailPos} = $pos;
6692 0         0 $$self{LeicaTrailer}{TrailLen} = $raf->Tell() - $pos - $fromEnd;
6693 0         0 Image::ExifTool::Panasonic::ProcessLeicaTrailer($self);
6694             }
6695             # finally, dump remaining information in JPEG trailer
6696 3 100 66     19 if ($verbose or $htmlDump) {
6697 1         3 my $endPos = $$self{LeicaTrailerPos};
6698 1 50       5 unless ($endPos) {
6699 1         4 $raf->Seek(0, 2);
6700 1         9 $endPos = $raf->Tell() - $fromEnd;
6701             }
6702             $self->DumpUnknownTrailer({
6703 1 50       4 RAF => $raf,
6704             DataPos => $pos,
6705             DirLen => $endPos - $pos
6706             }) if $endPos > $pos;
6707             }
6708 3 50       20 $self->FoundTag('JPEGImageLength', $pos - $appBytes) if $calcImageLen;
6709 3         10 last; # all done parsing file
6710             } elsif ($marker == 0xda) { # SOS
6711 242         1054 pop @$path;
6712 242         658 $foundSOS = 1;
6713             # all done with meta information unless we have a trailer
6714 242 100       861 $verbose and print $out "JPEG SOS\n";
6715 242 100       912 unless ($fast) {
6716 241         1064 $trailInfo = IdentifyTrailer($raf);
6717             # process trailer now unless we are doing verbose dump
6718 241 50 66     1874 if ($trailInfo and $verbose < 3 and not $htmlDump) {
      66        
6719             # process trailers (keep trailInfo to finish processing later
6720             # only if we can't finish without scanning from end of file)
6721 28 50       167 $self->ProcessTrailers($trailInfo) and undef $trailInfo;
6722             }
6723 241 0 33     1020 if ($wantTrailer and $$self{PreviewImageStart}) {
6724             # seek ahead and validate preview image
6725 0         0 my $buff;
6726 0         0 my $curPos = $raf->Tell();
6727 0 0 0     0 if ($raf->Seek($$self{PreviewImageStart}, 0) and
      0        
6728             $raf->Read($buff, 4) == 4 and
6729             $buff =~ /^.\xd8\xff[\xc4\xdb\xe0-\xef]/)
6730             {
6731 0         0 undef $wantTrailer;
6732             }
6733 0 0       0 $raf->Seek($curPos, 0) or last;
6734             }
6735             # seek ahead and process Leica trailer
6736 241 50       1055 if ($$self{LeicaTrailer}) {
6737 0         0 require Image::ExifTool::Panasonic;
6738 0         0 Image::ExifTool::Panasonic::ProcessLeicaTrailer($self);
6739 0 0       0 $wantTrailer = 1 if $$self{LeicaTrailer};
6740             } else {
6741 241 50       964 $wantTrailer = 1 if $$options{ExtractEmbedded};
6742             }
6743 241 100 33     2587 next if $trailInfo or $wantTrailer or $verbose > 2 or $htmlDump;
      66        
      66        
6744             }
6745             # must scan to EOI if Validate or JpegCompressionFactor used
6746 241 50 33     2680 next if $$options{Validate} or $calcImageLen or $$req{trailer} or $md5;
      33        
      33        
6747             # nothing interesting to parse after start of scan (SOS)
6748 241         551 $success = 1;
6749 241         608 last; # all done parsing file
6750             } elsif ($marker == 0x93) {
6751 1         3 pop @$path;
6752 1 50       5 $verbose and print $out "JPEG SOD\n";
6753 1         3 $success = 1;
6754 1 50 33     8 next if $verbose > 2 or $htmlDump;
6755 1         3 last; # all done parsing file
6756             } elsif (defined $markerLenBytes{$marker}) {
6757             # handle other stand-alone markers and segments we skipped over
6758 0 0 0     0 $verbose and $marker and print $out "JPEG $markerName\n";
6759 0         0 next;
6760             } elsif ($marker == 0xdb and length($$segDataPt) and # DQT
6761             # save the DQT data only if JPEGDigest has been requested
6762             # (Note: since we aren't checking the API RequestAll option here, the application
6763             # must use the RequestTags option to generate these tags if they have not been
6764             # specifically requested. The reason is that there is too much overhead involved
6765             # in the calculation of this tag to make this worth the CPU time.)
6766             ($$req{jpegdigest} or $$req{jpegqualityestimate}
6767             or ($$options{RequestAll} and $$options{RequestAll} > 2)))
6768             {
6769 1         5 my $num = unpack('C',$$segDataPt) & 0x0f; # get table index
6770 1 50       7 $dqt[$num] = $$segDataPt if $num < 4; # save for MD5 calculation
6771             }
6772             # handle all other markers
6773 1406         2934 my $dumpType = '';
6774 1406         2571 my ($desc, $tip, $xtra);
6775 1406         2646 $length = length $$segDataPt;
6776 1406 100       4664 $appBytes += $length + 4 if ($marker & 0xf0) == 0xe0; # total size of APP segments
6777 1406 100       3038 if ($verbose) {
6778 6         27 print $out "JPEG $markerName ($length bytes):\n";
6779 6 100       21 if ($verbose > 2) {
6780 3         10 my %extraParms = ( Addr => $segPos );
6781 3 50       13 $extraParms{MaxLen} = 128 if $verbose == 4;
6782 3         22 HexDump($segDataPt, undef, %dumpParms, %extraParms);
6783             }
6784             }
6785             # prepare dirInfo hash for processing this information
6786 1406         8439 my %dirInfo = (
6787             Parent => $markerName,
6788             DataPt => $segDataPt,
6789             DataPos => $segPos,
6790             DataLen => $length,
6791             DirStart => 0,
6792             DirLen => $length,
6793             Base => 0,
6794             );
6795 1406 100       17043 if ($marker == 0xe0) { # APP0 (JFIF, JFXX, CIFF, AVI1, Ocad)
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
6796 107 100       1286 if ($$segDataPt =~ /^JFIF\0/) {
    100          
    100          
    50          
6797 50         127 $dumpType = 'JFIF';
6798 50         255 DirStart(\%dirInfo, 5); # start at byte 5
6799 50         251 SetByteOrder('MM');
6800 50         267 my $tagTablePtr = GetTagTable('Image::ExifTool::JFIF::Main');
6801 50         355 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
6802             } elsif ($$segDataPt =~ /^JFXX\0(\x10|\x11|\x13)/) {
6803 19         78 my $tag = ord $1;
6804 19         49 $dumpType = 'JFXX';
6805 19         75 my $tagTablePtr = GetTagTable('Image::ExifTool::JFIF::Extension');
6806 19         109 my $tagInfo = $self->GetTagInfo($tagTablePtr, $tag);
6807 19         168 $self->FoundTag($tagInfo, substr($$segDataPt, 6));
6808             } elsif ($$segDataPt =~ /^(II|MM).{4}HEAPJPGM/s) {
6809 19 50       83 next if $fast > 1; # skip processing for very fast
6810 19         60 $dumpType = 'CIFF';
6811 19         114 my %dirInfo = ( RAF => new File::RandomAccess($segDataPt) );
6812 19         84 $$self{SET_GROUP1} = 'CIFF';
6813 19         44 push @{$$self{PATH}}, 'CIFF';
  19         75  
6814 19         1507 require Image::ExifTool::CanonRaw;
6815 19         181 Image::ExifTool::CanonRaw::ProcessCRW($self, \%dirInfo);
6816 19         59 pop @{$$self{PATH}};
  19         55  
6817 19         135 delete $$self{SET_GROUP1};
6818             } elsif ($$segDataPt =~ /^(AVI1|Ocad)/) {
6819 19         116 $dumpType = $1;
6820 19         78 SetByteOrder('MM');
6821 19         230 my $tagTablePtr = GetTagTable("Image::ExifTool::JPEG::$dumpType");
6822 19         118 DirStart(\%dirInfo, 4);
6823 19         110 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
6824             }
6825             } elsif ($marker == 0xe1) { # APP1 (EXIF, XMP, QVCI, PARROT)
6826             # (some Kodak cameras don't put a second "\0", and I have seen an
6827             # example where there was a second 4-byte APP1 segment header)
6828 272 100 66     3341 if ($$segDataPt =~ /^(.{0,4})Exif\0./is) {
    100          
    100          
    100          
    50          
6829 199         539 undef $dumpType; # (will be dumped here)
6830             # this is EXIF data --
6831             # get the data block (into a common variable)
6832 199         561 my $hdrLen = length($exifAPP1hdr);
6833 199 50       1561 if (length $1) {
    50          
6834 0         0 $hdrLen += length $1;
6835 0         0 $self->Warn('Unknown garbage at start of EXIF segment',1);
6836             } elsif ($$segDataPt !~ /^Exif\0/) {
6837 0         0 $self->Warn('Incorrect EXIF segment identifier',1);
6838             }
6839 199 50       770 if ($htmlDump) {
6840 0         0 $self->HDump($segPos-4, 4, 'APP1 header', "Data size: $length bytes");
6841 0         0 $self->HDump($segPos, $hdrLen, 'Exif header', 'APP1 data type: Exif');
6842 0         0 $dumpEnd = $segPos + $length;
6843             }
6844 199         517 my $dataPt = $segDataPt;
6845 199 50       704 if (defined $combinedSegData) {
6846 0         0 push @skipData, [ $segPos-4, $segPos+$hdrLen ];
6847 0         0 $combinedSegData .= substr($$segDataPt,$hdrLen);
6848 0         0 undef $$segDataPt;
6849 0         0 $dataPt = \$combinedSegData;
6850 0         0 $segPos = $firstSegPos;
6851             }
6852             # peek ahead to see if the next segment is extended EXIF
6853 199 50 66     1427 if ($nextMarker == $marker and
6854             $$nextSegDataPt =~ /^$exifAPP1hdr(?!(MM\0\x2a|II\x2a\0))/)
6855             {
6856             # initialize combined data if necessary
6857 0 0       0 unless (defined $combinedSegData) {
6858 0         0 $combinedSegData = $$segDataPt;
6859 0         0 undef $$segDataPt;
6860 0         0 $firstSegPos = $segPos;
6861 0         0 $self->Warn('File contains multi-segment EXIF',1);
6862 0         0 $$self{ExtendedEXIF} = 1;
6863             }
6864 0         0 next;
6865             }
6866 199         608 $dirInfo{DataPt} = $dataPt;
6867 199         485 $dirInfo{DataPos} = $segPos;
6868 199         552 $dirInfo{DataLen} = $dirInfo{DirLen} = length $$dataPt;
6869 199         917 DirStart(\%dirInfo, $hdrLen, $hdrLen);
6870 199 50       718 $$self{SkipData} = \@skipData if @skipData;
6871             # extract the EXIF information (it is in standard TIFF format)
6872 199 50       1158 $self->ProcessTIFF(\%dirInfo) or $self->Warn('Malformed APP1 EXIF segment');
6873             # avoid looking for preview unless necessary because it really slows
6874             # us down -- only look for it if we found pointer, and preview is
6875             # outside EXIF, and PreviewImage is specifically requested
6876 199         1053 my $start = $self->GetValue('PreviewImageStart', 'ValueConv');
6877 199         778 my $plen = $self->GetValue('PreviewImageLength', 'ValueConv');
6878 199 100 66     1344 if (not $start or not $plen and $$self{PreviewError}) {
      66        
6879 183         510 $start = $$self{PreviewImageStart};
6880 183         561 $plen = $$self{PreviewImageLength};
6881             }
6882 199 0 100     1047 if ($start and $plen and IsInt($start) and IsInt($plen) and
      66        
      66        
      33        
      0        
      33        
6883             $start + $plen > $$self{EXIF_POS} + length($$self{EXIF_DATA}) and
6884             ($$req{previewimage} or
6885             # (extracted normally, so check Binary option)
6886             ($$options{Binary} and not $$self{EXCL_TAG_LOOKUP}{previewimage})))
6887             {
6888 0         0 $$self{PreviewImageStart} = $start;
6889 0         0 $$self{PreviewImageLength} = $plen;
6890 0         0 $wantTrailer = 1;
6891             }
6892 199 50       838 if (@skipData) {
6893 0         0 undef @skipData;
6894 0         0 delete $$self{SkipData};
6895             }
6896 199         591 undef $$dataPt;
6897 199         1151 next;
6898             } elsif ($$segDataPt =~ /^$xmpExtAPP1hdr/) {
6899             # off len -- extended XMP header (75 bytes total):
6900             # 0 35 bytes - signature
6901             # 35 32 bytes - GUID (MD5 hash of full extended XMP data in ASCII)
6902             # 67 4 bytes - total size of extended XMP data
6903             # 71 4 bytes - offset for this XMP data portion
6904 2         7 $dumpType = 'Extended XMP';
6905 2 50       9 if ($length > 75) {
6906 2         11 my ($size, $off) = unpack('x67N2', $$segDataPt);
6907 2         8 my $guid = substr($$segDataPt, 35, 32);
6908 2 50       10 if ($guid =~ /[^A-Za-z0-9]/) { # (technically, should be uppercase)
6909 0         0 $self->WarnOnce($tip = 'Invalid extended XMP GUID');
6910             } else {
6911 2         6 my $extXMP = $extendedXMP{$guid};
6912 2 100       11 if (not $extXMP) {
    50          
6913 1         5 $extXMP = $extendedXMP{$guid} = { };
6914             } elsif ($size != $$extXMP{Size}) {
6915 0         0 $self->WarnOnce('Inconsistent extended XMP size');
6916             }
6917 2         6 $$extXMP{Size} = $size;
6918 2         7 $$extXMP{$off} = substr($$segDataPt, 75);
6919 2         12 $tip = "Full length: $size\nChunk offset: $off\nChunk length: " .
6920             ($length - 75) . "\nGUID: $guid";
6921             # (delay processing extended XMP until after reading all segments)
6922             }
6923             } else {
6924 0         0 $self->WarnOnce($tip = 'Invalid extended XMP segment');
6925             }
6926             } elsif ($$segDataPt =~ /^QVCI\0/) {
6927 1         4 $dumpType = 'QVCI';
6928 1         6 my $tagTablePtr = GetTagTable('Image::ExifTool::Casio::QVCI');
6929 1         5 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
6930             } elsif ($$segDataPt =~ /^FLIR\0/ and $length >= 8) {
6931 1         4 $dumpType = 'FLIR';
6932             # must concatenate FLIR chunks (note: handle the case where
6933             # some software erroneously writes zeros for the chunk counts)
6934 1         5 my $chunkNum = Get8u($segDataPt, 6);
6935 1         3 my $chunksTot = Get8u($segDataPt, 7) + 1; # (note the "+ 1"!)
6936 1 50       5 $verbose and printf $out "$$self{INDENT}FLIR chunk %d of %d\n",
6937             $chunkNum + 1, $chunksTot;
6938 1 50       4 if (defined $flirTotal) {
6939             # abort parsing FLIR if the total chunk count is inconsistent
6940 0 0       0 undef $flirCount if $chunksTot != $flirTotal;
6941             } else {
6942 1         3 $flirCount = 0;
6943 1         2 $flirTotal = $chunksTot;
6944             }
6945 1 50       21 if (defined $flirCount) {
6946 1 50       4 if (defined $flirChunk[$chunkNum]) {
6947 0         0 $self->WarnOnce('Duplicate FLIR chunk number(s)');
6948 0         0 $flirChunk[$chunkNum] .= substr($$segDataPt, 8);
6949             } else {
6950 1         13 $flirChunk[$chunkNum] = substr($$segDataPt, 8);
6951             }
6952             # process the FLIR information if we have all of the chunks
6953 1 50       5 if (++$flirCount >= $flirTotal) {
6954 1         2 my $flir = '';
6955 1   33     12 defined $_ and $flir .= $_ foreach @flirChunk;
6956 1         4 undef @flirChunk; # free memory
6957 1         3 my $tagTablePtr = GetTagTable('Image::ExifTool::FLIR::FFF');
6958 1         6 my %dirInfo = (
6959             DataPt => \$flir,
6960             Parent => $markerName,
6961             DirName => 'FLIR',
6962             );
6963 1         4 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
6964 1         3 undef $flirCount; # prevent reprocessing
6965             }
6966             } else {
6967 0         0 $self->WarnOnce('Invalid or extraneous FLIR chunk(s)');
6968             }
6969             } elsif ($$segDataPt =~ /^PARROT\0(II\x2a\0|MM\0\x2a)/) {
6970             # (don't know if this could span multiple segments)
6971 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::Main');
6972 0         0 $self->HandleTag($tagTablePtr, 'APP1', $$segDataPt);
6973 0         0 $dumpType = 'Parrot';
6974             } else {
6975             # Hmmm. Could be XMP, let's see
6976 69         199 my $processed;
6977 69 50 33     556 if ($$segDataPt =~ /^(http|XMP\0)/ or $$segDataPt =~ /<(exif:|\?xpacket)/) {
6978 69         201 $dumpType = 'XMP';
6979             # also try to parse XMP with a non-standard header
6980             # (note: this non-standard XMP is ignored when writing)
6981 69 50       672 my $start = ($$segDataPt =~ /^$xmpAPP1hdr/) ? length($xmpAPP1hdr) : 0;
6982 69         356 my $tagTablePtr = GetTagTable('Image::ExifTool::XMP::Main');
6983 69         455 DirStart(\%dirInfo, $start);
6984 69 50       630 $dirInfo{DirName} = $start ? 'XMP' : 'XML',
6985             $processed = $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
6986 69 50 33     697 if ($processed and not $start) {
6987 0         0 $self->Warn('Non-standard header for APP1 XMP segment');
6988             }
6989             }
6990 69 50 33     392 if ($verbose and not $processed) {
6991 0         0 $self->Warn("Ignored APP1 segment length $length (unknown header)");
6992             }
6993             }
6994             } elsif ($marker == 0xe2) { # APP2 (ICC Profile, FPXR, MPF, InfiRay, PreviewImage)
6995 121 100 66     1188 if ($$segDataPt =~ /^ICC_PROFILE\0/ and $length >= 14) {
    100          
    100          
    50          
    0          
    0          
6996 34         126 $dumpType = 'ICC_Profile';
6997             # must concatenate profile chunks (note: handle the case where
6998             # some software erroneously writes zeros for the chunk counts)
6999 34         134 my $chunkNum = Get8u($segDataPt, 12);
7000 34         187 my $chunksTot = Get8u($segDataPt, 13);
7001 34 50       183 $verbose and print $out "$$self{INDENT}ICC_Profile chunk $chunkNum of $chunksTot\n";
7002 34 50       133 if (defined $iccChunksTotal) {
7003             # abort parsing ICC_Profile if the total chunk count is inconsistent
7004 0 0       0 undef $iccChunkCount if $chunksTot != $iccChunksTotal;
7005             } else {
7006 34         83 $iccChunkCount = 0;
7007 34         81 $iccChunksTotal = $chunksTot;
7008 34 50       142 $self->Warn('ICC_Profile chunk count is zero') if !$chunksTot;
7009             }
7010 34 50       119 if (defined $iccChunkCount) {
7011 34 50       130 if (defined $iccChunk[$chunkNum]) {
7012 0         0 $self->WarnOnce('Duplicate ICC_Profile chunk number(s)');
7013 0         0 $iccChunk[$chunkNum] .= substr($$segDataPt, 14);
7014             } else {
7015 34         234 $iccChunk[$chunkNum] = substr($$segDataPt, 14);
7016             }
7017             # process profile if we have all of the chunks
7018 34 50       149 if (++$iccChunkCount >= $iccChunksTotal) {
7019 34         99 my $icc_profile = '';
7020 34   66     298 defined $_ and $icc_profile .= $_ foreach @iccChunk;
7021 34         105 undef @iccChunk; # free memory
7022 34         133 my $tagTablePtr = GetTagTable('Image::ExifTool::ICC_Profile::Main');
7023 34         345 my %dirInfo = (
7024             DataPt => \$icc_profile,
7025             DataPos => $segPos + 14,
7026             DataLen => length($icc_profile),
7027             DirStart => 0,
7028             DirLen => length($icc_profile),
7029             Parent => $markerName,
7030             );
7031 34         200 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7032 34         197 undef $iccChunkCount; # prevent reprocessing
7033             }
7034             } else {
7035 0         0 $self->WarnOnce('Invalid or extraneous ICC_Profile chunk(s)');
7036             }
7037             } elsif ($$segDataPt =~ /^FPXR\0/) {
7038 67 50       225 next if $fast > 1; # skip processing for very fast
7039 67         156 $dumpType = 'FPXR';
7040 67         217 my $tagTablePtr = GetTagTable('Image::ExifTool::FlashPix::Main');
7041             # set flag if this is the last FPXR segment
7042 67   100     641 $dirInfo{LastFPXR} = not ($nextMarker==$marker and $$nextSegDataPt=~/^FPXR\0/),
7043             $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7044             } elsif ($$segDataPt =~ /^MPF\0/) {
7045 19         56 undef $dumpType; # (will be dumped here)
7046 19         107 DirStart(\%dirInfo, 4, 4);
7047 19         83 $dirInfo{Multi} = 1; # the MP Attribute IFD will be MPF1
7048 19 50       79 if ($htmlDump) {
7049 0         0 $self->HDump($segPos-4, 4, 'APP2 header', "Data size: $length bytes");
7050 0         0 $self->HDump($segPos, 4, 'MPF header', 'APP2 data type: MPF');
7051 0         0 $dumpEnd = $segPos + $length;
7052             }
7053             # extract the MPF information (it is in standard TIFF format)
7054 19         59 my $tagTablePtr = GetTagTable('Image::ExifTool::MPF::Main');
7055 19         182 $self->ProcessTIFF(\%dirInfo, $tagTablePtr);
7056             } elsif ($$segDataPt =~ /^....IJPEG\0/s) {
7057 1         3 $dumpType = 'InfiRay Version';
7058 1         3 $$self{HasIJPEG} = 1;
7059 1         3 SetByteOrder('II');
7060 1         3 my $tagTablePtr = GetTagTable('Image::ExifTool::InfiRay::Version');
7061 1         13 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7062             } elsif ($$segDataPt =~ /^(|QVGA\0|BGTH)\xff\xd8\xff[\xdb\xe0\xe1]/) {
7063             # Samsung/GE/GoPro="", BenQ DC C1220/Pentacon/Polaroid="QVGA\0",
7064             # Digilife DDC-690/Rollei="BGTH"
7065 0         0 $dumpType = 'Preview Image';
7066 0         0 $preview = substr($$segDataPt, length($1));
7067             } elsif ($preview) {
7068 0         0 $dumpType = 'Preview Image';
7069 0         0 $preview .= $$segDataPt;
7070             }
7071 121 50 33     477 if ($preview and $nextMarker ne $marker) {
7072 0         0 $self->FoundTag('PreviewImage', $preview);
7073 0         0 undef $preview;
7074             }
7075             } elsif ($marker == 0xe3) { # APP3 (Kodak "Meta", Stim)
7076 21 100 33     266 if ($$segDataPt =~ /^(Meta|META|Exif)\0\0/) {
    50          
    100          
    50          
    0          
    0          
7077 19         59 undef $dumpType; # (will be dumped here)
7078 19         77 DirStart(\%dirInfo, 6, 6);
7079 19 50       146 if ($htmlDump) {
7080 0         0 $self->HDump($segPos-4, 10, 'APP3 Meta header');
7081 0         0 $dumpEnd = $segPos + $length;
7082             }
7083 19         87 my $tagTablePtr = GetTagTable('Image::ExifTool::Kodak::Meta');
7084 19         133 $self->ProcessTIFF(\%dirInfo, $tagTablePtr);
7085             } elsif ($$segDataPt =~ /^Stim\0/) {
7086 0         0 undef $dumpType; # (will be dumped here)
7087 0         0 DirStart(\%dirInfo, 6, 6);
7088 0 0       0 if ($htmlDump) {
7089 0         0 $self->HDump($segPos-4, 4, 'APP3 header', "Data size: $length bytes");
7090 0         0 $self->HDump($segPos, 5, 'Stim header', 'APP3 data type: Stim');
7091 0         0 $dumpEnd = $segPos + $length;
7092             }
7093             # extract the Stim information (it is in standard TIFF format)
7094 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::Stim::Main');
7095 0         0 $self->ProcessTIFF(\%dirInfo, $tagTablePtr);
7096             } elsif ($$segDataPt =~ /^_JPSJPS_/) {
7097 1         3 $dumpType = 'JPS';
7098 1 50       10 $self->OverrideFileType('JPS') if $$self{FILE_TYPE} eq 'JPEG';
7099 1         4 SetByteOrder('MM');
7100 1         8 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::JPS');
7101 1         7 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7102             } elsif ($$self{HasIJPEG} or $$self{Make} eq 'DJI') {
7103 1 50       8 $dumpType = $$self{HasIJPEG} ? 'InfiRay ImagingData' : 'DJI ThermalData';
7104             # add this data to the combined data if it exists
7105 1         3 my $dataPt = $segDataPt;
7106 1 50       5 if (defined $combinedSegData) {
7107 0         0 $combinedSegData .= $$segDataPt;
7108 0         0 $dataPt = \$combinedSegData;
7109             }
7110 1 50       6 if ($nextMarker == $marker) {
7111 0 0       0 $combinedSegData = $$segDataPt unless defined $combinedSegData;
7112             } else {
7113             # process InfiRay/DJI thermal data
7114 1         6 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::Main');
7115 1         8 $self->HandleTag($tagTablePtr, 'APP3', $$dataPt);
7116 1         2 undef $combinedSegData;
7117             }
7118             } elsif ($$self{HasIJPEG}) {
7119 0         0 $dumpType = 'InfiRay Data',
7120            
7121             } elsif ($$segDataPt =~ /^\xff\xd8\xff\xdb/) {
7122 0         0 $dumpType = 'PreviewImage'; # (Samsung, HP, BenQ)
7123 0         0 $preview = $$segDataPt;
7124             }
7125 21 50 33     179 if ($preview and $nextMarker ne 0xe4) { # this preview continues in APP4
7126 0         0 $self->FoundTag('PreviewImage', $preview);
7127 0         0 undef $preview;
7128             }
7129             } elsif ($marker == 0xe4) { # APP4 (InfiRay, "SCALADO", FPXR, DJI, PreviewImage)
7130 1 50 33     25 if ($$segDataPt =~ /^SCALADO\0/ and $length >= 16) {
    50 33        
    50 33        
    50 33        
    50 33        
    50          
    0          
7131 0         0 $dumpType = 'SCALADO';
7132 0         0 my ($num, $idx, $len) = unpack('x8n2N', $$segDataPt);
7133             # assume that the segments are in order and just concatinate them
7134 0 0       0 $scalado = '' unless defined $scalado;
7135 0         0 $scalado .= substr($$segDataPt, 16);
7136 0 0       0 if ($idx == $num - 1) {
7137 0 0       0 if ($len != length $scalado) {
7138 0         0 $self->Warn('Possibly corrupted APP4 SCALADO data', 1);
7139             }
7140 0         0 my %dirInfo = (
7141             Parent => $markerName,
7142             DataPt => \$scalado,
7143             );
7144 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::Scalado::Main');
7145 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7146 0         0 undef $scalado;
7147             }
7148             } elsif ($$segDataPt =~ /^FPXR\0/) {
7149 0 0       0 next if $fast > 1; # skip processing for very fast
7150 0         0 $dumpType = 'FPXR';
7151 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::FlashPix::Main');
7152             # set flag if this is the last FPXR segment
7153 0   0     0 $dirInfo{LastFPXR} = not ($nextMarker==$marker and $$nextSegDataPt=~/^FPXR\0/),
7154             $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7155             } elsif ($$self{Make} eq 'DJI' and $$segDataPt =~ /^\xaa\x55\x12\x06/) {
7156 0         0 $dumpType = 'DJI ThermalParams';
7157 0         0 DirStart(\%dirInfo, 0, 0);
7158 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::DJI::ThermalParams');
7159 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7160             } elsif ($$self{Make} eq 'DJI' and $$segDataPt =~ /^(.{32})?.{32}\x2c\x01\x20\0/s) {
7161 0         0 $dumpType = 'DJI ThermalParams2';
7162 0 0       0 DirStart(\%dirInfo, $1 ? 32 : 0, 0);
7163 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::DJI::ThermalParams2');
7164 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7165             } elsif ($$self{Make} eq 'DJI' and $$segDataPt =~ /^.{32}\xaa\x55\x38\0/s) {
7166 0         0 $dumpType = 'DJI ThermalParams3';
7167 0         0 DirStart(\%dirInfo, 32, 0);
7168 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::DJI::ThermalParams3');
7169 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7170             } elsif ($$self{HasIJPEG} and $length >= 120) {
7171 1         4 $dumpType = 'InfiRay Factory';
7172 1         4 SetByteOrder('II');
7173 1         3 my $tagTablePtr = GetTagTable('Image::ExifTool::InfiRay::Factory');
7174 1         4 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7175             } elsif ($preview) {
7176             # continued Samsung S1060 preview from APP3
7177 0         0 $dumpType = 'PreviewImage';
7178 0         0 $preview .= $$segDataPt;
7179             }
7180             # (also seen "QTI Debug Metadata\0" segment in some newer Samsung images)
7181             # BenQ DC E1050 continues preview in APP5
7182 1 50 33     19 if ($preview and $nextMarker ne 0xe5) {
7183 0         0 $self->FoundTag('PreviewImage', $preview);
7184 0         0 undef $preview;
7185             }
7186             } elsif ($marker == 0xe5) { # APP5 (InfiRay, Ricoh "RMETA")
7187 21 100 33     196 if ($$segDataPt =~ /^RMETA\0/) {
    50          
    50          
    50          
    0          
7188             # (NOTE: apparently these may span multiple segments, but I haven't seen
7189             # a sample like this, so multi-segment support hasn't yet been implemented)
7190 20         65 $dumpType = 'Ricoh RMETA';
7191 20         102 DirStart(\%dirInfo, 6, 6);
7192 20         140 my $tagTablePtr = GetTagTable('Image::ExifTool::Ricoh::RMETA');
7193 20         137 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7194             } elsif ($$segDataPt =~ /^ssuniqueid\0/) {
7195 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::Samsung::APP5');
7196 0         0 $self->HandleTag($tagTablePtr, 'ssuniqueid', substr($$segDataPt, 11));
7197             } elsif ($$self{Make} eq 'DJI') {
7198 0         0 $dumpType = 'DJI ThermalCal';
7199 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::Main');
7200 0         0 $self->HandleTag($tagTablePtr, 'APP5', $$segDataPt);
7201             } elsif ($$self{HasIJPEG} and $length >= 38) {
7202 1         3 $dumpType = 'InfiRay Picture';
7203 1         6 SetByteOrder('II');
7204 1         3 my $tagTablePtr = GetTagTable('Image::ExifTool::InfiRay::Picture');
7205 1         5 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7206             } elsif ($preview) {
7207 0         0 $dumpType = 'PreviewImage';
7208 0         0 $preview .= $$segDataPt;
7209 0         0 $self->FoundTag('PreviewImage', $preview);
7210 0         0 undef $preview;
7211             }
7212             } elsif ($marker == 0xe6) { # APP6 (InfiRay, Toshiba EPPIM, NITF, HP_TDHD)
7213 38 100 33     432 if ($$segDataPt =~ /^EPPIM\0/) {
    100 33        
    50          
    100          
    50          
    50          
7214 18         52 undef $dumpType; # (will be dumped here)
7215 18         77 DirStart(\%dirInfo, 6, 6);
7216 18 50       88 if ($htmlDump) {
7217 0         0 $self->HDump($segPos-4, 10, 'APP6 EPPIM header');
7218 0         0 $dumpEnd = $segPos + $length;
7219             }
7220 18         88 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::EPPIM');
7221 18         106 $self->ProcessTIFF(\%dirInfo, $tagTablePtr);
7222             } elsif ($$segDataPt =~ /^NITF\0/) {
7223 18         59 $dumpType = 'NITF';
7224 18         73 SetByteOrder('MM');
7225 18         137 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::NITF');
7226 18         107 DirStart(\%dirInfo, 5);
7227 18         112 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7228             } elsif ($$segDataPt =~ /^TDHD\x01\0\0\0/ and $length > 12) {
7229             # HP Photosmart R837 APP6 "TDHD" segment
7230 0         0 $dumpType = 'TDHD';
7231 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::HP::TDHD');
7232             # (ignore first TDHD element because size includes 12-byte tag header)
7233 0         0 DirStart(\%dirInfo, 12);
7234 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7235             } elsif ($$segDataPt =~ /^GoPro\0/) {
7236             # GoPro segment
7237 1         2 $dumpType = 'GoPro';
7238 1         3 my $tagTablePtr = GetTagTable('Image::ExifTool::GoPro::GPMF');
7239 1         3 DirStart(\%dirInfo, 6);
7240 1         4 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7241             } elsif ($$segDataPt =~ /^DTAT\0\0.\{/s) {
7242 0         0 $dumpType = 'DJI_DTAT';
7243 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::Main');
7244 0         0 $self->HandleTag($tagTablePtr, 'APP6', $$segDataPt);
7245             } elsif ($$self{HasIJPEG} and $length >= 129) {
7246 1         4 $dumpType = 'InfiRay MixMode';
7247 1         6 SetByteOrder('II');
7248 1         4 my $tagTablePtr = GetTagTable('Image::ExifTool::InfiRay::MixMode');
7249 1         4 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7250             }
7251             } elsif ($marker == 0xe7) { # APP7 (InfiRay, Pentax, Huawei, Qualcomm)
7252 20 50 33     309 if ($$segDataPt =~ /^PENTAX \0(II|MM)/) {
    50          
    50          
    100          
    50          
7253             # found in K-3 images (is this multi-segment??)
7254 0         0 SetByteOrder($1);
7255 0         0 undef $dumpType; # (dump this ourself)
7256 0         0 my $hdrLen = 10;
7257 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::Pentax::Main');
7258 0         0 DirStart(\%dirInfo, $hdrLen, 0);
7259 0         0 $dirInfo{DirName} = 'Pentax APP7';
7260 0 0       0 if ($htmlDump) {
7261 0         0 $self->HDump($segPos-4, 4, 'APP7 header', "Data size: $length bytes");
7262 0         0 $self->HDump($segPos, $hdrLen, 'Pentax header', 'APP7 data type: Pentax');
7263 0         0 $dumpEnd = $segPos + $length;
7264             }
7265 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7266             } elsif ($$segDataPt =~ /^HUAWEI\0\0(II|MM)/) {
7267 0         0 SetByteOrder($1);
7268 0         0 undef $dumpType; # (dump this ourself)
7269 0         0 my $hdrLen = 16;
7270 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::Unknown::Main');
7271 0         0 DirStart(\%dirInfo, $hdrLen, 8);
7272 0         0 $dirInfo{DirName} = 'Huawei APP7';
7273 0 0       0 if ($htmlDump) {
7274 0         0 $self->HDump($segPos-4, 4, 'APP7 header', "Data size: $length bytes");
7275 0         0 $self->HDump($segPos, $hdrLen, 'Huawei header', 'APP7 data type: Huawei');
7276 0         0 $dumpEnd = $segPos + $length;
7277             }
7278 0         0 $$self{SET_GROUP0} = 'APP7';
7279 0         0 $$self{SET_GROUP1} = 'Huawei';
7280 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7281 0         0 delete $$self{SET_GROUP0};
7282 0         0 delete $$self{SET_GROUP1};
7283             } elsif ($$segDataPt =~ /^DJI-DBG\0/) {
7284 0         0 $dumpType = 'DJI Info';
7285 0         0 my $tagTablePtr = GetTagTable('Image::ExifTool::DJI::Info');
7286 0         0 DirStart(\%dirInfo, 8, 0);
7287 0         0 $$self{SET_GROUP0} = 'APP7';
7288 0         0 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7289 0         0 delete $$self{SET_GROUP0};
7290             } elsif ($$segDataPt =~ /^\x1aQualcomm Camera Attributes/) {
7291             # found in HP iPAQ_VoiceMessenger
7292 19         55 $dumpType = 'Qualcomm';
7293 19         73 my $tagTablePtr = GetTagTable('Image::ExifTool::Qualcomm::Main');
7294 19         120 DirStart(\%dirInfo, 27);
7295 19         88 $dirInfo{DirName} = 'Qualcomm';
7296 19         101 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7297             } elsif ($$self{HasIJPEG} and $length >= 32) {
7298 1         5 $dumpType = 'InfiRay OpMode';
7299 1         3 SetByteOrder('II');
7300 1         13 my $tagTablePtr = GetTagTable('Image::ExifTool::InfiRay::OpMode');
7301 1         6 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7302             }
7303             } elsif ($marker == 0xe8) { # APP8 (InfiRay, SPIFF)
7304             # my sample SPIFF has 32 bytes of data, but spec states 30
7305 20 100 66     175 if ($$segDataPt =~ /^SPIFF\0/ and $length == 32) {
    50 33        
7306 19         50 $dumpType = 'SPIFF';
7307 19         74 DirStart(\%dirInfo, 6);
7308 19         87 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::SPIFF');
7309 19         113 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7310             } elsif ($$self{HasIJPEG} and $length >= 32) {
7311 1         3 $dumpType = 'InfiRay Isothermal';
7312 1         5 SetByteOrder('II');
7313 1         7 my $tagTablePtr = GetTagTable('Image::ExifTool::InfiRay::Isothermal');
7314 1         6 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7315             }
7316             } elsif ($marker == 0xe9) { # APP9 (InfiRay, Media Jukebox)
7317 20 100 66     241 if ($$segDataPt =~ /^Media Jukebox\0/ and $length > 22) {
    50 33        
7318 19         71 $dumpType = 'MediaJukebox';
7319             # (start parsing after the "")
7320 19         108 DirStart(\%dirInfo, 22);
7321 19         120 $dirInfo{DirName} = 'MediaJukebox';
7322 19         204 require Image::ExifTool::XMP;
7323 19         161 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::MediaJukebox');
7324 19         149 $self->ProcessDirectory(\%dirInfo, $tagTablePtr, \&Image::ExifTool::XMP::ProcessXMP);
7325             } elsif ($$self{HasIJPEG} and $length >= 768) {
7326 1         4 $dumpType = 'InfiRay Sensor';
7327 1         16 SetByteOrder('II');
7328 1         3 my $tagTablePtr = GetTagTable('Image::ExifTool::InfiRay::Sensor');
7329 1         5 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7330             }
7331             } elsif ($marker == 0xea) { # APP10 (PhotoStudio Unicode comments)
7332 19 50 0     144 if ($$segDataPt =~ /^UNICODE\0/) {
    0          
7333 19         60 $dumpType = 'PhotoStudio';
7334 19         109 my $comment = $self->Decode(substr($$segDataPt,8), 'UCS2', 'MM');
7335 19         143 $self->FoundTag('Comment', $comment);
7336             } elsif ($$segDataPt =~ /^AROT\0/ and $length > 10) {
7337             # iPhone "AROT" segment containing integrated intensity per 16 scan lines
7338             # (with number of elements N = ImageHeight / 16 - 1, ref PH/NealKrawetz)
7339 0         0 $xtra = 'segment (N=' . unpack('x6N', $$segDataPt) . ')';
7340             }
7341             } elsif ($marker == 0xeb) { # APP11 (JPEG-HDR, JUMBF)
7342 38 100 33     446 if ($$segDataPt =~ /^HDR_RI /) {
    50          
7343 19         53 $dumpType = 'JPEG-HDR';
7344 19         57 my $dataPt = $segDataPt;
7345 19 50       74 if (defined $combinedSegData) {
7346 0 0       0 if ($$segDataPt =~ /~\0/g) {
7347 0         0 $combinedSegData .= substr($$segDataPt,pos($$segDataPt));
7348             } else {
7349 0         0 $self->Warn('Invalid format for JPEG-HDR extended segment');
7350             }
7351 0         0 $dataPt = \$combinedSegData;
7352             }
7353 19 50 33     170 if ($nextMarker == $marker and $$nextSegDataPt =~ /^HDR_RI /) {
7354 0 0       0 $combinedSegData = $$segDataPt unless defined $combinedSegData;
7355             } else {
7356 19         68 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::HDR');
7357 19         94 my %dirInfo = ( DataPt => $dataPt );
7358 19         109 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7359 19         140 undef $combinedSegData;
7360             }
7361             } elsif ($$segDataPt =~ /^(JP..)/s and length($$segDataPt) >= 16) {
7362             # JUMBF extension marker
7363 19         554 my $hdr = $1;
7364 19         57 $dumpType = 'JUMBF';
7365 19         79 SetByteOrder('MM');
7366 19         178 my $seq = Get32u($segDataPt, 4) - 1; # (start from 0)
7367 19         130 my $len = Get32u($segDataPt, 8);
7368 19         93 my $type = substr($$segDataPt, 12, 4);
7369 19         390 my $hdrLen;
7370 19 50 33     114 if ($len == 1 and length($$segDataPt) >= 24) {
7371 0         0 $len = Get64u($$segDataPt, 16);
7372 0         0 $hdrLen = 16;
7373             } else {
7374 19         52 $hdrLen = 8;
7375             }
7376 19 50       124 $jumbfChunk{$type} or $jumbfChunk{$type} = [ ];
7377 19 50       135 if ($len < $hdrLen) {
    50          
    50          
7378 0         0 $self->Warn('Invalid JUMBF segment');
7379             } elsif ($seq < 0) {
7380 0         0 $self->Warn('Invalid JUMBF sequence number');
7381             } elsif (defined $jumbfChunk{$type}[$seq]) {
7382 0         0 $self->Warn('Duplicate JUMBF sequence number');
7383             } else {
7384             # add to list of JUMBF chunks
7385 19         83 $jumbfChunk{$type}[$seq] = substr($$segDataPt, 8 + $hdrLen);
7386             # check to see if we have a complete JUMBF box
7387 19         50 my $size = $hdrLen;
7388 19         43 foreach (@{$jumbfChunk{$type}}) {
  19         68  
7389 19 50       71 defined $_ or $size = 0, last;
7390 19         53 $size += length $_;
7391             }
7392 19 50       71 if ($size == $len) {
7393 19         61 my $buff = join '', substr($$segDataPt,8,$hdrLen), @{$jumbfChunk{$type}};
  19         84  
7394 19         68 $dirInfo{DataPt} = \$buff;
7395 19         55 $dirInfo{DataPos} = $segPos + 8; # (shows correct offsets for single-segment JUMBF)
7396 19         63 $dirInfo{DataLen} = $dirInfo{DirLen} = $size;
7397 19         83 my $tagTablePtr = GetTagTable('Image::ExifTool::Jpeg2000::Main');
7398 19         144 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7399 19         112 delete $jumbfChunk{$type};
7400             }
7401             }
7402             }
7403             } elsif ($marker == 0xec) { # APP12 (Ducky, Picture Info)
7404 40 100       233 if ($$segDataPt =~ /^Ducky/) {
7405 21         86 $dumpType = 'Ducky';
7406 21         98 DirStart(\%dirInfo, 5);
7407 21         108 my $tagTablePtr = GetTagTable('Image::ExifTool::APP12::Ducky');
7408 21         115 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7409             } else {
7410 19         93 my $tagTablePtr = GetTagTable('Image::ExifTool::APP12::PictureInfo');
7411 19 50       105 $self->ProcessDirectory(\%dirInfo, $tagTablePtr) and $dumpType = 'Picture Info';
7412             }
7413             } elsif ($marker == 0xed) { # APP13 (Photoshop, Adobe_CM)
7414 82         215 my $isOld;
7415 82 100 50     1307 if ($$segDataPt =~ /^$psAPP13hdr/ or ($$segDataPt =~ /^$psAPP13old/ and $isOld=1)) {
    50 66        
7416 63         228 $dumpType = 'Photoshop';
7417             # add this data to the combined data if it exists
7418 63         155 my $dataPt = $segDataPt;
7419 63 50       300 if (defined $combinedSegData) {
7420 0         0 $combinedSegData .= substr($$segDataPt,length($psAPP13hdr));
7421 0         0 $dataPt = \$combinedSegData;
7422             }
7423             # peek ahead to see if the next segment is photoshop data too
7424 63 50 66     420 if ($nextMarker == $marker and $$nextSegDataPt =~ /^$psAPP13hdr/) {
7425             # initialize combined data if necessary
7426 0 0       0 $combinedSegData = $$segDataPt unless defined $combinedSegData;
7427             # (will handle the Photoshop data the next time around)
7428             } else {
7429 63 50       254 my $hdrLen = $isOld ? 27 : 14;
7430             # process APP13 Photoshop record
7431 63         287 my $tagTablePtr = GetTagTable('Image::ExifTool::Photoshop::Main');
7432 63         594 my %dirInfo = (
7433             DataPt => $dataPt,
7434             DataPos => $segPos,
7435             DataLen => length $$dataPt,
7436             DirStart => $hdrLen, # directory starts after identifier
7437             DirLen => length($$dataPt) - $hdrLen,
7438             Parent => $markerName,
7439             );
7440 63         340 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7441 63         342 undef $combinedSegData;
7442             }
7443             } elsif ($$segDataPt =~ /^Adobe_CM/) {
7444 19         61 $dumpType = 'Adobe_CM';
7445 19         71 SetByteOrder('MM');
7446 19         134 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::AdobeCM');
7447 19         145 DirStart(\%dirInfo, 8);
7448 19         105 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7449             }
7450             } elsif ($marker == 0xee) { # APP14 (Adobe)
7451 45 50       496 if ($$segDataPt =~ /^Adobe/) {
7452             # extract as a block if requested, or if copying tags from file
7453 45 100 66     405 if ($$req{adobe} or
      66        
7454             # (not extracted normally, so check TAGS_FROM_FILE)
7455             ($$self{TAGS_FROM_FILE} and not $$self{EXCL_TAG_LOOKUP}{adobe}))
7456             {
7457 16         77 $self->FoundTag('Adobe', $$segDataPt);
7458             }
7459 45         174 $dumpType = 'Adobe';
7460 45         196 SetByteOrder('MM');
7461 45         252 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::Adobe');
7462 45         221 DirStart(\%dirInfo, 5);
7463 45         210 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7464             }
7465             } elsif ($marker == 0xef) { # APP15 (GraphicConverter)
7466 19 50 33     195 if ($$segDataPt =~ /^Q\s*(\d+)/ and $length == 4) {
7467 19         57 $dumpType = 'GraphicConverter';
7468 19         62 my $tagTablePtr = GetTagTable('Image::ExifTool::JPEG::GraphConv');
7469 19         115 $self->HandleTag($tagTablePtr, 'Q', $1);
7470             }
7471             } elsif ($marker == 0xfe) { # COM (JPEG comment)
7472 27         99 $dumpType = 'Comment';
7473 27         105 $$segDataPt =~ s/\0+$//; # some dumb softwares add null terminators
7474 27         105 $self->FoundTag('Comment', $$segDataPt);
7475             } elsif ($marker == 0x64) { # CME (J2C comment and extension)
7476 2         5 $dumpType = 'Comment';
7477 2 50       8 if ($length > 2) {
7478 2         5 my $reg = unpack('n', $$segDataPt); # get registration value
7479 2         7 my $val = substr($$segDataPt, 2);
7480 2 50       10 $val = $self->Decode($val, 'Latin') if $reg == 1;
7481             # (actually an extension for $reg==65535, but store as binary comment)
7482 2 50 33     13 $self->FoundTag('Comment', ($reg==0 or $reg==65535) ? \$val : $val);
7483             }
7484             } elsif ($marker == 0x51) { # SIZ (J2C)
7485 1         5 my ($w, $h) = unpack('x2N2', $$segDataPt);
7486 1         5 $self->FoundTag('ImageWidth', $w);
7487 1         7 $self->FoundTag('ImageHeight', $h);
7488             } elsif (($marker & 0xf0) != 0xe0) {
7489 492         1306 $dumpType = "$markerName segment";
7490 492         1393 $desc = "[JPEG $markerName]"; # (other known JPEG segments)
7491             }
7492 1207 100       3443 if (defined $dumpType) {
7493 1151 50 33     2963 if (not $dumpType and ($$options{Unknown} or $$options{Validate})) {
      66        
7494 0 0       0 my $str = ($$segDataPt =~ /^([\x20-\x7e]{1,20})\0/) ? " '${1}'" : '';
7495 0 0       0 $xtra = 'segment' unless $xtra;
7496 0         0 $self->Warn("Unknown $markerName$str $xtra", 1);
7497             }
7498 1151 50       2723 if ($htmlDump) {
7499 0 0       0 $desc or $desc = $markerName . ($dumpType ? " $dumpType" : '') . ' segment';
    0          
7500 0         0 $self->HDump($segPos-4, $length+4, $desc, $tip, 0x08);
7501 0         0 $dumpEnd = $segPos + $length;
7502             }
7503             }
7504 1207         4630 undef $$segDataPt;
7505             }
7506             # process extended XMP now if it existed
7507 245 100       937 if (%extendedXMP) {
7508 1         5 my $guid;
7509             # GUID indicated by the last main XMP segment
7510 1   50     7 my $goodGuid = $$self{VALUE}{HasExtendedXMP} || '';
7511             # GUID of the extended XMP that we will process ('2' for all)
7512 1   50     6 my $readGuid = $$options{ExtendedXMP} || 0;
7513 1 50       10 $readGuid = $goodGuid if $readGuid eq '1';
7514 1         8 foreach $guid (sort keys %extendedXMP) {
7515 1 50       6 next unless length $guid == 32; # ignore other (internal) keys
7516 1         3 my $extXMP = $extendedXMP{$guid};
7517 1         2 my ($off, @offsets, $warn);
7518             # make sure we have all chunks, and create a list of sorted offsets
7519 1         7 for ($off=0; $off<$$extXMP{Size}; ) {
7520 2 50       8 last unless defined $$extXMP{$off};
7521 2         6 push @offsets, $off;
7522 2         5 $off += length $$extXMP{$off};
7523             }
7524 1 50       5 unless ($off == $$extXMP{Size}) {
7525 0         0 $self->Warn("Incomplete extended XMP (GUID $guid)");
7526 0         0 next;
7527             }
7528 1 50 33     10 if ($guid eq $readGuid or $readGuid eq '2') {
7529 1 50       5 $warn = 'Reading non-' if $guid ne $goodGuid;
7530 1         4 my $buff = '';
7531             # assemble XMP all together
7532 1         8 $buff .= $$extXMP{$_} foreach @offsets;
7533 1         6 my $tagTablePtr = GetTagTable('Image::ExifTool::XMP::Main');
7534 1         13 my %dirInfo = (
7535             DataPt => \$buff,
7536             Parent => 'APP1',
7537             IsExtended => 1,
7538             );
7539 1         3 $$path[$pn] = 'APP1';
7540 1         6 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7541 1         5 pop @$path;
7542             } else {
7543 0         0 $warn = 'Ignored ';
7544 0 0       0 $warn .= 'non-' if $guid ne $goodGuid;
7545             }
7546 1 50       5 $self->Warn("${warn}standard extended XMP (GUID $guid)") if $warn;
7547 1         6 delete $extendedXMP{$guid};
7548             }
7549             }
7550             # print verbose MD5 message if necessary
7551 245 50 33     1083 print $out "$$self{INDENT}(ImageDataMD5: $md5size bytes of JPEG image data)\n" if $md5size and $verbose;
7552             # calculate JPEGDigest if requested
7553 245 100       964 if (@dqt) {
7554 1         1529 require Image::ExifTool::JPEGDigest;
7555 1         28 Image::ExifTool::JPEGDigest::Calculate($self, \@dqt, $subSampling);
7556             }
7557             # issue necessary warnings
7558 245 50       775 $self->Warn('Invalid JUMBF size or missing JUMBF chunk') if %jumbfChunk;
7559 245 50       800 $self->Warn('Incomplete ICC_Profile record', 1) if defined $iccChunkCount;
7560 245 50       794 $self->Warn('Incomplete FLIR record', 1) if defined $flirCount;
7561 245 50       957 $self->Warn('Error reading PreviewImage', 1) if $$self{PreviewError};
7562 245 50       892 $success or $self->Warn('JPEG format error');
7563 245 50       919 pop @$path if @$path > $pn;
7564 245         2229 return 1;
7565             }
7566              
7567             #------------------------------------------------------------------------------
7568             # Extract metadata from an Exiv2 EXV file
7569             # Inputs: 0) ExifTool object reference, 1) dirInfo ref with RAF set
7570             # Returns: 1 on success, 0 if this wasn't a valid JPEG file
7571             sub ProcessEXV($$)
7572             {
7573 2     2 0 9 my ($self, $dirInfo) = @_;
7574 2         10 return $self->ProcessJPEG($dirInfo);
7575             }
7576              
7577             #------------------------------------------------------------------------------
7578             # Process EXIF file
7579             # Inputs/Returns: same as ProcessTIFF
7580             sub ProcessEXIF($$;$)
7581             {
7582 2     2 0 10 my ($self, $dirInfo, $tagTablePtr) = @_;
7583 2         13 return $self->ProcessTIFF($dirInfo, $tagTablePtr);
7584             }
7585              
7586             #------------------------------------------------------------------------------
7587             # Process TIFF data (wrapper for DoProcessTIFF to allow re-entry)
7588             # Inputs: 0) ExifTool object ref, 1) dirInfo ref, 2) optional tag table ref
7589             # Returns: 1 if this looked like a valid EXIF block, 0 otherwise, or -1 on write error
7590             sub ProcessTIFF($$;$)
7591             {
7592 495     495 0 1697 my ($self, $dirInfo, $tagTablePtr) = @_;
7593 495         1284 my $exifData = $$self{EXIF_DATA};
7594 495         1361 my $exifPos = $$self{EXIF_POS};
7595 495         2304 my $rtnVal = $self->DoProcessTIFF($dirInfo, $tagTablePtr);
7596             # restore original EXIF information (in case ProcessTIFF is nested)
7597 495 100       1797 if (defined $exifData) {
7598 108         315 $$self{EXIF_DATA} = $exifData;
7599 108         230 $$self{EXIF_POS} = $exifPos;
7600             }
7601 495         2043 return $rtnVal;
7602             }
7603              
7604             #------------------------------------------------------------------------------
7605             # Process TIFF data
7606             # Inputs: 0) ExifTool object ref, 1) dirInfo ref, 2) optional tag table ref
7607             # Returns: 1 if this looked like a valid EXIF block, 0 otherwise, or -1 on write error
7608             sub DoProcessTIFF($$;$)
7609             {
7610 495     495 0 1502 my ($self, $dirInfo, $tagTablePtr) = @_;
7611 495         1157 my $dataPt = $$dirInfo{DataPt};
7612 495   100     1849 my $fileType = $$dirInfo{Parent} || '';
7613 495         1075 my $raf = $$dirInfo{RAF};
7614 495   100     1883 my $base = $$dirInfo{Base} || 0;
7615 495         1136 my $outfile = $$dirInfo{OutFile};
7616 495         1167 my ($err, $sig, $canonSig, $otherSig);
7617              
7618             # attempt to read TIFF header
7619 495         1435 $$self{EXIF_DATA} = '';
7620 495 100 100     3369 if ($raf) {
    100          
    50          
7621 47 100       177 if ($outfile) {
7622 14 50       71 $raf->Seek(0, 0) or return 0;
7623 14 50       108 if ($base) {
7624 0 0       0 $raf->Read($$dataPt, $base) == $base or return 0;
7625 0 0       0 Write($outfile, $$dataPt) or $err = 1;
7626             }
7627             } else {
7628 33 50       167 $raf->Seek($base, 0) or return 0;
7629             }
7630             # extract full EXIF block (for block copy) from EXIF file
7631 47 100       375 my $amount = $fileType eq 'EXIF' ? 65536 * 8 : 8;
7632 47         330 my $n = $raf->Read($$self{EXIF_DATA}, $amount);
7633 47 100       404 if ($n < 8) {
7634 1 50 33     17 return 0 if $n or not $outfile or $fileType ne 'EXIF';
      33        
7635             # create EXIF file from scratch
7636 1         4 delete $$self{EXIF_DATA};
7637 1         5 undef $raf;
7638             }
7639 47 100       213 if ($n > 8) {
7640 2         15 $raf->Seek(8, 0);
7641 2 50       14 if ($n == $amount) {
7642 0         0 $$self{EXIF_DATA} = substr($$self{EXIF_DATA}, 0, 8);
7643 0         0 $self->Warn('EXIF too large to extract as a block'); #(shouldn't happen)
7644             }
7645             }
7646             } elsif ($dataPt and length $$dataPt) {
7647             # save a copy of the EXIF data
7648 406   100     2592 my $dirStart = $$dirInfo{DirStart} || 0;
7649 406   66     1534 my $dirLen = $$dirInfo{DirLen} || (length($$dataPt) - $dirStart);
7650 406         2570 $$self{EXIF_DATA} = substr($$dataPt, $dirStart, $dirLen);
7651 406 50 66     2151 $self->VerboseDir('TIFF') if $$self{OPTIONS}{Verbose} and length($$self{INDENT}) > 2;
7652             } elsif ($outfile) {
7653 42         158 delete $$self{EXIF_DATA}; # create from scratch
7654             } else {
7655 0         0 $$self{EXIF_DATA} = '';
7656             }
7657 495 100       1883 unless (defined $$self{EXIF_DATA}) {
7658             # set default byte order for creating new GPS in CR3 images
7659 43         103 my $defaultByteOrder;
7660 43 50 33     354 if ($$dirInfo{DirName} and $$dirInfo{DirName} eq 'GPS') {
7661 0         0 $defaultByteOrder = $$self{SaveExifByteOrder};
7662             }
7663             # create TIFF information from scratch
7664 43 100       305 if ($self->SetPreferredByteOrder($defaultByteOrder) eq 'MM') {
7665 34         127 $$self{EXIF_DATA} = "MM\0\x2a\0\0\0\x08";
7666             } else {
7667 9         57 $$self{EXIF_DATA} = "II\x2a\0\x08\0\0\0";
7668             }
7669             }
7670 495         1840 $$self{EXIF_POS} = $base + $$self{BASE};
7671 495 100       2124 $$self{FIRST_EXIF_POS} = $$self{EXIF_POS} unless defined $$self{FIRST_EXIF_POS};
7672 495         1231 $dataPt = \$$self{EXIF_DATA};
7673              
7674             # set byte ordering
7675 495         1634 my $byteOrder = substr($$dataPt,0,2);
7676 495 100       1679 SetByteOrder($byteOrder) or return 0;
7677              
7678             # verify the byte ordering
7679 489         2333 my $identifier = Get16u($dataPt, 2);
7680             # identifier is 0x2a for TIFF (but 0x4f52, 0x5352 or ?? for ORF)
7681             # no longer do this because various files use different values
7682             # (TIFF=0x2a, RW2/RWL=0x55, HDP=0xbc, BTF=0x2b, ORF=0x4f52/0x5352/0x????)
7683             # return 0 unless $identifier == 0x2a;
7684 489 50 66     2918 $self->Warn('Invalid magic number in EXIF TIFF header') if $fileType eq 'APP1' and $identifier != 0x2a;
7685              
7686             # get offset to IFD0
7687 489 50       1823 return 0 if length $$dataPt < 8;
7688 489         1569 my $offset = Get32u($dataPt, 4);
7689 489 50       1888 $offset >= 8 or return 0;
7690              
7691 489 100       1677 if ($raf) {
7692             # check for canon or EXIF signature
7693             # (Canon CR2 images should have an offset of 16, but it may be
7694             # greater if edited by PhotoMechanic)
7695 40 100 100     407 if ($identifier == 0x2a and $offset >= 16) {
    100 66        
    100          
7696 17 50       90 $raf->Read($sig, 8) == 8 or return 0;
7697 17         72 $$dataPt .= $sig;
7698 17 100       148 if ($sig =~ /^(CR\x02\0|\xba\xb0\xac\xbb|ExifMeta)/) {
7699 10 100       46 if ($sig eq 'ExifMeta') {
7700 1         9 $self->SetFileType($fileType = 'EXIF');
7701 1         8 $otherSig = $sig;
7702             } else {
7703 9 50       65 $fileType = $sig =~ /^CR/ ? 'CR2' : 'Canon 1D RAW';
7704 9         24 $canonSig = $sig;
7705             }
7706 10 50       57 $self->HDump($base+8, 8, "[$fileType header]") if $$self{HTML_DUMP};
7707             }
7708             } elsif ($identifier == 0x55 and $fileType =~ /^(RAW|RW2|RWL|TIFF)$/) {
7709             # panasonic RAW, RW2 or RWL file
7710 3         7 my $magic;
7711             # test for RW2/RWL magic number
7712 3 50 33     25 if ($offset >= 0x18 and $raf->Read($magic, 16) and
      33        
7713             $magic eq "\x88\xe7\x74\xd8\xf8\x25\x1d\x4d\x94\x7a\x6e\x77\x82\x2b\x5d\x6a")
7714             {
7715 3 50       18 $fileType = 'RW2' unless $fileType eq 'RWL';
7716 3 50       12 $self->HDump($base + 8, 16, '[RW2/RWL header]') if $$self{HTML_DUMP};
7717 3         12 $otherSig = $magic; # save signature for writing
7718             } else {
7719 0         0 $fileType = 'RAW';
7720             }
7721 3         10 $tagTablePtr = GetTagTable('Image::ExifTool::PanasonicRaw::Main');
7722             } elsif ($fileType eq 'TIFF') {
7723 13 50 33     146 if ($identifier == 0x2b) {
    50 33        
    50          
    50          
7724             # this looks like a BigTIFF image
7725 0         0 $raf->Seek(0);
7726 0         0 require Image::ExifTool::BigTIFF;
7727 0         0 my $result = Image::ExifTool::BigTIFF::ProcessBTF($self, $dirInfo);
7728 0 0       0 if ($result) {
7729 0 0       0 $self->FoundTag(PageCount => $$self{PageCount}) if $$self{MultiPage};
7730 0         0 return 1;
7731             }
7732             } elsif ($identifier == 0x4f52 or $identifier == 0x5352) {
7733             # Olympus ORF image (set FileType now because base type is 'ORF')
7734 0         0 $self->SetFileType($fileType = 'ORF');
7735             } elsif ($identifier == 0x4352) {
7736 0         0 $fileType = 'DCP';
7737             } elsif ($byteOrder eq 'II' and ($identifier & 0xff) == 0xbc) {
7738 0         0 $fileType = 'HDP'; # Windows HD Photo file
7739             # check version number
7740 0         0 my $ver = Get8u($dataPt, 3);
7741 0 0       0 if ($ver > 1) {
7742 0         0 $self->Error("Windows HD Photo version $ver files not yet supported");
7743 0         0 return 1;
7744             }
7745             }
7746             }
7747             # we have a valid TIFF (or whatever) file
7748 40 100 66     318 if ($fileType and not $$self{VALUE}{FileType}) {
7749 38         108 my $lookup = $fileTypeLookup{$fileType};
7750 38 50 33     217 $lookup = $fileTypeLookup{$lookup} unless ref $lookup or not $lookup;
7751             # use file extension to pre-determine type if extension is TIFF-based or type is RAW
7752 38 50       198 my $baseType = $lookup ? (ref $$lookup[0] ? $$lookup[0][0] : $$lookup[0]) : '';
    50          
7753 38 100 66     208 my $t = ($baseType eq 'TIFF' or $fileType =~ /RAW/) ? $fileType : undef;
7754 38         201 $self->SetFileType($t);
7755             }
7756             # don't process file if FastScan == 3
7757 40 50 66     443 return 1 if not $outfile and $$self{OPTIONS}{FastScan} and $$self{OPTIONS}{FastScan} == 3;
      33        
7758             }
7759             # (accommodate CR3 images which have a TIFF directory with ExifIFD at the top level)
7760 489 100 100     3661 my $ifdName = ($$dirInfo{DirName} and $$dirInfo{DirName} =~ /^(ExifIFD|GPS)$/) ? $1 : 'IFD0';
7761 489 100 100     3393 if (not $tagTablePtr or $$tagTablePtr{GROUPS}{0} eq 'EXIF') {
    100          
7762 413 100       2733 $self->FoundTag('ExifByteOrder', $byteOrder) unless $outfile;
7763             } elsif ($$tagTablePtr{GROUPS}{0} eq 'MakerNotes') { # (for writing CR3 maker notes)
7764 19         70 $ifdName = $$tagTablePtr{GROUPS}{0};
7765             } else {
7766 57         185 $ifdName = $$tagTablePtr{GROUPS}{1};
7767             }
7768 489 50       2522 if ($$self{HTML_DUMP}) {
7769 0 0       0 my $tip = sprintf("Byte order: %s endian\nIdentifier: 0x%.4x\n$ifdName offset: 0x%.4x",
7770             ($byteOrder eq 'II') ? 'Little' : 'Big', $identifier, $offset);
7771 0         0 $self->HDump($base, 8, 'TIFF header', $tip, 0);
7772             }
7773             # remember where we found the TIFF data (APP1, APP3, TIFF, NEF, etc...)
7774 489         1509 $$self{TIFF_TYPE} = $fileType;
7775              
7776             # get reference to the main EXIF table
7777 489 100       1890 $tagTablePtr or $tagTablePtr = GetTagTable('Image::ExifTool::Exif::Main');
7778              
7779             # build directory information hash
7780             my %dirInfo = (
7781             Base => $base,
7782             DataPt => $dataPt,
7783             DataLen => length $$dataPt,
7784             DataPos => 0,
7785             DirStart => $offset,
7786             DirLen => length($$dataPt) - $offset,
7787             RAF => $raf,
7788             DirName => $ifdName,
7789             Parent => $fileType,
7790             ImageData=> 'Main', # set flag to get information to copy main image data later
7791             Multi => $$dirInfo{Multi},
7792 489         6039 );
7793              
7794             # extract information from the image
7795 489 100       1798 unless ($outfile) {
7796             # process the directory
7797 365         1822 $self->ProcessDirectory(\%dirInfo, $tagTablePtr);
7798             # process GeoTiff information if available
7799 365 100       2582 if ($$self{VALUE}{GeoTiffDirectory}) {
7800 7         910 require Image::ExifTool::GeoTiff;
7801 7         73 Image::ExifTool::GeoTiff::ProcessGeoTiff($self);
7802             }
7803             # process information in recognized trailers
7804 365 100       1479 if ($raf) {
7805 27         158 my $trailInfo = IdentifyTrailer($raf);
7806 27 100       136 if ($trailInfo) {
7807 3         12 $$trailInfo{ScanForAFCP} = 1; # scan to find AFCP if necessary
7808 3         20 $self->ProcessTrailers($trailInfo);
7809             }
7810             # dump any other known trailer (eg. A100 RAW Data)
7811 27 0 33     154 if ($$self{HTML_DUMP} and $$self{KnownTrailer}) {
7812 0         0 my $known = $$self{KnownTrailer};
7813 0         0 $raf->Seek(0, 2);
7814 0         0 my $len = $raf->Tell() - $$known{Start};
7815 0 0       0 $len -= $$trailInfo{Offset} if $trailInfo; # account for other trailers
7816 0 0       0 $self->HDump($$known{Start}, $len, "[$$known{Name}]") if $len > 0;
7817             }
7818             }
7819             # update FileType if necessary now that we know more about the file
7820 365 50 66     1663 if ($$self{DNGVersion} and $$self{FileType} !~ /^(DNG|GPR)$/) {
7821             # override whatever FileType we set since we now know it is DNG
7822 0         0 $self->OverrideFileType($$self{TIFF_TYPE} = 'DNG');
7823             }
7824 365 100       1533 if ($$self{TIFF_TYPE} eq 'TIFF') {
7825 10 50       39 $self->FoundTag(PageCount => $$self{PageCount}) if $$self{MultiPage};
7826             }
7827 365         2101 return 1;
7828             }
7829             #
7830             # rewrite the image
7831             #
7832 124 100       570 if ($$dirInfo{NoTiffEnd}) {
7833 1         3 delete $$self{TIFF_END};
7834             } else {
7835             # initialize TIFF_END so it will be updated by WriteExif()
7836 123         445 $$self{TIFF_END} = 0;
7837             }
7838 124 100       548 if ($canonSig) {
7839             # write Canon CR2 specially because it has a header we want to preserve,
7840             # and possibly trailers added by the Canon utilities and/or PhotoMechanic
7841 3         9 $dirInfo{OutFile} = $outfile;
7842 3         25 require Image::ExifTool::CanonRaw;
7843 3 50       31 Image::ExifTool::CanonRaw::WriteCR2($self, \%dirInfo, $tagTablePtr) or $err = 1;
7844             } else {
7845             # write TIFF header (8 bytes [plus optional signature] followed by IFD)
7846 121 100       892 if ($fileType eq 'EXIF') {
    100          
7847 3         9 $otherSig = 'ExifMeta'; # force this signature for all EXIF files
7848             } elsif (not defined $otherSig) {
7849 117         306 $otherSig = '';
7850             }
7851 121         784 my $offset = 8 + length($otherSig);
7852             # construct tiff header
7853 121         631 my $header = substr($$dataPt, 0, 4) . Set32u($offset) . $otherSig;
7854 121         469 $dirInfo{NewDataPos} = $offset;
7855 121         458 $dirInfo{HeaderPtr} = \$header;
7856             # preserve padding between image data blocks in ORF images
7857             # (otherwise dcraw has problems because it assumes fixed block spacing)
7858 121 100 66     838 $dirInfo{PreserveImagePadding} = 1 if $fileType eq 'ORF' or $identifier != 0x2a;
7859 121         1040 my $newData = $self->WriteDirectory(\%dirInfo, $tagTablePtr);
7860 121 50       833 if (not defined $newData) {
    100          
7861 0         0 $err = 1;
7862             } elsif (length($newData)) {
7863             # update header length in case more was added
7864 115         303 my $hdrLen = length $header;
7865 115 100       513 if ($hdrLen != 8) {
7866 5         25 Set32u($hdrLen, \$header, 4);
7867             # also update preview fixup if necessary
7868 5         17 my $pi = $$self{PREVIEW_INFO};
7869 5 0 33     24 $$pi{Fixup}{Start} += $hdrLen - 8 if $pi and $$pi{Fixup};
7870             }
7871 115 50 33     693 if ($$self{TIFF_TYPE} eq 'ARW' and not $err) {
7872             # write any required ARW trailer and patch other ARW quirks
7873 0         0 require Image::ExifTool::Sony;
7874             my $errStr = Image::ExifTool::Sony::FinishARW($self, $dirInfo, \$newData,
7875 0         0 $dirInfo{ImageData});
7876 0 0       0 $errStr and $self->Error($errStr);
7877 0         0 delete $dirInfo{ImageData}; # (was copied by FinishARW)
7878             } else {
7879 115 50       653 Write($outfile, $header, $newData) or $err = 1;
7880             }
7881 115         381 undef $newData; # free memory
7882             }
7883             # copy over image data now if necessary
7884 121 100 66     795 if (ref $dirInfo{ImageData} and not $err) {
7885 10 50       80 $self->CopyImageData($dirInfo{ImageData}, $outfile) or $err = 1;
7886 10         54 delete $dirInfo{ImageData};
7887             }
7888             }
7889             # make local copy of TIFF_END now (it may be reset when processing trailers)
7890 124         433 my $tiffEnd = $$self{TIFF_END};
7891 124         339 delete $$self{TIFF_END};
7892              
7893             # rewrite trailers if they exist
7894 124 100 100     680 if ($raf and $tiffEnd and not $err) {
      66        
7895 12         37 my ($buf, $trailInfo);
7896 12 50       55 $raf->Seek(0, 2) or $err = 1;
7897 12         122 my $extra = $raf->Tell() - $tiffEnd;
7898             # check for trailer and process if possible
7899 12         44 for (;;) {
7900 12 100       69 last unless $extra > 12;
7901 3         17 $raf->Seek($tiffEnd); # seek back to end of image
7902 3         45 $trailInfo = IdentifyTrailer($raf);
7903 3 50       17 last unless $trailInfo;
7904 0         0 my $tbuf = '';
7905 0         0 $$trailInfo{OutFile} = \$tbuf; # rewrite trailer(s)
7906 0         0 $$trailInfo{ScanForAFCP} = 1; # scan for AFCP if necessary
7907             # rewrite all trailers to buffer
7908 0 0       0 unless ($self->ProcessTrailers($trailInfo)) {
7909 0         0 undef $trailInfo;
7910 0         0 $err = 1;
7911 0         0 last;
7912             }
7913             # calculate unused bytes before trailer
7914 0         0 $extra = $$trailInfo{DataPos} - $tiffEnd;
7915 0         0 last; # yes, the 'for' loop was just a cheap 'goto'
7916             }
7917             # ignore a single zero byte if used for padding
7918 12 100 100     98 if ($extra > 0 and $tiffEnd & 0x01) {
7919 1 50       7 $raf->Seek($tiffEnd, 0) or $err = 1;
7920 1 50       30 $raf->Read($buf, 1) or $err = 1;
7921 1 50 33     20 defined $buf and $buf eq "\0" and --$extra, ++$tiffEnd;
7922             }
7923 12 100       60 if ($extra > 0) {
7924 3         11 my $known = $$self{KnownTrailer};
7925 3 50 33     28 if ($$self{DEL_GROUP}{Trailer} and not $known) {
    50          
7926 0         0 $self->VPrint(0, " Deleting unknown trailer ($extra bytes)\n");
7927 0         0 ++$$self{CHANGED};
7928             } elsif ($known) {
7929 0         0 $self->VPrint(0, " Copying $$known{Name} ($extra bytes)\n");
7930 0 0       0 $raf->Seek($tiffEnd, 0) or $err = 1;
7931 0 0       0 CopyBlock($raf, $outfile, $extra) or $err = 1;
7932             } else {
7933 3 50       13 $raf->Seek($tiffEnd, 0) or $err = 1;
7934             # preserve unknown trailer only if it contains non-null data
7935             # (Photoshop CS adds a trailer with 2 null bytes)
7936 3         16 my $size = $extra;
7937 3         8 for (;;) {
7938 3 50       17 my $n = $size > 65536 ? 65536 : $size;
7939 3 50       14 $raf->Read($buf, $n) == $n or $err = 1, last;
7940 3 50       51 if ($buf =~ /[^\0]/) {
7941 3         27 $self->VPrint(0, " Preserving unknown trailer ($extra bytes)\n");
7942             # copy the trailer since it contains non-null data
7943 3 50 0     17 Write($outfile, "\0"x($extra-$size)) or $err = 1, last if $size != $extra;
7944 3 50       15 Write($outfile, $buf) or $err = 1, last;
7945 3 50 0     27 CopyBlock($raf, $outfile, $size-$n) or $err = 1 if $size > $n;
7946 3         9 last;
7947             }
7948 0         0 $size -= $n;
7949 0 0       0 next if $size > 0;
7950 0         0 $self->VPrint(0, " Deleting blank trailer ($extra bytes)\n");
7951 0         0 last;
7952             }
7953             }
7954             }
7955             # write trailer buffer if necessary
7956 12 50 0     46 $self->WriteTrailerBuffer($trailInfo, $outfile) or $err = 1 if $trailInfo;
7957             # add any new trailers we are creating
7958 12         117 my $trailPt = $self->AddNewTrailers();
7959 12 100 50     59 Write($outfile, $$trailPt) or $err = 1 if $trailPt;
7960             }
7961             # check DNG version
7962 124 100       631 if ($$self{DNGVersion}) {
7963 1         2 my $ver = $$self{DNGVersion};
7964             # currently support up to DNG version 1.6
7965 1 50 33     20 unless ($ver =~ /^(\d+) (\d+)/ and "$1.$2" <= 1.6) {
7966 0         0 $ver =~ tr/ /./;
7967 0         0 $self->Error("DNG Version $ver not yet tested", 1);
7968             }
7969             }
7970 124 50       1122 return $err ? -1 : 1;
7971             }
7972              
7973             #------------------------------------------------------------------------------
7974             # Return list of tag table keys (ignoring special keys)
7975             # Inputs: 0) reference to tag table
7976             # Returns: List of table keys (unsorted)
7977             sub TagTableKeys($)
7978             {
7979 7715     7715 0 12190 local $_;
7980 7715         12052 my $tagTablePtr = shift;
7981 7715         11740 my @keyList;
7982 7715         124607 foreach (keys %$tagTablePtr) {
7983 455635 100       861897 push(@keyList, $_) unless $specialTags{$_};
7984             }
7985 7715         77957 return @keyList;
7986             }
7987              
7988             #------------------------------------------------------------------------------
7989             # GetTagTable
7990             # Inputs: 0) table name
7991             # Returns: tag table reference, or undefined if not found
7992             # Notes: Always use this function instead of requiring module and using table
7993             # directly since this function also does the following the first time the table
7994             # is loaded:
7995             # - requires new module if necessary
7996             # - generates default GROUPS hash and Group 0 name from module name
7997             # - registers Composite tags if Composite table found
7998             # - saves descriptions for tags in specified table
7999             # - generates default TAG_PREFIX to be used for unknown tags
8000             sub GetTagTable($)
8001             {
8002 90398 100   90398 0 200053 my $tableName = shift or return undef;
8003 90394         207525 my $table = $allTables{$tableName};
8004              
8005 90394 100       166660 unless ($table) {
8006 106     106   1171 no strict 'refs';
  106         307  
  106         19849  
8007 4572 100       35716 unless (%$tableName) {
8008             # try to load module for this table
8009 883 50       6888 if ($tableName =~ /(.*)::/) {
8010 883         3350 my $module = $1;
8011 883 50       72567 if (eval "require $module") {
8012             # load additional modules if required
8013 883 100       7847 if (not %$tableName) {
8014 28 50       244 if ($module eq 'Image::ExifTool::XMP') {
    0          
8015 28         24453 require 'Image/ExifTool/XMP2.pl';
8016             } elsif ($tableName eq 'Image::ExifTool::QuickTime::Stream') {
8017 0         0 require 'Image/ExifTool/QuickTimeStream.pl';
8018             }
8019             }
8020             } else {
8021 0 0       0 $@ and warn $@;
8022             }
8023             }
8024 883 50       5838 unless (%$tableName) {
8025 0         0 warn "Can't find table $tableName\n";
8026 0         0 return undef;
8027             }
8028             }
8029 106     106   927 no strict 'refs';
  106         294  
  106         5510  
8030 4572         12159 $table = \%$tableName;
8031 106     106   784 use strict 'refs';
  106         326  
  106         96898  
8032 4572 100       14822 &{$$table{INIT_TABLE}}($table) if $$table{INIT_TABLE};
  13         348  
8033 4572         11993 $$table{TABLE_NAME} = $tableName; # set table name
8034 4572         27300 ($$table{SHORT_NAME} = $tableName) =~ s/^Image::ExifTool:://;
8035             # set default group 0 and 1 from module name unless already specified
8036 4572         12511 my $defaultGroups = $$table{GROUPS};
8037 4572 100       11029 $defaultGroups or $defaultGroups = $$table{GROUPS} = { };
8038 4572 100 100     21460 unless ($$defaultGroups{0} and $$defaultGroups{1}) {
8039 3648 50       20996 if ($tableName =~ /Image::.*?::([^:]*)/) {
8040 3648 100       11897 $$defaultGroups{0} = $1 unless $$defaultGroups{0};
8041 3648 100       14486 $$defaultGroups{1} = $1 unless $$defaultGroups{1};
8042             } else {
8043 0 0       0 $$defaultGroups{0} = $tableName unless $$defaultGroups{0};
8044 0 0       0 $$defaultGroups{1} = $tableName unless $$defaultGroups{1};
8045             }
8046             }
8047 4572 100       12250 $$defaultGroups{2} = 'Other' unless $$defaultGroups{2};
8048 4572 100 100     19455 if ($$defaultGroups{0} eq 'XMP' or $$table{NAMESPACE}) {
8049             # initialize some XMP table defaults
8050 515         3672 require Image::ExifTool::XMP;
8051 515         2697 Image::ExifTool::XMP::RegisterNamespace($table); # register all table namespaces
8052             # set default write/check procs
8053 515 100       1910 $$table{WRITE_PROC} = \&Image::ExifTool::XMP::WriteXMP unless $$table{WRITE_PROC};
8054 515 100       1700 $$table{CHECK_PROC} = \&Image::ExifTool::XMP::CheckXMP unless $$table{CHECK_PROC};
8055 515 100       1610 $$table{LANG_INFO} = \&Image::ExifTool::XMP::GetLangInfo unless $$table{LANG_INFO};
8056             }
8057             # generate a tag prefix for unknown tags if necessary
8058 4572 100       11300 unless (defined $$table{TAG_PREFIX}) {
8059 4472         6659 my $tagPrefix;
8060 4472 50 66     27838 if ($tableName =~ /Image::.*?::(.*)::Main/ || $tableName =~ /Image::.*?::(.*)/) {
8061 4472         20280 ($tagPrefix = $1) =~ s/::/_/g;
8062             } else {
8063 0         0 $tagPrefix = $tableName;
8064             }
8065 4472         13462 $$table{TAG_PREFIX} = $tagPrefix;
8066             }
8067             # set up the new table
8068 4572         13905 SetupTagTable($table);
8069             # add any user-defined tags (except Composite tags, which are handled specially)
8070 4572 100 100     22214 if (%UserDefined and $UserDefined{$tableName} and $table ne \%Image::ExifTool::Composite) {
      66        
8071 2         5 my $tagID;
8072 2         7 foreach $tagID (TagTableKeys($UserDefined{$tableName})) {
8073 3 50       11 next if $specialTags{$tagID};
8074 3         7 delete $$table{$tagID}; # replace any existing entry
8075 3         15 AddTagToTable($table, $tagID, $UserDefined{$tableName}{$tagID}, 1);
8076             }
8077             }
8078             # remember order we loaded the tables in
8079 4572         11105 push @tableOrder, $tableName;
8080             # insert newly loaded table into list
8081 4572         16387 $allTables{$tableName} = $table;
8082             }
8083             # must check each time to add UserDefined Composite tags because the Composite table
8084             # may be loaded before the UserDefined tags are available
8085 90394 50 66     257394 if ($table eq \%Image::ExifTool::Composite and not $$table{VARS}{LOADED_USERDEFINED} and
      100        
      66        
8086             %UserDefined and $UserDefined{$tableName})
8087             {
8088 0         0 my $userComp = $UserDefined{$tableName};
8089 0         0 delete $UserDefined{$tableName}; # (must delete first to avoid infinite recursion)
8090 0         0 AddCompositeTags($userComp, 1);
8091 0         0 $UserDefined{$tableName} = $userComp; # (add back again for adding writable tags later)
8092 0         0 $$table{VARS}{LOADED_USERDEFINED} = 1; # set flag to avoid doing this again
8093             }
8094 90394         208549 return $table;
8095             }
8096              
8097             #------------------------------------------------------------------------------
8098             # Process an image directory
8099             # Inputs: 0) ExifTool object reference, 1) directory information reference
8100             # 2) tag table reference, 3) optional reference to processing procedure
8101             # Returns: Result from processing (1=success)
8102             sub ProcessDirectory($$$;$)
8103             {
8104 4988     4988 0 15929 my ($self, $dirInfo, $tagTablePtr, $proc) = @_;
8105              
8106 4988 50 33     20145 return 0 unless $tagTablePtr and $dirInfo;
8107             # use default proc from tag table or EXIF proc as fallback if no proc specified
8108 4988 100 100     21505 $proc or $proc = $$tagTablePtr{PROCESS_PROC} || \&Image::ExifTool::Exif::ProcessExif;
8109             # set directory name from default group0 name if not done already
8110 4988         9468 my $dirName = $$dirInfo{DirName};
8111 4988 100       11764 unless ($dirName) {
8112 717         3106 $dirName = $$tagTablePtr{GROUPS}{0};
8113 717 100       2917 $dirName = $$tagTablePtr{GROUPS}{1} if $dirName =~ /^APP\d+$/; # (use specific APP name)
8114 717         1800 $$dirInfo{DirName} = $dirName;
8115             }
8116              
8117             # guard against cyclical recursion into the same directory
8118 4988 100 100     26165 if (defined $$dirInfo{DirStart} and defined $$dirInfo{DataPos} and
      100        
      100        
8119             # directories don't overlap if the length is zero
8120             ($$dirInfo{DirLen} or not defined $$dirInfo{DirLen}))
8121             {
8122 4186   100     14665 my $addr = $$dirInfo{DirStart} + $$dirInfo{DataPos} + ($$dirInfo{Base}||0) + $$self{BASE};
8123 4186 50       11969 if ($$self{PROCESSED}{$addr}) {
8124 0         0 $self->Warn("$dirName pointer references previous $$self{PROCESSED}{$addr} directory");
8125             # patch for bug in Windows phone 7.5 O/S that writes incorrect InteropIFD pointer
8126 0 0 0     0 return 0 unless $dirName eq 'GPS' and $$self{PROCESSED}{$addr} eq 'InteropIFD';
8127             }
8128 4186 50 66     20624 $$self{PROCESSED}{$addr} = $dirName unless $$tagTablePtr{VARS} and $$tagTablePtr{VARS}{ALLOW_REPROCESS};
8129             }
8130 4988         12041 my $oldOrder = GetByteOrder();
8131 4988         19620 my @save = @$self{'INDENT','DIR_NAME','Compression','SubfileType'};
8132 4988         14048 $$self{LIST_TAGS} = { }; # don't build lists across different directories
8133 4988         10214 $$self{INDENT} .= '| ';
8134 4988         9040 $$self{DIR_NAME} = $dirName;
8135 4988         7427 push @{$$self{PATH}}, $dirName;
  4988         11841  
8136 4988         15251 $$self{FOUND_DIR}{$dirName} = 1;
8137              
8138             # process the directory
8139 106     106   1026 no strict 'refs';
  106         323  
  106         5603  
8140 4988         26670 my $rtnVal = &$proc($self, $dirInfo, $tagTablePtr);
8141 106     106   753 use strict 'refs';
  106         279  
  106         858722  
8142              
8143 4988         8157 pop @{$$self{PATH}};
  4988         11537  
8144 4988         18471 @$self{'INDENT','DIR_NAME','Compression','SubfileType'} = @save;
8145 4988         14035 SetByteOrder($oldOrder);
8146 4988         20364 return $rtnVal;
8147             }
8148              
8149             #------------------------------------------------------------------------------
8150             # Get Metadata path
8151             # Inputs: 0) ExifTool object ref
8152             # Return: Metadata path string
8153             sub MetadataPath($)
8154             {
8155 725     725 0 1467 my $self = shift;
8156 725         1339 return join '-', @{$$self{PATH}}
  725         3745  
8157             }
8158              
8159             #------------------------------------------------------------------------------
8160             # Get standardized file extension
8161             # Inputs: 0) file name
8162             # Returns: standardized extension (all uppercase), or undefined if no extension
8163             sub GetFileExtension($)
8164             {
8165 1957     1957 0 3734 my $filename = shift;
8166 1957         3019 my $fileExt;
8167 1957 100 100     12974 if ($filename and $filename =~ /^.*\.([^.]+)$/s) {
8168 1826         5289 $fileExt = uc($1); # change extension to upper case
8169             # convert TIF extension to TIFF because we use the
8170             # extension for the file type tag of TIFF images
8171 1826 100       4602 $fileExt eq 'TIF' and $fileExt = 'TIFF';
8172             }
8173 1957         6922 return $fileExt;
8174             }
8175              
8176             #------------------------------------------------------------------------------
8177             # Get list of tag information hashes for given tag ID
8178             # Inputs: 0) Tag table reference, 1) tag ID
8179             # Returns: Array of tag information references
8180             # Notes: Generates tagInfo hash if necessary
8181             sub GetTagInfoList($$)
8182             {
8183 538457     538457 0 859358 my ($tagTablePtr, $tagID) = @_;
8184 538457         1044033 my $tagInfo = $$tagTablePtr{$tagID};
8185              
8186 538457 50       1161930 if ($specialTags{$tagID}) {
    100          
    100          
    100          
8187             # (hopefully this won't happen)
8188 0         0 warn "Tag $tagID conflicts with internal ExifTool variable in $$tagTablePtr{TABLE_NAME}\n";
8189             } elsif (ref $tagInfo eq 'HASH') {
8190 493875         1012022 return ($tagInfo);
8191             } elsif (ref $tagInfo eq 'ARRAY') {
8192 11191         49357 return @$tagInfo;
8193             } elsif ($tagInfo) {
8194             # create hash with name
8195 28909         65991 $tagInfo = $$tagTablePtr{$tagID} = { Name => $tagInfo };
8196 28909         59041 return ($tagInfo);
8197             }
8198 4482         8236 return ();
8199             }
8200              
8201             #------------------------------------------------------------------------------
8202             # Find tag information, processing conditional tags
8203             # Inputs: 0) ExifTool object reference, 1) tagTable pointer, 2) tag ID
8204             # 3) optional value reference, 4) optional format type, 5) optional value count
8205             # Returns: pointer to tagInfo hash, undefined if none found, or '' if $valPt needed
8206             # Notes: You should always call this routine to find a tag in a table because
8207             # this routine will evaluate conditional tags.
8208             # Arguments 3-5 are only required if the information type allows $valPt, $format and/or
8209             # $count in a Condition, and if not given when needed this routine returns ''.
8210             sub GetTagInfo($$$;$$$)
8211             {
8212 109313     109313 0 205977 my ($self, $tagTablePtr, $tagID) = @_;
8213 109313         154484 my ($valPt, $format, $count);
8214              
8215 109313         212730 my @infoArray = GetTagInfoList($tagTablePtr, $tagID);
8216             # evaluate condition
8217 109313         155972 my $tagInfo;
8218 109313         181390 foreach $tagInfo (@infoArray) {
8219 114177         246650 my $condition = $$tagInfo{Condition};
8220 114177 100       214448 if ($condition) {
8221 13295 100       31642 ($valPt, $format, $count) = splice(@_, 3) if @_ > 3;
8222 13295 100 100     74197 return '' if $condition =~ /\$(valPt|format|count)\b/ and not defined $valPt;
8223             # set old value for use in condition if needed
8224 12608         54589 local $SIG{'__WARN__'} = \&SetWarning;
8225 12608         22784 undef $evalWarning;
8226             #### eval Condition ($self, [$valPt, $format, $count])
8227 12608 100       942572 unless (eval $condition) {
8228 10126 50       25388 $@ and $evalWarning = $@;
8229 10126 50       19434 $self->Warn("Condition $$tagInfo{Name}: " . CleanWarning()) if $evalWarning;
8230 10126         47643 next;
8231             }
8232             }
8233             # don't return Unknown tags unless that option is set (also see forum13716)
8234 103364 100 100     266649 if ($$tagInfo{Unknown} and not $$self{OPTIONS}{Unknown} and not
      66        
      100        
8235             ($$self{OPTIONS}{Verbose} or $$self{HTML_DUMP} or
8236             ($$self{OPTIONS}{Validate} and not $$tagInfo{AddedUnknown})))
8237             {
8238 2095         5633 return undef;
8239             }
8240             # return the tag information we found
8241 101269         237667 return $tagInfo;
8242             }
8243             # generate information for unknown tags (numerical only) if required
8244 5262 100 100     35622 if (not $tagInfo and ($$self{OPTIONS}{Unknown} or $$self{OPTIONS}{Verbose}) and
      66        
      100        
      100        
8245             $tagID =~ /^\d+$/ and not $$self{NO_UNKNOWN})
8246             {
8247 590         1085 my $printConv;
8248 590 100       1315 if (defined $$tagTablePtr{PRINT_CONV}) {
8249 155         325 $printConv = $$tagTablePtr{PRINT_CONV};
8250             } else {
8251             # limit length of printout (can be very long)
8252 435         737 $printConv = 'length($val) > 60 ? substr($val,0,55) . "[...]" : $val';
8253             }
8254 590         2035 my $hex = sprintf("0x%.4x", $tagID);
8255 590         1195 my $prefix = $$tagTablePtr{TAG_PREFIX};
8256 590         1827 $tagInfo = {
8257             Name => "${prefix}_$hex",
8258             Description => MakeDescription($prefix, $hex),
8259             Unknown => 1,
8260             Writable => 0, # can't write unknown tags
8261             PrintConv => $printConv,
8262             AddedUnknown => 1,
8263             };
8264             # add tag information to table
8265 590         1721 AddTagToTable($tagTablePtr, $tagID, $tagInfo);
8266             } else {
8267 4672         7600 undef $tagInfo;
8268             }
8269 5262         12600 return $tagInfo;
8270             }
8271              
8272             #------------------------------------------------------------------------------
8273             # Add new tag to table (must use this routine to add new tags to a table)
8274             # Inputs: 0) reference to tag table, 1) tag ID
8275             # 2) [optional] tag name or reference to tag information hash
8276             # 3) [optional] flag to avoid adding prefix when generating tag name
8277             # Returns: tagInfo ref
8278             # Notes: - will not override existing entry in table
8279             # - info need contain no entries when this routine is called
8280             # - tag name is cleaned if necessary
8281             sub AddTagToTable($$;$$)
8282             {
8283 6096     6096 0 12636 my ($tagTablePtr, $tagID, $tagInfo, $noPrefix) = @_;
8284              
8285             # generate tag info hash if necessary
8286 6096 0       13878 $tagInfo = $tagInfo ? { Name => $tagInfo } : { } unless ref $tagInfo eq 'HASH';
    50          
8287              
8288             # define necessary entries in information hash
8289 6096 100       11762 if ($$tagInfo{Groups}) {
8290             # fill in default groups from table GROUPS
8291 432         1125 foreach (keys %{$$tagTablePtr{GROUPS}}) {
  432         1578  
8292 1296 100       2962 next if $$tagInfo{Groups}{$_};
8293 558         1333 $$tagInfo{Groups}{$_} = $$tagTablePtr{GROUPS}{$_};
8294             }
8295             } else {
8296 5664         7220 $$tagInfo{Groups} = { %{$$tagTablePtr{GROUPS}} };
  5664         28918  
8297             }
8298 6096 100       14649 $$tagInfo{Flags} and ExpandFlags($tagInfo);
8299             $$tagInfo{GotGroups} = 1,
8300 6096         14048 $$tagInfo{Table} = $tagTablePtr;
8301 6096         13001 $$tagInfo{TagID} = $tagID;
8302 6096 100 100     15728 if (defined $$tagTablePtr{AVOID} and not defined $$tagInfo{Avoid}) {
8303 1442         3098 $$tagInfo{Avoid} = $$tagTablePtr{AVOID};
8304             }
8305              
8306 6096         9941 my $name = $$tagInfo{Name};
8307 6096 100       11636 $name = $tagID unless defined $name;
8308 6096         12855 $name =~ tr/-_a-zA-Z0-9//dc; # remove illegal characters
8309 6096         11363 $name = ucfirst $name; # capitalize first letter
8310             # add tag-name prefix if specified and tag name not provided
8311 6096 100 100     13745 unless (defined $$tagInfo{Name} or $noPrefix or not $$tagTablePtr{TAG_PREFIX}) {
      66        
8312             # make description to prevent tagID from getting mangled by MakeDescription()
8313 22         62 $$tagInfo{Description} = MakeDescription($$tagTablePtr{TAG_PREFIX}, $name);
8314 22         61 $name = "$$tagTablePtr{TAG_PREFIX}_$name";
8315             }
8316             # tag names must be at least 2 characters long and prefer them to start with a letter
8317 6096 100 100     27767 $name = "Tag$name" if length($name) < 2 or $name !~ /^[A-Z]/i;
8318 6096         11464 $$tagInfo{Name} = $name;
8319             # add tag to table, but never override existing entries (could potentially happen
8320             # if someone thinks there isn't any tagInfo because a condition wasn't satisfied)
8321 6096 50 66     21134 unless (defined $$tagTablePtr{$tagID} or $specialTags{$tagID}) {
8322 6013         19965 $$tagTablePtr{$tagID} = $tagInfo;
8323             }
8324 6096 100       12391 $$tagInfo{AddedUnknown} = 1 if $$tagInfo{Unknown};
8325 6096         13453 return $tagInfo;
8326             }
8327              
8328             #------------------------------------------------------------------------------
8329             # Handle simple extraction of new tag information
8330             # Inputs: 0) ExifTool object ref, 1) tag table reference, 2) tagID, 3) value,
8331             # 4-N) parameters hash: Index, DataPt, DataPos, Base, Start, Size, Parent,
8332             # TagInfo, ProcessProc, RAF, Format, Count
8333             # Returns: tag key or undef if tag not found
8334             # Notes: if value is not defined, it is extracted from DataPt using TagInfo
8335             # Format and Count if provided
8336             sub HandleTag($$$$;%)
8337             {
8338 9502     9502 0 36047 my ($self, $tagTablePtr, $tag, $val, %parms) = @_;
8339 9502         18213 my $verbose = $$self{OPTIONS}{Verbose};
8340 9502         14250 my $pfmt = $parms{Format};
8341 9502   100     35355 my $tagInfo = $parms{TagInfo} || $self->GetTagInfo($tagTablePtr, $tag, \$val, $pfmt, $parms{Count});
8342 9502         19536 my $dataPt = $parms{DataPt};
8343 9502         14764 my ($subdir, $format, $noTagInfo, $rational);
8344              
8345 9502 100       18140 if ($tagInfo) {
8346 7343         13208 $subdir = $$tagInfo{SubDirectory};
8347             } else {
8348 2159 50       7628 return undef unless $verbose;
8349 0         0 $tagInfo = { Name => "tag $tag" }; # create temporary tagInfo hash
8350 0         0 $noTagInfo = 1;
8351             }
8352             # read value if not done already (not necessary for subdir)
8353 7343 50 66     19731 unless (defined $val or ($subdir and not $$tagInfo{Writable} and not $$tagInfo{RawConv})) {
      66        
      100        
8354 873   100     2559 my $start = $parms{Start} || 0;
8355 873 50       2069 my $dLen = $dataPt ? length($$dataPt) : -1;
8356 873         1571 my $size = $parms{Size};
8357 873 100       1847 $size = $dLen unless defined $size;
8358             # read from data in memory if possible
8359 873 50 33     3184 if ($start >= 0 and $start + $size <= $dLen) {
8360 873   100     2933 $format = $$tagInfo{Format} || $$tagTablePtr{FORMAT};
8361 873 50 100     3408 $format = $pfmt if not $format and $pfmt and $formatSize{$pfmt};
      66        
8362 873 100       2594 if ($format) {
8363 422         1478 $val = ReadValue($dataPt, $start, $format, $$tagInfo{Count}, $size, \$rational);
8364             } else {
8365 451         1251 $val = substr($$dataPt, $start, $size);
8366             }
8367             } else {
8368 0         0 $self->Warn("Error extracting value for $$tagInfo{Name}");
8369 0         0 return undef;
8370             }
8371             }
8372             # do verbose print if necessary
8373 7343 100       15603 if ($verbose) {
8374 51 50       106 undef $tagInfo if $noTagInfo;
8375 51         93 $parms{Value} = $val;
8376 51 50       101 $parms{Value} .= " ($rational)" if defined $rational;
8377 51         94 $parms{Table} = $tagTablePtr;
8378 51 50       109 if ($format) {
8379 0   0     0 my $count = int(($parms{Size} || 0) / ($formatSize{$format} || 1));
      0        
8380 0         0 $parms{Format} = $format . "[$count]";
8381             }
8382 51         249 $self->VerboseInfo($tag, $tagInfo, %parms);
8383             }
8384 7343 50       14208 if ($tagInfo) {
8385 7343 100       13688 if ($subdir) {
8386 747         1627 my $subdirStart = $parms{Start};
8387 747         1347 my $subdirLen = $parms{Size};
8388 747 100 66     2198 if ($$tagInfo{RawConv} and not $$tagInfo{Writable}) {
8389 1         2 my $conv = $$tagInfo{RawConv};
8390 1         5 local $SIG{'__WARN__'} = \&SetWarning;
8391 1         5 undef $evalWarning;
8392 1 50       5 if (ref $conv eq 'CODE') {
8393 0         0 $val = &$conv($val, $self);
8394             } else {
8395 1         3 my ($priority, @grps);
8396             # NOTE: RawConv is evaluated in Writer.pl and twice in ExifTool.pm
8397             #### eval RawConv ($self, $val, $tag, $tagInfo, $priority, @grps)
8398 1         91 $val = eval $conv;
8399 1 50       7 $@ and $evalWarning = $@;
8400             }
8401 1 50       3 $self->Warn("RawConv $tag: " . CleanWarning()) if $evalWarning;
8402 1 50       4 return undef unless defined $val;
8403 1 50       7 $val = $$val if ref $val eq 'SCALAR';
8404 1         3 $dataPt = \$val;
8405 1         2 $subdirStart = 0;
8406 1         6 $subdirLen = length $val;
8407             }
8408 747 100       2252 if ($$subdir{Start}) {
8409 8         32 my $valuePtr = 0;
8410             #### eval Start ($valuePtr)
8411 8         427 my $off = eval $$subdir{Start};
8412 8         38 $subdirStart += $off;
8413 8         27 $subdirLen -= $off;
8414             }
8415 747 100       1827 $dataPt or $dataPt = \$val;
8416             # process subdirectory information
8417             my %dirInfo = (
8418             DirName => $$subdir{DirName} || $$tagInfo{Name},
8419             DataPt => $dataPt,
8420             DataLen => length $$dataPt,
8421             DataPos => $parms{DataPos},
8422             DirStart => $subdirStart,
8423             DirLen => $subdirLen,
8424             Parent => $parms{Parent},
8425             Base => $parms{Base},
8426             Multi => $$subdir{Multi},
8427             TagInfo => $tagInfo,
8428             RAF => $parms{RAF},
8429 747   66     7574 );
8430 747         1946 my $oldOrder = GetByteOrder();
8431 747 100       2077 if ($$subdir{ByteOrder}) {
8432 3 100       26 if ($$subdir{ByteOrder} eq 'Unknown') {
8433 1 50       19 if ($subdirStart + 2 <= $subdirLen) {
8434             # attempt to determine the byte ordering of an IFD-style subdirectory
8435 1         8 my $num = Get16u($dataPt, $subdirStart);
8436 1 50 33     10 ToggleByteOrder if $num & 0xff00 and ($num>>8) > ($num&0xff);
8437             }
8438             } else {
8439 2         11 SetByteOrder($$subdir{ByteOrder});
8440             }
8441             }
8442 747   33     2243 my $subTablePtr = GetTagTable($$subdir{TagTable}) || $tagTablePtr;
8443 747   100     5027 $self->ProcessDirectory(\%dirInfo, $subTablePtr, $$subdir{ProcessProc} || $parms{ProcessProc});
8444 747         2370 SetByteOrder($oldOrder);
8445             # return now unless directory is writable as a block
8446 747 50       6125 return undef unless $$tagInfo{Writable};
8447             }
8448 6596         15010 my $key = $self->FoundTag($tagInfo, $val);
8449             # save original components of rational numbers
8450 6596 100 66     17678 $$self{RATIONAL}{$key} = $rational if defined $rational and defined $key;
8451 6596         22295 return $key;
8452             }
8453 0         0 return undef;
8454             }
8455              
8456             #------------------------------------------------------------------------------
8457             # Add tag to hash of extracted information
8458             # Inputs: 0) ExifTool object reference
8459             # 1) reference to tagInfo hash or tag name
8460             # 2) data value (or reference to require hash if Composite)
8461             # 3) optional family 0 group, 4) optional family 1 group
8462             # Returns: tag key or undef if no value
8463             sub FoundTag($$$;@)
8464             {
8465 59806     59806 0 92073 local $_;
8466 59806         114661 my ($self, $tagInfo, $value, @grps) = @_;
8467 59806         86197 my ($tag, $noListDel, $tbl);
8468 59806         105135 my $options = $$self{OPTIONS};
8469              
8470 59806 100       129343 if (ref $tagInfo eq 'HASH') {
8471 52302 50       153748 $tag = $$tagInfo{Name} or warn("No tag name\n"), return undef;
8472 52302         93125 $tbl = $$tagInfo{Table};
8473             } else {
8474 7504         11040 $tag = $tagInfo;
8475             # look for tag in Extra
8476 7504         15387 $tbl = GetTagTable('Image::ExifTool::Extra');
8477 7504         18005 $tagInfo = $self->GetTagInfo($tbl, $tag);
8478             # make temporary hash if tag doesn't exist in Extra
8479             # (not advised to do this since the tag won't show in list)
8480 7504 100       15516 $tagInfo or $tagInfo = { Name => $tag, Groups => \%allGroupsExifTool };
8481 7504 100       16702 $$options{Verbose} and $self->VerboseInfo(undef, $tagInfo, Value => $value);
8482             }
8483             # get tag priority
8484 59806         92599 my $priority = $$tagInfo{Priority};
8485 59806 100       116539 unless (defined $priority) {
8486 55290         90075 $priority = $$tbl{PRIORITY};
8487 55290 100 100     191892 $priority = 0 if not defined $priority and $$tagInfo{Avoid};
8488             }
8489 59806 100       133063 $grps[0] or $grps[0] = $$self{SET_GROUP0};
8490 59806 100       120298 $grps[1] or $grps[1] = $$self{SET_GROUP1};
8491 59806         96037 my $valueHash = $$self{VALUE};
8492              
8493 59806 100       122992 if ($$tagInfo{RawConv}) {
8494             # initialize @val for use in Composite RawConv expressions
8495 9388         16394 my @val;
8496 9388 50 66     26060 if (ref $value eq 'HASH' and $$tagInfo{IsComposite}) {
8497 1814         5192 foreach (keys %$value) { $val[$_] = $$valueHash{$$value{$_}}; }
  6084         15753  
8498             }
8499 9388         19354 my $conv = $$tagInfo{RawConv};
8500 9388         46234 local $SIG{'__WARN__'} = \&SetWarning;
8501 9388         18538 undef $evalWarning;
8502 9388 100       19105 if (ref $conv eq 'CODE') {
8503 220         1157 $value = &$conv($value, $self);
8504 220 50       795 $$self{grps} and @grps = @{$$self{grps}}, delete $$self{grps};
  0         0  
8505             } else {
8506 9168         14340 my $val = $value; # do this so eval can use $val
8507             # NOTE: RawConv is also evaluated in Writer.pl
8508             #### eval RawConv ($self, $val, $tag, $tagInfo, $priority, @grps)
8509 9168         821056 $value = eval $conv;
8510 9168 50       41319 $@ and $evalWarning = $@;
8511             }
8512 9388 50       22299 $self->Warn("RawConv $tag: " . CleanWarning()) if $evalWarning;
8513 9388 100       42761 return undef unless defined $value;
8514             }
8515             # ignore specified tags (AFTER doing RawConv if necessary!)
8516 57172 50       118352 if ($$options{IgnoreTags}) {
8517 0 0       0 if ($$options{IgnoreTags}{all}) {
8518 0 0       0 return undef unless $$self{REQ_TAG_LOOKUP}{lc $tag};
8519             } else {
8520 0 0       0 return undef if $$options{IgnoreTags}{lc $tag};
8521             }
8522             }
8523             # handle duplicate tag names
8524 57172 100       147671 if (defined $$valueHash{$tag}) {
    100          
8525             # add to list if there is an active list for this tag
8526 6671 100       20427 if ($$self{LIST_TAGS}{$tagInfo}) {
8527 645         1765 $tag = $$self{LIST_TAGS}{$tagInfo}; # use key from previous list tag
8528 645 100       1564 if (defined $$self{NO_LIST}) {
8529             # accumulate list in TAG_EXTRA "NoList" element
8530 65 100       207 if (defined $$self{TAG_EXTRA}{$tag}{NoList}) {
8531 31         90 push @{$$self{TAG_EXTRA}{$tag}{NoList}}, $value;
  31         129  
8532             } else {
8533 34         145 $$self{TAG_EXTRA}{$tag}{NoList} = [ $$valueHash{$tag}, $value ];
8534             }
8535 65         150 $noListDel = 1; # set flag to delete this tag if re-listed
8536             } else {
8537 580 100       1743 if (ref $$valueHash{$tag} ne 'ARRAY') {
8538 300         1035 $$valueHash{$tag} = [ $$valueHash{$tag} ];
8539             }
8540 580         1016 push @{$$valueHash{$tag}}, $value;
  580         1922  
8541 580         2157 return $tag; # return without creating a new entry
8542             }
8543             }
8544             # get next available tag key
8545 6091   100     26967 my $nextInd = $$self{DUPL_TAG}{$tag} = ($$self{DUPL_TAG}{$tag} || 0) + 1;
8546 6091         15492 my $nextTag = "$tag ($nextInd)";
8547             #
8548             # take tag with highest priority
8549             #
8550             # promote existing 0-priority tag so it takes precedence over a new 0-tag
8551             # (unless old tag was a sub-document and new tag isn't. Also, never override
8552             # a Warning tag because they may be added by ValueConv, which could be confusing)
8553 6091         12016 my $oldPriority = $$self{PRIORITY}{$tag};
8554 6091 100       12573 unless ($oldPriority) {
8555 5183 100 100     29983 if ($$self{DOC_NUM} or not $$self{TAG_EXTRA}{$tag} or $tag eq 'Warning' or
      66        
      100        
8556             not $$self{TAG_EXTRA}{$tag}{G3})
8557             {
8558 5148         8888 $oldPriority = 1;
8559             } else {
8560 35         71 $oldPriority = 0; # don't promote sub-document tag over main document
8561             }
8562             }
8563             # set priority for this tag
8564 6091 100 100     28111 if (defined $priority) {
    100 33        
8565             # increase 0-priority tags if this is the priority directory
8566             $priority = 1 if not $priority and $$self{DIR_NAME} and
8567 2067 100 100     11756 $$self{DIR_NAME} eq $$self{PRIORITY_DIR};
      100        
8568             } elsif ($$self{LOW_PRIORITY_DIR}{'*'} or
8569             ($$self{DIR_NAME} and $$self{LOW_PRIORITY_DIR}{$$self{DIR_NAME}}))
8570             {
8571 411         684 $priority = 0; # default is 0 for a LOW_PRIORITY_DIR
8572             } else {
8573 3613         6013 $priority = 1; # the normal default
8574             }
8575 6091 100 100     29198 if ($priority >= $oldPriority and (not $$self{DOC_NUM} or
      100        
      100        
8576             ($$self{TAG_EXTRA}{$tag} and $$self{TAG_EXTRA}{$tag}{G3} and
8577             $$self{DOC_NUM} eq $$self{TAG_EXTRA}{$tag}{G3})) and not $noListDel)
8578             {
8579             # move existing tag out of the way since this tag is higher priority
8580             # (NOTE: any new members added here must also be added to DeleteTag())
8581 2745         9932 $$self{PRIORITY}{$nextTag} = $$self{PRIORITY}{$tag};
8582 2745         7248 $$valueHash{$nextTag} = $$valueHash{$tag};
8583 2745         6741 $$self{FILE_ORDER}{$nextTag} = $$self{FILE_ORDER}{$tag};
8584 2745         7140 my $oldInfo = $$self{TAG_INFO}{$nextTag} = $$self{TAG_INFO}{$tag};
8585 2745         5910 foreach ('TAG_EXTRA','RATIONAL') {
8586 5490 100       14199 if ($$self{$_}{$tag}) {
8587 1897         4737 $$self{$_}{$nextTag} = $$self{$_}{$tag};
8588 1897         4566 delete $$self{$_}{$tag};
8589             }
8590             }
8591 2745         4854 delete $$self{BOTH}{$tag};
8592             # update tag key for list if necessary
8593 2745 100       6969 $$self{LIST_TAGS}{$oldInfo} = $nextTag if $$self{LIST_TAGS}{$oldInfo};
8594             # update this key if used in a Composite tag
8595 2745 100       7737 if ($$self{COMP_KEYS}{$tag}) {
8596 89         156 $$_[0]{$$_[1]} = $nextTag foreach @{$$self{COMP_KEYS}{$tag}};
  89         424  
8597 89         250 $$self{COMP_KEYS}{$nextTag} = $$self{COMP_KEYS}{$tag};
8598 89         210 delete $$self{COMP_KEYS}{$tag};
8599             }
8600             } else {
8601 3346         5619 $tag = $nextTag; # don't override the existing tag
8602             }
8603 6091         16125 $$self{PRIORITY}{$tag} = $priority;
8604 6091 100       14035 $$self{TAG_EXTRA}{$tag}{NoListDel} = 1 if $noListDel;
8605             } elsif ($priority) {
8606             # set tag priority (only if exists and is non-zero)
8607 216         997 $$self{PRIORITY}{$tag} = $priority;
8608             }
8609              
8610             # save the raw value, file order, tagInfo ref, group1 name,
8611             # and tag key for lists if necessary
8612 56592         165693 $$valueHash{$tag} = $value;
8613 56592         123049 $$self{FILE_ORDER}{$tag} = ++$$self{NUM_FOUND};
8614 56592         112146 $$self{TAG_INFO}{$tag} = $tagInfo;
8615             # set dynamic groups 0, 1 and 3 if necessary
8616 56592 100       108043 $$self{TAG_EXTRA}{$tag}{G0} = $grps[0] if $grps[0];
8617 56592 100       111090 $$self{TAG_EXTRA}{$tag}{G1} = $grps[1] if $grps[1];
8618 56592 100       114053 if ($$self{DOC_NUM}) {
8619 1753         4575 $$self{TAG_EXTRA}{$tag}{G3} = $$self{DOC_NUM};
8620 1753 50       6877 if ($$self{DOC_NUM} =~ /^(\d+)/) {
8621             # keep track of maximum 1st-level sub-document number
8622 1753 100       5869 $$self{DOC_COUNT} = $1 unless $$self{DOC_COUNT} >= $1;
8623             }
8624             }
8625             # save path if requested
8626 56592 100       114588 $$self{TAG_EXTRA}{$tag}{G5} = $self->MetadataPath() if $$options{SavePath};
8627              
8628             # remember this tagInfo if we will be accumulating values in a list
8629             # (but don't override earlier list if this may be deleted by NoListDel flag)
8630 56592 100 100     131571 if ($$tagInfo{List} and not $$self{NO_LIST} and not $noListDel) {
      100        
8631 1111         4252 $$self{LIST_TAGS}{$tagInfo} = $tag;
8632             }
8633              
8634             # validate tag if requested (but only for simple values -- could result
8635             # in infinite recursion if called for a Composite tag (HASH ref value)
8636             # because FoundTag is called in the middle of building Composite tags
8637 56592 100 100     123327 if ($$options{Validate} and not ref $value) {
8638 213         594 Image::ExifTool::Validate::ValidateRaw($self, $tag, $value);
8639             }
8640              
8641 56592         156600 return $tag;
8642             }
8643              
8644             #------------------------------------------------------------------------------
8645             # Make current directory the priority directory if not set already
8646             # Inputs: 0) ExifTool object reference
8647             sub SetPriorityDir($)
8648             {
8649 22     22 0 81 my $self = shift;
8650 22 50       535 $$self{PRIORITY_DIR} = $$self{DIR_NAME} unless $$self{PRIORITY_DIR};
8651             }
8652              
8653             #------------------------------------------------------------------------------
8654             # Set family 0 or 1 group name specific to this tag instance
8655             # Inputs: 0) ExifTool ref, 1) tag key, 2) group name, 3) family (default 1)
8656             sub SetGroup($$$;$)
8657             {
8658 13715     13715 0 30152 my ($self, $tagKey, $extra, $fam) = @_;
8659 13715 50       61238 $$self{TAG_EXTRA}{$tagKey}{defined $fam ? "G$fam" : 'G1'} = $extra;
8660             }
8661              
8662             #------------------------------------------------------------------------------
8663             # Delete specified tag
8664             # Inputs: 0) ExifTool object ref, 1) tag key
8665             sub DeleteTag($$)
8666             {
8667 224     224 0 1134 my ($self, $tag) = @_;
8668 224         445 delete $$self{VALUE}{$tag};
8669 224         373 delete $$self{FILE_ORDER}{$tag};
8670 224         397 delete $$self{TAG_INFO}{$tag};
8671 224         439 delete $$self{TAG_EXTRA}{$tag};
8672 224         381 delete $$self{PRIORITY}{$tag};
8673 224         386 delete $$self{RATIONAL}{$tag};
8674 224         621 delete $$self{BOTH}{$tag};
8675             }
8676              
8677             #------------------------------------------------------------------------------
8678             # Escape all elements of a value
8679             # Inputs: 0) value, 1) escape proc
8680             sub DoEscape($$)
8681             {
8682 173     173 0 256 my ($val, $key);
8683 173 100       348 if (not ref $_[0]) {
    100          
    50          
8684 167         251 $_[0] = &{$_[1]}($_[0]);
  167         389  
8685             } elsif (ref $_[0] eq 'ARRAY') {
8686 4         11 foreach $val (@{$_[0]}) {
  4         18  
8687 10         25 DoEscape($val, $_[1]);
8688             }
8689             } elsif (ref $_[0] eq 'HASH') {
8690 0         0 foreach $key (keys %{$_[0]}) {
  0         0  
8691 0         0 DoEscape($_[0]{$key}, $_[1]);
8692             }
8693             }
8694             }
8695              
8696             #------------------------------------------------------------------------------
8697             # Set the FileType and MIMEType tags
8698             # Inputs: 0) ExifTool object reference
8699             # 1) Optional file type (uses FILE_TYPE if not specified)
8700             # 2) Optional MIME type (uses our lookup if not specified)
8701             # 3) Optional recommended extension (converted to lower case; uses FileType if undef)
8702             # Notes: Will NOT set file type twice (subsequent calls ignored)
8703             sub SetFileType($;$$$)
8704             {
8705 651     651 0 2620 my ($self, $fileType, $mimeType, $normExt) = @_;
8706 651 100 66     3642 unless ($$self{FileType} and not $$self{DOC_NUM}) {
8707 603         1713 my $baseType = $$self{FILE_TYPE};
8708 603         1587 my $ext = $$self{FILE_EXT};
8709 603 100       2908 $fileType or $fileType = $baseType;
8710             # handle sub-types which are identified by extension
8711 603 100 100     4867 if (defined $ext and $ext ne $fileType and not $$self{DOC_NUM}) {
      66        
8712 270         1450 my ($f,$e) = @fileTypeLookup{$fileType,$ext};
8713 270 100 100     2328 if (ref $f eq 'ARRAY' and ref $e eq 'ARRAY' and $$f[0] eq $$e[0]) {
      100        
8714             # make sure $fileType was a root type and not another sub-type
8715 10 100 66     73 $fileType = $ext if $$f[0] eq $fileType or not $fileTypeLookup{$$f[0]};
8716             }
8717             }
8718 603 100       3134 $mimeType or $mimeType = $mimeType{$fileType};
8719             # use base file type if necessary (except if 'TIFF', which is a special case)
8720 603 100 66     2626 $mimeType = $mimeType{$baseType} unless $mimeType or $baseType eq 'TIFF';
8721 603 100       2930 unless (defined $normExt) {
8722 593         1801 $normExt = $fileTypeExt{$fileType};
8723 593 100       2739 $normExt = $fileType unless defined $normExt;
8724             }
8725             # ($$self{FileType} is the file type of the main document)
8726 603 50       2561 $$self{FileType} = $fileType unless $$self{DOC_NUM};
8727 603         2530 $self->FoundTag('FileType', $fileType);
8728 603         4770 $self->FoundTag('FileTypeExtension', uc $normExt);
8729 603   100     4222 $self->FoundTag('MIMEType', $mimeType || 'application/unknown');
8730             }
8731             }
8732              
8733             #------------------------------------------------------------------------------
8734             # Override the FileType and MIMEType tags
8735             # Inputs: 0) ExifTool object ref, 1) file type, 2) MIME type, 3) normal extension (lower case)
8736             # Notes: does nothing if FileType was not previously defined (ie. when writing)
8737             sub OverrideFileType($$;$$)
8738             {
8739 18     18 0 83 my ($self, $fileType, $mimeType, $normExt) = @_;
8740 18 100 66     155 if (defined $$self{VALUE}{FileType} and $fileType ne $$self{VALUE}{FileType}) {
8741 12         41 $$self{FileType} = $fileType;
8742 12         31 $$self{VALUE}{FileType} = $fileType;
8743 12 100       45 unless (defined $normExt) {
8744 5         17 $normExt = $fileTypeExt{$fileType};
8745 5 50       21 $normExt = $fileType unless defined $normExt;
8746             }
8747 12         37 $$self{VALUE}{FileTypeExtension} = uc $normExt;
8748 12 50       101 $mimeType or $mimeType = $mimeType{$fileType};
8749 12 100       48 $$self{VALUE}{MIMEType} = $mimeType if $mimeType;
8750 12 50       126 if ($$self{OPTIONS}{Verbose}) {
8751 0         0 $self->VPrint(0,"$$self{INDENT}FileType [override] = $fileType\n");
8752 0         0 $self->VPrint(0,"$$self{INDENT}FileTypeExtension [override] = $$self{VALUE}{FileTypeExtension}\n");
8753 0 0       0 $self->VPrint(0,"$$self{INDENT}MIMEType [override] = $mimeType\n") if $mimeType;
8754             }
8755             }
8756             }
8757              
8758             #------------------------------------------------------------------------------
8759             # Modify the value of the MIMEType tag
8760             # Inputs: 0) ExifTool object reference, 1) file or MIME type
8761             # Notes: combines existing type with new type: ie) a/b + c/d => c/b-d
8762             sub ModifyMimeType($;$)
8763             {
8764 8     8 0 61 my ($self, $mime) = @_;
8765 8 50 33     60 $mime =~ m{/} or $mime = $mimeType{$mime} or return;
8766 8         30 my $old = $$self{VALUE}{MIMEType};
8767 8 50       33 if (defined $old) {
8768 8         42 my ($a, $b) = split '/', $old;
8769 8         38 my ($c, $d) = split '/', $mime;
8770 8         25 $d =~ s/^x-//;
8771 8         34 $$self{VALUE}{MIMEType} = "$c/$b-$d";
8772 8         56 $self->VPrint(0, " Modified MIMEType = $c/$b-$d\n");
8773             } else {
8774 0         0 $self->FoundTag('MIMEType', $mime);
8775             }
8776             }
8777              
8778             #------------------------------------------------------------------------------
8779             # Print verbose output
8780             # Inputs: 0) ExifTool ref, 1) verbose level (prints if level > this), 2-N) print args
8781             sub VPrint($$@)
8782             {
8783 9311     9311 0 16601 my $self = shift;
8784 9311         13512 my $level = shift;
8785 9311 100 66     35805 if ($$self{OPTIONS}{Verbose} and $$self{OPTIONS}{Verbose} > $level) {
8786 4         13 my $out = $$self{OPTIONS}{TextOut};
8787 4         19 print $out @_;
8788 4 50       31 print $out "\n" unless $_[-1] =~ /\n$/;
8789             }
8790             }
8791              
8792             #------------------------------------------------------------------------------
8793             # Print verbose directory information
8794             # Inputs: 0) ExifTool object reference, 1) directory name or dirInfo ref
8795             # 2) number of entries in directory (or 0 if unknown)
8796             # 3) optional size of directory in bytes
8797             sub VerboseDir($$;$$)
8798             {
8799 450     450 0 1217 my ($self, $name, $entries, $size) = @_;
8800 450 100       1635 return unless $$self{OPTIONS}{Verbose};
8801 44 50       113 if (ref $name eq 'HASH') {
8802 0 0       0 $size = $$name{DirLen} unless $size;
8803 0   0     0 $name = $$name{Name} || $$name{DirName};
8804             }
8805 44         124 my $indent = substr($$self{INDENT}, 0, -2);
8806 44         82 my $out = $$self{OPTIONS}{TextOut};
8807 44 100 66     240 my $str = ($entries or defined $entries and not $size) ? " with $entries entries" : '';
8808 44 100       130 $str .= ", $size bytes" if $size;
8809 44         166 print $out "$indent+ [$name directory$str]\n";
8810             }
8811              
8812             #------------------------------------------------------------------------------
8813             # Verbose dump
8814             # Inputs: 0) ExifTool ref, 1) data ref, 2-N) HexDump options
8815             sub VerboseDump($$;%)
8816             {
8817 128     128 0 248 my $self = shift;
8818 128         211 my $dataPt = shift;
8819 128         285 my $verbose = $$self{OPTIONS}{Verbose};
8820 128 50 33     460 if ($verbose and $verbose > 2) {
8821             my %parms = (
8822             Prefix => $$self{INDENT},
8823             Out => $$self{OPTIONS}{TextOut},
8824 0 0       0 MaxLen => $verbose < 4 ? 96 : $verbose < 5 ? 2048 : undef,
    0          
8825             );
8826 0         0 HexDump($dataPt, undef, %parms, @_);
8827             }
8828             }
8829              
8830             #------------------------------------------------------------------------------
8831             # Print data in hex
8832             # Inputs: 0) data
8833             # Returns: hex string
8834             # (this is a convenience function for use in debugging PrintConv statements)
8835             sub PrintHex($)
8836             {
8837 0     0 0 0 my $val = shift;
8838 0         0 return join(' ', unpack('H2' x length($val), $val));
8839             }
8840              
8841             #------------------------------------------------------------------------------
8842             # Extract binary data from file
8843             # 0) ExifTool object reference, 1) offset, 2) length, 3) tag name if conditional
8844             # Returns: binary data, or undef on error
8845             # Notes: Returns "Binary data #### bytes" instead of data unless tag is
8846             # specifically requested or the Binary option is set
8847             sub ExtractBinary($$$;$)
8848             {
8849 47     47 0 191 my ($self, $offset, $length, $tag) = @_;
8850 47         107 my ($isPreview, $buff);
8851              
8852 47 100       1089 if ($tag) {
8853 43 100       171 if ($tag eq 'PreviewImage') {
8854             # save PreviewImage start/length in case we want to dump trailer
8855 29         123 $$self{PreviewImageStart} = $offset;
8856 29         116 $$self{PreviewImageLength} = $length;
8857 29         71 $isPreview = 1;
8858             }
8859 43         125 my $lcTag = lc $tag;
8860 43 50 66     541 if ((not $$self{OPTIONS}{Binary} or $$self{EXCL_TAG_LOOKUP}{$lcTag}) and
      66        
      66        
8861             not $$self{OPTIONS}{Verbose} and not $$self{REQ_TAG_LOOKUP}{$lcTag})
8862             {
8863 34         217 return "Binary data $length bytes";
8864             }
8865             }
8866 13 100 66     74 unless ($$self{RAF}->Seek($offset,0)
8867             and $$self{RAF}->Read($buff, $length) == $length)
8868             {
8869 5 50       32 $tag or $tag = 'binary data';
8870 5 50 33     40 if ($isPreview and not $$self{BuildingComposite}) {
8871 0         0 $$self{PreviewError} = 1;
8872             } else {
8873 5         44 $self->Warn("Error reading $tag from file", $isPreview);
8874             }
8875 5         40 return undef;
8876             }
8877 8         38 return $buff;
8878             }
8879              
8880             #------------------------------------------------------------------------------
8881             # Process binary data
8882             # Inputs: 0) ExifTool object ref, 1) directory information ref, 2) tag table ref
8883             # Returns: 1 on success
8884             # Notes: dirInfo may contain VarFormatData (reference to empty list) to return
8885             # details about any variable-length-format tags in the table (used when writing)
8886             sub ProcessBinaryData($$$)
8887             {
8888 2113     2113 0 4774 my ($self, $dirInfo, $tagTablePtr) = @_;
8889 2113         4123 my $dataPt = $$dirInfo{DataPt};
8890 2113         4025 my $dataLen = length $$dataPt;
8891 2113   100     6659 my $dirStart = $$dirInfo{DirStart} || 0;
8892 2113         3658 my $maxLen = $dataLen - $dirStart;
8893 2113         3638 my $size = $$dirInfo{DirLen};
8894 2113   100     6088 my $base = $$dirInfo{Base} || 0;
8895 2113         4437 my $verbose = $$self{OPTIONS}{Verbose};
8896 2113         4055 my $unknown = $$self{OPTIONS}{Unknown};
8897 2113   100     6312 my $dataPos = $$dirInfo{DataPos} || 0;
8898              
8899 2113 100 66     8186 $size = $maxLen if not defined $size or $size > $maxLen;
8900             # get default format ('int8u' unless specified)
8901 2113   100     8111 my $defaultFormat = $$tagTablePtr{FORMAT} || 'int8u';
8902 2113         4261 my $increment = $formatSize{$defaultFormat};
8903 2113 50       4879 unless ($increment) {
8904 0         0 warn "Unknown format $defaultFormat\n";
8905 0         0 $defaultFormat = 'int8u';
8906 0         0 $increment = $formatSize{$defaultFormat};
8907             }
8908             # prepare list of tag numbers to extract
8909 2113         3749 my (@tags, $topIndex);
8910 2113 50 33     8704 if ($unknown > 1 and defined $$tagTablePtr{FIRST_ENTRY}) {
    100          
    100          
8911             # don't create a stupid number of tags if data is huge
8912 0 0       0 my $sizeLimit = $size < 65536 ? $size : 65536;
8913             # scan through entire binary table
8914 0         0 $topIndex = int($sizeLimit/$increment);
8915 0         0 @tags = ($$tagTablePtr{FIRST_ENTRY}..($topIndex - 1));
8916             # add in floating point tag ID's if they exist
8917 0         0 my @ftags = grep /\./, TagTableKeys($tagTablePtr);
8918 0 0       0 @tags = sort { $a <=> $b } @tags, @ftags if @ftags;
  0         0  
8919             } elsif ($$dirInfo{DataMember}) {
8920 195         329 @tags = @{$$dirInfo{DataMember}};
  195         712  
8921 195         429 $verbose = 0; # no verbose output of extracted values when writing
8922             } elsif ($$dirInfo{MixedTags}) {
8923             # process sorted integer-ID tags only
8924 38         139 @tags = sort { $a <=> $b } grep /^\d+$/, TagTableKeys($tagTablePtr);
  444         823  
8925             } else {
8926             # extract known tags in numerical order
8927 1880 50       4833 @tags = sort { ($a < 0 ? $a + 1e9 : $a) <=> ($b < 0 ? $b + 1e9 : $b) } TagTableKeys($tagTablePtr);
  55728 50       109628  
8928             }
8929 2113 100       7350 $self->VerboseDir('BinaryData', undef, $size) if $verbose;
8930             # avoid creating unknown tags for tags that fail condition if Unknown is 1
8931 2113 50       8060 $$self{NO_UNKNOWN} = 1 if $unknown < 2;
8932 2113         3600 my ($index, %val);
8933 2113         3403 my $nextIndex = 0;
8934 2113         3283 my $varSize = 0;
8935 2113         3912 foreach $index (@tags) {
8936 17684         30087 my ($tagInfo, $val, $saveNextIndex, $len, $mask, $wasVar, $rational);
8937 17684 50 0     44577 if ($$tagTablePtr{$index}) {
    0          
8938 17684         39616 $tagInfo = $self->GetTagInfo($tagTablePtr, $index);
8939 17684 100       37248 unless ($tagInfo) {
8940 730 100       2167 next unless defined $tagInfo;
8941             # $entry = offset of value relative to directory start (or end if negative)
8942 48         263 my $entry = int($index) * $increment + $varSize;
8943 48 50       237 if ($entry < 0) {
8944 0         0 $entry += $size;
8945 0 0       0 next if $entry < 0;
8946             }
8947 48 100       208 next if $entry >= $size;
8948 4         13 my $more = $size - $entry;
8949 4 50       17 $more = 128 if $more > 128;
8950 4         17 my $v = substr($$dataPt, $entry+$dirStart, $more);
8951 4         17 $tagInfo = $self->GetTagInfo($tagTablePtr, $index, \$v);
8952 4 50       33 next unless $tagInfo;
8953             }
8954             next if $$tagInfo{Unknown} and
8955 16958 100 66     35544 ($$tagInfo{Unknown} > $unknown or $index < $nextIndex);
      66        
8956             } elsif ($topIndex and $$tagTablePtr{$index - $topIndex}) {
8957 0 0       0 $tagInfo = $self->GetTagInfo($tagTablePtr, $index - $topIndex) or next;
8958             } else {
8959             # don't generate unknown tags in binary tables unless Unknown > 1
8960 0 0       0 next unless $unknown > 1;
8961 0 0       0 next if $index < $nextIndex; # skip if data already used
8962 0 0       0 $tagInfo = $self->GetTagInfo($tagTablePtr, $index) or next;
8963 0         0 $$tagInfo{Unknown} = 2; # set unknown to 2 for binary unknowns
8964             }
8965             # get relative offset of this entry
8966 16957         31370 my $entry = int($index) * $increment + $varSize;
8967             # allow negative indices to represent bytes from end
8968 16957 50       34037 if ($entry < 0) {
8969 0         0 $entry += $size;
8970 0 0       0 next if $entry < 0;
8971             }
8972 16957         25106 my $more = $size - $entry;
8973 16957 100       31758 last if $more <= 0; # all done if we have reached the end of data
8974 16684         23891 my $count = 1;
8975 16684         34121 my $format = $$tagInfo{Format};
8976 16684 100       43403 if (not $format) {
    100          
    50          
    100          
8977 9652         15568 $format = $defaultFormat;
8978             } elsif ($format eq 'string') {
8979             # string with no specified count runs to end of block
8980 104         237 $count = $more;
8981             } elsif ($format eq 'pstring') {
8982 0         0 $format = 'string';
8983 0         0 $count = Get8u($dataPt, ($entry++)+$dirStart);
8984 0         0 --$more;
8985             } elsif (not $formatSize{$format}) {
8986 3182 100       17237 if ($format =~ /(.*)\[(.*)\]/) {
    50          
8987             # handle format count field
8988 2997         7957 $format = $1;
8989 2997         5780 $count = $2;
8990             # evaluate count to allow count to be based on previous values
8991             #### eval Format size (%val, $size, $self)
8992 2997         133339 $count = eval $count;
8993 2997 50       12165 $@ and warn("Format $$tagInfo{Name}: $@"), next;
8994 2997 50       7206 next if $count < 0;
8995             # allow a variable-length value of any format
8996             # (note: the next incremental index points to data immediately after
8997             # this value, regardless of the size of this value, even if it is zero)
8998 2997 50       7977 if ($format =~ s/^var_//) {
8999 0   0     0 $varSize += $count * ($formatSize{$format} || 1) - $increment;
9000 0         0 $wasVar = 1;
9001             # save variable size data if required for writing
9002 0 0       0 if ($$dirInfo{VarFormatData}) {
9003 0         0 push @{$$dirInfo{VarFormatData}}, [ $index, $varSize, $format ];
  0         0  
9004             }
9005             # don't extract value if large and we wanted it just to get
9006             # the variable-format information when writing
9007 0 0 0     0 next if $$tagInfo{LargeTag} and $$dirInfo{VarFormatData};
9008             }
9009             } elsif ($format =~ /^var_/) {
9010             # handle variable-length string formats
9011 185         497 $format = substr($format, 4);
9012 185         715 pos($$dataPt) = $entry + $dirStart;
9013 185         479 undef $count;
9014 185 50 100     1292 if ($format eq 'ustring') {
    50          
    100          
    100          
    100          
    50          
9015 0 0       0 $count = pos($$dataPt) - ($entry+$dirStart) if $$dataPt =~ /\G(..)*?\0\0/sg;
9016 0         0 $varSize -= 2; # ($count includes base size of 2 bytes)
9017             } elsif ($format eq 'pstring') {
9018 0         0 $count = Get8u($dataPt, ($entry++)+$dirStart);
9019 0         0 --$more;
9020             } elsif ($format eq 'pstr32' or $format eq 'ustr32') {
9021 170 50       434 last if $more < 4;
9022 170         449 $count = Get32u($dataPt, $entry + $dirStart);
9023 170 100       646 $count *= 2 if $format eq 'ustr32';
9024 170         304 $entry += 4;
9025 170         288 $more -= 4;
9026 170         482 $nextIndex += 4 / $increment; # (increment next index for int32u)
9027             } elsif ($format eq 'int16u') {
9028             # int16u size of binary data to follow
9029 10 50       39 last if $more < 2;
9030 10         60 $count = Get16u($dataPt, $entry + $dirStart) + 2;
9031 10         22 $varSize -= 2; # ($count includes size word)
9032 10         36 $format = 'undef';
9033             } elsif ($format eq 'ue7') {
9034 3         16 require Image::ExifTool::BPG;
9035 3         14 ($val, $count) = Image::ExifTool::BPG::Get_ue7($dataPt, $entry + $dirStart);
9036 3 50       7 last unless defined $val;
9037 3         5 --$varSize; # ($count includes base size of 1 byte)
9038             } elsif ($$dataPt =~ /\0/g) {
9039 2         5 $count = pos($$dataPt) - ($entry+$dirStart);
9040 2         3 --$varSize; # ($count includes base size of 1 byte)
9041             }
9042 185 50 33     877 $count = $more if not defined $count or $count > $more;
9043 185         340 $varSize += $count; # shift subsequent indices
9044 185 100       457 unless (defined $val) {
9045 182         516 $val = substr($$dataPt, $entry+$dirStart, $count);
9046 182 100 66     1081 $val = $self->Decode($val, 'UCS2') if $format eq 'ustring' or $format eq 'ustr32';
9047 182 100       684 $val =~ s/\0.*//s unless $format eq 'undef'; # truncate at null
9048             }
9049 185         334 $wasVar = 1;
9050             # save variable size data if required for writing
9051 185 100       523 if ($$dirInfo{VarFormatData}) {
9052 5         10 push @{$$dirInfo{VarFormatData}}, [ $index, $varSize, $format ];
  5         21  
9053             }
9054             }
9055             }
9056             # hook to allow format, etc to be set dynamically
9057 16684 100       38112 if (defined $$tagInfo{Hook}) {
9058 540         903 my $oldVarSize = $varSize;
9059 540         860 my $pos = $entry + $dirStart;
9060             #### eval Hook ($format, $varSize, $size, $dataPt, $pos)
9061 540         35337 eval $$tagInfo{Hook};
9062             # save variable size data if required for writing (in case changed by Hook)
9063 540 100 66     3109 if ($$dirInfo{VarFormatData}) {
    50          
9064 247 50       589 $#{$$dirInfo{VarFormatData}} -= 1 if $wasVar; # remove previous entry for this tag
  0         0  
9065 247         377 push @{$$dirInfo{VarFormatData}}, [ $index, $varSize, $format ];
  247         920  
9066             } elsif ($varSize != $oldVarSize and $verbose > 2) {
9067 0         0 my ($tmp, $sign) = ($varSize, '+');
9068 0 0       0 $tmp < 0 and $tmp = -$tmp, $sign = '-';
9069 0         0 $self->VPrint(2, sprintf("$$self{INDENT}\[offsets adjusted by ${sign}0x%.4x after 0x%.4x $$tagInfo{Name}]\n", $tmp, $index));
9070             }
9071             }
9072 16684 50       32577 if ($unknown > 1) {
9073             # calculate next valid index for unknown tag
9074 0         0 my $ni = int $index;
9075 0 0 0     0 $ni += (($formatSize{$format} || 1) * $count) / $increment unless $wasVar;
9076 0         0 $saveNextIndex = $nextIndex;
9077 0 0       0 $nextIndex = $ni unless $nextIndex > $ni;
9078             }
9079             # allow large tags to be excluded from extraction
9080             # (provides a work-around for some tight memory situations)
9081 16684 50 33     37246 next if $$tagInfo{LargeTag} and $$self{EXCL_TAG_LOOKUP}{lc $$tagInfo{Name}};
9082             # read value now if necessary
9083 16684 100 66     36797 unless (defined $val and not $$tagInfo{SubDirectory}) {
9084 16499         41808 $val = ReadValue($dataPt, $entry+$dirStart, $format, $count, $more, \$rational);
9085 16499 50       34264 next unless defined $val;
9086 16499         30042 $mask = $$tagInfo{Mask};
9087 16499 100       33844 $val = ($val & $mask) >> $$tagInfo{BitShift} if $mask;
9088             }
9089 16684 100 66     35723 if ($verbose and not $$tagInfo{Hidden}) {
9090 198 50 33     548 if (not $$tagInfo{SubDirectory} or $$tagInfo{Format}) {
9091 198   50     441 $len = $count * ($formatSize{$format} || 1);
9092 198 50       399 $len = $more if $len > $more;
9093             } else {
9094 0         0 $len = $more;
9095             }
9096 198 50       900 $self->VerboseInfo($index, $tagInfo,
9097             Table => $tagTablePtr,
9098             Value => $val,
9099             DataPt => $dataPt,
9100             Size => $len,
9101             Start => $entry+$dirStart,
9102             Addr => $entry+$dirStart+$base+$dataPos,
9103             Format => $format,
9104             Count => $count,
9105             Extra => $mask ? sprintf(', mask 0x%.2x',$mask) : undef,
9106             );
9107             }
9108             # parse nested BinaryData directories
9109 16684 100       33579 if ($$tagInfo{SubDirectory}) {
9110 14         84 my $subdir = $$tagInfo{SubDirectory};
9111 14         63 my $subTablePtr = GetTagTable($$subdir{TagTable});
9112             # use specified subdirectory length if given
9113 14 100 66     146 if ($$tagInfo{Format} and $formatSize{$format}) {
9114 12         39 $len = $count * $formatSize{$format};
9115 12 50       47 $len = $more if $len > $more;
9116             } else {
9117 2         3 $len = $more; # directory size is all of remaining data
9118 2 50 33     16 if ($$subTablePtr{PROCESS_PROC} and
9119             $$subTablePtr{PROCESS_PROC} eq \&ProcessBinaryData)
9120             {
9121             # the rest of the data will be printed in the subdirectory
9122 2         5 $nextIndex = $size / $increment;
9123             }
9124             }
9125 14         32 my $subdirBase = $base;
9126 14 50       69 if (defined $$subdir{Base}) {
9127             #### eval Base ($start,$base)
9128 0         0 my $start = $entry + $dirStart + $dataPos;
9129 0         0 $subdirBase = eval($$subdir{Base}) + $base;
9130             }
9131 14   50     83 my $start = $$subdir{Start} || 0;
9132 14 50       63 if ($start =~ /\$/) {
9133             # ignore directories with a zero offset (ie. missing Nikon ShotInfo entries)
9134 0 0       0 next unless $val;
9135             #### eval Start ($val, $dirStart)
9136 0         0 $start = eval($start);
9137 0 0 0     0 next if $start < $dirStart or $start > $dataLen;
9138 0         0 $len = $$subdir{DirLen};
9139 0 0 0     0 $len = $dataLen - $start unless $len and $len <= $dataLen - $start;
9140             } else {
9141 14         37 $start += $dirStart + $entry;
9142             }
9143 14         89 my %subdirInfo = (
9144             DataPt => $dataPt,
9145             DataPos => $dataPos,
9146             DataLen => $dataLen,
9147             DirStart => $start,
9148             DirLen => $len,
9149             Base => $subdirBase,
9150             );
9151 14         46 delete $$self{NO_UNKNOWN};
9152 14         126 $self->ProcessDirectory(\%subdirInfo, $subTablePtr, $$subdir{ProcessProc});
9153 14 50       132 $$self{NO_UNKNOWN} = 1 if $unknown < 2;
9154 14         57 next;
9155             }
9156 16670 100 66     35856 if ($$tagInfo{IsOffset} and $$tagInfo{IsOffset} ne '3') {
9157 38         79 my $et = $self;
9158             #### eval IsOffset ($val, $et)
9159 38 100       2284 $val += $base + $$self{BASE} if eval $$tagInfo{IsOffset};
9160             }
9161 16670         37914 $val{$index} = $val;
9162 16670         22909 my $oldBase;
9163 16670 50       34215 if ($$tagInfo{SetBase}) {
9164 0         0 $oldBase = $$self{BASE};
9165 0         0 $$self{BASE} += $base;
9166             }
9167 16670         40421 my $key = $self->FoundTag($tagInfo,$val);
9168 16670 50       36161 $$self{BASE} = $oldBase if defined $oldBase;
9169 16670 100       30842 if ($key) {
9170 15269 100       41127 $$self{RATIONAL}{$key} = $rational if defined $rational;
9171             } else {
9172             # don't increment nextIndex if we didn't extract a tag
9173 1401 50       4730 $nextIndex = $saveNextIndex if defined $saveNextIndex;
9174             }
9175             }
9176 2113         5075 delete $$self{NO_UNKNOWN};
9177 2113         10770 return 1;
9178             }
9179              
9180             #..............................................................................
9181             # Load .ExifTool_config file from user's home directory
9182             # (use of noConfig is now deprecated, use configFile = '' instead)
9183             until ($Image::ExifTool::noConfig) {
9184             my $config = $Image::ExifTool::configFile;
9185             my $file;
9186             if (not defined $config) {
9187             $config = '.ExifTool_config';
9188             # get our home directory (HOMEDRIVE and HOMEPATH are used in Windows cmd shell)
9189             my $home = $ENV{EXIFTOOL_HOME} || $ENV{HOME} ||
9190             ($ENV{HOMEDRIVE} || '') . ($ENV{HOMEPATH} || '') || '.';
9191             # look for the config file in 1) the home directory, 2) the program dir
9192             $file = "$home/$config";
9193             } else {
9194             length $config or last; # filename of "" disables configuration
9195             $file = $config;
9196             }
9197             # also check executable directory unless path is absolute
9198             $exeDir = ($0 =~ /(.*)[\\\/]/) ? $1 : '.' unless defined $exeDir;
9199             -r $file or $config =~ /^\// or $file = "$exeDir/$config";
9200             unless (-r $file) {
9201             warn("Config file not found\n") if defined $Image::ExifTool::configFile;
9202             last;
9203             }
9204             unshift @INC, '.'; # look in current directory first
9205             eval { require $file }; # load the config file
9206             shift @INC;
9207             # print warning (minus "Compilation failed" part)
9208             $@ and $_=$@, s/Compilation failed.*//s, warn $_;
9209             last;
9210             }
9211             # read user-defined lenses (may have been defined by script instead of config file)
9212             if (@Image::ExifTool::UserDefined::Lenses) {
9213             foreach (@Image::ExifTool::UserDefined::Lenses) {
9214             $Image::ExifTool::userLens{$_} = 1;
9215             }
9216             }
9217             # add user-defined file types
9218             if (%Image::ExifTool::UserDefined::FileTypes) {
9219             foreach (sort keys %Image::ExifTool::UserDefined::FileTypes) {
9220             my $fileInfo = $Image::ExifTool::UserDefined::FileTypes{$_};
9221             my $type = uc $_;
9222             ref $fileInfo eq 'HASH' or $fileTypeLookup{$type} = $fileInfo, next;
9223             my $baseType = $$fileInfo{BaseType};
9224             if ($baseType) {
9225             if ($$fileInfo{Description}) {
9226             $fileTypeLookup{$type} = [ $baseType, $$fileInfo{Description} ];
9227             } else {
9228             $fileTypeLookup{$type} = $baseType;
9229             }
9230             if (defined $$fileInfo{Writable} and not $$fileInfo{Writable}) {
9231             # first make sure we are using an actual base type and not a derived type
9232             $baseType = $fileTypeLookup{$baseType} while $baseType and not ref $fileTypeLookup{$baseType};
9233             # mark this type as not writable
9234             $noWriteFile{$baseType} or $noWriteFile{$baseType} = [ ];
9235             push @{$noWriteFile{$baseType}}, $type;
9236             }
9237             } else {
9238             $fileTypeLookup{$type} = [ $type, $$fileInfo{Description} || $type ];
9239             $moduleName{$type} = 0; # not supported
9240             if ($$fileInfo{Magic}) {
9241             $magicNumber{$type} = $$fileInfo{Magic};
9242             push @fileTypes, $type unless grep /^$type$/, @fileTypes;
9243             }
9244             }
9245             $mimeType{$type} = $$fileInfo{MIMEType} if defined $$fileInfo{MIMEType};
9246             }
9247             }
9248              
9249             #------------------------------------------------------------------------------
9250             1; # end