line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
2
|
|
|
|
|
|
|
# File: Writer.pl |
3
|
|
|
|
|
|
|
# |
4
|
|
|
|
|
|
|
# Description: ExifTool write routines |
5
|
|
|
|
|
|
|
# |
6
|
|
|
|
|
|
|
# Notes: Also contains some less used ExifTool functions |
7
|
|
|
|
|
|
|
# |
8
|
|
|
|
|
|
|
# URL: https://exiftool.org/ |
9
|
|
|
|
|
|
|
# |
10
|
|
|
|
|
|
|
# Revisions: 12/16/2004 - P. Harvey Created |
11
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
package Image::ExifTool; |
14
|
|
|
|
|
|
|
|
15
|
59
|
|
|
59
|
|
458
|
use strict; |
|
59
|
|
|
|
|
129
|
|
|
59
|
|
|
|
|
2690
|
|
16
|
|
|
|
|
|
|
|
17
|
59
|
|
|
59
|
|
175316
|
use Image::ExifTool::TagLookup qw(FindTagInfo TagExists); |
|
59
|
|
|
|
|
10335
|
|
|
59
|
|
|
|
|
23128
|
|
18
|
59
|
|
|
59
|
|
42970
|
use Image::ExifTool::Fixup; |
|
59
|
|
|
|
|
446
|
|
|
59
|
|
|
|
|
138582
|
|
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
sub AssembleRational($$@); |
21
|
|
|
|
|
|
|
sub LastInList($); |
22
|
|
|
|
|
|
|
sub CreateDirectory($$); |
23
|
|
|
|
|
|
|
sub NextFreeTagKey($$); |
24
|
|
|
|
|
|
|
sub RemoveNewValueHash($$$); |
25
|
|
|
|
|
|
|
sub RemoveNewValuesForGroup($$); |
26
|
|
|
|
|
|
|
sub GetWriteGroup1($$); |
27
|
|
|
|
|
|
|
sub Sanitize($$); |
28
|
|
|
|
|
|
|
sub ConvInv($$$$$;$$); |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
my $loadedAllTables; # flag indicating we loaded all tables |
31
|
|
|
|
|
|
|
my $advFmtSelf; # ExifTool object during evaluation of advanced formatting expr |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
# the following is a road map of where we write each directory |
34
|
|
|
|
|
|
|
# in the different types of files. |
35
|
|
|
|
|
|
|
my %tiffMap = ( |
36
|
|
|
|
|
|
|
IFD0 => 'TIFF', |
37
|
|
|
|
|
|
|
IFD1 => 'IFD0', |
38
|
|
|
|
|
|
|
XMP => 'IFD0', |
39
|
|
|
|
|
|
|
ICC_Profile => 'IFD0', |
40
|
|
|
|
|
|
|
ExifIFD => 'IFD0', |
41
|
|
|
|
|
|
|
GPS => 'IFD0', |
42
|
|
|
|
|
|
|
SubIFD => 'IFD0', |
43
|
|
|
|
|
|
|
GlobParamIFD => 'IFD0', |
44
|
|
|
|
|
|
|
PrintIM => 'IFD0', |
45
|
|
|
|
|
|
|
IPTC => 'IFD0', |
46
|
|
|
|
|
|
|
Photoshop => 'IFD0', |
47
|
|
|
|
|
|
|
InteropIFD => 'ExifIFD', |
48
|
|
|
|
|
|
|
MakerNotes => 'ExifIFD', |
49
|
|
|
|
|
|
|
CanonVRD => 'MakerNotes', # (so VRDOffset will get updated) |
50
|
|
|
|
|
|
|
NikonCapture => 'MakerNotes', # (to allow delete by group) |
51
|
|
|
|
|
|
|
PhaseOne => 'MakerNotes', # (for editing PhaseOne SensorCalibration tags) |
52
|
|
|
|
|
|
|
); |
53
|
|
|
|
|
|
|
my %exifMap = ( |
54
|
|
|
|
|
|
|
IFD1 => 'IFD0', |
55
|
|
|
|
|
|
|
EXIF => 'IFD0', # to write EXIF as a block |
56
|
|
|
|
|
|
|
ExifIFD => 'IFD0', |
57
|
|
|
|
|
|
|
GPS => 'IFD0', |
58
|
|
|
|
|
|
|
SubIFD => 'IFD0', |
59
|
|
|
|
|
|
|
GlobParamIFD => 'IFD0', |
60
|
|
|
|
|
|
|
PrintIM => 'IFD0', |
61
|
|
|
|
|
|
|
InteropIFD => 'ExifIFD', |
62
|
|
|
|
|
|
|
MakerNotes => 'ExifIFD', |
63
|
|
|
|
|
|
|
NikonCapture => 'MakerNotes', # (to allow delete by group) |
64
|
|
|
|
|
|
|
# (no CanonVRD trailer allowed) |
65
|
|
|
|
|
|
|
); |
66
|
|
|
|
|
|
|
my %jpegMap = ( |
67
|
|
|
|
|
|
|
%exifMap, # covers all JPEG EXIF mappings |
68
|
|
|
|
|
|
|
JFIF => 'APP0', |
69
|
|
|
|
|
|
|
CIFF => 'APP0', |
70
|
|
|
|
|
|
|
IFD0 => 'APP1', |
71
|
|
|
|
|
|
|
XMP => 'APP1', |
72
|
|
|
|
|
|
|
ICC_Profile => 'APP2', |
73
|
|
|
|
|
|
|
FlashPix => 'APP2', |
74
|
|
|
|
|
|
|
MPF => 'APP2', |
75
|
|
|
|
|
|
|
Meta => 'APP3', |
76
|
|
|
|
|
|
|
MetaIFD => 'Meta', |
77
|
|
|
|
|
|
|
RMETA => 'APP5', |
78
|
|
|
|
|
|
|
Ducky => 'APP12', |
79
|
|
|
|
|
|
|
Photoshop => 'APP13', |
80
|
|
|
|
|
|
|
Adobe => 'APP14', |
81
|
|
|
|
|
|
|
IPTC => 'Photoshop', |
82
|
|
|
|
|
|
|
MakerNotes => ['ExifIFD', 'CIFF'], # (first parent is the default) |
83
|
|
|
|
|
|
|
CanonVRD => 'MakerNotes', # (so VRDOffset will get updated) |
84
|
|
|
|
|
|
|
NikonCapture => 'MakerNotes', # (to allow delete by group) |
85
|
|
|
|
|
|
|
Comment => 'COM', |
86
|
|
|
|
|
|
|
); |
87
|
|
|
|
|
|
|
my %dirMap = ( |
88
|
|
|
|
|
|
|
JPEG => \%jpegMap, |
89
|
|
|
|
|
|
|
EXV => \%jpegMap, |
90
|
|
|
|
|
|
|
TIFF => \%tiffMap, |
91
|
|
|
|
|
|
|
ORF => \%tiffMap, |
92
|
|
|
|
|
|
|
RAW => \%tiffMap, |
93
|
|
|
|
|
|
|
EXIF => \%exifMap, |
94
|
|
|
|
|
|
|
); |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
# module names and write functions for each writable file type |
97
|
|
|
|
|
|
|
# (defaults to "$type" and "Process$type" if not defined) |
98
|
|
|
|
|
|
|
# - types that are handled specially will not appear in this list |
99
|
|
|
|
|
|
|
my %writableType = ( |
100
|
|
|
|
|
|
|
CRW => [ 'CanonRaw', 'WriteCRW' ], |
101
|
|
|
|
|
|
|
DR4 => 'CanonVRD', |
102
|
|
|
|
|
|
|
EPS => [ 'PostScript', 'WritePS' ], |
103
|
|
|
|
|
|
|
FLIF=> [ undef, 'WriteFLIF'], |
104
|
|
|
|
|
|
|
GIF => undef, |
105
|
|
|
|
|
|
|
ICC => [ 'ICC_Profile', 'WriteICC' ], |
106
|
|
|
|
|
|
|
IND => 'InDesign', |
107
|
|
|
|
|
|
|
JP2 => 'Jpeg2000', |
108
|
|
|
|
|
|
|
JXL => 'Jpeg2000', |
109
|
|
|
|
|
|
|
MIE => undef, |
110
|
|
|
|
|
|
|
MOV => [ 'QuickTime', 'WriteMOV' ], |
111
|
|
|
|
|
|
|
MRW => 'MinoltaRaw', |
112
|
|
|
|
|
|
|
PDF => [ undef, 'WritePDF' ], |
113
|
|
|
|
|
|
|
PNG => undef, |
114
|
|
|
|
|
|
|
PPM => undef, |
115
|
|
|
|
|
|
|
PS => [ 'PostScript', 'WritePS' ], |
116
|
|
|
|
|
|
|
PSD => 'Photoshop', |
117
|
|
|
|
|
|
|
RAF => [ 'FujiFilm', 'WriteRAF' ], |
118
|
|
|
|
|
|
|
RIFF=> [ 'RIFF', 'WriteRIFF'], |
119
|
|
|
|
|
|
|
VRD => 'CanonVRD', |
120
|
|
|
|
|
|
|
WEBP=> [ 'RIFF', 'WriteRIFF'], |
121
|
|
|
|
|
|
|
X3F => 'SigmaRaw', |
122
|
|
|
|
|
|
|
XMP => [ undef, 'WriteXMP' ], |
123
|
|
|
|
|
|
|
); |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
# RAW file types |
126
|
|
|
|
|
|
|
my %rawType = ( |
127
|
|
|
|
|
|
|
'3FR'=> 1, CR3 => 1, IIQ => 1, NEF => 1, RW2 => 1, |
128
|
|
|
|
|
|
|
ARQ => 1, CRW => 1, K25 => 1, NRW => 1, RWL => 1, |
129
|
|
|
|
|
|
|
ARW => 1, DCR => 1, KDC => 1, ORF => 1, SR2 => 1, |
130
|
|
|
|
|
|
|
ARW => 1, ERF => 1, MEF => 1, PEF => 1, SRF => 1, |
131
|
|
|
|
|
|
|
CR2 => 1, FFF => 1, MOS => 1, RAW => 1, SRW => 1, |
132
|
|
|
|
|
|
|
); |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
# groups we are allowed to delete |
135
|
|
|
|
|
|
|
# Notes: |
136
|
|
|
|
|
|
|
# 1) these names must either exist in %dirMap, or be translated in InitWriteDirs()) |
137
|
|
|
|
|
|
|
# 2) any dependencies must be added to %excludeGroups |
138
|
|
|
|
|
|
|
my @delGroups = qw( |
139
|
|
|
|
|
|
|
Adobe AFCP APP0 APP1 APP2 APP3 APP4 APP5 APP6 APP7 APP8 APP9 APP10 APP11 |
140
|
|
|
|
|
|
|
APP12 APP13 APP14 APP15 CanonVRD CIFF Ducky EXIF ExifIFD File FlashPix |
141
|
|
|
|
|
|
|
FotoStation GlobParamIFD GPS ICC_Profile IFD0 IFD1 Insta360 InteropIFD IPTC |
142
|
|
|
|
|
|
|
ItemList JFIF Jpeg2000 Keys MakerNotes Meta MetaIFD Microsoft MIE MPF |
143
|
|
|
|
|
|
|
NikonApp NikonCapture PDF PDF-update PhotoMechanic Photoshop PNG PNG-pHYs |
144
|
|
|
|
|
|
|
PrintIM QuickTime RMETA RSRC SubIFD Trailer UserData XML XML-* XMP XMP-* |
145
|
|
|
|
|
|
|
); |
146
|
|
|
|
|
|
|
# family 2 group names that we can delete |
147
|
|
|
|
|
|
|
my @delGroup2 = qw( |
148
|
|
|
|
|
|
|
Audio Author Camera Document ExifTool Image Location Other Preview Printing |
149
|
|
|
|
|
|
|
Time Video |
150
|
|
|
|
|
|
|
); |
151
|
|
|
|
|
|
|
# Extra groups to delete when deleting another group |
152
|
|
|
|
|
|
|
my %delMore = ( |
153
|
|
|
|
|
|
|
QuickTime => [ qw(ItemList UserData Keys) ], |
154
|
|
|
|
|
|
|
XMP => [ 'XMP-*' ], |
155
|
|
|
|
|
|
|
XML => [ 'XML-*' ], |
156
|
|
|
|
|
|
|
); |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
# family 0 groups where directories should never be deleted |
159
|
|
|
|
|
|
|
my %permanentDir = ( QuickTime => 1, Jpeg2000 => 1 ); |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
# lookup for all valid family 2 groups (lower case) |
162
|
|
|
|
|
|
|
my %family2groups = map { lc $_ => 1 } @delGroup2, 'Unknown'; |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
# groups we don't delete when deleting all information |
165
|
|
|
|
|
|
|
my $protectedGroups = '(IFD1|SubIFD|InteropIFD|GlobParamIFD|PDF-update|Adobe)'; |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
# other group names of new tag values to remove when deleting an entire group |
168
|
|
|
|
|
|
|
my %removeGroups = ( |
169
|
|
|
|
|
|
|
IFD0 => [ 'EXIF', 'MakerNotes' ], |
170
|
|
|
|
|
|
|
EXIF => [ 'MakerNotes' ], |
171
|
|
|
|
|
|
|
ExifIFD => [ 'MakerNotes', 'InteropIFD' ], |
172
|
|
|
|
|
|
|
Trailer => [ 'CanonVRD' ], #(because we can add back CanonVRD as a block) |
173
|
|
|
|
|
|
|
); |
174
|
|
|
|
|
|
|
# related family 0/1 groups in @delGroups (and not already in %jpegMap) |
175
|
|
|
|
|
|
|
# that must be removed from delete list when excluding a group |
176
|
|
|
|
|
|
|
my %excludeGroups = ( |
177
|
|
|
|
|
|
|
EXIF => [ qw(IFD0 IFD1 ExifIFD GPS MakerNotes GlobParamIFD InteropIFD PrintIM SubIFD) ], |
178
|
|
|
|
|
|
|
IFD0 => [ 'EXIF' ], |
179
|
|
|
|
|
|
|
IFD1 => [ 'EXIF' ], |
180
|
|
|
|
|
|
|
ExifIFD => [ 'EXIF' ], |
181
|
|
|
|
|
|
|
GPS => [ 'EXIF' ], |
182
|
|
|
|
|
|
|
MakerNotes => [ 'EXIF' ], |
183
|
|
|
|
|
|
|
InteropIFD => [ 'EXIF' ], |
184
|
|
|
|
|
|
|
GlobParamIFD => [ 'EXIF' ], |
185
|
|
|
|
|
|
|
PrintIM => [ 'EXIF' ], |
186
|
|
|
|
|
|
|
CIFF => [ 'MakerNotes' ], |
187
|
|
|
|
|
|
|
# technically correct, but very uncommon and not a good reason to avoid deleting trailer |
188
|
|
|
|
|
|
|
# IPTC => [ qw(AFCP FotoStation Trailer) ], |
189
|
|
|
|
|
|
|
AFCP => [ 'Trailer' ], |
190
|
|
|
|
|
|
|
FotoStation => [ 'Trailer' ], |
191
|
|
|
|
|
|
|
CanonVRD => [ 'Trailer' ], |
192
|
|
|
|
|
|
|
PhotoMechanic=> [ 'Trailer' ], |
193
|
|
|
|
|
|
|
MIE => [ 'Trailer' ], |
194
|
|
|
|
|
|
|
QuickTime => [ qw(ItemList UserData Keys) ], |
195
|
|
|
|
|
|
|
); |
196
|
|
|
|
|
|
|
# translate (lower case) wanted group when writing for tags where group name may change |
197
|
|
|
|
|
|
|
my %translateWantGroup = ( |
198
|
|
|
|
|
|
|
ciff => 'canonraw', |
199
|
|
|
|
|
|
|
); |
200
|
|
|
|
|
|
|
# group names to translate for writing |
201
|
|
|
|
|
|
|
my %translateWriteGroup = ( |
202
|
|
|
|
|
|
|
EXIF => 'ExifIFD', |
203
|
|
|
|
|
|
|
Meta => 'MetaIFD', |
204
|
|
|
|
|
|
|
File => 'Comment', |
205
|
|
|
|
|
|
|
# any entry in this table causes the write group to be set from the |
206
|
|
|
|
|
|
|
# tag information instead of whatever the user specified... |
207
|
|
|
|
|
|
|
MIE => 'MIE', |
208
|
|
|
|
|
|
|
APP14 => 'APP14', |
209
|
|
|
|
|
|
|
); |
210
|
|
|
|
|
|
|
# names of valid EXIF and Meta directories (lower case keys): |
211
|
|
|
|
|
|
|
my %exifDirs = ( |
212
|
|
|
|
|
|
|
gps => 'GPS', |
213
|
|
|
|
|
|
|
exififd => 'ExifIFD', |
214
|
|
|
|
|
|
|
subifd => 'SubIFD', |
215
|
|
|
|
|
|
|
globparamifd => 'GlobParamIFD', |
216
|
|
|
|
|
|
|
interopifd => 'InteropIFD', |
217
|
|
|
|
|
|
|
previewifd => 'PreviewIFD', # (in MakerNotes) |
218
|
|
|
|
|
|
|
metaifd => 'MetaIFD', # Kodak APP3 Meta |
219
|
|
|
|
|
|
|
makernotes => 'MakerNotes', |
220
|
|
|
|
|
|
|
); |
221
|
|
|
|
|
|
|
# valid family 0 groups when WriteGroup is set to "All" |
222
|
|
|
|
|
|
|
my %allFam0 = ( |
223
|
|
|
|
|
|
|
exif => 1, |
224
|
|
|
|
|
|
|
makernotes => 1, |
225
|
|
|
|
|
|
|
); |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
my @writableMacOSTags = qw( |
228
|
|
|
|
|
|
|
FileCreateDate MDItemFinderComment MDItemFSCreationDate MDItemFSLabel MDItemUserTags |
229
|
|
|
|
|
|
|
XAttrQuarantine |
230
|
|
|
|
|
|
|
); |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
# min/max values for integer formats |
233
|
|
|
|
|
|
|
my %intRange = ( |
234
|
|
|
|
|
|
|
'int8u' => [0, 0xff], |
235
|
|
|
|
|
|
|
'int8s' => [-0x80, 0x7f], |
236
|
|
|
|
|
|
|
'int16u' => [0, 0xffff], |
237
|
|
|
|
|
|
|
'int16uRev' => [0, 0xffff], |
238
|
|
|
|
|
|
|
'int16s' => [-0x8000, 0x7fff], |
239
|
|
|
|
|
|
|
'int32u' => [0, 0xffffffff], |
240
|
|
|
|
|
|
|
'int32s' => [-0x80000000, 0x7fffffff], |
241
|
|
|
|
|
|
|
'int64u' => [0, 18446744073709551615], |
242
|
|
|
|
|
|
|
'int64s' => [-9223372036854775808, 9223372036854775807], |
243
|
|
|
|
|
|
|
); |
244
|
|
|
|
|
|
|
# lookup for file types with block-writable EXIF |
245
|
|
|
|
|
|
|
my %blockExifTypes = map { $_ => 1 } qw(JPEG PNG JP2 JXL MIE EXIF FLIF MOV MP4 RIFF); |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
my $maxSegmentLen = 0xfffd; # maximum length of data in a JPEG segment |
248
|
|
|
|
|
|
|
my $maxXMPLen = $maxSegmentLen; # maximum length of XMP data in JPEG |
249
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
# value separators when conversion list is used (in SetNewValue) |
251
|
|
|
|
|
|
|
my %listSep = ( PrintConv => '; ?', ValueConv => ' ' ); |
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
# printConv hash keys to ignore when doing reverse lookup |
254
|
|
|
|
|
|
|
my %ignorePrintConv = map { $_ => 1 } qw(OTHER BITMASK Notes); |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
257
|
|
|
|
|
|
|
# Set tag value |
258
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object reference |
259
|
|
|
|
|
|
|
# 1) tag key, tag name, or '*' (optionally prefixed by group name), |
260
|
|
|
|
|
|
|
# or undef to reset all previous SetNewValue() calls |
261
|
|
|
|
|
|
|
# 2) new value (scalar, scalar ref or list ref), or undef to delete tag |
262
|
|
|
|
|
|
|
# 3-N) Options: |
263
|
|
|
|
|
|
|
# Type => PrintConv, ValueConv or Raw - specifies value type |
264
|
|
|
|
|
|
|
# AddValue => true to add to list of existing values instead of overwriting |
265
|
|
|
|
|
|
|
# DelValue => true to delete this existing value value from a list, or |
266
|
|
|
|
|
|
|
# or doing a conditional delete, or to shift a time value |
267
|
|
|
|
|
|
|
# Group => family 0 or 1 group name (case insensitive) |
268
|
|
|
|
|
|
|
# Replace => 0, 1 or 2 - overwrite previous new values (2=reset) |
269
|
|
|
|
|
|
|
# Protected => bitmask to write tags with specified protections |
270
|
|
|
|
|
|
|
# EditOnly => true to only edit existing tags (don't create new tag) |
271
|
|
|
|
|
|
|
# EditGroup => true to only edit existing groups (don't create new group) |
272
|
|
|
|
|
|
|
# Shift => undef, 0, +1 or -1 - shift value if possible |
273
|
|
|
|
|
|
|
# NoFlat => treat flattened tags as 'unsafe' |
274
|
|
|
|
|
|
|
# NoShortcut => true to prevent looking up shortcut tags |
275
|
|
|
|
|
|
|
# ProtectSaved => protect existing new values with a save count greater than this |
276
|
|
|
|
|
|
|
# IgnorePermanent => ignore attempts to delete a permanent tag |
277
|
|
|
|
|
|
|
# CreateGroups => [internal use] createGroups hash ref from related tags |
278
|
|
|
|
|
|
|
# ListOnly => [internal use] set only list or non-list tags |
279
|
|
|
|
|
|
|
# SetTags => [internal use] hash ref to return tagInfo refs of set tags |
280
|
|
|
|
|
|
|
# Sanitized => [internal use] set to avoid double-sanitizing the value |
281
|
|
|
|
|
|
|
# Returns: number of tags set (plus error string in list context) |
282
|
|
|
|
|
|
|
# Notes: For tag lists (like Keywords), call repeatedly with the same tag name for |
283
|
|
|
|
|
|
|
# each value in the list. Internally, the new information is stored in |
284
|
|
|
|
|
|
|
# the following members of the $$self{NEW_VALUE}{$tagInfo} hash: |
285
|
|
|
|
|
|
|
# TagInfo - tag info ref |
286
|
|
|
|
|
|
|
# DelValue - list ref for raw values to delete |
287
|
|
|
|
|
|
|
# Value - list ref for raw values to add (not defined if deleting the tag) |
288
|
|
|
|
|
|
|
# IsCreating - must be set for the tag to be added for the standard file types, |
289
|
|
|
|
|
|
|
# otherwise just changed if it already exists. This may be |
290
|
|
|
|
|
|
|
# overridden for file types with a PREFERRED metadata type. |
291
|
|
|
|
|
|
|
# Set to 2 to create individual tags but not new groups |
292
|
|
|
|
|
|
|
# EditOnly - flag set if tag should never be created (regardless of file type). |
293
|
|
|
|
|
|
|
# If this is set, then IsCreating must be false |
294
|
|
|
|
|
|
|
# CreateOnly - flag set if creating only (never edit existing tag) |
295
|
|
|
|
|
|
|
# CreateGroups - hash of all family 0 group names where tag may be created |
296
|
|
|
|
|
|
|
# WriteGroup - group name where information is being written (correct case) |
297
|
|
|
|
|
|
|
# WantGroup - group name as specified in call to function (case insensitive) |
298
|
|
|
|
|
|
|
# Next - pointer to next new value hash (if more than one) |
299
|
|
|
|
|
|
|
# NoReplace - set if value was created with Replace=0 |
300
|
|
|
|
|
|
|
# AddBefore - number of list items added by a subsequent Replace=0 call |
301
|
|
|
|
|
|
|
# IsNVH - Flag indicating this is a new value hash |
302
|
|
|
|
|
|
|
# Shift - shift value |
303
|
|
|
|
|
|
|
# Save - counter used by SaveNewValues()/RestoreNewValues() |
304
|
|
|
|
|
|
|
# MAKER_NOTE_FIXUP - pointer to fixup if necessary for a maker note value |
305
|
|
|
|
|
|
|
sub SetNewValue($;$$%) |
306
|
|
|
|
|
|
|
{ |
307
|
5679
|
|
|
5679
|
1
|
47876
|
local $_; |
308
|
5679
|
|
|
|
|
21460
|
my ($self, $tag, $value, %options) = @_; |
309
|
5679
|
|
|
|
|
10343
|
my ($err, $tagInfo, $family); |
310
|
5679
|
|
|
|
|
15371
|
my $verbose = $$self{OPTIONS}{Verbose}; |
311
|
5679
|
|
|
|
|
11644
|
my $out = $$self{OPTIONS}{TextOut}; |
312
|
5679
|
|
100
|
|
|
19913
|
my $protected = $options{Protected} || 0; |
313
|
5679
|
|
|
|
|
9878
|
my $listOnly = $options{ListOnly}; |
314
|
5679
|
|
|
|
|
9637
|
my $setTags = $options{SetTags}; |
315
|
5679
|
|
|
|
|
9216
|
my $noFlat = $options{NoFlat}; |
316
|
5679
|
|
|
|
|
8821
|
my $numSet = 0; |
317
|
|
|
|
|
|
|
|
318
|
5679
|
100
|
|
|
|
12304
|
unless (defined $tag) { |
319
|
40
|
|
|
|
|
949
|
delete $$self{NEW_VALUE}; |
320
|
40
|
|
|
|
|
123
|
$$self{SAVE_COUNT} = 0; |
321
|
40
|
|
|
|
|
182
|
$$self{DEL_GROUP} = { }; |
322
|
40
|
|
|
|
|
177
|
return 1; |
323
|
|
|
|
|
|
|
} |
324
|
|
|
|
|
|
|
# allow value to be scalar or list reference |
325
|
5639
|
100
|
|
|
|
13416
|
if (ref $value) { |
326
|
218
|
100
|
|
|
|
1563
|
if (ref $value eq 'ARRAY') { |
|
|
100
|
|
|
|
|
|
327
|
|
|
|
|
|
|
# value is an ARRAY so it may have more than one entry |
328
|
|
|
|
|
|
|
# - set values both separately and as a combined string if there are more than one |
329
|
78
|
100
|
|
|
|
365
|
if (@$value > 1) { |
330
|
|
|
|
|
|
|
# set all list-type tags first |
331
|
51
|
|
|
|
|
139
|
my $replace = $options{Replace}; |
332
|
51
|
|
|
|
|
107
|
my $noJoin; |
333
|
51
|
|
|
|
|
166
|
foreach (@$value) { |
334
|
153
|
100
|
|
|
|
401
|
$noJoin = 1 if ref $_; |
335
|
153
|
|
|
|
|
913
|
my ($n, $e) = SetNewValue($self, $tag, $_, %options, ListOnly => 1); |
336
|
153
|
100
|
|
|
|
456
|
$err = $e if $e; |
337
|
153
|
|
|
|
|
286
|
$numSet += $n; |
338
|
153
|
|
|
|
|
480
|
delete $options{Replace}; # don't replace earlier values in list |
339
|
|
|
|
|
|
|
} |
340
|
51
|
100
|
|
|
|
290
|
return $numSet if $noJoin; # don't join if list contains objects |
341
|
|
|
|
|
|
|
# and now set only non-list tags |
342
|
50
|
|
|
|
|
280
|
$value = join $$self{OPTIONS}{ListSep}, @$value; |
343
|
50
|
|
|
|
|
153
|
$options{Replace} = $replace; |
344
|
50
|
|
|
|
|
159
|
$listOnly = $options{ListOnly} = 0; |
345
|
|
|
|
|
|
|
} else { |
346
|
27
|
|
|
|
|
104
|
$value = $$value[0]; |
347
|
27
|
50
|
|
|
|
130
|
$value = $$value if ref $value eq 'SCALAR'; # (handle single scalar ref in a list) |
348
|
|
|
|
|
|
|
} |
349
|
|
|
|
|
|
|
} elsif (ref $value eq 'SCALAR') { |
350
|
127
|
|
|
|
|
469
|
$value = $$value; |
351
|
|
|
|
|
|
|
} |
352
|
|
|
|
|
|
|
} |
353
|
|
|
|
|
|
|
# un-escape as necessary and make sure the Perl UTF-8 flag is OFF for the value |
354
|
|
|
|
|
|
|
# if perl is 5.6 or greater (otherwise our byte manipulations get corrupted!!) |
355
|
5638
|
100
|
100
|
|
|
40354
|
$self->Sanitize(\$value) if defined $value and not ref $value and not $options{Sanitized}; |
|
|
|
100
|
|
|
|
|
356
|
|
|
|
|
|
|
|
357
|
|
|
|
|
|
|
# set group name in options if specified |
358
|
5638
|
100
|
|
|
|
20607
|
($options{Group}, $tag) = ($1, $2) if $tag =~ /(.*):(.+)/; |
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
# allow trailing '#' for ValueConv value |
361
|
5638
|
100
|
|
|
|
15684
|
$options{Type} = 'ValueConv' if $tag =~ s/#$//; |
362
|
5638
|
|
66
|
|
|
25322
|
my $convType = $options{Type} || ($$self{OPTIONS}{PrintConv} ? 'PrintConv' : 'ValueConv'); |
363
|
|
|
|
|
|
|
|
364
|
|
|
|
|
|
|
# filter value if necessary |
365
|
5638
|
100
|
50
|
|
|
26636
|
$self->Filter($$self{OPTIONS}{FilterW}, \$value) or return 0 if $convType eq 'PrintConv'; |
366
|
|
|
|
|
|
|
|
367
|
5638
|
|
|
|
|
10539
|
my (@wantGroup, $family2); |
368
|
5638
|
|
|
|
|
11036
|
my $wantGroup = $options{Group}; |
369
|
5638
|
100
|
|
|
|
12300
|
if ($wantGroup) { |
370
|
2414
|
|
|
|
|
7801
|
foreach (split /:/, $wantGroup) { |
371
|
2440
|
50
|
33
|
|
|
17387
|
next unless length($_) and /^(\d+)?(.*)/; # separate family number and group name |
372
|
2440
|
|
|
|
|
8329
|
my ($f, $g) = ($1, $2); |
373
|
2440
|
|
|
|
|
5088
|
my $lcg = lc $g; |
374
|
|
|
|
|
|
|
# save group/family unless '*' or 'all' |
375
|
2440
|
100
|
66
|
|
|
12828
|
push @wantGroup, [ $f, $lcg ] unless $lcg eq '*' or $lcg eq 'all'; |
376
|
2440
|
100
|
|
|
|
9504
|
if ($g =~ s/^ID-//i) { # family 7 is a tag ID |
|
|
100
|
|
|
|
|
|
377
|
1
|
50
|
33
|
|
|
7
|
return 0 if defined $f and $f ne 7; |
378
|
1
|
|
|
|
|
4
|
$wantGroup[-1] = [ 7, $g ]; # group name with 'ID-' removed and case preserved |
379
|
|
|
|
|
|
|
} elsif (defined $f) { |
380
|
30
|
50
|
|
|
|
122
|
$f > 2 and return 0; # only allow family 0, 1 or 2 |
381
|
30
|
100
|
|
|
|
105
|
$family2 = 1 if $f == 2; # set flag indicating family 2 was used |
382
|
|
|
|
|
|
|
} else { |
383
|
2409
|
100
|
|
|
|
8434
|
$family2 = 1 if $family2groups{$lcg}; |
384
|
|
|
|
|
|
|
} |
385
|
|
|
|
|
|
|
} |
386
|
2414
|
100
|
|
|
|
7281
|
undef $wantGroup unless @wantGroup; |
387
|
|
|
|
|
|
|
} |
388
|
|
|
|
|
|
|
|
389
|
5638
|
|
|
|
|
13950
|
$tag =~ s/ .*//; # convert from tag key to tag name if necessary |
390
|
5638
|
100
|
|
|
|
14745
|
$tag = '*' if lc($tag) eq 'all'; # use '*' instead of 'all' |
391
|
|
|
|
|
|
|
# |
392
|
|
|
|
|
|
|
# handle group delete |
393
|
|
|
|
|
|
|
# |
394
|
5638
|
|
100
|
|
|
17364
|
while ($tag eq '*' and not defined $value and not $family2 and @wantGroup < 2) { |
|
|
|
100
|
|
|
|
|
|
|
|
66
|
|
|
|
|
395
|
|
|
|
|
|
|
# set groups to delete |
396
|
47
|
|
|
|
|
126
|
my (@del, $grp); |
397
|
47
|
|
66
|
|
|
255
|
my $remove = ($options{Replace} and $options{Replace} > 1); |
398
|
47
|
100
|
|
|
|
173
|
if ($wantGroup) { |
399
|
34
|
50
|
|
|
|
2336
|
@del = grep /^$wantGroup$/i, @delGroups unless $wantGroup =~ /^XM[LP]-\*$/i; |
400
|
|
|
|
|
|
|
# remove associated groups when excluding from mass delete |
401
|
34
|
100
|
100
|
|
|
300
|
if (@del and $remove) { |
402
|
|
|
|
|
|
|
# remove associated groups in other family |
403
|
4
|
100
|
|
|
|
34
|
push @del, @{$excludeGroups{$del[0]}} if $excludeGroups{$del[0]}; |
|
2
|
|
|
|
|
14
|
|
404
|
|
|
|
|
|
|
# remove upstream groups according to JPEG map |
405
|
4
|
|
|
|
|
11
|
my $dirName = $del[0]; |
406
|
4
|
|
|
|
|
10
|
my @dirNames; |
407
|
4
|
|
|
|
|
9
|
for (;;) { |
408
|
10
|
|
|
|
|
26
|
my $parent = $jpegMap{$dirName}; |
409
|
10
|
50
|
|
|
|
30
|
if (ref $parent) { |
410
|
0
|
|
|
|
|
0
|
push @dirNames, @$parent; |
411
|
0
|
|
|
|
|
0
|
$parent = pop @dirNames; |
412
|
|
|
|
|
|
|
} |
413
|
10
|
100
|
66
|
|
|
51
|
$dirName = $parent || shift @dirNames or last; |
414
|
6
|
|
|
|
|
16
|
push @del, $dirName; # exclude this too |
415
|
|
|
|
|
|
|
} |
416
|
|
|
|
|
|
|
} |
417
|
|
|
|
|
|
|
# allow MIE groups to be deleted by number, |
418
|
|
|
|
|
|
|
# and allow any XMP family 1 group to be deleted |
419
|
34
|
100
|
|
|
|
218
|
push @del, uc($wantGroup) if $wantGroup =~ /^(MIE\d+|XM[LP]-[-\w]*\w)$/i; |
420
|
|
|
|
|
|
|
} else { |
421
|
|
|
|
|
|
|
# push all groups plus '*', except the protected groups |
422
|
13
|
|
|
|
|
1579
|
push @del, (grep !/^$protectedGroups$/, @delGroups), '*'; |
423
|
|
|
|
|
|
|
} |
424
|
47
|
50
|
|
|
|
220
|
if (@del) { |
|
|
0
|
|
|
|
|
|
425
|
47
|
|
|
|
|
98
|
++$numSet; |
426
|
47
|
|
|
|
|
99
|
my @donegrps; |
427
|
47
|
|
|
|
|
204
|
my $delGroup = $$self{DEL_GROUP}; |
428
|
47
|
|
|
|
|
144
|
foreach $grp (@del) { |
429
|
804
|
100
|
|
|
|
1268
|
if ($remove) { |
430
|
23
|
|
|
|
|
43
|
my $didExcl; |
431
|
23
|
100
|
|
|
|
76
|
if ($grp =~ /^(XM[LP])(-.*)?$/) { |
432
|
4
|
|
|
|
|
13
|
my $x = $1; |
433
|
4
|
100
|
33
|
|
|
39
|
if ($grp eq $x) { |
|
|
50
|
|
|
|
|
|
434
|
|
|
|
|
|
|
# exclude all related family 1 groups too |
435
|
1
|
|
|
|
|
20
|
foreach (keys %$delGroup) { |
436
|
58
|
100
|
|
|
|
167
|
next unless /^(-?)$x-/; |
437
|
1
|
50
|
|
|
|
8
|
push @donegrps, $_ unless $1; |
438
|
1
|
|
|
|
|
4
|
delete $$delGroup{$_}; |
439
|
|
|
|
|
|
|
} |
440
|
|
|
|
|
|
|
} elsif ($$delGroup{"$x-*"} and not $$delGroup{"-$grp"}) { |
441
|
|
|
|
|
|
|
# must also exclude XMP or XML to prevent bulk delete |
442
|
3
|
100
|
|
|
|
16
|
if ($$delGroup{$x}) { |
443
|
2
|
|
|
|
|
7
|
push @donegrps, $x; |
444
|
2
|
|
|
|
|
7
|
delete $$delGroup{$x}; |
445
|
|
|
|
|
|
|
} |
446
|
|
|
|
|
|
|
# flag XMP/XML family 1 group for exclusion with leading '-' |
447
|
3
|
|
|
|
|
12
|
$$delGroup{"-$grp"} = 1; |
448
|
3
|
|
|
|
|
9
|
$didExcl = 1; |
449
|
|
|
|
|
|
|
} |
450
|
|
|
|
|
|
|
} |
451
|
23
|
100
|
|
|
|
60
|
if (exists $$delGroup{$grp}) { |
452
|
15
|
|
|
|
|
26
|
delete $$delGroup{$grp}; |
453
|
|
|
|
|
|
|
} else { |
454
|
8
|
100
|
|
|
|
25
|
next unless $didExcl; |
455
|
|
|
|
|
|
|
} |
456
|
|
|
|
|
|
|
} else { |
457
|
781
|
|
|
|
|
1913
|
$$delGroup{$grp} = 1; |
458
|
|
|
|
|
|
|
# add extra groups to delete if necessary |
459
|
781
|
100
|
|
|
|
1547
|
if ($delMore{$grp}) { |
460
|
49
|
|
|
|
|
123
|
$$delGroup{$_} = 1, push @donegrps, $_ foreach @{$delMore{$grp}}; |
|
49
|
|
|
|
|
284
|
|
461
|
|
|
|
|
|
|
} |
462
|
|
|
|
|
|
|
# remove all of this group from previous new values |
463
|
781
|
|
|
|
|
1386
|
$self->RemoveNewValuesForGroup($grp); |
464
|
|
|
|
|
|
|
} |
465
|
799
|
|
|
|
|
1359
|
push @donegrps, $grp; |
466
|
|
|
|
|
|
|
} |
467
|
47
|
100
|
66
|
|
|
302
|
if ($verbose > 1 and @donegrps) { |
468
|
1
|
|
|
|
|
5
|
@donegrps = sort @donegrps; |
469
|
1
|
50
|
|
|
|
6
|
my $msg = $remove ? 'Excluding from deletion' : 'Deleting tags in'; |
470
|
1
|
|
|
|
|
12
|
print $out " $msg: @donegrps\n"; |
471
|
|
|
|
|
|
|
} |
472
|
|
|
|
|
|
|
} elsif (grep /^$wantGroup$/i, @delGroup2) { |
473
|
0
|
|
|
|
|
0
|
last; # allow tags to be deleted by group2 name |
474
|
|
|
|
|
|
|
} else { |
475
|
0
|
|
|
|
|
0
|
$err = "Not a deletable group: $wantGroup"; |
476
|
|
|
|
|
|
|
} |
477
|
|
|
|
|
|
|
# all done |
478
|
47
|
50
|
|
|
|
177
|
return ($numSet, $err) if wantarray; |
479
|
47
|
50
|
|
|
|
184
|
$err and warn "$err\n"; |
480
|
47
|
|
|
|
|
322
|
return $numSet; |
481
|
|
|
|
|
|
|
} |
482
|
|
|
|
|
|
|
|
483
|
|
|
|
|
|
|
# initialize write/create flags |
484
|
5591
|
|
|
|
|
8455
|
my $createOnly; |
485
|
5591
|
|
|
|
|
9934
|
my $editOnly = $options{EditOnly}; |
486
|
5591
|
|
|
|
|
8944
|
my $editGroup = $options{EditGroup}; |
487
|
5591
|
|
|
|
|
12422
|
my $writeMode = $$self{OPTIONS}{WriteMode}; |
488
|
5591
|
100
|
|
|
|
12486
|
if ($writeMode ne 'wcg') { |
489
|
27
|
100
|
|
|
|
139
|
$createOnly = 1 if $writeMode !~ /w/i; # don't write existing tags |
490
|
27
|
100
|
|
|
|
143
|
if ($writeMode !~ /c/i) { |
|
|
100
|
|
|
|
|
|
491
|
2
|
50
|
|
|
|
25
|
return 0 if $createOnly; # nothing to do unless writing existing tags |
492
|
2
|
|
|
|
|
6
|
$editOnly = 1; # don't create new tags |
493
|
|
|
|
|
|
|
} elsif ($writeMode !~ /g/i) { |
494
|
8
|
|
|
|
|
19
|
$editGroup = 1; # don't create new groups |
495
|
|
|
|
|
|
|
} |
496
|
|
|
|
|
|
|
} |
497
|
5591
|
|
|
|
|
10369
|
my ($ifdName, $mieGroup, $movGroup, $fg); |
498
|
|
|
|
|
|
|
# set family 1 group names |
499
|
5591
|
|
|
|
|
10986
|
foreach $fg (@wantGroup) { |
500
|
2297
|
100
|
100
|
|
|
6639
|
next if defined $$fg[0] and $$fg[0] != 1; |
501
|
2278
|
|
|
|
|
4667
|
$_ = $$fg[1]; |
502
|
|
|
|
|
|
|
# set $ifdName if this group is a valid IFD or SubIFD name |
503
|
2278
|
|
|
|
|
3271
|
my $grpName; |
504
|
2278
|
100
|
100
|
|
|
19792
|
if (/^IFD(\d+)$/i) { |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
505
|
131
|
|
|
|
|
523
|
$grpName = $ifdName = "IFD$1"; |
506
|
|
|
|
|
|
|
} elsif (/^SubIFD(\d+)$/i) { |
507
|
0
|
|
|
|
|
0
|
$grpName = $ifdName = "SubIFD$1"; |
508
|
|
|
|
|
|
|
} elsif (/^Version(\d+)$/i) { |
509
|
0
|
|
|
|
|
0
|
$grpName = $ifdName = "Version$1"; # Sony IDC VersionIFD |
510
|
|
|
|
|
|
|
} elsif ($exifDirs{$_}) { |
511
|
274
|
|
|
|
|
846
|
$grpName = $exifDirs{$_}; |
512
|
274
|
50
|
33
|
|
|
1252
|
$ifdName = $grpName unless $ifdName and $allFam0{$_}; |
513
|
|
|
|
|
|
|
} elsif ($allFam0{$_}) { |
514
|
293
|
|
|
|
|
647
|
$grpName = $allFam0{$_}; |
515
|
|
|
|
|
|
|
} elsif (/^Track(\d+)$/i) { |
516
|
1
|
|
|
|
|
6
|
$grpName = $movGroup = "Track$1"; # QuickTime track |
517
|
|
|
|
|
|
|
} elsif (/^MIE(\d*-?)(\w+)$/i) { |
518
|
2
|
|
|
|
|
21
|
$grpName = $mieGroup = "MIE$1" . ucfirst(lc($2)); |
519
|
|
|
|
|
|
|
} elsif (not $ifdName and /^XMP\b/i) { |
520
|
|
|
|
|
|
|
# must load XMP table to set group1 names |
521
|
502
|
|
|
|
|
1898
|
my $table = GetTagTable('Image::ExifTool::XMP::Main'); |
522
|
502
|
|
|
|
|
1310
|
my $writeProc = $$table{WRITE_PROC}; |
523
|
502
|
50
|
|
|
|
1263
|
if ($writeProc) { |
524
|
59
|
|
|
59
|
|
632
|
no strict 'refs'; |
|
59
|
|
|
|
|
350
|
|
|
59
|
|
|
|
|
90457
|
|
525
|
502
|
|
|
|
|
1841
|
&$writeProc(); |
526
|
|
|
|
|
|
|
} |
527
|
|
|
|
|
|
|
} |
528
|
|
|
|
|
|
|
# fix case for known groups |
529
|
2278
|
100
|
66
|
|
|
12539
|
$wantGroup =~ s/$grpName/$grpName/i if $grpName and $grpName ne $_; |
530
|
|
|
|
|
|
|
} |
531
|
|
|
|
|
|
|
# |
532
|
|
|
|
|
|
|
# get list of tags we want to set |
533
|
|
|
|
|
|
|
# |
534
|
5591
|
|
|
|
|
10253
|
my $origTag = $tag; |
535
|
5591
|
|
|
|
|
18687
|
my @matchingTags = FindTagInfo($tag); |
536
|
5591
|
|
|
|
|
15701
|
until (@matchingTags) { |
537
|
1416
|
|
|
|
|
2543
|
my $langCode; |
538
|
|
|
|
|
|
|
# allow language suffix of form "-en_CA" or "-" on tag name |
539
|
1416
|
100
|
100
|
|
|
8079
|
if ($tag =~ /^([?*\w]+)-([a-z]{2})(_[a-z]{2})$/i or # MIE |
|
|
50
|
|
|
|
|
|
540
|
|
|
|
|
|
|
$tag =~ /^([?*\w]+)-([a-z]{2,3}|[xi])(-[a-z\d]{2,8}(-[a-z\d]{1,8})*)?$/i) # XMP/PNG/QuickTime |
541
|
|
|
|
|
|
|
{ |
542
|
51
|
|
|
|
|
186
|
$tag = $1; |
543
|
|
|
|
|
|
|
# normalize case of language codes |
544
|
51
|
|
|
|
|
138
|
$langCode = lc($2); |
545
|
51
|
100
|
|
|
|
235
|
$langCode .= (length($3) == 3 ? uc($3) : lc($3)) if $3; |
|
|
100
|
|
|
|
|
|
546
|
51
|
|
|
|
|
187
|
my @newMatches = FindTagInfo($tag); |
547
|
51
|
|
|
|
|
184
|
foreach $tagInfo (@newMatches) { |
548
|
|
|
|
|
|
|
# only allow language codes in tables which support them |
549
|
238
|
50
|
|
|
|
672
|
next unless $$tagInfo{Table}; |
550
|
238
|
100
|
|
|
|
645
|
my $langInfoProc = $$tagInfo{Table}{LANG_INFO} or next; |
551
|
186
|
|
|
|
|
615
|
my $langInfo = &$langInfoProc($tagInfo, $langCode); |
552
|
186
|
100
|
|
|
|
598
|
push @matchingTags, $langInfo if $langInfo; |
553
|
|
|
|
|
|
|
} |
554
|
51
|
100
|
|
|
|
187
|
last if @matchingTags; |
555
|
|
|
|
|
|
|
} elsif (not $options{NoShortcut}) { |
556
|
|
|
|
|
|
|
# look for a shortcut or alias |
557
|
1365
|
|
|
|
|
10607
|
require Image::ExifTool::Shortcuts; |
558
|
1365
|
|
|
|
|
31311
|
my ($match) = grep /^\Q$tag\E$/i, keys %Image::ExifTool::Shortcuts::Main; |
559
|
1365
|
|
|
|
|
4111
|
undef $err; |
560
|
1365
|
100
|
|
|
|
3480
|
if ($match) { |
561
|
1
|
|
|
|
|
6
|
$options{NoShortcut} = $options{Sanitized} = 1; |
562
|
1
|
|
|
|
|
2
|
foreach $tag (@{$Image::ExifTool::Shortcuts::Main{$match}}) { |
|
1
|
|
|
|
|
4
|
|
563
|
3
|
|
|
|
|
49
|
my ($n, $e) = $self->SetNewValue($tag, $value, %options); |
564
|
3
|
|
|
|
|
12
|
$numSet += $n; |
565
|
3
|
50
|
|
|
|
22
|
$e and $err = $e; |
566
|
|
|
|
|
|
|
} |
567
|
1
|
50
|
|
|
|
5
|
undef $err if $numSet; # no error if any set successfully |
568
|
1
|
50
|
|
|
|
4
|
return ($numSet, $err) if wantarray; |
569
|
1
|
50
|
|
|
|
4
|
$err and warn "$err\n"; |
570
|
1
|
|
|
|
|
9
|
return $numSet; |
571
|
|
|
|
|
|
|
} |
572
|
|
|
|
|
|
|
} |
573
|
1366
|
50
|
|
|
|
3174
|
unless ($listOnly) { |
574
|
1366
|
100
|
|
|
|
4462
|
if (not TagExists($tag)) { |
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
575
|
49
|
50
|
|
|
|
287
|
if ($tag =~ /^[-\w*?]+$/) { |
576
|
49
|
100
|
|
|
|
134
|
my $pre = $wantGroup ? $wantGroup . ':' : ''; |
577
|
49
|
|
|
|
|
155
|
$err = "Tag '$pre${origTag}' is not defined"; |
578
|
49
|
100
|
|
|
|
161
|
$err .= ' or has a bad language code' if $origTag =~ /-/; |
579
|
49
|
50
|
66
|
|
|
179
|
if (not $pre and uc($origTag) eq 'TAG') { |
580
|
0
|
|
|
|
|
0
|
$err .= " (specify a writable tag name, not '${origTag}' literally)" |
581
|
|
|
|
|
|
|
} |
582
|
|
|
|
|
|
|
} else { |
583
|
0
|
|
|
|
|
0
|
$err = "Invalid tag name '${tag}'"; |
584
|
0
|
0
|
|
|
|
0
|
$err .= " (remove the leading '\$')" if $tag =~ /^\$/; |
585
|
|
|
|
|
|
|
} |
586
|
|
|
|
|
|
|
} elsif ($langCode) { |
587
|
0
|
|
|
|
|
0
|
$err = "Tag '${tag}' does not support alternate languages"; |
588
|
|
|
|
|
|
|
} elsif ($wantGroup) { |
589
|
507
|
|
|
|
|
1512
|
$err = "Sorry, $wantGroup:$origTag doesn't exist or isn't writable"; |
590
|
|
|
|
|
|
|
} else { |
591
|
810
|
|
|
|
|
2294
|
$err = "Sorry, $origTag is not writable"; |
592
|
|
|
|
|
|
|
} |
593
|
1366
|
50
|
|
|
|
3523
|
$verbose > 2 and print $out "$err\n"; |
594
|
|
|
|
|
|
|
} |
595
|
|
|
|
|
|
|
# all done |
596
|
1366
|
50
|
|
|
|
8274
|
return ($numSet, $err) if wantarray; |
597
|
0
|
0
|
|
|
|
0
|
$err and warn "$err\n"; |
598
|
0
|
|
|
|
|
0
|
return $numSet; |
599
|
|
|
|
|
|
|
} |
600
|
|
|
|
|
|
|
# get group name that we're looking for |
601
|
4224
|
|
|
|
|
8038
|
my $foundMatch = 0; |
602
|
|
|
|
|
|
|
# |
603
|
|
|
|
|
|
|
# determine the groups for all tags found, and the tag with |
604
|
|
|
|
|
|
|
# the highest priority group |
605
|
|
|
|
|
|
|
# |
606
|
4224
|
|
|
|
|
12134
|
my (@tagInfoList, @writeAlsoList, %writeGroup, %preferred, %tagPriority); |
607
|
4224
|
|
|
|
|
0
|
my (%avoid, $wasProtected, $noCreate, %highestPriority, %highestQT); |
608
|
|
|
|
|
|
|
|
609
|
4224
|
|
|
|
|
7843
|
TAG: foreach $tagInfo (@matchingTags) { |
610
|
69913
|
|
|
|
|
331092
|
$tag = $$tagInfo{Name}; # get tag name for warnings |
611
|
69913
|
|
|
|
|
118020
|
my $lcTag = lc $tag; # get lower-case tag name for use in variables |
612
|
|
|
|
|
|
|
# initialize highest priority if we are starting a new tag |
613
|
69913
|
100
|
|
|
|
197591
|
$highestPriority{$lcTag} = -999 unless defined $highestPriority{$lcTag}; |
614
|
69913
|
|
|
|
|
104087
|
my ($priority, $writeGroup); |
615
|
69913
|
100
|
|
|
|
217395
|
my $prfTag = defined $$tagInfo{Preferred} ? $$tagInfo{Preferred} : $$tagInfo{Table}{PREFERRED}; |
616
|
69913
|
100
|
|
|
|
128936
|
if ($wantGroup) { |
617
|
|
|
|
|
|
|
# a WriteGroup of All is special |
618
|
49702
|
|
100
|
|
|
102768
|
my $wgAll = ($$tagInfo{WriteGroup} and $$tagInfo{WriteGroup} eq 'All'); |
619
|
49702
|
|
|
|
|
129397
|
my @grp = $self->GetGroup($tagInfo); |
620
|
49702
|
|
|
|
|
77676
|
my $hiPri = 1000; |
621
|
49702
|
|
|
|
|
79972
|
foreach $fg (@wantGroup) { |
622
|
49740
|
|
|
|
|
93506
|
my ($fam, $lcWant) = @$fg; |
623
|
49740
|
100
|
|
|
|
100161
|
$lcWant = $translateWantGroup{$lcWant} if $translateWantGroup{$lcWant}; |
624
|
|
|
|
|
|
|
# only set tag in specified group |
625
|
|
|
|
|
|
|
# bump priority of preferred tag |
626
|
49740
|
100
|
|
|
|
89929
|
$hiPri += $prfTag if $prfTag; |
627
|
49740
|
100
|
66
|
|
|
91087
|
if (not defined $fam) { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
628
|
49498
|
100
|
|
|
|
101764
|
if ($lcWant eq lc $grp[0]) { |
629
|
|
|
|
|
|
|
# don't go to more general write group of "All" |
630
|
|
|
|
|
|
|
# if something more specific was wanted |
631
|
2182
|
100
|
100
|
|
|
5315
|
$writeGroup = $grp[0] if $wgAll and not $writeGroup; |
632
|
2182
|
|
|
|
|
4219
|
next; |
633
|
|
|
|
|
|
|
} |
634
|
47316
|
100
|
|
|
|
97116
|
next if $lcWant eq lc $grp[2]; |
635
|
|
|
|
|
|
|
} elsif ($fam == 7) { |
636
|
2
|
100
|
|
|
|
24
|
next if IsSameID($$tagInfo{TagID}, $lcWant); |
637
|
|
|
|
|
|
|
} elsif ($fam != 1 and not $$tagInfo{AllowGroup}) { |
638
|
132
|
100
|
|
|
|
351
|
next if $lcWant eq lc $grp[$fam]; |
639
|
110
|
100
|
100
|
|
|
350
|
if ($wgAll and not $fam and $allFam0{$lcWant}) { |
|
|
|
100
|
|
|
|
|
640
|
5
|
100
|
|
|
|
23
|
$writeGroup or $writeGroup = $allFam0{$lcWant}; |
641
|
5
|
|
|
|
|
18
|
next; |
642
|
|
|
|
|
|
|
} |
643
|
105
|
|
|
|
|
271
|
next TAG; # wrong group |
644
|
|
|
|
|
|
|
} |
645
|
|
|
|
|
|
|
# handle family 1 groups specially |
646
|
36848
|
100
|
66
|
|
|
213811
|
if ($grp[0] eq 'EXIF' or $grp[0] eq 'SonyIDC' or $wgAll) { |
|
|
100
|
100
|
|
|
|
|
|
|
100
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
647
|
1581
|
100
|
100
|
|
|
5460
|
unless ($ifdName and $lcWant eq lc $ifdName) { |
648
|
1141
|
100
|
100
|
|
|
4938
|
next TAG unless $wgAll and not $fam and $allFam0{$lcWant}; |
|
|
|
100
|
|
|
|
|
649
|
7
|
100
|
|
|
|
29
|
$writeGroup = $allFam0{$lcWant} unless $writeGroup; |
650
|
7
|
|
|
|
|
15
|
next; |
651
|
|
|
|
|
|
|
} |
652
|
440
|
100
|
100
|
|
|
1183
|
next TAG if $wgAll and $allFam0{$lcWant} and $fam; |
|
|
|
100
|
|
|
|
|
653
|
|
|
|
|
|
|
# can't yet write PreviewIFD tags (except for image) |
654
|
438
|
50
|
|
|
|
1154
|
$lcWant eq 'PreviewIFD' and ++$foundMatch, next TAG; |
655
|
438
|
|
|
|
|
984
|
$writeGroup = $ifdName; # write to the specified IFD |
656
|
|
|
|
|
|
|
} elsif ($grp[0] eq 'QuickTime') { |
657
|
1558
|
100
|
|
|
|
3703
|
if ($grp[1] eq 'Track#') { |
658
|
16
|
100
|
66
|
|
|
127
|
next TAG unless $movGroup and $lcWant eq lc($movGroup); |
659
|
1
|
|
|
|
|
3
|
$writeGroup = $movGroup; |
660
|
|
|
|
|
|
|
} else { |
661
|
1542
|
|
|
|
|
4142
|
my $grp = $$tagInfo{Table}{WRITE_GROUP}; |
662
|
1542
|
100
|
100
|
|
|
7288
|
next TAG unless $grp and $lcWant eq lc $grp; |
663
|
28
|
|
|
|
|
71
|
$writeGroup = $grp; |
664
|
|
|
|
|
|
|
} |
665
|
|
|
|
|
|
|
} elsif ($grp[0] eq 'MIE') { |
666
|
746
|
100
|
66
|
|
|
3595
|
next TAG unless $mieGroup and $lcWant eq lc($mieGroup); |
667
|
2
|
|
|
|
|
9
|
$writeGroup = $mieGroup; # write to specific MIE group |
668
|
|
|
|
|
|
|
# set specific write group with document number if specified |
669
|
2
|
0
|
33
|
|
|
15
|
if ($writeGroup =~ /^MIE\d+$/ and $$tagInfo{Table}{WRITE_GROUP}) { |
670
|
0
|
|
|
|
|
0
|
$writeGroup = $$tagInfo{Table}{WRITE_GROUP}; |
671
|
0
|
|
|
|
|
0
|
$writeGroup =~ s/^MIE/$mieGroup/; |
672
|
|
|
|
|
|
|
} |
673
|
|
|
|
|
|
|
} elsif (not $$tagInfo{AllowGroup} or $lcWant !~ /^$$tagInfo{AllowGroup}$/i) { |
674
|
|
|
|
|
|
|
# allow group1 name to be specified |
675
|
32962
|
100
|
|
|
|
105188
|
next TAG unless $lcWant eq lc $grp[1]; |
676
|
|
|
|
|
|
|
} |
677
|
|
|
|
|
|
|
} |
678
|
13750
|
100
|
66
|
|
|
70063
|
$writeGroup or $writeGroup = ($$tagInfo{WriteGroup} || $$tagInfo{Table}{WRITE_GROUP} || $grp[0]); |
679
|
13750
|
|
|
|
|
25492
|
$priority = $hiPri; # highest priority since group was specified |
680
|
|
|
|
|
|
|
} |
681
|
33961
|
|
|
|
|
48392
|
++$foundMatch; |
682
|
|
|
|
|
|
|
# must do a dummy call to the write proc to autoload write package |
683
|
|
|
|
|
|
|
# before checking Writable flag |
684
|
33961
|
|
|
|
|
54004
|
my $table = $$tagInfo{Table}; |
685
|
33961
|
|
|
|
|
66623
|
my $writeProc = $$table{WRITE_PROC}; |
686
|
|
|
|
|
|
|
# load source table if this was a user-defined table |
687
|
33961
|
100
|
|
|
|
76441
|
if ($$table{SRC_TABLE}) { |
688
|
9
|
|
|
|
|
36
|
my $src = GetTagTable($$table{SRC_TABLE}); |
689
|
9
|
50
|
|
|
|
35
|
$writeProc = $$src{WRITE_PROC} unless $writeProc; |
690
|
|
|
|
|
|
|
} |
691
|
|
|
|
|
|
|
{ |
692
|
59
|
|
|
59
|
|
565
|
no strict 'refs'; |
|
59
|
|
|
|
|
152
|
|
|
59
|
|
|
|
|
761589
|
|
|
33961
|
|
|
|
|
46296
|
|
693
|
33961
|
100
|
66
|
|
|
110476
|
next unless $writeProc and &$writeProc(); |
694
|
|
|
|
|
|
|
} |
695
|
|
|
|
|
|
|
# must still check writable flags in case of UserDefined tags |
696
|
33961
|
|
|
|
|
74637
|
my $writable = $$tagInfo{Writable}; |
697
|
|
|
|
|
|
|
next unless $writable or ($$table{WRITABLE} and |
698
|
33961
|
50
|
66
|
|
|
146149
|
not defined $writable and not $$tagInfo{SubDirectory}); |
|
|
|
66
|
|
|
|
|
|
|
|
66
|
|
|
|
|
699
|
|
|
|
|
|
|
# set specific write group (if we didn't already) |
700
|
33960
|
100
|
66
|
|
|
87237
|
if (not $writeGroup or ($translateWriteGroup{$writeGroup} and |
|
|
|
66
|
|
|
|
|
|
|
|
66
|
|
|
|
|
701
|
|
|
|
|
|
|
(not $$tagInfo{WriteGroup} or $$tagInfo{WriteGroup} ne 'All'))) |
702
|
|
|
|
|
|
|
{ |
703
|
|
|
|
|
|
|
# use default write group |
704
|
20287
|
|
100
|
|
|
64514
|
$writeGroup = $$tagInfo{WriteGroup} || $$tagInfo{Table}{WRITE_GROUP}; |
705
|
|
|
|
|
|
|
# use group 0 name if no WriteGroup specified |
706
|
20287
|
|
|
|
|
54710
|
my $group0 = $self->GetGroup($tagInfo, 0); |
707
|
20287
|
100
|
|
|
|
46961
|
$writeGroup or $writeGroup = $group0; |
708
|
|
|
|
|
|
|
# get priority for this group |
709
|
20287
|
100
|
|
|
|
38056
|
unless ($priority) { |
710
|
20210
|
100
|
100
|
|
|
50272
|
if ($$tagInfo{Avoid} and $$tagInfo{WriteAlso}) { |
711
|
22
|
|
|
|
|
50
|
$priority = 0; |
712
|
|
|
|
|
|
|
} else { |
713
|
20188
|
|
|
|
|
42978
|
$priority = $$self{WRITE_PRIORITY}{lc($writeGroup)}; |
714
|
20188
|
100
|
|
|
|
38015
|
unless ($priority) { |
715
|
3568
|
|
100
|
|
|
11422
|
$priority = $$self{WRITE_PRIORITY}{lc($group0)} || 0; |
716
|
|
|
|
|
|
|
} |
717
|
|
|
|
|
|
|
} |
718
|
|
|
|
|
|
|
} |
719
|
|
|
|
|
|
|
# adjust priority based on Preferred level for this tag |
720
|
20287
|
100
|
|
|
|
39343
|
$priority += $prfTag if $prfTag; |
721
|
|
|
|
|
|
|
} |
722
|
|
|
|
|
|
|
# don't write tag if protected |
723
|
33960
|
|
|
|
|
57962
|
my $prot = $$tagInfo{Protected}; |
724
|
33960
|
100
|
100
|
|
|
70500
|
$prot = 1 if $noFlat and defined $$tagInfo{Flat}; |
725
|
33960
|
100
|
|
|
|
59858
|
if ($prot) { |
726
|
2341
|
|
|
|
|
4791
|
$prot &= ~$protected; |
727
|
2341
|
100
|
|
|
|
5205
|
if ($prot) { |
728
|
1208
|
|
|
|
|
4590
|
my %lkup = ( 1=>'unsafe', 2=>'protected', 3=>'unsafe and protected'); |
729
|
1208
|
|
|
|
|
2500
|
$wasProtected = $lkup{$prot}; |
730
|
1208
|
100
|
|
|
|
2791
|
if ($verbose > 1) { |
731
|
1
|
|
|
|
|
7
|
my $wgrp1 = $self->GetWriteGroup1($tagInfo, $writeGroup); |
732
|
1
|
|
|
|
|
9
|
print $out "Sorry, $wgrp1:$tag is $wasProtected for writing\n"; |
733
|
|
|
|
|
|
|
} |
734
|
1208
|
|
|
|
|
3574
|
next; |
735
|
|
|
|
|
|
|
} |
736
|
|
|
|
|
|
|
} |
737
|
|
|
|
|
|
|
# set priority for this tag |
738
|
32752
|
|
|
|
|
120005
|
$tagPriority{$tagInfo} = $priority; |
739
|
|
|
|
|
|
|
# keep track of highest priority QuickTime tag |
740
|
|
|
|
|
|
|
$highestQT{$lcTag} = $priority if $$table{GROUPS}{0} eq 'QuickTime' and |
741
|
32752
|
100
|
100
|
|
|
100604
|
(not defined $highestQT{$lcTag} or $highestQT{$lcTag} < $priority); |
|
|
|
100
|
|
|
|
|
742
|
32752
|
100
|
|
|
|
85806
|
if ($priority > $highestPriority{$lcTag}) { |
|
|
100
|
|
|
|
|
|
743
|
10388
|
|
|
|
|
17130
|
$highestPriority{$lcTag} = $priority; |
744
|
10388
|
|
|
|
|
38746
|
$preferred{$lcTag} = { $tagInfo => 1 }; |
745
|
10388
|
100
|
|
|
|
32850
|
$avoid{$lcTag} = $$tagInfo{Avoid} ? 1 : 0; |
746
|
|
|
|
|
|
|
} elsif ($priority == $highestPriority{$lcTag}) { |
747
|
|
|
|
|
|
|
# create all tags with highest priority |
748
|
13490
|
|
|
|
|
31366
|
$preferred{$lcTag}{$tagInfo} = 1; |
749
|
13490
|
100
|
|
|
|
32210
|
++$avoid{$lcTag} if $$tagInfo{Avoid}; |
750
|
|
|
|
|
|
|
} |
751
|
32752
|
100
|
|
|
|
62360
|
if ($$tagInfo{WriteAlso}) { |
752
|
|
|
|
|
|
|
# store WriteAlso tags separately so we can set them first |
753
|
111
|
|
|
|
|
411
|
push @writeAlsoList, $tagInfo; |
754
|
|
|
|
|
|
|
} else { |
755
|
32641
|
|
|
|
|
58092
|
push @tagInfoList, $tagInfo; |
756
|
|
|
|
|
|
|
} |
757
|
|
|
|
|
|
|
# special case to allow override of XMP WriteGroup |
758
|
32752
|
100
|
|
|
|
65104
|
if ($writeGroup eq 'XMP') { |
759
|
5490
|
|
33
|
|
|
19385
|
my $wg = $$tagInfo{WriteGroup} || $$table{WRITE_GROUP}; |
760
|
5490
|
50
|
|
|
|
12864
|
$writeGroup = $wg if $wg; |
761
|
|
|
|
|
|
|
} |
762
|
32752
|
|
|
|
|
106255
|
$writeGroup{$tagInfo} = $writeGroup; |
763
|
|
|
|
|
|
|
} |
764
|
|
|
|
|
|
|
# sort tag info list in reverse order of priority (highest number last) |
765
|
|
|
|
|
|
|
# so we get the highest priority error message in the end |
766
|
4224
|
|
|
|
|
14143
|
@tagInfoList = sort { $tagPriority{$a} <=> $tagPriority{$b} } @tagInfoList; |
|
54489
|
|
|
|
|
106498
|
|
767
|
|
|
|
|
|
|
# must write any tags which also write other tags first |
768
|
4224
|
100
|
|
|
|
11800
|
unshift @tagInfoList, @writeAlsoList if @writeAlsoList; |
769
|
|
|
|
|
|
|
|
770
|
|
|
|
|
|
|
# check priorities for each set of tags we are writing |
771
|
4224
|
|
|
|
|
7311
|
my $lcTag; |
772
|
4224
|
|
|
|
|
13938
|
foreach $lcTag (keys %preferred) { |
773
|
|
|
|
|
|
|
# don't create tags with priority 0 if group priorities are set |
774
|
9535
|
100
|
66
|
|
|
49025
|
if ($preferred{$lcTag} and $highestPriority{$lcTag} == 0 and |
|
|
|
66
|
|
|
|
|
775
|
9
|
|
|
|
|
71
|
%{$$self{WRITE_PRIORITY}}) |
776
|
|
|
|
|
|
|
{ |
777
|
9
|
|
|
|
|
36
|
delete $preferred{$lcTag} |
778
|
|
|
|
|
|
|
} |
779
|
|
|
|
|
|
|
# avoid creating tags with 'Avoid' flag set if there are other alternatives |
780
|
9535
|
50
|
66
|
|
|
26622
|
if ($avoid{$lcTag} and $preferred{$lcTag}) { |
781
|
1350
|
100
|
|
|
|
2611
|
if ($avoid{$lcTag} < scalar(keys %{$preferred{$lcTag}})) { |
|
1350
|
100
|
|
|
|
9526
|
|
782
|
|
|
|
|
|
|
# just remove the 'Avoid' tags since there are other preferred tags |
783
|
1236
|
|
|
|
|
3015
|
foreach $tagInfo (@tagInfoList) { |
784
|
4561111
|
100
|
|
|
|
9466497
|
next unless $lcTag eq lc $$tagInfo{Name}; |
785
|
5803
|
100
|
|
|
|
18015
|
delete $preferred{$lcTag}{$tagInfo} if $$tagInfo{Avoid}; |
786
|
|
|
|
|
|
|
} |
787
|
|
|
|
|
|
|
} elsif ($highestPriority{$lcTag} < 1000) { |
788
|
|
|
|
|
|
|
# look for another priority tag to create instead |
789
|
29
|
|
|
|
|
82
|
my $nextHighest = 0; |
790
|
29
|
|
|
|
|
72
|
my @nextBestTags; |
791
|
29
|
|
|
|
|
86
|
foreach $tagInfo (@tagInfoList) { |
792
|
10962
|
100
|
|
|
|
22661
|
next unless $lcTag eq lc $$tagInfo{Name}; |
793
|
102
|
100
|
|
|
|
274
|
my $priority = $tagPriority{$tagInfo} or next; |
794
|
101
|
100
|
|
|
|
293
|
next if $priority == $highestPriority{$lcTag}; |
795
|
71
|
50
|
|
|
|
166
|
next if $priority < $nextHighest; |
796
|
71
|
|
|
|
|
122
|
my $permanent = $$tagInfo{Permanent}; |
797
|
71
|
50
|
|
|
|
240
|
$permanent = $$tagInfo{Table}{PERMANENT} unless defined $permanent; |
798
|
71
|
100
|
66
|
|
|
268
|
next if $$tagInfo{Avoid} or $permanent; |
799
|
67
|
100
|
|
|
|
245
|
next if $writeGroup{$tagInfo} eq 'MakerNotes'; |
800
|
23
|
100
|
|
|
|
94
|
if ($nextHighest < $priority) { |
801
|
18
|
|
|
|
|
41
|
$nextHighest = $priority; |
802
|
18
|
|
|
|
|
54
|
undef @nextBestTags; |
803
|
|
|
|
|
|
|
} |
804
|
23
|
|
|
|
|
58
|
push @nextBestTags, $tagInfo; |
805
|
|
|
|
|
|
|
} |
806
|
29
|
100
|
|
|
|
172
|
if (@nextBestTags) { |
807
|
|
|
|
|
|
|
# change our preferred tags to the next best tags |
808
|
13
|
|
|
|
|
43
|
delete $preferred{$lcTag}; |
809
|
13
|
|
|
|
|
46
|
foreach $tagInfo (@nextBestTags) { |
810
|
14
|
|
|
|
|
92
|
$preferred{$lcTag}{$tagInfo} = 1; |
811
|
|
|
|
|
|
|
} |
812
|
|
|
|
|
|
|
} |
813
|
|
|
|
|
|
|
} |
814
|
|
|
|
|
|
|
} |
815
|
|
|
|
|
|
|
} |
816
|
|
|
|
|
|
|
# |
817
|
|
|
|
|
|
|
# generate new value hash for each tag |
818
|
|
|
|
|
|
|
# |
819
|
4224
|
|
|
|
|
8708
|
my ($prioritySet, $createGroups, %alsoWrote); |
820
|
|
|
|
|
|
|
|
821
|
4224
|
|
|
|
|
9143
|
delete $$self{CHECK_WARN}; # reset CHECK_PROC warnings |
822
|
|
|
|
|
|
|
|
823
|
|
|
|
|
|
|
# loop through all valid tags to find the one(s) to write |
824
|
4224
|
|
|
|
|
7955
|
foreach $tagInfo (@tagInfoList) { |
825
|
32740
|
100
|
|
|
|
98508
|
next if $alsoWrote{$tagInfo}; # don't rewrite tags we already wrote |
826
|
|
|
|
|
|
|
# only process List or non-List tags if specified |
827
|
32731
|
100
|
100
|
|
|
80693
|
next if defined $listOnly and ($listOnly xor $$tagInfo{List}); |
|
|
|
100
|
|
|
|
|
828
|
32510
|
|
|
|
|
43983
|
my $noConv; |
829
|
32510
|
|
|
|
|
95486
|
my $writeGroup = $writeGroup{$tagInfo}; |
830
|
32510
|
|
|
|
|
69436
|
my $permanent = $$tagInfo{Permanent}; |
831
|
32510
|
100
|
|
|
|
110307
|
$permanent = $$tagInfo{Table}{PERMANENT} unless defined $permanent; |
832
|
32510
|
100
|
100
|
|
|
93982
|
$writeGroup eq 'MakerNotes' and $permanent = 1 unless defined $permanent; |
833
|
32510
|
|
|
|
|
90933
|
my $wgrp1 = $self->GetWriteGroup1($tagInfo, $writeGroup); |
834
|
32510
|
|
|
|
|
77290
|
$tag = $$tagInfo{Name}; # get tag name for warnings |
835
|
32510
|
|
|
|
|
64222
|
my $lcTag = lc $tag; |
836
|
32510
|
|
100
|
|
|
97072
|
my $pref = $preferred{$lcTag} || { }; |
837
|
|
|
|
|
|
|
# don't write Avoid-ed tags with side effect unless preferred |
838
|
32510
|
100
|
100
|
|
|
120420
|
next if not $$pref{$tagInfo} and $$tagInfo{Avoid} and $$tagInfo{WriteAlso}; |
|
|
|
100
|
|
|
|
|
839
|
32488
|
|
|
|
|
56167
|
my $shift = $options{Shift}; |
840
|
32488
|
|
|
|
|
50040
|
my $addValue = $options{AddValue}; |
841
|
32488
|
100
|
|
|
|
69499
|
if (defined $shift) { |
842
|
|
|
|
|
|
|
# (can't currently shift list-type tags) |
843
|
164
|
|
|
|
|
287
|
my $shiftable; |
844
|
164
|
50
|
|
|
|
435
|
if ($$tagInfo{List}) { |
845
|
0
|
|
|
|
|
0
|
$shiftable = ''; # can add/delete but not shift |
846
|
|
|
|
|
|
|
} else { |
847
|
164
|
|
|
|
|
325
|
$shiftable = $$tagInfo{Shift}; |
848
|
164
|
100
|
|
|
|
423
|
unless ($shift) { |
849
|
|
|
|
|
|
|
# set shift according to AddValue/DelValue |
850
|
24
|
50
|
|
|
|
81
|
$shift = 1 if $addValue; |
851
|
|
|
|
|
|
|
# can shift a date/time with -=, but this is |
852
|
|
|
|
|
|
|
# a conditional delete operation for other tags |
853
|
24
|
0
|
33
|
|
|
86
|
$shift = -1 if $options{DelValue} and defined $shiftable and $shiftable eq 'Time'; |
|
|
|
33
|
|
|
|
|
854
|
|
|
|
|
|
|
} |
855
|
164
|
50
|
33
|
|
|
976
|
if ($shift and (not defined $value or not length $value)) { |
|
|
|
33
|
|
|
|
|
856
|
|
|
|
|
|
|
# (now allow -= to be used for shiftable tag - v8.05) |
857
|
|
|
|
|
|
|
#$err = "No value for time shift of $wgrp1:$tag"; |
858
|
|
|
|
|
|
|
#$verbose > 2 and print $out "$err\n"; |
859
|
|
|
|
|
|
|
#next; |
860
|
0
|
|
|
|
|
0
|
undef $shift; |
861
|
|
|
|
|
|
|
} |
862
|
|
|
|
|
|
|
} |
863
|
|
|
|
|
|
|
# can't shift List-type tag |
864
|
164
|
0
|
66
|
|
|
544
|
if ((defined $shiftable and not $shiftable) and |
|
|
|
0
|
|
|
|
|
|
|
|
33
|
|
|
|
|
865
|
|
|
|
|
|
|
# and don't try to conditionally delete if Shift is "0" |
866
|
|
|
|
|
|
|
($shift or ($shiftable eq '0' and $options{DelValue}))) |
867
|
|
|
|
|
|
|
{ |
868
|
0
|
|
|
|
|
0
|
$err = "$wgrp1:$tag is not shiftable"; |
869
|
0
|
0
|
|
|
|
0
|
$verbose and print $out "$err\n"; |
870
|
0
|
|
|
|
|
0
|
next; |
871
|
|
|
|
|
|
|
} |
872
|
|
|
|
|
|
|
} |
873
|
32488
|
|
|
|
|
52107
|
my $val = $value; |
874
|
32488
|
100
|
33
|
|
|
85286
|
if (defined $val) { |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
875
|
|
|
|
|
|
|
# check to make sure this is a List or Shift tag if adding |
876
|
21666
|
100
|
100
|
|
|
50590
|
if ($addValue and not ($shift or $$tagInfo{List})) { |
|
|
|
100
|
|
|
|
|
877
|
9
|
50
|
|
|
|
37
|
if ($addValue eq '2') { |
878
|
0
|
|
|
|
|
0
|
undef $addValue; # quietly reset this option |
879
|
|
|
|
|
|
|
} else { |
880
|
9
|
|
|
|
|
39
|
$err = "Can't add $wgrp1:$tag (not a List type)"; |
881
|
9
|
50
|
|
|
|
31
|
$verbose > 2 and print $out "$err\n"; |
882
|
9
|
|
|
|
|
30
|
next; |
883
|
|
|
|
|
|
|
} |
884
|
|
|
|
|
|
|
} |
885
|
21657
|
100
|
66
|
|
|
101552
|
if ($shift) { |
|
|
100
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
886
|
164
|
100
|
66
|
|
|
695
|
if ($$tagInfo{Shift} and $$tagInfo{Shift} eq 'Time') { |
|
|
100
|
|
|
|
|
|
887
|
|
|
|
|
|
|
# add '+' or '-' prefix to indicate shift direction |
888
|
47
|
100
|
|
|
|
139
|
$val = ($shift > 0 ? '+' : '-') . $val; |
889
|
|
|
|
|
|
|
# check the shift for validity |
890
|
47
|
|
|
|
|
2353
|
require 'Image/ExifTool/Shift.pl'; |
891
|
47
|
|
|
|
|
183
|
my $err2 = CheckShift($$tagInfo{Shift}, $val); |
892
|
47
|
50
|
|
|
|
143
|
if ($err2) { |
893
|
0
|
|
|
|
|
0
|
$err = "$err2 for $wgrp1:$tag"; |
894
|
0
|
0
|
|
|
|
0
|
$verbose > 2 and print $out "$err\n"; |
895
|
0
|
|
|
|
|
0
|
next; |
896
|
|
|
|
|
|
|
} |
897
|
|
|
|
|
|
|
} elsif (IsFloat($val)) { |
898
|
113
|
|
|
|
|
310
|
$val *= $shift; |
899
|
|
|
|
|
|
|
} else { |
900
|
4
|
|
|
|
|
20
|
$err = "Shift value for $wgrp1:$tag is not a number"; |
901
|
4
|
50
|
|
|
|
15
|
$verbose > 2 and print $out "$err\n"; |
902
|
4
|
|
|
|
|
17
|
next; |
903
|
|
|
|
|
|
|
} |
904
|
160
|
|
|
|
|
328
|
$noConv = 1; # no conversions if shifting tag |
905
|
|
|
|
|
|
|
} elsif (not length $val and $options{DelValue}) { |
906
|
35
|
|
|
|
|
79
|
$noConv = 1; # no conversions for deleting empty value |
907
|
|
|
|
|
|
|
} elsif (ref $val eq 'HASH' and not $$tagInfo{Struct}) { |
908
|
2
|
|
|
|
|
10
|
$err = "Can't write a structure to $wgrp1:$tag"; |
909
|
2
|
50
|
|
|
|
9
|
$verbose > 2 and print $out "$err\n"; |
910
|
2
|
|
|
|
|
8
|
next; |
911
|
|
|
|
|
|
|
} |
912
|
|
|
|
|
|
|
} elsif ($permanent) { |
913
|
6784
|
100
|
|
|
|
14513
|
return 0 if $options{IgnorePermanent}; |
914
|
|
|
|
|
|
|
# can't delete permanent tags, so set them to DelValue or empty string instead |
915
|
6780
|
100
|
|
|
|
13492
|
if (defined $$tagInfo{DelValue}) { |
916
|
33
|
|
|
|
|
64
|
$val = $$tagInfo{DelValue}; |
917
|
33
|
|
|
|
|
70
|
$noConv = 1; # DelValue is the raw value, so no conversion necessary |
918
|
|
|
|
|
|
|
} else { |
919
|
6747
|
|
|
|
|
10206
|
$val = ''; |
920
|
|
|
|
|
|
|
} |
921
|
|
|
|
|
|
|
} elsif ($addValue or $options{DelValue}) { |
922
|
0
|
|
|
|
|
0
|
$err = "No value to add or delete in $wgrp1:$tag"; |
923
|
0
|
0
|
|
|
|
0
|
$verbose > 2 and print $out "$err\n"; |
924
|
0
|
|
|
|
|
0
|
next; |
925
|
|
|
|
|
|
|
} else { |
926
|
4038
|
100
|
|
|
|
9740
|
if ($$tagInfo{DelCheck}) { |
927
|
|
|
|
|
|
|
#### eval DelCheck ($self, $tagInfo, $wantGroup) |
928
|
6
|
|
|
|
|
679
|
my $err2 = eval $$tagInfo{DelCheck}; |
929
|
6
|
50
|
|
|
|
46
|
$@ and warn($@), $err2 = 'Error evaluating DelCheck'; |
930
|
6
|
50
|
|
|
|
24
|
if (defined $err2) { |
931
|
|
|
|
|
|
|
# (allow other tags to be set using DelCheck as a hook) |
932
|
6
|
100
|
|
|
|
111
|
$err2 or goto WriteAlso; # GOTO! |
933
|
3
|
50
|
|
|
|
21
|
$err2 .= ' for' unless $err2 =~ /delete$/; |
934
|
3
|
|
|
|
|
29
|
$err = "$err2 $wgrp1:$tag"; |
935
|
3
|
50
|
|
|
|
16
|
$verbose > 2 and print $out "$err\n"; |
936
|
3
|
|
|
|
|
13
|
next; |
937
|
|
|
|
|
|
|
} |
938
|
|
|
|
|
|
|
} |
939
|
|
|
|
|
|
|
# set group delete flag if this tag represents an entire group |
940
|
4032
|
100
|
66
|
|
|
10378
|
if ($$tagInfo{DelGroup} and not $options{DelValue}) { |
941
|
3
|
|
|
|
|
18
|
my @del = ( $tag ); |
942
|
3
|
|
|
|
|
10
|
$$self{DEL_GROUP}{$tag} = 1; |
943
|
|
|
|
|
|
|
# delete extra groups if necessary |
944
|
3
|
50
|
|
|
|
12
|
if ($delMore{$tag}) { |
945
|
0
|
|
|
|
|
0
|
$$self{DEL_GROUP}{$_} = 1, push(@del,$_) foreach @{$delMore{$tag}}; |
|
0
|
|
|
|
|
0
|
|
946
|
|
|
|
|
|
|
} |
947
|
|
|
|
|
|
|
# remove all of this group from previous new values |
948
|
3
|
|
|
|
|
15
|
$self->RemoveNewValuesForGroup($tag); |
949
|
3
|
50
|
|
|
|
9
|
$verbose and print $out " Deleting tags in: @del\n"; |
950
|
3
|
|
|
|
|
6
|
++$numSet; |
951
|
3
|
|
|
|
|
12
|
next; |
952
|
|
|
|
|
|
|
} |
953
|
4029
|
|
|
|
|
6510
|
$noConv = 1; # value is not defined, so don't do conversion |
954
|
|
|
|
|
|
|
} |
955
|
|
|
|
|
|
|
# apply inverse PrintConv and ValueConv conversions |
956
|
|
|
|
|
|
|
# save ValueConv setting for use in ConvInv() |
957
|
32460
|
100
|
|
|
|
62154
|
unless ($noConv) { |
958
|
|
|
|
|
|
|
# set default conversion type used by ConvInv() and CHECK_PROC routines |
959
|
28203
|
|
|
|
|
60585
|
$$self{ConvType} = $convType; |
960
|
28203
|
|
|
|
|
39764
|
my $e; |
961
|
28203
|
|
|
|
|
85055
|
($val,$e) = $self->ConvInv($val,$tagInfo,$tag,$wgrp1,$$self{ConvType},$wantGroup); |
962
|
28203
|
100
|
|
|
|
68528
|
if (defined $e) { |
963
|
|
|
|
|
|
|
# empty error string causes error to be ignored without setting the value |
964
|
8476
|
100
|
|
|
|
20414
|
$e or goto WriteAlso; # GOTO! |
965
|
8459
|
|
|
|
|
16274
|
$err = $e; |
966
|
|
|
|
|
|
|
} |
967
|
|
|
|
|
|
|
} |
968
|
32443
|
100
|
100
|
|
|
92393
|
if (not defined $val and defined $value) { |
969
|
|
|
|
|
|
|
# if value conversion failed, we must still add a NEW_VALUE |
970
|
|
|
|
|
|
|
# entry for this tag it it was a DelValue |
971
|
2805
|
50
|
|
|
|
10944
|
next unless $options{DelValue}; |
972
|
0
|
|
|
|
|
0
|
$val = 'xxx never delete xxx'; |
973
|
|
|
|
|
|
|
} |
974
|
29638
|
100
|
|
|
|
85823
|
$$self{NEW_VALUE} or $$self{NEW_VALUE} = { }; |
975
|
29638
|
100
|
|
|
|
68288
|
if ($options{Replace}) { |
976
|
|
|
|
|
|
|
# delete the previous new value |
977
|
14215
|
|
|
|
|
64479
|
$self->GetNewValueHash($tagInfo, $writeGroup, 'delete', $options{ProtectSaved}); |
978
|
|
|
|
|
|
|
# also delete related tag previous new values |
979
|
14215
|
100
|
|
|
|
40211
|
if ($$tagInfo{WriteAlso}) { |
980
|
25
|
|
|
|
|
132
|
$$self{INDENT2} = '+'; |
981
|
25
|
|
|
|
|
116
|
my ($wgrp, $wtag); |
982
|
25
|
100
|
66
|
|
|
185
|
if ($$tagInfo{WriteGroup} and $$tagInfo{WriteGroup} eq 'All' and $writeGroup) { |
|
|
|
66
|
|
|
|
|
983
|
6
|
|
|
|
|
20
|
$wgrp = $writeGroup . ':'; |
984
|
|
|
|
|
|
|
} else { |
985
|
19
|
|
|
|
|
51
|
$wgrp = ''; |
986
|
|
|
|
|
|
|
} |
987
|
25
|
|
|
|
|
58
|
foreach $wtag (sort keys %{$$tagInfo{WriteAlso}}) { |
|
25
|
|
|
|
|
203
|
|
988
|
91
|
|
|
|
|
448
|
my ($n,$e) = $self->SetNewValue($wgrp . $wtag, undef, Replace=>2); |
989
|
91
|
|
|
|
|
262
|
$numSet += $n; |
990
|
|
|
|
|
|
|
} |
991
|
25
|
|
|
|
|
125
|
$$self{INDENT2} = ''; |
992
|
|
|
|
|
|
|
} |
993
|
14215
|
100
|
|
|
|
35355
|
$options{Replace} == 2 and ++$numSet, next; |
994
|
|
|
|
|
|
|
} |
995
|
|
|
|
|
|
|
|
996
|
29364
|
100
|
33
|
|
|
72561
|
if (defined $val) { |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
997
|
|
|
|
|
|
|
# we are editing this tag, so create a NEW_VALUE hash entry |
998
|
|
|
|
|
|
|
my $nvHash = $self->GetNewValueHash($tagInfo, $writeGroup, 'create', |
999
|
19885
|
|
66
|
|
|
81389
|
$options{ProtectSaved}, ($options{DelValue} and not $shift)); |
1000
|
|
|
|
|
|
|
# ignore new values protected with ProtectSaved |
1001
|
19885
|
50
|
|
|
|
51181
|
$nvHash or ++$numSet, next; # (increment $numSet to avoid warning) |
1002
|
19885
|
100
|
100
|
|
|
51867
|
$$nvHash{NoReplace} = 1 if $$tagInfo{List} and not $options{Replace}; |
1003
|
19885
|
|
|
|
|
41108
|
$$nvHash{WantGroup} = $wantGroup; |
1004
|
19885
|
100
|
|
|
|
37579
|
$$nvHash{EditOnly} = 1 if $editOnly; |
1005
|
|
|
|
|
|
|
# save maker note information if writing maker notes |
1006
|
19885
|
100
|
|
|
|
44640
|
if ($$tagInfo{MakerNotes}) { |
1007
|
22
|
|
|
|
|
123
|
$$nvHash{MAKER_NOTE_FIXUP} = $$self{MAKER_NOTE_FIXUP}; |
1008
|
|
|
|
|
|
|
} |
1009
|
19885
|
100
|
100
|
|
|
100328
|
if ($createOnly) { # create only (never edit) |
|
|
100
|
100
|
|
|
|
|
1010
|
|
|
|
|
|
|
# empty item in DelValue list to never edit existing value |
1011
|
49
|
|
|
|
|
145
|
$$nvHash{DelValue} = [ '' ]; |
1012
|
49
|
|
|
|
|
118
|
$$nvHash{CreateOnly} = 1; |
1013
|
|
|
|
|
|
|
} elsif ($options{DelValue} or $addValue or $shift) { |
1014
|
|
|
|
|
|
|
# flag any AddValue or DelValue by creating the DelValue list |
1015
|
227
|
100
|
|
|
|
846
|
$$nvHash{DelValue} or $$nvHash{DelValue} = [ ]; |
1016
|
227
|
100
|
|
|
|
614
|
if ($shift) { |
|
|
100
|
|
|
|
|
|
1017
|
|
|
|
|
|
|
# add shift value to list |
1018
|
160
|
|
|
|
|
475
|
$$nvHash{Shift} = $val; |
1019
|
|
|
|
|
|
|
} elsif ($options{DelValue}) { |
1020
|
|
|
|
|
|
|
# don't create if we are replacing a specific value |
1021
|
54
|
100
|
100
|
|
|
220
|
$$nvHash{IsCreating} = 0 unless $val eq '' or $$tagInfo{List}; |
1022
|
|
|
|
|
|
|
# add delete value to list |
1023
|
54
|
100
|
|
|
|
87
|
push @{$$nvHash{DelValue}}, ref $val eq 'ARRAY' ? @$val : $val; |
|
54
|
|
|
|
|
231
|
|
1024
|
54
|
50
|
|
|
|
389
|
if ($verbose > 1) { |
1025
|
0
|
0
|
|
|
|
0
|
my $verb = $permanent ? 'Replacing' : 'Deleting'; |
1026
|
0
|
0
|
|
|
|
0
|
my $fromList = $$tagInfo{List} ? ' from list' : ''; |
1027
|
0
|
0
|
|
|
|
0
|
my @vals = (ref $val eq 'ARRAY' ? @$val : $val); |
1028
|
0
|
|
|
|
|
0
|
foreach (@vals) { |
1029
|
0
|
0
|
|
|
|
0
|
if (ref $_ eq 'HASH') { |
1030
|
0
|
|
|
|
|
0
|
require 'Image/ExifTool/XMPStruct.pl'; |
1031
|
0
|
|
|
|
|
0
|
$_ = Image::ExifTool::XMP::SerializeStruct($_); |
1032
|
|
|
|
|
|
|
} |
1033
|
0
|
|
|
|
|
0
|
print $out "$$self{INDENT2}$verb $wgrp1:$tag$fromList if value is '${_}'\n"; |
1034
|
|
|
|
|
|
|
} |
1035
|
|
|
|
|
|
|
} |
1036
|
|
|
|
|
|
|
} |
1037
|
|
|
|
|
|
|
} |
1038
|
|
|
|
|
|
|
# set priority flag to add only the high priority info |
1039
|
|
|
|
|
|
|
# (will only create the priority tag if it doesn't exist, |
1040
|
|
|
|
|
|
|
# others get changed only if they already exist) |
1041
|
19885
|
100
|
|
|
|
57911
|
my $prf = defined $$tagInfo{Preferred} ? $$tagInfo{Preferred} : $$tagInfo{Table}{PREFERRED}; |
1042
|
|
|
|
|
|
|
# hack to prefer only a single tag in the QuickTime group |
1043
|
19885
|
100
|
|
|
|
56350
|
if ($$tagInfo{Table}{GROUPS}{0} eq 'QuickTime') { |
1044
|
660
|
100
|
|
|
|
2873
|
$prf = 0 if $tagPriority{$tagInfo} < $highestQT{$lcTag}; |
1045
|
|
|
|
|
|
|
} |
1046
|
19885
|
100
|
100
|
|
|
67335
|
if ($$pref{$tagInfo} or $prf) { |
1047
|
9209
|
100
|
100
|
|
|
47006
|
if ($permanent or $shift) { |
|
|
100
|
100
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
1048
|
|
|
|
|
|
|
# don't create permanent or Shift-ed tag but define IsCreating |
1049
|
|
|
|
|
|
|
# so we know that it is the preferred tag |
1050
|
5447
|
|
|
|
|
11803
|
$$nvHash{IsCreating} = 0; |
1051
|
|
|
|
|
|
|
} elsif (($$tagInfo{List} and not $options{DelValue}) or |
1052
|
|
|
|
|
|
|
not ($$nvHash{DelValue} and @{$$nvHash{DelValue}}) or |
1053
|
|
|
|
|
|
|
# also create tag if any DelValue value is empty ('') |
1054
|
58
|
|
|
|
|
436
|
grep(/^$/,@{$$nvHash{DelValue}})) |
1055
|
|
|
|
|
|
|
{ |
1056
|
3748
|
100
|
|
|
|
11846
|
$$nvHash{IsCreating} = $editOnly ? 0 : ($editGroup ? 2 : 1); |
|
|
100
|
|
|
|
|
|
1057
|
|
|
|
|
|
|
# add to hash of groups where this tag is being created |
1058
|
3748
|
100
|
100
|
|
|
13505
|
$createGroups or $createGroups = $options{CreateGroups} || { }; |
1059
|
3748
|
|
|
|
|
14463
|
$$createGroups{$self->GetGroup($tagInfo, 0)} = 1; |
1060
|
3748
|
|
|
|
|
11014
|
$$nvHash{CreateGroups} = $createGroups; |
1061
|
|
|
|
|
|
|
} |
1062
|
|
|
|
|
|
|
} |
1063
|
19885
|
100
|
|
|
|
52399
|
if ($$nvHash{IsCreating}) { |
|
|
100
|
|
|
|
|
|
1064
|
3738
|
100
|
|
|
|
5962
|
if (%{$$self{DEL_GROUP}}) { |
|
3738
|
|
|
|
|
11131
|
|
1065
|
227
|
|
|
|
|
441
|
my ($grp, @grps); |
1066
|
227
|
|
|
|
|
334
|
foreach $grp (keys %{$$self{DEL_GROUP}}) { |
|
227
|
|
|
|
|
3309
|
|
1067
|
12589
|
100
|
|
|
|
23864
|
next if $$self{DEL_GROUP}{$grp} == 2; |
1068
|
|
|
|
|
|
|
# set flag indicating tags were written after this group was deleted |
1069
|
354
|
|
|
|
|
485
|
$$self{DEL_GROUP}{$grp} = 2; |
1070
|
354
|
|
|
|
|
568
|
push @grps, $grp; |
1071
|
|
|
|
|
|
|
} |
1072
|
227
|
100
|
66
|
|
|
1183
|
if ($verbose > 1 and @grps) { |
1073
|
1
|
|
|
|
|
5
|
@grps = sort @grps; |
1074
|
1
|
|
|
|
|
10
|
print $out " Writing new tags after deleting groups: @grps\n"; |
1075
|
|
|
|
|
|
|
} |
1076
|
|
|
|
|
|
|
} |
1077
|
|
|
|
|
|
|
} elsif ($createOnly) { |
1078
|
22
|
100
|
|
|
|
95
|
$noCreate = $permanent ? 'permanent' : ($$tagInfo{Avoid} ? 'avoided' : ''); |
|
|
100
|
|
|
|
|
|
1079
|
22
|
50
|
|
|
|
67
|
$noCreate or $noCreate = $shift ? 'shifting' : 'not preferred'; |
|
|
100
|
|
|
|
|
|
1080
|
22
|
50
|
|
|
|
63
|
$verbose > 2 and print $out "Not creating $wgrp1:$tag ($noCreate)\n"; |
1081
|
22
|
|
|
|
|
73
|
next; # nothing to do (not creating and not editing) |
1082
|
|
|
|
|
|
|
} |
1083
|
19863
|
100
|
100
|
|
|
69554
|
if ($shift or not $options{DelValue}) { |
1084
|
19809
|
100
|
|
|
|
63415
|
$$nvHash{Value} or $$nvHash{Value} = [ ]; |
1085
|
19809
|
100
|
33
|
|
|
47199
|
if (not $$tagInfo{List}) { |
|
|
50
|
|
|
|
|
|
1086
|
|
|
|
|
|
|
# not a List tag -- overwrite existing value |
1087
|
19293
|
|
|
|
|
46862
|
$$nvHash{Value}[0] = $val; |
1088
|
0
|
|
|
|
|
0
|
} elsif (defined $$nvHash{AddBefore} and @{$$nvHash{Value}} >= $$nvHash{AddBefore}) { |
1089
|
|
|
|
|
|
|
# values from a later argument have been added (ie. Replace=0) |
1090
|
|
|
|
|
|
|
# to this list, so the new values should come before these |
1091
|
0
|
0
|
|
|
|
0
|
splice @{$$nvHash{Value}}, -$$nvHash{AddBefore}, 0, ref $val eq 'ARRAY' ? @$val : $val; |
|
0
|
|
|
|
|
0
|
|
1092
|
|
|
|
|
|
|
} else { |
1093
|
|
|
|
|
|
|
# add at end of existing list |
1094
|
516
|
100
|
|
|
|
918
|
push @{$$nvHash{Value}}, ref $val eq 'ARRAY' ? @$val : $val; |
|
516
|
|
|
|
|
2264
|
|
1095
|
|
|
|
|
|
|
} |
1096
|
19809
|
100
|
|
|
|
50106
|
if ($verbose > 1) { |
1097
|
22
|
|
|
|
|
39
|
my $ifExists; |
1098
|
22
|
50
|
|
|
|
55
|
if ($$tagInfo{IsComposite}) { |
1099
|
|
|
|
|
|
|
# (composite tags don't technically exist in the file) |
1100
|
0
|
0
|
|
|
|
0
|
if ($$tagInfo{WriteAlso}) { |
1101
|
0
|
|
|
|
|
0
|
$ifExists = ' (+' . join(',+',sort keys %{$$tagInfo{WriteAlso}}) . '):'; |
|
0
|
|
|
|
|
0
|
|
1102
|
|
|
|
|
|
|
} else { |
1103
|
0
|
|
|
|
|
0
|
$ifExists = ''; |
1104
|
|
|
|
|
|
|
} |
1105
|
|
|
|
|
|
|
} else { |
1106
|
|
|
|
|
|
|
$ifExists = $$nvHash{IsCreating} ? ( $createOnly ? |
1107
|
|
|
|
|
|
|
($$nvHash{IsCreating} == 2 ? |
1108
|
|
|
|
|
|
|
" if $writeGroup exists and tag doesn't" : |
1109
|
|
|
|
|
|
|
" if tag doesn't exist") : |
1110
|
|
|
|
|
|
|
($$nvHash{IsCreating} == 2 ? " if $writeGroup exists" : '')) : |
1111
|
22
|
0
|
33
|
|
|
104
|
(($$nvHash{DelValue} and @{$$nvHash{DelValue}}) ? |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
1112
|
|
|
|
|
|
|
' if tag was deleted' : ' if tag exists'); |
1113
|
|
|
|
|
|
|
} |
1114
|
22
|
50
|
|
|
|
69
|
my $verb = ($shift ? 'Shifting' : ($addValue ? 'Adding' : 'Writing')); |
|
|
50
|
|
|
|
|
|
1115
|
22
|
|
|
|
|
114
|
print $out "$$self{INDENT2}$verb $wgrp1:$tag$ifExists\n"; |
1116
|
|
|
|
|
|
|
} |
1117
|
|
|
|
|
|
|
} |
1118
|
|
|
|
|
|
|
} elsif ($permanent) { |
1119
|
5556
|
|
|
|
|
12908
|
$err = "Can't delete Permanent tag $wgrp1:$tag"; |
1120
|
5556
|
50
|
|
|
|
11699
|
$verbose > 1 and print $out "$err\n"; |
1121
|
5556
|
|
|
|
|
17996
|
next; |
1122
|
|
|
|
|
|
|
} elsif ($addValue or $options{DelValue}) { |
1123
|
0
|
0
|
|
|
|
0
|
$verbose > 1 and print $out "Adding/Deleting nothing does nothing\n"; |
1124
|
0
|
|
|
|
|
0
|
next; |
1125
|
|
|
|
|
|
|
} else { |
1126
|
|
|
|
|
|
|
# create empty new value hash entry to delete this tag |
1127
|
3923
|
|
|
|
|
11965
|
$self->GetNewValueHash($tagInfo, $writeGroup, 'delete'); |
1128
|
3923
|
|
|
|
|
7837
|
my $nvHash = $self->GetNewValueHash($tagInfo, $writeGroup, 'create'); |
1129
|
3923
|
|
|
|
|
9663
|
$$nvHash{WantGroup} = $wantGroup; |
1130
|
3923
|
50
|
|
|
|
9289
|
$verbose > 1 and print $out "$$self{INDENT2}Deleting $wgrp1:$tag\n"; |
1131
|
|
|
|
|
|
|
} |
1132
|
23786
|
100
|
|
|
|
46671
|
$$setTags{$tagInfo} = 1 if $setTags; |
1133
|
23786
|
100
|
|
|
|
59431
|
$prioritySet = 1 if $$pref{$tagInfo}; |
1134
|
23806
|
|
|
|
|
36310
|
WriteAlso: |
1135
|
|
|
|
|
|
|
++$numSet; |
1136
|
|
|
|
|
|
|
# also write related tags |
1137
|
23806
|
|
|
|
|
42905
|
my $writeAlso = $$tagInfo{WriteAlso}; |
1138
|
23806
|
100
|
|
|
|
77997
|
if ($writeAlso) { |
1139
|
76
|
|
|
|
|
342
|
$$self{INDENT2} = '+'; # indicate related tag with a leading "+" |
1140
|
76
|
|
|
|
|
228
|
my ($wgrp, $wtag, $n); |
1141
|
76
|
100
|
66
|
|
|
668
|
if ($$tagInfo{WriteGroup} and $$tagInfo{WriteGroup} eq 'All' and $writeGroup) { |
|
|
|
66
|
|
|
|
|
1142
|
46
|
|
|
|
|
148
|
$wgrp = $writeGroup . ':'; |
1143
|
|
|
|
|
|
|
} else { |
1144
|
30
|
|
|
|
|
88
|
$wgrp = ''; |
1145
|
|
|
|
|
|
|
} |
1146
|
76
|
|
|
|
|
472
|
local $SIG{'__WARN__'} = \&SetWarning; |
1147
|
76
|
|
|
|
|
583
|
foreach $wtag (sort keys %$writeAlso) { |
1148
|
|
|
|
|
|
|
my %opts = ( |
1149
|
|
|
|
|
|
|
Type => 'ValueConv', |
1150
|
|
|
|
|
|
|
Protected => $protected | 0x02, |
1151
|
|
|
|
|
|
|
AddValue => $addValue, |
1152
|
|
|
|
|
|
|
DelValue => $options{DelValue}, |
1153
|
|
|
|
|
|
|
Shift => $options{Shift}, |
1154
|
|
|
|
|
|
|
Replace => $options{Replace}, # handle lists properly |
1155
|
243
|
|
|
|
|
2046
|
CreateGroups=> $createGroups, |
1156
|
|
|
|
|
|
|
SetTags => \%alsoWrote, # remember tags already written |
1157
|
|
|
|
|
|
|
); |
1158
|
243
|
|
|
|
|
577
|
undef $evalWarning; |
1159
|
|
|
|
|
|
|
#### eval WriteAlso ($val,%opts) |
1160
|
243
|
|
|
|
|
19215
|
my $v = eval $$writeAlso{$wtag}; |
1161
|
|
|
|
|
|
|
# we wanted to do the eval in case there are side effect, but we |
1162
|
|
|
|
|
|
|
# don't want to write a value for a tag that is being deleted: |
1163
|
243
|
100
|
|
|
|
1286
|
undef $v unless defined $val; |
1164
|
243
|
50
|
|
|
|
767
|
$@ and $evalWarning = $@; |
1165
|
243
|
50
|
|
|
|
680
|
unless ($evalWarning) { |
1166
|
243
|
|
|
|
|
1950
|
($n,$evalWarning) = $self->SetNewValue($wgrp . $wtag, $v, %opts); |
1167
|
243
|
|
|
|
|
768
|
$numSet += $n; |
1168
|
|
|
|
|
|
|
# count this as being set if any related tag is set |
1169
|
243
|
100
|
100
|
|
|
1490
|
$prioritySet = 1 if $n and $$pref{$tagInfo}; |
1170
|
|
|
|
|
|
|
} |
1171
|
243
|
100
|
66
|
|
|
1102
|
if ($evalWarning and (not $err or $verbose > 2)) { |
|
|
|
66
|
|
|
|
|
1172
|
9
|
|
|
|
|
39
|
my $str = CleanWarning(); |
1173
|
9
|
50
|
|
|
|
31
|
if ($str) { |
1174
|
9
|
50
|
|
|
|
63
|
$str .= " for $wtag" unless $str =~ / for [-\w:]+$/; |
1175
|
9
|
|
|
|
|
34
|
$str .= " in $wgrp1:$tag (WriteAlso)"; |
1176
|
9
|
50
|
|
|
|
28
|
$err or $err = $str; |
1177
|
9
|
50
|
|
|
|
50
|
print $out "$str\n" if $verbose > 2; |
1178
|
|
|
|
|
|
|
} |
1179
|
|
|
|
|
|
|
} |
1180
|
|
|
|
|
|
|
} |
1181
|
76
|
|
|
|
|
741
|
$$self{INDENT2} = ''; |
1182
|
|
|
|
|
|
|
} |
1183
|
|
|
|
|
|
|
} |
1184
|
|
|
|
|
|
|
# print warning if we couldn't set our priority tag |
1185
|
4220
|
100
|
100
|
|
|
25445
|
if (defined $err and not $prioritySet) { |
|
|
100
|
66
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
1186
|
85
|
50
|
33
|
|
|
577
|
warn "$err\n" if $err and not wantarray; |
1187
|
|
|
|
|
|
|
} elsif (not $numSet) { |
1188
|
619
|
100
|
|
|
|
2391
|
my $pre = $wantGroup ? $wantGroup . ':' : ''; |
1189
|
619
|
100
|
|
|
|
1884
|
if ($wasProtected) { |
|
|
100
|
|
|
|
|
|
1190
|
372
|
|
|
|
|
779
|
$verbose = 0; # we already printed this verbose message |
1191
|
372
|
100
|
100
|
|
|
2172
|
unless ($options{Replace} and $options{Replace} == 2) { |
1192
|
360
|
|
|
|
|
1434
|
$err = "Sorry, $pre$tag is $wasProtected for writing"; |
1193
|
|
|
|
|
|
|
} |
1194
|
|
|
|
|
|
|
} elsif (not $listOnly) { |
1195
|
240
|
50
|
33
|
|
|
1717
|
if ($origTag =~ /[?*]/) { |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
1196
|
0
|
0
|
|
|
|
0
|
if ($noCreate) { |
|
|
0
|
|
|
|
|
|
1197
|
0
|
|
|
|
|
0
|
$err = "No tags matching 'pre${origTag}' will be created"; |
1198
|
0
|
|
|
|
|
0
|
$verbose = 0; # (already printed) |
1199
|
|
|
|
|
|
|
} elsif ($foundMatch) { |
1200
|
0
|
|
|
|
|
0
|
$err = "Sorry, no writable tags matching '$pre${origTag}'"; |
1201
|
|
|
|
|
|
|
} else { |
1202
|
0
|
|
|
|
|
0
|
$err = "No matching tags for '$pre${origTag}'"; |
1203
|
|
|
|
|
|
|
} |
1204
|
|
|
|
|
|
|
} elsif ($noCreate) { |
1205
|
0
|
|
|
|
|
0
|
$err = "Not creating $pre$tag"; |
1206
|
0
|
|
|
|
|
0
|
$verbose = 0; # (already printed) |
1207
|
|
|
|
|
|
|
} elsif ($foundMatch) { |
1208
|
0
|
|
|
|
|
0
|
$err = "Sorry, $pre$tag is not writable"; |
1209
|
|
|
|
|
|
|
} elsif ($wantGroup and @matchingTags) { |
1210
|
240
|
|
|
|
|
748
|
$err = "Sorry, $pre$tag doesn't exist or isn't writable"; |
1211
|
|
|
|
|
|
|
} else { |
1212
|
0
|
|
|
|
|
0
|
$err = "Tag '$pre${tag}' is not defined"; |
1213
|
|
|
|
|
|
|
} |
1214
|
|
|
|
|
|
|
} |
1215
|
619
|
100
|
|
|
|
1657
|
if ($err) { |
1216
|
600
|
50
|
|
|
|
1653
|
$verbose > 2 and print $out "$err\n"; |
1217
|
600
|
50
|
|
|
|
1520
|
warn "$err\n" unless wantarray; |
1218
|
|
|
|
|
|
|
} |
1219
|
|
|
|
|
|
|
} elsif ($$self{CHECK_WARN}) { |
1220
|
0
|
|
|
|
|
0
|
$err = $$self{CHECK_WARN}; |
1221
|
0
|
0
|
|
|
|
0
|
$verbose > 2 and print $out "$err\n"; |
1222
|
|
|
|
|
|
|
} elsif ($err and not $verbose) { |
1223
|
437
|
|
|
|
|
992
|
undef $err; |
1224
|
|
|
|
|
|
|
} |
1225
|
4220
|
100
|
|
|
|
42842
|
return ($numSet, $err) if wantarray; |
1226
|
423
|
|
|
|
|
32279
|
return $numSet; |
1227
|
|
|
|
|
|
|
} |
1228
|
|
|
|
|
|
|
|
1229
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1230
|
|
|
|
|
|
|
# set new values from information in specified file |
1231
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object reference, 1) source file name or reference, etc |
1232
|
|
|
|
|
|
|
# 2-N) List of tags to set (or all if none specified), or reference(s) to |
1233
|
|
|
|
|
|
|
# hash for options to pass to SetNewValue. The Replace option defaults |
1234
|
|
|
|
|
|
|
# to 1 for SetNewValuesFromFile -- set this to 0 to allow multiple tags |
1235
|
|
|
|
|
|
|
# to be copied to a list |
1236
|
|
|
|
|
|
|
# Returns: Hash of information set successfully (includes Warning or Error messages) |
1237
|
|
|
|
|
|
|
# Notes: Tag names may contain a group prefix, a leading '-' to exclude from copy, |
1238
|
|
|
|
|
|
|
# and/or a trailing '#' to copy the ValueConv value. The tag name '*' may |
1239
|
|
|
|
|
|
|
# be used to represent all tags in a group. An optional destination tag |
1240
|
|
|
|
|
|
|
# may be specified with '>DSTTAG' ('DSTTAG
|
1241
|
|
|
|
|
|
|
# case the source tag may also be an expression involving tag names). |
1242
|
|
|
|
|
|
|
sub SetNewValuesFromFile($$;@) |
1243
|
|
|
|
|
|
|
{ |
1244
|
59
|
|
|
59
|
1
|
1245
|
local $_; |
1245
|
59
|
|
|
|
|
293
|
my ($self, $srcFile, @setTags) = @_; |
1246
|
59
|
|
|
|
|
398
|
my ($key, $tag, @exclude, @reqTags); |
1247
|
|
|
|
|
|
|
|
1248
|
|
|
|
|
|
|
# get initial SetNewValuesFromFile options |
1249
|
59
|
|
|
|
|
330
|
my %opts = ( Replace => 1 ); # replace existing list items by default |
1250
|
59
|
|
|
|
|
354
|
while (ref $setTags[0] eq 'HASH') { |
1251
|
1
|
|
|
|
|
3
|
$_ = shift @setTags; |
1252
|
1
|
|
|
|
|
6
|
foreach $key (keys %$_) { |
1253
|
1
|
|
|
|
|
7
|
$opts{$key} = $$_{$key}; |
1254
|
|
|
|
|
|
|
} |
1255
|
|
|
|
|
|
|
} |
1256
|
|
|
|
|
|
|
# expand shortcuts |
1257
|
59
|
100
|
|
|
|
433
|
@setTags and ExpandShortcuts(\@setTags); |
1258
|
59
|
|
|
|
|
458
|
my $srcExifTool = new Image::ExifTool; |
1259
|
|
|
|
|
|
|
# set flag to indicate we are being called from inside SetNewValuesFromFile() |
1260
|
59
|
|
|
|
|
388
|
$$srcExifTool{TAGS_FROM_FILE} = 1; |
1261
|
|
|
|
|
|
|
# synchronize and increment the file sequence number |
1262
|
59
|
|
|
|
|
295
|
$$srcExifTool{FILE_SEQUENCE} = $$self{FILE_SEQUENCE}++; |
1263
|
|
|
|
|
|
|
# set options for our extraction tool |
1264
|
59
|
|
|
|
|
173
|
my $options = $$self{OPTIONS}; |
1265
|
|
|
|
|
|
|
# copy both structured and flattened tags by default (but flattened tags are "unsafe") |
1266
|
59
|
50
|
|
|
|
309
|
my $structOpt = defined $$options{Struct} ? $$options{Struct} : 2; |
1267
|
|
|
|
|
|
|
# copy structures only if no tags specified (since flattened tags are "unsafe") |
1268
|
59
|
100
|
66
|
|
|
526
|
$structOpt = 1 if $structOpt eq '2' and not @setTags; |
1269
|
|
|
|
|
|
|
# +------------------------------------------+ |
1270
|
|
|
|
|
|
|
# ! DON'T FORGET!! Must consider each new ! |
1271
|
|
|
|
|
|
|
# ! option to decide how it is handled here. ! |
1272
|
|
|
|
|
|
|
# +------------------------------------------+ |
1273
|
|
|
|
|
|
|
$srcExifTool->Options( |
1274
|
|
|
|
|
|
|
Binary => 1, |
1275
|
|
|
|
|
|
|
Charset => $$options{Charset}, |
1276
|
|
|
|
|
|
|
CharsetEXIF => $$options{CharsetEXIF}, |
1277
|
|
|
|
|
|
|
CharsetFileName => $$options{CharsetFileName}, |
1278
|
|
|
|
|
|
|
CharsetID3 => $$options{CharsetID3}, |
1279
|
|
|
|
|
|
|
CharsetIPTC => $$options{CharsetIPTC}, |
1280
|
|
|
|
|
|
|
CharsetPhotoshop=> $$options{CharsetPhotoshop}, |
1281
|
|
|
|
|
|
|
Composite => $$options{Composite}, |
1282
|
|
|
|
|
|
|
CoordFormat => $$options{CoordFormat} || '%d %d %.8f', # copy coordinates at high resolution unless otherwise specified |
1283
|
|
|
|
|
|
|
DateFormat => $$options{DateFormat}, |
1284
|
|
|
|
|
|
|
Duplicates => 1, |
1285
|
|
|
|
|
|
|
Escape => $$options{Escape}, |
1286
|
|
|
|
|
|
|
# Exclude (set below) |
1287
|
|
|
|
|
|
|
ExtendedXMP => $$options{ExtendedXMP}, |
1288
|
|
|
|
|
|
|
ExtractEmbedded => $$options{ExtractEmbedded}, |
1289
|
|
|
|
|
|
|
FastScan => $$options{FastScan}, |
1290
|
|
|
|
|
|
|
Filter => $$options{Filter}, |
1291
|
|
|
|
|
|
|
FixBase => $$options{FixBase}, |
1292
|
|
|
|
|
|
|
GlobalTimeShift => $$options{GlobalTimeShift}, |
1293
|
|
|
|
|
|
|
HexTagIDs => $$options{HexTagIDs}, |
1294
|
|
|
|
|
|
|
IgnoreMinorErrors=>$$options{IgnoreMinorErrors}, |
1295
|
|
|
|
|
|
|
IgnoreTags => $$options{IgnoreTags}, |
1296
|
|
|
|
|
|
|
Lang => $$options{Lang}, |
1297
|
|
|
|
|
|
|
LargeFileSupport=> $$options{LargeFileSupport}, |
1298
|
|
|
|
|
|
|
List => 1, |
1299
|
|
|
|
|
|
|
ListItem => $$options{ListItem}, |
1300
|
|
|
|
|
|
|
ListSep => $$options{ListSep}, |
1301
|
|
|
|
|
|
|
MakerNotes => $$options{FastScan} && $$options{FastScan} > 1 ? undef : 1, |
1302
|
|
|
|
|
|
|
MDItemTags => $$options{MDItemTags}, |
1303
|
|
|
|
|
|
|
MissingTagValue => $$options{MissingTagValue}, |
1304
|
|
|
|
|
|
|
NoPDFList => $$options{NoPDFList}, |
1305
|
|
|
|
|
|
|
Password => $$options{Password}, |
1306
|
|
|
|
|
|
|
PrintConv => $$options{PrintConv}, |
1307
|
|
|
|
|
|
|
QuickTimeUTC => $$options{QuickTimeUTC}, |
1308
|
|
|
|
|
|
|
RequestAll => $$options{RequestAll} || 1, # (is this still necessary now that RequestTags are being set?) |
1309
|
|
|
|
|
|
|
RequestTags => $$options{RequestTags}, |
1310
|
|
|
|
|
|
|
SaveFormat => $$options{SaveFormat}, |
1311
|
|
|
|
|
|
|
SavePath => $$options{SavePath}, |
1312
|
|
|
|
|
|
|
ScanForXMP => $$options{ScanForXMP}, |
1313
|
|
|
|
|
|
|
StrictDate => defined $$options{StrictDate} ? $$options{StrictDate} : 1, |
1314
|
|
|
|
|
|
|
Struct => $structOpt, |
1315
|
|
|
|
|
|
|
SystemTags => $$options{SystemTags}, |
1316
|
|
|
|
|
|
|
TimeZone => $$options{TimeZone}, |
1317
|
|
|
|
|
|
|
Unknown => $$options{Unknown}, |
1318
|
|
|
|
|
|
|
UserParam => $$options{UserParam}, |
1319
|
|
|
|
|
|
|
Validate => $$options{Validate}, |
1320
|
|
|
|
|
|
|
XAttrTags => $$options{XAttrTags}, |
1321
|
|
|
|
|
|
|
XMPAutoConv => $$options{XMPAutoConv}, |
1322
|
59
|
50
|
50
|
|
|
2590
|
); |
|
|
50
|
33
|
|
|
|
|
|
|
|
50
|
|
|
|
|
1323
|
59
|
|
|
|
|
342
|
$$srcExifTool{GLOBAL_TIME_OFFSET} = $$self{GLOBAL_TIME_OFFSET}; |
1324
|
59
|
|
|
|
|
276
|
$$srcExifTool{ALT_EXIFTOOL} = $$self{ALT_EXIFTOOL}; |
1325
|
59
|
|
|
|
|
211
|
foreach $tag (@setTags) { |
1326
|
69
|
100
|
|
|
|
253
|
next if ref $tag; |
1327
|
68
|
100
|
|
|
|
296
|
if ($tag =~ /^-(.*)/) { |
1328
|
|
|
|
|
|
|
# avoid extracting tags that are excluded |
1329
|
7
|
|
|
|
|
33
|
push @exclude, $1; |
1330
|
7
|
|
|
|
|
23
|
next; |
1331
|
|
|
|
|
|
|
} |
1332
|
|
|
|
|
|
|
# add specified tags to list of requested tags |
1333
|
61
|
|
|
|
|
145
|
$_ = $tag; |
1334
|
61
|
100
|
|
|
|
682
|
if (/(.+?)\s*(>|<)\s*(.+)/) { |
1335
|
30
|
100
|
|
|
|
148
|
if ($2 eq '>') { |
1336
|
10
|
|
|
|
|
34
|
$_ = $1; |
1337
|
|
|
|
|
|
|
} else { |
1338
|
20
|
|
|
|
|
61
|
$_ = $3; |
1339
|
20
|
100
|
|
|
|
128
|
/\$/ and push(@reqTags, /\$\{?(?:[-\w]+:)*([-\w?*]+)/g), next; |
1340
|
|
|
|
|
|
|
} |
1341
|
|
|
|
|
|
|
} |
1342
|
54
|
50
|
|
|
|
559
|
push @reqTags, $2 if /(^|:)([-\w?*]+)#?$/; |
1343
|
|
|
|
|
|
|
} |
1344
|
59
|
100
|
|
|
|
303
|
if (@exclude) { |
1345
|
6
|
|
|
|
|
39
|
ExpandShortcuts(\@exclude, 1); |
1346
|
6
|
|
|
|
|
64
|
$srcExifTool->Options(Exclude => \@exclude); |
1347
|
|
|
|
|
|
|
} |
1348
|
59
|
100
|
|
|
|
443
|
$srcExifTool->Options(RequestTags => \@reqTags) if @reqTags; |
1349
|
59
|
|
|
|
|
274
|
my $printConv = $$options{PrintConv}; |
1350
|
59
|
50
|
|
|
|
330
|
if ($opts{Type}) { |
1351
|
|
|
|
|
|
|
# save source type separately because it may be different than dst Type |
1352
|
0
|
|
|
|
|
0
|
$opts{SrcType} = $opts{Type}; |
1353
|
|
|
|
|
|
|
# override PrintConv option with initial Type if given |
1354
|
0
|
0
|
|
|
|
0
|
$printConv = ($opts{Type} eq 'PrintConv' ? 1 : 0); |
1355
|
0
|
|
|
|
|
0
|
$srcExifTool->Options(PrintConv => $printConv); |
1356
|
|
|
|
|
|
|
} |
1357
|
59
|
100
|
|
|
|
265
|
my $srcType = $printConv ? 'PrintConv' : 'ValueConv'; |
1358
|
|
|
|
|
|
|
|
1359
|
|
|
|
|
|
|
# get all tags from source file (including MakerNotes block) |
1360
|
59
|
|
|
|
|
307
|
my $info = $srcExifTool->ImageInfo($srcFile); |
1361
|
59
|
50
|
33
|
|
|
442
|
return $info if $$info{Error} and $$info{Error} eq 'Error opening file'; |
1362
|
59
|
|
|
|
|
258
|
delete $$srcExifTool{VALUE}{Error}; # delete so we can check this later |
1363
|
|
|
|
|
|
|
|
1364
|
|
|
|
|
|
|
# sort tags in reverse order so we get priority tag last |
1365
|
59
|
|
|
|
|
5909
|
my @tags = reverse sort keys %$info; |
1366
|
|
|
|
|
|
|
# |
1367
|
|
|
|
|
|
|
# simply transfer all tags from source image if no tags specified |
1368
|
|
|
|
|
|
|
# |
1369
|
59
|
100
|
|
|
|
1138
|
unless (@setTags) { |
1370
|
|
|
|
|
|
|
# transfer maker note information to this object |
1371
|
15
|
|
|
|
|
86
|
$$self{MAKER_NOTE_FIXUP} = $$srcExifTool{MAKER_NOTE_FIXUP}; |
1372
|
15
|
|
|
|
|
77
|
$$self{MAKER_NOTE_BYTE_ORDER} = $$srcExifTool{MAKER_NOTE_BYTE_ORDER}; |
1373
|
15
|
|
|
|
|
60
|
foreach $tag (@tags) { |
1374
|
|
|
|
|
|
|
# don't try to set errors or warnings |
1375
|
2649
|
100
|
|
|
|
11019
|
next if $tag =~ /^(Error|Warning)\b/; |
1376
|
|
|
|
|
|
|
# get appropriate value type if necessary |
1377
|
2645
|
50
|
33
|
|
|
7632
|
if ($opts{SrcType} and $opts{SrcType} ne $srcType) { |
1378
|
0
|
|
|
|
|
0
|
$$info{$tag} = $srcExifTool->GetValue($tag, $opts{SrcType}); |
1379
|
|
|
|
|
|
|
} |
1380
|
|
|
|
|
|
|
# set value for this tag |
1381
|
2645
|
|
|
|
|
12886
|
my ($n, $e) = $self->SetNewValue($tag, $$info{$tag}, %opts); |
1382
|
|
|
|
|
|
|
# delete this tag if we couldn't set it |
1383
|
2645
|
100
|
|
|
|
10360
|
$n or delete $$info{$tag}; |
1384
|
|
|
|
|
|
|
} |
1385
|
15
|
|
|
|
|
1430
|
return $info; |
1386
|
|
|
|
|
|
|
} |
1387
|
|
|
|
|
|
|
# |
1388
|
|
|
|
|
|
|
# transfer specified tags in the proper order |
1389
|
|
|
|
|
|
|
# |
1390
|
|
|
|
|
|
|
# 1) loop through input list of tags to set, and build @setList |
1391
|
44
|
|
|
|
|
195
|
my (@setList, $set, %setMatches, $t, %altFiles); |
1392
|
44
|
|
|
|
|
186
|
foreach $t (@setTags) { |
1393
|
69
|
100
|
|
|
|
299
|
if (ref $t eq 'HASH') { |
1394
|
|
|
|
|
|
|
# update current options |
1395
|
1
|
|
|
|
|
5
|
foreach $key (keys %$t) { |
1396
|
1
|
|
|
|
|
4
|
$opts{$key} = $$t{$key}; |
1397
|
|
|
|
|
|
|
} |
1398
|
1
|
|
|
|
|
5
|
next; |
1399
|
|
|
|
|
|
|
} |
1400
|
|
|
|
|
|
|
# make a copy of the current options for this setTag |
1401
|
|
|
|
|
|
|
# (also use this hash to store expression and wildcard flags, EXPR and WILD) |
1402
|
68
|
|
|
|
|
314
|
my $opts = { %opts }; |
1403
|
68
|
|
|
|
|
274
|
$tag = lc $t; # change tag/group names to all lower case |
1404
|
68
|
|
|
|
|
205
|
my (@fg, $grp, $dst, $dstGrp, $dstTag, $isExclude); |
1405
|
|
|
|
|
|
|
# handle redirection to another tag |
1406
|
68
|
100
|
|
|
|
902
|
if ($tag =~ /(.+?)\s*(>|<)\s*(.+)/) { |
1407
|
30
|
|
|
|
|
92
|
$dstGrp = ''; |
1408
|
30
|
|
|
|
|
61
|
my $opt; |
1409
|
30
|
100
|
|
|
|
133
|
if ($2 eq '>') { |
1410
|
10
|
|
|
|
|
48
|
($tag, $dstTag) = ($1, $3); |
1411
|
|
|
|
|
|
|
# flag add and delete (eg. '+<' and '-<') redirections |
1412
|
10
|
50
|
33
|
|
|
118
|
$opt = $1 if $tag =~ s/\s*([-+])$// or $dstTag =~ s/^([-+])\s*//; |
1413
|
|
|
|
|
|
|
} else { |
1414
|
20
|
|
|
|
|
90
|
($tag, $dstTag) = ($3, $1); |
1415
|
20
|
50
|
|
|
|
112
|
$opt = $1 if $dstTag =~ s/\s*([-+])$//; |
1416
|
|
|
|
|
|
|
# handle expressions |
1417
|
20
|
100
|
|
|
|
93
|
if ($tag =~ /\$/) { |
1418
|
7
|
|
|
|
|
22
|
$tag = $t; # restore original case |
1419
|
|
|
|
|
|
|
# recover leading whitespace (except for initial single space) |
1420
|
7
|
|
|
|
|
62
|
$tag =~ s/(.+?)\s*(>|<) ?//; |
1421
|
7
|
|
|
|
|
68
|
$$opts{EXPR} = 1; # flag this expression |
1422
|
|
|
|
|
|
|
} else { |
1423
|
|
|
|
|
|
|
# (not sure why this is here because sign should be before '<') |
1424
|
|
|
|
|
|
|
# (--> allows "<+" or "<-", which is an undocumented feature) |
1425
|
13
|
50
|
|
|
|
60
|
$opt = $1 if $tag =~ s/^([-+])\s*//; |
1426
|
|
|
|
|
|
|
} |
1427
|
|
|
|
|
|
|
} |
1428
|
30
|
100
|
|
|
|
152
|
$$opts{Replace} = 0 if $dstTag =~ s/^\+//; |
1429
|
|
|
|
|
|
|
# validate tag name(s) |
1430
|
30
|
50
|
66
|
|
|
219
|
unless ($$opts{EXPR} or ValidTagName($tag)) { |
1431
|
0
|
|
|
|
|
0
|
$self->Warn("Invalid tag name '${tag}'. Use '=' not '<' to assign a tag value"); |
1432
|
0
|
|
|
|
|
0
|
next; |
1433
|
|
|
|
|
|
|
} |
1434
|
30
|
50
|
|
|
|
125
|
ValidTagName($dstTag) or $self->Warn("Invalid tag name '${dstTag}'"), next; |
1435
|
|
|
|
|
|
|
# translate '+' and '-' to appropriate SetNewValue option |
1436
|
30
|
50
|
|
|
|
122
|
if ($opt) { |
1437
|
0
|
|
|
|
|
0
|
$$opts{{ '+' => 'AddValue', '-' => 'DelValue' }->{$opt}} = 1; |
1438
|
0
|
|
|
|
|
0
|
$$opts{Shift} = 0; # shift if shiftable |
1439
|
|
|
|
|
|
|
} |
1440
|
30
|
100
|
|
|
|
192
|
($dstGrp, $dstTag) = ($1, $2) if $dstTag =~ /(.*):(.+)/; |
1441
|
|
|
|
|
|
|
# ValueConv may be specified separately on the destination with '#' |
1442
|
30
|
50
|
|
|
|
147
|
$$opts{Type} = 'ValueConv' if $dstTag =~ s/#$//; |
1443
|
|
|
|
|
|
|
# replace tag name of 'all' with '*' |
1444
|
30
|
100
|
|
|
|
124
|
$dstTag = '*' if $dstTag eq 'all'; |
1445
|
|
|
|
|
|
|
} else { |
1446
|
38
|
50
|
|
|
|
224
|
$$opts{Replace} = 0 if $tag =~ s/^\+//; |
1447
|
|
|
|
|
|
|
} |
1448
|
68
|
100
|
|
|
|
303
|
unless ($$opts{EXPR}) { |
1449
|
61
|
|
|
|
|
261
|
$isExclude = ($tag =~ s/^-//); |
1450
|
61
|
100
|
|
|
|
362
|
if ($tag =~ /(.*):(.+)/) { |
1451
|
34
|
|
|
|
|
162
|
($grp, $tag) = ($1, $2); |
1452
|
34
|
|
|
|
|
204
|
foreach (split /:/, $grp) { |
1453
|
|
|
|
|
|
|
# save family/groups in list (ignoring 'all' and '*') |
1454
|
35
|
50
|
33
|
|
|
338
|
next unless length($_) and /^(\d+)?(.*)/; |
1455
|
35
|
|
|
|
|
135
|
my ($f, $g) = ($1, $2); |
1456
|
35
|
50
|
33
|
|
|
305
|
$f = 7 if (not $f or $f eq '7') and $g =~ s/^ID-//i; |
|
|
|
33
|
|
|
|
|
1457
|
35
|
50
|
33
|
|
|
178
|
if ($g =~ /^file\d+$/i and (not $f or $f eq '8')) { |
|
|
|
66
|
|
|
|
|
1458
|
3
|
|
|
|
|
8
|
$f = 8; |
1459
|
3
|
|
|
|
|
14
|
my $g8 = ucfirst $g; |
1460
|
3
|
50
|
|
|
|
18
|
if ($$srcExifTool{ALT_EXIFTOOL}{$g8}) { |
1461
|
3
|
|
|
|
|
9
|
$$opts{GROUP8} = $g8; |
1462
|
3
|
100
|
|
|
|
12
|
$altFiles{$g8} or $altFiles{$g8} = [ ]; |
1463
|
|
|
|
|
|
|
# save list of requested tags for this alternate ExifTool object |
1464
|
3
|
|
|
|
|
5
|
push @{$altFiles{$g8}}, "$grp:$tag"; |
|
3
|
|
|
|
|
14
|
|
1465
|
|
|
|
|
|
|
} |
1466
|
|
|
|
|
|
|
} |
1467
|
35
|
100
|
100
|
|
|
367
|
push @fg, [ $f, $g ] unless $g eq '*' or $g eq 'all'; |
1468
|
|
|
|
|
|
|
} |
1469
|
|
|
|
|
|
|
} |
1470
|
|
|
|
|
|
|
# allow ValueConv to be specified by a '#' on the tag name |
1471
|
61
|
50
|
|
|
|
281
|
if ($tag =~ s/#$//) { |
1472
|
0
|
|
|
|
|
0
|
$$opts{SrcType} = 'ValueConv'; |
1473
|
0
|
0
|
|
|
|
0
|
$$opts{Type} = 'ValueConv' unless $dstTag; |
1474
|
|
|
|
|
|
|
} |
1475
|
|
|
|
|
|
|
# replace 'all' with '*' in tag and group names |
1476
|
61
|
100
|
|
|
|
283
|
$tag = '*' if $tag eq 'all'; |
1477
|
|
|
|
|
|
|
# allow wildcards in tag names (handle differently from all tags: '*') |
1478
|
61
|
100
|
100
|
|
|
486
|
if ($tag =~ /[?*]/ and $tag ne '*') { |
1479
|
3
|
|
|
|
|
13
|
$$opts{WILD} = 1; # set flag indicating wildcards were used in source tag |
1480
|
3
|
|
|
|
|
16
|
$tag =~ s/\*/[-\\w]*/g; |
1481
|
3
|
|
|
|
|
15
|
$tag =~ s/\?/[-\\w]/g; |
1482
|
|
|
|
|
|
|
} |
1483
|
|
|
|
|
|
|
} |
1484
|
|
|
|
|
|
|
# redirect, exclude or set this tag (Note: @fg is empty if we don't care about the group) |
1485
|
68
|
100
|
|
|
|
356
|
if ($dstTag) { |
|
|
100
|
|
|
|
|
|
1486
|
|
|
|
|
|
|
# redirect this tag |
1487
|
30
|
50
|
|
|
|
97
|
$isExclude and return { Error => "Can't redirect excluded tag" }; |
1488
|
|
|
|
|
|
|
# set destination group the same as source if necessary |
1489
|
|
|
|
|
|
|
# (removed in 7.72 so '-*:*
|
1490
|
|
|
|
|
|
|
# $dstGrp = $grp if $dstGrp eq '*' and $grp; |
1491
|
|
|
|
|
|
|
# write to specified destination group/tag |
1492
|
30
|
|
|
|
|
107
|
$dst = [ $dstGrp, $dstTag ]; |
1493
|
|
|
|
|
|
|
} elsif ($isExclude) { |
1494
|
|
|
|
|
|
|
# implicitly assume '*' if first entry is an exclusion |
1495
|
7
|
100
|
|
|
|
64
|
unshift @setList, [ [ ], '*', [ '', '*' ], $opts ] unless @setList; |
1496
|
|
|
|
|
|
|
# exclude this tag by leaving $dst undefined |
1497
|
|
|
|
|
|
|
} else { |
1498
|
31
|
100
|
100
|
|
|
283
|
$dst = [ $grp || '', $$opts{WILD} ? '*' : $tag ]; # use same group name for dest |
1499
|
|
|
|
|
|
|
} |
1500
|
|
|
|
|
|
|
# save in reverse order so we don't set tags before an exclude |
1501
|
68
|
|
|
|
|
392
|
unshift @setList, [ \@fg, $tag, $dst, $opts ]; |
1502
|
|
|
|
|
|
|
} |
1503
|
|
|
|
|
|
|
# 1b) copy requested tags for each alternate ExifTool object |
1504
|
44
|
|
|
|
|
161
|
my $g8; |
1505
|
44
|
|
|
|
|
254
|
foreach $g8 (sort keys %altFiles) { |
1506
|
|
|
|
|
|
|
# request specific alternate tags to load them from the alternate ExifTool object |
1507
|
1
|
|
|
|
|
8
|
my $altInfo = $srcExifTool->GetInfo($altFiles{$g8}); |
1508
|
|
|
|
|
|
|
# add to tags list after dummy entry to signify start of tags for this alt file |
1509
|
1
|
50
|
|
|
|
13
|
if (%$altInfo) { |
1510
|
1
|
|
|
|
|
12
|
push @tags, 'Warning DUMMY', reverse sort keys %$altInfo; |
1511
|
1
|
|
|
|
|
12
|
$$info{$_} = $$altInfo{$_} foreach keys %$altInfo; |
1512
|
|
|
|
|
|
|
} |
1513
|
|
|
|
|
|
|
} |
1514
|
|
|
|
|
|
|
# 2) initialize lists of matching tags for each setTag |
1515
|
44
|
|
|
|
|
181
|
foreach $set (@setList) { |
1516
|
69
|
100
|
|
|
|
455
|
$$set[2] and $setMatches{$set} = [ ]; |
1517
|
|
|
|
|
|
|
} |
1518
|
|
|
|
|
|
|
# 3) loop through all tags in source image and save tags matching each setTag |
1519
|
44
|
|
|
|
|
201
|
my (%rtnInfo, $isAlt); |
1520
|
44
|
|
|
|
|
148
|
foreach $tag (@tags) { |
1521
|
|
|
|
|
|
|
# don't try to set errors or warnings |
1522
|
6487
|
100
|
|
|
|
16104
|
if ($tag =~ /^(Error|Warning)( |$)/) { |
1523
|
14
|
100
|
|
|
|
59
|
if ($tag eq 'Warning DUMMY') { |
1524
|
1
|
|
|
|
|
10
|
$isAlt = 1; # start of the alt tags |
1525
|
|
|
|
|
|
|
} else { |
1526
|
13
|
|
|
|
|
46
|
$rtnInfo{$tag} = $$info{$tag}; |
1527
|
|
|
|
|
|
|
} |
1528
|
14
|
|
|
|
|
33
|
next; |
1529
|
|
|
|
|
|
|
} |
1530
|
|
|
|
|
|
|
# only set specified tags |
1531
|
6473
|
|
|
|
|
13714
|
my $lcTag = lc(GetTagName($tag)); |
1532
|
6473
|
|
|
|
|
11228
|
my (@grp, %grp); |
1533
|
6473
|
|
|
|
|
10276
|
SET: foreach $set (@setList) { |
1534
|
10205
|
|
|
|
|
15416
|
my $opts = $$set[3]; |
1535
|
10205
|
100
|
|
|
|
19151
|
next if $$opts{EXPR}; # (expressions handled in step 4) |
1536
|
9238
|
100
|
100
|
|
|
26005
|
next if $$opts{GROUP8} xor $isAlt; |
1537
|
|
|
|
|
|
|
# check first for matching tag |
1538
|
8668
|
100
|
100
|
|
|
25186
|
unless ($$set[1] eq $lcTag or $$set[1] eq '*') { |
1539
|
|
|
|
|
|
|
# handle wildcards |
1540
|
6048
|
100
|
100
|
|
|
17022
|
next unless $$opts{WILD} and $lcTag =~ /^$$set[1]$/; |
1541
|
|
|
|
|
|
|
} |
1542
|
|
|
|
|
|
|
# then check for matching group |
1543
|
2636
|
100
|
|
|
|
3634
|
if (@{$$set[0]}) { |
|
2636
|
|
|
|
|
5384
|
|
1544
|
|
|
|
|
|
|
# get lower case group names if not done already |
1545
|
1472
|
100
|
|
|
|
3131
|
unless (@grp) { |
1546
|
1368
|
|
|
|
|
3652
|
@grp = map(lc, $srcExifTool->GetGroup($tag)); |
1547
|
1368
|
|
|
|
|
9600
|
$grp{$_} = 1 foreach @grp; |
1548
|
|
|
|
|
|
|
} |
1549
|
1472
|
|
|
|
|
2456
|
foreach (@{$$set[0]}) { |
|
1472
|
|
|
|
|
2873
|
|
1550
|
1514
|
|
|
|
|
3242
|
my ($f, $g) = @$_; |
1551
|
1514
|
100
|
|
|
|
2782
|
if (not defined $f) { |
|
|
50
|
|
|
|
|
|
1552
|
1510
|
100
|
|
|
|
5459
|
next SET unless $grp{$g}; |
1553
|
|
|
|
|
|
|
} elsif ($f == 7) { |
1554
|
0
|
0
|
|
|
|
0
|
next SET unless IsSameID($srcExifTool->GetTagID($tag), $g); |
1555
|
|
|
|
|
|
|
} else { |
1556
|
4
|
50
|
33
|
|
|
22
|
next SET unless defined $grp[$f] and $g eq $grp[$f]; |
1557
|
|
|
|
|
|
|
} |
1558
|
|
|
|
|
|
|
} |
1559
|
|
|
|
|
|
|
} |
1560
|
1622
|
100
|
|
|
|
3587
|
last unless $$set[2]; # all done if we hit an exclude |
1561
|
|
|
|
|
|
|
# add to the list of tags matching this setTag |
1562
|
1448
|
|
|
|
|
1899
|
push @{$setMatches{$set}}, $tag; |
|
1448
|
|
|
|
|
5490
|
|
1563
|
|
|
|
|
|
|
} |
1564
|
|
|
|
|
|
|
} |
1565
|
|
|
|
|
|
|
# 4) loop through each setTag in original order, setting new tag values |
1566
|
44
|
|
|
|
|
261
|
foreach $set (reverse @setList) { |
1567
|
|
|
|
|
|
|
# get options for SetNewValue |
1568
|
69
|
|
|
|
|
257
|
my $opts = $$set[3]; |
1569
|
|
|
|
|
|
|
# handle expressions |
1570
|
69
|
100
|
|
|
|
321
|
if ($$opts{EXPR}) { |
1571
|
7
|
|
|
|
|
67
|
my $val = $srcExifTool->InsertTagValues(\@tags, $$set[1], 'Error'); |
1572
|
7
|
50
|
|
|
|
40
|
if ($$srcExifTool{VALUE}{Error}) { |
1573
|
|
|
|
|
|
|
# pass on any error as a warning |
1574
|
0
|
|
|
|
|
0
|
$tag = NextFreeTagKey(\%rtnInfo, 'Warning'); |
1575
|
0
|
|
|
|
|
0
|
$rtnInfo{$tag} = $$srcExifTool{VALUE}{Error}; |
1576
|
0
|
|
|
|
|
0
|
delete $$srcExifTool{VALUE}{Error}; |
1577
|
0
|
0
|
|
|
|
0
|
next unless defined $val; |
1578
|
|
|
|
|
|
|
} |
1579
|
7
|
|
|
|
|
16
|
my ($dstGrp, $dstTag) = @{$$set[2]}; |
|
7
|
|
|
|
|
32
|
|
1580
|
7
|
50
|
33
|
|
|
83
|
$$opts{Protected} = 1 unless $dstTag =~ /[?*]/ and $dstTag ne '*'; |
1581
|
7
|
50
|
|
|
|
28
|
$$opts{Group} = $dstGrp if $dstGrp; |
1582
|
7
|
|
|
|
|
62
|
my @rtnVals = $self->SetNewValue($dstTag, $val, %$opts); |
1583
|
7
|
50
|
|
|
|
53
|
$rtnInfo{$dstTag} = $val if $rtnVals[0]; # tag was set successfully |
1584
|
7
|
|
|
|
|
30
|
next; |
1585
|
|
|
|
|
|
|
} |
1586
|
62
|
|
|
|
|
168
|
foreach $tag (@{$setMatches{$set}}) { |
|
62
|
|
|
|
|
278
|
|
1587
|
1448
|
|
|
|
|
2573
|
my ($val, $noWarn); |
1588
|
1448
|
50
|
33
|
|
|
4468
|
if ($$opts{SrcType} and $$opts{SrcType} ne $srcType) { |
1589
|
0
|
|
|
|
|
0
|
$val = $srcExifTool->GetValue($tag, $$opts{SrcType}); |
1590
|
|
|
|
|
|
|
} else { |
1591
|
1448
|
|
|
|
|
5733
|
$val = $$info{$tag}; |
1592
|
|
|
|
|
|
|
} |
1593
|
1448
|
|
|
|
|
2565
|
my ($dstGrp, $dstTag) = @{$$set[2]}; |
|
1448
|
|
|
|
|
3722
|
|
1594
|
1448
|
100
|
|
|
|
3014
|
if ($dstGrp) { |
1595
|
1366
|
|
|
|
|
4081
|
my @dstGrp = split /:/, $dstGrp; |
1596
|
|
|
|
|
|
|
# destination group of '*' writes to same group as source tag |
1597
|
|
|
|
|
|
|
# (family 1 unless otherwise specified) |
1598
|
1366
|
|
|
|
|
2960
|
foreach (@dstGrp) { |
1599
|
1368
|
100
|
|
|
|
6693
|
next unless /^(\d*)(all|\*)$/i; |
1600
|
1082
|
50
|
|
|
|
5648
|
$_ = $1 . $srcExifTool->GetGroup($tag, length $1 ? $1 : 1); |
1601
|
1082
|
|
|
|
|
2584
|
$noWarn = 1; # don't warn on wildcard destinations |
1602
|
|
|
|
|
|
|
} |
1603
|
1366
|
|
|
|
|
4597
|
$$opts{Group} = join ':', @dstGrp; |
1604
|
|
|
|
|
|
|
} else { |
1605
|
82
|
|
|
|
|
174
|
delete $$opts{Group}; |
1606
|
|
|
|
|
|
|
} |
1607
|
|
|
|
|
|
|
# transfer maker note information if setting this tag |
1608
|
1448
|
100
|
|
|
|
4867
|
if ($$srcExifTool{TAG_INFO}{$tag}{MakerNotes}) { |
1609
|
7
|
|
|
|
|
75
|
$$self{MAKER_NOTE_FIXUP} = $$srcExifTool{MAKER_NOTE_FIXUP}; |
1610
|
7
|
|
|
|
|
37
|
$$self{MAKER_NOTE_BYTE_ORDER} = $$srcExifTool{MAKER_NOTE_BYTE_ORDER}; |
1611
|
|
|
|
|
|
|
} |
1612
|
1448
|
100
|
|
|
|
3424
|
if ($dstTag eq '*') { |
1613
|
1415
|
|
|
|
|
2282
|
$dstTag = $tag; |
1614
|
1415
|
|
|
|
|
2198
|
$noWarn = 1; |
1615
|
|
|
|
|
|
|
} |
1616
|
1448
|
100
|
100
|
|
|
4870
|
if ($$set[1] eq '*' or $$set[3]{WILD}) { |
1617
|
|
|
|
|
|
|
# don't copy from protected binary tags when using wildcards |
1618
|
|
|
|
|
|
|
next if $$srcExifTool{TAG_INFO}{$tag}{Protected} and |
1619
|
1411
|
100
|
100
|
|
|
4428
|
$$srcExifTool{TAG_INFO}{$tag}{Binary}; |
1620
|
|
|
|
|
|
|
# don't copy to protected tags when using wildcards |
1621
|
1385
|
|
|
|
|
2300
|
delete $$opts{Protected}; |
1622
|
|
|
|
|
|
|
# don't copy flattened tags if copying structures too when copying all |
1623
|
1385
|
50
|
|
|
|
3396
|
$$opts{NoFlat} = $structOpt eq '2' ? 1 : 0; |
1624
|
|
|
|
|
|
|
} else { |
1625
|
|
|
|
|
|
|
# allow protected tags to be copied if specified explicitly |
1626
|
37
|
50
|
|
|
|
221
|
$$opts{Protected} = 1 unless $dstTag =~ /[?*]/; |
1627
|
37
|
|
|
|
|
113
|
delete $$opts{NoFlat}; |
1628
|
|
|
|
|
|
|
} |
1629
|
|
|
|
|
|
|
# set value(s) for this tag |
1630
|
1422
|
|
|
|
|
5824
|
my ($rtn, $wrn) = $self->SetNewValue($dstTag, $val, %$opts); |
1631
|
|
|
|
|
|
|
# this was added in version 9.14, and allowed actions like "-subject
|
1632
|
|
|
|
|
|
|
# write values of multiple tags into a list, but it had the side effect of |
1633
|
|
|
|
|
|
|
# duplicating items if there were multiple list tags with the same name |
1634
|
|
|
|
|
|
|
# (eg. -use mwg "-creator
|
1635
|
|
|
|
|
|
|
# $$opts{Replace} = 0; # accumulate values from tags matching a single argument |
1636
|
1422
|
50
|
66
|
|
|
5957
|
if ($wrn and not $noWarn) { |
1637
|
|
|
|
|
|
|
# return this warning |
1638
|
0
|
|
|
|
|
0
|
$rtnInfo{NextFreeTagKey(\%rtnInfo, 'Warning')} = $wrn; |
1639
|
0
|
|
|
|
|
0
|
$noWarn = 1; |
1640
|
|
|
|
|
|
|
} |
1641
|
1422
|
100
|
|
|
|
6305
|
$rtnInfo{$tag} = $val if $rtn; # tag was set successfully |
1642
|
|
|
|
|
|
|
} |
1643
|
|
|
|
|
|
|
} |
1644
|
44
|
|
|
|
|
3139
|
return \%rtnInfo; # return information that we set |
1645
|
|
|
|
|
|
|
} |
1646
|
|
|
|
|
|
|
|
1647
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1648
|
|
|
|
|
|
|
# Get new value(s) for tag |
1649
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object reference, 1) tag name (or tagInfo or nvHash ref, not public) |
1650
|
|
|
|
|
|
|
# 2) optional pointer to return new value hash reference (not part of public API) |
1651
|
|
|
|
|
|
|
# Returns: List of new Raw values (list may be empty if tag is being deleted) |
1652
|
|
|
|
|
|
|
# Notes: 1) Preferentially returns new value from Extra table if writable Extra tag exists |
1653
|
|
|
|
|
|
|
# 2) Must call AFTER IsOverwriting() returns 1 to get proper value for shifted times |
1654
|
|
|
|
|
|
|
# 3) Tag name is case sensitive and may be prefixed by family 0 or 1 group name |
1655
|
|
|
|
|
|
|
# 4) Value may have been modified by CHECK_PROC routine after ValueConv |
1656
|
|
|
|
|
|
|
sub GetNewValue($$;$) |
1657
|
|
|
|
|
|
|
{ |
1658
|
6735
|
|
|
6735
|
1
|
11948
|
local $_; |
1659
|
6735
|
|
|
|
|
10615
|
my $self = shift; |
1660
|
6735
|
|
|
|
|
11525
|
my $tag = shift; |
1661
|
6735
|
|
|
|
|
9684
|
my $nvHash; |
1662
|
6735
|
100
|
100
|
|
|
32499
|
if ((ref $tag eq 'HASH' and $$tag{IsNVH}) or not defined $tag) { |
|
|
|
100
|
|
|
|
|
1663
|
4008
|
|
|
|
|
7053
|
$nvHash = $tag; |
1664
|
|
|
|
|
|
|
} else { |
1665
|
2727
|
|
|
|
|
4785
|
my $newValueHashPt = shift; |
1666
|
2727
|
100
|
|
|
|
6763
|
if ($$self{NEW_VALUE}) { |
1667
|
2610
|
|
|
|
|
4388
|
my ($group, $tagInfo); |
1668
|
2610
|
100
|
66
|
|
|
13942
|
if (ref $tag) { |
|
|
100
|
|
|
|
|
|
1669
|
50
|
|
|
|
|
200
|
$nvHash = $self->GetNewValueHash($tag); |
1670
|
|
|
|
|
|
|
} elsif (defined($tagInfo = $Image::ExifTool::Extra{$tag}) and |
1671
|
|
|
|
|
|
|
$$tagInfo{Writable}) |
1672
|
|
|
|
|
|
|
{ |
1673
|
1477
|
|
|
|
|
3777
|
$nvHash = $self->GetNewValueHash($tagInfo); |
1674
|
|
|
|
|
|
|
} else { |
1675
|
|
|
|
|
|
|
# separate group from tag name |
1676
|
1083
|
|
|
|
|
1998
|
my @groups; |
1677
|
1083
|
100
|
|
|
|
3667
|
@groups = split ':', $1 if $tag =~ s/(.*)://; |
1678
|
1083
|
|
|
|
|
3735
|
my @tagInfoList = FindTagInfo($tag); |
1679
|
|
|
|
|
|
|
# decide which tag we want |
1680
|
1083
|
|
|
|
|
2464
|
GNV_TagInfo: foreach $tagInfo (@tagInfoList) { |
1681
|
1087
|
100
|
|
|
|
2927
|
my $nvh = $self->GetNewValueHash($tagInfo) or next; |
1682
|
|
|
|
|
|
|
# select tag in specified group(s) if necessary |
1683
|
4
|
|
|
|
|
16
|
foreach (@groups) { |
1684
|
2
|
50
|
|
|
|
7
|
next if $_ eq $$nvh{WriteGroup}; |
1685
|
2
|
|
|
|
|
8
|
my @grps = $self->GetGroup($tagInfo); |
1686
|
2
|
50
|
|
|
|
7
|
if ($grps[0] eq $$nvh{WriteGroup}) { |
1687
|
|
|
|
|
|
|
# check family 1 group only if WriteGroup is not specific |
1688
|
0
|
0
|
|
|
|
0
|
next if $_ eq $grps[1]; |
1689
|
|
|
|
|
|
|
} else { |
1690
|
|
|
|
|
|
|
# otherwise check family 0 group |
1691
|
2
|
50
|
|
|
|
8
|
next if $_ eq $grps[0]; |
1692
|
|
|
|
|
|
|
} |
1693
|
|
|
|
|
|
|
# also check family 7 |
1694
|
0
|
0
|
0
|
|
|
0
|
next if /^ID-(.*)/i and IsSameID($$tagInfo{TagID}, $1); |
1695
|
|
|
|
|
|
|
# step to next entry in list |
1696
|
0
|
0
|
|
|
|
0
|
$nvh = $$nvh{Next} or next GNV_TagInfo; |
1697
|
|
|
|
|
|
|
} |
1698
|
4
|
|
|
|
|
9
|
$nvHash = $nvh; |
1699
|
|
|
|
|
|
|
# give priority to the one we are creating |
1700
|
4
|
100
|
|
|
|
17
|
last if defined $$nvHash{IsCreating}; |
1701
|
|
|
|
|
|
|
} |
1702
|
|
|
|
|
|
|
} |
1703
|
|
|
|
|
|
|
} |
1704
|
|
|
|
|
|
|
# return new value hash if requested |
1705
|
2727
|
100
|
|
|
|
7920
|
$newValueHashPt and $$newValueHashPt = $nvHash; |
1706
|
|
|
|
|
|
|
} |
1707
|
6735
|
100
|
100
|
|
|
24222
|
unless ($nvHash and $$nvHash{Value}) { |
1708
|
4462
|
100
|
|
|
|
16865
|
return () if wantarray; # return empty list |
1709
|
2675
|
|
|
|
|
7741
|
return undef; |
1710
|
|
|
|
|
|
|
} |
1711
|
2273
|
|
|
|
|
4423
|
my $vals = $$nvHash{Value}; |
1712
|
|
|
|
|
|
|
# do inverse raw conversion if necessary |
1713
|
|
|
|
|
|
|
# - must also check after doing a Shift |
1714
|
2273
|
100
|
100
|
|
|
9291
|
if ($$nvHash{TagInfo}{RawConvInv} or $$nvHash{Shift}) { |
1715
|
60
|
|
|
|
|
321
|
my @copyVals = @$vals; # modify a copy of the values |
1716
|
60
|
|
|
|
|
142
|
$vals = \@copyVals; |
1717
|
60
|
|
|
|
|
175
|
my $tagInfo = $$nvHash{TagInfo}; |
1718
|
60
|
|
|
|
|
145
|
my $conv = $$tagInfo{RawConvInv}; |
1719
|
60
|
|
|
|
|
164
|
my $table = $$tagInfo{Table}; |
1720
|
60
|
|
|
|
|
142
|
my ($val, $checkProc); |
1721
|
60
|
100
|
66
|
|
|
293
|
$checkProc = $$table{CHECK_PROC} if $$nvHash{Shift} and $table; |
1722
|
60
|
|
|
|
|
354
|
local $SIG{'__WARN__'} = \&SetWarning; |
1723
|
60
|
|
|
|
|
184
|
undef $evalWarning; |
1724
|
60
|
|
|
|
|
182
|
foreach $val (@$vals) { |
1725
|
|
|
|
|
|
|
# must check value now if it was shifted |
1726
|
60
|
100
|
|
|
|
187
|
if ($checkProc) { |
1727
|
26
|
|
|
|
|
153
|
my $err = &$checkProc($self, $tagInfo, \$val); |
1728
|
26
|
50
|
33
|
|
|
118
|
if ($err or not defined $val) { |
1729
|
0
|
0
|
|
|
|
0
|
$err or $err = 'Error generating raw value'; |
1730
|
0
|
|
|
|
|
0
|
$self->WarnOnce("$err for $$tagInfo{Name}"); |
1731
|
0
|
|
|
|
|
0
|
@$vals = (); |
1732
|
0
|
|
|
|
|
0
|
last; |
1733
|
|
|
|
|
|
|
} |
1734
|
26
|
50
|
|
|
|
169
|
next unless $conv; |
1735
|
|
|
|
|
|
|
} else { |
1736
|
34
|
50
|
|
|
|
119
|
last unless $conv; |
1737
|
|
|
|
|
|
|
} |
1738
|
|
|
|
|
|
|
# do inverse raw conversion |
1739
|
34
|
100
|
|
|
|
171
|
if (ref($conv) eq 'CODE') { |
1740
|
2
|
|
|
|
|
13
|
$val = &$conv($val, $self); |
1741
|
|
|
|
|
|
|
} else { |
1742
|
|
|
|
|
|
|
#### eval RawConvInv ($self, $val, $tagInfo) |
1743
|
32
|
|
|
|
|
3555
|
$val = eval $conv; |
1744
|
32
|
50
|
|
|
|
219
|
$@ and $evalWarning = $@; |
1745
|
|
|
|
|
|
|
} |
1746
|
34
|
50
|
|
|
|
240
|
if ($evalWarning) { |
1747
|
|
|
|
|
|
|
# an empty warning ("\n") ignores tag with no error |
1748
|
0
|
0
|
|
|
|
0
|
if ($evalWarning ne "\n") { |
1749
|
0
|
|
|
|
|
0
|
my $err = CleanWarning() . " in $$tagInfo{Name} (RawConvInv)"; |
1750
|
0
|
|
|
|
|
0
|
$self->WarnOnce($err); |
1751
|
|
|
|
|
|
|
} |
1752
|
0
|
|
|
|
|
0
|
@$vals = (); |
1753
|
0
|
|
|
|
|
0
|
last; |
1754
|
|
|
|
|
|
|
} |
1755
|
|
|
|
|
|
|
} |
1756
|
|
|
|
|
|
|
} |
1757
|
|
|
|
|
|
|
# return our value(s) |
1758
|
2273
|
100
|
|
|
|
9824
|
return @$vals if wantarray; |
1759
|
1159
|
|
|
|
|
5496
|
return $$vals[0]; |
1760
|
|
|
|
|
|
|
} |
1761
|
|
|
|
|
|
|
|
1762
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1763
|
|
|
|
|
|
|
# Return the total number of new values set |
1764
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object reference |
1765
|
|
|
|
|
|
|
# Returns: Scalar context) Number of new values that have been set (incl pseudo) |
1766
|
|
|
|
|
|
|
# List context) Number of new values (incl pseudo), number of "pseudo" values |
1767
|
|
|
|
|
|
|
# ("pseudo" values are those which don't require rewriting the file to change) |
1768
|
|
|
|
|
|
|
sub CountNewValues($) |
1769
|
|
|
|
|
|
|
{ |
1770
|
236
|
|
|
236
|
1
|
663
|
my $self = shift; |
1771
|
236
|
|
|
|
|
810
|
my $newVal = $$self{NEW_VALUE}; |
1772
|
236
|
|
|
|
|
856
|
my ($num, $pseudo) = (0, 0); |
1773
|
236
|
100
|
|
|
|
1039
|
if ($newVal) { |
1774
|
217
|
|
|
|
|
1086
|
$num = scalar keys %$newVal; |
1775
|
217
|
|
|
|
|
469
|
my $nv; |
1776
|
217
|
|
|
|
|
2836
|
foreach $nv (values %$newVal) { |
1777
|
19139
|
|
|
|
|
44553
|
my $tagInfo = $$nv{TagInfo}; |
1778
|
|
|
|
|
|
|
# don't count tags that don't write anything |
1779
|
19139
|
100
|
|
|
|
42478
|
$$tagInfo{WriteNothing} and --$num, next; |
1780
|
|
|
|
|
|
|
# count the number of pseudo tags included |
1781
|
19124
|
100
|
|
|
|
43733
|
$$tagInfo{WritePseudo} and ++$pseudo; |
1782
|
|
|
|
|
|
|
} |
1783
|
|
|
|
|
|
|
} |
1784
|
236
|
|
|
|
|
931
|
$num += scalar keys %{$$self{DEL_GROUP}}; |
|
236
|
|
|
|
|
1193
|
|
1785
|
236
|
50
|
|
|
|
1021
|
return $num unless wantarray; |
1786
|
236
|
|
|
|
|
970
|
return ($num, $pseudo); |
1787
|
|
|
|
|
|
|
} |
1788
|
|
|
|
|
|
|
|
1789
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1790
|
|
|
|
|
|
|
# Save new values for subsequent restore |
1791
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object reference |
1792
|
|
|
|
|
|
|
# Returns: Number of times new values have been saved |
1793
|
|
|
|
|
|
|
# Notes: increments SAVE_COUNT flag each time routine is called |
1794
|
|
|
|
|
|
|
sub SaveNewValues($) |
1795
|
|
|
|
|
|
|
{ |
1796
|
1
|
|
|
1
|
1
|
12
|
my $self = shift; |
1797
|
1
|
|
|
|
|
4
|
my $newValues = $$self{NEW_VALUE}; |
1798
|
1
|
|
|
|
|
4
|
my $saveCount = ++$$self{SAVE_COUNT}; |
1799
|
1
|
|
|
|
|
3
|
my $key; |
1800
|
1
|
|
|
|
|
58
|
foreach $key (keys %$newValues) { |
1801
|
113
|
|
|
|
|
164
|
my $nvHash = $$newValues{$key}; |
1802
|
113
|
|
|
|
|
197
|
while ($nvHash) { |
1803
|
|
|
|
|
|
|
# set Save count if not done already |
1804
|
115
|
50
|
|
|
|
238
|
$$nvHash{Save} or $$nvHash{Save} = $saveCount; |
1805
|
115
|
|
|
|
|
225
|
$nvHash = $$nvHash{Next}; |
1806
|
|
|
|
|
|
|
} |
1807
|
|
|
|
|
|
|
} |
1808
|
|
|
|
|
|
|
# initialize hash for saving overwritten new values |
1809
|
1
|
|
|
|
|
9
|
$$self{SAVE_NEW_VALUE} = { }; |
1810
|
|
|
|
|
|
|
# make a copy of the delete group hash |
1811
|
1
|
|
|
|
|
3
|
my %delGrp = %{$$self{DEL_GROUP}}; |
|
1
|
|
|
|
|
6
|
|
1812
|
1
|
|
|
|
|
4
|
$$self{SAVE_DEL_GROUP} = \%delGrp; |
1813
|
1
|
|
|
|
|
5
|
return $saveCount; |
1814
|
|
|
|
|
|
|
} |
1815
|
|
|
|
|
|
|
|
1816
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1817
|
|
|
|
|
|
|
# Restore new values to last saved state |
1818
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object reference |
1819
|
|
|
|
|
|
|
# Notes: Restores saved new values, but currently doesn't restore them in the |
1820
|
|
|
|
|
|
|
# original order, so there may be some minor side-effects when restoring tags |
1821
|
|
|
|
|
|
|
# with overlapping groups. eg) XMP:Identifier, XMP-dc:Identifier |
1822
|
|
|
|
|
|
|
# Also, this doesn't do the right thing for list-type tags which accumulate |
1823
|
|
|
|
|
|
|
# values across a save point |
1824
|
|
|
|
|
|
|
sub RestoreNewValues($) |
1825
|
|
|
|
|
|
|
{ |
1826
|
1
|
|
|
1
|
1
|
12
|
my $self = shift; |
1827
|
1
|
|
|
|
|
3
|
my $newValues = $$self{NEW_VALUE}; |
1828
|
1
|
|
|
|
|
8
|
my $savedValues = $$self{SAVE_NEW_VALUE}; |
1829
|
1
|
|
|
|
|
3
|
my $key; |
1830
|
|
|
|
|
|
|
# 1) remove any new values which don't have the Save flag set |
1831
|
1
|
50
|
|
|
|
6
|
if ($newValues) { |
1832
|
1
|
|
|
|
|
209
|
my @keys = keys %$newValues; |
1833
|
1
|
|
|
|
|
7
|
foreach $key (@keys) { |
1834
|
574
|
|
|
|
|
728
|
my $lastHash; |
1835
|
574
|
|
|
|
|
981
|
my $nvHash = $$newValues{$key}; |
1836
|
574
|
|
|
|
|
933
|
while ($nvHash) { |
1837
|
576
|
100
|
|
|
|
1063
|
if ($$nvHash{Save}) { |
1838
|
25
|
|
|
|
|
37
|
$lastHash = $nvHash; |
1839
|
|
|
|
|
|
|
} else { |
1840
|
|
|
|
|
|
|
# remove this entry from the list |
1841
|
551
|
50
|
|
|
|
1030
|
if ($lastHash) { |
|
|
100
|
|
|
|
|
|
1842
|
0
|
|
|
|
|
0
|
$$lastHash{Next} = $$nvHash{Next}; |
1843
|
|
|
|
|
|
|
} elsif ($$nvHash{Next}) { |
1844
|
2
|
|
|
|
|
8
|
$$newValues{$key} = $$nvHash{Next}; |
1845
|
|
|
|
|
|
|
} else { |
1846
|
549
|
|
|
|
|
794
|
delete $$newValues{$key}; |
1847
|
|
|
|
|
|
|
} |
1848
|
|
|
|
|
|
|
} |
1849
|
576
|
|
|
|
|
2892
|
$nvHash = $$nvHash{Next}; |
1850
|
|
|
|
|
|
|
} |
1851
|
|
|
|
|
|
|
} |
1852
|
|
|
|
|
|
|
} |
1853
|
|
|
|
|
|
|
# 2) restore saved new values |
1854
|
1
|
50
|
|
|
|
7
|
if ($savedValues) { |
1855
|
1
|
50
|
|
|
|
4
|
$newValues or $newValues = $$self{NEW_VALUE} = { }; |
1856
|
1
|
|
|
|
|
153
|
foreach $key (keys %$savedValues) { |
1857
|
90
|
100
|
|
|
|
142
|
if ($$newValues{$key}) { |
1858
|
|
|
|
|
|
|
# add saved values to end of list |
1859
|
2
|
|
|
|
|
10
|
my $nvHash = LastInList($$newValues{$key}); |
1860
|
2
|
|
|
|
|
21
|
$$nvHash{Next} = $$savedValues{$key}; |
1861
|
|
|
|
|
|
|
} else { |
1862
|
88
|
|
|
|
|
177
|
$$newValues{$key} = $$savedValues{$key}; |
1863
|
|
|
|
|
|
|
} |
1864
|
|
|
|
|
|
|
} |
1865
|
1
|
|
|
|
|
20
|
$$self{SAVE_NEW_VALUE} = { }; # reset saved new values |
1866
|
|
|
|
|
|
|
} |
1867
|
|
|
|
|
|
|
# 3) restore delete groups |
1868
|
1
|
|
|
|
|
6
|
my %delGrp = %{$$self{SAVE_DEL_GROUP}}; |
|
1
|
|
|
|
|
9
|
|
1869
|
1
|
|
|
|
|
24
|
$$self{DEL_GROUP} = \%delGrp; |
1870
|
|
|
|
|
|
|
} |
1871
|
|
|
|
|
|
|
|
1872
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1873
|
|
|
|
|
|
|
# Set alternate file for extracting information |
1874
|
|
|
|
|
|
|
# Inputs: 0) ExifTool ref, 1) family 8 group name (of the form "File#" where # is any number) |
1875
|
|
|
|
|
|
|
# 2) alternate file name, or undef to reset |
1876
|
|
|
|
|
|
|
# Returns: 1 on success, or 0 on invalid group name |
1877
|
|
|
|
|
|
|
sub SetAlternateFile($$$) |
1878
|
|
|
|
|
|
|
{ |
1879
|
6
|
|
|
6
|
1
|
74
|
my ($self, $g8, $file) = @_; |
1880
|
6
|
|
|
|
|
33
|
$g8 = ucfirst lc $g8; |
1881
|
6
|
50
|
|
|
|
44
|
return 0 unless $g8 =~ /^File\d+$/; |
1882
|
|
|
|
|
|
|
# keep the same file if already initialized (possibly has metadata extracted) |
1883
|
6
|
50
|
33
|
|
|
55
|
if (not defined $file) { |
|
|
50
|
|
|
|
|
|
1884
|
0
|
|
|
|
|
0
|
delete $$self{ALT_EXIFTOOL}{$g8}; |
1885
|
|
|
|
|
|
|
} elsif (not ($$self{ALT_EXIFTOOL}{$g8} and $$self{ALT_EXIFTOOL}{$g8}{ALT_FILE} eq $file)) { |
1886
|
6
|
|
|
|
|
60
|
my $altExifTool = Image::ExifTool->new; |
1887
|
6
|
|
|
|
|
16
|
$$altExifTool{ALT_FILE} = $file; |
1888
|
6
|
|
|
|
|
24
|
$$self{ALT_EXIFTOOL}{$g8} = $altExifTool; |
1889
|
|
|
|
|
|
|
} |
1890
|
6
|
|
|
|
|
20
|
return 1; |
1891
|
|
|
|
|
|
|
} |
1892
|
|
|
|
|
|
|
|
1893
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1894
|
|
|
|
|
|
|
# Set filesystem time from from FileModifyDate or FileCreateDate tag |
1895
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object reference, 1) file name or file ref |
1896
|
|
|
|
|
|
|
# 2) time (-M or -C) of original file (used for shift; obtained from file if not given) |
1897
|
|
|
|
|
|
|
# 3) tag name to write (undef for 'FileModifyDate') |
1898
|
|
|
|
|
|
|
# 4) flag set if argument 2 has already been converted to Unix seconds |
1899
|
|
|
|
|
|
|
# Returns: 1=time changed OK, 0=nothing done, -1=error setting time |
1900
|
|
|
|
|
|
|
# (increments CHANGED flag and sets corresponding WRITTEN tag) |
1901
|
|
|
|
|
|
|
sub SetFileModifyDate($$;$$$) |
1902
|
|
|
|
|
|
|
{ |
1903
|
0
|
|
|
0
|
1
|
0
|
my ($self, $file, $originalTime, $tag, $isUnixTime) = @_; |
1904
|
0
|
|
|
|
|
0
|
my $nvHash; |
1905
|
0
|
0
|
|
|
|
0
|
$tag = 'FileModifyDate' unless defined $tag; |
1906
|
0
|
|
|
|
|
0
|
my $val = $self->GetNewValue($tag, \$nvHash); |
1907
|
0
|
0
|
|
|
|
0
|
return 0 unless defined $val; |
1908
|
0
|
|
|
|
|
0
|
my $isOverwriting = $self->IsOverwriting($nvHash); |
1909
|
0
|
0
|
|
|
|
0
|
return 0 unless $isOverwriting; |
1910
|
|
|
|
|
|
|
# can currently only set creation date on Windows systems |
1911
|
|
|
|
|
|
|
# (and Mac now too, but that is handled with the MacOS tags) |
1912
|
0
|
0
|
0
|
|
|
0
|
return 0 if $tag eq 'FileCreateDate' and $^O ne 'MSWin32'; |
1913
|
0
|
0
|
|
|
|
0
|
if ($isOverwriting < 0) { # are we shifting time? |
1914
|
|
|
|
|
|
|
# use original time of this file if not specified |
1915
|
0
|
0
|
|
|
|
0
|
unless (defined $originalTime) { |
1916
|
0
|
|
|
|
|
0
|
my ($aTime, $mTime, $cTime) = $self->GetFileTime($file); |
1917
|
0
|
0
|
|
|
|
0
|
$originalTime = ($tag eq 'FileCreateDate') ? $cTime : $mTime; |
1918
|
0
|
0
|
|
|
|
0
|
return 0 unless defined $originalTime; |
1919
|
0
|
|
|
|
|
0
|
$isUnixTime = 1; |
1920
|
|
|
|
|
|
|
} |
1921
|
0
|
0
|
|
|
|
0
|
$originalTime = int($^T - $originalTime*(24*3600) + 0.5) unless $isUnixTime; |
1922
|
0
|
0
|
|
|
|
0
|
return 0 unless $self->IsOverwriting($nvHash, $originalTime); |
1923
|
0
|
|
|
|
|
0
|
$val = $$nvHash{Value}[0]; # get shifted value |
1924
|
|
|
|
|
|
|
} |
1925
|
0
|
|
|
|
|
0
|
my ($aTime, $mTime, $cTime); |
1926
|
0
|
0
|
|
|
|
0
|
if ($tag eq 'FileCreateDate') { |
1927
|
0
|
0
|
|
|
|
0
|
eval { require Win32::API } or $self->WarnOnce("Install Win32::API to set $tag"), return -1; |
|
0
|
|
|
|
|
0
|
|
1928
|
0
|
0
|
|
|
|
0
|
eval { require Win32API::File } or $self->WarnOnce("Install Win32API::File to set $tag"), return -1; |
|
0
|
|
|
|
|
0
|
|
1929
|
0
|
|
|
|
|
0
|
$cTime = $val; |
1930
|
|
|
|
|
|
|
} else { |
1931
|
0
|
|
|
|
|
0
|
$aTime = $mTime = $val; |
1932
|
|
|
|
|
|
|
} |
1933
|
0
|
0
|
|
|
|
0
|
$self->SetFileTime($file, $aTime, $mTime, $cTime, 1) or $self->Warn("Error setting $tag"), return -1; |
1934
|
0
|
|
|
|
|
0
|
++$$self{CHANGED}; |
1935
|
0
|
|
|
|
|
0
|
$$self{WRITTEN}{$tag} = $val; # remember that we wrote this tag |
1936
|
0
|
|
|
|
|
0
|
$self->VerboseValue("+ $tag", $val); |
1937
|
0
|
|
|
|
|
0
|
return 1; |
1938
|
|
|
|
|
|
|
} |
1939
|
|
|
|
|
|
|
|
1940
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1941
|
|
|
|
|
|
|
# Change file name and/or directory from FileName and Directory tags |
1942
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object reference, 1) current file name (including path) |
1943
|
|
|
|
|
|
|
# 2) new name (or undef to build from FileName and Directory tags) |
1944
|
|
|
|
|
|
|
# 3) option: 'HardLink'/'SymLink' to create hard/symbolic link instead of renaming |
1945
|
|
|
|
|
|
|
# 'Test' to only print new file name |
1946
|
|
|
|
|
|
|
# 4) 0 to indicate that a file will no longer exist (used for 'Test' only) |
1947
|
|
|
|
|
|
|
# Returns: 1=name changed OK, 0=nothing changed, -1=error changing name |
1948
|
|
|
|
|
|
|
# (and increments CHANGED flag if filename changed) |
1949
|
|
|
|
|
|
|
# Notes: Will not overwrite existing file. Creates directories as necessary. |
1950
|
|
|
|
|
|
|
sub SetFileName($$;$$$) |
1951
|
|
|
|
|
|
|
{ |
1952
|
1
|
|
|
1
|
1
|
4
|
my ($self, $file, $newName, $opt, $usedFlag) = @_; |
1953
|
1
|
|
|
|
|
3
|
my ($nvHash, $doName, $doDir); |
1954
|
|
|
|
|
|
|
|
1955
|
1
|
50
|
|
|
|
4
|
$opt or $opt = ''; |
1956
|
|
|
|
|
|
|
# determine the new file name |
1957
|
1
|
50
|
|
|
|
5
|
unless (defined $newName) { |
1958
|
1
|
50
|
|
|
|
4
|
if ($opt) { |
1959
|
0
|
0
|
0
|
|
|
0
|
if ($opt eq 'HardLink' or $opt eq 'Link') { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
1960
|
0
|
|
|
|
|
0
|
$newName = $self->GetNewValue('HardLink'); |
1961
|
|
|
|
|
|
|
} elsif ($opt eq 'SymLink') { |
1962
|
0
|
|
|
|
|
0
|
$newName = $self->GetNewValue('SymLink'); |
1963
|
|
|
|
|
|
|
} elsif ($opt eq 'Test') { |
1964
|
0
|
|
|
|
|
0
|
$newName = $self->GetNewValue('TestName'); |
1965
|
|
|
|
|
|
|
} |
1966
|
0
|
0
|
|
|
|
0
|
return 0 unless defined $newName; |
1967
|
|
|
|
|
|
|
} else { |
1968
|
1
|
|
|
|
|
5
|
my $filename = $self->GetNewValue('FileName', \$nvHash); |
1969
|
1
|
50
|
33
|
|
|
23
|
$doName = 1 if defined $filename and $self->IsOverwriting($nvHash, $file); |
1970
|
1
|
|
|
|
|
10
|
my $dir = $self->GetNewValue('Directory', \$nvHash); |
1971
|
1
|
50
|
33
|
|
|
5
|
$doDir = 1 if defined $dir and $self->IsOverwriting($nvHash, $file); |
1972
|
1
|
50
|
33
|
|
|
5
|
return 0 unless $doName or $doDir; # nothing to do |
1973
|
1
|
50
|
|
|
|
3
|
if ($doName) { |
1974
|
1
|
|
|
|
|
5
|
$newName = GetNewFileName($file, $filename); |
1975
|
1
|
50
|
|
|
|
5
|
$newName = GetNewFileName($newName, $dir) if $doDir; |
1976
|
|
|
|
|
|
|
} else { |
1977
|
0
|
|
|
|
|
0
|
$newName = GetNewFileName($file, $dir); |
1978
|
|
|
|
|
|
|
} |
1979
|
|
|
|
|
|
|
} |
1980
|
|
|
|
|
|
|
} |
1981
|
|
|
|
|
|
|
# validate new file name in Windows |
1982
|
1
|
50
|
|
|
|
5
|
if ($^O eq 'MSWin32') { |
1983
|
0
|
0
|
|
|
|
0
|
if ($newName =~ /[\0-\x1f<>"|*]/) { |
1984
|
0
|
|
|
|
|
0
|
$self->Warn('New file name not allowed in Windows (contains reserved characters)'); |
1985
|
0
|
|
|
|
|
0
|
return -1; |
1986
|
|
|
|
|
|
|
} |
1987
|
0
|
0
|
0
|
|
|
0
|
if ($newName =~ /:/ and $newName !~ /^[A-Z]:[^:]*$/i) { |
1988
|
0
|
|
|
|
|
0
|
$self->Warn("New file name not allowed in Windows (contains ':')"); |
1989
|
0
|
|
|
|
|
0
|
return -1; |
1990
|
|
|
|
|
|
|
} |
1991
|
0
|
0
|
0
|
|
|
0
|
if ($newName =~ /\?/ and $newName !~ m{^[\\/]{2}\?[\\/][^?]*$}) { |
1992
|
0
|
|
|
|
|
0
|
$self->Warn("New file name not allowed in Windows (contains '?')"); |
1993
|
0
|
|
|
|
|
0
|
return -1; |
1994
|
|
|
|
|
|
|
} |
1995
|
0
|
0
|
|
|
|
0
|
if ($newName =~ m{(^|[\\/])(CON|PRN|AUX|NUL|COM[1-9]|LPT[1-9])(\.[^.]*)?$}i) { |
1996
|
0
|
|
|
|
|
0
|
$self->Warn('New file name not allowed in Windows (reserved device name)'); |
1997
|
0
|
|
|
|
|
0
|
return -1; |
1998
|
|
|
|
|
|
|
} |
1999
|
0
|
0
|
|
|
|
0
|
if ($newName =~ /([. ])$/) { |
2000
|
0
|
0
|
|
|
|
0
|
$self->Warn("New file name not recommended for Windows (ends with '${1}')", 2) and return -1; |
2001
|
|
|
|
|
|
|
} |
2002
|
0
|
0
|
0
|
|
|
0
|
if (length $newName > 259 and $newName !~ /\?/) { |
2003
|
0
|
0
|
|
|
|
0
|
$self->Warn('New file name not recommended for Windows (exceeds 260 chars)', 2) and return -1; |
2004
|
|
|
|
|
|
|
} |
2005
|
|
|
|
|
|
|
} else { |
2006
|
1
|
|
|
|
|
4
|
$newName =~ tr/\0//d; # make sure name doesn't contain nulls |
2007
|
|
|
|
|
|
|
} |
2008
|
|
|
|
|
|
|
# protect against empty file name |
2009
|
1
|
50
|
|
|
|
6
|
length $newName or $self->Warn('New file name is empty'), return -1; |
2010
|
|
|
|
|
|
|
# don't replace existing file |
2011
|
1
|
0
|
0
|
|
|
6
|
if ($self->Exists($newName) and (not defined $usedFlag or $usedFlag)) { |
|
|
|
33
|
|
|
|
|
2012
|
0
|
0
|
0
|
|
|
0
|
if ($file ne $newName or $opt =~ /Link$/) { |
2013
|
|
|
|
|
|
|
# allow for case-insensitive filesystem |
2014
|
0
|
0
|
0
|
|
|
0
|
if ($opt =~ /Link$/ or not $self->IsSameFile($file, $newName)) { |
2015
|
0
|
|
|
|
|
0
|
$self->Warn("File '${newName}' already exists"); |
2016
|
0
|
|
|
|
|
0
|
return -1; |
2017
|
|
|
|
|
|
|
} |
2018
|
|
|
|
|
|
|
} else { |
2019
|
0
|
|
|
|
|
0
|
$self->Warn('File name is unchanged'); |
2020
|
0
|
|
|
|
|
0
|
return 0; |
2021
|
|
|
|
|
|
|
} |
2022
|
|
|
|
|
|
|
} |
2023
|
1
|
50
|
|
|
|
7
|
if ($opt eq 'Test') { |
2024
|
0
|
|
|
|
|
0
|
my $out = $$self{OPTIONS}{TextOut}; |
2025
|
0
|
|
|
|
|
0
|
print $out "'${file}' --> '${newName}'\n"; |
2026
|
0
|
|
|
|
|
0
|
return 1; |
2027
|
|
|
|
|
|
|
} |
2028
|
|
|
|
|
|
|
# create directory for new file if necessary |
2029
|
1
|
|
|
|
|
2
|
my $result; |
2030
|
1
|
50
|
|
|
|
8
|
if (($result = $self->CreateDirectory($newName)) != 0) { |
2031
|
0
|
0
|
|
|
|
0
|
if ($result < 0) { |
2032
|
0
|
|
|
|
|
0
|
$self->Warn("Error creating directory for '${newName}'"); |
2033
|
0
|
|
|
|
|
0
|
return -1; |
2034
|
|
|
|
|
|
|
} |
2035
|
0
|
|
|
|
|
0
|
$self->VPrint(0, "Created directory for '${newName}'\n"); |
2036
|
|
|
|
|
|
|
} |
2037
|
1
|
50
|
33
|
|
|
11
|
if ($opt eq 'HardLink' or $opt eq 'Link') { |
|
|
50
|
|
|
|
|
|
2038
|
0
|
0
|
|
|
|
0
|
unless (link $file, $newName) { |
2039
|
0
|
|
|
|
|
0
|
$self->Warn("Error creating hard link '${newName}'"); |
2040
|
0
|
|
|
|
|
0
|
return -1; |
2041
|
|
|
|
|
|
|
} |
2042
|
0
|
|
|
|
|
0
|
++$$self{CHANGED}; |
2043
|
0
|
|
|
|
|
0
|
$self->VerboseValue('+ HardLink', $newName); |
2044
|
0
|
|
|
|
|
0
|
return 1; |
2045
|
|
|
|
|
|
|
} elsif ($opt eq 'SymLink') { |
2046
|
0
|
0
|
|
|
|
0
|
$^O eq 'MSWin32' and $self->Warn('SymLink not supported in Windows'), return -1; |
2047
|
0
|
|
|
|
|
0
|
$newName =~ s(^\./)(); # remove leading "./" from link name if it exists |
2048
|
|
|
|
|
|
|
# path to linked file must be relative to the $newName directory, but $file |
2049
|
|
|
|
|
|
|
# is relative to the current directory, so convert it to an absolute path |
2050
|
|
|
|
|
|
|
# if using a relative directory and $newName isn't in the current directory |
2051
|
0
|
0
|
0
|
|
|
0
|
if ($file !~ m(^/) and $newName =~ m(/)) { |
2052
|
0
|
0
|
|
|
|
0
|
unless (eval { require Cwd }) { |
|
0
|
|
|
|
|
0
|
|
2053
|
0
|
|
|
|
|
0
|
$self->Warn('Install Cwd to make symlinks to other directories'); |
2054
|
0
|
|
|
|
|
0
|
return -1; |
2055
|
|
|
|
|
|
|
} |
2056
|
0
|
|
|
|
|
0
|
$file = eval { Cwd::abs_path($file) }; |
|
0
|
|
|
|
|
0
|
|
2057
|
0
|
0
|
|
|
|
0
|
unless (defined $file) { |
2058
|
0
|
|
|
|
|
0
|
$self->Warn('Error in Cwd::abs_path when creating symlink'); |
2059
|
0
|
|
|
|
|
0
|
return -1; |
2060
|
|
|
|
|
|
|
} |
2061
|
|
|
|
|
|
|
} |
2062
|
0
|
0
|
|
|
|
0
|
unless (eval { symlink $file, $newName } ) { |
|
0
|
|
|
|
|
0
|
|
2063
|
0
|
|
|
|
|
0
|
$self->Warn("Error creating symbolic link '${newName}'"); |
2064
|
0
|
|
|
|
|
0
|
return -1; |
2065
|
|
|
|
|
|
|
} |
2066
|
0
|
|
|
|
|
0
|
++$$self{CHANGED}; |
2067
|
0
|
|
|
|
|
0
|
$self->VerboseValue('+ SymLink', $newName); |
2068
|
0
|
|
|
|
|
0
|
return 1; |
2069
|
|
|
|
|
|
|
} |
2070
|
|
|
|
|
|
|
# attempt to rename the file |
2071
|
1
|
50
|
|
|
|
8
|
unless ($self->Rename($file, $newName)) { |
2072
|
0
|
|
|
|
|
0
|
local (*EXIFTOOL_SFN_IN, *EXIFTOOL_SFN_OUT); |
2073
|
|
|
|
|
|
|
# renaming didn't work, so copy the file instead |
2074
|
0
|
0
|
|
|
|
0
|
unless ($self->Open(\*EXIFTOOL_SFN_IN, $file)) { |
2075
|
0
|
|
|
|
|
0
|
$self->Error("Error opening '${file}'"); |
2076
|
0
|
|
|
|
|
0
|
return -1; |
2077
|
|
|
|
|
|
|
} |
2078
|
0
|
0
|
|
|
|
0
|
unless ($self->Open(\*EXIFTOOL_SFN_OUT, $newName, '>')) { |
2079
|
0
|
|
|
|
|
0
|
close EXIFTOOL_SFN_IN; |
2080
|
0
|
|
|
|
|
0
|
$self->Error("Error creating '${newName}'"); |
2081
|
0
|
|
|
|
|
0
|
return -1; |
2082
|
|
|
|
|
|
|
} |
2083
|
0
|
|
|
|
|
0
|
binmode EXIFTOOL_SFN_IN; |
2084
|
0
|
|
|
|
|
0
|
binmode EXIFTOOL_SFN_OUT; |
2085
|
0
|
|
|
|
|
0
|
my ($buff, $err); |
2086
|
0
|
|
|
|
|
0
|
while (read EXIFTOOL_SFN_IN, $buff, 65536) { |
2087
|
0
|
0
|
|
|
|
0
|
print EXIFTOOL_SFN_OUT $buff or $err = 1; |
2088
|
|
|
|
|
|
|
} |
2089
|
0
|
0
|
|
|
|
0
|
close EXIFTOOL_SFN_OUT or $err = 1; |
2090
|
0
|
|
|
|
|
0
|
close EXIFTOOL_SFN_IN; |
2091
|
0
|
0
|
|
|
|
0
|
if ($err) { |
2092
|
0
|
|
|
|
|
0
|
$self->Unlink($newName); # erase bad output file |
2093
|
0
|
|
|
|
|
0
|
$self->Error("Error writing '${newName}'"); |
2094
|
0
|
|
|
|
|
0
|
return -1; |
2095
|
|
|
|
|
|
|
} |
2096
|
|
|
|
|
|
|
# preserve modification time |
2097
|
0
|
|
|
|
|
0
|
my ($aTime, $mTime, $cTime) = $self->GetFileTime($file); |
2098
|
0
|
|
|
|
|
0
|
$self->SetFileTime($newName, $aTime, $mTime, $cTime); |
2099
|
|
|
|
|
|
|
# remove the original file |
2100
|
0
|
0
|
|
|
|
0
|
$self->Unlink($file) or $self->Warn('Error removing old file'); |
2101
|
|
|
|
|
|
|
} |
2102
|
1
|
|
|
|
|
5
|
$$self{NewName} = $newName; # remember new file name |
2103
|
1
|
|
|
|
|
6
|
++$$self{CHANGED}; |
2104
|
1
|
|
|
|
|
9
|
$self->VerboseValue('+ FileName', $newName); |
2105
|
1
|
|
|
|
|
5
|
return 1; |
2106
|
|
|
|
|
|
|
} |
2107
|
|
|
|
|
|
|
|
2108
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
2109
|
|
|
|
|
|
|
# Set file permissions, group/user id and various MDItem tags from new tag values |
2110
|
|
|
|
|
|
|
# Inputs: 0) ExifTool ref, 1) file name or glob (must be a name for MDItem tags) |
2111
|
|
|
|
|
|
|
# Returns: 1=something was set OK, 0=didn't try, -1=error (and warning set) |
2112
|
|
|
|
|
|
|
# Notes: There may be errors even if 1 is returned |
2113
|
|
|
|
|
|
|
sub SetSystemTags($$) |
2114
|
|
|
|
|
|
|
{ |
2115
|
223
|
|
|
223
|
0
|
874
|
my ($self, $file) = @_; |
2116
|
223
|
|
|
|
|
649
|
my $result = 0; |
2117
|
|
|
|
|
|
|
|
2118
|
223
|
|
|
|
|
926
|
my $perm = $self->GetNewValue('FilePermissions'); |
2119
|
223
|
50
|
|
|
|
1238
|
if (defined $perm) { |
2120
|
0
|
0
|
|
|
|
0
|
if (eval { chmod($perm & 07777, $file) }) { |
|
0
|
|
|
|
|
0
|
|
2121
|
0
|
|
|
|
|
0
|
$self->VerboseValue('+ FilePermissions', $perm); |
2122
|
0
|
|
|
|
|
0
|
$result = 1; |
2123
|
|
|
|
|
|
|
} else { |
2124
|
0
|
|
|
|
|
0
|
$self->WarnOnce('Error setting FilePermissions'); |
2125
|
0
|
|
|
|
|
0
|
$result = -1; |
2126
|
|
|
|
|
|
|
} |
2127
|
|
|
|
|
|
|
} |
2128
|
223
|
|
|
|
|
883
|
my $uid = $self->GetNewValue('FileUserID'); |
2129
|
223
|
|
|
|
|
1346
|
my $gid = $self->GetNewValue('FileGroupID'); |
2130
|
223
|
50
|
33
|
|
|
2344
|
if (defined $uid or defined $gid) { |
2131
|
0
|
0
|
|
|
|
0
|
defined $uid or $uid = -1; |
2132
|
0
|
0
|
|
|
|
0
|
defined $gid or $gid = -1; |
2133
|
0
|
0
|
|
|
|
0
|
if (eval { chown($uid, $gid, $file) }) { |
|
0
|
|
|
|
|
0
|
|
2134
|
0
|
0
|
|
|
|
0
|
$self->VerboseValue('+ FileUserID', $uid) if $uid >= 0; |
2135
|
0
|
0
|
|
|
|
0
|
$self->VerboseValue('+ FileGroupID', $gid) if $gid >= 0; |
2136
|
0
|
|
|
|
|
0
|
$result = 1; |
2137
|
|
|
|
|
|
|
} else { |
2138
|
0
|
|
|
|
|
0
|
$self->WarnOnce('Error setting FileGroup/UserID'); |
2139
|
0
|
0
|
|
|
|
0
|
$result = -1 unless $result; |
2140
|
|
|
|
|
|
|
} |
2141
|
|
|
|
|
|
|
} |
2142
|
223
|
|
|
|
|
670
|
my $tag; |
2143
|
223
|
|
|
|
|
828
|
foreach $tag (@writableMacOSTags) { |
2144
|
1338
|
|
|
|
|
2136
|
my $nvHash; |
2145
|
1338
|
|
|
|
|
3312
|
my $val = $self->GetNewValue($tag, \$nvHash); |
2146
|
1338
|
50
|
|
|
|
4939
|
next unless $nvHash; |
2147
|
0
|
0
|
|
|
|
0
|
if ($^O eq 'darwin') { |
|
|
0
|
|
|
|
|
|
2148
|
0
|
0
|
|
|
|
0
|
ref $file and $self->Warn('Setting MDItem tags requires a file name'), last; |
2149
|
0
|
|
|
|
|
0
|
require Image::ExifTool::MacOS; |
2150
|
0
|
|
|
|
|
0
|
my $res = Image::ExifTool::MacOS::SetMacOSTags($self, $file, \@writableMacOSTags); |
2151
|
0
|
0
|
0
|
|
|
0
|
$result = $res if $res == 1 or not $result; |
2152
|
0
|
|
|
|
|
0
|
last; |
2153
|
|
|
|
|
|
|
} elsif ($tag ne 'FileCreateDate') { |
2154
|
0
|
|
|
|
|
0
|
$self->WarnOnce('Can only set MDItem tags on OS X'); |
2155
|
0
|
|
|
|
|
0
|
last; |
2156
|
|
|
|
|
|
|
} |
2157
|
|
|
|
|
|
|
} |
2158
|
|
|
|
|
|
|
# delete Windows Zone.Identifier if specified |
2159
|
223
|
|
|
|
|
1536
|
my $zhash = $self->GetNewValueHash($Image::ExifTool::Extra{ZoneIdentifier}); |
2160
|
223
|
50
|
|
|
|
1411
|
if ($zhash) { |
2161
|
0
|
|
|
|
|
0
|
my $res = -1; |
2162
|
0
|
0
|
|
|
|
0
|
if ($^O ne 'MSWin32') { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2163
|
0
|
|
|
|
|
0
|
$self->Warn('ZoneIdentifer is a Windows-only tag'); |
2164
|
|
|
|
|
|
|
} elsif (ref $file) { |
2165
|
0
|
|
|
|
|
0
|
$self->Warn('Writing ZoneIdentifer requires a file name'); |
2166
|
|
|
|
|
|
|
} elsif (defined $self->GetNewValue('ZoneIdentifier', \$zhash)) { |
2167
|
0
|
|
|
|
|
0
|
$self->Warn('ZoneIndentifier may only be delted'); |
2168
|
0
|
|
|
|
|
0
|
} elsif (not eval { require Win32API::File }) { |
2169
|
0
|
|
|
|
|
0
|
$self->Warn('Install Win32API::File to write ZoneIdentifier'); |
2170
|
|
|
|
|
|
|
} else { |
2171
|
0
|
|
|
|
|
0
|
my ($wattr, $wide); |
2172
|
0
|
|
|
|
|
0
|
my $zfile = "${file}:Zone.Identifier"; |
2173
|
0
|
0
|
|
|
|
0
|
if ($self->EncodeFileName($zfile)) { |
2174
|
0
|
|
|
|
|
0
|
$wide = 1; |
2175
|
0
|
|
|
|
|
0
|
$wattr = eval { Win32API::File::GetFileAttributesW($zfile) }; |
|
0
|
|
|
|
|
0
|
|
2176
|
|
|
|
|
|
|
} else { |
2177
|
0
|
|
|
|
|
0
|
$wattr = eval { Win32API::File::GetFileAttributes($zfile) }; |
|
0
|
|
|
|
|
0
|
|
2178
|
|
|
|
|
|
|
} |
2179
|
0
|
0
|
|
|
|
0
|
if ($wattr == Win32API::File::INVALID_FILE_ATTRIBUTES()) { |
|
|
0
|
|
|
|
|
|
2180
|
0
|
|
|
|
|
0
|
$res = 0; # file doesn't exist, nothing to do |
2181
|
|
|
|
|
|
|
} elsif ($wattr & Win32API::File::FILE_ATTRIBUTE_READONLY()) { |
2182
|
0
|
|
|
|
|
0
|
$self->Warn('Zone.Identifier stream is read-only'); |
2183
|
|
|
|
|
|
|
} else { |
2184
|
0
|
0
|
|
|
|
0
|
if ($wide) { |
2185
|
0
|
0
|
|
|
|
0
|
$res = 1 if eval { Win32API::File::DeleteFileW($zfile) }; |
|
0
|
|
|
|
|
0
|
|
2186
|
|
|
|
|
|
|
} else { |
2187
|
0
|
0
|
|
|
|
0
|
$res = 1 if eval { Win32API::File::DeleteFile($zfile) }; |
|
0
|
|
|
|
|
0
|
|
2188
|
|
|
|
|
|
|
} |
2189
|
0
|
0
|
|
|
|
0
|
if ($res > 0) { |
2190
|
0
|
|
|
|
|
0
|
$self->VPrint(0, " Deleting Zone.Identifier stream\n"); |
2191
|
|
|
|
|
|
|
} else { |
2192
|
0
|
|
|
|
|
0
|
$self->Warn('Error deleting Zone.Identifier stream'); |
2193
|
|
|
|
|
|
|
} |
2194
|
|
|
|
|
|
|
} |
2195
|
|
|
|
|
|
|
} |
2196
|
0
|
0
|
0
|
|
|
0
|
$result = $res if $res == 1 or not $result; |
2197
|
|
|
|
|
|
|
} |
2198
|
223
|
|
|
|
|
1166
|
return $result; |
2199
|
|
|
|
|
|
|
} |
2200
|
|
|
|
|
|
|
|
2201
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
2202
|
|
|
|
|
|
|
# Write information back to file |
2203
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object reference, |
2204
|
|
|
|
|
|
|
# 1) input filename, file ref, RAF ref, or scalar ref (or '' or undef to create from scratch) |
2205
|
|
|
|
|
|
|
# 2) output filename, file ref, or scalar ref (or undef to overwrite) |
2206
|
|
|
|
|
|
|
# 3) optional output file type (required only if input file is not specified |
2207
|
|
|
|
|
|
|
# and output file is a reference) |
2208
|
|
|
|
|
|
|
# Returns: 1=file written OK, 2=file written but no changes made, 0=file write error |
2209
|
|
|
|
|
|
|
sub WriteInfo($$;$$) |
2210
|
|
|
|
|
|
|
{ |
2211
|
236
|
|
|
236
|
1
|
21001
|
local ($_, *EXIFTOOL_FILE2, *EXIFTOOL_OUTFILE); |
2212
|
236
|
|
|
|
|
1194
|
my ($self, $infile, $outfile, $outType) = @_; |
2213
|
236
|
|
|
|
|
1648
|
my (@fileTypeList, $fileType, $tiffType, $hdr, $seekErr, $type, $tmpfile); |
2214
|
236
|
|
|
|
|
0
|
my ($inRef, $outRef, $closeIn, $closeOut, $outPos, $outBuff, $eraseIn, $raf, $fileExt); |
2215
|
236
|
|
|
|
|
0
|
my ($hardLink, $symLink, $testName); |
2216
|
236
|
|
|
|
|
885
|
my $oldRaf = $$self{RAF}; |
2217
|
236
|
|
|
|
|
592
|
my $rtnVal = 0; |
2218
|
|
|
|
|
|
|
|
2219
|
|
|
|
|
|
|
# initialize member variables |
2220
|
236
|
|
|
|
|
1572
|
$self->Init(); |
2221
|
236
|
|
|
|
|
987
|
$$self{IsWriting} = 1; |
2222
|
|
|
|
|
|
|
|
2223
|
|
|
|
|
|
|
# first, save original file modify date if necessary |
2224
|
|
|
|
|
|
|
# (do this now in case we are modifying file in place and shifting date) |
2225
|
236
|
|
|
|
|
814
|
my ($nvHash, $nvHash2, $originalTime, $createTime); |
2226
|
236
|
|
|
|
|
1492
|
my $setModDate = defined $self->GetNewValue('FileModifyDate', \$nvHash); |
2227
|
236
|
|
|
|
|
1054
|
my $setCreateDate = defined $self->GetNewValue('FileCreateDate', \$nvHash2); |
2228
|
236
|
|
|
|
|
1093
|
my ($aTime, $mTime, $cTime); |
2229
|
236
|
0
|
33
|
|
|
1522
|
if ($setModDate and $self->IsOverwriting($nvHash) < 0 and |
|
|
|
33
|
|
|
|
|
|
|
|
0
|
|
|
|
|
2230
|
|
|
|
|
|
|
defined $infile and ref $infile ne 'SCALAR') |
2231
|
|
|
|
|
|
|
{ |
2232
|
0
|
|
|
|
|
0
|
($aTime, $mTime, $cTime) = $self->GetFileTime($infile); |
2233
|
0
|
|
|
|
|
0
|
$originalTime = $mTime; |
2234
|
|
|
|
|
|
|
} |
2235
|
236
|
0
|
33
|
|
|
1166
|
if ($setCreateDate and $self->IsOverwriting($nvHash2) < 0 and |
|
|
|
33
|
|
|
|
|
|
|
|
0
|
|
|
|
|
2236
|
|
|
|
|
|
|
defined $infile and ref $infile ne 'SCALAR') |
2237
|
|
|
|
|
|
|
{ |
2238
|
0
|
0
|
|
|
|
0
|
($aTime, $mTime, $cTime) = $self->GetFileTime($infile) unless defined $cTime; |
2239
|
0
|
|
|
|
|
0
|
$createTime = $cTime; |
2240
|
|
|
|
|
|
|
} |
2241
|
|
|
|
|
|
|
# |
2242
|
|
|
|
|
|
|
# do quick in-place change of file dir/name or date if that is all we are doing |
2243
|
|
|
|
|
|
|
# |
2244
|
236
|
|
|
|
|
1312
|
my ($numNew, $numPseudo) = $self->CountNewValues(); |
2245
|
236
|
100
|
66
|
|
|
1315
|
if (not defined $outfile and defined $infile) { |
2246
|
4
|
|
|
|
|
18
|
$hardLink = $self->GetNewValue('HardLink'); |
2247
|
4
|
|
|
|
|
23
|
$symLink = $self->GetNewValue('SymLink'); |
2248
|
4
|
|
|
|
|
35
|
$testName = $self->GetNewValue('TestName'); |
2249
|
4
|
50
|
33
|
|
|
41
|
undef $hardLink if defined $hardLink and not length $hardLink; |
2250
|
4
|
50
|
33
|
|
|
20
|
undef $symLink if defined $symLink and not length $symLink; |
2251
|
4
|
50
|
33
|
|
|
24
|
undef $testName if defined $testName and not length $testName; |
2252
|
4
|
|
|
|
|
15
|
my $newFileName = $self->GetNewValue('FileName', \$nvHash); |
2253
|
4
|
|
|
|
|
22
|
my $newDir = $self->GetNewValue('Directory'); |
2254
|
4
|
50
|
33
|
|
|
38
|
if (defined $newDir and length $newDir) { |
2255
|
0
|
0
|
|
|
|
0
|
$newDir .= '/' unless $newDir =~ m{/$}; |
2256
|
|
|
|
|
|
|
} else { |
2257
|
4
|
|
|
|
|
8
|
undef $newDir; |
2258
|
|
|
|
|
|
|
} |
2259
|
4
|
100
|
33
|
|
|
33
|
if ($numNew == $numPseudo) { |
|
|
50
|
|
|
|
|
|
2260
|
1
|
|
|
|
|
3
|
$rtnVal = 2; |
2261
|
1
|
50
|
33
|
|
|
10
|
if ((defined $newFileName or defined $newDir) and not ref $infile) { |
|
|
|
33
|
|
|
|
|
2262
|
1
|
|
|
|
|
8
|
my $result = $self->SetFileName($infile); |
2263
|
1
|
50
|
|
|
|
5
|
if ($result > 0) { |
|
|
0
|
|
|
|
|
|
2264
|
1
|
|
|
|
|
3
|
$infile = $$self{NewName}; # file name changed |
2265
|
1
|
|
|
|
|
4
|
$rtnVal = 1; |
2266
|
|
|
|
|
|
|
} elsif ($result < 0) { |
2267
|
0
|
|
|
|
|
0
|
return 0; # don't try to do anything else |
2268
|
|
|
|
|
|
|
} |
2269
|
|
|
|
|
|
|
} |
2270
|
1
|
50
|
33
|
|
|
7
|
if (not ref $infile or UNIVERSAL::isa($infile,'GLOB')) { |
2271
|
1
|
50
|
0
|
|
|
4
|
$self->SetFileModifyDate($infile) > 0 and $rtnVal = 1 if $setModDate; |
2272
|
1
|
50
|
0
|
|
|
4
|
$self->SetFileModifyDate($infile, undef, 'FileCreateDate') > 0 and $rtnVal = 1 if $setCreateDate; |
2273
|
1
|
50
|
|
|
|
6
|
$self->SetSystemTags($infile) > 0 and $rtnVal = 1; |
2274
|
|
|
|
|
|
|
} |
2275
|
1
|
50
|
33
|
|
|
16
|
if (defined $hardLink or defined $symLink or defined $testName) { |
|
|
|
33
|
|
|
|
|
2276
|
0
|
0
|
0
|
|
|
0
|
$hardLink and $self->SetFileName($infile, $hardLink, 'HardLink') and $rtnVal = 1; |
2277
|
0
|
0
|
0
|
|
|
0
|
$symLink and $self->SetFileName($infile, $symLink, 'SymLink') and $rtnVal = 1; |
2278
|
0
|
0
|
0
|
|
|
0
|
$testName and $self->SetFileName($infile, $testName, 'Test') and $rtnVal = 1; |
2279
|
|
|
|
|
|
|
} |
2280
|
1
|
|
|
|
|
7
|
return $rtnVal; |
2281
|
|
|
|
|
|
|
} elsif (defined $newFileName and length $newFileName) { |
2282
|
|
|
|
|
|
|
# can't simply rename file, so just set the output name if new FileName |
2283
|
|
|
|
|
|
|
# --> in this case, must erase original copy |
2284
|
0
|
0
|
|
|
|
0
|
if (ref $infile) { |
|
|
0
|
|
|
|
|
|
2285
|
0
|
|
|
|
|
0
|
$outfile = $newFileName; |
2286
|
|
|
|
|
|
|
# can't delete original |
2287
|
|
|
|
|
|
|
} elsif ($self->IsOverwriting($nvHash, $infile)) { |
2288
|
0
|
|
|
|
|
0
|
$outfile = GetNewFileName($infile, $newFileName); |
2289
|
0
|
|
|
|
|
0
|
$eraseIn = 1; # delete original |
2290
|
|
|
|
|
|
|
} |
2291
|
|
|
|
|
|
|
} |
2292
|
|
|
|
|
|
|
# set new directory if specified |
2293
|
3
|
50
|
|
|
|
16
|
if (defined $newDir) { |
2294
|
0
|
0
|
0
|
|
|
0
|
$outfile = $infile unless defined $outfile or ref $infile; |
2295
|
0
|
0
|
|
|
|
0
|
if (defined $outfile) { |
2296
|
0
|
|
|
|
|
0
|
$outfile = GetNewFileName($outfile, $newDir); |
2297
|
0
|
0
|
|
|
|
0
|
$eraseIn = 1 unless ref $infile; |
2298
|
|
|
|
|
|
|
} |
2299
|
|
|
|
|
|
|
} |
2300
|
|
|
|
|
|
|
} |
2301
|
|
|
|
|
|
|
# |
2302
|
|
|
|
|
|
|
# set up input file |
2303
|
|
|
|
|
|
|
# |
2304
|
235
|
100
|
66
|
|
|
2212
|
if (ref $infile) { |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
2305
|
5
|
|
|
|
|
12
|
$inRef = $infile; |
2306
|
5
|
100
|
33
|
|
|
66
|
if (UNIVERSAL::isa($inRef,'GLOB')) { |
|
|
50
|
33
|
|
|
|
|
|
|
50
|
|
|
|
|
|
2307
|
1
|
|
|
|
|
14
|
seek($inRef, 0, 0); # make sure we are at the start of the file |
2308
|
|
|
|
|
|
|
} elsif (UNIVERSAL::isa($inRef,'File::RandomAccess')) { |
2309
|
0
|
|
|
|
|
0
|
$inRef->Seek(0); |
2310
|
0
|
|
|
|
|
0
|
$raf = $inRef; |
2311
|
|
|
|
|
|
|
} elsif ($] >= 5.006 and (eval { require Encode; Encode::is_utf8($$inRef) } or $@)) { |
2312
|
|
|
|
|
|
|
# convert image data from UTF-8 to character stream if necessary |
2313
|
0
|
0
|
|
|
|
0
|
my $buff = $@ ? pack('C*',unpack($] < 5.010000 ? 'U0C*' : 'C0C*',$$inRef)) : Encode::encode('utf8',$$inRef); |
|
|
0
|
|
|
|
|
|
2314
|
0
|
0
|
|
|
|
0
|
if (defined $outfile) { |
2315
|
0
|
|
|
|
|
0
|
$inRef = \$buff; |
2316
|
|
|
|
|
|
|
} else { |
2317
|
0
|
|
|
|
|
0
|
$$inRef = $buff; |
2318
|
|
|
|
|
|
|
} |
2319
|
|
|
|
|
|
|
} |
2320
|
|
|
|
|
|
|
} elsif (defined $infile and $infile ne '') { |
2321
|
|
|
|
|
|
|
# write to a temporary file if no output file given |
2322
|
207
|
100
|
|
|
|
811
|
$outfile = $tmpfile = "${infile}_exiftool_tmp" unless defined $outfile; |
2323
|
207
|
50
|
|
|
|
1529
|
if ($self->Open(\*EXIFTOOL_FILE2, $infile)) { |
2324
|
207
|
|
|
|
|
1767
|
$fileExt = GetFileExtension($infile); |
2325
|
207
|
|
|
|
|
1246
|
$fileType = GetFileType($infile); |
2326
|
207
|
|
|
|
|
901
|
@fileTypeList = GetFileType($infile); |
2327
|
207
|
|
|
|
|
968
|
$tiffType = $$self{FILE_EXT} = GetFileExtension($infile); |
2328
|
207
|
|
|
|
|
2370
|
$self->VPrint(0, "Rewriting $infile...\n"); |
2329
|
207
|
|
|
|
|
670
|
$inRef = \*EXIFTOOL_FILE2; |
2330
|
207
|
|
|
|
|
763
|
$closeIn = 1; # we must close the file since we opened it |
2331
|
|
|
|
|
|
|
} else { |
2332
|
0
|
|
|
|
|
0
|
$self->Error('Error opening file'); |
2333
|
0
|
|
|
|
|
0
|
return 0; |
2334
|
|
|
|
|
|
|
} |
2335
|
|
|
|
|
|
|
} elsif (not defined $outfile) { |
2336
|
0
|
|
|
|
|
0
|
$self->Error("WriteInfo(): Must specify infile or outfile\n"); |
2337
|
0
|
|
|
|
|
0
|
return 0; |
2338
|
|
|
|
|
|
|
} else { |
2339
|
|
|
|
|
|
|
# create file from scratch |
2340
|
23
|
100
|
66
|
|
|
282
|
$outType = GetFileExtension($outfile) unless $outType or ref $outfile; |
2341
|
23
|
50
|
|
|
|
193
|
if (CanCreate($outType)) { |
|
|
0
|
|
|
|
|
|
2342
|
23
|
50
|
|
|
|
182
|
if ($$self{OPTIONS}{WriteMode} =~ /g/i) { |
2343
|
23
|
|
|
|
|
77
|
$fileType = $tiffType = $outType; # use output file type if no input file |
2344
|
23
|
|
|
|
|
86
|
$infile = "$fileType file"; # make bogus file name |
2345
|
23
|
|
|
|
|
176
|
$self->VPrint(0, "Creating $infile...\n"); |
2346
|
23
|
|
|
|
|
90
|
$inRef = \ ''; # set $inRef to reference to empty data |
2347
|
|
|
|
|
|
|
} else { |
2348
|
0
|
|
|
|
|
0
|
$self->Error("Not creating new $outType file (disallowed by WriteMode)"); |
2349
|
0
|
|
|
|
|
0
|
return 0; |
2350
|
|
|
|
|
|
|
} |
2351
|
|
|
|
|
|
|
} elsif ($outType) { |
2352
|
0
|
|
|
|
|
0
|
$self->Error("Can't create $outType files"); |
2353
|
0
|
|
|
|
|
0
|
return 0; |
2354
|
|
|
|
|
|
|
} else { |
2355
|
0
|
|
|
|
|
0
|
$self->Error("Can't create file (unknown type)"); |
2356
|
0
|
|
|
|
|
0
|
return 0; |
2357
|
|
|
|
|
|
|
} |
2358
|
|
|
|
|
|
|
} |
2359
|
235
|
100
|
|
|
|
1137
|
unless (@fileTypeList) { |
2360
|
29
|
100
|
|
|
|
107
|
if ($fileType) { |
2361
|
23
|
|
|
|
|
86
|
@fileTypeList = ( $fileType ); |
2362
|
|
|
|
|
|
|
} else { |
2363
|
6
|
|
|
|
|
155
|
@fileTypeList = @fileTypes; |
2364
|
6
|
|
|
|
|
28
|
$tiffType = 'TIFF'; |
2365
|
|
|
|
|
|
|
} |
2366
|
|
|
|
|
|
|
} |
2367
|
|
|
|
|
|
|
# |
2368
|
|
|
|
|
|
|
# set up output file |
2369
|
|
|
|
|
|
|
# |
2370
|
235
|
100
|
|
|
|
2156
|
if (ref $outfile) { |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
2371
|
13
|
|
|
|
|
31
|
$outRef = $outfile; |
2372
|
13
|
50
|
|
|
|
95
|
if (UNIVERSAL::isa($outRef,'GLOB')) { |
2373
|
0
|
|
|
|
|
0
|
binmode($outRef); |
2374
|
0
|
|
|
|
|
0
|
$outPos = tell($outRef); |
2375
|
|
|
|
|
|
|
} else { |
2376
|
|
|
|
|
|
|
# initialize our output buffer if necessary |
2377
|
13
|
50
|
|
|
|
82
|
defined $$outRef or $$outRef = ''; |
2378
|
13
|
|
|
|
|
42
|
$outPos = length($$outRef); |
2379
|
|
|
|
|
|
|
} |
2380
|
|
|
|
|
|
|
} elsif (not defined $outfile) { |
2381
|
|
|
|
|
|
|
# editing in place, so write to memory first |
2382
|
|
|
|
|
|
|
# (only when infile is a file ref or scalar ref) |
2383
|
1
|
50
|
|
|
|
7
|
if ($raf) { |
2384
|
0
|
|
|
|
|
0
|
$self->Error("Can't edit File::RandomAccess object in place"); |
2385
|
0
|
|
|
|
|
0
|
return 0; |
2386
|
|
|
|
|
|
|
} |
2387
|
1
|
|
|
|
|
5
|
$outBuff = ''; |
2388
|
1
|
|
|
|
|
2
|
$outRef = \$outBuff; |
2389
|
1
|
|
|
|
|
4
|
$outPos = 0; |
2390
|
|
|
|
|
|
|
} elsif ($self->Exists($outfile)) { |
2391
|
0
|
|
|
|
|
0
|
$self->Error("File already exists: $outfile"); |
2392
|
|
|
|
|
|
|
} elsif ($self->Open(\*EXIFTOOL_OUTFILE, $outfile, '>')) { |
2393
|
221
|
|
|
|
|
1360
|
$outRef = \*EXIFTOOL_OUTFILE; |
2394
|
221
|
|
|
|
|
731
|
$closeOut = 1; # we must close $outRef |
2395
|
221
|
|
|
|
|
1050
|
binmode($outRef); |
2396
|
221
|
|
|
|
|
660
|
$outPos = 0; |
2397
|
|
|
|
|
|
|
} else { |
2398
|
0
|
0
|
|
|
|
0
|
my $tmp = $tmpfile ? ' temporary' : ''; |
2399
|
0
|
|
|
|
|
0
|
$self->Error("Error creating$tmp file: $outfile"); |
2400
|
|
|
|
|
|
|
} |
2401
|
|
|
|
|
|
|
# |
2402
|
|
|
|
|
|
|
# write the file |
2403
|
|
|
|
|
|
|
# |
2404
|
235
|
|
|
|
|
1434
|
until ($$self{VALUE}{Error}) { |
2405
|
|
|
|
|
|
|
# create random access file object (disable seek test in case of straight copy) |
2406
|
235
|
50
|
|
|
|
3027
|
$raf or $raf = new File::RandomAccess($inRef, 1); |
2407
|
235
|
|
|
|
|
1456
|
$raf->BinMode(); |
2408
|
235
|
100
|
33
|
|
|
3195
|
if ($numNew == $numPseudo) { |
|
|
50
|
66
|
|
|
|
|
2409
|
1
|
|
|
|
|
3
|
$rtnVal = 1; |
2410
|
|
|
|
|
|
|
# just do a straight copy of the file (no "real" tags are being changed) |
2411
|
1
|
|
|
|
|
3
|
my $buff; |
2412
|
1
|
|
|
|
|
6
|
while ($raf->Read($buff, 65536)) { |
2413
|
1
|
50
|
|
|
|
7
|
Write($outRef, $buff) or $rtnVal = -1, last; |
2414
|
|
|
|
|
|
|
} |
2415
|
1
|
|
|
|
|
4
|
last; |
2416
|
|
|
|
|
|
|
} elsif (not ref $infile and ($infile eq '-' or $infile =~ /\|$/)) { |
2417
|
|
|
|
|
|
|
# patch for Windows command shell pipe |
2418
|
0
|
|
|
|
|
0
|
$$raf{TESTED} = -1; # force buffering |
2419
|
|
|
|
|
|
|
} else { |
2420
|
234
|
|
|
|
|
1237
|
$raf->SeekTest(); |
2421
|
|
|
|
|
|
|
} |
2422
|
|
|
|
|
|
|
# $raf->Debug() and warn " RAF debugging enabled!\n"; |
2423
|
234
|
|
|
|
|
1355
|
my $inPos = $raf->Tell(); |
2424
|
234
|
|
|
|
|
1501
|
$$self{RAF} = $raf; |
2425
|
234
|
|
|
|
|
1326
|
my %dirInfo = ( |
2426
|
|
|
|
|
|
|
RAF => $raf, |
2427
|
|
|
|
|
|
|
OutFile => $outRef, |
2428
|
|
|
|
|
|
|
); |
2429
|
234
|
100
|
|
|
|
1263
|
$raf->Read($hdr, 1024) or $hdr = ''; |
2430
|
234
|
50
|
|
|
|
1449
|
$raf->Seek($inPos, 0) or $seekErr = 1; |
2431
|
234
|
|
|
|
|
775
|
my $wrongType; |
2432
|
234
|
|
|
|
|
1132
|
until ($seekErr) { |
2433
|
269
|
|
|
|
|
807
|
$type = shift @fileTypeList; |
2434
|
|
|
|
|
|
|
# do quick test to see if this is the right file type |
2435
|
269
|
100
|
66
|
|
|
6978
|
if ($magicNumber{$type} and length($hdr) and $hdr !~ /^$magicNumber{$type}/s) { |
|
|
|
100
|
|
|
|
|
2436
|
35
|
50
|
|
|
|
124
|
next if @fileTypeList; |
2437
|
0
|
|
|
|
|
0
|
$wrongType = 1; |
2438
|
0
|
|
|
|
|
0
|
last; |
2439
|
|
|
|
|
|
|
} |
2440
|
|
|
|
|
|
|
# save file type in member variable |
2441
|
234
|
|
|
|
|
1912
|
$dirInfo{Parent} = $$self{FILE_TYPE} = $$self{PATH}[0] = $type; |
2442
|
|
|
|
|
|
|
# determine which directories we must write for this file type |
2443
|
234
|
|
|
|
|
1699
|
$self->InitWriteDirs($type); |
2444
|
234
|
100
|
100
|
|
|
2174
|
if ($type eq 'JPEG' or $type eq 'EXV') { |
|
|
100
|
33
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
2445
|
107
|
|
|
|
|
740
|
$rtnVal = $self->WriteJPEG(\%dirInfo); |
2446
|
|
|
|
|
|
|
} elsif ($type eq 'TIFF') { |
2447
|
|
|
|
|
|
|
# disallow writing of some TIFF-based RAW images: |
2448
|
13
|
50
|
|
|
|
41
|
if (grep /^$tiffType$/, @{$noWriteFile{TIFF}}) { |
|
13
|
|
|
|
|
270
|
|
2449
|
0
|
|
|
|
|
0
|
$fileType = $tiffType; |
2450
|
0
|
|
|
|
|
0
|
undef $rtnVal; |
2451
|
|
|
|
|
|
|
} else { |
2452
|
13
|
50
|
|
|
|
133
|
if ($tiffType eq 'FFF') { |
2453
|
|
|
|
|
|
|
# (see https://exiftool.org/forum/index.php?topic=10848.0) |
2454
|
0
|
|
|
|
|
0
|
$self->Error('Phocus may not properly update previews of edited FFF images', 1); |
2455
|
|
|
|
|
|
|
} |
2456
|
13
|
|
|
|
|
47
|
$dirInfo{Parent} = $tiffType; |
2457
|
13
|
|
|
|
|
97
|
$rtnVal = $self->ProcessTIFF(\%dirInfo); |
2458
|
|
|
|
|
|
|
} |
2459
|
0
|
|
|
|
|
0
|
} elsif (exists $writableType{$type}) { |
2460
|
112
|
|
|
|
|
307
|
my ($module, $func); |
2461
|
112
|
100
|
|
|
|
569
|
if (ref $writableType{$type} eq 'ARRAY') { |
2462
|
85
|
|
66
|
|
|
508
|
$module = $writableType{$type}[0] || $type; |
2463
|
85
|
|
|
|
|
289
|
$func = $writableType{$type}[1]; |
2464
|
|
|
|
|
|
|
} else { |
2465
|
27
|
|
66
|
|
|
126
|
$module = $writableType{$type} || $type; |
2466
|
|
|
|
|
|
|
} |
2467
|
112
|
|
|
|
|
1574
|
require "Image/ExifTool/$module.pm"; |
2468
|
112
|
|
66
|
|
|
817
|
$func = "Image::ExifTool::${module}::" . ($func || "Process$type"); |
2469
|
59
|
|
|
59
|
|
665
|
no strict 'refs'; |
|
59
|
|
|
|
|
184
|
|
|
59
|
|
|
|
|
2962
|
|
2470
|
112
|
|
|
|
|
1081
|
$rtnVal = &$func($self, \%dirInfo); |
2471
|
59
|
|
|
59
|
|
513
|
use strict 'refs'; |
|
59
|
|
|
|
|
180
|
|
|
59
|
|
|
|
|
379750
|
|
2472
|
|
|
|
|
|
|
} elsif ($type eq 'ORF' or $type eq 'RAW') { |
2473
|
0
|
|
|
|
|
0
|
$rtnVal = $self->ProcessTIFF(\%dirInfo); |
2474
|
|
|
|
|
|
|
} elsif ($type eq 'EXIF') { |
2475
|
|
|
|
|
|
|
# go through WriteDirectory so block writes, etc are handled |
2476
|
2
|
|
|
|
|
27
|
my $tagTablePtr = GetTagTable('Image::ExifTool::Exif::Main'); |
2477
|
2
|
|
|
|
|
17
|
my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr, \&WriteTIFF); |
2478
|
2
|
50
|
|
|
|
9
|
if (defined $buff) { |
2479
|
2
|
50
|
|
|
|
12
|
$rtnVal = Write($outRef, $buff) ? 1 : -1; |
2480
|
|
|
|
|
|
|
} else { |
2481
|
0
|
|
|
|
|
0
|
$rtnVal = 0; |
2482
|
|
|
|
|
|
|
} |
2483
|
|
|
|
|
|
|
} else { |
2484
|
0
|
|
|
|
|
0
|
undef $rtnVal; # flag that we don't write this type of file |
2485
|
|
|
|
|
|
|
} |
2486
|
|
|
|
|
|
|
# all done unless we got the wrong type |
2487
|
234
|
50
|
|
|
|
1247
|
last if $rtnVal; |
2488
|
0
|
0
|
|
|
|
0
|
last unless @fileTypeList; |
2489
|
|
|
|
|
|
|
# seek back to original position in files for next try |
2490
|
0
|
0
|
|
|
|
0
|
$raf->Seek($inPos, 0) or $seekErr = 1, last; |
2491
|
0
|
0
|
|
|
|
0
|
if (UNIVERSAL::isa($outRef,'GLOB')) { |
2492
|
0
|
|
|
|
|
0
|
seek($outRef, 0, $outPos); |
2493
|
|
|
|
|
|
|
} else { |
2494
|
0
|
|
|
|
|
0
|
$$outRef = substr($$outRef, 0, $outPos); |
2495
|
|
|
|
|
|
|
} |
2496
|
|
|
|
|
|
|
} |
2497
|
|
|
|
|
|
|
# print file format errors |
2498
|
234
|
50
|
|
|
|
994
|
unless ($rtnVal) { |
2499
|
0
|
|
|
|
|
0
|
my $err; |
2500
|
0
|
0
|
0
|
|
|
0
|
if ($seekErr) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
2501
|
0
|
|
|
|
|
0
|
$err = 'Error seeking in file'; |
2502
|
|
|
|
|
|
|
} elsif ($fileType and defined $rtnVal) { |
2503
|
0
|
0
|
|
|
|
0
|
if ($$self{VALUE}{Error}) { |
|
|
0
|
|
|
|
|
|
2504
|
|
|
|
|
|
|
# existing error message will do |
2505
|
|
|
|
|
|
|
} elsif ($fileType eq 'RAW') { |
2506
|
0
|
|
|
|
|
0
|
$err = 'Writing this type of RAW file is not supported'; |
2507
|
|
|
|
|
|
|
} else { |
2508
|
0
|
0
|
|
|
|
0
|
if ($wrongType) { |
2509
|
0
|
|
0
|
|
|
0
|
my $type = $fileExt || ($fileType eq 'TIFF' ? $tiffType : $fileType); |
2510
|
0
|
|
|
|
|
0
|
$err = "Not a valid $type"; |
2511
|
|
|
|
|
|
|
# do a quick check to see what this file looks like |
2512
|
0
|
|
|
|
|
0
|
foreach $type (@fileTypes) { |
2513
|
0
|
0
|
|
|
|
0
|
next unless $magicNumber{$type}; |
2514
|
0
|
0
|
|
|
|
0
|
next unless $hdr =~ /^$magicNumber{$type}/s; |
2515
|
0
|
|
|
|
|
0
|
$err .= " (looks more like a $type)"; |
2516
|
0
|
|
|
|
|
0
|
last; |
2517
|
|
|
|
|
|
|
} |
2518
|
|
|
|
|
|
|
} else { |
2519
|
0
|
|
|
|
|
0
|
$err = 'Format error in file'; |
2520
|
|
|
|
|
|
|
} |
2521
|
|
|
|
|
|
|
} |
2522
|
|
|
|
|
|
|
} elsif ($fileType) { |
2523
|
|
|
|
|
|
|
# get specific type of file from extension |
2524
|
0
|
0
|
0
|
|
|
0
|
$fileType = GetFileExtension($infile) if $infile and GetFileType($infile); |
2525
|
0
|
|
|
|
|
0
|
$err = "Writing of $fileType files is not yet supported"; |
2526
|
|
|
|
|
|
|
} else { |
2527
|
0
|
|
|
|
|
0
|
$err = 'Writing of this type of file is not supported'; |
2528
|
|
|
|
|
|
|
} |
2529
|
0
|
0
|
|
|
|
0
|
$self->Error($err) if $err; |
2530
|
0
|
|
|
|
|
0
|
$rtnVal = 0; # (in case it was undef) |
2531
|
|
|
|
|
|
|
} |
2532
|
|
|
|
|
|
|
# $raf->Close(); # only used to force debug output |
2533
|
234
|
|
|
|
|
1043
|
last; # (didn't really want to loop) |
2534
|
|
|
|
|
|
|
} |
2535
|
|
|
|
|
|
|
# don't return success code if any error occurred |
2536
|
235
|
50
|
|
|
|
1153
|
if ($rtnVal > 0) { |
2537
|
235
|
50
|
66
|
|
|
1279
|
if ($outType and $type and $outType ne $type) { |
|
|
|
66
|
|
|
|
|
2538
|
0
|
|
|
|
|
0
|
my @types = GetFileType($outType); |
2539
|
0
|
0
|
|
|
|
0
|
unless (grep /^$type$/, @types) { |
2540
|
0
|
|
|
|
|
0
|
$self->Error("Can't create $outType file from $type"); |
2541
|
0
|
|
|
|
|
0
|
$rtnVal = 0; |
2542
|
|
|
|
|
|
|
} |
2543
|
|
|
|
|
|
|
} |
2544
|
235
|
50
|
33
|
|
|
1647
|
if ($rtnVal > 0 and not Tell($outRef) and not $$self{VALUE}{Error}) { |
|
|
|
33
|
|
|
|
|
2545
|
|
|
|
|
|
|
# don't write a file with zero length |
2546
|
0
|
0
|
0
|
|
|
0
|
if (defined $hdr and length $hdr) { |
2547
|
0
|
0
|
|
|
|
0
|
$type = '' unless defined $type; |
2548
|
0
|
|
|
|
|
0
|
$self->Error("Can't delete all meta information from $type file"); |
2549
|
|
|
|
|
|
|
} else { |
2550
|
0
|
|
|
|
|
0
|
$self->Error('Nothing to write'); |
2551
|
|
|
|
|
|
|
} |
2552
|
|
|
|
|
|
|
} |
2553
|
235
|
50
|
|
|
|
1396
|
$rtnVal = 0 if $$self{VALUE}{Error}; |
2554
|
|
|
|
|
|
|
} |
2555
|
|
|
|
|
|
|
|
2556
|
|
|
|
|
|
|
# rewrite original file in place if required |
2557
|
235
|
100
|
|
|
|
949
|
if (defined $outBuff) { |
2558
|
1
|
50
|
33
|
|
|
15
|
if ($rtnVal <= 0 or not $$self{CHANGED}) { |
|
|
50
|
|
|
|
|
|
2559
|
|
|
|
|
|
|
# nothing changed, so no need to write $outBuff |
2560
|
|
|
|
|
|
|
} elsif (UNIVERSAL::isa($inRef,'GLOB')) { |
2561
|
1
|
|
|
|
|
3
|
my $len = length($outBuff); |
2562
|
1
|
|
|
|
|
3
|
my $size; |
2563
|
|
|
|
|
|
|
$rtnVal = -1 unless |
2564
|
|
|
|
|
|
|
seek($inRef, 0, 2) and # seek to the end of file |
2565
|
|
|
|
|
|
|
($size = tell $inRef) >= 0 and # get the file size |
2566
|
|
|
|
|
|
|
seek($inRef, 0, 0) and # seek back to the start |
2567
|
|
|
|
|
|
|
print $inRef $outBuff and # write the new data |
2568
|
|
|
|
|
|
|
($len >= $size or # if necessary: |
2569
|
1
|
50
|
33
|
|
|
39
|
eval { truncate($inRef, $len) }); # shorten output file |
|
|
|
33
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
|
33
|
|
|
|
|
2570
|
|
|
|
|
|
|
} else { |
2571
|
0
|
|
|
|
|
0
|
$$inRef = $outBuff; # replace original data |
2572
|
|
|
|
|
|
|
} |
2573
|
1
|
|
|
|
|
6
|
$outBuff = ''; # free memory but leave $outBuff defined |
2574
|
|
|
|
|
|
|
} |
2575
|
|
|
|
|
|
|
# close input file if we opened it |
2576
|
235
|
100
|
|
|
|
848
|
if ($closeIn) { |
2577
|
|
|
|
|
|
|
# errors on input file are significant if we edited the file in place |
2578
|
207
|
50
|
0
|
|
|
4718
|
$rtnVal and $rtnVal = -1 unless close($inRef) or not defined $outBuff; |
|
|
|
33
|
|
|
|
|
2579
|
207
|
50
|
|
|
|
1115
|
if ($rtnVal > 0) { |
2580
|
|
|
|
|
|
|
# copy Mac OS resource fork if it exists |
2581
|
207
|
50
|
33
|
|
|
1593
|
if ($^O eq 'darwin' and -s "$infile/..namedfork/rsrc") { |
2582
|
0
|
0
|
|
|
|
0
|
if ($$self{DEL_GROUP}{RSRC}) { |
2583
|
0
|
|
|
|
|
0
|
$self->VPrint(0,"Deleting Mac OS resource fork\n"); |
2584
|
0
|
|
|
|
|
0
|
++$$self{CHANGED}; |
2585
|
|
|
|
|
|
|
} else { |
2586
|
0
|
|
|
|
|
0
|
$self->VPrint(0,"Copying Mac OS resource fork\n"); |
2587
|
0
|
|
|
|
|
0
|
my ($buf, $err); |
2588
|
0
|
|
|
|
|
0
|
local (*SRC, *DST); |
2589
|
0
|
0
|
|
|
|
0
|
if ($self->Open(\*SRC, "$infile/..namedfork/rsrc")) { |
2590
|
0
|
0
|
|
|
|
0
|
if ($self->Open(\*DST, "$outfile/..namedfork/rsrc", '>')) { |
2591
|
0
|
|
|
|
|
0
|
binmode SRC; # (not necessary for Darwin, but let's be thorough) |
2592
|
0
|
|
|
|
|
0
|
binmode DST; |
2593
|
0
|
|
|
|
|
0
|
while (read SRC, $buf, 65536) { |
2594
|
0
|
0
|
|
|
|
0
|
print DST $buf or $err = 'copying', last; |
2595
|
|
|
|
|
|
|
} |
2596
|
0
|
0
|
0
|
|
|
0
|
close DST or $err or $err = 'closing'; |
2597
|
|
|
|
|
|
|
} else { |
2598
|
|
|
|
|
|
|
# (this is normal if the destination filesystem isn't Mac OS) |
2599
|
0
|
|
|
|
|
0
|
$self->Warn('Error creating Mac OS resource fork'); |
2600
|
|
|
|
|
|
|
} |
2601
|
0
|
|
|
|
|
0
|
close SRC; |
2602
|
|
|
|
|
|
|
} else { |
2603
|
0
|
|
|
|
|
0
|
$err = 'opening'; |
2604
|
|
|
|
|
|
|
} |
2605
|
0
|
0
|
0
|
|
|
0
|
$rtnVal = 0 if $err and $self->Error("Error $err Mac OS resource fork", 2); |
2606
|
|
|
|
|
|
|
} |
2607
|
|
|
|
|
|
|
} |
2608
|
|
|
|
|
|
|
# erase input file if renaming while editing information in place |
2609
|
207
|
50
|
0
|
|
|
832
|
$self->Unlink($infile) or $self->Warn('Error erasing original file') if $eraseIn; |
2610
|
|
|
|
|
|
|
} |
2611
|
|
|
|
|
|
|
} |
2612
|
|
|
|
|
|
|
# close output file if we created it |
2613
|
235
|
100
|
|
|
|
914
|
if ($closeOut) { |
2614
|
|
|
|
|
|
|
# close file and set $rtnVal to -1 if there was an error |
2615
|
221
|
50
|
0
|
|
|
16594
|
$rtnVal and $rtnVal = -1 unless close($outRef); |
2616
|
|
|
|
|
|
|
# erase the output file if we weren't successful |
2617
|
221
|
50
|
|
|
|
1916
|
if ($rtnVal <= 0) { |
|
|
100
|
|
|
|
|
|
2618
|
0
|
|
|
|
|
0
|
$self->Unlink($outfile); |
2619
|
|
|
|
|
|
|
# else rename temporary file if necessary |
2620
|
|
|
|
|
|
|
} elsif ($tmpfile) { |
2621
|
2
|
|
|
|
|
20
|
$self->CopyFileAttrs($infile, $tmpfile); # copy attributes to new file |
2622
|
2
|
50
|
|
|
|
27
|
unless ($self->Rename($tmpfile, $infile)) { |
2623
|
|
|
|
|
|
|
# some filesystems won't overwrite with 'rename', so try erasing original |
2624
|
0
|
0
|
|
|
|
0
|
if (not $self->Unlink($infile)) { |
|
|
0
|
|
|
|
|
|
2625
|
0
|
|
|
|
|
0
|
$self->Unlink($tmpfile); |
2626
|
0
|
|
|
|
|
0
|
$self->Error('Error renaming temporary file'); |
2627
|
0
|
|
|
|
|
0
|
$rtnVal = 0; |
2628
|
|
|
|
|
|
|
} elsif (not $self->Rename($tmpfile, $infile)) { |
2629
|
0
|
|
|
|
|
0
|
$self->Error('Error renaming temporary file after deleting original'); |
2630
|
0
|
|
|
|
|
0
|
$rtnVal = 0; |
2631
|
|
|
|
|
|
|
} |
2632
|
|
|
|
|
|
|
} |
2633
|
|
|
|
|
|
|
# the output file should now have the name of the original infile |
2634
|
2
|
50
|
|
|
|
13
|
$outfile = $infile if $rtnVal > 0; |
2635
|
|
|
|
|
|
|
} |
2636
|
|
|
|
|
|
|
} |
2637
|
|
|
|
|
|
|
# set filesystem attributes if requested (and if possible!) |
2638
|
235
|
50
|
100
|
|
|
2057
|
if ($rtnVal > 0 and ($closeOut or (defined $outBuff and ($closeIn or UNIVERSAL::isa($infile,'GLOB'))))) { |
|
|
|
66
|
|
|
|
|
2639
|
222
|
100
|
|
|
|
1419
|
my $target = $closeOut ? $outfile : $infile; |
2640
|
|
|
|
|
|
|
# set file permissions if requested |
2641
|
222
|
50
|
|
|
|
1679
|
++$$self{CHANGED} if $self->SetSystemTags($target) > 0; |
2642
|
222
|
100
|
|
|
|
980
|
if ($closeIn) { # (no use setting file times unless the input file is closed) |
2643
|
198
|
50
|
33
|
|
|
946
|
++$$self{CHANGED} if $setModDate and $self->SetFileModifyDate($target, $originalTime, undef, 1) > 0; |
2644
|
|
|
|
|
|
|
# set FileCreateDate if requested (and if possible!) |
2645
|
198
|
50
|
33
|
|
|
935
|
++$$self{CHANGED} if $setCreateDate and $self->SetFileModifyDate($target, $createTime, 'FileCreateDate', 1) > 0; |
2646
|
|
|
|
|
|
|
# create hard link if requested and no output filename specified (and if possible!) |
2647
|
198
|
50
|
33
|
|
|
932
|
++$$self{CHANGED} if defined $hardLink and $self->SetFileName($target, $hardLink, 'HardLink'); |
2648
|
198
|
50
|
33
|
|
|
868
|
++$$self{CHANGED} if defined $symLink and $self->SetFileName($target, $symLink, 'SymLink'); |
2649
|
198
|
50
|
|
|
|
815
|
defined $testName and $self->SetFileName($target, $testName, 'Test'); |
2650
|
|
|
|
|
|
|
} |
2651
|
|
|
|
|
|
|
} |
2652
|
|
|
|
|
|
|
# check for write error and set appropriate error message and return value |
2653
|
235
|
50
|
|
|
|
1366
|
if ($rtnVal < 0) { |
|
|
50
|
|
|
|
|
|
2654
|
0
|
0
|
|
|
|
0
|
$self->Error('Error writing output file') unless $$self{VALUE}{Error}; |
2655
|
0
|
|
|
|
|
0
|
$rtnVal = 0; # return 0 on failure |
2656
|
|
|
|
|
|
|
} elsif ($rtnVal > 0) { |
2657
|
235
|
100
|
|
|
|
1019
|
++$rtnVal unless $$self{CHANGED}; |
2658
|
|
|
|
|
|
|
} |
2659
|
|
|
|
|
|
|
# set things back to the way they were |
2660
|
235
|
|
|
|
|
850
|
$$self{RAF} = $oldRaf; |
2661
|
|
|
|
|
|
|
|
2662
|
235
|
|
|
|
|
2704
|
return $rtnVal; |
2663
|
|
|
|
|
|
|
} |
2664
|
|
|
|
|
|
|
|
2665
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
2666
|
|
|
|
|
|
|
# Get list of all available tags for specified group |
2667
|
|
|
|
|
|
|
# Inputs: 0) optional group name (or string of names separated by colons) |
2668
|
|
|
|
|
|
|
# Returns: tag list (sorted alphabetically) |
2669
|
|
|
|
|
|
|
# Notes: Can't get tags for specific IFD |
2670
|
|
|
|
|
|
|
sub GetAllTags(;$) |
2671
|
|
|
|
|
|
|
{ |
2672
|
0
|
|
|
0
|
1
|
0
|
local $_; |
2673
|
0
|
|
|
|
|
0
|
my $group = shift; |
2674
|
0
|
|
|
|
|
0
|
my (%allTags, @groups); |
2675
|
0
|
0
|
|
|
|
0
|
@groups = split ':', $group if $group; |
2676
|
|
|
|
|
|
|
|
2677
|
0
|
|
|
|
|
0
|
my $et = new Image::ExifTool; |
2678
|
0
|
|
|
|
|
0
|
LoadAllTables(); # first load all our tables |
2679
|
0
|
|
|
|
|
0
|
my @tableNames = keys %allTables; |
2680
|
|
|
|
|
|
|
|
2681
|
|
|
|
|
|
|
# loop through all tables and save tag names to %allTags hash |
2682
|
0
|
|
|
|
|
0
|
while (@tableNames) { |
2683
|
0
|
|
|
|
|
0
|
my $table = GetTagTable(pop @tableNames); |
2684
|
|
|
|
|
|
|
# generate flattened tag names for structure fields if this is an XMP table |
2685
|
0
|
0
|
0
|
|
|
0
|
if ($$table{GROUPS} and $$table{GROUPS}{0} eq 'XMP') { |
2686
|
0
|
|
|
|
|
0
|
Image::ExifTool::XMP::AddFlattenedTags($table); |
2687
|
|
|
|
|
|
|
} |
2688
|
0
|
|
|
|
|
0
|
my $tagID; |
2689
|
0
|
|
|
|
|
0
|
foreach $tagID (TagTableKeys($table)) { |
2690
|
0
|
|
|
|
|
0
|
my @infoArray = GetTagInfoList($table,$tagID); |
2691
|
0
|
|
|
|
|
0
|
my $tagInfo; |
2692
|
0
|
|
|
|
|
0
|
GATInfo: foreach $tagInfo (@infoArray) { |
2693
|
0
|
|
|
|
|
0
|
my $tag = $$tagInfo{Name}; |
2694
|
0
|
0
|
|
|
|
0
|
$tag or warn("no name for tag!\n"), next; |
2695
|
|
|
|
|
|
|
# don't list subdirectories unless they are writable |
2696
|
0
|
0
|
0
|
|
|
0
|
next if $$tagInfo{SubDirectory} and not $$tagInfo{Writable}; |
2697
|
0
|
0
|
|
|
|
0
|
next if $$tagInfo{Hidden}; # ignore hidden tags |
2698
|
0
|
0
|
|
|
|
0
|
if (@groups) { |
2699
|
0
|
|
|
|
|
0
|
my @tg = $et->GetGroup($tagInfo); |
2700
|
0
|
|
|
|
|
0
|
foreach $group (@groups) { |
2701
|
0
|
0
|
|
|
|
0
|
next GATInfo unless grep /^$group$/i, @tg; |
2702
|
|
|
|
|
|
|
} |
2703
|
|
|
|
|
|
|
} |
2704
|
0
|
|
|
|
|
0
|
$allTags{$tag} = 1; |
2705
|
|
|
|
|
|
|
} |
2706
|
|
|
|
|
|
|
} |
2707
|
|
|
|
|
|
|
} |
2708
|
0
|
|
|
|
|
0
|
return sort keys %allTags; |
2709
|
|
|
|
|
|
|
} |
2710
|
|
|
|
|
|
|
|
2711
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
2712
|
|
|
|
|
|
|
# Get list of all writable tags |
2713
|
|
|
|
|
|
|
# Inputs: 0) optional group name (or names separated by colons) |
2714
|
|
|
|
|
|
|
# Returns: tag list (sorted alphabetically) |
2715
|
|
|
|
|
|
|
sub GetWritableTags(;$) |
2716
|
|
|
|
|
|
|
{ |
2717
|
0
|
|
|
0
|
1
|
0
|
local $_; |
2718
|
0
|
|
|
|
|
0
|
my $group = shift; |
2719
|
0
|
|
|
|
|
0
|
my (%writableTags, @groups); |
2720
|
0
|
0
|
|
|
|
0
|
@groups = split ':', $group if $group; |
2721
|
|
|
|
|
|
|
|
2722
|
0
|
|
|
|
|
0
|
my $et = new Image::ExifTool; |
2723
|
0
|
|
|
|
|
0
|
LoadAllTables(); |
2724
|
0
|
|
|
|
|
0
|
my @tableNames = keys %allTables; |
2725
|
|
|
|
|
|
|
|
2726
|
0
|
|
|
|
|
0
|
while (@tableNames) { |
2727
|
0
|
|
|
|
|
0
|
my $tableName = pop @tableNames; |
2728
|
0
|
|
|
|
|
0
|
my $table = GetTagTable($tableName); |
2729
|
|
|
|
|
|
|
# generate flattened tag names for structure fields if this is an XMP table |
2730
|
0
|
0
|
0
|
|
|
0
|
if ($$table{GROUPS} and $$table{GROUPS}{0} eq 'XMP') { |
2731
|
0
|
|
|
|
|
0
|
Image::ExifTool::XMP::AddFlattenedTags($table); |
2732
|
|
|
|
|
|
|
} |
2733
|
|
|
|
|
|
|
# attempt to load Write tables if autoloaded |
2734
|
0
|
|
|
|
|
0
|
my @parts = split(/::/,$tableName); |
2735
|
0
|
0
|
|
|
|
0
|
if (@parts > 3) { |
2736
|
0
|
|
|
|
|
0
|
my $i = $#parts - 1; |
2737
|
0
|
|
|
|
|
0
|
$parts[$i] = "Write$parts[$i]"; # add 'Write' before class name |
2738
|
0
|
|
|
|
|
0
|
my $module = join('::',@parts[0..$i]); |
2739
|
0
|
|
|
|
|
0
|
eval { require $module }; # (fails silently if nothing loaded) |
|
0
|
|
|
|
|
0
|
|
2740
|
|
|
|
|
|
|
} |
2741
|
0
|
|
|
|
|
0
|
my $tagID; |
2742
|
0
|
|
|
|
|
0
|
foreach $tagID (TagTableKeys($table)) { |
2743
|
0
|
|
|
|
|
0
|
my @infoArray = GetTagInfoList($table,$tagID); |
2744
|
0
|
|
|
|
|
0
|
my $tagInfo; |
2745
|
0
|
|
|
|
|
0
|
GWTInfo: foreach $tagInfo (@infoArray) { |
2746
|
0
|
|
|
|
|
0
|
my $tag = $$tagInfo{Name}; |
2747
|
0
|
0
|
|
|
|
0
|
$tag or warn("no name for tag!\n"), next; |
2748
|
0
|
|
|
|
|
0
|
my $writable = $$tagInfo{Writable}; |
2749
|
|
|
|
|
|
|
next unless $writable or ($$table{WRITABLE} and |
2750
|
0
|
0
|
0
|
|
|
0
|
not defined $writable and not $$tagInfo{SubDirectory}); |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
2751
|
0
|
0
|
|
|
|
0
|
next if $$tagInfo{Hidden}; # ignore hidden tags |
2752
|
0
|
0
|
|
|
|
0
|
if (@groups) { |
2753
|
0
|
|
|
|
|
0
|
my @tg = $et->GetGroup($tagInfo); |
2754
|
0
|
|
|
|
|
0
|
foreach $group (@groups) { |
2755
|
0
|
0
|
|
|
|
0
|
next GWTInfo unless grep /^$group$/i, @tg; |
2756
|
|
|
|
|
|
|
} |
2757
|
|
|
|
|
|
|
} |
2758
|
0
|
|
|
|
|
0
|
$writableTags{$tag} = 1; |
2759
|
|
|
|
|
|
|
} |
2760
|
|
|
|
|
|
|
} |
2761
|
|
|
|
|
|
|
} |
2762
|
0
|
|
|
|
|
0
|
return sort keys %writableTags; |
2763
|
|
|
|
|
|
|
} |
2764
|
|
|
|
|
|
|
|
2765
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
2766
|
|
|
|
|
|
|
# Get list of all group names |
2767
|
|
|
|
|
|
|
# Inputs: 0) [optional] ExifTool ref, 1) Group family number |
2768
|
|
|
|
|
|
|
# Returns: List of group names (sorted alphabetically) |
2769
|
|
|
|
|
|
|
sub GetAllGroups($;$) |
2770
|
|
|
|
|
|
|
{ |
2771
|
0
|
|
|
0
|
1
|
0
|
local $_; |
2772
|
0
|
|
0
|
|
|
0
|
my $family = shift || 0; |
2773
|
0
|
|
|
|
|
0
|
my $self; |
2774
|
0
|
0
|
0
|
|
|
0
|
ref $family and $self = $family, $family = shift || 0; |
2775
|
|
|
|
|
|
|
|
2776
|
0
|
0
|
|
|
|
0
|
$family == 3 and return('Doc#', 'Main'); |
2777
|
0
|
0
|
|
|
|
0
|
$family == 4 and return('Copy#'); |
2778
|
0
|
0
|
|
|
|
0
|
$family == 5 and return('[too many possibilities to list]'); |
2779
|
0
|
0
|
|
|
|
0
|
$family == 6 and return(@Image::ExifTool::Exif::formatName[1..$#Image::ExifTool::Exif::formatName]); |
2780
|
0
|
0
|
|
|
|
0
|
$family == 8 and return('File#'); |
2781
|
|
|
|
|
|
|
|
2782
|
0
|
|
|
|
|
0
|
LoadAllTables(); # first load all our tables |
2783
|
|
|
|
|
|
|
|
2784
|
0
|
|
|
|
|
0
|
my @tableNames = keys %allTables; |
2785
|
|
|
|
|
|
|
|
2786
|
0
|
|
|
|
|
0
|
my %allGroups; |
2787
|
|
|
|
|
|
|
# add family 1 groups not in tables |
2788
|
0
|
0
|
|
|
|
0
|
$family == 1 and map { $allGroups{$_} = 1 } qw(Garmin); |
|
0
|
|
|
|
|
0
|
|
2789
|
|
|
|
|
|
|
# loop through all tag tables and get all group names |
2790
|
0
|
|
|
|
|
0
|
while (@tableNames) { |
2791
|
0
|
|
|
|
|
0
|
my $table = GetTagTable(pop @tableNames); |
2792
|
0
|
|
|
|
|
0
|
my ($grps, $grp, $tag, $tagInfo); |
2793
|
0
|
0
|
0
|
|
|
0
|
$allGroups{$grp} = 1 if ($grps = $$table{GROUPS}) and ($grp = $$grps{$family}); |
2794
|
0
|
|
|
|
|
0
|
foreach $tag (TagTableKeys($table)) { |
2795
|
0
|
|
|
|
|
0
|
my @infoArray = GetTagInfoList($table, $tag); |
2796
|
0
|
0
|
|
|
|
0
|
if ($family == 7) { |
2797
|
0
|
|
|
|
|
0
|
foreach $tagInfo (@infoArray) { |
2798
|
0
|
|
|
|
|
0
|
my $id = $$tagInfo{TagID}; |
2799
|
0
|
0
|
|
|
|
0
|
if (not defined $id) { |
|
|
0
|
|
|
|
|
|
2800
|
0
|
|
|
|
|
0
|
$id = ''; # (just to be safe) |
2801
|
|
|
|
|
|
|
} elsif ($id =~ /^\d+$/) { |
2802
|
0
|
0
|
0
|
|
|
0
|
$id = sprintf('0x%x', $id) if $self and $$self{OPTIONS}{HexTagIDs}; |
2803
|
|
|
|
|
|
|
} else { |
2804
|
0
|
|
|
|
|
0
|
$id =~ s/([^-_A-Za-z0-9])/sprintf('%.2x',ord $1)/ge; |
|
0
|
|
|
|
|
0
|
|
2805
|
|
|
|
|
|
|
} |
2806
|
0
|
|
|
|
|
0
|
$allGroups{'ID-' . $id} = 1; |
2807
|
|
|
|
|
|
|
} |
2808
|
|
|
|
|
|
|
} else { |
2809
|
0
|
|
|
|
|
0
|
foreach $tagInfo (@infoArray) { |
2810
|
0
|
0
|
0
|
|
|
0
|
next unless ($grps = $$tagInfo{Groups}) and ($grp = $$grps{$family}); |
2811
|
0
|
|
|
|
|
0
|
$allGroups{$grp} = 1; |
2812
|
|
|
|
|
|
|
} |
2813
|
|
|
|
|
|
|
} |
2814
|
|
|
|
|
|
|
} |
2815
|
|
|
|
|
|
|
} |
2816
|
0
|
|
|
|
|
0
|
delete $allGroups{'*'}; # (not a real group) |
2817
|
0
|
|
|
|
|
0
|
return sort keys %allGroups; |
2818
|
|
|
|
|
|
|
} |
2819
|
|
|
|
|
|
|
|
2820
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
2821
|
|
|
|
|
|
|
# get priority group list for new values |
2822
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object reference |
2823
|
|
|
|
|
|
|
# Returns: List of group names |
2824
|
|
|
|
|
|
|
sub GetNewGroups($) |
2825
|
|
|
|
|
|
|
{ |
2826
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
2827
|
0
|
|
|
|
|
0
|
return @{$$self{WRITE_GROUPS}}; |
|
0
|
|
|
|
|
0
|
|
2828
|
|
|
|
|
|
|
} |
2829
|
|
|
|
|
|
|
|
2830
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
2831
|
|
|
|
|
|
|
# Get list of all deletable group names |
2832
|
|
|
|
|
|
|
# Returns: List of group names (sorted alphabetically) |
2833
|
|
|
|
|
|
|
sub GetDeleteGroups() |
2834
|
|
|
|
|
|
|
{ |
2835
|
0
|
|
|
0
|
1
|
0
|
return sort @delGroups, @delGroup2; |
2836
|
|
|
|
|
|
|
} |
2837
|
|
|
|
|
|
|
|
2838
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
2839
|
|
|
|
|
|
|
# Add user-defined tags at run time |
2840
|
|
|
|
|
|
|
# Inputs: 0) destination table name, 1) tagID/tagInfo pairs for tags to add |
2841
|
|
|
|
|
|
|
# Returns: number of tags added |
2842
|
|
|
|
|
|
|
# Notes: will replace existing tags |
2843
|
|
|
|
|
|
|
sub AddUserDefinedTags($%) |
2844
|
|
|
|
|
|
|
{ |
2845
|
2
|
|
|
2
|
1
|
629
|
local $_; |
2846
|
2
|
|
|
|
|
14
|
my ($tableName, %addTags) = @_; |
2847
|
2
|
50
|
|
|
|
10
|
my $table = GetTagTable($tableName) or return 0; |
2848
|
|
|
|
|
|
|
# add tags to writer lookup |
2849
|
2
|
|
|
|
|
19
|
Image::ExifTool::TagLookup::AddTags(\%addTags, $tableName); |
2850
|
2
|
|
|
|
|
6
|
my $tagID; |
2851
|
2
|
|
|
|
|
7
|
my $num = 0; |
2852
|
2
|
|
|
|
|
9
|
foreach $tagID (keys %addTags) { |
2853
|
2
|
50
|
|
|
|
11
|
next if $specialTags{$tagID}; |
2854
|
2
|
|
|
|
|
11
|
delete $$table{$tagID}; # delete old entry if it existed |
2855
|
2
|
|
|
|
|
16
|
AddTagToTable($table, $tagID, $addTags{$tagID}, 1); |
2856
|
2
|
|
|
|
|
7
|
++$num; |
2857
|
|
|
|
|
|
|
} |
2858
|
2
|
|
|
|
|
10
|
return $num; |
2859
|
|
|
|
|
|
|
} |
2860
|
|
|
|
|
|
|
|
2861
|
|
|
|
|
|
|
#============================================================================== |
2862
|
|
|
|
|
|
|
# Functions below this are not part of the public API |
2863
|
|
|
|
|
|
|
|
2864
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
2865
|
|
|
|
|
|
|
# Maintain backward compatibility for old GetNewValues function name |
2866
|
|
|
|
|
|
|
sub GetNewValues($$;$) |
2867
|
|
|
|
|
|
|
{ |
2868
|
0
|
|
|
0
|
0
|
0
|
my ($self, $tag, $nvHashPt) = @_; |
2869
|
0
|
|
|
|
|
0
|
return $self->GetNewValue($tag, $nvHashPt); |
2870
|
|
|
|
|
|
|
} |
2871
|
|
|
|
|
|
|
|
2872
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
2873
|
|
|
|
|
|
|
# Un-escape string according to options settings and clear UTF-8 flag |
2874
|
|
|
|
|
|
|
# Inputs: 0) ExifTool ref, 1) string ref or string ref ref |
2875
|
|
|
|
|
|
|
# Notes: also de-references SCALAR values |
2876
|
|
|
|
|
|
|
sub Sanitize($$) |
2877
|
|
|
|
|
|
|
{ |
2878
|
5400
|
|
|
5400
|
0
|
10868
|
my ($self, $valPt) = @_; |
2879
|
|
|
|
|
|
|
# de-reference SCALAR references |
2880
|
5400
|
50
|
|
|
|
13872
|
$$valPt = $$$valPt if ref $$valPt eq 'SCALAR'; |
2881
|
|
|
|
|
|
|
# make sure the Perl UTF-8 flag is OFF for the value if perl 5.6 or greater |
2882
|
|
|
|
|
|
|
# (otherwise our byte manipulations get corrupted!!) |
2883
|
5400
|
50
|
33
|
|
|
15654
|
if ($] >= 5.006 and (eval { require Encode; Encode::is_utf8($$valPt) } or $@)) { |
|
|
|
33
|
|
|
|
|
2884
|
0
|
|
|
|
|
0
|
local $SIG{'__WARN__'} = \&SetWarning; |
2885
|
|
|
|
|
|
|
# repack by hand if Encode isn't available |
2886
|
0
|
0
|
|
|
|
0
|
$$valPt = $@ ? pack('C*',unpack($] < 5.010000 ? 'U0C*' : 'C0C*',$$valPt)) : Encode::encode('utf8',$$valPt); |
|
|
0
|
|
|
|
|
|
2887
|
|
|
|
|
|
|
} |
2888
|
|
|
|
|
|
|
# un-escape value if necessary |
2889
|
5400
|
100
|
|
|
|
19708
|
if ($$self{OPTIONS}{Escape}) { |
2890
|
|
|
|
|
|
|
# (XMP.pm and HTML.pm were require'd as necessary when option was set) |
2891
|
92
|
50
|
|
|
|
314
|
if ($$self{OPTIONS}{Escape} eq 'XML') { |
|
|
50
|
|
|
|
|
|
2892
|
0
|
|
|
|
|
0
|
$$valPt = Image::ExifTool::XMP::UnescapeXML($$valPt); |
2893
|
|
|
|
|
|
|
} elsif ($$self{OPTIONS}{Escape} eq 'HTML') { |
2894
|
92
|
|
|
|
|
290
|
$$valPt = Image::ExifTool::HTML::UnescapeHTML($$valPt, $$self{OPTIONS}{Charset}); |
2895
|
|
|
|
|
|
|
} |
2896
|
|
|
|
|
|
|
} |
2897
|
|
|
|
|
|
|
} |
2898
|
|
|
|
|
|
|
|
2899
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
2900
|
|
|
|
|
|
|
# Apply inverse conversions |
2901
|
|
|
|
|
|
|
# Inputs: 0) ExifTool ref, 1) value, 2) tagInfo (or Struct item) ref, |
2902
|
|
|
|
|
|
|
# 3) tag name, 4) group 1 name, 5) conversion type (or undef), |
2903
|
|
|
|
|
|
|
# 6) [optional] want group ("" for structure field) |
2904
|
|
|
|
|
|
|
# Returns: 0) converted value, 1) error string (or undef on success) |
2905
|
|
|
|
|
|
|
# Notes: |
2906
|
|
|
|
|
|
|
# - uses ExifTool "ConvType" member when conversion type is undef |
2907
|
|
|
|
|
|
|
# - conversion types other than 'ValueConv' and 'PrintConv' are treated as 'Raw' |
2908
|
|
|
|
|
|
|
sub ConvInv($$$$$;$$) |
2909
|
|
|
|
|
|
|
{ |
2910
|
28276
|
|
|
28276
|
0
|
77338
|
my ($self, $val, $tagInfo, $tag, $wgrp1, $convType, $wantGroup) = @_; |
2911
|
28276
|
|
|
|
|
43774
|
my ($err, $type); |
2912
|
|
|
|
|
|
|
|
2913
|
28276
|
100
|
50
|
|
|
56462
|
$convType or $convType = $$self{ConvType} || 'PrintConv'; |
2914
|
|
|
|
|
|
|
|
2915
|
28276
|
|
|
|
|
49509
|
Conv: for (;;) { |
2916
|
73158
|
100
|
|
|
|
171961
|
if (not defined $type) { |
|
|
100
|
|
|
|
|
|
2917
|
|
|
|
|
|
|
# split value into list if necessary |
2918
|
28276
|
100
|
|
|
|
70869
|
if ($$tagInfo{List}) { |
2919
|
583
|
|
100
|
|
|
3214
|
my $listSplit = $$tagInfo{AutoSplit} || $$self{OPTIONS}{ListSplit}; |
2920
|
583
|
50
|
100
|
|
|
2541
|
if (defined $listSplit and not $$tagInfo{Struct} and |
|
|
|
66
|
|
|
|
|
|
|
|
100
|
|
|
|
|
2921
|
|
|
|
|
|
|
($wantGroup or not defined $wantGroup)) |
2922
|
|
|
|
|
|
|
{ |
2923
|
74
|
50
|
66
|
|
|
487
|
$listSplit = ',?\s+' if $listSplit eq '1' and $$tagInfo{AutoSplit}; |
2924
|
74
|
|
|
|
|
825
|
my @splitVal = split /$listSplit/, $val, -1; |
2925
|
74
|
50
|
|
|
|
450
|
$val = @splitVal > 1 ? \@splitVal : @splitVal ? $splitVal[0] : ''; |
|
|
100
|
|
|
|
|
|
2926
|
|
|
|
|
|
|
} |
2927
|
|
|
|
|
|
|
} |
2928
|
28276
|
|
|
|
|
47065
|
$type = $convType; |
2929
|
|
|
|
|
|
|
} elsif ($type eq 'PrintConv') { |
2930
|
21738
|
|
|
|
|
38024
|
$type = 'ValueConv'; |
2931
|
|
|
|
|
|
|
} else { |
2932
|
|
|
|
|
|
|
# split raw value if necessary |
2933
|
23144
|
50
|
66
|
|
|
56472
|
if ($$tagInfo{RawJoin} and $$tagInfo{List} and not ref $val) { |
|
|
|
33
|
|
|
|
|
2934
|
13
|
|
|
|
|
72
|
my @splitVal = split ' ', $val; |
2935
|
13
|
50
|
|
|
|
78
|
$val = \@splitVal if @splitVal > 1; |
2936
|
|
|
|
|
|
|
} |
2937
|
|
|
|
|
|
|
# finally, do our value check |
2938
|
23144
|
|
|
|
|
36189
|
my ($err2, $v); |
2939
|
23144
|
100
|
|
|
|
60291
|
if ($$tagInfo{WriteCheck}) { |
2940
|
|
|
|
|
|
|
#### eval WriteCheck ($self, $tagInfo, $val) |
2941
|
296
|
|
|
|
|
23891
|
$err2 = eval $$tagInfo{WriteCheck}; |
2942
|
296
|
50
|
|
|
|
1611
|
$@ and warn($@), $err2 = 'Error evaluating WriteCheck'; |
2943
|
|
|
|
|
|
|
} |
2944
|
23144
|
100
|
|
|
|
51427
|
unless ($err2) { |
2945
|
23110
|
|
|
|
|
46337
|
my $table = $$tagInfo{Table}; |
2946
|
23110
|
100
|
100
|
|
|
138632
|
if ($table and $$table{CHECK_PROC} and not $$tagInfo{RawConvInv}) { |
|
|
|
100
|
|
|
|
|
2947
|
22225
|
|
|
|
|
39397
|
my $checkProc = $$table{CHECK_PROC}; |
2948
|
22225
|
100
|
|
|
|
44875
|
if (ref $val eq 'ARRAY') { |
2949
|
|
|
|
|
|
|
# loop through array values |
2950
|
46
|
|
|
|
|
193
|
foreach $v (@$val) { |
2951
|
136
|
|
|
|
|
459
|
$err2 = &$checkProc($self, $tagInfo, \$v, $convType); |
2952
|
136
|
50
|
|
|
|
454
|
last if $err2; |
2953
|
|
|
|
|
|
|
} |
2954
|
|
|
|
|
|
|
} else { |
2955
|
22179
|
|
|
|
|
69076
|
$err2 = &$checkProc($self, $tagInfo, \$val, $convType); |
2956
|
|
|
|
|
|
|
} |
2957
|
|
|
|
|
|
|
} |
2958
|
|
|
|
|
|
|
} |
2959
|
23144
|
100
|
|
|
|
55299
|
if (defined $err2) { |
2960
|
3344
|
100
|
|
|
|
6957
|
if ($err2) { |
2961
|
3336
|
|
|
|
|
8583
|
$err = "$err2 for $wgrp1:$tag"; |
2962
|
3336
|
|
|
|
|
16108
|
$self->VPrint(2, "$err\n"); |
2963
|
3336
|
|
|
|
|
7023
|
undef $val; # value was invalid |
2964
|
|
|
|
|
|
|
} else { |
2965
|
8
|
|
|
|
|
17
|
$err = $err2; # empty error (quietly don't write tag) |
2966
|
|
|
|
|
|
|
} |
2967
|
|
|
|
|
|
|
} |
2968
|
23144
|
|
|
|
|
40299
|
last; |
2969
|
|
|
|
|
|
|
} |
2970
|
50014
|
|
|
|
|
103105
|
my $conv = $$tagInfo{$type}; |
2971
|
50014
|
|
|
|
|
119176
|
my $convInv = $$tagInfo{"${type}Inv"}; |
2972
|
|
|
|
|
|
|
# nothing to do at this level if no conversion defined |
2973
|
50014
|
100
|
100
|
|
|
146178
|
next unless defined $conv or defined $convInv; |
2974
|
|
|
|
|
|
|
|
2975
|
22525
|
|
|
|
|
37966
|
my (@valList, $index, $convList, $convInvList); |
2976
|
22525
|
100
|
66
|
|
|
89844
|
if (ref $val eq 'ARRAY') { |
|
|
100
|
|
|
|
|
|
2977
|
|
|
|
|
|
|
# handle ValueConv of ListSplit and AutoSplit values |
2978
|
12
|
|
|
|
|
58
|
@valList = @$val; |
2979
|
12
|
|
|
|
|
61
|
$val = $valList[$index = 0]; |
2980
|
|
|
|
|
|
|
} elsif (ref $conv eq 'ARRAY' or ref $convInv eq 'ARRAY') { |
2981
|
|
|
|
|
|
|
# handle conversion lists |
2982
|
153
|
|
|
|
|
1464
|
@valList = split /$listSep{$type}/, $val; |
2983
|
153
|
|
|
|
|
467
|
$val = $valList[$index = 0]; |
2984
|
153
|
50
|
|
|
|
526
|
if (ref $conv eq 'ARRAY') { |
2985
|
153
|
|
|
|
|
319
|
$convList = $conv; |
2986
|
153
|
|
|
|
|
518
|
$conv = $$conv[0]; |
2987
|
|
|
|
|
|
|
} |
2988
|
153
|
100
|
|
|
|
464
|
if (ref $convInv eq 'ARRAY') { |
2989
|
29
|
|
|
|
|
64
|
$convInvList = $convInv; |
2990
|
29
|
|
|
|
|
69
|
$convInv = $$convInv[0]; |
2991
|
|
|
|
|
|
|
} |
2992
|
|
|
|
|
|
|
} |
2993
|
|
|
|
|
|
|
# loop through multiple values if necessary |
2994
|
22525
|
|
|
|
|
32934
|
for (;;) { |
2995
|
22577
|
100
|
|
|
|
50205
|
if ($convInv) { |
|
|
100
|
|
|
|
|
|
2996
|
|
|
|
|
|
|
# capture eval warnings too |
2997
|
13657
|
|
|
|
|
61393
|
local $SIG{'__WARN__'} = \&SetWarning; |
2998
|
13657
|
|
|
|
|
27252
|
undef $evalWarning; |
2999
|
13657
|
100
|
|
|
|
27018
|
if (ref($convInv) eq 'CODE') { |
3000
|
144
|
|
|
|
|
756
|
$val = &$convInv($val, $self); |
3001
|
|
|
|
|
|
|
} else { |
3002
|
|
|
|
|
|
|
#### eval PrintConvInv/ValueConvInv ($val, $self, $wantGroup) |
3003
|
13513
|
|
|
|
|
888127
|
$val = eval $convInv; |
3004
|
13513
|
100
|
|
|
|
58785
|
$@ and $evalWarning = $@; |
3005
|
|
|
|
|
|
|
} |
3006
|
13657
|
100
|
|
|
|
59905
|
if ($evalWarning) { |
|
|
100
|
|
|
|
|
|
3007
|
|
|
|
|
|
|
# an empty warning ("\n") ignores tag with no error |
3008
|
223
|
100
|
|
|
|
691
|
if ($evalWarning eq "\n") { |
3009
|
9
|
50
|
|
|
|
44
|
$err = '' unless defined $err; |
3010
|
|
|
|
|
|
|
} else { |
3011
|
214
|
|
|
|
|
748
|
$err = CleanWarning() . " in $wgrp1:$tag (${type}Inv)"; |
3012
|
214
|
|
|
|
|
1005
|
$self->VPrint(2, "$err\n"); |
3013
|
|
|
|
|
|
|
} |
3014
|
223
|
|
|
|
|
492
|
undef $val; |
3015
|
223
|
|
|
|
|
984
|
last Conv; |
3016
|
|
|
|
|
|
|
} elsif (not defined $val) { |
3017
|
124
|
|
|
|
|
626
|
$err = "Error converting value for $wgrp1:$tag (${type}Inv)"; |
3018
|
124
|
|
|
|
|
669
|
$self->VPrint(2, "$err\n"); |
3019
|
124
|
|
|
|
|
576
|
last Conv; |
3020
|
|
|
|
|
|
|
} |
3021
|
|
|
|
|
|
|
} elsif ($conv) { |
3022
|
8917
|
100
|
66
|
|
|
40440
|
if (ref $conv eq 'HASH' and (not exists $$tagInfo{"${type}Inv"} or $convInvList)) { |
|
|
100
|
66
|
|
|
|
|
3023
|
8730
|
|
|
|
|
14670
|
my ($multi, $lc); |
3024
|
|
|
|
|
|
|
# insert alternate language print conversions if required |
3025
|
8730
|
0
|
33
|
|
|
22982
|
if ($$self{CUR_LANG} and $type eq 'PrintConv' and |
|
|
|
33
|
|
|
|
|
|
|
|
0
|
|
|
|
|
3026
|
|
|
|
|
|
|
ref($lc = $$self{CUR_LANG}{$tag}) eq 'HASH' and |
3027
|
|
|
|
|
|
|
($lc = $$lc{PrintConv})) |
3028
|
|
|
|
|
|
|
{ |
3029
|
0
|
|
|
|
|
0
|
my %newConv; |
3030
|
0
|
|
|
|
|
0
|
foreach (keys %$conv) { |
3031
|
0
|
|
|
|
|
0
|
my $val = $$conv{$_}; |
3032
|
0
|
0
|
|
|
|
0
|
defined $$lc{$val} or $newConv{$_} = $val, next; |
3033
|
0
|
|
|
|
|
0
|
$newConv{$_} = $self->Decode($$lc{$val}, 'UTF8'); |
3034
|
|
|
|
|
|
|
} |
3035
|
0
|
0
|
|
|
|
0
|
if ($$conv{BITMASK}) { |
3036
|
0
|
|
|
|
|
0
|
foreach (keys %{$$conv{BITMASK}}) { |
|
0
|
|
|
|
|
0
|
|
3037
|
0
|
|
|
|
|
0
|
my $val = $$conv{BITMASK}{$_}; |
3038
|
0
|
0
|
|
|
|
0
|
defined $$lc{$val} or $newConv{BITMASK}{$_} = $val, next; |
3039
|
0
|
|
|
|
|
0
|
$newConv{BITMASK}{$_} = $self->Decode($$lc{$val}, 'UTF8'); |
3040
|
|
|
|
|
|
|
} |
3041
|
|
|
|
|
|
|
} |
3042
|
0
|
|
|
|
|
0
|
$conv = \%newConv; |
3043
|
|
|
|
|
|
|
} |
3044
|
8730
|
|
|
|
|
14233
|
undef $evalWarning; |
3045
|
8730
|
100
|
|
|
|
24216
|
if ($$conv{BITMASK}) { |
3046
|
104
|
|
|
|
|
328
|
my $lookupBits = $$conv{BITMASK}; |
3047
|
104
|
|
|
|
|
326
|
my ($wbits, $tbits) = @$tagInfo{'BitsPerWord','BitsTotal'}; |
3048
|
104
|
|
|
|
|
397
|
my ($val2, $err2) = EncodeBits($val, $lookupBits, $wbits, $tbits); |
3049
|
104
|
100
|
|
|
|
411
|
if ($err2) { |
|
|
100
|
|
|
|
|
|
3050
|
|
|
|
|
|
|
# ok, try matching a straight value |
3051
|
2
|
|
|
|
|
8
|
($val, $multi) = ReverseLookup($val, $conv); |
3052
|
2
|
50
|
|
|
|
14
|
unless (defined $val) { |
3053
|
2
|
|
|
|
|
12
|
$err = "Can't encode $wgrp1:$tag ($err2)"; |
3054
|
2
|
|
|
|
|
19
|
$self->VPrint(2, "$err\n"); |
3055
|
2
|
|
|
|
|
7
|
last Conv; |
3056
|
|
|
|
|
|
|
} |
3057
|
|
|
|
|
|
|
} elsif (defined $val2) { |
3058
|
71
|
|
|
|
|
181
|
$val = $val2; |
3059
|
|
|
|
|
|
|
} else { |
3060
|
31
|
|
|
|
|
93
|
delete $$conv{BITMASK}; |
3061
|
31
|
|
|
|
|
100
|
($val, $multi) = ReverseLookup($val, $conv); |
3062
|
31
|
|
|
|
|
103
|
$$conv{BITMASK} = $lookupBits; |
3063
|
|
|
|
|
|
|
} |
3064
|
|
|
|
|
|
|
} else { |
3065
|
8626
|
|
|
|
|
22565
|
($val, $multi) = ReverseLookup($val, $conv); |
3066
|
|
|
|
|
|
|
} |
3067
|
8728
|
100
|
|
|
|
28515
|
if (not defined $val) { |
|
|
50
|
|
|
|
|
|
3068
|
4619
|
100
|
|
|
|
16995
|
my $prob = $evalWarning ? lcfirst CleanWarning() : ($multi ? 'matches more than one ' : 'not in ') . $type; |
|
|
50
|
|
|
|
|
|
3069
|
4619
|
|
|
|
|
12038
|
$err = "Can't convert $wgrp1:$tag ($prob)"; |
3070
|
4619
|
|
|
|
|
21600
|
$self->VPrint(2, "$err\n"); |
3071
|
4619
|
|
|
|
|
12235
|
last Conv; |
3072
|
|
|
|
|
|
|
} elsif ($evalWarning) { |
3073
|
0
|
|
|
|
|
0
|
$self->VPrint(2, CleanWarning() . " for $wgrp1:$tag\n"); |
3074
|
|
|
|
|
|
|
} |
3075
|
|
|
|
|
|
|
} elsif (not $$tagInfo{WriteAlso}) { |
3076
|
164
|
|
|
|
|
640
|
$err = "Can't convert value for $wgrp1:$tag (no ${type}Inv)"; |
3077
|
164
|
|
|
|
|
837
|
$self->VPrint(2, "$err\n"); |
3078
|
164
|
|
|
|
|
387
|
undef $val; |
3079
|
164
|
|
|
|
|
492
|
last Conv; |
3080
|
|
|
|
|
|
|
} |
3081
|
|
|
|
|
|
|
} |
3082
|
17445
|
100
|
|
|
|
58579
|
last unless @valList; |
3083
|
124
|
|
|
|
|
413
|
$valList[$index] = $val; |
3084
|
124
|
100
|
|
|
|
410
|
if (++$index >= @valList) { |
3085
|
|
|
|
|
|
|
# leave AutoSplit lists in ARRAY form, or join conversion lists |
3086
|
72
|
100
|
|
|
|
409
|
$val = $$tagInfo{List} ? \@valList : join ' ', @valList; |
3087
|
72
|
|
|
|
|
236
|
last; |
3088
|
|
|
|
|
|
|
} |
3089
|
52
|
100
|
|
|
|
173
|
$conv = $$convList[$index] if $convList; |
3090
|
52
|
100
|
|
|
|
160
|
$convInv = $$convInvList[$index] if $convInvList; |
3091
|
52
|
|
|
|
|
116
|
$val = $valList[$index]; |
3092
|
|
|
|
|
|
|
} |
3093
|
|
|
|
|
|
|
} # end ValueConv/PrintConv loop |
3094
|
|
|
|
|
|
|
|
3095
|
28276
|
|
|
|
|
86165
|
return($val, $err); |
3096
|
|
|
|
|
|
|
} |
3097
|
|
|
|
|
|
|
|
3098
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
3099
|
|
|
|
|
|
|
# Convert tag names to values or variables in a string |
3100
|
|
|
|
|
|
|
# (eg. '${EXIF:ISO}x $$' --> '100x $' without hash ref, or "$info{'EXIF:ISO'}x $" with) |
3101
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object ref, 1) reference to list of found tags |
3102
|
|
|
|
|
|
|
# 2) string with embedded tag names, 3) Options: |
3103
|
|
|
|
|
|
|
# undef - set missing tags to '' |
3104
|
|
|
|
|
|
|
# 'Error' - issue minor error on missing tag (and return undef) |
3105
|
|
|
|
|
|
|
# 'Warn' - issue minor warning on missing tag (and return undef) |
3106
|
|
|
|
|
|
|
# 'Silent' - just return undef on missing tag (no errors/warnings) |
3107
|
|
|
|
|
|
|
# Hash ref - defined to interpolate as variables in string instead of values |
3108
|
|
|
|
|
|
|
# --> receives tag/value pairs for interpolation of the variables |
3109
|
|
|
|
|
|
|
# 4) document group name if extracting from a specific document |
3110
|
|
|
|
|
|
|
# 5) hash ref to cache tag keys for subsequent calls in document loop |
3111
|
|
|
|
|
|
|
# Returns: string with embedded tag values (or '$info{TAGNAME}' entries with Hash ref option) |
3112
|
|
|
|
|
|
|
# Notes: |
3113
|
|
|
|
|
|
|
# - tag names are not case sensitive and may end with '#' for ValueConv value |
3114
|
|
|
|
|
|
|
# - uses MissingTagValue option if set |
3115
|
|
|
|
|
|
|
# - '$GROUP:all' evaluates to 1 if any tag from GROUP exists, or 0 otherwise |
3116
|
|
|
|
|
|
|
# - advanced feature allows Perl expressions inside braces (eg. '${model;tr/ //d}') |
3117
|
|
|
|
|
|
|
# - an error/warning in an advanced expression ("${TAG;EXPR}") generates an error |
3118
|
|
|
|
|
|
|
# if option set to 'Error', or a warning otherwise |
3119
|
|
|
|
|
|
|
sub InsertTagValues($$$;$$$) |
3120
|
|
|
|
|
|
|
{ |
3121
|
9
|
|
|
9
|
0
|
43
|
local $_; |
3122
|
9
|
|
|
|
|
51
|
my ($self, $foundTags, $line, $opt, $docGrp, $cache) = @_; |
3123
|
9
|
|
|
|
|
33
|
my $rtnStr = ''; |
3124
|
9
|
|
|
|
|
37
|
my ($docNum, $tag); |
3125
|
9
|
50
|
|
|
|
42
|
if ($docGrp) { |
3126
|
0
|
0
|
|
|
|
0
|
$docNum = $docGrp =~ /(\d+)$/ ? $1 : 0; |
3127
|
|
|
|
|
|
|
} else { |
3128
|
9
|
|
|
|
|
28
|
undef $cache; # no cache if no document groups |
3129
|
|
|
|
|
|
|
} |
3130
|
9
|
|
|
|
|
123
|
while ($line =~ s/(.*?)\$(\{\s*)?([-\w]*\w|\$|\/)//s) { |
3131
|
13
|
|
|
|
|
78
|
my ($pre, $bra, $var) = ($1, $2, $3); |
3132
|
13
|
|
|
|
|
40
|
my (@tags, $val, $tg, @val, $type, $expr, $didExpr, $level, $asList); |
3133
|
|
|
|
|
|
|
# "$$" represents a "$" symbol, and "$/" is a newline |
3134
|
13
|
50
|
33
|
|
|
103
|
if ($var eq '$' or $var eq '/') { |
3135
|
0
|
0
|
|
|
|
0
|
$line =~ s/^\s*\}// if $bra; |
3136
|
0
|
0
|
0
|
|
|
0
|
if ($var eq '/') { |
|
|
0
|
|
|
|
|
|
3137
|
0
|
|
|
|
|
0
|
$var = "\n"; |
3138
|
|
|
|
|
|
|
} elsif ($line =~ /^self\b/ and not $rtnStr =~ /\$$/) { |
3139
|
0
|
|
|
|
|
0
|
$var = '$$'; # ("$$self{var}" in string) |
3140
|
|
|
|
|
|
|
} |
3141
|
0
|
|
|
|
|
0
|
$rtnStr .= "$pre$var"; |
3142
|
0
|
|
|
|
|
0
|
next; |
3143
|
|
|
|
|
|
|
} |
3144
|
|
|
|
|
|
|
# allow multiple group names |
3145
|
13
|
|
|
|
|
78
|
while ($line =~ /^:([-\w]*\w)(.*)/s) { |
3146
|
7
|
|
|
|
|
25
|
my $group = $var; |
3147
|
7
|
|
|
|
|
22
|
($var, $line) = ($1, $2); |
3148
|
7
|
|
|
|
|
30
|
$var = "$group:$var"; |
3149
|
|
|
|
|
|
|
} |
3150
|
|
|
|
|
|
|
# allow trailing '#' to indicate ValueConv value |
3151
|
13
|
50
|
|
|
|
51
|
$type = 'ValueConv' if $line =~ s/^#//; |
3152
|
|
|
|
|
|
|
# special advanced formatting '@' feature to evaluate list values separately |
3153
|
13
|
100
|
100
|
|
|
85
|
if ($bra and $line =~ s/^\@(#)?//) { |
3154
|
1
|
|
|
|
|
2
|
$asList = 1; |
3155
|
1
|
50
|
|
|
|
9
|
$type = 'ValueConv' if $1; |
3156
|
|
|
|
|
|
|
} |
3157
|
|
|
|
|
|
|
# remove trailing bracket if there was a leading one |
3158
|
|
|
|
|
|
|
# and extract Perl expression from inside brackets if it exists |
3159
|
13
|
100
|
100
|
|
|
133
|
if ($bra and $line !~ s/^\s*\}// and $line =~ s/^\s*;\s*(.*?)\s*\}//s) { |
|
|
|
66
|
|
|
|
|
3160
|
3
|
|
|
|
|
16
|
my $part = $1; |
3161
|
3
|
|
|
|
|
11
|
$expr = ''; |
3162
|
3
|
|
|
|
|
14
|
for ($level=0; ; --$level) { |
3163
|
|
|
|
|
|
|
# increase nesting level for each opening brace |
3164
|
7
|
|
|
|
|
34
|
++$level while $part =~ /\{/g; |
3165
|
7
|
|
|
|
|
19
|
$expr .= $part; |
3166
|
7
|
100
|
66
|
|
|
48
|
last unless $level and $line =~ s/^(.*?)\s*\}//s; # get next part |
3167
|
4
|
|
|
|
|
14
|
$part = $1; |
3168
|
4
|
|
|
|
|
7
|
$expr .= '}'; # this brace was part of the expression |
3169
|
|
|
|
|
|
|
} |
3170
|
|
|
|
|
|
|
# use default Windows filename filter if expression is empty |
3171
|
3
|
50
|
|
|
|
19
|
$expr = 'tr(/\\\\?*:|"<>\\0)()d' unless length $expr; |
3172
|
|
|
|
|
|
|
} |
3173
|
13
|
|
|
|
|
60
|
push @tags, $var; |
3174
|
13
|
|
|
|
|
80
|
ExpandShortcuts(\@tags); |
3175
|
13
|
50
|
|
|
|
80
|
@tags or $rtnStr .= $pre, next; |
3176
|
|
|
|
|
|
|
# save advanced formatting expression to allow access by user-defined ValueConv |
3177
|
13
|
|
|
|
|
57
|
$$self{FMT_EXPR} = $expr; |
3178
|
|
|
|
|
|
|
|
3179
|
13
|
|
|
|
|
29
|
for (;;) { |
3180
|
|
|
|
|
|
|
# temporarily reset ListJoin option if evaluating list values separately |
3181
|
13
|
|
|
|
|
32
|
my $oldListJoin; |
3182
|
13
|
100
|
|
|
|
55
|
$oldListJoin = $self->Options(ListJoin => undef) if $asList; |
3183
|
13
|
|
|
|
|
34
|
$tag = shift @tags; |
3184
|
13
|
|
|
|
|
43
|
my $lcTag = lc $tag; |
3185
|
13
|
50
|
33
|
|
|
65
|
if ($cache and $lcTag !~ /(^|:)all$/) { |
3186
|
|
|
|
|
|
|
# remove group from tag name (but not lower-case version) |
3187
|
0
|
|
|
|
|
0
|
my $group; |
3188
|
0
|
0
|
|
|
|
0
|
$tag =~ s/^(.*):// and $group = $1; |
3189
|
|
|
|
|
|
|
# cache tag keys to speed processing for a large number of sub-documents |
3190
|
|
|
|
|
|
|
# (similar to code in BuildCompositeTags(), but this is case-insensitive) |
3191
|
0
|
|
|
|
|
0
|
my $cacheTag = $$cache{$lcTag}; |
3192
|
0
|
0
|
|
|
|
0
|
unless ($cacheTag) { |
3193
|
0
|
|
|
|
|
0
|
$cacheTag = $$cache{$lcTag} = [ ]; |
3194
|
|
|
|
|
|
|
# find all matching keys, organize into groups, and store in cache |
3195
|
0
|
|
|
|
|
0
|
my $ex = $$self{TAG_EXTRA}; |
3196
|
0
|
|
|
|
|
0
|
my @matches = grep /^$tag(\s|$)/i, @$foundTags; |
3197
|
0
|
0
|
|
|
|
0
|
@matches = $self->GroupMatches($group, \@matches) if defined $group; |
3198
|
0
|
|
|
|
|
0
|
foreach (@matches) { |
3199
|
0
|
0
|
0
|
|
|
0
|
my $doc = $$ex{$_} ? $$ex{$_}{G3} || 0 : 0; |
3200
|
0
|
0
|
|
|
|
0
|
if (defined $$cacheTag[$doc]) { |
3201
|
0
|
0
|
|
|
|
0
|
next unless $$cacheTag[$doc] =~ / \((\d+)\)$/; |
3202
|
0
|
|
|
|
|
0
|
my $cur = $1; |
3203
|
|
|
|
|
|
|
# keep the most recently extracted tag |
3204
|
0
|
0
|
0
|
|
|
0
|
next if / \((\d+)\)$/ and $1 < $cur; |
3205
|
|
|
|
|
|
|
} |
3206
|
0
|
|
|
|
|
0
|
$$cacheTag[$doc] = $_; |
3207
|
|
|
|
|
|
|
} |
3208
|
|
|
|
|
|
|
} |
3209
|
0
|
0
|
0
|
|
|
0
|
my $doc = $lcTag =~ /\b(main|doc(\d+)):/ ? ($2 || 0) : $docNum; |
3210
|
0
|
0
|
|
|
|
0
|
if ($$cacheTag[$doc]) { |
3211
|
0
|
|
|
|
|
0
|
$tag = $$cacheTag[$doc]; |
3212
|
0
|
|
|
|
|
0
|
$val = $self->GetValue($tag, $type); |
3213
|
|
|
|
|
|
|
} |
3214
|
|
|
|
|
|
|
} else { |
3215
|
|
|
|
|
|
|
# add document number to tag if specified and it doesn't already exist |
3216
|
13
|
50
|
33
|
|
|
60
|
if ($docGrp and $lcTag !~ /\b(main|doc\d+):/) { |
3217
|
0
|
|
|
|
|
0
|
$tag = $docGrp . ':' . $tag; |
3218
|
0
|
|
|
|
|
0
|
$lcTag = lc $tag; |
3219
|
|
|
|
|
|
|
} |
3220
|
13
|
|
|
|
|
34
|
my $et = $self; |
3221
|
13
|
100
|
|
|
|
83
|
if ($tag =~ s/(\bfile\d+)://i) { |
3222
|
3
|
50
|
|
|
|
28
|
$et = $$self{ALT_EXIFTOOL}{ucfirst lc $1} or $et=$self, $tag = 'no_alt_file'; |
3223
|
|
|
|
|
|
|
} |
3224
|
13
|
50
|
|
|
|
145
|
if ($lcTag eq 'all') { |
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
3225
|
0
|
|
|
|
|
0
|
$val = 1; # always some tag available |
3226
|
|
|
|
|
|
|
} elsif (defined $$et{OPTIONS}{UserParam}{$lcTag}) { |
3227
|
0
|
|
|
|
|
0
|
$val = $$et{OPTIONS}{UserParam}{$lcTag}; |
3228
|
|
|
|
|
|
|
} elsif ($tag =~ /(.*):(.+)/) { |
3229
|
3
|
|
|
|
|
10
|
my $group; |
3230
|
3
|
|
|
|
|
13
|
($group, $tag) = ($1, $2); |
3231
|
3
|
50
|
|
|
|
17
|
if (lc $tag eq 'all') { |
3232
|
|
|
|
|
|
|
# see if any tag from the specified group exists |
3233
|
0
|
|
|
|
|
0
|
my $match = $et->GroupMatches($group, $foundTags); |
3234
|
0
|
0
|
|
|
|
0
|
$val = $match ? 1 : 0; |
3235
|
|
|
|
|
|
|
} else { |
3236
|
|
|
|
|
|
|
# find the specified tag |
3237
|
3
|
|
|
|
|
698
|
my @matches = grep /^$tag(\s|$)/i, @$foundTags; |
3238
|
3
|
|
|
|
|
23
|
@matches = $et->GroupMatches($group, \@matches); |
3239
|
3
|
|
|
|
|
20
|
foreach $tg (@matches) { |
3240
|
3
|
50
|
33
|
|
|
17
|
if (defined $val and $tg =~ / \((\d+)\)$/) { |
3241
|
|
|
|
|
|
|
# take the most recently extracted tag |
3242
|
0
|
|
|
|
|
0
|
my $tagNum = $1; |
3243
|
0
|
0
|
0
|
|
|
0
|
next if $tag !~ / \((\d+)\)$/ or $1 > $tagNum; |
3244
|
|
|
|
|
|
|
} |
3245
|
3
|
|
|
|
|
15
|
$val = $et->GetValue($tg, $type); |
3246
|
3
|
|
|
|
|
11
|
$tag = $tg; |
3247
|
3
|
100
|
|
|
|
24
|
last unless $tag =~ / /; # all done if we got our best match |
3248
|
|
|
|
|
|
|
} |
3249
|
|
|
|
|
|
|
} |
3250
|
|
|
|
|
|
|
} elsif ($tag eq 'self') { |
3251
|
0
|
|
|
|
|
0
|
$val = $et; # ("$self{var}" or "$file1:self{var}" in string) |
3252
|
|
|
|
|
|
|
} else { |
3253
|
|
|
|
|
|
|
# get the tag value |
3254
|
10
|
|
|
|
|
52
|
$val = $et->GetValue($tag, $type); |
3255
|
10
|
100
|
|
|
|
63
|
unless (defined $val) { |
3256
|
|
|
|
|
|
|
# check for tag name with different case |
3257
|
7
|
|
|
|
|
763
|
($tg) = grep /^$tag$/i, @$foundTags; |
3258
|
7
|
50
|
|
|
|
52
|
if (defined $tg) { |
3259
|
7
|
|
|
|
|
32
|
$val = $et->GetValue($tg, $type); |
3260
|
7
|
|
|
|
|
33
|
$tag = $tg; |
3261
|
|
|
|
|
|
|
} |
3262
|
|
|
|
|
|
|
} |
3263
|
|
|
|
|
|
|
} |
3264
|
|
|
|
|
|
|
} |
3265
|
13
|
100
|
|
|
|
81
|
$self->Options(ListJoin => $oldListJoin) if $asList; |
3266
|
13
|
100
|
|
|
|
108
|
if (ref $val eq 'ARRAY') { |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
3267
|
1
|
|
|
|
|
6
|
push @val, @$val; |
3268
|
1
|
|
|
|
|
3
|
undef $val; |
3269
|
1
|
50
|
|
|
|
7
|
last unless @tags; |
3270
|
|
|
|
|
|
|
} elsif (ref $val eq 'SCALAR') { |
3271
|
0
|
0
|
0
|
|
|
0
|
if ($$self{OPTIONS}{Binary} or $$val =~ /^Binary data/) { |
3272
|
0
|
|
|
|
|
0
|
$val = $$val; |
3273
|
|
|
|
|
|
|
} else { |
3274
|
0
|
|
|
|
|
0
|
$val = 'Binary data ' . length($$val) . ' bytes'; |
3275
|
|
|
|
|
|
|
} |
3276
|
|
|
|
|
|
|
} elsif (ref $val eq 'HASH') { |
3277
|
0
|
|
|
|
|
0
|
require 'Image/ExifTool/XMPStruct.pl'; |
3278
|
0
|
|
|
|
|
0
|
$val = Image::ExifTool::XMP::SerializeStruct($val); |
3279
|
|
|
|
|
|
|
} elsif (not defined $val) { |
3280
|
0
|
0
|
|
|
|
0
|
$val = $$self{OPTIONS}{MissingTagValue} if $asList; |
3281
|
|
|
|
|
|
|
} |
3282
|
12
|
50
|
|
|
|
51
|
last unless @tags; |
3283
|
0
|
0
|
|
|
|
0
|
push @val, $val if defined $val; |
3284
|
0
|
|
|
|
|
0
|
undef $val; |
3285
|
|
|
|
|
|
|
} |
3286
|
13
|
100
|
|
|
|
46
|
if (@val) { |
3287
|
1
|
50
|
|
|
|
5
|
push @val, $val if defined $val; |
3288
|
1
|
|
|
|
|
8
|
$val = join $$self{OPTIONS}{ListSep}, @val; |
3289
|
|
|
|
|
|
|
} else { |
3290
|
12
|
50
|
|
|
|
53
|
push @val, $val if defined $val; # (so the eval has access to @val if required) |
3291
|
|
|
|
|
|
|
} |
3292
|
|
|
|
|
|
|
# evaluate advanced formatting expression if given (eg. "${TAG;EXPR}") |
3293
|
13
|
100
|
66
|
|
|
92
|
if (defined $expr and defined $val) { |
3294
|
3
|
|
|
|
|
22
|
local $SIG{'__WARN__'} = \&SetWarning; |
3295
|
3
|
|
|
|
|
10
|
undef $evalWarning; |
3296
|
3
|
|
|
|
|
10
|
$advFmtSelf = $self; |
3297
|
3
|
100
|
|
|
|
14
|
if ($asList) { |
3298
|
1
|
|
|
|
|
4
|
foreach (@val) { |
3299
|
|
|
|
|
|
|
#### eval advanced formatting expression ($_, $self, @val, $advFmtSelf) |
3300
|
3
|
|
|
|
|
279
|
eval $expr; |
3301
|
3
|
50
|
|
|
|
19
|
$@ and $evalWarning = $@; |
3302
|
|
|
|
|
|
|
} |
3303
|
|
|
|
|
|
|
# join back together if any values are still defined |
3304
|
1
|
|
|
|
|
8
|
@val = grep defined, @val; |
3305
|
1
|
50
|
|
|
|
9
|
$val = @val ? join $$self{OPTIONS}{ListSep}, @val : undef; |
3306
|
|
|
|
|
|
|
} else { |
3307
|
2
|
|
|
|
|
8
|
$_ = $val; |
3308
|
|
|
|
|
|
|
#### eval advanced formatting expression ($_, $self, @val, $advFmtSelf) |
3309
|
2
|
|
|
|
|
179
|
eval $expr; |
3310
|
2
|
50
|
|
|
|
17
|
$@ and $evalWarning = $@; |
3311
|
2
|
50
|
|
|
|
14
|
$val = ref $_ eq 'ARRAY' ? join($$self{OPTIONS}{ListSep}, @$_): $_; |
3312
|
|
|
|
|
|
|
} |
3313
|
3
|
50
|
|
|
|
19
|
if ($evalWarning) { |
3314
|
0
|
0
|
0
|
|
|
0
|
my $g3 = ($docGrp and $var !~ /\b(main|doc\d+):/i) ? $docGrp . ':' : ''; |
3315
|
0
|
|
|
|
|
0
|
my $str = CleanWarning() . " for '$g3${var}'"; |
3316
|
0
|
0
|
|
|
|
0
|
if ($opt) { |
3317
|
0
|
0
|
|
|
|
0
|
if ($opt eq 'Error') { |
|
|
0
|
|
|
|
|
|
3318
|
0
|
|
|
|
|
0
|
$self->Error($str); |
3319
|
|
|
|
|
|
|
} elsif ($opt ne 'Silent') { |
3320
|
0
|
|
|
|
|
0
|
$self->Warn($str); |
3321
|
|
|
|
|
|
|
} |
3322
|
|
|
|
|
|
|
} |
3323
|
|
|
|
|
|
|
} |
3324
|
3
|
|
|
|
|
9
|
undef $advFmtSelf; |
3325
|
3
|
|
|
|
|
16
|
$didExpr = 1; # set flag indicating an expression was evaluated |
3326
|
|
|
|
|
|
|
} |
3327
|
13
|
50
|
|
|
|
57
|
unless (defined $val) { |
3328
|
0
|
|
|
|
|
0
|
$val = $$self{OPTIONS}{MissingTagValue}; |
3329
|
0
|
0
|
|
|
|
0
|
unless (defined $val) { |
3330
|
0
|
0
|
0
|
|
|
0
|
my $g3 = ($docGrp and $var !~ /\b(main|doc\d+):/i) ? $docGrp . ':' : ''; |
3331
|
0
|
0
|
|
|
|
0
|
my $msg = $didExpr ? "Advanced formatting expression returned undef for '$g3${var}'" : |
3332
|
|
|
|
|
|
|
"Tag '$g3${var}' not defined"; |
3333
|
0
|
0
|
|
|
|
0
|
if (ref $opt) { |
|
|
0
|
|
|
|
|
|
3334
|
0
|
0
|
|
|
|
0
|
$self->Warn($msg,2) or $val = ''; |
3335
|
|
|
|
|
|
|
} elsif ($opt) { |
3336
|
59
|
|
|
59
|
|
609
|
no strict 'refs'; |
|
59
|
|
|
|
|
194
|
|
|
59
|
|
|
|
|
42906
|
|
3337
|
0
|
0
|
0
|
|
|
0
|
($opt eq 'Silent' or &$opt($self, $msg, 2)) and return $$self{FMT_EXPR} = undef; |
3338
|
0
|
|
|
|
|
0
|
$val = ''; |
3339
|
|
|
|
|
|
|
} |
3340
|
|
|
|
|
|
|
} |
3341
|
|
|
|
|
|
|
} |
3342
|
13
|
50
|
|
|
|
50
|
if (ref $opt eq 'HASH') { |
3343
|
0
|
0
|
|
|
|
0
|
$var .= '#' if $type; |
3344
|
0
|
0
|
|
|
|
0
|
if (defined $expr) { |
3345
|
|
|
|
|
|
|
# generate unique variable name for this modified tag value |
3346
|
0
|
|
|
|
|
0
|
my $i = 1; |
3347
|
0
|
|
|
|
|
0
|
++$i while exists $$opt{"$var.expr$i"}; |
3348
|
0
|
|
|
|
|
0
|
$var .= '.expr' . $i; |
3349
|
|
|
|
|
|
|
} |
3350
|
0
|
|
|
|
|
0
|
$rtnStr .= "$pre\$info{'${var}'}"; |
3351
|
0
|
|
|
|
|
0
|
$$opt{$var} = $val; |
3352
|
|
|
|
|
|
|
} else { |
3353
|
13
|
|
|
|
|
97
|
$rtnStr .= "$pre$val"; |
3354
|
|
|
|
|
|
|
} |
3355
|
|
|
|
|
|
|
} |
3356
|
9
|
|
|
|
|
42
|
$$self{FMT_EXPR} = undef; |
3357
|
9
|
|
|
|
|
47
|
return $rtnStr . $line; |
3358
|
|
|
|
|
|
|
} |
3359
|
|
|
|
|
|
|
|
3360
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
3361
|
|
|
|
|
|
|
# Reformat date/time value in $_ based on specified format string |
3362
|
|
|
|
|
|
|
# Inputs: 0) date/time format string |
3363
|
|
|
|
|
|
|
sub DateFmt($) |
3364
|
|
|
|
|
|
|
{ |
3365
|
0
|
|
|
0
|
0
|
0
|
my $et = bless { OPTIONS => { DateFormat => shift, StrictDate => 1 } }; |
3366
|
0
|
|
|
|
|
0
|
my $shift; |
3367
|
0
|
0
|
0
|
|
|
0
|
if ($advFmtSelf and defined($shift = $$advFmtSelf{OPTIONS}{GlobalTimeShift})) { |
3368
|
0
|
|
|
|
|
0
|
$$et{OPTIONS}{GlobalTimeShift} = $shift; |
3369
|
0
|
|
|
|
|
0
|
$$et{GLOBAL_TIME_OFFSET} = $$advFmtSelf{GLOBAL_TIME_OFFSET}; |
3370
|
|
|
|
|
|
|
} |
3371
|
0
|
|
|
|
|
0
|
$_ = $et->ConvertDateTime($_); |
3372
|
0
|
0
|
|
|
|
0
|
defined $_ or warn "Error converting date/time\n"; |
3373
|
0
|
0
|
|
|
|
0
|
$$advFmtSelf{GLOBAL_TIME_OFFSET} = $$et{GLOBAL_TIME_OFFSET} if $shift; |
3374
|
|
|
|
|
|
|
} |
3375
|
|
|
|
|
|
|
|
3376
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
3377
|
|
|
|
|
|
|
# Utility routine to remove duplicate items from default input string |
3378
|
|
|
|
|
|
|
# Inputs: 0) true to set $_ to undef if not changed |
3379
|
|
|
|
|
|
|
# Notes: - for use only in advanced formatting expressions |
3380
|
|
|
|
|
|
|
sub NoDups |
3381
|
|
|
|
|
|
|
{ |
3382
|
0
|
|
|
0
|
0
|
0
|
my %seen; |
3383
|
0
|
0
|
|
|
|
0
|
my $sep = $advFmtSelf ? $$advFmtSelf{OPTIONS}{ListSep} : ', '; |
3384
|
0
|
|
|
|
|
0
|
my $new = join $sep, grep { !$seen{$_}++ } split /\Q$sep\E/, $_; |
|
0
|
|
|
|
|
0
|
|
3385
|
0
|
0
|
0
|
|
|
0
|
$_ = ($_[0] and $new eq $_) ? undef : $new; |
3386
|
|
|
|
|
|
|
} |
3387
|
|
|
|
|
|
|
|
3388
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
3389
|
|
|
|
|
|
|
# Is specified tag writable |
3390
|
|
|
|
|
|
|
# Inputs: 0) tag name, case insensitive (optional group name currently ignored) |
3391
|
|
|
|
|
|
|
# Returns: 0=exists but not writable, 1=writable, undef=doesn't exist |
3392
|
|
|
|
|
|
|
sub IsWritable($) |
3393
|
|
|
|
|
|
|
{ |
3394
|
0
|
|
|
0
|
0
|
0
|
my $tag = shift; |
3395
|
0
|
|
|
|
|
0
|
$tag =~ s/^(.*)://; # ignore group name |
3396
|
0
|
|
|
|
|
0
|
my @tagInfo = FindTagInfo($tag); |
3397
|
0
|
0
|
|
|
|
0
|
unless (@tagInfo) { |
3398
|
0
|
0
|
|
|
|
0
|
return 0 if TagExists($tag); |
3399
|
0
|
|
|
|
|
0
|
return undef; |
3400
|
|
|
|
|
|
|
} |
3401
|
0
|
|
|
|
|
0
|
my $tagInfo; |
3402
|
0
|
|
|
|
|
0
|
foreach $tagInfo (@tagInfo) { |
3403
|
0
|
0
|
|
|
|
0
|
return $$tagInfo{Writable} ? 1 : 0 if defined $$tagInfo{Writable}; |
|
|
0
|
|
|
|
|
|
3404
|
0
|
0
|
|
|
|
0
|
return 1 if $$tagInfo{Table}{WRITABLE}; |
3405
|
|
|
|
|
|
|
# must call WRITE_PROC to autoload writer because this may set the writable tag |
3406
|
0
|
|
|
|
|
0
|
my $writeProc = $$tagInfo{Table}{WRITE_PROC}; |
3407
|
0
|
0
|
|
|
|
0
|
if ($writeProc) { |
3408
|
59
|
|
|
59
|
|
614
|
no strict 'refs'; |
|
59
|
|
|
|
|
213
|
|
|
59
|
|
|
|
|
16813
|
|
3409
|
0
|
|
|
|
|
0
|
&$writeProc(); # dummy call to autoload writer |
3410
|
0
|
0
|
|
|
|
0
|
return 1 if $$tagInfo{Writable}; |
3411
|
|
|
|
|
|
|
} |
3412
|
|
|
|
|
|
|
} |
3413
|
0
|
|
|
|
|
0
|
return 0; |
3414
|
|
|
|
|
|
|
} |
3415
|
|
|
|
|
|
|
|
3416
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
3417
|
|
|
|
|
|
|
# Check to see if these are the same file |
3418
|
|
|
|
|
|
|
# Inputs: 0) ExifTool ref, 1) first file name, 2) second file name |
3419
|
|
|
|
|
|
|
# Returns: true if file names reference the same file |
3420
|
|
|
|
|
|
|
sub IsSameFile($$$) |
3421
|
|
|
|
|
|
|
{ |
3422
|
0
|
|
|
0
|
0
|
0
|
my ($self, $file, $file2) = @_; |
3423
|
0
|
0
|
|
|
|
0
|
return 0 unless lc $file eq lc $file2; # (only looking for differences in case) |
3424
|
0
|
|
|
|
|
0
|
my ($isSame, $interrupted); |
3425
|
0
|
|
|
|
|
0
|
my $tmp1 = "${file}_ExifTool_tmp_$$"; |
3426
|
0
|
|
|
|
|
0
|
my $tmp2 = "${file2}_ExifTool_tmp_$$"; |
3427
|
|
|
|
|
|
|
{ |
3428
|
0
|
|
|
|
|
0
|
local *TMP1; |
|
0
|
|
|
|
|
0
|
|
3429
|
0
|
|
|
0
|
|
0
|
local $SIG{INT} = sub { $interrupted = 1 }; |
|
0
|
|
|
|
|
0
|
|
3430
|
0
|
0
|
|
|
|
0
|
if ($self->Open(\*TMP1, $tmp1, '>')) { |
3431
|
0
|
|
|
|
|
0
|
close TMP1; |
3432
|
0
|
0
|
|
|
|
0
|
$isSame = 1 if $self->Exists($tmp2); |
3433
|
0
|
|
|
|
|
0
|
$self->Unlink($tmp1); |
3434
|
|
|
|
|
|
|
} |
3435
|
|
|
|
|
|
|
} |
3436
|
0
|
0
|
0
|
|
|
0
|
if ($interrupted and $SIG{INT}) { |
3437
|
59
|
|
|
59
|
|
562
|
no strict 'refs'; |
|
59
|
|
|
|
|
182
|
|
|
59
|
|
|
|
|
149220
|
|
3438
|
0
|
|
|
|
|
0
|
&{$SIG{INT}}(); |
|
0
|
|
|
|
|
0
|
|
3439
|
|
|
|
|
|
|
} |
3440
|
0
|
|
|
|
|
0
|
return $isSame; |
3441
|
|
|
|
|
|
|
} |
3442
|
|
|
|
|
|
|
|
3443
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
3444
|
|
|
|
|
|
|
# Is this a raw file type? |
3445
|
|
|
|
|
|
|
# Inputs: 0) ExifTool ref |
3446
|
|
|
|
|
|
|
# Returns: true if FileType is a type of RAW image |
3447
|
|
|
|
|
|
|
sub IsRawType($) |
3448
|
|
|
|
|
|
|
{ |
3449
|
12
|
|
|
12
|
0
|
38
|
my $self = shift; |
3450
|
12
|
|
|
|
|
123
|
return $rawType{$$self{FileType}}; |
3451
|
|
|
|
|
|
|
} |
3452
|
|
|
|
|
|
|
|
3453
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
3454
|
|
|
|
|
|
|
# Create directory for specified file |
3455
|
|
|
|
|
|
|
# Inputs: 0) ExifTool ref, 1) complete file name including path |
3456
|
|
|
|
|
|
|
# Returns: 1 = directory created, 0 = nothing done, -1 = error |
3457
|
|
|
|
|
|
|
my $k32CreateDir; |
3458
|
|
|
|
|
|
|
sub CreateDirectory($$) |
3459
|
|
|
|
|
|
|
{ |
3460
|
1
|
|
|
1
|
0
|
4
|
local $_; |
3461
|
1
|
|
|
|
|
4
|
my ($self, $file) = @_; |
3462
|
1
|
|
|
|
|
2
|
my $rtnVal = 0; |
3463
|
1
|
|
|
|
|
3
|
my $enc = $$self{OPTIONS}{CharsetFileName}; |
3464
|
1
|
|
|
|
|
2
|
my $dir; |
3465
|
1
|
|
|
|
|
12
|
($dir = $file) =~ s/[^\/]*$//; # remove filename from path specification |
3466
|
|
|
|
|
|
|
# recode as UTF-8 if necessary |
3467
|
1
|
50
|
33
|
|
|
10
|
if ($dir and not $self->IsDirectory($dir)) { |
3468
|
0
|
|
|
|
|
0
|
my @parts = split /\//, $dir; |
3469
|
0
|
|
|
|
|
0
|
$dir = ''; |
3470
|
0
|
|
|
|
|
0
|
foreach (@parts) { |
3471
|
0
|
|
|
|
|
0
|
$dir .= $_; |
3472
|
0
|
0
|
0
|
|
|
0
|
if (length $dir and not $self->IsDirectory($dir)) { |
3473
|
|
|
|
|
|
|
# create directory since it doesn't exist |
3474
|
0
|
|
|
|
|
0
|
my $d2 = $dir; # (must make a copy in case EncodeFileName recodes it) |
3475
|
0
|
0
|
|
|
|
0
|
if ($self->EncodeFileName($d2)) { |
3476
|
|
|
|
|
|
|
# handle Windows Unicode directory names |
3477
|
0
|
0
|
|
|
|
0
|
unless (eval { require Win32::API }) { |
|
0
|
|
|
|
|
0
|
|
3478
|
0
|
|
|
|
|
0
|
$self->Warn('Install Win32::API to create directories with Unicode names'); |
3479
|
0
|
|
|
|
|
0
|
return -1; |
3480
|
|
|
|
|
|
|
} |
3481
|
0
|
0
|
|
|
|
0
|
unless ($k32CreateDir) { |
3482
|
0
|
0
|
|
|
|
0
|
return -1 if defined $k32CreateDir; |
3483
|
0
|
|
|
|
|
0
|
$k32CreateDir = new Win32::API('KERNEL32', 'CreateDirectoryW', 'PP', 'I'); |
3484
|
0
|
0
|
|
|
|
0
|
unless ($k32CreateDir) { |
3485
|
0
|
|
|
|
|
0
|
$self->Warn('Error calling Win32::API::CreateDirectoryW'); |
3486
|
0
|
|
|
|
|
0
|
$k32CreateDir = 0; |
3487
|
0
|
|
|
|
|
0
|
return -1; |
3488
|
|
|
|
|
|
|
} |
3489
|
|
|
|
|
|
|
} |
3490
|
0
|
0
|
|
|
|
0
|
$k32CreateDir->Call($d2, 0) or return -1; |
3491
|
|
|
|
|
|
|
} else { |
3492
|
0
|
0
|
|
|
|
0
|
mkdir($d2, 0777) or return -1; |
3493
|
|
|
|
|
|
|
} |
3494
|
0
|
|
|
|
|
0
|
$rtnVal = 1; |
3495
|
|
|
|
|
|
|
} |
3496
|
0
|
|
|
|
|
0
|
$dir .= '/'; |
3497
|
|
|
|
|
|
|
} |
3498
|
|
|
|
|
|
|
} |
3499
|
1
|
|
|
|
|
7
|
return $rtnVal; |
3500
|
|
|
|
|
|
|
} |
3501
|
|
|
|
|
|
|
|
3502
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
3503
|
|
|
|
|
|
|
# Copy file attributes from one file to another |
3504
|
|
|
|
|
|
|
# Inputs: 0) ExifTool ref, 1) source file name, 2) destination file name |
3505
|
|
|
|
|
|
|
# Notes: eventually add support for extended attributes? |
3506
|
|
|
|
|
|
|
sub CopyFileAttrs($$$) |
3507
|
|
|
|
|
|
|
{ |
3508
|
2
|
|
|
2
|
0
|
12
|
my ($self, $src, $dst) = @_; |
3509
|
2
|
|
|
|
|
58
|
my ($mode, $uid, $gid) = (stat($src))[2, 4, 5]; |
3510
|
|
|
|
|
|
|
# copy file attributes unless we already set them |
3511
|
2
|
50
|
33
|
|
|
25
|
if (defined $mode and not defined $self->GetNewValue('FilePermissions')) { |
3512
|
2
|
|
|
|
|
6
|
eval { chmod($mode & 07777, $dst) }; |
|
2
|
|
|
|
|
61
|
|
3513
|
|
|
|
|
|
|
} |
3514
|
2
|
|
|
|
|
17
|
my $newUid = $self->GetNewValue('FileUserID'); |
3515
|
2
|
|
|
|
|
9
|
my $newGid = $self->GetNewValue('FileGroupID'); |
3516
|
2
|
50
|
33
|
|
|
41
|
if (defined $uid and defined $gid and (not defined $newUid or not defined $newGid)) { |
|
|
|
33
|
|
|
|
|
|
|
|
33
|
|
|
|
|
3517
|
2
|
50
|
|
|
|
12
|
defined $newGid and $gid = $newGid; |
3518
|
2
|
50
|
|
|
|
9
|
defined $newUid and $uid = $newUid; |
3519
|
2
|
|
|
|
|
8
|
eval { chown($uid, $gid, $dst) }; |
|
2
|
|
|
|
|
53
|
|
3520
|
|
|
|
|
|
|
} |
3521
|
|
|
|
|
|
|
} |
3522
|
|
|
|
|
|
|
|
3523
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
3524
|
|
|
|
|
|
|
# Get new file path name |
3525
|
|
|
|
|
|
|
# Inputs: 0) existing name (may contain directory), |
3526
|
|
|
|
|
|
|
# 1) new file name, new directory, or new path (dir+name) |
3527
|
|
|
|
|
|
|
# Returns: new file path name |
3528
|
|
|
|
|
|
|
sub GetNewFileName($$) |
3529
|
|
|
|
|
|
|
{ |
3530
|
1
|
|
|
1
|
0
|
3
|
my ($oldName, $newName) = @_; |
3531
|
1
|
|
|
|
|
10
|
my ($dir, $name) = ($oldName =~ m{(.*/)(.*)}); |
3532
|
1
|
50
|
|
|
|
5
|
($dir, $name) = ('', $oldName) unless defined $dir; |
3533
|
1
|
50
|
|
|
|
10
|
if ($newName =~ m{/$}) { |
|
|
50
|
|
|
|
|
|
3534
|
0
|
|
|
|
|
0
|
$newName = "$newName$name"; # change dir only |
3535
|
|
|
|
|
|
|
} elsif ($newName !~ m{/}) { |
3536
|
1
|
|
|
|
|
6
|
$newName = "$dir$newName"; # change name only if newname doesn't specify dir |
3537
|
|
|
|
|
|
|
} # else change dir and name |
3538
|
1
|
|
|
|
|
5
|
return $newName; |
3539
|
|
|
|
|
|
|
} |
3540
|
|
|
|
|
|
|
|
3541
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
3542
|
|
|
|
|
|
|
# Get next available tag key |
3543
|
|
|
|
|
|
|
# Inputs: 0) hash reference (keys are tag keys), 1) tag name |
3544
|
|
|
|
|
|
|
# Returns: next available tag key |
3545
|
|
|
|
|
|
|
sub NextFreeTagKey($$) |
3546
|
|
|
|
|
|
|
{ |
3547
|
0
|
|
|
0
|
0
|
0
|
my ($info, $tag) = @_; |
3548
|
0
|
0
|
|
|
|
0
|
return $tag unless exists $$info{$tag}; |
3549
|
0
|
|
|
|
|
0
|
my $i; |
3550
|
0
|
|
|
|
|
0
|
for ($i=1; ; ++$i) { |
3551
|
0
|
|
|
|
|
0
|
my $key = "$tag ($i)"; |
3552
|
0
|
0
|
|
|
|
0
|
return $key unless exists $$info{$key}; |
3553
|
|
|
|
|
|
|
} |
3554
|
|
|
|
|
|
|
} |
3555
|
|
|
|
|
|
|
|
3556
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
3557
|
|
|
|
|
|
|
# Reverse hash lookup |
3558
|
|
|
|
|
|
|
# Inputs: 0) value, 1) hash reference |
3559
|
|
|
|
|
|
|
# Returns: Hash key or undef if not found (plus flag for multiple matches in list context) |
3560
|
|
|
|
|
|
|
sub ReverseLookup($$) |
3561
|
|
|
|
|
|
|
{ |
3562
|
8726
|
|
|
8726
|
0
|
19887
|
my ($val, $conv) = @_; |
3563
|
8726
|
100
|
|
|
|
18045
|
return undef unless defined $val; |
3564
|
8665
|
|
|
|
|
13154
|
my $multi; |
3565
|
8665
|
100
|
|
|
|
19224
|
if ($val =~ /^Unknown\s*\((.*)\)$/i) { |
3566
|
40
|
|
|
|
|
141
|
$val = $1; # was unknown |
3567
|
40
|
50
|
|
|
|
119
|
if ($val =~ /^0x([\da-fA-F]+)$/) { |
3568
|
|
|
|
|
|
|
# disable "Hexadecimal number > 0xffffffff non-portable" warning |
3569
|
0
|
|
|
0
|
|
0
|
local $SIG{'__WARN__'} = sub { }; |
3570
|
0
|
|
|
|
|
0
|
$val = hex($val); # convert hex value |
3571
|
|
|
|
|
|
|
} |
3572
|
|
|
|
|
|
|
} else { |
3573
|
8625
|
|
|
|
|
14071
|
my $qval = $val; |
3574
|
8625
|
|
|
|
|
20129
|
$qval =~ s/\s+$//; # remove trailing whitespace |
3575
|
8625
|
|
|
|
|
15260
|
$qval = quotemeta $qval; |
3576
|
8625
|
|
|
|
|
35672
|
my @patterns = ( |
3577
|
|
|
|
|
|
|
"^$qval\$", # exact match |
3578
|
|
|
|
|
|
|
"^(?i)$qval\$", # case-insensitive |
3579
|
|
|
|
|
|
|
"^(?i)$qval", # beginning of string |
3580
|
|
|
|
|
|
|
"(?i)$qval", # substring |
3581
|
|
|
|
|
|
|
); |
3582
|
|
|
|
|
|
|
# hash entries to ignore in reverse lookup |
3583
|
8625
|
|
|
|
|
14474
|
my ($pattern, $found, $matches); |
3584
|
8625
|
|
|
|
|
18204
|
PAT: foreach $pattern (@patterns) { |
3585
|
22085
|
|
|
|
|
401122
|
$matches = scalar grep /$pattern/, values(%$conv); |
3586
|
22085
|
100
|
|
|
|
59902
|
next unless $matches; |
3587
|
|
|
|
|
|
|
# multiple matches are bad unless they were exact |
3588
|
6524
|
100
|
100
|
|
|
22768
|
if ($matches > 1 and $pattern !~ /\$$/) { |
3589
|
|
|
|
|
|
|
# don't match entries that we should ignore |
3590
|
3212
|
|
|
|
|
9067
|
foreach (keys %ignorePrintConv) { |
3591
|
9636
|
100
|
100
|
|
|
24646
|
--$matches if defined $$conv{$_} and $$conv{$_} =~ /$pattern/; |
3592
|
|
|
|
|
|
|
} |
3593
|
3212
|
100
|
|
|
|
11031
|
last if $matches > 1; |
3594
|
|
|
|
|
|
|
} |
3595
|
3442
|
|
|
|
|
53245
|
foreach (sort keys %$conv) { |
3596
|
10741
|
100
|
100
|
|
|
44744
|
next if $$conv{$_} !~ /$pattern/ or $ignorePrintConv{$_}; |
3597
|
3416
|
|
|
|
|
6654
|
$val = $_; |
3598
|
3416
|
|
|
|
|
5355
|
$found = 1; |
3599
|
3416
|
|
|
|
|
7403
|
last PAT; |
3600
|
|
|
|
|
|
|
} |
3601
|
|
|
|
|
|
|
} |
3602
|
8625
|
100
|
|
|
|
23778
|
unless ($found) { |
3603
|
|
|
|
|
|
|
# call OTHER conversion routine if available |
3604
|
5209
|
100
|
|
|
|
13342
|
if ($$conv{OTHER}) { |
3605
|
792
|
|
|
|
|
4099
|
local $SIG{'__WARN__'} = \&SetWarning; |
3606
|
792
|
|
|
|
|
1472
|
undef $evalWarning; |
3607
|
792
|
|
|
|
|
1328
|
$val = &{$$conv{OTHER}}($val,1,$conv); |
|
792
|
|
|
|
|
3327
|
|
3608
|
|
|
|
|
|
|
} else { |
3609
|
4417
|
|
|
|
|
7567
|
$val = undef; |
3610
|
|
|
|
|
|
|
} |
3611
|
5209
|
100
|
|
|
|
14671
|
$multi = 1 if $matches > 1; |
3612
|
|
|
|
|
|
|
} |
3613
|
|
|
|
|
|
|
} |
3614
|
8665
|
100
|
|
|
|
31022
|
return ($val, $multi) if wantarray; |
3615
|
47
|
|
|
|
|
164
|
return $val; |
3616
|
|
|
|
|
|
|
} |
3617
|
|
|
|
|
|
|
|
3618
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
3619
|
|
|
|
|
|
|
# Return true if we are deleting or overwriting the specified tag |
3620
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object ref, 1) new value hash reference |
3621
|
|
|
|
|
|
|
# 2) optional tag value (before RawConv) if deleting specific values |
3622
|
|
|
|
|
|
|
# Returns: >0 - tag should be overwritten |
3623
|
|
|
|
|
|
|
# =0 - the tag should be preserved |
3624
|
|
|
|
|
|
|
# <0 - not sure, we need the old value to tell (if there is no old value |
3625
|
|
|
|
|
|
|
# then the tag should be written if $$nvHash{IsCreating} is true) |
3626
|
|
|
|
|
|
|
# Notes: $$nvHash{Value} is updated with the new value when shifting a value |
3627
|
|
|
|
|
|
|
sub IsOverwriting($$;$) |
3628
|
|
|
|
|
|
|
{ |
3629
|
6231
|
|
|
6231
|
0
|
13029
|
my ($self, $nvHash, $val) = @_; |
3630
|
6231
|
100
|
|
|
|
14616
|
return 0 unless $nvHash; |
3631
|
|
|
|
|
|
|
# overwrite regardless if no DelValues specified |
3632
|
6190
|
100
|
|
|
|
26633
|
return 1 unless $$nvHash{DelValue}; |
3633
|
|
|
|
|
|
|
# never overwrite if DelValue list exists but is empty |
3634
|
117
|
|
|
|
|
312
|
my $shift = $$nvHash{Shift}; |
3635
|
117
|
100
|
100
|
|
|
224
|
return 0 unless @{$$nvHash{DelValue}} or defined $shift; |
|
117
|
|
|
|
|
549
|
|
3636
|
|
|
|
|
|
|
# return "don't know" if we don't have a value to test |
3637
|
104
|
100
|
|
|
|
384
|
return -1 unless defined $val; |
3638
|
|
|
|
|
|
|
# apply raw conversion if necessary |
3639
|
46
|
|
|
|
|
121
|
my $tagInfo = $$nvHash{TagInfo}; |
3640
|
46
|
|
|
|
|
127
|
my $conv = $$tagInfo{RawConv}; |
3641
|
46
|
100
|
|
|
|
148
|
if ($conv) { |
3642
|
3
|
|
|
|
|
22
|
local $SIG{'__WARN__'} = \&SetWarning; |
3643
|
3
|
|
|
|
|
11
|
undef $evalWarning; |
3644
|
3
|
50
|
|
|
|
16
|
if (ref $conv eq 'CODE') { |
3645
|
0
|
|
|
|
|
0
|
$val = &$conv($val, $self); |
3646
|
|
|
|
|
|
|
} else { |
3647
|
3
|
|
|
|
|
9
|
my ($priority, @grps); |
3648
|
3
|
|
|
|
|
9
|
my $tag = $$tagInfo{Name}; |
3649
|
|
|
|
|
|
|
#### eval RawConv ($self, $val, $tag, $tagInfo, $priority, @grps) |
3650
|
3
|
|
|
|
|
324
|
$val = eval $conv; |
3651
|
3
|
50
|
|
|
|
23
|
$@ and $evalWarning = $@; |
3652
|
|
|
|
|
|
|
} |
3653
|
3
|
50
|
|
|
|
23
|
return -1 unless defined $val; |
3654
|
|
|
|
|
|
|
} |
3655
|
|
|
|
|
|
|
# do not overwrite if only creating |
3656
|
46
|
100
|
|
|
|
178
|
return 0 if $$nvHash{CreateOnly}; |
3657
|
|
|
|
|
|
|
# apply time/number shift if necessary |
3658
|
40
|
100
|
|
|
|
115
|
if (defined $shift) { |
3659
|
13
|
|
|
|
|
39
|
my $shiftType = $$tagInfo{Shift}; |
3660
|
13
|
100
|
66
|
|
|
70
|
unless ($shiftType and $shiftType eq 'Time') { |
3661
|
6
|
50
|
|
|
|
23
|
unless (IsFloat($val)) { |
3662
|
|
|
|
|
|
|
# do the ValueConv to try to get a number |
3663
|
0
|
|
|
|
|
0
|
my $conv = $$tagInfo{ValueConv}; |
3664
|
0
|
0
|
|
|
|
0
|
if (defined $conv) { |
3665
|
0
|
|
|
|
|
0
|
local $SIG{'__WARN__'} = \&SetWarning; |
3666
|
0
|
|
|
|
|
0
|
undef $evalWarning; |
3667
|
0
|
0
|
|
|
|
0
|
if (ref $conv eq 'CODE') { |
|
|
0
|
|
|
|
|
|
3668
|
0
|
|
|
|
|
0
|
$val = &$conv($val, $self); |
3669
|
|
|
|
|
|
|
} elsif (not ref $conv) { |
3670
|
|
|
|
|
|
|
#### eval ValueConv ($val, $self) |
3671
|
0
|
|
|
|
|
0
|
$val = eval $conv; |
3672
|
0
|
0
|
|
|
|
0
|
$@ and $evalWarning = $@; |
3673
|
|
|
|
|
|
|
} |
3674
|
0
|
0
|
|
|
|
0
|
if ($evalWarning) { |
3675
|
0
|
|
|
|
|
0
|
$self->Warn("ValueConv $$tagInfo{Name}: " . CleanWarning()); |
3676
|
0
|
|
|
|
|
0
|
return 0; |
3677
|
|
|
|
|
|
|
} |
3678
|
|
|
|
|
|
|
} |
3679
|
0
|
0
|
0
|
|
|
0
|
unless (defined $val and IsFloat($val)) { |
3680
|
0
|
|
|
|
|
0
|
$self->Warn("Can't shift $$tagInfo{Name} (not a number)"); |
3681
|
0
|
|
|
|
|
0
|
return 0; |
3682
|
|
|
|
|
|
|
} |
3683
|
|
|
|
|
|
|
} |
3684
|
6
|
|
|
|
|
17
|
$shiftType = 'Number'; # allow any number to be shifted |
3685
|
|
|
|
|
|
|
} |
3686
|
13
|
|
|
|
|
106
|
require 'Image/ExifTool/Shift.pl'; |
3687
|
13
|
|
|
|
|
81
|
my $err = $self->ApplyShift($shiftType, $shift, $val, $nvHash); |
3688
|
13
|
50
|
|
|
|
42
|
if ($err) { |
3689
|
0
|
|
|
|
|
0
|
$self->Warn("$err when shifting $$tagInfo{Name}"); |
3690
|
0
|
|
|
|
|
0
|
return 0; |
3691
|
|
|
|
|
|
|
} |
3692
|
|
|
|
|
|
|
# ensure that the shifted value is valid and reformat if necessary |
3693
|
13
|
|
|
|
|
63
|
my $checkVal = $self->GetNewValue($nvHash); |
3694
|
13
|
50
|
|
|
|
43
|
return 0 unless defined $checkVal; |
3695
|
|
|
|
|
|
|
# don't bother overwriting if value is the same |
3696
|
13
|
50
|
|
|
|
61
|
return 0 if $val eq $$nvHash{Value}[0]; |
3697
|
13
|
|
|
|
|
69
|
return 1; |
3698
|
|
|
|
|
|
|
} |
3699
|
|
|
|
|
|
|
# return 1 if value matches a DelValue |
3700
|
27
|
|
|
|
|
51
|
my $delVal; |
3701
|
27
|
|
|
|
|
51
|
foreach $delVal (@{$$nvHash{DelValue}}) { |
|
27
|
|
|
|
|
79
|
|
3702
|
32
|
100
|
|
|
|
115
|
return 1 if $val eq $delVal; |
3703
|
|
|
|
|
|
|
} |
3704
|
17
|
|
|
|
|
65
|
return 0; |
3705
|
|
|
|
|
|
|
} |
3706
|
|
|
|
|
|
|
|
3707
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
3708
|
|
|
|
|
|
|
# Get write group for specified tag |
3709
|
|
|
|
|
|
|
# Inputs: 0) new value hash reference |
3710
|
|
|
|
|
|
|
# Returns: Write group name |
3711
|
|
|
|
|
|
|
sub GetWriteGroup($) |
3712
|
|
|
|
|
|
|
{ |
3713
|
0
|
|
|
0
|
0
|
0
|
return $_[0]{WriteGroup}; |
3714
|
|
|
|
|
|
|
} |
3715
|
|
|
|
|
|
|
|
3716
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
3717
|
|
|
|
|
|
|
# Get name of write group or family 1 group |
3718
|
|
|
|
|
|
|
# Inputs: 0) ExifTool ref, 1) tagInfo ref, 2) write group name |
3719
|
|
|
|
|
|
|
# Returns: Name of group for verbose message |
3720
|
|
|
|
|
|
|
sub GetWriteGroup1($$) |
3721
|
|
|
|
|
|
|
{ |
3722
|
32511
|
|
|
32511
|
0
|
69255
|
my ($self, $tagInfo, $writeGroup) = @_; |
3723
|
32511
|
100
|
|
|
|
143084
|
return $writeGroup unless $writeGroup =~ /^(MakerNotes|XMP|Composite|QuickTime)$/; |
3724
|
27117
|
|
|
|
|
97308
|
return $self->GetGroup($tagInfo, 1); |
3725
|
|
|
|
|
|
|
} |
3726
|
|
|
|
|
|
|
|
3727
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
3728
|
|
|
|
|
|
|
# Get new value hash for specified tagInfo/writeGroup |
3729
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object reference, 1) reference to tag info hash |
3730
|
|
|
|
|
|
|
# 2) Write group name, 3) Options: 'delete' or 'create' new value hash |
3731
|
|
|
|
|
|
|
# 4) optional ProtectSaved value, 5) true if we are deleting a value |
3732
|
|
|
|
|
|
|
# Returns: new value hash reference for specified write group |
3733
|
|
|
|
|
|
|
# (or first new value hash in linked list if write group not specified) |
3734
|
|
|
|
|
|
|
# Notes: May return undef when 'create' is used with ProtectSaved |
3735
|
|
|
|
|
|
|
sub GetNewValueHash($$;$$$$) |
3736
|
|
|
|
|
|
|
{ |
3737
|
67739
|
|
|
67739
|
0
|
166811
|
my ($self, $tagInfo, $writeGroup, $opts) = @_; |
3738
|
67739
|
100
|
|
|
|
136621
|
return undef unless $tagInfo; |
3739
|
67738
|
|
|
|
|
176279
|
my $nvHash = $$self{NEW_VALUE}{$tagInfo}; |
3740
|
|
|
|
|
|
|
|
3741
|
67738
|
|
|
|
|
92541
|
my %opts; # quick lookup for options |
3742
|
67738
|
100
|
|
|
|
147340
|
$opts and $opts{$opts} = 1; |
3743
|
67738
|
100
|
|
|
|
127812
|
$writeGroup = '' unless defined $writeGroup; |
3744
|
|
|
|
|
|
|
|
3745
|
67738
|
100
|
|
|
|
120816
|
if ($writeGroup) { |
3746
|
|
|
|
|
|
|
# find the new value in the list with the specified write group |
3747
|
46539
|
|
100
|
|
|
115791
|
while ($nvHash and $$nvHash{WriteGroup} ne $writeGroup) { |
3748
|
|
|
|
|
|
|
# QuickTime and All are special cases because all group1 tags may be updated at once |
3749
|
2010
|
100
|
|
|
|
6504
|
last if $$nvHash{WriteGroup} =~ /^(QuickTime|All)$/; |
3750
|
|
|
|
|
|
|
# replace existing entry if WriteGroup is 'All' (avoids confusion of forum10349) |
3751
|
1974
|
100
|
100
|
|
|
5700
|
last if $$tagInfo{WriteGroup} and $$tagInfo{WriteGroup} eq 'All'; |
3752
|
1962
|
|
|
|
|
4666
|
$nvHash = $$nvHash{Next}; |
3753
|
|
|
|
|
|
|
} |
3754
|
|
|
|
|
|
|
} |
3755
|
|
|
|
|
|
|
# remove this entry if deleting, or if creating a new entry and |
3756
|
|
|
|
|
|
|
# this entry is marked with "Save" flag |
3757
|
67738
|
100
|
100
|
|
|
179240
|
if (defined $nvHash and ($opts{'delete'} or ($opts{'create'} and $$nvHash{Save}))) { |
|
|
|
100
|
|
|
|
|
3758
|
2406
|
|
33
|
|
|
7588
|
my $protect = (defined $_[4] and defined $$nvHash{Save} and $$nvHash{Save} > $_[4]); |
3759
|
|
|
|
|
|
|
# this is a bit tricky: we want to add to a protected nvHash only if we |
3760
|
|
|
|
|
|
|
# are adding a conditional delete ($_[5] true or DelValue with no Shift) |
3761
|
|
|
|
|
|
|
# or accumulating List items (NoReplace true) |
3762
|
2406
|
50
|
0
|
|
|
8408
|
if ($protect and not ($opts{create} and ($$nvHash{NoReplace} or $_[5] or |
|
|
100
|
33
|
|
|
|
|
3763
|
|
|
|
|
|
|
($$nvHash{DelValue} and not defined $$nvHash{Shift})))) |
3764
|
|
|
|
|
|
|
{ |
3765
|
0
|
|
|
|
|
0
|
return undef; # honour ProtectSaved value by not writing this tag |
3766
|
|
|
|
|
|
|
} elsif ($opts{'delete'}) { |
3767
|
2396
|
|
|
|
|
8103
|
$self->RemoveNewValueHash($nvHash, $tagInfo); |
3768
|
2396
|
|
|
|
|
7972
|
undef $nvHash; |
3769
|
|
|
|
|
|
|
} else { |
3770
|
|
|
|
|
|
|
# save a copy of this new value hash |
3771
|
10
|
|
|
|
|
147
|
my %copy = %$nvHash; |
3772
|
|
|
|
|
|
|
# make copy of Value and DelValue lists |
3773
|
10
|
|
|
|
|
39
|
my $key; |
3774
|
10
|
|
|
|
|
36
|
foreach $key (keys %copy) { |
3775
|
75
|
100
|
|
|
|
171
|
next unless ref $copy{$key} eq 'ARRAY'; |
3776
|
10
|
|
|
|
|
17
|
$copy{$key} = [ @{$copy{$key}} ]; |
|
10
|
|
|
|
|
76
|
|
3777
|
|
|
|
|
|
|
} |
3778
|
10
|
|
|
|
|
36
|
my $saveHash = $$self{SAVE_NEW_VALUE}; |
3779
|
|
|
|
|
|
|
# add to linked list of saved new value hashes |
3780
|
10
|
|
|
|
|
26
|
$copy{Next} = $$saveHash{$tagInfo}; |
3781
|
10
|
|
|
|
|
30
|
$$saveHash{$tagInfo} = \%copy; |
3782
|
10
|
|
|
|
|
21
|
delete $$nvHash{Save}; # don't save it again |
3783
|
10
|
0
|
33
|
|
|
40
|
$$nvHash{AddBefore} = scalar @{$$nvHash{Value}} if $protect and $$nvHash{Value}; |
|
0
|
|
|
|
|
0
|
|
3784
|
|
|
|
|
|
|
} |
3785
|
|
|
|
|
|
|
} |
3786
|
67738
|
100
|
100
|
|
|
192009
|
if (not defined $nvHash and $opts{'create'}) { |
3787
|
|
|
|
|
|
|
# create a new entry |
3788
|
23209
|
|
|
|
|
98364
|
$nvHash = { |
3789
|
|
|
|
|
|
|
TagInfo => $tagInfo, |
3790
|
|
|
|
|
|
|
WriteGroup => $writeGroup, |
3791
|
|
|
|
|
|
|
IsNVH => 1, # set flag so we can recognize a new value hash |
3792
|
|
|
|
|
|
|
}; |
3793
|
|
|
|
|
|
|
# add entry to our NEW_VALUE hash |
3794
|
23209
|
100
|
|
|
|
59540
|
if ($$self{NEW_VALUE}{$tagInfo}) { |
3795
|
|
|
|
|
|
|
# add to end of linked list |
3796
|
33
|
|
|
|
|
229
|
my $lastHash = LastInList($$self{NEW_VALUE}{$tagInfo}); |
3797
|
33
|
|
|
|
|
140
|
$$lastHash{Next} = $nvHash; |
3798
|
|
|
|
|
|
|
} else { |
3799
|
23176
|
|
|
|
|
68412
|
$$self{NEW_VALUE}{$tagInfo} = $nvHash; |
3800
|
|
|
|
|
|
|
} |
3801
|
|
|
|
|
|
|
} |
3802
|
67738
|
|
|
|
|
167204
|
return $nvHash; |
3803
|
|
|
|
|
|
|
} |
3804
|
|
|
|
|
|
|
|
3805
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
3806
|
|
|
|
|
|
|
# Load all tag tables |
3807
|
|
|
|
|
|
|
sub LoadAllTables() |
3808
|
|
|
|
|
|
|
{ |
3809
|
0
|
0
|
|
0
|
0
|
0
|
return if $loadedAllTables; |
3810
|
|
|
|
|
|
|
|
3811
|
|
|
|
|
|
|
# load all of our non-referenced tables (first our modules) |
3812
|
0
|
|
|
|
|
0
|
my $table; |
3813
|
0
|
|
|
|
|
0
|
foreach $table (@loadAllTables) { |
3814
|
0
|
|
|
|
|
0
|
my $tableName = "Image::ExifTool::$table"; |
3815
|
0
|
0
|
|
|
|
0
|
$tableName .= '::Main' unless $table =~ /:/; |
3816
|
0
|
|
|
|
|
0
|
GetTagTable($tableName); |
3817
|
|
|
|
|
|
|
} |
3818
|
|
|
|
|
|
|
# (then our special tables) |
3819
|
0
|
|
|
|
|
0
|
GetTagTable('Image::ExifTool::Extra'); |
3820
|
0
|
|
|
|
|
0
|
GetTagTable('Image::ExifTool::Composite'); |
3821
|
|
|
|
|
|
|
# recursively load all tables referenced by the current tables |
3822
|
0
|
|
|
|
|
0
|
my @tableNames = keys %allTables; |
3823
|
0
|
|
|
|
|
0
|
my %pushedTables; |
3824
|
0
|
|
|
|
|
0
|
while (@tableNames) { |
3825
|
0
|
|
|
|
|
0
|
$table = GetTagTable(shift @tableNames); |
3826
|
|
|
|
|
|
|
# call write proc if it exists in case it adds tags to the table |
3827
|
0
|
|
|
|
|
0
|
my $writeProc = $$table{WRITE_PROC}; |
3828
|
0
|
0
|
|
|
|
0
|
if ($writeProc) { |
3829
|
59
|
|
|
59
|
|
706
|
no strict 'refs'; |
|
59
|
|
|
|
|
214
|
|
|
59
|
|
|
|
|
183616
|
|
3830
|
0
|
|
|
|
|
0
|
&$writeProc(); |
3831
|
|
|
|
|
|
|
} |
3832
|
|
|
|
|
|
|
# recursively scan through tables in subdirectories |
3833
|
0
|
|
|
|
|
0
|
foreach (TagTableKeys($table)) { |
3834
|
0
|
|
|
|
|
0
|
my @infoArray = GetTagInfoList($table,$_); |
3835
|
0
|
|
|
|
|
0
|
my $tagInfo; |
3836
|
0
|
|
|
|
|
0
|
foreach $tagInfo (@infoArray) { |
3837
|
0
|
0
|
|
|
|
0
|
my $subdir = $$tagInfo{SubDirectory} or next; |
3838
|
0
|
0
|
|
|
|
0
|
my $tableName = $$subdir{TagTable} or next; |
3839
|
|
|
|
|
|
|
# next if table already loaded or queued for loading |
3840
|
0
|
0
|
0
|
|
|
0
|
next if $allTables{$tableName} or $pushedTables{$tableName}; |
3841
|
0
|
|
|
|
|
0
|
push @tableNames, $tableName; # must scan this one too |
3842
|
0
|
|
|
|
|
0
|
$pushedTables{$tableName} = 1; |
3843
|
|
|
|
|
|
|
} |
3844
|
|
|
|
|
|
|
} |
3845
|
|
|
|
|
|
|
} |
3846
|
0
|
|
|
|
|
0
|
$loadedAllTables = 1; |
3847
|
|
|
|
|
|
|
} |
3848
|
|
|
|
|
|
|
|
3849
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
3850
|
|
|
|
|
|
|
# Remove new value hash from linked list (and save if necessary) |
3851
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object reference, 1) new value hash ref, 2) tagInfo ref |
3852
|
|
|
|
|
|
|
sub RemoveNewValueHash($$$) |
3853
|
|
|
|
|
|
|
{ |
3854
|
2666
|
|
|
2666
|
0
|
5073
|
my ($self, $nvHash, $tagInfo) = @_; |
3855
|
2666
|
|
|
|
|
5992
|
my $firstHash = $$self{NEW_VALUE}{$tagInfo}; |
3856
|
2666
|
50
|
|
|
|
7045
|
if ($nvHash eq $firstHash) { |
3857
|
|
|
|
|
|
|
# remove first entry from linked list |
3858
|
2666
|
50
|
|
|
|
5794
|
if ($$nvHash{Next}) { |
3859
|
0
|
|
|
|
|
0
|
$$self{NEW_VALUE}{$tagInfo} = $$nvHash{Next}; |
3860
|
|
|
|
|
|
|
} else { |
3861
|
2666
|
|
|
|
|
7438
|
delete $$self{NEW_VALUE}{$tagInfo}; |
3862
|
|
|
|
|
|
|
} |
3863
|
|
|
|
|
|
|
} else { |
3864
|
|
|
|
|
|
|
# find the list element pointing to this hash |
3865
|
0
|
|
|
|
|
0
|
$firstHash = $$firstHash{Next} while $$firstHash{Next} ne $nvHash; |
3866
|
|
|
|
|
|
|
# remove from linked list |
3867
|
0
|
|
|
|
|
0
|
$$firstHash{Next} = $$nvHash{Next}; |
3868
|
|
|
|
|
|
|
} |
3869
|
|
|
|
|
|
|
# save the existing entry if necessary |
3870
|
2666
|
100
|
|
|
|
8146
|
if ($$nvHash{Save}) { |
3871
|
80
|
|
|
|
|
163
|
my $saveHash = $$self{SAVE_NEW_VALUE}; |
3872
|
|
|
|
|
|
|
# add to linked list of saved new value hashes |
3873
|
80
|
|
|
|
|
216
|
$$nvHash{Next} = $$saveHash{$tagInfo}; |
3874
|
80
|
|
|
|
|
291
|
$$saveHash{$tagInfo} = $nvHash; |
3875
|
|
|
|
|
|
|
} |
3876
|
|
|
|
|
|
|
} |
3877
|
|
|
|
|
|
|
|
3878
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
3879
|
|
|
|
|
|
|
# Remove all new value entries for specified group |
3880
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object reference, 1) group name |
3881
|
|
|
|
|
|
|
sub RemoveNewValuesForGroup($$) |
3882
|
|
|
|
|
|
|
{ |
3883
|
784
|
|
|
784
|
0
|
1286
|
my ($self, $group) = @_; |
3884
|
|
|
|
|
|
|
|
3885
|
784
|
100
|
|
|
|
1611
|
return unless $$self{NEW_VALUE}; |
3886
|
|
|
|
|
|
|
|
3887
|
|
|
|
|
|
|
# make list of all groups we must remove |
3888
|
7
|
|
|
|
|
27
|
my @groups = ( $group ); |
3889
|
7
|
100
|
|
|
|
39
|
push @groups, @{$removeGroups{$group}} if $removeGroups{$group}; |
|
2
|
|
|
|
|
9
|
|
3890
|
|
|
|
|
|
|
|
3891
|
7
|
|
|
|
|
22
|
my ($out, @keys, $hashKey); |
3892
|
7
|
50
|
|
|
|
36
|
$out = $$self{OPTIONS}{TextOut} if $$self{OPTIONS}{Verbose} > 1; |
3893
|
|
|
|
|
|
|
|
3894
|
|
|
|
|
|
|
# loop though all new values, and remove any in this group |
3895
|
7
|
|
|
|
|
18
|
@keys = keys %{$$self{NEW_VALUE}}; |
|
7
|
|
|
|
|
754
|
|
3896
|
7
|
|
|
|
|
44
|
foreach $hashKey (@keys) { |
3897
|
1985
|
|
|
|
|
5572
|
my $nvHash = $$self{NEW_VALUE}{$hashKey}; |
3898
|
|
|
|
|
|
|
# loop through each entry in linked list |
3899
|
1985
|
|
|
|
|
2832
|
for (;;) { |
3900
|
1991
|
|
|
|
|
4500
|
my $nextHash = $$nvHash{Next}; |
3901
|
1991
|
|
|
|
|
4620
|
my $tagInfo = $$nvHash{TagInfo}; |
3902
|
1991
|
|
|
|
|
5354
|
my ($grp0,$grp1) = $self->GetGroup($tagInfo); |
3903
|
1991
|
|
|
|
|
5938
|
my $wgrp = $$nvHash{WriteGroup}; |
3904
|
|
|
|
|
|
|
# use group1 if write group is not specific |
3905
|
1991
|
100
|
|
|
|
4399
|
$wgrp = $grp1 if $wgrp eq $grp0; |
3906
|
1991
|
100
|
|
|
|
45239
|
if (grep /^($grp0|$wgrp)$/i, @groups) { |
3907
|
270
|
50
|
|
|
|
772
|
$out and print $out "Removed new value for $wgrp:$$tagInfo{Name}\n"; |
3908
|
|
|
|
|
|
|
# remove from linked list |
3909
|
270
|
|
|
|
|
712
|
$self->RemoveNewValueHash($nvHash, $tagInfo); |
3910
|
|
|
|
|
|
|
} |
3911
|
1991
|
100
|
|
|
|
8158
|
$nvHash = $nextHash or last; |
3912
|
|
|
|
|
|
|
} |
3913
|
|
|
|
|
|
|
} |
3914
|
|
|
|
|
|
|
} |
3915
|
|
|
|
|
|
|
|
3916
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
3917
|
|
|
|
|
|
|
# Get list of tagInfo hashes for all new data |
3918
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object reference, 1) optional tag table pointer |
3919
|
|
|
|
|
|
|
# Returns: list of tagInfo hashes |
3920
|
|
|
|
|
|
|
sub GetNewTagInfoList($;$) |
3921
|
|
|
|
|
|
|
{ |
3922
|
1207
|
|
|
1207
|
0
|
3049
|
my ($self, $tagTablePtr) = @_; |
3923
|
1207
|
|
|
|
|
2063
|
my @tagInfoList; |
3924
|
1207
|
|
|
|
|
3060
|
my $nv = $$self{NEW_VALUE}; |
3925
|
1207
|
100
|
|
|
|
3346
|
if ($nv) { |
3926
|
1183
|
|
|
|
|
1966
|
my $hashKey; |
3927
|
1183
|
|
|
|
|
22084
|
foreach $hashKey (keys %$nv) { |
3928
|
89484
|
|
|
|
|
162385
|
my $tagInfo = $$nv{$hashKey}{TagInfo}; |
3929
|
89484
|
100
|
100
|
|
|
262594
|
next if $tagTablePtr and $tagTablePtr ne $$tagInfo{Table}; |
3930
|
32539
|
|
|
|
|
57811
|
push @tagInfoList, $tagInfo; |
3931
|
|
|
|
|
|
|
} |
3932
|
|
|
|
|
|
|
} |
3933
|
1207
|
|
|
|
|
15307
|
return @tagInfoList; |
3934
|
|
|
|
|
|
|
} |
3935
|
|
|
|
|
|
|
|
3936
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
3937
|
|
|
|
|
|
|
# Get hash of tagInfo references keyed on tagID for a specific table |
3938
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object reference, 1-N) tag table pointers |
3939
|
|
|
|
|
|
|
# Returns: hash reference |
3940
|
|
|
|
|
|
|
# Notes: returns only one tagInfo ref for each conditional list |
3941
|
|
|
|
|
|
|
sub GetNewTagInfoHash($@) |
3942
|
|
|
|
|
|
|
{ |
3943
|
474
|
|
|
474
|
0
|
914
|
my $self = shift; |
3944
|
474
|
|
|
|
|
879
|
my (%tagInfoHash, $hashKey); |
3945
|
474
|
|
|
|
|
1025
|
my $nv = $$self{NEW_VALUE}; |
3946
|
474
|
|
|
|
|
1253
|
while ($nv) { |
3947
|
923
|
|
100
|
|
|
2305
|
my $tagTablePtr = shift || last; |
3948
|
464
|
|
|
|
|
4791
|
foreach $hashKey (keys %$nv) { |
3949
|
21558
|
|
|
|
|
36425
|
my $tagInfo = $$nv{$hashKey}{TagInfo}; |
3950
|
21558
|
100
|
66
|
|
|
74453
|
next if $tagTablePtr and $tagTablePtr ne $$tagInfo{Table}; |
3951
|
288
|
|
|
|
|
1209
|
$tagInfoHash{$$tagInfo{TagID}} = $tagInfo; |
3952
|
|
|
|
|
|
|
} |
3953
|
|
|
|
|
|
|
} |
3954
|
474
|
|
|
|
|
1684
|
return \%tagInfoHash; |
3955
|
|
|
|
|
|
|
} |
3956
|
|
|
|
|
|
|
|
3957
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
3958
|
|
|
|
|
|
|
# Get a tagInfo/tagID hash for subdirectories we need to add |
3959
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object reference, 1) parent tag table reference |
3960
|
|
|
|
|
|
|
# 2) parent directory name (taken from GROUP0 of tag table if not defined) |
3961
|
|
|
|
|
|
|
# Returns: Reference to Hash of subdirectory tagInfo references keyed by tagID |
3962
|
|
|
|
|
|
|
# (plus Reference to edit directory hash in list context) |
3963
|
|
|
|
|
|
|
sub GetAddDirHash($$;$) |
3964
|
|
|
|
|
|
|
{ |
3965
|
460
|
|
|
460
|
0
|
1322
|
my ($self, $tagTablePtr, $parent) = @_; |
3966
|
460
|
100
|
|
|
|
1361
|
$parent or $parent = $$tagTablePtr{GROUPS}{0}; |
3967
|
460
|
|
|
|
|
1336
|
my $tagID; |
3968
|
|
|
|
|
|
|
my %addDirHash; |
3969
|
460
|
|
|
|
|
0
|
my %editDirHash; |
3970
|
460
|
|
|
|
|
4656
|
my $addDirs = $$self{ADD_DIRS}; |
3971
|
460
|
|
|
|
|
992
|
my $editDirs = $$self{EDIT_DIRS}; |
3972
|
460
|
|
|
|
|
1756
|
foreach $tagID (TagTableKeys($tagTablePtr)) { |
3973
|
151029
|
|
|
|
|
269679
|
my @infoArray = GetTagInfoList($tagTablePtr,$tagID); |
3974
|
151029
|
|
|
|
|
193129
|
my $tagInfo; |
3975
|
151029
|
|
|
|
|
214546
|
foreach $tagInfo (@infoArray) { |
3976
|
187219
|
100
|
|
|
|
475417
|
next unless $$tagInfo{SubDirectory}; |
3977
|
|
|
|
|
|
|
# get name for this sub directory |
3978
|
|
|
|
|
|
|
# (take directory name from SubDirectory DirName if it exists, |
3979
|
|
|
|
|
|
|
# otherwise Group0 name of SubDirectory TagTable or tag Group1 name) |
3980
|
34442
|
|
|
|
|
60975
|
my $dirName = $$tagInfo{SubDirectory}{DirName}; |
3981
|
34442
|
100
|
|
|
|
54277
|
unless ($dirName) { |
3982
|
|
|
|
|
|
|
# use tag name for directory name and save for next time |
3983
|
3797
|
|
|
|
|
7971
|
$dirName = $$tagInfo{Name}; |
3984
|
3797
|
|
|
|
|
5998
|
$$tagInfo{SubDirectory}{DirName} = $dirName; |
3985
|
|
|
|
|
|
|
} |
3986
|
|
|
|
|
|
|
# save this directory information if we are writing it |
3987
|
34442
|
100
|
100
|
|
|
77949
|
if ($$editDirs{$dirName} and $$editDirs{$dirName} eq $parent) { |
3988
|
254
|
|
|
|
|
945
|
$editDirHash{$tagID} = $tagInfo; |
3989
|
254
|
100
|
|
|
|
1317
|
$addDirHash{$tagID} = $tagInfo if $$addDirs{$dirName}; |
3990
|
|
|
|
|
|
|
} |
3991
|
|
|
|
|
|
|
} |
3992
|
|
|
|
|
|
|
} |
3993
|
460
|
100
|
|
|
|
7322
|
return (\%addDirHash, \%editDirHash) if wantarray; |
3994
|
384
|
|
|
|
|
2024
|
return \%addDirHash; |
3995
|
|
|
|
|
|
|
} |
3996
|
|
|
|
|
|
|
|
3997
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
3998
|
|
|
|
|
|
|
# Get localized version of tagInfo hash (used by MIE, XMP, PNG and QuickTime) |
3999
|
|
|
|
|
|
|
# Inputs: 0) tagInfo hash ref, 1) locale code (eg. "en_CA" for MIE) |
4000
|
|
|
|
|
|
|
# Returns: new tagInfo hash ref, or undef if invalid |
4001
|
|
|
|
|
|
|
# - sets LangCode member in new tagInfo |
4002
|
|
|
|
|
|
|
sub GetLangInfo($$) |
4003
|
|
|
|
|
|
|
{ |
4004
|
298
|
|
|
298
|
0
|
636
|
my ($tagInfo, $langCode) = @_; |
4005
|
|
|
|
|
|
|
# make a new tagInfo hash for this locale |
4006
|
298
|
|
|
|
|
581
|
my $table = $$tagInfo{Table}; |
4007
|
298
|
|
|
|
|
819
|
my $tagID = $$tagInfo{TagID} . '-' . $langCode; |
4008
|
298
|
|
|
|
|
694
|
my $langInfo = $$table{$tagID}; |
4009
|
298
|
100
|
|
|
|
771
|
unless ($langInfo) { |
4010
|
|
|
|
|
|
|
# make a new tagInfo entry for this locale |
4011
|
|
|
|
|
|
|
$langInfo = { |
4012
|
|
|
|
|
|
|
%$tagInfo, |
4013
|
|
|
|
|
|
|
Name => $$tagInfo{Name} . '-' . $langCode, |
4014
|
182
|
|
|
|
|
1049
|
Description => Image::ExifTool::MakeDescription($$tagInfo{Name}) . |
4015
|
|
|
|
|
|
|
" ($langCode)", |
4016
|
|
|
|
|
|
|
LangCode => $langCode, |
4017
|
|
|
|
|
|
|
SrcTagInfo => $tagInfo, # save reference to original tagInfo |
4018
|
|
|
|
|
|
|
}; |
4019
|
182
|
|
|
|
|
665
|
AddTagToTable($table, $tagID, $langInfo); |
4020
|
|
|
|
|
|
|
} |
4021
|
298
|
|
|
|
|
785
|
return $langInfo; |
4022
|
|
|
|
|
|
|
} |
4023
|
|
|
|
|
|
|
|
4024
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
4025
|
|
|
|
|
|
|
# initialize ADD_DIRS and EDIT_DIRS hashes for all directories that need |
4026
|
|
|
|
|
|
|
# to be created or will have tags changed in them |
4027
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object reference, 1) file type string (or map hash ref) |
4028
|
|
|
|
|
|
|
# 2) preferred family 0 group for creating tags, 3) alternate preferred group |
4029
|
|
|
|
|
|
|
# Notes: |
4030
|
|
|
|
|
|
|
# - the ADD_DIRS and EDIT_DIRS keys are the directory names, and the values |
4031
|
|
|
|
|
|
|
# are the names of the parent directories (undefined for a top-level directory) |
4032
|
|
|
|
|
|
|
# - also initializes FORCE_WRITE lookup |
4033
|
|
|
|
|
|
|
sub InitWriteDirs($$;$$) |
4034
|
|
|
|
|
|
|
{ |
4035
|
318
|
|
|
318
|
0
|
1198
|
my ($self, $fileType, $preferredGroup, $altGroup) = @_; |
4036
|
318
|
|
|
|
|
1424
|
my $editDirs = $$self{EDIT_DIRS} = { }; |
4037
|
318
|
|
|
|
|
1259
|
my $addDirs = $$self{ADD_DIRS} = { }; |
4038
|
318
|
|
|
|
|
1207
|
my $fileDirs = $dirMap{$fileType}; |
4039
|
318
|
100
|
|
|
|
1180
|
unless ($fileDirs) { |
4040
|
192
|
100
|
|
|
|
853
|
return unless ref $fileType eq 'HASH'; |
4041
|
80
|
|
|
|
|
286
|
$fileDirs = $fileType; |
4042
|
|
|
|
|
|
|
} |
4043
|
206
|
|
|
|
|
1615
|
my @tagInfoList = $self->GetNewTagInfoList(); |
4044
|
206
|
|
|
|
|
704
|
my ($tagInfo, $nvHash); |
4045
|
|
|
|
|
|
|
|
4046
|
|
|
|
|
|
|
# save the preferred group |
4047
|
206
|
|
|
|
|
847
|
$$self{PreferredGroup} = $preferredGroup; |
4048
|
|
|
|
|
|
|
|
4049
|
206
|
|
|
|
|
683
|
foreach $tagInfo (@tagInfoList) { |
4050
|
|
|
|
|
|
|
# cycle through all hashes in linked list |
4051
|
12958
|
|
|
|
|
24830
|
for ($nvHash=$self->GetNewValueHash($tagInfo); $nvHash; $nvHash=$$nvHash{Next}) { |
4052
|
|
|
|
|
|
|
# are we creating this tag? (otherwise just deleting or editing it) |
4053
|
12985
|
|
|
|
|
27333
|
my $isCreating = $$nvHash{IsCreating}; |
4054
|
12985
|
100
|
|
|
|
21657
|
if ($preferredGroup) { |
4055
|
3536
|
|
|
|
|
8345
|
my $g0 = $self->GetGroup($tagInfo, 0); |
4056
|
3536
|
100
|
|
|
|
6928
|
if ($isCreating) { |
4057
|
|
|
|
|
|
|
# if another group is taking priority, only create |
4058
|
|
|
|
|
|
|
# directory if specifically adding tags to this group |
4059
|
|
|
|
|
|
|
# or if this tag isn't being added to the priority group |
4060
|
|
|
|
|
|
|
$isCreating = 0 if $preferredGroup ne $g0 and |
4061
|
826
|
100
|
100
|
|
|
3873
|
$$nvHash{CreateGroups}{$preferredGroup} and |
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
4062
|
|
|
|
|
|
|
(not $altGroup or $altGroup ne $g0); |
4063
|
|
|
|
|
|
|
} else { |
4064
|
|
|
|
|
|
|
# create this directory if any tag is preferred and has a value |
4065
|
|
|
|
|
|
|
# (unless group creation is disabled via the WriteMode option) |
4066
|
|
|
|
|
|
|
$isCreating = 1 if $$nvHash{Value} and $preferredGroup eq $g0 and |
4067
|
2710
|
50
|
100
|
|
|
10864
|
not $$nvHash{EditOnly} and $$self{OPTIONS}{WriteMode} =~ /g/; |
|
|
|
66
|
|
|
|
|
|
|
|
66
|
|
|
|
|
4068
|
|
|
|
|
|
|
} |
4069
|
|
|
|
|
|
|
} |
4070
|
|
|
|
|
|
|
# tag belongs to directory specified by WriteGroup, or by |
4071
|
|
|
|
|
|
|
# the Group0 name if WriteGroup not defined |
4072
|
12985
|
|
|
|
|
28494
|
my $dirName = $$nvHash{WriteGroup}; |
4073
|
|
|
|
|
|
|
# remove MIE copy number(s) if they exist |
4074
|
12985
|
100
|
|
|
|
29501
|
if ($dirName =~ /^MIE\d*(-[a-z]+)?\d*$/i) { |
4075
|
388
|
|
50
|
|
|
1868
|
$dirName = 'MIE' . ($1 || ''); |
4076
|
|
|
|
|
|
|
} |
4077
|
12985
|
|
|
|
|
17551
|
my @dirNames; |
4078
|
|
|
|
|
|
|
# allow a group name of '*' to force writing EXIF/IPTC/XMP/PNG (ForceWrite tag) |
4079
|
12985
|
50
|
33
|
|
|
33017
|
if ($dirName eq '*' and $$nvHash{Value}) { |
|
|
100
|
|
|
|
|
|
4080
|
0
|
|
|
|
|
0
|
my $val = $$nvHash{Value}[0]; |
4081
|
0
|
0
|
|
|
|
0
|
if ($val) { |
4082
|
0
|
|
|
|
|
0
|
foreach (qw(EXIF IPTC XMP PNG FixBase)) { |
4083
|
0
|
0
|
|
|
|
0
|
next unless $val =~ /\b($_|All)\b/i; |
4084
|
0
|
|
|
|
|
0
|
push @dirNames, $_; |
4085
|
0
|
0
|
|
|
|
0
|
push @dirNames, 'EXIF' if $_ eq 'FixBase'; |
4086
|
0
|
|
|
|
|
0
|
$$self{FORCE_WRITE}{$_} = 1; |
4087
|
|
|
|
|
|
|
} |
4088
|
|
|
|
|
|
|
} |
4089
|
0
|
|
|
|
|
0
|
$dirName = shift @dirNames; |
4090
|
|
|
|
|
|
|
} elsif ($dirName eq 'QuickTime') { |
4091
|
|
|
|
|
|
|
# write to specific QuickTime group |
4092
|
46
|
|
|
|
|
308
|
$dirName = $self->GetGroup($tagInfo, 1); |
4093
|
|
|
|
|
|
|
} |
4094
|
12985
|
|
|
|
|
22356
|
while ($dirName) { |
4095
|
52730
|
|
|
|
|
78405
|
my $parent = $$fileDirs{$dirName}; |
4096
|
52730
|
100
|
|
|
|
86086
|
if (ref $parent) { |
4097
|
6366
|
|
|
|
|
12105
|
push @dirNames, reverse @$parent; |
4098
|
6366
|
|
|
|
|
9235
|
$parent = pop @dirNames; |
4099
|
|
|
|
|
|
|
} |
4100
|
52730
|
|
|
|
|
76562
|
$$editDirs{$dirName} = $parent; |
4101
|
52730
|
100
|
100
|
|
|
98974
|
$$addDirs{$dirName} = $parent if $isCreating and $isCreating != 2; |
4102
|
52730
|
|
100
|
|
|
143667
|
$dirName = $parent || shift @dirNames |
4103
|
|
|
|
|
|
|
} |
4104
|
|
|
|
|
|
|
} |
4105
|
|
|
|
|
|
|
} |
4106
|
206
|
100
|
|
|
|
735
|
if (%{$$self{DEL_GROUP}}) { |
|
206
|
|
|
|
|
1249
|
|
4107
|
|
|
|
|
|
|
# add delete groups to list of edited groups |
4108
|
37
|
|
|
|
|
111
|
foreach (keys %{$$self{DEL_GROUP}}) { |
|
37
|
|
|
|
|
337
|
|
4109
|
843
|
100
|
|
|
|
1631
|
next if /^-/; # ignore excluded groups |
4110
|
841
|
|
|
|
|
1175
|
my $dirName = $_; |
4111
|
|
|
|
|
|
|
# translate necessary group 0 names |
4112
|
841
|
100
|
|
|
|
1706
|
$dirName = $translateWriteGroup{$dirName} if $translateWriteGroup{$dirName}; |
4113
|
|
|
|
|
|
|
# convert XMP group 1 names |
4114
|
841
|
100
|
|
|
|
1659
|
$dirName = 'XMP' if $dirName =~ /^XMP-/; |
4115
|
841
|
|
|
|
|
1134
|
my @dirNames; |
4116
|
841
|
|
|
|
|
1448
|
while ($dirName) { |
4117
|
1199
|
|
|
|
|
1917
|
my $parent = $$fileDirs{$dirName}; |
4118
|
1199
|
100
|
|
|
|
1991
|
if (ref $parent) { |
4119
|
13
|
|
|
|
|
60
|
push @dirNames, reverse @$parent; |
4120
|
13
|
|
|
|
|
28
|
$parent = pop @dirNames; |
4121
|
|
|
|
|
|
|
} |
4122
|
1199
|
|
|
|
|
2230
|
$$editDirs{$dirName} = $parent; |
4123
|
1199
|
|
100
|
|
|
3419
|
$dirName = $parent || shift @dirNames |
4124
|
|
|
|
|
|
|
} |
4125
|
|
|
|
|
|
|
} |
4126
|
|
|
|
|
|
|
} |
4127
|
|
|
|
|
|
|
# special case to edit JFIF to get resolutions if editing EXIF information |
4128
|
206
|
100
|
100
|
|
|
1671
|
if ($$editDirs{IFD0} and $$fileDirs{JFIF}) { |
4129
|
86
|
|
|
|
|
370
|
$$editDirs{JFIF} = 'IFD1'; |
4130
|
86
|
|
|
|
|
296
|
$$editDirs{APP0} = undef; |
4131
|
|
|
|
|
|
|
} |
4132
|
|
|
|
|
|
|
|
4133
|
206
|
100
|
|
|
|
2513
|
if ($$self{OPTIONS}{Verbose}) { |
4134
|
2
|
|
|
|
|
11
|
my $out = $$self{OPTIONS}{TextOut}; |
4135
|
2
|
|
|
|
|
10
|
print $out " Editing tags in: "; |
4136
|
2
|
|
|
|
|
17
|
foreach (sort keys %$editDirs) { print $out "$_ "; } |
|
10
|
|
|
|
|
25
|
|
4137
|
2
|
|
|
|
|
11
|
print $out "\n"; |
4138
|
2
|
50
|
|
|
|
18
|
return unless $$self{OPTIONS}{Verbose} > 1; |
4139
|
2
|
|
|
|
|
7
|
print $out " Creating tags in: "; |
4140
|
2
|
|
|
|
|
11
|
foreach (sort keys %$addDirs) { print $out "$_ "; } |
|
7
|
|
|
|
|
19
|
|
4141
|
2
|
|
|
|
|
11
|
print $out "\n"; |
4142
|
|
|
|
|
|
|
} |
4143
|
|
|
|
|
|
|
} |
4144
|
|
|
|
|
|
|
|
4145
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
4146
|
|
|
|
|
|
|
# Write an image directory |
4147
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object reference, 1) source directory information reference |
4148
|
|
|
|
|
|
|
# 2) tag table reference, 3) optional reference to writing procedure |
4149
|
|
|
|
|
|
|
# Returns: New directory data or undefined on error (or empty string to delete directory) |
4150
|
|
|
|
|
|
|
sub WriteDirectory($$$;$) |
4151
|
|
|
|
|
|
|
{ |
4152
|
1728
|
|
|
1728
|
0
|
6272
|
my ($self, $dirInfo, $tagTablePtr, $writeProc) = @_; |
4153
|
1728
|
|
|
|
|
3268
|
my ($out, $nvHash, $delFlag); |
4154
|
|
|
|
|
|
|
|
4155
|
1728
|
50
|
|
|
|
4031
|
$tagTablePtr or return undef; |
4156
|
1728
|
100
|
|
|
|
6408
|
$out = $$self{OPTIONS}{TextOut} if $$self{OPTIONS}{Verbose}; |
4157
|
|
|
|
|
|
|
# set directory name from default group0 name if not done already |
4158
|
1728
|
|
|
|
|
3846
|
my $dirName = $$dirInfo{DirName}; |
4159
|
1728
|
|
|
|
|
3131
|
my $dataPt = $$dirInfo{DataPt}; |
4160
|
1728
|
|
|
|
|
6972
|
my $grp0 = $$tagTablePtr{GROUPS}{0}; |
4161
|
1728
|
100
|
|
|
|
4631
|
$dirName or $dirName = $$dirInfo{DirName} = $grp0; |
4162
|
1728
|
100
|
|
|
|
2778
|
if (%{$$self{DEL_GROUP}}) { |
|
1728
|
|
|
|
|
5829
|
|
4163
|
207
|
|
|
|
|
415
|
my $delGroup = $$self{DEL_GROUP}; |
4164
|
|
|
|
|
|
|
# delete entire directory if specified |
4165
|
207
|
|
|
|
|
458
|
my $grp1 = $dirName; |
4166
|
207
|
100
|
100
|
|
|
900
|
$delFlag = ($$delGroup{$grp0} or $$delGroup{$grp1}) unless $permanentDir{$grp0}; |
4167
|
|
|
|
|
|
|
# (never delete an entire QuickTime group) |
4168
|
207
|
100
|
|
|
|
614
|
if ($delFlag) { |
4169
|
40
|
50
|
100
|
|
|
528
|
if (($grp0 =~ /^(MakerNotes)$/ or $grp1 =~ /^(IFD0|ExifIFD|MakerNotes)$/) and |
|
|
100
|
66
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
33
|
|
|
|
|
4170
|
|
|
|
|
|
|
$self->IsRawType() and |
4171
|
|
|
|
|
|
|
# allow non-permanent MakerNote directories to be deleted (ie. NikonCapture) |
4172
|
|
|
|
|
|
|
(not $$dirInfo{TagInfo} or not defined $$dirInfo{TagInfo}{Permanent} or |
4173
|
|
|
|
|
|
|
$$dirInfo{TagInfo}{Permanent})) |
4174
|
|
|
|
|
|
|
{ |
4175
|
0
|
|
|
|
|
0
|
$self->WarnOnce("Can't delete $1 from $$self{FileType}",1); |
4176
|
0
|
|
|
|
|
0
|
undef $grp1; |
4177
|
|
|
|
|
|
|
} elsif (not $blockExifTypes{$$self{FILE_TYPE}}) { |
4178
|
|
|
|
|
|
|
# restrict delete logic to prevent entire tiff image from being killed |
4179
|
|
|
|
|
|
|
# (don't allow IFD0 to be deleted, and delete only ExifIFD if EXIF specified) |
4180
|
10
|
50
|
33
|
|
|
156
|
if ($$self{FILE_TYPE} eq 'PSD') { |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
4181
|
|
|
|
|
|
|
# don't delete Photoshop directories from PSD image |
4182
|
0
|
0
|
|
|
|
0
|
undef $grp1 if $grp0 eq 'Photoshop'; |
4183
|
|
|
|
|
|
|
} elsif ($$self{FILE_TYPE} =~ /^(EPS|PS)$/) { |
4184
|
|
|
|
|
|
|
# allow anything to be deleted from PostScript files |
4185
|
|
|
|
|
|
|
} elsif ($grp1 eq 'IFD0') { |
4186
|
0
|
|
0
|
|
|
0
|
my $type = $$self{TIFF_TYPE} || $$self{FILE_TYPE}; |
4187
|
0
|
0
|
|
|
|
0
|
$$delGroup{IFD0} and $self->Warn("Can't delete IFD0 from $type",1); |
4188
|
0
|
|
|
|
|
0
|
undef $grp1; |
4189
|
|
|
|
|
|
|
} elsif ($grp0 eq 'EXIF' and $$delGroup{$grp0}) { |
4190
|
0
|
0
|
0
|
|
|
0
|
undef $grp1 unless $$delGroup{$grp1} or $grp1 eq 'ExifIFD'; |
4191
|
|
|
|
|
|
|
} |
4192
|
|
|
|
|
|
|
} |
4193
|
40
|
50
|
|
|
|
138
|
if ($grp1) { |
4194
|
40
|
100
|
66
|
|
|
202
|
if ($dataPt or $$dirInfo{RAF}) { |
4195
|
30
|
|
|
|
|
132
|
++$$self{CHANGED}; |
4196
|
30
|
100
|
|
|
|
134
|
$out and print $out " Deleting $grp1\n"; |
4197
|
30
|
100
|
|
|
|
133
|
$self->Warn('ICC_Profile deleted. Image colors may be affected') if $grp1 eq 'ICC_Profile'; |
4198
|
|
|
|
|
|
|
# can no longer validate TIFF_END if deleting an entire IFD |
4199
|
30
|
100
|
|
|
|
158
|
delete $$self{TIFF_END} if $dirName =~ /IFD/; |
4200
|
|
|
|
|
|
|
} |
4201
|
|
|
|
|
|
|
# don't add back into the wrong location |
4202
|
40
|
|
|
|
|
124
|
my $right = $$self{ADD_DIRS}{$grp1}; |
4203
|
|
|
|
|
|
|
# (take care because EXIF directory name may be either EXIF or IFD0, |
4204
|
|
|
|
|
|
|
# but IFD0 will be the one that appears in the directory map) |
4205
|
40
|
100
|
100
|
|
|
214
|
$right = $$self{ADD_DIRS}{IFD0} if not $right and $grp1 eq 'EXIF'; |
4206
|
40
|
100
|
100
|
|
|
208
|
if ($delFlag == 2 and $right) { |
4207
|
|
|
|
|
|
|
# also check grandparent because some routines create 2 levels in 1 |
4208
|
21
|
|
100
|
|
|
121
|
my $right2 = $$self{ADD_DIRS}{$right} || ''; |
4209
|
21
|
|
|
|
|
55
|
my $parent = $$dirInfo{Parent}; |
4210
|
21
|
50
|
66
|
|
|
122
|
if (not $parent or $parent eq $right or $parent eq $right2) { |
|
|
|
33
|
|
|
|
|
4211
|
|
|
|
|
|
|
# prevent duplicate directories from being recreated at the same path |
4212
|
21
|
|
|
|
|
44
|
my $path = join '-', @{$$self{PATH}}, $dirName; |
|
21
|
|
|
|
|
91
|
|
4213
|
21
|
100
|
|
|
|
91
|
$$self{Recreated} or $$self{Recreated} = { }; |
4214
|
21
|
50
|
|
|
|
82
|
if ($$self{Recreated}{$path}) { |
4215
|
0
|
0
|
|
|
|
0
|
my $p = $parent ? " in $parent" : ''; |
4216
|
0
|
|
|
|
|
0
|
$self->Warn("Not recreating duplicate $grp1$p",1); |
4217
|
0
|
|
|
|
|
0
|
return ''; |
4218
|
|
|
|
|
|
|
} |
4219
|
21
|
|
|
|
|
75
|
$$self{Recreated}{$path} = 1; |
4220
|
|
|
|
|
|
|
# empty the directory |
4221
|
21
|
|
|
|
|
46
|
my $data = ''; |
4222
|
21
|
|
|
|
|
51
|
$$dirInfo{DataPt} = \$data; |
4223
|
21
|
|
|
|
|
49
|
$$dirInfo{DataLen} = 0; |
4224
|
21
|
|
|
|
|
58
|
$$dirInfo{DirStart} = 0; |
4225
|
21
|
|
|
|
|
83
|
$$dirInfo{DirLen} = 0; |
4226
|
21
|
|
|
|
|
59
|
delete $$dirInfo{RAF}; |
4227
|
21
|
|
|
|
|
48
|
delete $$dirInfo{Base}; |
4228
|
21
|
|
|
|
|
57
|
delete $$dirInfo{DataPos}; |
4229
|
|
|
|
|
|
|
} else { |
4230
|
0
|
|
|
|
|
0
|
$self->Warn("Not recreating $grp1 in $parent (should be in $right)",1); |
4231
|
0
|
|
|
|
|
0
|
return ''; |
4232
|
|
|
|
|
|
|
} |
4233
|
|
|
|
|
|
|
} else { |
4234
|
19
|
100
|
|
|
|
138
|
return '' unless $$dirInfo{NoDelete}; |
4235
|
|
|
|
|
|
|
} |
4236
|
|
|
|
|
|
|
} |
4237
|
|
|
|
|
|
|
} |
4238
|
|
|
|
|
|
|
} |
4239
|
|
|
|
|
|
|
# use default proc from tag table if no proc specified |
4240
|
1710
|
100
|
100
|
|
|
8621
|
$writeProc or $writeProc = $$tagTablePtr{WRITE_PROC} or return undef; |
4241
|
|
|
|
|
|
|
|
4242
|
|
|
|
|
|
|
# are we rewriting a pre-existing directory? |
4243
|
1478
|
|
100
|
|
|
6253
|
my $isRewriting = ($$dirInfo{DirLen} or (defined $dataPt and length $$dataPt) or $$dirInfo{RAF}); |
4244
|
|
|
|
|
|
|
|
4245
|
|
|
|
|
|
|
# copy or delete new directory as a block if specified |
4246
|
1478
|
|
|
|
|
2700
|
my $blockName = $dirName; |
4247
|
1478
|
100
|
|
|
|
3617
|
$blockName = 'EXIF' if $blockName eq 'IFD0'; |
4248
|
1478
|
|
100
|
|
|
6294
|
my $tagInfo = $Image::ExifTool::Extra{$blockName} || $$dirInfo{TagInfo}; |
4249
|
1478
|
|
100
|
|
|
7927
|
while ($tagInfo and ($nvHash = $$self{NEW_VALUE}{$tagInfo}) and |
|
|
|
66
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
|
66
|
|
|
|
|
4250
|
|
|
|
|
|
|
$self->IsOverwriting($nvHash) and not ($$nvHash{CreateOnly} and $isRewriting)) |
4251
|
|
|
|
|
|
|
{ |
4252
|
|
|
|
|
|
|
# protect against writing EXIF to wrong file types, etc |
4253
|
13
|
100
|
|
|
|
76
|
if ($blockName eq 'EXIF') { |
4254
|
1
|
50
|
|
|
|
9
|
unless ($blockExifTypes{$$self{FILE_TYPE}}) { |
4255
|
0
|
|
|
|
|
0
|
$self->Warn("Can't write EXIF as a block to $$self{FILE_TYPE} file"); |
4256
|
0
|
|
|
|
|
0
|
last; |
4257
|
|
|
|
|
|
|
} |
4258
|
|
|
|
|
|
|
# this can happen if we call WriteDirectory for an EXIF directory without going |
4259
|
|
|
|
|
|
|
# through WriteTIFF as the WriteProc (which happens if conditionally replacing |
4260
|
|
|
|
|
|
|
# the EXIF block and the condition fails), but we never want to do a block write |
4261
|
|
|
|
|
|
|
# in this case because the EXIF block would end up with two TIFF headers |
4262
|
1
|
50
|
|
|
|
7
|
last unless $writeProc eq \&Image::ExifTool::WriteTIFF; |
4263
|
|
|
|
|
|
|
} |
4264
|
13
|
100
|
|
|
|
79
|
last unless $self->IsOverwriting($nvHash, $dataPt ? $$dataPt : ''); |
|
|
50
|
|
|
|
|
|
4265
|
13
|
|
|
|
|
54
|
my $verb = 'Writing'; |
4266
|
13
|
|
|
|
|
53
|
my $newVal = $self->GetNewValue($nvHash); |
4267
|
13
|
50
|
33
|
|
|
142
|
unless (defined $newVal and length $newVal) { |
4268
|
0
|
0
|
0
|
|
|
0
|
return '' unless $dataPt or $$dirInfo{RAF}; # nothing to do if block never existed |
4269
|
|
|
|
|
|
|
# don't allow MakerNotes to be removed from RAW files |
4270
|
0
|
0
|
0
|
|
|
0
|
if ($blockName eq 'MakerNotes' and $rawType{$$self{FileType}}) { |
4271
|
0
|
|
|
|
|
0
|
$self->Warn("Can't delete MakerNotes from $$self{FileType}",1); |
4272
|
0
|
|
|
|
|
0
|
return undef; |
4273
|
|
|
|
|
|
|
} |
4274
|
0
|
|
|
|
|
0
|
$verb = 'Deleting'; |
4275
|
0
|
|
|
|
|
0
|
$newVal = ''; |
4276
|
|
|
|
|
|
|
} |
4277
|
13
|
|
|
|
|
50
|
$$dirInfo{BlockWrite} = 1; # set flag indicating we did a block write |
4278
|
13
|
50
|
|
|
|
56
|
$out and print $out " $verb $blockName as a block\n"; |
4279
|
13
|
|
|
|
|
41
|
++$$self{CHANGED}; |
4280
|
13
|
|
|
|
|
74
|
return $newVal; |
4281
|
|
|
|
|
|
|
} |
4282
|
|
|
|
|
|
|
# guard against writing the same directory twice |
4283
|
1465
|
100
|
100
|
|
|
10407
|
if (defined $dataPt and defined $$dirInfo{DirStart} and defined $$dirInfo{DataPos} and |
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
4284
|
|
|
|
|
|
|
not $$dirInfo{NoRefTest}) |
4285
|
|
|
|
|
|
|
{ |
4286
|
691
|
|
100
|
|
|
3193
|
my $addr = $$dirInfo{DirStart} + $$dirInfo{DataPos} + ($$dirInfo{Base}||0) + $$self{BASE}; |
4287
|
|
|
|
|
|
|
# (Phase One P25 IIQ files have ICC_Profile duplicated in IFD0 and IFD1) |
4288
|
691
|
50
|
0
|
|
|
3232
|
if ($$self{PROCESSED}{$addr} and ($dirName ne 'ICC_Profile' or $$self{TIFF_TYPE} ne 'IIQ')) { |
|
|
|
33
|
|
|
|
|
4289
|
0
|
0
|
0
|
|
|
0
|
if (defined $$dirInfo{DirLen} and not $$dirInfo{DirLen} and $dirName ne $$self{PROCESSED}{$addr}) { |
|
|
0
|
0
|
|
|
|
|
4290
|
|
|
|
|
|
|
# it is hypothetically possible to have 2 different directories |
4291
|
|
|
|
|
|
|
# with the same address if one has a length of zero |
4292
|
|
|
|
|
|
|
} elsif ($self->Error("$dirName pointer references previous $$self{PROCESSED}{$addr} directory", 2)) { |
4293
|
0
|
|
|
|
|
0
|
return undef; |
4294
|
|
|
|
|
|
|
} else { |
4295
|
0
|
|
|
|
|
0
|
$self->Warn("Deleting duplicate $dirName directory"); |
4296
|
0
|
0
|
|
|
|
0
|
$out and print $out " Deleting $dirName\n"; |
4297
|
|
|
|
|
|
|
# delete the duplicate directory (don't recreate it when writing new |
4298
|
|
|
|
|
|
|
# tags to prevent propagating a duplicate IFD in cases like when the |
4299
|
|
|
|
|
|
|
# same ExifIFD exists in both IFD0 and IFD1) |
4300
|
0
|
|
|
|
|
0
|
return ''; |
4301
|
|
|
|
|
|
|
} |
4302
|
|
|
|
|
|
|
} else { |
4303
|
691
|
|
|
|
|
2588
|
$$self{PROCESSED}{$addr} = $dirName; |
4304
|
|
|
|
|
|
|
} |
4305
|
|
|
|
|
|
|
} |
4306
|
1465
|
|
|
|
|
3420
|
my $oldDir = $$self{DIR_NAME}; |
4307
|
1465
|
|
|
|
|
4608
|
my @save = @$self{'Compression','SubfileType'}; |
4308
|
1465
|
|
|
|
|
2391
|
my $name; |
4309
|
1465
|
100
|
|
|
|
3417
|
if ($out) { |
4310
|
|
|
|
|
|
|
$name = ($dirName eq 'MakerNotes' and $$dirInfo{TagInfo}) ? |
4311
|
4
|
50
|
33
|
|
|
24
|
$$dirInfo{TagInfo}{Name} : $dirName; |
4312
|
4
|
100
|
100
|
|
|
27
|
if (not defined $oldDir or $oldDir ne $name) { |
4313
|
3
|
100
|
|
|
|
12
|
my $verb = $isRewriting ? 'Rewriting' : 'Creating'; |
4314
|
3
|
|
|
|
|
17
|
print $out " $verb $name\n"; |
4315
|
|
|
|
|
|
|
} |
4316
|
|
|
|
|
|
|
} |
4317
|
1465
|
|
|
|
|
4413
|
my $saveOrder = GetByteOrder(); |
4318
|
1465
|
|
|
|
|
3235
|
my $oldChanged = $$self{CHANGED}; |
4319
|
1465
|
|
|
|
|
3181
|
$$self{DIR_NAME} = $dirName; |
4320
|
1465
|
|
|
|
|
2314
|
push @{$$self{PATH}}, $dirName; |
|
1465
|
|
|
|
|
3809
|
|
4321
|
1465
|
|
|
|
|
3126
|
$$dirInfo{IsWriting} = 1; |
4322
|
1465
|
|
|
|
|
2373
|
my $newData; |
4323
|
|
|
|
|
|
|
{ |
4324
|
59
|
|
|
59
|
|
616
|
no strict 'refs'; |
|
59
|
|
|
|
|
222
|
|
|
59
|
|
|
|
|
1277738
|
|
|
1465
|
|
|
|
|
2351
|
|
4325
|
1465
|
|
|
|
|
12907
|
$newData = &$writeProc($self, $dirInfo, $tagTablePtr); |
4326
|
|
|
|
|
|
|
} |
4327
|
1465
|
|
|
|
|
2991
|
pop @{$$self{PATH}}; |
|
1465
|
|
|
|
|
3617
|
|
4328
|
|
|
|
|
|
|
# nothing changed if error occurred or nothing was created |
4329
|
1465
|
100
|
100
|
|
|
7137
|
$$self{CHANGED} = $oldChanged unless defined $newData and (length($newData) or $isRewriting); |
|
|
|
100
|
|
|
|
|
4330
|
1465
|
|
|
|
|
3393
|
$$self{DIR_NAME} = $oldDir; |
4331
|
1465
|
|
|
|
|
4321
|
@$self{'Compression','SubfileType'} = @save; |
4332
|
1465
|
|
|
|
|
5743
|
SetByteOrder($saveOrder); |
4333
|
1465
|
100
|
|
|
|
4153
|
if ($out) { |
4334
|
4
|
50
|
33
|
|
|
29
|
print $out " Deleting $name\n" if defined $newData and not length $newData; |
4335
|
4
|
50
|
33
|
|
|
19
|
if ($$self{CHANGED} == $oldChanged and $$self{OPTIONS}{Verbose} > 2) { |
4336
|
0
|
|
|
|
|
0
|
print $out "$$self{INDENT} [nothing changed in $name]\n"; |
4337
|
|
|
|
|
|
|
} |
4338
|
|
|
|
|
|
|
} |
4339
|
1465
|
|
|
|
|
7201
|
return $newData; |
4340
|
|
|
|
|
|
|
} |
4341
|
|
|
|
|
|
|
|
4342
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
4343
|
|
|
|
|
|
|
# Uncommon utility routines to for reading binary data values |
4344
|
|
|
|
|
|
|
# Inputs: 0) data reference, 1) offset into data |
4345
|
|
|
|
|
|
|
sub Get64s($$) |
4346
|
|
|
|
|
|
|
{ |
4347
|
12
|
|
|
12
|
0
|
26
|
my ($dataPt, $pos) = @_; |
4348
|
12
|
50
|
|
|
|
28
|
my $pt = GetByteOrder() eq 'MM' ? 0 : 4; # get position of high word |
4349
|
12
|
|
|
|
|
34
|
my $hi = Get32s($dataPt, $pos + $pt); # preserve sign bit of high word |
4350
|
12
|
|
|
|
|
33
|
my $lo = Get32u($dataPt, $pos + 4 - $pt); |
4351
|
12
|
|
|
|
|
31
|
return $hi * 4294967296 + $lo; |
4352
|
|
|
|
|
|
|
} |
4353
|
|
|
|
|
|
|
sub Get64u($$) |
4354
|
|
|
|
|
|
|
{ |
4355
|
189
|
|
|
189
|
0
|
470
|
my ($dataPt, $pos) = @_; |
4356
|
189
|
100
|
|
|
|
487
|
my $pt = GetByteOrder() eq 'MM' ? 0 : 4; # get position of high word |
4357
|
189
|
|
|
|
|
646
|
my $hi = Get32u($dataPt, $pos + $pt); # (unsigned this time) |
4358
|
189
|
|
|
|
|
612
|
my $lo = Get32u($dataPt, $pos + 4 - $pt); |
4359
|
189
|
|
|
|
|
777
|
return $hi * 4294967296 + $lo; |
4360
|
|
|
|
|
|
|
} |
4361
|
|
|
|
|
|
|
sub GetFixed64s($$) |
4362
|
|
|
|
|
|
|
{ |
4363
|
0
|
|
|
0
|
0
|
0
|
my ($dataPt, $pos) = @_; |
4364
|
0
|
|
|
|
|
0
|
my $val = Get64s($dataPt, $pos) / 4294967296; |
4365
|
|
|
|
|
|
|
# remove insignificant digits |
4366
|
0
|
0
|
|
|
|
0
|
return int($val * 1e10 + ($val>0 ? 0.5 : -0.5)) / 1e10; |
4367
|
|
|
|
|
|
|
} |
4368
|
|
|
|
|
|
|
# Decode extended 80-bit float used by Apple SANE and Intel 8087 |
4369
|
|
|
|
|
|
|
# (note: different than the IEEE standard 80-bit float) |
4370
|
|
|
|
|
|
|
sub GetExtended($$) |
4371
|
|
|
|
|
|
|
{ |
4372
|
1
|
|
|
1
|
0
|
4
|
my ($dataPt, $pos) = @_; |
4373
|
1
|
50
|
|
|
|
5
|
my $pt = GetByteOrder() eq 'MM' ? 0 : 2; # get position of exponent |
4374
|
1
|
|
|
|
|
5
|
my $exp = Get16u($dataPt, $pos + $pt); |
4375
|
1
|
|
|
|
|
4
|
my $sig = Get64u($dataPt, $pos + 2 - $pt); # get significand as int64u |
4376
|
1
|
50
|
|
|
|
4
|
my $sign = $exp & 0x8000 ? -1 : 1; |
4377
|
1
|
|
|
|
|
5
|
$exp = ($exp & 0x7fff) - 16383 - 63; # (-63 to fractionalize significand) |
4378
|
1
|
|
|
|
|
18
|
return $sign * $sig * 2 ** $exp; |
4379
|
|
|
|
|
|
|
} |
4380
|
|
|
|
|
|
|
|
4381
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
4382
|
|
|
|
|
|
|
# Dump data in hex and ASCII to console |
4383
|
|
|
|
|
|
|
# Inputs: 0) data reference, 1) length or undef, 2-N) Options: |
4384
|
|
|
|
|
|
|
# Options: Start => offset to start of data (default=0) |
4385
|
|
|
|
|
|
|
# Addr => address to print for data start (default=DataPos+Base+Start) |
4386
|
|
|
|
|
|
|
# DataPos => position of data within block (relative to Base) |
4387
|
|
|
|
|
|
|
# Base => base offset for pointers from start of file |
4388
|
|
|
|
|
|
|
# Width => width of printout (bytes, default=16) |
4389
|
|
|
|
|
|
|
# Prefix => prefix to print at start of line (default='') |
4390
|
|
|
|
|
|
|
# MaxLen => maximum length to dump |
4391
|
|
|
|
|
|
|
# Out => output file reference |
4392
|
|
|
|
|
|
|
# Len => data length |
4393
|
|
|
|
|
|
|
sub HexDump($;$%) |
4394
|
|
|
|
|
|
|
{ |
4395
|
169
|
|
|
169
|
0
|
276
|
my $dataPt = shift; |
4396
|
169
|
|
|
|
|
316
|
my $len = shift; |
4397
|
169
|
|
|
|
|
781
|
my %opts = @_; |
4398
|
169
|
|
100
|
|
|
429
|
my $start = $opts{Start} || 0; |
4399
|
169
|
|
|
|
|
259
|
my $addr = $opts{Addr}; |
4400
|
169
|
|
50
|
|
|
485
|
my $wid = $opts{Width} || 16; |
4401
|
169
|
|
100
|
|
|
363
|
my $prefix = $opts{Prefix} || ''; |
4402
|
169
|
|
50
|
|
|
361
|
my $out = $opts{Out} || \*STDOUT; |
4403
|
169
|
|
|
|
|
306
|
my $maxLen = $opts{MaxLen}; |
4404
|
169
|
|
|
|
|
326
|
my $datLen = length($$dataPt) - $start; |
4405
|
169
|
|
|
|
|
240
|
my $more; |
4406
|
169
|
50
|
|
|
|
378
|
$len = $opts{Len} if defined $opts{Len}; |
4407
|
|
|
|
|
|
|
|
4408
|
169
|
100
|
50
|
|
|
506
|
$addr = $start + ($opts{DataPos} || 0) + ($opts{Base} || 0) unless defined $addr; |
|
|
|
50
|
|
|
|
|
4409
|
169
|
100
|
|
|
|
350
|
$len = $datLen unless defined $len; |
4410
|
169
|
100
|
66
|
|
|
532
|
if ($maxLen and $len > $maxLen) { |
4411
|
|
|
|
|
|
|
# print one line less to allow for $more line below |
4412
|
5
|
|
|
|
|
16
|
$maxLen = int(($maxLen - 1) / $wid) * $wid; |
4413
|
5
|
|
|
|
|
8
|
$more = $len - $maxLen; |
4414
|
5
|
|
|
|
|
12
|
$len = $maxLen; |
4415
|
|
|
|
|
|
|
} |
4416
|
169
|
50
|
|
|
|
338
|
if ($len > $datLen) { |
4417
|
0
|
|
|
|
|
0
|
print $out "$prefix Warning: Attempted dump outside data\n"; |
4418
|
0
|
|
|
|
|
0
|
print $out "$prefix ($len bytes specified, but only $datLen available)\n"; |
4419
|
0
|
|
|
|
|
0
|
$len = $datLen; |
4420
|
|
|
|
|
|
|
} |
4421
|
169
|
|
|
|
|
549
|
my $format = sprintf("%%-%ds", $wid * 3); |
4422
|
169
|
|
|
|
|
383
|
my $tmpl = 'H2' x $wid; # ('(H2)*' would have been nice, but older perl versions don't support it) |
4423
|
169
|
|
|
|
|
265
|
my $i; |
4424
|
169
|
|
|
|
|
392
|
for ($i=0; $i<$len; $i+=$wid) { |
4425
|
228
|
100
|
|
|
|
609
|
$wid > $len-$i and $wid = $len-$i, $tmpl = 'H2' x $wid; |
4426
|
228
|
|
|
|
|
757
|
printf $out "$prefix%8.4x: ", $addr+$i; |
4427
|
228
|
|
|
|
|
563
|
my $dat = substr($$dataPt, $i+$start, $wid); |
4428
|
228
|
|
|
|
|
1074
|
my $s = join(' ', unpack($tmpl, $dat)); |
4429
|
228
|
|
|
|
|
764
|
printf $out $format, $s; |
4430
|
228
|
|
|
|
|
427
|
$dat =~ tr /\x00-\x1f\x7f-\xff/./; |
4431
|
228
|
|
|
|
|
701
|
print $out "[$dat]\n"; |
4432
|
|
|
|
|
|
|
} |
4433
|
169
|
100
|
|
|
|
1147
|
$more and print $out "$prefix [snip $more bytes]\n"; |
4434
|
|
|
|
|
|
|
} |
4435
|
|
|
|
|
|
|
|
4436
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
4437
|
|
|
|
|
|
|
# Print verbose tag information |
4438
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object reference, 1) tag ID |
4439
|
|
|
|
|
|
|
# 2) tag info reference (or undef) |
4440
|
|
|
|
|
|
|
# 3-N) extra parms: |
4441
|
|
|
|
|
|
|
# Parms: Index => Index of tag in menu (starting at 0) |
4442
|
|
|
|
|
|
|
# Value => Tag value |
4443
|
|
|
|
|
|
|
# DataPt => reference to value data block |
4444
|
|
|
|
|
|
|
# DataPos => location of data block in file |
4445
|
|
|
|
|
|
|
# Base => base added to all offsets |
4446
|
|
|
|
|
|
|
# Size => length of value data within block |
4447
|
|
|
|
|
|
|
# Format => value format string |
4448
|
|
|
|
|
|
|
# Count => number of values |
4449
|
|
|
|
|
|
|
# Extra => Extra Verbose=2 information to put after tag number |
4450
|
|
|
|
|
|
|
# Table => Reference to tag table |
4451
|
|
|
|
|
|
|
# --> plus any of these HexDump() options: Start, Addr, Width |
4452
|
|
|
|
|
|
|
sub VerboseInfo($$$%) |
4453
|
|
|
|
|
|
|
{ |
4454
|
617
|
|
|
617
|
0
|
3487
|
my ($self, $tagID, $tagInfo, %parms) = @_; |
4455
|
617
|
|
|
|
|
1471
|
my $verbose = $$self{OPTIONS}{Verbose}; |
4456
|
617
|
|
|
|
|
1104
|
my $out = $$self{OPTIONS}{TextOut}; |
4457
|
617
|
|
|
|
|
966
|
my ($tag, $line, $hexID); |
4458
|
|
|
|
|
|
|
|
4459
|
|
|
|
|
|
|
# generate hex number if tagID is numerical |
4460
|
617
|
100
|
|
|
|
1172
|
if (defined $tagID) { |
4461
|
578
|
100
|
|
|
|
3880
|
$tagID =~ /^\d+$/ and $hexID = sprintf("0x%.4x", $tagID); |
4462
|
|
|
|
|
|
|
} else { |
4463
|
39
|
|
|
|
|
67
|
$tagID = 'Unknown'; |
4464
|
|
|
|
|
|
|
} |
4465
|
|
|
|
|
|
|
# get tag name |
4466
|
617
|
50
|
33
|
|
|
2747
|
if ($tagInfo and $$tagInfo{Name}) { |
4467
|
617
|
|
|
|
|
1248
|
$tag = $$tagInfo{Name}; |
4468
|
|
|
|
|
|
|
} else { |
4469
|
0
|
|
|
|
|
0
|
my $prefix; |
4470
|
0
|
0
|
|
|
|
0
|
$prefix = $parms{Table}{TAG_PREFIX} if $parms{Table}; |
4471
|
0
|
0
|
0
|
|
|
0
|
if ($prefix or $hexID) { |
4472
|
0
|
0
|
|
|
|
0
|
$prefix = 'Unknown' unless $prefix; |
4473
|
0
|
0
|
|
|
|
0
|
$tag = $prefix . '_' . ($hexID ? $hexID : $tagID); |
4474
|
|
|
|
|
|
|
} else { |
4475
|
0
|
|
|
|
|
0
|
$tag = $tagID; |
4476
|
|
|
|
|
|
|
} |
4477
|
|
|
|
|
|
|
} |
4478
|
617
|
|
|
|
|
1077
|
my $dataPt = $parms{DataPt}; |
4479
|
617
|
|
|
|
|
1033
|
my $size = $parms{Size}; |
4480
|
617
|
50
|
66
|
|
|
1604
|
$size = length $$dataPt unless defined $size or not $dataPt; |
4481
|
617
|
|
|
|
|
1181
|
my $indent = $$self{INDENT}; |
4482
|
|
|
|
|
|
|
|
4483
|
|
|
|
|
|
|
# Level 1: print tag/value information |
4484
|
617
|
|
|
|
|
955
|
$line = $indent; |
4485
|
617
|
|
|
|
|
1008
|
my $index = $parms{Index}; |
4486
|
617
|
100
|
|
|
|
1268
|
if (defined $index) { |
4487
|
365
|
|
|
|
|
705
|
$line .= $index . ') '; |
4488
|
365
|
100
|
|
|
|
826
|
$line .= ' ' if length($index) < 2; |
4489
|
365
|
|
|
|
|
570
|
$indent .= ' '; # indent everything else to align with tag name |
4490
|
|
|
|
|
|
|
} |
4491
|
617
|
|
|
|
|
1084
|
$line .= $tag; |
4492
|
617
|
100
|
66
|
|
|
2161
|
if ($tagInfo and $$tagInfo{SubDirectory}) { |
4493
|
39
|
|
|
|
|
72
|
$line .= ' (SubDirectory) -->'; |
4494
|
|
|
|
|
|
|
} else { |
4495
|
578
|
|
|
|
|
1016
|
my $maxLen = 90 - length($line); |
4496
|
578
|
|
|
|
|
907
|
my $val = $parms{Value}; |
4497
|
578
|
50
|
|
|
|
1101
|
if (defined $val) { |
|
|
0
|
|
|
|
|
|
4498
|
578
|
50
|
|
|
|
1224
|
$val = '[' . join(',',@$val) . ']' if ref $val eq 'ARRAY'; |
4499
|
578
|
|
|
|
|
1750
|
$line .= ' = ' . $self->Printable($val, $maxLen); |
4500
|
|
|
|
|
|
|
} elsif ($dataPt) { |
4501
|
0
|
|
0
|
|
|
0
|
my $start = $parms{Start} || 0; |
4502
|
0
|
|
|
|
|
0
|
$line .= ' = ' . $self->Printable(substr($$dataPt,$start,$size), $maxLen); |
4503
|
|
|
|
|
|
|
} |
4504
|
|
|
|
|
|
|
} |
4505
|
617
|
|
|
|
|
1912
|
print $out "$line\n"; |
4506
|
|
|
|
|
|
|
|
4507
|
|
|
|
|
|
|
# Level 2: print detailed information about the tag |
4508
|
617
|
50
|
66
|
|
|
2995
|
if ($verbose > 1 and ($parms{Extra} or $parms{Format} or |
|
|
|
66
|
|
|
|
|
4509
|
|
|
|
|
|
|
$parms{DataPt} or defined $size or $tagID =~ /\//)) |
4510
|
|
|
|
|
|
|
{ |
4511
|
390
|
|
|
|
|
700
|
$line = $indent . '- Tag '; |
4512
|
390
|
100
|
|
|
|
759
|
if ($hexID) { |
4513
|
389
|
|
|
|
|
575
|
$line .= $hexID; |
4514
|
|
|
|
|
|
|
} else { |
4515
|
1
|
|
|
|
|
7
|
$tagID =~ s/([\0-\x1f\x7f-\xff])/sprintf('\\x%.2x',ord $1)/ge; |
|
0
|
|
|
|
|
0
|
|
4516
|
1
|
|
|
|
|
3
|
$line .= "'${tagID}'"; |
4517
|
|
|
|
|
|
|
} |
4518
|
390
|
50
|
|
|
|
793
|
$line .= $parms{Extra} if defined $parms{Extra}; |
4519
|
390
|
|
|
|
|
622
|
my $format = $parms{Format}; |
4520
|
390
|
50
|
66
|
|
|
986
|
if ($format or defined $size) { |
4521
|
390
|
|
|
|
|
633
|
$line .= ' ('; |
4522
|
390
|
50
|
|
|
|
751
|
if (defined $size) { |
4523
|
390
|
|
|
|
|
685
|
$line .= "$size bytes"; |
4524
|
390
|
100
|
|
|
|
820
|
$line .= ', ' if $format; |
4525
|
|
|
|
|
|
|
} |
4526
|
390
|
100
|
|
|
|
732
|
if ($format) { |
4527
|
352
|
|
|
|
|
496
|
$line .= $format; |
4528
|
352
|
50
|
|
|
|
929
|
$line .= '['.$parms{Count}.']' if $parms{Count}; |
4529
|
|
|
|
|
|
|
} |
4530
|
390
|
|
|
|
|
613
|
$line .= ')'; |
4531
|
|
|
|
|
|
|
} |
4532
|
390
|
50
|
66
|
|
|
1062
|
$line .= ':' if $verbose > 2 and $parms{DataPt}; |
4533
|
390
|
|
|
|
|
898
|
print $out "$line\n"; |
4534
|
|
|
|
|
|
|
} |
4535
|
|
|
|
|
|
|
|
4536
|
|
|
|
|
|
|
# Level 3: do hex dump of value |
4537
|
617
|
100
|
100
|
|
|
2985
|
if ($verbose > 2 and $parms{DataPt} and (not $tagInfo or not $$tagInfo{ReadFromRAF})) { |
|
|
|
33
|
|
|
|
|
|
|
|
66
|
|
|
|
|
4538
|
165
|
|
|
|
|
355
|
$parms{Out} = $out; |
4539
|
165
|
|
|
|
|
333
|
$parms{Prefix} = $indent; |
4540
|
|
|
|
|
|
|
# limit dump length if Verbose < 5 |
4541
|
165
|
50
|
|
|
|
493
|
$parms{MaxLen} = $verbose == 3 ? 96 : 2048 if $verbose < 5; |
|
|
50
|
|
|
|
|
|
4542
|
165
|
|
|
|
|
1115
|
HexDump($dataPt, $size, %parms); |
4543
|
|
|
|
|
|
|
} |
4544
|
|
|
|
|
|
|
} |
4545
|
|
|
|
|
|
|
|
4546
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
4547
|
|
|
|
|
|
|
# Dump trailer information |
4548
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object ref, 1) dirInfo hash (RAF, DirName, DataPos, DirLen) |
4549
|
|
|
|
|
|
|
# Notes: Restores current file position before returning |
4550
|
|
|
|
|
|
|
sub DumpTrailer($$) |
4551
|
|
|
|
|
|
|
{ |
4552
|
1
|
|
|
1
|
0
|
5
|
my ($self, $dirInfo) = @_; |
4553
|
1
|
|
|
|
|
5
|
my $raf = $$dirInfo{RAF}; |
4554
|
1
|
|
|
|
|
5
|
my $curPos = $raf->Tell(); |
4555
|
1
|
|
50
|
|
|
6
|
my $trailer = $$dirInfo{DirName} || 'Unknown'; |
4556
|
1
|
|
|
|
|
4
|
my $pos = $$dirInfo{DataPos}; |
4557
|
1
|
|
|
|
|
4
|
my $verbose = $$self{OPTIONS}{Verbose}; |
4558
|
1
|
|
|
|
|
4
|
my $htmlDump = $$self{HTML_DUMP}; |
4559
|
1
|
|
|
|
|
2
|
my ($buff, $buf2); |
4560
|
1
|
|
|
|
|
3
|
my $size = $$dirInfo{DirLen}; |
4561
|
1
|
50
|
|
|
|
6
|
$pos = $curPos unless defined $pos; |
4562
|
|
|
|
|
|
|
|
4563
|
|
|
|
|
|
|
# get full trailer size if not specified |
4564
|
1
|
|
|
|
|
3
|
for (;;) { |
4565
|
1
|
50
|
|
|
|
5
|
unless ($size) { |
4566
|
0
|
0
|
|
|
|
0
|
$raf->Seek(0, 2) or last; |
4567
|
0
|
|
|
|
|
0
|
$size = $raf->Tell() - $pos; |
4568
|
0
|
0
|
|
|
|
0
|
last unless $size; |
4569
|
|
|
|
|
|
|
} |
4570
|
1
|
50
|
|
|
|
6
|
$raf->Seek($pos, 0) or last; |
4571
|
1
|
50
|
|
|
|
6
|
if ($htmlDump) { |
4572
|
0
|
0
|
|
|
|
0
|
my $num = $raf->Read($buff, $size) or return; |
4573
|
0
|
|
|
|
|
0
|
my $desc = "$trailer trailer"; |
4574
|
0
|
0
|
|
|
|
0
|
$desc = "[$desc]" if $trailer eq 'Unknown'; |
4575
|
0
|
|
|
|
|
0
|
$self->HDump($pos, $num, $desc, undef, 0x08); |
4576
|
0
|
|
|
|
|
0
|
last; |
4577
|
|
|
|
|
|
|
} |
4578
|
1
|
|
|
|
|
4
|
my $out = $$self{OPTIONS}{TextOut}; |
4579
|
1
|
|
|
|
|
12
|
printf $out "$trailer trailer (%d bytes at offset 0x%.4x):\n", $size, $pos; |
4580
|
1
|
50
|
|
|
|
7
|
last unless $verbose > 2; |
4581
|
0
|
|
|
|
|
0
|
my $num = $size; # number of bytes to read |
4582
|
|
|
|
|
|
|
# limit size if not very verbose |
4583
|
0
|
0
|
|
|
|
0
|
if ($verbose < 5) { |
4584
|
0
|
0
|
|
|
|
0
|
my $limit = $verbose < 4 ? 96 : 512; |
4585
|
0
|
0
|
|
|
|
0
|
$num = $limit if $num > $limit; |
4586
|
|
|
|
|
|
|
} |
4587
|
0
|
0
|
|
|
|
0
|
$raf->Read($buff, $num) == $num or return; |
4588
|
|
|
|
|
|
|
# read the end of the trailer too if not done already |
4589
|
0
|
0
|
|
|
|
0
|
if ($size > 2 * $num) { |
|
|
0
|
|
|
|
|
|
4590
|
0
|
|
|
|
|
0
|
$raf->Seek($pos + $size - $num, 0); |
4591
|
0
|
|
|
|
|
0
|
$raf->Read($buf2, $num); |
4592
|
|
|
|
|
|
|
} elsif ($size > $num) { |
4593
|
0
|
|
|
|
|
0
|
$raf->Seek($pos + $num, 0); |
4594
|
0
|
|
|
|
|
0
|
$raf->Read($buf2, $size - $num); |
4595
|
0
|
|
|
|
|
0
|
$buff .= $buf2; |
4596
|
0
|
|
|
|
|
0
|
undef $buf2; |
4597
|
|
|
|
|
|
|
} |
4598
|
0
|
|
|
|
|
0
|
HexDump(\$buff, undef, Addr => $pos, Out => $out); |
4599
|
0
|
0
|
|
|
|
0
|
if (defined $buf2) { |
4600
|
0
|
|
|
|
|
0
|
print $out " [snip ", $size - $num * 2, " bytes]\n"; |
4601
|
0
|
|
|
|
|
0
|
HexDump(\$buf2, undef, Addr => $pos + $size - $num, Out => $out); |
4602
|
|
|
|
|
|
|
} |
4603
|
0
|
|
|
|
|
0
|
last; |
4604
|
|
|
|
|
|
|
} |
4605
|
1
|
|
|
|
|
7
|
$raf->Seek($curPos, 0); |
4606
|
|
|
|
|
|
|
} |
4607
|
|
|
|
|
|
|
|
4608
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
4609
|
|
|
|
|
|
|
# Dump unknown trailer information |
4610
|
|
|
|
|
|
|
# Inputs: 0) ExifTool ref, 1) dirInfo ref (with RAF, DataPos and DirLen defined) |
4611
|
|
|
|
|
|
|
# Notes: changes dirInfo elements |
4612
|
|
|
|
|
|
|
sub DumpUnknownTrailer($$) |
4613
|
|
|
|
|
|
|
{ |
4614
|
0
|
|
|
0
|
0
|
0
|
my ($self, $dirInfo) = @_; |
4615
|
0
|
|
|
|
|
0
|
my $pos = $$dirInfo{DataPos}; |
4616
|
0
|
|
|
|
|
0
|
my $endPos = $pos + $$dirInfo{DirLen}; |
4617
|
|
|
|
|
|
|
# account for preview/MPF image trailer |
4618
|
0
|
|
0
|
|
|
0
|
my $prePos = $$self{VALUE}{PreviewImageStart} || $$self{PreviewImageStart}; |
4619
|
0
|
|
0
|
|
|
0
|
my $preLen = $$self{VALUE}{PreviewImageLength} || $$self{PreviewImageLength}; |
4620
|
0
|
|
|
|
|
0
|
my $tag = 'PreviewImage'; |
4621
|
0
|
|
|
|
|
0
|
my $mpImageNum = 0; |
4622
|
0
|
|
|
|
|
0
|
my (%image, $lastOne); |
4623
|
0
|
|
|
|
|
0
|
for (;;) { |
4624
|
|
|
|
|
|
|
# add to Preview block list if valid and in the trailer |
4625
|
0
|
0
|
0
|
|
|
0
|
$image{$prePos} = [$tag, $preLen] if $prePos and $preLen and $prePos+$preLen > $pos; |
|
|
|
0
|
|
|
|
|
4626
|
0
|
0
|
|
|
|
0
|
last if $lastOne; # checked all images |
4627
|
|
|
|
|
|
|
# look for MPF images (in the proper order) |
4628
|
0
|
|
|
|
|
0
|
++$mpImageNum; |
4629
|
0
|
|
|
|
|
0
|
$prePos = $$self{VALUE}{"MPImageStart ($mpImageNum)"}; |
4630
|
0
|
0
|
|
|
|
0
|
if (defined $prePos) { |
4631
|
0
|
|
|
|
|
0
|
$preLen = $$self{VALUE}{"MPImageLength ($mpImageNum)"}; |
4632
|
|
|
|
|
|
|
} else { |
4633
|
0
|
|
|
|
|
0
|
$prePos = $$self{VALUE}{'MPImageStart'}; |
4634
|
0
|
|
|
|
|
0
|
$preLen = $$self{VALUE}{'MPImageLength'}; |
4635
|
0
|
|
|
|
|
0
|
$lastOne = 1; |
4636
|
|
|
|
|
|
|
} |
4637
|
0
|
|
|
|
|
0
|
$tag = "MPImage$mpImageNum"; |
4638
|
|
|
|
|
|
|
} |
4639
|
|
|
|
|
|
|
# dump trailer sections in order |
4640
|
0
|
|
|
|
|
0
|
$image{$endPos} = [ '', 0 ]; # add terminator "image" |
4641
|
0
|
|
|
|
|
0
|
foreach $prePos (sort { $a <=> $b } keys %image) { |
|
0
|
|
|
|
|
0
|
|
4642
|
0
|
0
|
|
|
|
0
|
if ($pos < $prePos) { |
4643
|
|
|
|
|
|
|
# dump unknown trailer data |
4644
|
0
|
|
|
|
|
0
|
$$dirInfo{DirName} = 'Unknown'; |
4645
|
0
|
|
|
|
|
0
|
$$dirInfo{DataPos} = $pos; |
4646
|
0
|
|
|
|
|
0
|
$$dirInfo{DirLen} = $prePos - $pos; |
4647
|
0
|
|
|
|
|
0
|
$self->DumpTrailer($dirInfo); |
4648
|
|
|
|
|
|
|
} |
4649
|
0
|
|
|
|
|
0
|
($tag, $preLen) = @{$image{$prePos}}; |
|
0
|
|
|
|
|
0
|
|
4650
|
0
|
0
|
|
|
|
0
|
last unless $preLen; |
4651
|
|
|
|
|
|
|
# dump image if verbose (it is htmlDump'd by ExtractImage) |
4652
|
0
|
0
|
|
|
|
0
|
if ($$self{OPTIONS}{Verbose}) { |
4653
|
0
|
|
|
|
|
0
|
$$dirInfo{DirName} = $tag; |
4654
|
0
|
|
|
|
|
0
|
$$dirInfo{DataPos} = $prePos; |
4655
|
0
|
|
|
|
|
0
|
$$dirInfo{DirLen} = $preLen; |
4656
|
0
|
|
|
|
|
0
|
$self->DumpTrailer($dirInfo); |
4657
|
|
|
|
|
|
|
} |
4658
|
0
|
|
|
|
|
0
|
$pos = $prePos + $preLen; |
4659
|
|
|
|
|
|
|
} |
4660
|
|
|
|
|
|
|
} |
4661
|
|
|
|
|
|
|
|
4662
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
4663
|
|
|
|
|
|
|
# Find last element in linked list |
4664
|
|
|
|
|
|
|
# Inputs: 0) element in list |
4665
|
|
|
|
|
|
|
# Returns: Last element in list |
4666
|
|
|
|
|
|
|
sub LastInList($) |
4667
|
|
|
|
|
|
|
{ |
4668
|
35
|
|
|
35
|
0
|
108
|
my $element = shift; |
4669
|
35
|
|
|
|
|
149
|
while ($$element{Next}) { |
4670
|
0
|
|
|
|
|
0
|
$element = $$element{Next}; |
4671
|
|
|
|
|
|
|
} |
4672
|
35
|
|
|
|
|
83
|
return $element; |
4673
|
|
|
|
|
|
|
} |
4674
|
|
|
|
|
|
|
|
4675
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
4676
|
|
|
|
|
|
|
# Print verbose value while writing |
4677
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object ref, 1) heading "eg. '+ IPTC:Keywords', |
4678
|
|
|
|
|
|
|
# 2) value, 3) [optional] extra text after value |
4679
|
|
|
|
|
|
|
sub VerboseValue($$$;$) |
4680
|
|
|
|
|
|
|
{ |
4681
|
1059
|
100
|
|
1059
|
0
|
3307
|
return unless $_[0]{OPTIONS}{Verbose} > 1; |
4682
|
14
|
|
|
|
|
33
|
my ($self, $str, $val, $xtra) = @_; |
4683
|
14
|
|
|
|
|
30
|
my $out = $$self{OPTIONS}{TextOut}; |
4684
|
14
|
100
|
|
|
|
38
|
$xtra or $xtra = ''; |
4685
|
14
|
|
|
|
|
32
|
my $maxLen = 81 - length($str) - length($xtra); |
4686
|
14
|
|
|
|
|
44
|
$val = $self->Printable($val, $maxLen); |
4687
|
14
|
|
|
|
|
73
|
print $out " $str = '${val}'$xtra\n"; |
4688
|
|
|
|
|
|
|
} |
4689
|
|
|
|
|
|
|
|
4690
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
4691
|
|
|
|
|
|
|
# Pack Unicode numbers into UTF8 string |
4692
|
|
|
|
|
|
|
# Inputs: 0-N) list of Unicode numbers |
4693
|
|
|
|
|
|
|
# Returns: Packed UTF-8 string |
4694
|
|
|
|
|
|
|
sub PackUTF8(@) |
4695
|
|
|
|
|
|
|
{ |
4696
|
0
|
|
|
0
|
0
|
0
|
my @out; |
4697
|
0
|
|
|
|
|
0
|
while (@_) { |
4698
|
0
|
|
|
|
|
0
|
my $ch = pop; |
4699
|
0
|
0
|
|
|
|
0
|
unshift(@out, $ch), next if $ch < 0x80; |
4700
|
0
|
|
|
|
|
0
|
unshift(@out, 0x80 | ($ch & 0x3f)); |
4701
|
0
|
|
|
|
|
0
|
$ch >>= 6; |
4702
|
0
|
0
|
|
|
|
0
|
unshift(@out, 0xc0 | $ch), next if $ch < 0x20; |
4703
|
0
|
|
|
|
|
0
|
unshift(@out, 0x80 | ($ch & 0x3f)); |
4704
|
0
|
|
|
|
|
0
|
$ch >>= 6; |
4705
|
0
|
0
|
|
|
|
0
|
unshift(@out, 0xe0 | $ch), next if $ch < 0x10; |
4706
|
0
|
|
|
|
|
0
|
unshift(@out, 0x80 | ($ch & 0x3f)); |
4707
|
0
|
|
|
|
|
0
|
$ch >>= 6; |
4708
|
0
|
|
|
|
|
0
|
unshift(@out, 0xf0 | ($ch & 0x07)); |
4709
|
|
|
|
|
|
|
} |
4710
|
0
|
|
|
|
|
0
|
return pack('C*', @out); |
4711
|
|
|
|
|
|
|
} |
4712
|
|
|
|
|
|
|
|
4713
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
4714
|
|
|
|
|
|
|
# Unpack numbers from UTF8 string |
4715
|
|
|
|
|
|
|
# Inputs: 0) UTF-8 string |
4716
|
|
|
|
|
|
|
# Returns: List of Unicode numbers (sets $evalWarning on error) |
4717
|
|
|
|
|
|
|
sub UnpackUTF8($) |
4718
|
|
|
|
|
|
|
{ |
4719
|
0
|
|
|
0
|
0
|
0
|
my (@out, $pos); |
4720
|
0
|
|
|
|
|
0
|
pos($_[0]) = $pos = 0; # start at beginning of string |
4721
|
0
|
|
|
|
|
0
|
for (;;) { |
4722
|
0
|
|
|
|
|
0
|
my ($ch, $newPos, $val, $byte); |
4723
|
0
|
0
|
|
|
|
0
|
if ($_[0] =~ /([\x80-\xff])/g) { |
4724
|
0
|
|
|
|
|
0
|
$ch = ord($1); |
4725
|
0
|
|
|
|
|
0
|
$newPos = pos($_[0]) - 1; |
4726
|
|
|
|
|
|
|
} else { |
4727
|
0
|
|
|
|
|
0
|
$newPos = length $_[0]; |
4728
|
|
|
|
|
|
|
} |
4729
|
|
|
|
|
|
|
# unpack 7-bit characters |
4730
|
0
|
|
|
|
|
0
|
my $len = $newPos - $pos; |
4731
|
0
|
0
|
|
|
|
0
|
push @out, unpack("x${pos}C$len",$_[0]) if $len; |
4732
|
0
|
0
|
|
|
|
0
|
last unless defined $ch; |
4733
|
0
|
|
|
|
|
0
|
$pos = $newPos + 1; |
4734
|
|
|
|
|
|
|
# minimum lead byte for 2-byte sequence is 0xc2 (overlong sequences |
4735
|
|
|
|
|
|
|
# not allowed), 0xf8-0xfd are restricted by RFC 3629 (no 5 or 6 byte |
4736
|
|
|
|
|
|
|
# sequences), and 0xfe and 0xff are not valid in UTF-8 strings |
4737
|
0
|
0
|
0
|
|
|
0
|
if ($ch < 0xc2 or $ch >= 0xf8) { |
4738
|
0
|
|
|
|
|
0
|
push @out, ord('?'); # invalid UTF-8 |
4739
|
0
|
|
|
|
|
0
|
$evalWarning = 'Bad UTF-8'; |
4740
|
0
|
|
|
|
|
0
|
next; |
4741
|
|
|
|
|
|
|
} |
4742
|
|
|
|
|
|
|
# decode 2, 3 and 4-byte sequences |
4743
|
0
|
|
|
|
|
0
|
my $n = 1; |
4744
|
0
|
0
|
|
|
|
0
|
if ($ch < 0xe0) { |
|
|
0
|
|
|
|
|
|
4745
|
0
|
|
|
|
|
0
|
$val = $ch & 0x1f; # 2-byte sequence |
4746
|
|
|
|
|
|
|
} elsif ($ch < 0xf0) { |
4747
|
0
|
|
|
|
|
0
|
$val = $ch & 0x0f; # 3-byte sequence |
4748
|
0
|
|
|
|
|
0
|
++$n; |
4749
|
|
|
|
|
|
|
} else { |
4750
|
0
|
|
|
|
|
0
|
$val = $ch & 0x07; # 4-byte sequence |
4751
|
0
|
|
|
|
|
0
|
$n += 2; |
4752
|
|
|
|
|
|
|
} |
4753
|
0
|
0
|
|
|
|
0
|
unless ($_[0] =~ /\G([\x80-\xbf]{$n})/g) { |
4754
|
0
|
|
|
|
|
0
|
pos($_[0]) = $pos; # restore position |
4755
|
0
|
|
|
|
|
0
|
push @out, ord('?'); # invalid UTF-8 |
4756
|
0
|
|
|
|
|
0
|
$evalWarning = 'Bad UTF-8'; |
4757
|
0
|
|
|
|
|
0
|
next; |
4758
|
|
|
|
|
|
|
} |
4759
|
0
|
|
|
|
|
0
|
foreach $byte (unpack 'C*', $1) { |
4760
|
0
|
|
|
|
|
0
|
$val = ($val << 6) | ($byte & 0x3f); |
4761
|
|
|
|
|
|
|
} |
4762
|
0
|
|
|
|
|
0
|
push @out, $val; # save Unicode character value |
4763
|
0
|
|
|
|
|
0
|
$pos += $n; # position at end of UTF-8 character |
4764
|
|
|
|
|
|
|
} |
4765
|
0
|
|
|
|
|
0
|
return @out; |
4766
|
|
|
|
|
|
|
} |
4767
|
|
|
|
|
|
|
|
4768
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
4769
|
|
|
|
|
|
|
# Generate a new, random GUID |
4770
|
|
|
|
|
|
|
# Inputs: |
4771
|
|
|
|
|
|
|
# Returns: GUID string |
4772
|
|
|
|
|
|
|
my $guidCount; |
4773
|
|
|
|
|
|
|
sub NewGUID() |
4774
|
|
|
|
|
|
|
{ |
4775
|
61
|
|
|
61
|
0
|
1536
|
my @tm = localtime time; |
4776
|
61
|
100
|
66
|
|
|
664
|
$guidCount = 0 unless defined $guidCount and ++$guidCount < 0x100; |
4777
|
61
|
|
|
|
|
1834
|
return sprintf('%.4d%.2d%.2d%.2d%.2d%.2d%.2X%.4X%.4X%.4X%.4X', |
4778
|
|
|
|
|
|
|
$tm[5]+1900, $tm[4]+1, $tm[3], $tm[2], $tm[1], $tm[0], $guidCount, |
4779
|
|
|
|
|
|
|
$$ & 0xffff, rand(0x10000), rand(0x10000), rand(0x10000)); |
4780
|
|
|
|
|
|
|
} |
4781
|
|
|
|
|
|
|
|
4782
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
4783
|
|
|
|
|
|
|
# Make TIFF header for raw data |
4784
|
|
|
|
|
|
|
# Inputs: 0) width, 1) height, 2) num colour components, 3) bits, 4) resolution |
4785
|
|
|
|
|
|
|
# 5) color-map data for palette-color image (8 or 16 bit) |
4786
|
|
|
|
|
|
|
# Returns: TIFF header |
4787
|
|
|
|
|
|
|
# Notes: Multi-byte data must be little-endian |
4788
|
|
|
|
|
|
|
sub MakeTiffHeader($$$$;$$) |
4789
|
|
|
|
|
|
|
{ |
4790
|
0
|
|
|
0
|
0
|
0
|
my ($w, $h, $cols, $bits, $res, $cmap) = @_; |
4791
|
0
|
0
|
|
|
|
0
|
$res or $res = 72; |
4792
|
0
|
|
|
|
|
0
|
my $saveOrder = GetByteOrder(); |
4793
|
0
|
|
|
|
|
0
|
SetByteOrder('II'); |
4794
|
0
|
0
|
|
|
|
0
|
if (not $cmap) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
4795
|
0
|
|
|
|
|
0
|
$cmap = ''; |
4796
|
|
|
|
|
|
|
} elsif (length $cmap == 3 * 2**$bits) { |
4797
|
|
|
|
|
|
|
# convert to short |
4798
|
0
|
|
|
|
|
0
|
$cmap = pack 'v*', map { $_ | ($_<<8) } unpack 'C*', $cmap; |
|
0
|
|
|
|
|
0
|
|
4799
|
|
|
|
|
|
|
} elsif (length $cmap != 6 * 2**$bits) { |
4800
|
0
|
|
|
|
|
0
|
$cmap = ''; |
4801
|
|
|
|
|
|
|
} |
4802
|
0
|
0
|
|
|
|
0
|
my $cmo = $cmap ? 12 : 0; # offset due to ColorMap IFD entry |
4803
|
0
|
0
|
|
|
|
0
|
my $hdr = |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
4804
|
|
|
|
|
|
|
"\x49\x49\x2a\0\x08\0\0\0\x0e\0" . # 0x00 14 menu entries: |
4805
|
|
|
|
|
|
|
"\xfe\x00\x04\0\x01\0\0\0\x00\0\0\0" . # 0x0a SubfileType = 0 |
4806
|
|
|
|
|
|
|
"\x00\x01\x04\0\x01\0\0\0" . Set32u($w) . # 0x16 ImageWidth |
4807
|
|
|
|
|
|
|
"\x01\x01\x04\0\x01\0\0\0" . Set32u($h) . # 0x22 ImageHeight |
4808
|
|
|
|
|
|
|
"\x02\x01\x03\0" . Set32u($cols) . # 0x2e BitsPerSample |
4809
|
|
|
|
|
|
|
Set32u($cols == 1 ? $bits : 0xb6 + $cmo) . |
4810
|
|
|
|
|
|
|
"\x03\x01\x03\0\x01\0\0\0\x01\0\0\0" . # 0x3a Compression = 1 |
4811
|
|
|
|
|
|
|
"\x06\x01\x03\0\x01\0\0\0" . # 0x46 PhotometricInterpretation |
4812
|
|
|
|
|
|
|
Set32u($cmap ? 3 : $cols == 1 ? 1 : 2) . |
4813
|
|
|
|
|
|
|
"\x11\x01\x04\0\x01\0\0\0" . # 0x52 StripOffsets |
4814
|
|
|
|
|
|
|
Set32u(0xcc + $cmo + length($cmap)) . |
4815
|
|
|
|
|
|
|
"\x15\x01\x03\0\x01\0\0\0" . Set32u($cols) . # 0x5e SamplesPerPixel |
4816
|
|
|
|
|
|
|
"\x16\x01\x04\0\x01\0\0\0" . Set32u($h) . # 0x6a RowsPerStrip |
4817
|
|
|
|
|
|
|
"\x17\x01\x04\0\x01\0\0\0" . # 0x76 StripByteCounts |
4818
|
|
|
|
|
|
|
Set32u($w * $h * $cols * int(($bits+7)/8)) . |
4819
|
|
|
|
|
|
|
"\x1a\x01\x05\0\x01\0\0\0" . Set32u(0xbc + $cmo) . # 0x82 XResolution |
4820
|
|
|
|
|
|
|
"\x1b\x01\x05\0\x01\0\0\0" . Set32u(0xc4 + $cmo) . # 0x8e YResolution |
4821
|
|
|
|
|
|
|
"\x1c\x01\x03\0\x01\0\0\0\x01\0\0\0" . # 0x9a PlanarConfiguration = 1 |
4822
|
|
|
|
|
|
|
"\x28\x01\x03\0\x01\0\0\0\x02\0\0\0" . # 0xa6 ResolutionUnit = 2 |
4823
|
|
|
|
|
|
|
($cmap ? # 0xb2 ColorMap [optional] |
4824
|
|
|
|
|
|
|
"\x40\x01\x03\0" . Set32u(3 * 2**$bits) . "\xd8\0\0\0" : '') . |
4825
|
|
|
|
|
|
|
"\0\0\0\0" . # 0xb2+$cmo (no IFD1) |
4826
|
|
|
|
|
|
|
(Set16u($bits) x 3) . # 0xb6+$cmo BitsPerSample value |
4827
|
|
|
|
|
|
|
Set32u($res) . "\x01\0\0\0" . # 0xbc+$cmo XResolution = 72 |
4828
|
|
|
|
|
|
|
Set32u($res) . "\x01\0\0\0" . # 0xc4+$cmo YResolution = 72 |
4829
|
|
|
|
|
|
|
$cmap; # 0xcc or 0xd8 (cmap and data go here) |
4830
|
0
|
|
|
|
|
0
|
SetByteOrder($saveOrder); |
4831
|
0
|
|
|
|
|
0
|
return $hdr; |
4832
|
|
|
|
|
|
|
} |
4833
|
|
|
|
|
|
|
|
4834
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
4835
|
|
|
|
|
|
|
# Return current time in EXIF format |
4836
|
|
|
|
|
|
|
# Inputs: 0) [optional] ExifTool ref, 1) flag to include timezone (0 to disable, |
4837
|
|
|
|
|
|
|
# undef or 1 to include) |
4838
|
|
|
|
|
|
|
# Returns: time string |
4839
|
|
|
|
|
|
|
# - a consistent value is returned for each processed file |
4840
|
|
|
|
|
|
|
sub TimeNow(;$$) |
4841
|
|
|
|
|
|
|
{ |
4842
|
61
|
|
|
61
|
0
|
275
|
my ($self, $tzFlag) = @_; |
4843
|
61
|
|
|
|
|
153
|
my $timeNow; |
4844
|
61
|
50
|
|
|
|
301
|
ref $self or $tzFlag = $self, $self = { }; |
4845
|
61
|
50
|
|
|
|
287
|
if ($$self{Now}) { |
4846
|
0
|
|
|
|
|
0
|
$timeNow = $$self{Now}[0]; |
4847
|
|
|
|
|
|
|
} else { |
4848
|
61
|
|
|
|
|
190
|
my $time = time(); |
4849
|
61
|
|
|
|
|
2537
|
my @tm = localtime $time; |
4850
|
61
|
|
|
|
|
635
|
my $tz = TimeZoneString(\@tm, $time); |
4851
|
61
|
|
|
|
|
586
|
$timeNow = sprintf("%4d:%.2d:%.2d %.2d:%.2d:%.2d", |
4852
|
|
|
|
|
|
|
$tm[5]+1900, $tm[4]+1, $tm[3], |
4853
|
|
|
|
|
|
|
$tm[2], $tm[1], $tm[0]); |
4854
|
61
|
|
|
|
|
372
|
$$self{Now} = [ $timeNow, $tz ]; |
4855
|
|
|
|
|
|
|
} |
4856
|
61
|
50
|
33
|
|
|
656
|
$timeNow .= $$self{Now}[1] if $tzFlag or not defined $tzFlag; |
4857
|
61
|
|
|
|
|
382
|
return $timeNow; |
4858
|
|
|
|
|
|
|
} |
4859
|
|
|
|
|
|
|
|
4860
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
4861
|
|
|
|
|
|
|
# Inverse date/time print conversion (reformat to YYYY:mm:dd HH:MM:SS[.ss][+-HH:MM|Z]) |
4862
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object ref, 1) Date/Time string, 2) timezone flag: |
4863
|
|
|
|
|
|
|
# 0 - remove timezone and sub-seconds if they exist |
4864
|
|
|
|
|
|
|
# 1 - add timezone if it doesn't exist |
4865
|
|
|
|
|
|
|
# undef - leave timezone alone |
4866
|
|
|
|
|
|
|
# 3) flag to allow date-only (YYYY, YYYY:mm or YYYY:mm:dd) or time without seconds |
4867
|
|
|
|
|
|
|
# Returns: formatted date/time string (or undef and issues warning on error) |
4868
|
|
|
|
|
|
|
# Notes: currently accepts different separators, but doesn't use DateFormat yet |
4869
|
|
|
|
|
|
|
my $strptimeLib; # strptime library name if available |
4870
|
|
|
|
|
|
|
sub InverseDateTime($$;$$) |
4871
|
|
|
|
|
|
|
{ |
4872
|
437
|
|
|
437
|
0
|
1323
|
my ($self, $val, $tzFlag, $dateOnly) = @_; |
4873
|
437
|
|
|
|
|
773
|
my ($rtnVal, $tz); |
4874
|
437
|
|
|
|
|
1281
|
my $fmt = $$self{OPTIONS}{DateFormat}; |
4875
|
|
|
|
|
|
|
# strip off timezone first if it exists |
4876
|
437
|
100
|
66
|
|
|
3987
|
if (not $fmt and $val =~ s/([-+])(\d{1,2}):?(\d{2})\s*(DST)?$//i) { |
|
|
50
|
33
|
|
|
|
|
4877
|
6
|
|
|
|
|
89
|
$tz = sprintf("$1%.2d:$3", $2); |
4878
|
|
|
|
|
|
|
} elsif (not $fmt and $val =~ s/Z$//i) { |
4879
|
0
|
|
|
|
|
0
|
$tz = 'Z'; |
4880
|
|
|
|
|
|
|
} else { |
4881
|
431
|
|
|
|
|
898
|
$tz = ''; |
4882
|
|
|
|
|
|
|
# allow special value of 'now' |
4883
|
431
|
50
|
|
|
|
1251
|
return $self->TimeNow($tzFlag) if lc($val) eq 'now'; |
4884
|
|
|
|
|
|
|
} |
4885
|
|
|
|
|
|
|
# only convert date if a format was specified and the date is recognizable |
4886
|
437
|
50
|
|
|
|
1025
|
if ($fmt) { |
4887
|
0
|
0
|
|
|
|
0
|
unless (defined $strptimeLib) { |
4888
|
0
|
0
|
|
|
|
0
|
if (eval { require POSIX::strptime }) { |
|
0
|
0
|
|
|
|
0
|
|
4889
|
0
|
|
|
|
|
0
|
$strptimeLib = 'POSIX::strptime'; |
4890
|
0
|
|
|
|
|
0
|
} elsif (eval { require Time::Piece }) { |
4891
|
0
|
|
|
|
|
0
|
$strptimeLib = 'Time::Piece'; |
4892
|
|
|
|
|
|
|
# (call use_locale() to convert localized date/time, |
4893
|
|
|
|
|
|
|
# only available in Time::Piece 1.32 and later) |
4894
|
0
|
|
|
|
|
0
|
eval { Time::Piece->use_locale() }; |
|
0
|
|
|
|
|
0
|
|
4895
|
|
|
|
|
|
|
} else { |
4896
|
0
|
|
|
|
|
0
|
$strptimeLib = ''; |
4897
|
|
|
|
|
|
|
} |
4898
|
|
|
|
|
|
|
} |
4899
|
|
|
|
|
|
|
# handle factional seconds (%f), but only at the end of the string |
4900
|
0
|
0
|
0
|
|
|
0
|
my $fs = ($fmt =~ s/%f$// and $val =~ s/(\.\d+)\s*$//) ? $1 : ''; |
4901
|
0
|
|
|
|
|
0
|
my ($lib, $wrn, @a); |
4902
|
0
|
|
|
|
|
0
|
TryLib: for ($lib=$strptimeLib; ; $lib='') { |
4903
|
0
|
0
|
|
|
|
0
|
if (not $lib) { |
|
|
0
|
|
|
|
|
|
4904
|
0
|
0
|
|
|
|
0
|
last unless $$self{OPTIONS}{StrictDate}; |
4905
|
0
|
|
0
|
|
|
0
|
warn $wrn || "Install POSIX::strptime or Time::Piece for inverse date/time conversions\n"; |
4906
|
0
|
|
|
|
|
0
|
return undef; |
4907
|
|
|
|
|
|
|
} elsif ($lib eq 'POSIX::strptime') { |
4908
|
0
|
|
|
|
|
0
|
@a = eval { POSIX::strptime($val, $fmt) }; |
|
0
|
|
|
|
|
0
|
|
4909
|
|
|
|
|
|
|
} else { |
4910
|
|
|
|
|
|
|
# protect against a negative epoch time, it can cause a hard crash in Windows |
4911
|
0
|
0
|
0
|
|
|
0
|
if ($^O eq 'MSWin32' and $fmt =~ /%s/ and $val =~ /-\d/) { |
|
|
|
0
|
|
|
|
|
4912
|
0
|
|
|
|
|
0
|
warn "Can't convert negative epoch time\n"; |
4913
|
0
|
|
|
|
|
0
|
return undef; |
4914
|
|
|
|
|
|
|
} |
4915
|
0
|
|
|
|
|
0
|
@a = eval { |
4916
|
0
|
|
|
|
|
0
|
my $t = Time::Piece->strptime($val, $fmt); |
4917
|
0
|
|
|
|
|
0
|
return ($t->sec, $t->min, $t->hour, $t->mday, $t->_mon, $t->_year); |
4918
|
|
|
|
|
|
|
}; |
4919
|
|
|
|
|
|
|
} |
4920
|
0
|
0
|
0
|
|
|
0
|
if (defined $a[5] and length $a[5]) { |
4921
|
0
|
|
|
|
|
0
|
$a[5] += 1900; # add 1900 to year |
4922
|
|
|
|
|
|
|
} else { |
4923
|
0
|
|
|
|
|
0
|
$wrn = "Invalid date/time (no year) using $lib\n"; |
4924
|
0
|
|
|
|
|
0
|
next; |
4925
|
|
|
|
|
|
|
} |
4926
|
0
|
0
|
0
|
|
|
0
|
++$a[4] if defined $a[4] and length $a[4]; # add 1 to month |
4927
|
0
|
|
|
|
|
0
|
my $i; |
4928
|
0
|
|
|
|
|
0
|
foreach $i (0..4) { |
4929
|
0
|
0
|
0
|
|
|
0
|
if (not defined $a[$i] or not length $a[$i]) { |
|
|
0
|
|
|
|
|
|
4930
|
0
|
0
|
0
|
|
|
0
|
if ($i < 2 or $dateOnly) { # (allow missing minutes/seconds) |
4931
|
0
|
|
|
|
|
0
|
$a[$i] = ' '; |
4932
|
|
|
|
|
|
|
} else { |
4933
|
0
|
|
|
|
|
0
|
$wrn = "Incomplete date/time specification using $lib\n"; |
4934
|
0
|
|
|
|
|
0
|
next TryLib; |
4935
|
|
|
|
|
|
|
} |
4936
|
|
|
|
|
|
|
} elsif (length($a[$i]) < 2) { |
4937
|
0
|
|
|
|
|
0
|
$a[$i] = "0$a[$i]"; # pad to 2 digits if necessary |
4938
|
|
|
|
|
|
|
} |
4939
|
|
|
|
|
|
|
} |
4940
|
0
|
|
|
|
|
0
|
$val = join(':', @a[5,4,3]) . ' ' . join(':', @a[2,1,0]) . $fs; |
4941
|
0
|
|
|
|
|
0
|
last; |
4942
|
|
|
|
|
|
|
} |
4943
|
|
|
|
|
|
|
} |
4944
|
437
|
100
|
|
|
|
1970
|
if ($val =~ /(\d{4})/g) { # get YYYY |
4945
|
430
|
|
|
|
|
1118
|
my $yr = $1; |
4946
|
430
|
|
|
|
|
2609
|
my @a = ($val =~ /\d{1,2}/g); # get mm, dd, HH, and maybe MM, SS |
4947
|
430
|
|
66
|
|
|
2560
|
length($_) < 2 and $_ = "0$_" foreach @a; # pad to 2 digits if necessary |
4948
|
430
|
100
|
|
|
|
1174
|
if (@a >= 3) { |
|
|
50
|
|
|
|
|
|
4949
|
404
|
|
|
|
|
824
|
my $ss = $a[4]; # get SS |
4950
|
404
|
|
|
|
|
1147
|
push @a, '00' while @a < 5; # add MM, SS if not given |
4951
|
|
|
|
|
|
|
# get sub-seconds if they exist (must be after SS, and have leading ".") |
4952
|
404
|
100
|
100
|
|
|
1386
|
my $fs = (@a > 5 and $val =~ /(\.\d+)\s*$/) ? $1 : ''; |
4953
|
|
|
|
|
|
|
# add/remove timezone if necessary |
4954
|
404
|
100
|
|
|
|
1324
|
if ($tzFlag) { |
|
|
100
|
|
|
|
|
|
4955
|
34
|
50
|
|
|
|
159
|
if (not $tz) { |
4956
|
34
|
50
|
|
|
|
89
|
if (eval { require Time::Local }) { |
|
34
|
|
|
|
|
945
|
|
4957
|
|
|
|
|
|
|
# determine timezone offset for this time |
4958
|
34
|
|
|
|
|
2658
|
my @args = ($a[4],$a[3],$a[2],$a[1],$a[0]-1,$yr); |
4959
|
34
|
|
|
|
|
188
|
my $diff = Time::Local::timegm(@args) - TimeLocal(@args); |
4960
|
34
|
|
|
|
|
157
|
$tz = TimeZoneString($diff / 60); |
4961
|
|
|
|
|
|
|
} else { |
4962
|
0
|
|
|
|
|
0
|
$tz = 'Z'; # don't know time zone |
4963
|
|
|
|
|
|
|
} |
4964
|
|
|
|
|
|
|
} |
4965
|
|
|
|
|
|
|
} elsif (defined $tzFlag) { |
4966
|
92
|
|
|
|
|
257
|
$tz = $fs = ''; # remove timezone and sub-seconds |
4967
|
|
|
|
|
|
|
} |
4968
|
404
|
100
|
66
|
|
|
2168
|
if (defined $ss and $ss < 60) { |
|
|
50
|
|
|
|
|
|
4969
|
403
|
|
|
|
|
1048
|
$ss = ":$ss"; |
4970
|
|
|
|
|
|
|
} elsif ($dateOnly) { |
4971
|
1
|
|
|
|
|
5
|
$ss = ''; |
4972
|
|
|
|
|
|
|
} else { |
4973
|
0
|
|
|
|
|
0
|
$ss = ':00'; |
4974
|
|
|
|
|
|
|
} |
4975
|
|
|
|
|
|
|
# construct properly formatted date/time string |
4976
|
404
|
50
|
33
|
|
|
1899
|
if ($a[0] < 1 or $a[0] > 12) { |
4977
|
0
|
|
|
|
|
0
|
warn "Month '$a[0]' out of range 1..12\n"; |
4978
|
0
|
|
|
|
|
0
|
return undef; |
4979
|
|
|
|
|
|
|
} |
4980
|
404
|
50
|
33
|
|
|
1719
|
if ($a[1] < 1 or $a[1] > 31) { |
4981
|
0
|
|
|
|
|
0
|
warn "Day '$a[1]' out of range 1..31\n"; |
4982
|
0
|
|
|
|
|
0
|
return undef; |
4983
|
|
|
|
|
|
|
} |
4984
|
404
|
50
|
|
|
|
969
|
$a[2] > 24 and warn("Hour '$a[2]' out of range 0..24\n"), return undef; |
4985
|
404
|
50
|
|
|
|
956
|
$a[3] > 59 and warn("Minutes '$a[3]' out of range 0..59\n"), return undef; |
4986
|
404
|
|
|
|
|
1697
|
$rtnVal = "$yr:$a[0]:$a[1] $a[2]:$a[3]$ss$fs$tz"; |
4987
|
|
|
|
|
|
|
} elsif ($dateOnly) { |
4988
|
26
|
|
|
|
|
154
|
$rtnVal = join ':', $yr, @a; |
4989
|
|
|
|
|
|
|
} |
4990
|
|
|
|
|
|
|
} |
4991
|
437
|
100
|
|
|
|
1102
|
$rtnVal or warn "Invalid date/time (use YYYY:mm:dd HH:MM:SS[.ss][+/-HH:MM|Z])\n"; |
4992
|
437
|
|
|
|
|
3975
|
return $rtnVal; |
4993
|
|
|
|
|
|
|
} |
4994
|
|
|
|
|
|
|
|
4995
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
4996
|
|
|
|
|
|
|
# Set byte order according to our current preferences |
4997
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object ref, 1) default byte order |
4998
|
|
|
|
|
|
|
# Returns: new byte order ('II' or 'MM') and sets current byte order |
4999
|
|
|
|
|
|
|
# Notes: takes the first of the following that is valid: |
5000
|
|
|
|
|
|
|
# 1) ByteOrder option |
5001
|
|
|
|
|
|
|
# 2) new value for ExifByteOrder |
5002
|
|
|
|
|
|
|
# 3) default byte order passed to this routine |
5003
|
|
|
|
|
|
|
# 4) makenote byte order from last file read |
5004
|
|
|
|
|
|
|
# 5) big endian |
5005
|
|
|
|
|
|
|
sub SetPreferredByteOrder($;$) |
5006
|
|
|
|
|
|
|
{ |
5007
|
44
|
|
|
44
|
0
|
176
|
my ($self, $default) = @_; |
5008
|
|
|
|
|
|
|
my $byteOrder = $self->Options('ByteOrder') || |
5009
|
|
|
|
|
|
|
$self->GetNewValue('ExifByteOrder') || |
5010
|
44
|
|
100
|
|
|
228
|
$default || $$self{MAKER_NOTE_BYTE_ORDER} || 'MM'; |
5011
|
44
|
50
|
|
|
|
281
|
unless (SetByteOrder($byteOrder)) { |
5012
|
0
|
0
|
|
|
|
0
|
warn "Invalid byte order '${byteOrder}'\n" if $self->Options('Verbose'); |
5013
|
0
|
|
0
|
|
|
0
|
$byteOrder = $$self{MAKER_NOTE_BYTE_ORDER} || 'MM'; |
5014
|
0
|
|
|
|
|
0
|
SetByteOrder($byteOrder); |
5015
|
|
|
|
|
|
|
} |
5016
|
44
|
|
|
|
|
223
|
return GetByteOrder(); |
5017
|
|
|
|
|
|
|
} |
5018
|
|
|
|
|
|
|
|
5019
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
5020
|
|
|
|
|
|
|
# Assemble a continuing fraction into a rational value |
5021
|
|
|
|
|
|
|
# Inputs: 0) numerator, 1) denominator |
5022
|
|
|
|
|
|
|
# 2-N) list of fraction denominators, deepest first |
5023
|
|
|
|
|
|
|
# Returns: numerator, denominator (in list context) |
5024
|
|
|
|
|
|
|
sub AssembleRational($$@) |
5025
|
|
|
|
|
|
|
{ |
5026
|
4968
|
100
|
|
4968
|
0
|
10947
|
@_ < 3 and return @_; |
5027
|
3417
|
|
|
|
|
6033
|
my ($num, $denom, $frac) = splice(@_, 0, 3); |
5028
|
3417
|
|
|
|
|
6565
|
return AssembleRational($frac*$num+$denom, $num, @_); |
5029
|
|
|
|
|
|
|
} |
5030
|
|
|
|
|
|
|
|
5031
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
5032
|
|
|
|
|
|
|
# Convert a floating point number (or 'inf' or 'undef' or a fraction) into a rational |
5033
|
|
|
|
|
|
|
# Inputs: 0) floating point number, 1) optional maximum value (defaults to 0x7fffffff) |
5034
|
|
|
|
|
|
|
# Returns: numerator, denominator (in list context) |
5035
|
|
|
|
|
|
|
# Notes: |
5036
|
|
|
|
|
|
|
# - the returned rational will be accurate to at least 8 significant figures if possible |
5037
|
|
|
|
|
|
|
# - eg. an input of 3.14159265358979 returns a rational of 104348/33215, |
5038
|
|
|
|
|
|
|
# which equals 3.14159265392142 and is accurate to 10 significant figures |
5039
|
|
|
|
|
|
|
# - the returned rational will be reduced to the lowest common denominator except when |
5040
|
|
|
|
|
|
|
# the input is a fraction in which case the input is returned unchanged |
5041
|
|
|
|
|
|
|
# - these routines were a bit tricky, but fun to write! |
5042
|
|
|
|
|
|
|
sub Rationalize($;$) |
5043
|
|
|
|
|
|
|
{ |
5044
|
741
|
|
|
741
|
0
|
1747
|
my $val = shift; |
5045
|
741
|
50
|
|
|
|
1984
|
return (1, 0) if $val eq 'inf'; |
5046
|
741
|
50
|
|
|
|
1779
|
return (0, 0) if $val eq 'undef'; |
5047
|
741
|
100
|
|
|
|
2199
|
return ($1,$2) if $val =~ m{^([-+]?\d+)/(\d+)$}; # accept fractional values |
5048
|
|
|
|
|
|
|
# Note: Just testing "if $val" doesn't work because '0.0' is true! (ugghh!) |
5049
|
725
|
100
|
|
|
|
2459
|
return (0, 1) if $val == 0; |
5050
|
686
|
100
|
|
|
|
1755
|
my $sign = $val < 0 ? ($val = -$val, -1) : 1; |
5051
|
686
|
|
|
|
|
1244
|
my ($num, $denom, @fracs); |
5052
|
686
|
|
|
|
|
1218
|
my $frac = $val; |
5053
|
686
|
|
100
|
|
|
2171
|
my $maxInt = shift || 0x7fffffff; |
5054
|
686
|
|
|
|
|
1099
|
for (;;) { |
5055
|
1551
|
|
|
|
|
4284
|
my ($n, $d) = AssembleRational(int($frac + 0.5), 1, @fracs); |
5056
|
1551
|
50
|
33
|
|
|
5729
|
if ($n > $maxInt or $d > $maxInt) { |
5057
|
0
|
0
|
|
|
|
0
|
last if defined $num; |
5058
|
0
|
0
|
|
|
|
0
|
return ($sign, $maxInt) if $val < 1; |
5059
|
0
|
|
|
|
|
0
|
return ($sign * $maxInt, 1); |
5060
|
|
|
|
|
|
|
} |
5061
|
1551
|
|
|
|
|
3027
|
($num, $denom) = ($n, $d); # save last good values |
5062
|
1551
|
|
|
|
|
3288
|
my $err = ($n/$d-$val) / $val; # get error of this rational |
5063
|
1551
|
100
|
|
|
|
3684
|
last if abs($err) < 1e-8; # all done if error is small |
5064
|
865
|
|
|
|
|
1383
|
my $int = int($frac); |
5065
|
865
|
|
|
|
|
1660
|
unshift @fracs, $int; |
5066
|
865
|
50
|
|
|
|
1898
|
last unless $frac -= $int; |
5067
|
865
|
|
|
|
|
1552
|
$frac = 1 / $frac; |
5068
|
|
|
|
|
|
|
} |
5069
|
686
|
|
|
|
|
2632
|
return ($num * $sign, $denom); |
5070
|
|
|
|
|
|
|
} |
5071
|
|
|
|
|
|
|
|
5072
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
5073
|
|
|
|
|
|
|
# Utility routines to for writing binary data values |
5074
|
|
|
|
|
|
|
# Inputs: 0) value, 1) data ref, 2) offset |
5075
|
|
|
|
|
|
|
# Notes: prototype is (@) so values can be passed from list if desired |
5076
|
|
|
|
|
|
|
sub Set16s(@) |
5077
|
|
|
|
|
|
|
{ |
5078
|
188
|
|
|
188
|
0
|
334
|
my $val = shift; |
5079
|
188
|
100
|
|
|
|
473
|
$val < 0 and $val += 0x10000; |
5080
|
188
|
|
|
|
|
434
|
return Set16u($val, @_); |
5081
|
|
|
|
|
|
|
} |
5082
|
|
|
|
|
|
|
sub Set32s(@) |
5083
|
|
|
|
|
|
|
{ |
5084
|
69
|
|
|
69
|
0
|
618
|
my $val = shift; |
5085
|
69
|
100
|
|
|
|
227
|
$val < 0 and $val += 0xffffffff, ++$val; |
5086
|
69
|
|
|
|
|
235
|
return Set32u($val, @_); |
5087
|
|
|
|
|
|
|
} |
5088
|
|
|
|
|
|
|
sub Set64u(@) |
5089
|
|
|
|
|
|
|
{ |
5090
|
28
|
|
|
28
|
0
|
50
|
my $val = $_[0]; |
5091
|
28
|
|
|
|
|
65
|
my $hi = int($val / 4294967296); |
5092
|
28
|
|
|
|
|
72
|
my $lo = Set32u($val - $hi * 4294967296); |
5093
|
28
|
|
|
|
|
63
|
$hi = Set32u($hi); |
5094
|
28
|
100
|
|
|
|
74
|
$val = GetByteOrder() eq 'MM' ? $hi . $lo : $lo . $hi; |
5095
|
28
|
100
|
|
|
|
69
|
$_[1] and substr(${$_[1]}, $_[2], length($val)) = $val; |
|
27
|
|
|
|
|
74
|
|
5096
|
28
|
|
|
|
|
72
|
return $val; |
5097
|
|
|
|
|
|
|
} |
5098
|
|
|
|
|
|
|
sub Set64s(@) |
5099
|
|
|
|
|
|
|
{ |
5100
|
0
|
|
|
0
|
0
|
0
|
my $val = shift; |
5101
|
0
|
0
|
|
|
|
0
|
$val < 0 and $val += 4294967296 * 4294967296; # (temporary hack won't really work due to round-off errors) |
5102
|
0
|
|
|
|
|
0
|
return Set64u($val, @_); |
5103
|
|
|
|
|
|
|
} |
5104
|
|
|
|
|
|
|
sub SetRational64u(@) { |
5105
|
428
|
|
|
428
|
0
|
1551
|
my ($numer,$denom) = Rationalize($_[0],0xffffffff); |
5106
|
428
|
|
|
|
|
1313
|
my $val = Set32u($numer) . Set32u($denom); |
5107
|
428
|
50
|
|
|
|
1337
|
$_[1] and substr(${$_[1]}, $_[2], length($val)) = $val; |
|
0
|
|
|
|
|
0
|
|
5108
|
428
|
|
|
|
|
1565
|
return $val; |
5109
|
|
|
|
|
|
|
} |
5110
|
|
|
|
|
|
|
sub SetRational64s(@) { |
5111
|
44
|
|
|
44
|
0
|
265
|
my ($numer,$denom) = Rationalize($_[0]); |
5112
|
44
|
|
|
|
|
208
|
my $val = Set32s($numer) . Set32u($denom); |
5113
|
44
|
50
|
|
|
|
210
|
$_[1] and substr(${$_[1]}, $_[2], length($val)) = $val; |
|
0
|
|
|
|
|
0
|
|
5114
|
44
|
|
|
|
|
166
|
return $val; |
5115
|
|
|
|
|
|
|
} |
5116
|
|
|
|
|
|
|
sub SetRational32u(@) { |
5117
|
0
|
|
|
0
|
0
|
0
|
my ($numer,$denom) = Rationalize($_[0],0xffff); |
5118
|
0
|
|
|
|
|
0
|
my $val = Set16u($numer) . Set16u($denom); |
5119
|
0
|
0
|
|
|
|
0
|
$_[1] and substr(${$_[1]}, $_[2], length($val)) = $val; |
|
0
|
|
|
|
|
0
|
|
5120
|
0
|
|
|
|
|
0
|
return $val; |
5121
|
|
|
|
|
|
|
} |
5122
|
|
|
|
|
|
|
sub SetRational32s(@) { |
5123
|
0
|
|
|
0
|
0
|
0
|
my ($numer,$denom) = Rationalize($_[0],0x7fff); |
5124
|
0
|
|
|
|
|
0
|
my $val = Set16s($numer) . Set16u($denom); |
5125
|
0
|
0
|
|
|
|
0
|
$_[1] and substr(${$_[1]}, $_[2], length($val)) = $val; |
|
0
|
|
|
|
|
0
|
|
5126
|
0
|
|
|
|
|
0
|
return $val; |
5127
|
|
|
|
|
|
|
} |
5128
|
|
|
|
|
|
|
sub SetFixed16u(@) { |
5129
|
0
|
|
|
0
|
0
|
0
|
my $val = int(shift() * 0x100 + 0.5); |
5130
|
0
|
|
|
|
|
0
|
return Set16u($val, @_); |
5131
|
|
|
|
|
|
|
} |
5132
|
|
|
|
|
|
|
sub SetFixed16s(@) { |
5133
|
0
|
|
|
0
|
0
|
0
|
my $val = shift; |
5134
|
0
|
0
|
|
|
|
0
|
return Set16s(int($val * 0x100 + ($val < 0 ? -0.5 : 0.5)), @_); |
5135
|
|
|
|
|
|
|
} |
5136
|
|
|
|
|
|
|
sub SetFixed32u(@) { |
5137
|
0
|
|
|
0
|
0
|
0
|
my $val = int(shift() * 0x10000 + 0.5); |
5138
|
0
|
|
|
|
|
0
|
return Set32u($val, @_); |
5139
|
|
|
|
|
|
|
} |
5140
|
|
|
|
|
|
|
sub SetFixed32s(@) { |
5141
|
12
|
|
|
12
|
0
|
24
|
my $val = shift; |
5142
|
12
|
100
|
|
|
|
55
|
return Set32s(int($val * 0x10000 + ($val < 0 ? -0.5 : 0.5)), @_); |
5143
|
|
|
|
|
|
|
} |
5144
|
|
|
|
|
|
|
sub SetFloat(@) { |
5145
|
62
|
|
|
62
|
0
|
485
|
my $val = SwapBytes(pack('f',$_[0]), 4); |
5146
|
62
|
50
|
|
|
|
360
|
$_[1] and substr(${$_[1]}, $_[2], length($val)) = $val; |
|
0
|
|
|
|
|
0
|
|
5147
|
62
|
|
|
|
|
416
|
return $val; |
5148
|
|
|
|
|
|
|
} |
5149
|
|
|
|
|
|
|
sub SetDouble(@) { |
5150
|
|
|
|
|
|
|
# swap 32-bit words (ARM quirk) and bytes if necessary |
5151
|
64
|
|
|
64
|
0
|
500
|
my $val = SwapBytes(SwapWords(pack('d',$_[0])), 8); |
5152
|
64
|
50
|
|
|
|
339
|
$_[1] and substr(${$_[1]}, $_[2], length($val)) = $val; |
|
0
|
|
|
|
|
0
|
|
5153
|
64
|
|
|
|
|
435
|
return $val; |
5154
|
|
|
|
|
|
|
} |
5155
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
5156
|
|
|
|
|
|
|
# hash lookups for writing binary data values |
5157
|
|
|
|
|
|
|
my %writeValueProc = ( |
5158
|
|
|
|
|
|
|
int8s => \&Set8s, |
5159
|
|
|
|
|
|
|
int8u => \&Set8u, |
5160
|
|
|
|
|
|
|
int16s => \&Set16s, |
5161
|
|
|
|
|
|
|
int16u => \&Set16u, |
5162
|
|
|
|
|
|
|
int16uRev => \&Set16uRev, |
5163
|
|
|
|
|
|
|
int32s => \&Set32s, |
5164
|
|
|
|
|
|
|
int32u => \&Set32u, |
5165
|
|
|
|
|
|
|
int64s => \&Set64s, |
5166
|
|
|
|
|
|
|
int64u => \&Set64u, |
5167
|
|
|
|
|
|
|
rational32s => \&SetRational32s, |
5168
|
|
|
|
|
|
|
rational32u => \&SetRational32u, |
5169
|
|
|
|
|
|
|
rational64s => \&SetRational64s, |
5170
|
|
|
|
|
|
|
rational64u => \&SetRational64u, |
5171
|
|
|
|
|
|
|
fixed16u => \&SetFixed16u, |
5172
|
|
|
|
|
|
|
fixed16s => \&SetFixed16s, |
5173
|
|
|
|
|
|
|
fixed32u => \&SetFixed32u, |
5174
|
|
|
|
|
|
|
fixed32s => \&SetFixed32s, |
5175
|
|
|
|
|
|
|
float => \&SetFloat, |
5176
|
|
|
|
|
|
|
double => \&SetDouble, |
5177
|
|
|
|
|
|
|
ifd => \&Set32u, |
5178
|
|
|
|
|
|
|
); |
5179
|
|
|
|
|
|
|
# verify that we can write floats on this platform |
5180
|
|
|
|
|
|
|
{ |
5181
|
|
|
|
|
|
|
my %writeTest = ( |
5182
|
|
|
|
|
|
|
float => [ -3.14159, 'c0490fd0' ], |
5183
|
|
|
|
|
|
|
double => [ -3.14159, 'c00921f9f01b866e' ], |
5184
|
|
|
|
|
|
|
); |
5185
|
|
|
|
|
|
|
my $format; |
5186
|
|
|
|
|
|
|
my $oldOrder = GetByteOrder(); |
5187
|
|
|
|
|
|
|
SetByteOrder('MM'); |
5188
|
|
|
|
|
|
|
foreach $format (keys %writeTest) { |
5189
|
|
|
|
|
|
|
my ($val, $hex) = @{$writeTest{$format}}; |
5190
|
|
|
|
|
|
|
# add floating point entries if we can write them |
5191
|
|
|
|
|
|
|
next if unpack('H*', &{$writeValueProc{$format}}($val)) eq $hex; |
5192
|
|
|
|
|
|
|
delete $writeValueProc{$format}; # we can't write them |
5193
|
|
|
|
|
|
|
} |
5194
|
|
|
|
|
|
|
SetByteOrder($oldOrder); |
5195
|
|
|
|
|
|
|
} |
5196
|
|
|
|
|
|
|
|
5197
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
5198
|
|
|
|
|
|
|
# write binary data value (with current byte ordering) |
5199
|
|
|
|
|
|
|
# Inputs: 0) value, 1) format string |
5200
|
|
|
|
|
|
|
# 2) number of values: |
5201
|
|
|
|
|
|
|
# undef = 1 for numerical types, or data length for string/undef types |
5202
|
|
|
|
|
|
|
# -1 = number of space-delimited values in the input string |
5203
|
|
|
|
|
|
|
# 3) optional data reference, 4) value offset (may be negative for bytes from end) |
5204
|
|
|
|
|
|
|
# Returns: packed value (and sets value in data) or undef on error |
5205
|
|
|
|
|
|
|
# Notes: May modify input value to round for integer formats |
5206
|
|
|
|
|
|
|
sub WriteValue($$;$$$$) |
5207
|
|
|
|
|
|
|
{ |
5208
|
1598
|
|
|
1598
|
0
|
3871
|
my ($val, $format, $count, $dataPt, $offset) = @_; |
5209
|
1598
|
|
|
|
|
3930
|
my $proc = $writeValueProc{$format}; |
5210
|
1598
|
|
|
|
|
2470
|
my $packed; |
5211
|
|
|
|
|
|
|
|
5212
|
1598
|
100
|
66
|
|
|
4211
|
if ($proc) { |
|
|
50
|
|
|
|
|
|
5213
|
1238
|
|
|
|
|
4307
|
my @vals = split(' ',$val); |
5214
|
1238
|
100
|
|
|
|
2719
|
if ($count) { |
5215
|
662
|
100
|
|
|
|
1738
|
$count = @vals if $count < 0; |
5216
|
|
|
|
|
|
|
} else { |
5217
|
576
|
|
|
|
|
1076
|
$count = 1; # assume 1 if count not specified |
5218
|
|
|
|
|
|
|
} |
5219
|
1238
|
|
|
|
|
2166
|
$packed = ''; |
5220
|
1238
|
|
|
|
|
2746
|
while ($count--) { |
5221
|
1721
|
|
|
|
|
2951
|
$val = shift @vals; |
5222
|
1721
|
50
|
|
|
|
3687
|
return undef unless defined $val; |
5223
|
|
|
|
|
|
|
# validate numerical formats |
5224
|
1721
|
100
|
|
|
|
6647
|
if ($format =~ /^int/) { |
|
|
100
|
|
|
|
|
|
5225
|
1232
|
50
|
33
|
|
|
3455
|
unless (IsInt($val) or IsHex($val)) { |
5226
|
0
|
0
|
|
|
|
0
|
return undef unless IsFloat($val); |
5227
|
|
|
|
|
|
|
# round to nearest integer |
5228
|
0
|
0
|
|
|
|
0
|
$val = int($val + ($val < 0 ? -0.5 : 0.5)); |
5229
|
0
|
|
|
|
|
0
|
$_[0] = $val; |
5230
|
|
|
|
|
|
|
} |
5231
|
|
|
|
|
|
|
} elsif (not IsFloat($val)) { |
5232
|
7
|
50
|
33
|
|
|
132
|
return undef unless $format =~ /^rational/ and ($val eq 'inf' or |
|
|
|
33
|
|
|
|
|
5233
|
|
|
|
|
|
|
$val eq 'undef' or IsRational($val)); |
5234
|
|
|
|
|
|
|
} |
5235
|
1721
|
|
|
|
|
4804
|
$packed .= &$proc($val); |
5236
|
|
|
|
|
|
|
} |
5237
|
|
|
|
|
|
|
} elsif ($format eq 'string' or $format eq 'undef') { |
5238
|
360
|
100
|
|
|
|
1052
|
$format eq 'string' and $val .= "\0"; # null-terminate strings |
5239
|
360
|
100
|
66
|
|
|
1178
|
if ($count and $count > 0) { |
5240
|
61
|
|
|
|
|
174
|
my $diff = $count - length($val); |
5241
|
61
|
100
|
|
|
|
224
|
if ($diff) { |
5242
|
|
|
|
|
|
|
#warn "wrong string length!\n"; |
5243
|
|
|
|
|
|
|
# adjust length of string to match specified count |
5244
|
29
|
100
|
|
|
|
77
|
if ($diff < 0) { |
5245
|
22
|
50
|
|
|
|
63
|
if ($format eq 'string') { |
5246
|
22
|
50
|
|
|
|
58
|
return undef unless $count; |
5247
|
22
|
|
|
|
|
64
|
$val = substr($val, 0, $count - 1) . "\0"; |
5248
|
|
|
|
|
|
|
} else { |
5249
|
0
|
|
|
|
|
0
|
$val = substr($val, 0, $count); |
5250
|
|
|
|
|
|
|
} |
5251
|
|
|
|
|
|
|
} else { |
5252
|
7
|
|
|
|
|
25
|
$val .= "\0" x $diff; |
5253
|
|
|
|
|
|
|
} |
5254
|
|
|
|
|
|
|
} |
5255
|
|
|
|
|
|
|
} else { |
5256
|
299
|
|
|
|
|
541
|
$count = length($val); |
5257
|
|
|
|
|
|
|
} |
5258
|
360
|
100
|
|
|
|
855
|
$dataPt and substr($$dataPt, $offset, $count) = $val; |
5259
|
360
|
|
|
|
|
1154
|
return $val; |
5260
|
|
|
|
|
|
|
} else { |
5261
|
0
|
|
|
|
|
0
|
warn "Sorry, Can't write $format values on this platform\n"; |
5262
|
0
|
|
|
|
|
0
|
return undef; |
5263
|
|
|
|
|
|
|
} |
5264
|
1238
|
100
|
|
|
|
3234
|
$dataPt and substr($$dataPt, $offset, length($packed)) = $packed; |
5265
|
1238
|
|
|
|
|
3427
|
return $packed; |
5266
|
|
|
|
|
|
|
} |
5267
|
|
|
|
|
|
|
|
5268
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
5269
|
|
|
|
|
|
|
# Encode bit mask (the inverse of DecodeBits()) |
5270
|
|
|
|
|
|
|
# Inputs: 0) value to encode, 1) Reference to hash for encoding (or undef) |
5271
|
|
|
|
|
|
|
# 2) optional number of bits per word (defaults to 32), 3) total bits |
5272
|
|
|
|
|
|
|
# Returns: bit mask or undef on error (plus error string in list context) |
5273
|
|
|
|
|
|
|
sub EncodeBits($$;$$) |
5274
|
|
|
|
|
|
|
{ |
5275
|
104
|
|
|
104
|
0
|
309
|
my ($val, $lookup, $bits, $num) = @_; |
5276
|
104
|
100
|
|
|
|
328
|
$bits or $bits = 32; |
5277
|
104
|
100
|
|
|
|
352
|
$num or $num = $bits; |
5278
|
104
|
|
|
|
|
396
|
my $words = int(($num + $bits - 1) / $bits); |
5279
|
104
|
|
|
|
|
333
|
my @outVal = (0) x $words; |
5280
|
104
|
100
|
|
|
|
318
|
if ($val ne '(none)') { |
5281
|
85
|
|
|
|
|
370
|
my @vals = split /\s*,\s*/, $val; |
5282
|
85
|
|
|
|
|
256
|
foreach $val (@vals) { |
5283
|
42
|
|
|
|
|
160
|
my $bit; |
5284
|
42
|
50
|
|
|
|
113
|
if ($lookup) { |
5285
|
42
|
|
|
|
|
135
|
$bit = ReverseLookup($val, $lookup); |
5286
|
|
|
|
|
|
|
# (Note: may get non-numerical $bit values from Unknown() tags) |
5287
|
42
|
100
|
|
|
|
163
|
unless (defined $bit) { |
5288
|
33
|
50
|
|
|
|
130
|
if ($val =~ /\[(\d+)\]/) { # numerical bit specification |
5289
|
0
|
|
|
|
|
0
|
$bit = $1; |
5290
|
|
|
|
|
|
|
} else { |
5291
|
|
|
|
|
|
|
# don't return error string unless more than one value |
5292
|
33
|
100
|
66
|
|
|
249
|
return undef unless @vals > 1 and wantarray; |
5293
|
2
|
|
|
|
|
23
|
return (undef, "no match for '${val}'"); |
5294
|
|
|
|
|
|
|
} |
5295
|
|
|
|
|
|
|
} |
5296
|
|
|
|
|
|
|
} else { |
5297
|
0
|
|
|
|
|
0
|
$bit = $val; |
5298
|
|
|
|
|
|
|
} |
5299
|
9
|
50
|
33
|
|
|
61
|
unless (IsInt($bit) and $bit < $num) { |
5300
|
0
|
0
|
|
|
|
0
|
return undef unless wantarray; |
5301
|
0
|
0
|
|
|
|
0
|
return (undef, IsInt($bit) ? 'bit number too high' : 'not an integer'); |
5302
|
|
|
|
|
|
|
} |
5303
|
9
|
|
|
|
|
46
|
my $word = int($bit / $bits); |
5304
|
9
|
|
|
|
|
50
|
$outVal[$word] |= (1 << ($bit - $word * $bits)); |
5305
|
|
|
|
|
|
|
} |
5306
|
|
|
|
|
|
|
} |
5307
|
71
|
|
|
|
|
381
|
return "@outVal"; |
5308
|
|
|
|
|
|
|
} |
5309
|
|
|
|
|
|
|
|
5310
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
5311
|
|
|
|
|
|
|
# get current position in output file (or end of file if a scalar reference) |
5312
|
|
|
|
|
|
|
# Inputs: 0) file or scalar reference |
5313
|
|
|
|
|
|
|
# Returns: Current position or -1 on error |
5314
|
|
|
|
|
|
|
sub Tell($) |
5315
|
|
|
|
|
|
|
{ |
5316
|
325
|
|
|
325
|
0
|
757
|
my $outfile = shift; |
5317
|
325
|
100
|
|
|
|
1482
|
if (UNIVERSAL::isa($outfile,'GLOB')) { |
5318
|
296
|
|
|
|
|
2106
|
return tell($outfile); |
5319
|
|
|
|
|
|
|
} else { |
5320
|
29
|
|
|
|
|
168
|
return length($$outfile); |
5321
|
|
|
|
|
|
|
} |
5322
|
|
|
|
|
|
|
} |
5323
|
|
|
|
|
|
|
|
5324
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
5325
|
|
|
|
|
|
|
# write to file or memory |
5326
|
|
|
|
|
|
|
# Inputs: 0) file or scalar reference, 1-N) list of stuff to write |
5327
|
|
|
|
|
|
|
# Returns: true on success |
5328
|
|
|
|
|
|
|
sub Write($@) |
5329
|
|
|
|
|
|
|
{ |
5330
|
3736
|
|
|
3736
|
0
|
6592
|
my $outfile = shift; |
5331
|
3736
|
100
|
|
|
|
12327
|
if (UNIVERSAL::isa($outfile,'GLOB')) { |
|
|
50
|
|
|
|
|
|
5332
|
2311
|
|
|
|
|
19059
|
return print $outfile @_; |
5333
|
|
|
|
|
|
|
} elsif (ref $outfile eq 'SCALAR') { |
5334
|
1425
|
|
|
|
|
6291
|
$$outfile .= join('', @_); |
5335
|
1425
|
|
|
|
|
5360
|
return 1; |
5336
|
|
|
|
|
|
|
} |
5337
|
0
|
|
|
|
|
0
|
return 0; |
5338
|
|
|
|
|
|
|
} |
5339
|
|
|
|
|
|
|
|
5340
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
5341
|
|
|
|
|
|
|
# Write trailer buffer to file (applying fixups if necessary) |
5342
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object ref, 1) trailer dirInfo ref, 2) output file ref |
5343
|
|
|
|
|
|
|
# Returns: 1 on success |
5344
|
|
|
|
|
|
|
sub WriteTrailerBuffer($$$) |
5345
|
|
|
|
|
|
|
{ |
5346
|
12
|
|
|
12
|
0
|
48
|
my ($self, $trailInfo, $outfile) = @_; |
5347
|
12
|
50
|
|
|
|
67
|
if ($$self{DEL_GROUP}{Trailer}) { |
5348
|
0
|
|
|
|
|
0
|
$self->VPrint(0, " Deleting trailer ($$trailInfo{Offset} bytes)\n"); |
5349
|
0
|
|
|
|
|
0
|
++$$self{CHANGED}; |
5350
|
0
|
|
|
|
|
0
|
return 1; |
5351
|
|
|
|
|
|
|
} |
5352
|
12
|
|
|
|
|
50
|
my $pos = Tell($outfile); |
5353
|
12
|
|
|
|
|
41
|
my $trailPt = $$trailInfo{OutFile}; |
5354
|
|
|
|
|
|
|
# apply fixup if necessary (AFCP requires this) |
5355
|
12
|
100
|
|
|
|
70
|
if ($$trailInfo{Fixup}) { |
5356
|
8
|
50
|
|
|
|
31
|
if ($pos > 0) { |
5357
|
|
|
|
|
|
|
# shift offsets to final AFCP location and write it out |
5358
|
8
|
|
|
|
|
23
|
$$trailInfo{Fixup}{Shift} += $pos; |
5359
|
8
|
|
|
|
|
40
|
$$trailInfo{Fixup}->ApplyFixup($trailPt); |
5360
|
|
|
|
|
|
|
} else { |
5361
|
0
|
|
|
|
|
0
|
$self->Error("Can't get file position for trailer offset fixup",1); |
5362
|
|
|
|
|
|
|
} |
5363
|
|
|
|
|
|
|
} |
5364
|
12
|
|
|
|
|
82
|
return Write($outfile, $$trailPt); |
5365
|
|
|
|
|
|
|
} |
5366
|
|
|
|
|
|
|
|
5367
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
5368
|
|
|
|
|
|
|
# Add trailers as a block |
5369
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object ref, 1) [optional] trailer data raf, |
5370
|
|
|
|
|
|
|
# 1 or 2-N) trailer types to add (or none to add all) |
5371
|
|
|
|
|
|
|
# Returns: new trailer ref, or undef |
5372
|
|
|
|
|
|
|
# - increments CHANGED if trailer was added |
5373
|
|
|
|
|
|
|
sub AddNewTrailers($;@) |
5374
|
|
|
|
|
|
|
{ |
5375
|
130
|
|
|
130
|
0
|
485
|
my ($self, @types) = @_; |
5376
|
130
|
|
|
|
|
265
|
my $trailPt; |
5377
|
130
|
100
|
|
|
|
486
|
ref $types[0] and $trailPt = shift @types; |
5378
|
130
|
100
|
|
|
|
505
|
$types[0] or shift @types; # (in case undef data ref is passed) |
5379
|
|
|
|
|
|
|
# add all possible trailers if none specified (currently only CanonVRD) |
5380
|
130
|
100
|
|
|
|
661
|
@types or @types = qw(CanonVRD CanonDR4); |
5381
|
|
|
|
|
|
|
# add trailers as a block (if not done already) |
5382
|
130
|
|
|
|
|
317
|
my $type; |
5383
|
130
|
|
|
|
|
473
|
foreach $type (@types) { |
5384
|
253
|
100
|
|
|
|
1406
|
next unless $$self{NEW_VALUE}{$Image::ExifTool::Extra{$type}}; |
5385
|
10
|
100
|
|
|
|
64
|
next if $$self{"Did$type"}; |
5386
|
9
|
100
|
|
|
|
78
|
my $val = $self->GetNewValue($type) or next; |
5387
|
|
|
|
|
|
|
# DR4 record must be wrapped in VRD trailer package |
5388
|
8
|
100
|
|
|
|
46
|
if ($type eq 'CanonDR4') { |
5389
|
3
|
100
|
|
|
|
17
|
next if $$self{DidCanonVRD}; # (only allow one VRD trailer) |
5390
|
2
|
|
|
|
|
23
|
require Image::ExifTool::CanonVRD; |
5391
|
2
|
|
|
|
|
380
|
$val = Image::ExifTool::CanonVRD::WrapDR4($val); |
5392
|
2
|
|
|
|
|
8
|
$$self{DidCanonVRD} = 1; |
5393
|
|
|
|
|
|
|
} |
5394
|
7
|
50
|
|
|
|
45
|
my $verb = $trailPt ? 'Writing' : 'Adding'; |
5395
|
7
|
|
|
|
|
62
|
$self->VPrint(0, " $verb $type as a block\n"); |
5396
|
7
|
50
|
|
|
|
42
|
if ($trailPt) { |
5397
|
0
|
|
|
|
|
0
|
$$trailPt .= $val; |
5398
|
|
|
|
|
|
|
} else { |
5399
|
7
|
|
|
|
|
21
|
$trailPt = \$val; |
5400
|
|
|
|
|
|
|
} |
5401
|
7
|
|
|
|
|
30
|
$$self{"Did$type"} = 1; |
5402
|
7
|
|
|
|
|
26
|
++$$self{CHANGED}; |
5403
|
|
|
|
|
|
|
} |
5404
|
130
|
|
|
|
|
501
|
return $trailPt; |
5405
|
|
|
|
|
|
|
} |
5406
|
|
|
|
|
|
|
|
5407
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
5408
|
|
|
|
|
|
|
# Write segment, splitting up into multiple segments if necessary |
5409
|
|
|
|
|
|
|
# Inputs: 0) file or scalar reference, 1) segment marker |
5410
|
|
|
|
|
|
|
# 2) segment header, 3) segment data ref, 4) segment type |
5411
|
|
|
|
|
|
|
# Returns: number of segments written, or 0 on error |
5412
|
|
|
|
|
|
|
# Notes: Writes a single empty segment if data is empty |
5413
|
|
|
|
|
|
|
sub WriteMultiSegment($$$$;$) |
5414
|
|
|
|
|
|
|
{ |
5415
|
110
|
|
|
110
|
0
|
487
|
my ($outfile, $marker, $header, $dataPt, $type) = @_; |
5416
|
110
|
100
|
|
|
|
474
|
$type or $type = ''; |
5417
|
110
|
|
|
|
|
349
|
my $len = length($$dataPt); |
5418
|
110
|
|
|
|
|
439
|
my $hdr = "\xff" . chr($marker); |
5419
|
110
|
|
|
|
|
230
|
my $count = 0; |
5420
|
110
|
|
|
|
|
296
|
my $maxLen = $maxSegmentLen - length($header); |
5421
|
110
|
100
|
|
|
|
442
|
$maxLen -= 2 if $type eq 'ICC'; # leave room for segment counters |
5422
|
110
|
|
|
|
|
475
|
my $num = int(($len + $maxLen - 1) / $maxLen); # number of segments to write |
5423
|
110
|
|
|
|
|
233
|
my $n = 0; |
5424
|
|
|
|
|
|
|
# write data, splitting into multiple segments if necessary |
5425
|
|
|
|
|
|
|
# (each segment gets its own header) |
5426
|
110
|
|
|
|
|
275
|
for (;;) { |
5427
|
110
|
|
|
|
|
236
|
++$count; |
5428
|
110
|
|
|
|
|
291
|
my $size = $len - $n; |
5429
|
110
|
50
|
|
|
|
431
|
if ($size > $maxLen) { |
5430
|
0
|
|
|
|
|
0
|
$size = $maxLen; |
5431
|
|
|
|
|
|
|
# avoid starting an Extended EXIF segment with a valid TIFF header |
5432
|
|
|
|
|
|
|
# (because we would interpret that as a separate EXIF segment) |
5433
|
0
|
0
|
0
|
|
|
0
|
--$size if $type eq 'EXIF' and $n+$maxLen <= $len-4 and |
|
|
|
0
|
|
|
|
|
5434
|
|
|
|
|
|
|
substr($$dataPt, $n+$maxLen, 4) =~ /^(MM\0\x2a|II\x2a\0)/; |
5435
|
|
|
|
|
|
|
} |
5436
|
110
|
|
|
|
|
662
|
my $buff = substr($$dataPt,$n,$size); |
5437
|
110
|
|
|
|
|
253
|
$n += $size; |
5438
|
110
|
|
|
|
|
286
|
$size += length($header); |
5439
|
110
|
100
|
|
|
|
409
|
if ($type eq 'ICC') { |
5440
|
3
|
|
|
|
|
22
|
$buff = pack('CC', $count, $num) . $buff; |
5441
|
3
|
|
|
|
|
10
|
$size += 2; |
5442
|
|
|
|
|
|
|
} |
5443
|
|
|
|
|
|
|
# write the new segment with appropriate header |
5444
|
110
|
|
|
|
|
557
|
my $segHdr = $hdr . pack('n', $size + 2); |
5445
|
110
|
50
|
|
|
|
431
|
Write($outfile, $segHdr, $header, $buff) or return 0; |
5446
|
110
|
50
|
|
|
|
539
|
last if $n >= $len; |
5447
|
|
|
|
|
|
|
} |
5448
|
110
|
|
|
|
|
464
|
return $count; |
5449
|
|
|
|
|
|
|
} |
5450
|
|
|
|
|
|
|
|
5451
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
5452
|
|
|
|
|
|
|
# Write XMP segment(s) to JPEG file |
5453
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object ref, 1) outfile ref, 2) XMP data ref, |
5454
|
|
|
|
|
|
|
# 3) extended XMP data ref, 4) 32-char extended XMP GUID (or undef if no extended data) |
5455
|
|
|
|
|
|
|
# Returns: true on success, false on write error |
5456
|
|
|
|
|
|
|
sub WriteMultiXMP($$$$$) |
5457
|
|
|
|
|
|
|
{ |
5458
|
34
|
|
|
34
|
0
|
180
|
my ($self, $outfile, $dataPt, $extPt, $guid) = @_; |
5459
|
34
|
|
|
|
|
94
|
my $success = 1; |
5460
|
|
|
|
|
|
|
|
5461
|
|
|
|
|
|
|
# write main XMP segment |
5462
|
34
|
|
|
|
|
131
|
my $size = length($$dataPt) + length($xmpAPP1hdr); |
5463
|
34
|
50
|
|
|
|
141
|
if ($size > $maxXMPLen) { |
5464
|
0
|
|
|
|
|
0
|
$self->Error("XMP block too large for JPEG segment! ($size bytes)", 1); |
5465
|
0
|
|
|
|
|
0
|
return 1; |
5466
|
|
|
|
|
|
|
} |
5467
|
34
|
|
|
|
|
210
|
my $app1hdr = "\xff\xe1" . pack('n', $size + 2); |
5468
|
34
|
50
|
|
|
|
169
|
Write($outfile, $app1hdr, $xmpAPP1hdr, $$dataPt) or $success = 0; |
5469
|
|
|
|
|
|
|
# write extended XMP segment(s) if necessary |
5470
|
34
|
50
|
|
|
|
206
|
if (defined $guid) { |
5471
|
0
|
|
|
|
|
0
|
$size = length($$extPt); |
5472
|
0
|
|
|
|
|
0
|
my $maxLen = $maxXMPLen - 75; # maximum size without 75-byte header |
5473
|
0
|
|
|
|
|
0
|
my $off; |
5474
|
0
|
|
|
|
|
0
|
for ($off=0; $off<$size; $off+=$maxLen) { |
5475
|
|
|
|
|
|
|
# header(75) = signature(35) + guid(32) + size(4) + offset(4) |
5476
|
0
|
|
|
|
|
0
|
my $len = $size - $off; |
5477
|
0
|
0
|
|
|
|
0
|
$len = $maxLen if $len > $maxLen; |
5478
|
0
|
|
|
|
|
0
|
$app1hdr = "\xff\xe1" . pack('n', $len + 75 + 2); |
5479
|
0
|
|
|
|
|
0
|
$self->VPrint(0, "Writing extended XMP segment ($len bytes)\n"); |
5480
|
0
|
0
|
|
|
|
0
|
Write($outfile, $app1hdr, $xmpExtAPP1hdr, $guid, pack('N2', $size, $off), |
5481
|
|
|
|
|
|
|
substr($$extPt, $off, $len)) or $success = 0; |
5482
|
|
|
|
|
|
|
} |
5483
|
|
|
|
|
|
|
} |
5484
|
34
|
|
|
|
|
194
|
return $success; |
5485
|
|
|
|
|
|
|
} |
5486
|
|
|
|
|
|
|
|
5487
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
5488
|
|
|
|
|
|
|
# WriteJPEG : Write JPEG image |
5489
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object reference, 1) dirInfo reference |
5490
|
|
|
|
|
|
|
# Returns: 1 on success, 0 if this wasn't a valid JPEG file, or -1 if |
5491
|
|
|
|
|
|
|
# an output file was specified and a write error occurred |
5492
|
|
|
|
|
|
|
sub WriteJPEG($$) |
5493
|
|
|
|
|
|
|
{ |
5494
|
111
|
|
|
111
|
0
|
462
|
my ($self, $dirInfo) = @_; |
5495
|
111
|
|
|
|
|
403
|
my $outfile = $$dirInfo{OutFile}; |
5496
|
111
|
|
|
|
|
429
|
my $raf = $$dirInfo{RAF}; |
5497
|
111
|
|
|
|
|
356
|
my ($ch, $s, $length,$err, %doneDir, $isEXV, $creatingEXV); |
5498
|
111
|
|
|
|
|
318
|
my $verbose = $$self{OPTIONS}{Verbose}; |
5499
|
111
|
|
|
|
|
398
|
my $out = $$self{OPTIONS}{TextOut}; |
5500
|
111
|
|
|
|
|
302
|
my $rtnVal = 0; |
5501
|
111
|
|
|
|
|
377
|
my ($writeBuffer, $oldOutfile); # used to buffer writing until PreviewImage position is known |
5502
|
|
|
|
|
|
|
|
5503
|
|
|
|
|
|
|
# check to be sure this is a valid JPG or EXV file |
5504
|
111
|
100
|
100
|
|
|
696
|
unless ($raf->Read($s,2) == 2 and $s eq "\xff\xd8") { |
5505
|
2
|
100
|
66
|
|
|
15
|
if (defined $s and length $s) { |
5506
|
1
|
50
|
33
|
|
|
14
|
return 0 unless $s eq "\xff\x01" and $raf->Read($s,5) == 5 and $s eq 'Exiv2'; |
|
|
|
33
|
|
|
|
|
5507
|
|
|
|
|
|
|
} else { |
5508
|
1
|
50
|
|
|
|
9
|
return 0 unless $$self{FILE_TYPE} eq 'EXV'; |
5509
|
1
|
|
|
|
|
5
|
$s = 'Exiv2'; |
5510
|
1
|
|
|
|
|
4
|
$creatingEXV = 1; |
5511
|
|
|
|
|
|
|
} |
5512
|
2
|
50
|
|
|
|
8
|
Write($outfile,"\xff\x01") or $err = 1; |
5513
|
2
|
|
|
|
|
10
|
$isEXV = 1; |
5514
|
|
|
|
|
|
|
} |
5515
|
|
|
|
|
|
|
|
5516
|
111
|
|
|
|
|
445
|
delete $$self{PREVIEW_INFO}; # reset preview information |
5517
|
111
|
|
|
|
|
323
|
delete $$self{DEL_PREVIEW}; # reset flag to delete preview |
5518
|
|
|
|
|
|
|
|
5519
|
111
|
50
|
|
|
|
612
|
Write($outfile, $s) or $err = 1; |
5520
|
|
|
|
|
|
|
# figure out what segments we need to write for the tags we have set |
5521
|
111
|
|
|
|
|
579
|
my $addDirs = $$self{ADD_DIRS}; |
5522
|
111
|
|
|
|
|
336
|
my $editDirs = $$self{EDIT_DIRS}; |
5523
|
111
|
|
|
|
|
436
|
my $delGroup = $$self{DEL_GROUP}; |
5524
|
111
|
|
|
|
|
341
|
my $path = $$self{PATH}; |
5525
|
111
|
|
|
|
|
314
|
my $pn = scalar @$path; |
5526
|
|
|
|
|
|
|
|
5527
|
|
|
|
|
|
|
# set input record separator to 0xff (the JPEG marker) to make reading quicker |
5528
|
111
|
|
|
|
|
802
|
local $/ = "\xff"; |
5529
|
|
|
|
|
|
|
# |
5530
|
|
|
|
|
|
|
# pre-scan image to determine if any create-able segment already exists |
5531
|
|
|
|
|
|
|
# |
5532
|
111
|
|
|
|
|
597
|
my $pos = $raf->Tell(); |
5533
|
111
|
|
|
|
|
452
|
my ($marker, @dirOrder, %dirCount); |
5534
|
111
|
|
|
|
|
330
|
Prescan: for (;;) { |
5535
|
|
|
|
|
|
|
# read up to next marker (JPEG markers begin with 0xff) |
5536
|
796
|
100
|
|
|
|
2740
|
$raf->ReadLine($s) or last; |
5537
|
|
|
|
|
|
|
# JPEG markers can be padded with unlimited 0xff's |
5538
|
795
|
|
|
|
|
1607
|
for (;;) { |
5539
|
795
|
50
|
|
|
|
2563
|
$raf->Read($ch, 1) or last Prescan; |
5540
|
795
|
|
|
|
|
1609
|
$marker = ord($ch); |
5541
|
795
|
50
|
|
|
|
2031
|
last unless $marker == 0xff; |
5542
|
|
|
|
|
|
|
} |
5543
|
795
|
|
|
|
|
1815
|
my $dirName; |
5544
|
|
|
|
|
|
|
# stop pre-scan at SOS (end of meta information) or EOI (end of image) |
5545
|
795
|
100
|
100
|
|
|
3143
|
if ($marker == 0xda or $marker == 0xd9) { |
5546
|
110
|
|
|
|
|
688
|
$dirName = $jpegMarker{$marker}; |
5547
|
110
|
|
|
|
|
420
|
push(@dirOrder, $dirName); |
5548
|
110
|
|
|
|
|
365
|
$dirCount{$dirName} = 1; |
5549
|
110
|
|
|
|
|
342
|
last; |
5550
|
|
|
|
|
|
|
} |
5551
|
|
|
|
|
|
|
# handle SOF markers: SOF0-SOF15, except DHT(0xc4), JPGA(0xc8) and DAC(0xcc) |
5552
|
685
|
100
|
66
|
|
|
5855
|
if (($marker & 0xf0) == 0xc0 and ($marker == 0xc0 or $marker & 0x03)) { |
|
|
50
|
100
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
|
33
|
|
|
|
|
5553
|
109
|
50
|
|
|
|
483
|
last unless $raf->Seek(7, 1); |
5554
|
|
|
|
|
|
|
# read data for all markers except stand-alone |
5555
|
|
|
|
|
|
|
# markers 0x00, 0x01 and 0xd0-0xd7 (NULL, TEM, RST0-RST7) |
5556
|
|
|
|
|
|
|
} elsif ($marker!=0x00 and $marker!=0x01 and ($marker<0xd0 or $marker>0xd7)) { |
5557
|
|
|
|
|
|
|
# read record length word |
5558
|
576
|
50
|
|
|
|
1563
|
last unless $raf->Read($s, 2) == 2; |
5559
|
576
|
|
|
|
|
2104
|
my $len = unpack('n',$s); # get data length |
5560
|
576
|
50
|
33
|
|
|
2491
|
last unless defined($len) and $len >= 2; |
5561
|
576
|
|
|
|
|
998
|
$len -= 2; # subtract size of length word |
5562
|
576
|
100
|
|
|
|
1406
|
if (($marker & 0xf0) == 0xe0) { # is this an APP segment? |
5563
|
347
|
100
|
|
|
|
1230
|
my $n = $len < 64 ? $len : 64; |
5564
|
347
|
50
|
|
|
|
995
|
$raf->Read($s, $n) == $n or last; |
5565
|
347
|
|
|
|
|
1263
|
$len -= $n; |
5566
|
|
|
|
|
|
|
# Note: only necessary to recognize APP segments that we can create, |
5567
|
|
|
|
|
|
|
# or delete as a group (and the names below should match @delGroups) |
5568
|
347
|
100
|
|
|
|
1941
|
if ($marker == 0xe0) { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
5569
|
45
|
100
|
|
|
|
268
|
$s =~ /^JFIF\0/ and $dirName = 'JFIF'; |
5570
|
45
|
100
|
|
|
|
224
|
$s =~ /^JFXX\0\x10/ and $dirName = 'JFXX'; |
5571
|
45
|
100
|
|
|
|
237
|
$s =~ /^(II|MM).{4}HEAPJPGM/s and $dirName = 'CIFF'; |
5572
|
|
|
|
|
|
|
} elsif ($marker == 0xe1) { |
5573
|
84
|
100
|
|
|
|
688
|
if ($s =~ /^(.{0,4})Exif\0.(.{1,4})/is) { |
5574
|
60
|
|
|
|
|
220
|
$dirName = 'IFD0'; |
5575
|
60
|
|
|
|
|
381
|
my ($junk, $bytes) = ($1, $2); |
5576
|
|
|
|
|
|
|
# support multi-segment EXIF |
5577
|
60
|
0
|
66
|
|
|
929
|
if (@dirOrder and $dirOrder[-1] =~ /^(IFD0|ExtendedEXIF)$/ and |
|
|
|
33
|
|
|
|
|
|
|
|
33
|
|
|
|
|
5578
|
|
|
|
|
|
|
not length $junk and $bytes !~ /^(MM\0\x2a|II\x2a\0)/) |
5579
|
|
|
|
|
|
|
{ |
5580
|
0
|
|
|
|
|
0
|
$dirName = 'ExtendedEXIF'; |
5581
|
|
|
|
|
|
|
} |
5582
|
|
|
|
|
|
|
} |
5583
|
84
|
100
|
|
|
|
1082
|
$s =~ /^$xmpAPP1hdr/ and $dirName = 'XMP'; |
5584
|
84
|
100
|
|
|
|
886
|
$s =~ /^$xmpExtAPP1hdr/ and $dirName = 'XMP'; |
5585
|
|
|
|
|
|
|
} elsif ($marker == 0xe2) { |
5586
|
55
|
100
|
|
|
|
298
|
$s =~ /^ICC_PROFILE\0/ and $dirName = 'ICC_Profile'; |
5587
|
55
|
100
|
|
|
|
258
|
$s =~ /^FPXR\0/ and $dirName = 'FlashPix'; |
5588
|
55
|
100
|
|
|
|
204
|
$s =~ /^MPF\0/ and $dirName = 'MPF'; |
5589
|
|
|
|
|
|
|
} elsif ($marker == 0xe3) { |
5590
|
9
|
50
|
|
|
|
146
|
$s =~ /^(Meta|META|Exif)\0\0/ and $dirName = 'Meta'; |
5591
|
|
|
|
|
|
|
} elsif ($marker == 0xe5) { |
5592
|
9
|
50
|
|
|
|
97
|
$s =~ /^RMETA\0/ and $dirName = 'RMETA'; |
5593
|
|
|
|
|
|
|
} elsif ($marker == 0xec) { |
5594
|
19
|
100
|
|
|
|
204
|
$s =~ /^Ducky/ and $dirName = 'Ducky'; |
5595
|
|
|
|
|
|
|
} elsif ($marker == 0xed) { |
5596
|
29
|
100
|
|
|
|
454
|
$s =~ /^$psAPP13hdr/ and $dirName = 'Photoshop'; |
5597
|
|
|
|
|
|
|
} elsif ($marker == 0xee) { |
5598
|
16
|
50
|
|
|
|
139
|
$s =~ /^Adobe/ and $dirName = 'Adobe'; |
5599
|
|
|
|
|
|
|
} |
5600
|
|
|
|
|
|
|
# initialize doneDir as a flag that the directory exists |
5601
|
|
|
|
|
|
|
# (unless we are deleting it anyway) |
5602
|
347
|
100
|
100
|
|
|
2734
|
$doneDir{$dirName} = 0 if defined $dirName and not $$delGroup{$dirName}; |
5603
|
|
|
|
|
|
|
} |
5604
|
576
|
50
|
|
|
|
1788
|
$raf->Seek($len, 1) or last; |
5605
|
|
|
|
|
|
|
} |
5606
|
685
|
100
|
|
|
|
3251
|
$dirName or $dirName = JpegMarkerName($marker); |
5607
|
685
|
|
100
|
|
|
3463
|
$dirCount{$dirName} = ($dirCount{$dirName} || 0) + 1; |
5608
|
685
|
|
|
|
|
1807
|
push @dirOrder, $dirName; |
5609
|
|
|
|
|
|
|
} |
5610
|
111
|
100
|
100
|
|
|
814
|
unless ($marker and $marker == 0xda) { |
5611
|
2
|
50
|
|
|
|
10
|
$isEXV or $self->Error('Corrupted JPEG image'), return 1; |
5612
|
2
|
50
|
66
|
|
|
16
|
$marker and $marker != 0xd9 and $self->Error('Corrupted EXV file'), return 1; |
5613
|
|
|
|
|
|
|
} |
5614
|
111
|
50
|
|
|
|
1004
|
$raf->Seek($pos, 0) or $self->Error('Seek error'), return 1; |
5615
|
|
|
|
|
|
|
# |
5616
|
|
|
|
|
|
|
# re-write the image |
5617
|
|
|
|
|
|
|
# |
5618
|
111
|
|
|
|
|
1075
|
my ($combinedSegData, $segPos, $firstSegPos, %extendedXMP); |
5619
|
111
|
|
|
|
|
0
|
my (@iccChunk, $iccChunkCount, $iccChunksTotal); |
5620
|
|
|
|
|
|
|
# read through each segment in the JPEG file |
5621
|
111
|
|
|
|
|
255
|
Marker: for (;;) { |
5622
|
|
|
|
|
|
|
|
5623
|
|
|
|
|
|
|
# read up to next marker (JPEG markers begin with 0xff) |
5624
|
796
|
|
|
|
|
1736
|
my $segJunk; |
5625
|
796
|
100
|
|
|
|
2930
|
$raf->ReadLine($segJunk) or $segJunk = ''; |
5626
|
|
|
|
|
|
|
# remove the 0xff but write the rest of the junk up to this point |
5627
|
|
|
|
|
|
|
# (this will handle the data after the first 7 bytes of SOF segments) |
5628
|
796
|
|
|
|
|
2147
|
chomp($segJunk); |
5629
|
796
|
100
|
|
|
|
2232
|
Write($outfile, $segJunk) if length $segJunk; |
5630
|
|
|
|
|
|
|
# JPEG markers can be padded with unlimited 0xff's |
5631
|
796
|
|
|
|
|
1295
|
for (;;) { |
5632
|
796
|
100
|
|
|
|
2460
|
if ($raf->Read($ch, 1)) { |
|
|
50
|
|
|
|
|
|
5633
|
795
|
|
|
|
|
1657
|
$marker = ord($ch); |
5634
|
795
|
50
|
|
|
|
2189
|
last unless $marker == 0xff; |
5635
|
|
|
|
|
|
|
} elsif ($creatingEXV) { |
5636
|
|
|
|
|
|
|
# create EXV from scratch |
5637
|
1
|
|
|
|
|
4
|
$marker = 0xd9; # EOI |
5638
|
1
|
|
|
|
|
4
|
push @dirOrder, 'EOI'; |
5639
|
1
|
|
|
|
|
7
|
$dirCount{EOI} = 1; |
5640
|
1
|
|
|
|
|
4
|
last; |
5641
|
|
|
|
|
|
|
} else { |
5642
|
0
|
|
|
|
|
0
|
$self->Error('Format error'); |
5643
|
0
|
|
|
|
|
0
|
return 1; |
5644
|
|
|
|
|
|
|
} |
5645
|
|
|
|
|
|
|
} |
5646
|
|
|
|
|
|
|
# read the segment data |
5647
|
796
|
|
|
|
|
1442
|
my $segData; |
5648
|
|
|
|
|
|
|
# handle SOF markers: SOF0-SOF15, except DHT(0xc4), JPGA(0xc8) and DAC(0xcc) |
5649
|
796
|
100
|
66
|
|
|
8631
|
if (($marker & 0xf0) == 0xc0 and ($marker == 0xc0 or $marker & 0x03)) { |
|
|
100
|
100
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
|
66
|
|
|
|
|
5650
|
109
|
50
|
|
|
|
479
|
last unless $raf->Read($segData, 7) == 7; |
5651
|
|
|
|
|
|
|
# read data for all markers except stand-alone |
5652
|
|
|
|
|
|
|
# markers 0x00, 0x01 and 0xd0-0xd7 (NULL, TEM, EOI, RST0-RST7) |
5653
|
|
|
|
|
|
|
} elsif ($marker!=0x00 and $marker!=0x01 and $marker!=0xd9 and |
5654
|
|
|
|
|
|
|
($marker<0xd0 or $marker>0xd7)) |
5655
|
|
|
|
|
|
|
{ |
5656
|
|
|
|
|
|
|
# read record length word |
5657
|
685
|
50
|
|
|
|
1912
|
last unless $raf->Read($s, 2) == 2; |
5658
|
685
|
|
|
|
|
2184
|
my $len = unpack('n',$s); # get data length |
5659
|
685
|
50
|
33
|
|
|
3152
|
last unless defined($len) and $len >= 2; |
5660
|
685
|
|
|
|
|
2032
|
$segPos = $raf->Tell(); |
5661
|
685
|
|
|
|
|
1392
|
$len -= 2; # subtract size of length word |
5662
|
685
|
50
|
|
|
|
1765
|
last unless $raf->Read($segData, $len) == $len; |
5663
|
|
|
|
|
|
|
} |
5664
|
|
|
|
|
|
|
# initialize variables for this segment |
5665
|
796
|
|
|
|
|
2656
|
my $hdr = "\xff" . chr($marker); # segment header |
5666
|
796
|
|
|
|
|
2355
|
my $markerName = JpegMarkerName($marker); |
5667
|
796
|
|
|
|
|
2074
|
my $dirName = shift @dirOrder; # get directory name |
5668
|
|
|
|
|
|
|
# |
5669
|
|
|
|
|
|
|
# create all segments that must come before this one |
5670
|
|
|
|
|
|
|
# (nothing comes before SOI or after SOS) |
5671
|
|
|
|
|
|
|
# |
5672
|
796
|
|
|
|
|
2512
|
while ($markerName ne 'SOI') { |
5673
|
796
|
100
|
100
|
|
|
2783
|
if (exists $$addDirs{JFIF} and not defined $doneDir{JFIF}) { |
5674
|
1
|
|
|
|
|
4
|
$doneDir{JFIF} = 1; |
5675
|
1
|
50
|
|
|
|
4
|
if (defined $doneDir{Adobe}) { |
5676
|
|
|
|
|
|
|
# JFIF overrides Adobe APP14 colour components, so don't allow this |
5677
|
|
|
|
|
|
|
# (ref https://docs.oracle.com/javase/8/docs/api/javax/imageio/metadata/doc-files/jpeg_metadata.html) |
5678
|
1
|
|
|
|
|
6
|
$self->Warn('Not creating JFIF in JPEG with Adobe APP14'); |
5679
|
|
|
|
|
|
|
} else { |
5680
|
0
|
0
|
|
|
|
0
|
if ($verbose) { |
5681
|
0
|
|
|
|
|
0
|
print $out "Creating APP0:\n"; |
5682
|
0
|
|
|
|
|
0
|
print $out " Creating JFIF with default values\n"; |
5683
|
|
|
|
|
|
|
} |
5684
|
0
|
|
|
|
|
0
|
my $jfif = "\x01\x02\x01\0\x48\0\x48\0\0"; |
5685
|
0
|
|
|
|
|
0
|
SetByteOrder('MM'); |
5686
|
0
|
|
|
|
|
0
|
my $tagTablePtr = GetTagTable('Image::ExifTool::JFIF::Main'); |
5687
|
0
|
|
|
|
|
0
|
my %dirInfo = ( |
5688
|
|
|
|
|
|
|
DataPt => \$jfif, |
5689
|
|
|
|
|
|
|
DirStart => 0, |
5690
|
|
|
|
|
|
|
DirLen => length $jfif, |
5691
|
|
|
|
|
|
|
Parent => 'JFIF', |
5692
|
|
|
|
|
|
|
); |
5693
|
|
|
|
|
|
|
# must temporarily remove JFIF from DEL_GROUP so we can |
5694
|
|
|
|
|
|
|
# delete JFIF and add it back again in a single step |
5695
|
0
|
|
|
|
|
0
|
my $delJFIF = $$delGroup{JFIF}; |
5696
|
0
|
|
|
|
|
0
|
delete $$delGroup{JFIF}; |
5697
|
0
|
|
|
|
|
0
|
$$path[$pn] = 'JFIF'; |
5698
|
0
|
|
|
|
|
0
|
my $newData = $self->WriteDirectory(\%dirInfo, $tagTablePtr); |
5699
|
0
|
0
|
|
|
|
0
|
$$delGroup{JFIF} = $delJFIF if defined $delJFIF; |
5700
|
0
|
0
|
0
|
|
|
0
|
if (defined $newData and length $newData) { |
5701
|
0
|
|
|
|
|
0
|
my $app0hdr = "\xff\xe0" . pack('n', length($newData) + 7); |
5702
|
0
|
0
|
|
|
|
0
|
Write($outfile,$app0hdr,"JFIF\0",$newData) or $err = 1; |
5703
|
|
|
|
|
|
|
} |
5704
|
|
|
|
|
|
|
} |
5705
|
|
|
|
|
|
|
} |
5706
|
|
|
|
|
|
|
# don't create anything before APP0 or APP1 EXIF (containing IFD0) |
5707
|
796
|
100
|
100
|
|
|
5169
|
last if $markerName eq 'APP0' or $dirCount{IFD0} or $dirCount{ExtendedEXIF}; |
|
|
|
66
|
|
|
|
|
5708
|
|
|
|
|
|
|
# EXIF information must come immediately after APP0 |
5709
|
691
|
100
|
100
|
|
|
2612
|
if (exists $$addDirs{IFD0} and not defined $doneDir{IFD0}) { |
5710
|
31
|
|
|
|
|
120
|
$doneDir{IFD0} = 1; |
5711
|
31
|
100
|
|
|
|
136
|
$verbose and print $out "Creating APP1:\n"; |
5712
|
|
|
|
|
|
|
# write new EXIF data |
5713
|
31
|
|
|
|
|
112
|
$$self{TIFF_TYPE} = 'APP1'; |
5714
|
31
|
|
|
|
|
154
|
my $tagTablePtr = GetTagTable('Image::ExifTool::Exif::Main'); |
5715
|
31
|
|
|
|
|
234
|
my %dirInfo = ( |
5716
|
|
|
|
|
|
|
DirName => 'IFD0', |
5717
|
|
|
|
|
|
|
Parent => 'APP1', |
5718
|
|
|
|
|
|
|
); |
5719
|
31
|
|
|
|
|
133
|
$$path[$pn] = 'APP1'; |
5720
|
31
|
|
|
|
|
255
|
my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr, \&WriteTIFF); |
5721
|
31
|
100
|
66
|
|
|
319
|
if (defined $buff and length $buff) { |
5722
|
29
|
50
|
|
|
|
191
|
if (length($buff) + length($exifAPP1hdr) > $maxSegmentLen) { |
5723
|
0
|
0
|
|
|
|
0
|
if ($self->Options('NoMultiExif')) { |
5724
|
0
|
|
|
|
|
0
|
$self->Error('EXIF is too large for JPEG segment'); |
5725
|
|
|
|
|
|
|
} else { |
5726
|
0
|
|
|
|
|
0
|
$self->Warn('Creating multi-segment EXIF',1); |
5727
|
|
|
|
|
|
|
} |
5728
|
|
|
|
|
|
|
} |
5729
|
|
|
|
|
|
|
# switch to buffered output if required |
5730
|
29
|
50
|
33
|
|
|
320
|
if (($$self{PREVIEW_INFO} or $$self{LeicaTrailer}) and not $oldOutfile) { |
|
|
|
33
|
|
|
|
|
5731
|
0
|
|
|
|
|
0
|
$writeBuffer = ''; |
5732
|
0
|
|
|
|
|
0
|
$oldOutfile = $outfile; |
5733
|
0
|
|
|
|
|
0
|
$outfile = \$writeBuffer; |
5734
|
|
|
|
|
|
|
# account for segment, EXIF and TIFF headers |
5735
|
0
|
0
|
|
|
|
0
|
$$self{PREVIEW_INFO}{Fixup}{Start} += 18 if $$self{PREVIEW_INFO}; |
5736
|
0
|
0
|
|
|
|
0
|
$$self{LeicaTrailer}{Fixup}{Start} += 18 if $$self{LeicaTrailer}; |
5737
|
|
|
|
|
|
|
} |
5738
|
|
|
|
|
|
|
# write as multi-segment |
5739
|
29
|
|
|
|
|
174
|
my $n = WriteMultiSegment($outfile, 0xe1, $exifAPP1hdr, \$buff, 'EXIF'); |
5740
|
29
|
50
|
33
|
|
|
230
|
if (not $n) { |
|
|
50
|
|
|
|
|
|
5741
|
0
|
|
|
|
|
0
|
$err = 1; |
5742
|
|
|
|
|
|
|
} elsif ($n > 1 and $oldOutfile) { |
5743
|
|
|
|
|
|
|
# (punt on this because updating the pointers would be a real pain) |
5744
|
0
|
|
|
|
|
0
|
$self->Error("Can't write multi-segment EXIF with external pointers"); |
5745
|
|
|
|
|
|
|
} |
5746
|
29
|
|
|
|
|
191
|
++$$self{CHANGED}; |
5747
|
|
|
|
|
|
|
} |
5748
|
|
|
|
|
|
|
} |
5749
|
|
|
|
|
|
|
# APP13 Photoshop segment next |
5750
|
691
|
100
|
|
|
|
1804
|
last if $dirCount{Photoshop}; |
5751
|
509
|
100
|
100
|
|
|
5537
|
if (exists $$addDirs{Photoshop} and not defined $doneDir{Photoshop}) { |
5752
|
19
|
|
|
|
|
75
|
$doneDir{Photoshop} = 1; |
5753
|
19
|
50
|
|
|
|
87
|
$verbose and print $out "Creating APP13:\n"; |
5754
|
|
|
|
|
|
|
# write new APP13 Photoshop record to memory |
5755
|
19
|
|
|
|
|
88
|
my $tagTablePtr = GetTagTable('Image::ExifTool::Photoshop::Main'); |
5756
|
19
|
|
|
|
|
110
|
my %dirInfo = ( |
5757
|
|
|
|
|
|
|
Parent => 'APP13', |
5758
|
|
|
|
|
|
|
); |
5759
|
19
|
|
|
|
|
73
|
$$path[$pn] = 'APP13'; |
5760
|
19
|
|
|
|
|
113
|
my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr); |
5761
|
19
|
50
|
33
|
|
|
156
|
if (defined $buff and length $buff) { |
5762
|
19
|
50
|
|
|
|
447
|
WriteMultiSegment($outfile, 0xed, $psAPP13hdr, \$buff) or $err = 1; |
5763
|
19
|
|
|
|
|
100
|
++$$self{CHANGED}; |
5764
|
|
|
|
|
|
|
} |
5765
|
|
|
|
|
|
|
} |
5766
|
|
|
|
|
|
|
# then APP1 XMP segment |
5767
|
509
|
100
|
|
|
|
1353
|
last if $dirCount{XMP}; |
5768
|
494
|
100
|
100
|
|
|
1787
|
if (exists $$addDirs{XMP} and not defined $doneDir{XMP}) { |
5769
|
27
|
|
|
|
|
92
|
$doneDir{XMP} = 1; |
5770
|
27
|
50
|
|
|
|
130
|
$verbose and print $out "Creating APP1:\n"; |
5771
|
|
|
|
|
|
|
# write new XMP data |
5772
|
27
|
|
|
|
|
165
|
my $tagTablePtr = GetTagTable('Image::ExifTool::XMP::Main'); |
5773
|
27
|
|
|
|
|
250
|
my %dirInfo = ( |
5774
|
|
|
|
|
|
|
Parent => 'APP1', |
5775
|
|
|
|
|
|
|
# specify MaxDataLen so XMP is split if required |
5776
|
|
|
|
|
|
|
MaxDataLen => $maxXMPLen - length($xmpAPP1hdr), |
5777
|
|
|
|
|
|
|
); |
5778
|
27
|
|
|
|
|
108
|
$$path[$pn] = 'APP1'; |
5779
|
27
|
|
|
|
|
165
|
my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr); |
5780
|
27
|
50
|
33
|
|
|
300
|
if (defined $buff and length $buff) { |
5781
|
|
|
|
|
|
|
WriteMultiXMP($self, $outfile, \$buff, $dirInfo{ExtendedXMP}, |
5782
|
27
|
50
|
|
|
|
209
|
$dirInfo{ExtendedGUID}) or $err = 1; |
5783
|
|
|
|
|
|
|
} |
5784
|
|
|
|
|
|
|
} |
5785
|
|
|
|
|
|
|
# then APP2 ICC_Profile segment |
5786
|
494
|
100
|
|
|
|
1478
|
last if $dirCount{ICC_Profile}; |
5787
|
489
|
100
|
100
|
|
|
1476
|
if (exists $$addDirs{ICC_Profile} and not defined $doneDir{ICC_Profile}) { |
5788
|
3
|
|
|
|
|
11
|
$doneDir{ICC_Profile} = 1; |
5789
|
3
|
50
|
66
|
|
|
23
|
next if $$delGroup{ICC_Profile} and $$delGroup{ICC_Profile} != 2; |
5790
|
3
|
50
|
|
|
|
13
|
$verbose and print $out "Creating APP2:\n"; |
5791
|
|
|
|
|
|
|
# write new ICC_Profile data |
5792
|
3
|
|
|
|
|
16
|
my $tagTablePtr = GetTagTable('Image::ExifTool::ICC_Profile::Main'); |
5793
|
3
|
|
|
|
|
23
|
my %dirInfo = ( |
5794
|
|
|
|
|
|
|
Parent => 'APP2', |
5795
|
|
|
|
|
|
|
); |
5796
|
3
|
|
|
|
|
14
|
$$path[$pn] = 'APP2'; |
5797
|
3
|
|
|
|
|
50
|
my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr); |
5798
|
3
|
50
|
33
|
|
|
23
|
if (defined $buff and length $buff) { |
5799
|
3
|
50
|
|
|
|
16
|
WriteMultiSegment($outfile, 0xe2, "ICC_PROFILE\0", \$buff, 'ICC') or $err = 1; |
5800
|
3
|
|
|
|
|
24
|
++$$self{CHANGED}; |
5801
|
|
|
|
|
|
|
} |
5802
|
|
|
|
|
|
|
} |
5803
|
|
|
|
|
|
|
# then APP12 Ducky segment |
5804
|
489
|
100
|
|
|
|
1210
|
last if $dirCount{Ducky}; |
5805
|
488
|
100
|
100
|
|
|
1458
|
if (exists $$addDirs{Ducky} and not defined $doneDir{Ducky}) { |
5806
|
2
|
|
|
|
|
10
|
$doneDir{Ducky} = 1; |
5807
|
2
|
50
|
|
|
|
14
|
$verbose and print $out "Creating APP12 Ducky:\n"; |
5808
|
|
|
|
|
|
|
# write new Ducky segment data |
5809
|
2
|
|
|
|
|
15
|
my $tagTablePtr = GetTagTable('Image::ExifTool::APP12::Ducky'); |
5810
|
2
|
|
|
|
|
17
|
my %dirInfo = ( |
5811
|
|
|
|
|
|
|
Parent => 'APP12', |
5812
|
|
|
|
|
|
|
); |
5813
|
2
|
|
|
|
|
11
|
$$path[$pn] = 'APP12'; |
5814
|
2
|
|
|
|
|
12
|
my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr); |
5815
|
2
|
50
|
33
|
|
|
25
|
if (defined $buff and length $buff) { |
5816
|
2
|
|
|
|
|
7
|
my $size = length($buff) + 5; |
5817
|
2
|
50
|
|
|
|
8
|
if ($size <= $maxSegmentLen) { |
5818
|
|
|
|
|
|
|
# write the new segment with appropriate header |
5819
|
2
|
|
|
|
|
11
|
my $app12hdr = "\xff\xec" . pack('n', $size + 2); |
5820
|
2
|
50
|
|
|
|
10
|
Write($outfile, $app12hdr, 'Ducky', $buff) or $err = 1; |
5821
|
|
|
|
|
|
|
} else { |
5822
|
0
|
|
|
|
|
0
|
$self->Warn("APP12 Ducky segment too large! ($size bytes)"); |
5823
|
|
|
|
|
|
|
} |
5824
|
|
|
|
|
|
|
} |
5825
|
|
|
|
|
|
|
} |
5826
|
|
|
|
|
|
|
# then APP14 Adobe segment |
5827
|
488
|
100
|
|
|
|
1331
|
last if $dirCount{Adobe}; |
5828
|
463
|
50
|
33
|
|
|
1596
|
if (exists $$addDirs{Adobe} and not defined $doneDir{Adobe}) { |
5829
|
0
|
|
|
|
|
0
|
$doneDir{Adobe} = 1; |
5830
|
0
|
|
|
|
|
0
|
my $buff = $self->GetNewValue('Adobe'); |
5831
|
0
|
0
|
|
|
|
0
|
if ($buff) { |
5832
|
0
|
0
|
|
|
|
0
|
$verbose and print $out "Creating APP14:\n Creating Adobe segment\n"; |
5833
|
0
|
|
|
|
|
0
|
my $size = length($buff); |
5834
|
0
|
0
|
|
|
|
0
|
if ($size <= $maxSegmentLen) { |
5835
|
|
|
|
|
|
|
# write the new segment with appropriate header |
5836
|
0
|
|
|
|
|
0
|
my $app14hdr = "\xff\xee" . pack('n', $size + 2); |
5837
|
0
|
0
|
|
|
|
0
|
Write($outfile, $app14hdr, $buff) or $err = 1; |
5838
|
0
|
|
|
|
|
0
|
++$$self{CHANGED}; |
5839
|
|
|
|
|
|
|
} else { |
5840
|
0
|
|
|
|
|
0
|
$self->Warn("APP14 Adobe segment too large! ($size bytes)"); |
5841
|
|
|
|
|
|
|
} |
5842
|
|
|
|
|
|
|
} |
5843
|
|
|
|
|
|
|
} |
5844
|
|
|
|
|
|
|
# finally, COM segment |
5845
|
463
|
100
|
|
|
|
1166
|
last if $dirCount{COM}; |
5846
|
443
|
100
|
100
|
|
|
1388
|
if (exists $$addDirs{COM} and not defined $doneDir{COM}) { |
5847
|
5
|
|
|
|
|
16
|
$doneDir{COM} = 1; |
5848
|
5
|
50
|
33
|
|
|
22
|
next if $$delGroup{File} and $$delGroup{File} != 2; |
5849
|
5
|
|
|
|
|
24
|
my $newComment = $self->GetNewValue('Comment'); |
5850
|
5
|
50
|
|
|
|
25
|
if (defined $newComment) { |
5851
|
5
|
50
|
|
|
|
29
|
if ($verbose) { |
5852
|
0
|
|
|
|
|
0
|
print $out "Creating COM:\n"; |
5853
|
0
|
|
|
|
|
0
|
$self->VerboseValue('+ Comment', $newComment); |
5854
|
|
|
|
|
|
|
} |
5855
|
5
|
50
|
|
|
|
29
|
WriteMultiSegment($outfile, 0xfe, '', \$newComment) or $err = 1; |
5856
|
5
|
|
|
|
|
27
|
++$$self{CHANGED}; |
5857
|
|
|
|
|
|
|
} |
5858
|
|
|
|
|
|
|
} |
5859
|
443
|
|
|
|
|
758
|
last; # didn't want to loop anyway |
5860
|
|
|
|
|
|
|
} |
5861
|
796
|
|
|
|
|
1936
|
$$path[$pn] = $markerName; |
5862
|
|
|
|
|
|
|
# decrement counter for this directory since we are about to process it |
5863
|
796
|
|
|
|
|
1878
|
--$dirCount{$dirName}; |
5864
|
|
|
|
|
|
|
# |
5865
|
|
|
|
|
|
|
# rewrite existing segments |
5866
|
|
|
|
|
|
|
# |
5867
|
|
|
|
|
|
|
# handle SOF markers: SOF0-SOF15, except DHT(0xc4), JPGA(0xc8) and DAC(0xcc) |
5868
|
796
|
100
|
66
|
|
|
8273
|
if (($marker & 0xf0) == 0xc0 and ($marker == 0xc0 or $marker & 0x03)) { |
|
|
100
|
100
|
|
|
|
|
|
|
100
|
66
|
|
|
|
|
|
|
50
|
33
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
|
33
|
|
|
|
|
5869
|
109
|
100
|
|
|
|
464
|
$verbose and print $out "JPEG $markerName:\n"; |
5870
|
109
|
50
|
|
|
|
404
|
Write($outfile, $hdr, $segData) or $err = 1; |
5871
|
109
|
|
|
|
|
411
|
next; |
5872
|
|
|
|
|
|
|
} elsif ($marker == 0xda) { # SOS |
5873
|
109
|
|
|
|
|
511
|
pop @$path; |
5874
|
109
|
100
|
|
|
|
571
|
$verbose and print $out "JPEG SOS\n"; |
5875
|
|
|
|
|
|
|
# write SOS segment |
5876
|
109
|
|
|
|
|
491
|
$s = pack('n', length($segData) + 2); |
5877
|
109
|
50
|
|
|
|
498
|
Write($outfile, $hdr, $s, $segData) or $err = 1; |
5878
|
109
|
|
|
|
|
479
|
my ($buff, $endPos, $trailInfo); |
5879
|
109
|
|
|
|
|
389
|
my $delPreview = $$self{DEL_PREVIEW}; |
5880
|
109
|
100
|
|
|
|
775
|
$trailInfo = IdentifyTrailer($raf) unless $$delGroup{Trailer}; |
5881
|
109
|
|
|
|
|
961
|
my $nvTrail = $self->GetNewValueHash($Image::ExifTool::Extra{Trailer}); |
5882
|
109
|
100
|
66
|
|
|
1953
|
unless ($oldOutfile or $delPreview or $trailInfo or $$delGroup{Trailer} or $nvTrail) { |
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
66
|
|
|
|
|
5883
|
|
|
|
|
|
|
# blindly copy the rest of the file |
5884
|
93
|
|
|
|
|
485
|
while ($raf->Read($buff, 65536)) { |
5885
|
93
|
50
|
|
|
|
4372
|
Write($outfile, $buff) or $err = 1, last; |
5886
|
|
|
|
|
|
|
} |
5887
|
93
|
|
|
|
|
378
|
$rtnVal = 1; # success unless we have a file write error |
5888
|
93
|
|
|
|
|
307
|
last; # all done |
5889
|
|
|
|
|
|
|
} |
5890
|
|
|
|
|
|
|
# write the rest of the image (as quickly as possible) up to the EOI |
5891
|
16
|
|
|
|
|
58
|
my $endedWithFF; |
5892
|
16
|
|
|
|
|
45
|
for (;;) { |
5893
|
16
|
50
|
|
|
|
82
|
my $n = $raf->Read($buff, 65536) or last Marker; |
5894
|
16
|
50
|
33
|
|
|
298
|
if (($endedWithFF and $buff =~ m/^\xd9/sg) or |
|
|
|
33
|
|
|
|
|
5895
|
|
|
|
|
|
|
$buff =~ m/\xff\xd9/sg) |
5896
|
|
|
|
|
|
|
{ |
5897
|
16
|
|
|
|
|
47
|
$rtnVal = 1; # the JPEG is OK |
5898
|
|
|
|
|
|
|
# write up to the EOI |
5899
|
16
|
|
|
|
|
51
|
my $pos = pos($buff); |
5900
|
16
|
50
|
|
|
|
92
|
Write($outfile, substr($buff, 0, $pos)) or $err = 1; |
5901
|
16
|
|
|
|
|
141
|
$buff = substr($buff, $pos); |
5902
|
16
|
|
|
|
|
47
|
last; |
5903
|
|
|
|
|
|
|
} |
5904
|
0
|
0
|
|
|
|
0
|
unless ($n == 65536) { |
5905
|
0
|
|
|
|
|
0
|
$self->Error('JPEG EOI marker not found'); |
5906
|
0
|
|
|
|
|
0
|
last Marker; |
5907
|
|
|
|
|
|
|
} |
5908
|
0
|
0
|
|
|
|
0
|
Write($outfile, $buff) or $err = 1; |
5909
|
0
|
0
|
|
|
|
0
|
$endedWithFF = substr($buff, 65535, 1) eq "\xff" ? 1 : 0; |
5910
|
|
|
|
|
|
|
} |
5911
|
|
|
|
|
|
|
# remember position of last data copied |
5912
|
16
|
|
|
|
|
112
|
$endPos = $raf->Tell() - length($buff); |
5913
|
|
|
|
|
|
|
# write new trailer if specified |
5914
|
16
|
50
|
|
|
|
102
|
if ($nvTrail) { |
5915
|
|
|
|
|
|
|
# access new value directly to avoid copying a potentially very large data block |
5916
|
0
|
0
|
0
|
|
|
0
|
if ($$nvTrail{Value} and $$nvTrail{Value}[0]) { # (note: "0" will also delete the trailer) |
|
|
0
|
0
|
|
|
|
|
5917
|
0
|
|
|
|
|
0
|
$self->VPrint(0, ' Writing new trailer'); |
5918
|
0
|
0
|
|
|
|
0
|
Write($outfile, $$nvTrail{Value}[0]) or $err = 1; |
5919
|
0
|
|
|
|
|
0
|
++$$self{CHANGED}; |
5920
|
|
|
|
|
|
|
} elsif ($raf->Seek(0, 2) and $raf->Tell() != $endPos) { |
5921
|
0
|
|
|
|
|
0
|
$self->VPrint(0, ' Deleting trailer (', $raf->Tell() - $endPos, ' bytes)'); |
5922
|
0
|
|
|
|
|
0
|
++$$self{CHANGED}; # changed if there was previously a trailer |
5923
|
|
|
|
|
|
|
} |
5924
|
0
|
|
|
|
|
0
|
last; # all done |
5925
|
|
|
|
|
|
|
} |
5926
|
|
|
|
|
|
|
# rewrite existing trailers |
5927
|
16
|
100
|
|
|
|
108
|
if ($trailInfo) { |
5928
|
11
|
|
|
|
|
39
|
my $tbuf = ''; |
5929
|
11
|
|
|
|
|
66
|
$raf->Seek(-length($buff), 1); # seek back to just after EOI |
5930
|
11
|
|
|
|
|
110
|
$$trailInfo{OutFile} = \$tbuf; # rewrite the trailer |
5931
|
11
|
|
|
|
|
68
|
$$trailInfo{ScanForAFCP} = 1; # scan if necessary |
5932
|
11
|
50
|
|
|
|
76
|
$self->ProcessTrailers($trailInfo) or undef $trailInfo; |
5933
|
|
|
|
|
|
|
} |
5934
|
16
|
100
|
|
|
|
77
|
if (not $oldOutfile) { |
|
|
50
|
|
|
|
|
|
5935
|
|
|
|
|
|
|
# do nothing special |
5936
|
|
|
|
|
|
|
} elsif ($$self{LeicaTrailer}) { |
5937
|
0
|
|
|
|
|
0
|
my $trailLen; |
5938
|
0
|
0
|
|
|
|
0
|
if ($trailInfo) { |
5939
|
0
|
|
|
|
|
0
|
$trailLen = $$trailInfo{DataPos} - $endPos; |
5940
|
|
|
|
|
|
|
} else { |
5941
|
0
|
0
|
|
|
|
0
|
$raf->Seek(0, 2) or $err = 1; |
5942
|
0
|
|
|
|
|
0
|
$trailLen = $raf->Tell() - $endPos; |
5943
|
|
|
|
|
|
|
} |
5944
|
0
|
|
|
|
|
0
|
my $fixup = $$self{LeicaTrailer}{Fixup}; |
5945
|
0
|
|
|
|
|
0
|
$$self{LeicaTrailer}{TrailPos} = $endPos; |
5946
|
0
|
|
|
|
|
0
|
$$self{LeicaTrailer}{TrailLen} = $trailLen; |
5947
|
|
|
|
|
|
|
# get _absolute_ position of new Leica trailer |
5948
|
0
|
|
|
|
|
0
|
my $absPos = Tell($oldOutfile) + length($$outfile); |
5949
|
0
|
|
|
|
|
0
|
require Image::ExifTool::Panasonic; |
5950
|
0
|
|
|
|
|
0
|
my $dat = Image::ExifTool::Panasonic::ProcessLeicaTrailer($self, $absPos); |
5951
|
|
|
|
|
|
|
# allow some junk before Leica trailer (just in case) |
5952
|
0
|
|
|
|
|
0
|
my $junk = $$self{LeicaTrailerPos} - $endPos; |
5953
|
|
|
|
|
|
|
# set MakerNote pointer and size (subtract 10 for segment and EXIF headers) |
5954
|
0
|
|
|
|
|
0
|
$fixup->SetMarkerPointers($outfile, 'LeicaTrailer', length($$outfile) - 10 + $junk); |
5955
|
|
|
|
|
|
|
# use this fixup to set the size too (sneaky) |
5956
|
0
|
0
|
|
|
|
0
|
my $trailSize = defined($dat) ? length($dat) - $junk : $$self{LeicaTrailer}{Size}; |
5957
|
0
|
|
|
|
|
0
|
$$fixup{Start} -= 4; $$fixup{Shift} += 4; |
|
0
|
|
|
|
|
0
|
|
5958
|
0
|
0
|
|
|
|
0
|
$fixup->SetMarkerPointers($outfile, 'LeicaTrailer', $trailSize) if defined $trailSize; |
5959
|
0
|
|
|
|
|
0
|
$$fixup{Start} += 4; $$fixup{Shift} -= 4; |
|
0
|
|
|
|
|
0
|
|
5960
|
|
|
|
|
|
|
# clean up and write the buffered data |
5961
|
0
|
|
|
|
|
0
|
$outfile = $oldOutfile; |
5962
|
0
|
|
|
|
|
0
|
undef $oldOutfile; |
5963
|
0
|
0
|
|
|
|
0
|
Write($outfile, $writeBuffer) or $err = 1; |
5964
|
0
|
|
|
|
|
0
|
undef $writeBuffer; |
5965
|
0
|
0
|
|
|
|
0
|
if (defined $dat) { |
5966
|
0
|
0
|
|
|
|
0
|
Write($outfile, $dat) or $err = 1; # write new Leica trailer |
5967
|
0
|
|
|
|
|
0
|
$delPreview = 1; # delete existing Leica trailer |
5968
|
|
|
|
|
|
|
} |
5969
|
|
|
|
|
|
|
} else { |
5970
|
|
|
|
|
|
|
# locate preview image and fix up preview offsets |
5971
|
1
|
50
|
|
|
|
8
|
my $scanLen = $$self{Make} =~ /^SONY/i ? 65536 : 1024; |
5972
|
1
|
50
|
|
|
|
4
|
if (length($buff) < $scanLen) { # make sure we have enough trailer to scan |
5973
|
1
|
|
|
|
|
2
|
my $buf2; |
5974
|
1
|
50
|
|
|
|
5
|
$buff .= $buf2 if $raf->Read($buf2, $scanLen - length($buff)); |
5975
|
|
|
|
|
|
|
} |
5976
|
|
|
|
|
|
|
# get new preview image position, relative to EXIF base |
5977
|
1
|
|
|
|
|
16
|
my $newPos = length($$outfile) - 10; # (subtract 10 for segment and EXIF headers) |
5978
|
1
|
|
|
|
|
4
|
my $junkLen; |
5979
|
|
|
|
|
|
|
# adjust position if image isn't at the start (eg. Olympus E-1/E-300) |
5980
|
1
|
50
|
|
|
|
4
|
if ($buff =~ /(\xff\xd8\xff.|.\xd8\xff\xdb)(..)/sg) { |
5981
|
0
|
|
|
|
|
0
|
my ($jpegHdr, $segLen) = ($1, $2); |
5982
|
0
|
|
|
|
|
0
|
$junkLen = pos($buff) - 6; |
5983
|
|
|
|
|
|
|
# Sony previewimage trailer has a 32 byte header |
5984
|
0
|
0
|
0
|
|
|
0
|
if ($$self{Make} =~ /^SONY/i and $junkLen > 32) { |
5985
|
|
|
|
|
|
|
# with some newer Sony models, the makernotes preview pointer |
5986
|
|
|
|
|
|
|
# points to JPEG at end of EXIF inside MPImage preview (what a pain!) |
5987
|
0
|
0
|
|
|
|
0
|
if ($jpegHdr eq "\xff\xd8\xff\xe1") { # is the first segment EXIF? |
5988
|
0
|
|
|
|
|
0
|
$segLen = unpack('n', $segLen); # the EXIF segment length |
5989
|
|
|
|
|
|
|
# Sony PreviewImage starts with last 2 bytes of EXIF segment |
5990
|
|
|
|
|
|
|
# (and first byte is usually "\0", not "\xff", so don't check this) |
5991
|
0
|
0
|
0
|
|
|
0
|
if (length($buff) > $junkLen + $segLen + 6 and |
5992
|
|
|
|
|
|
|
substr($buff, $junkLen + $segLen + 3, 3) eq "\xd8\xff\xdb") |
5993
|
|
|
|
|
|
|
{ |
5994
|
0
|
|
|
|
|
0
|
$junkLen += $segLen + 2; |
5995
|
|
|
|
|
|
|
# (note: this will not copy the trailer after PreviewImage, |
5996
|
|
|
|
|
|
|
# which is a 14kB block full of zeros for the A77) |
5997
|
|
|
|
|
|
|
} |
5998
|
|
|
|
|
|
|
} |
5999
|
0
|
|
|
|
|
0
|
$junkLen -= 32; |
6000
|
|
|
|
|
|
|
} |
6001
|
0
|
|
|
|
|
0
|
$newPos += $junkLen; |
6002
|
|
|
|
|
|
|
} |
6003
|
|
|
|
|
|
|
# fix up the preview offsets to point to the start of the new image |
6004
|
1
|
|
|
|
|
4
|
my $previewInfo = $$self{PREVIEW_INFO}; |
6005
|
1
|
|
|
|
|
2
|
delete $$self{PREVIEW_INFO}; |
6006
|
1
|
|
|
|
|
4
|
my $fixup = $$previewInfo{Fixup}; |
6007
|
1
|
|
50
|
|
|
7
|
$newPos += ($$previewInfo{BaseShift} || 0); |
6008
|
|
|
|
|
|
|
# adjust to absolute file offset if necessary (Samsung STMN) |
6009
|
1
|
50
|
|
|
|
4
|
$newPos += Tell($oldOutfile) + 10 if $$previewInfo{Absolute}; |
6010
|
1
|
50
|
|
|
|
4
|
if ($$previewInfo{Relative}) { |
|
|
0
|
|
|
|
|
|
6011
|
|
|
|
|
|
|
# adjust for our base by looking at how far the pointer got shifted |
6012
|
1
|
|
50
|
|
|
7
|
$newPos -= ($fixup->GetMarkerPointers($outfile, 'PreviewImage') || 0); |
6013
|
|
|
|
|
|
|
} elsif ($$previewInfo{ChangeBase}) { |
6014
|
|
|
|
|
|
|
# Leica S2 uses relative offsets for the preview only (leica sucks) |
6015
|
0
|
|
|
|
|
0
|
my $makerOffset = $fixup->GetMarkerPointers($outfile, 'LeicaTrailer'); |
6016
|
0
|
0
|
|
|
|
0
|
$newPos -= $makerOffset if $makerOffset; |
6017
|
|
|
|
|
|
|
} |
6018
|
1
|
|
|
|
|
5
|
$fixup->SetMarkerPointers($outfile, 'PreviewImage', $newPos); |
6019
|
|
|
|
|
|
|
# clean up and write the buffered data |
6020
|
1
|
|
|
|
|
2
|
$outfile = $oldOutfile; |
6021
|
1
|
|
|
|
|
4
|
undef $oldOutfile; |
6022
|
1
|
50
|
|
|
|
4
|
Write($outfile, $writeBuffer) or $err = 1; |
6023
|
1
|
|
|
|
|
3
|
undef $writeBuffer; |
6024
|
|
|
|
|
|
|
# write preview image |
6025
|
1
|
50
|
|
|
|
15
|
if ($$previewInfo{Data} ne 'LOAD_PREVIEW') { |
6026
|
|
|
|
|
|
|
# write any junk that existed before the preview image |
6027
|
0
|
0
|
0
|
|
|
0
|
Write($outfile, substr($buff,0,$junkLen)) or $err = 1 if $junkLen; |
6028
|
|
|
|
|
|
|
# write the saved preview image |
6029
|
0
|
0
|
|
|
|
0
|
Write($outfile, $$previewInfo{Data}) or $err = 1; |
6030
|
0
|
|
|
|
|
0
|
delete $$previewInfo{Data}; |
6031
|
|
|
|
|
|
|
# (don't increment CHANGED because we could be rewriting existing preview) |
6032
|
0
|
|
|
|
|
0
|
$delPreview = 1; # remove old preview |
6033
|
|
|
|
|
|
|
} |
6034
|
|
|
|
|
|
|
} |
6035
|
|
|
|
|
|
|
# copy over preview image if necessary |
6036
|
16
|
50
|
|
|
|
72
|
unless ($delPreview) { |
6037
|
16
|
|
|
|
|
56
|
my $extra; |
6038
|
16
|
100
|
|
|
|
69
|
if ($trailInfo) { |
6039
|
|
|
|
|
|
|
# copy everything up to start of first processed trailer |
6040
|
11
|
|
|
|
|
32
|
$extra = $$trailInfo{DataPos} - $endPos; |
6041
|
|
|
|
|
|
|
} else { |
6042
|
|
|
|
|
|
|
# copy everything up to end of file |
6043
|
5
|
50
|
|
|
|
28
|
$raf->Seek(0, 2) or $err = 1; |
6044
|
5
|
|
|
|
|
36
|
$extra = $raf->Tell() - $endPos; |
6045
|
|
|
|
|
|
|
} |
6046
|
16
|
100
|
|
|
|
104
|
if ($extra > 0) { |
6047
|
3
|
100
|
|
|
|
16
|
if ($$delGroup{Trailer}) { |
6048
|
2
|
50
|
|
|
|
12
|
$verbose and print $out " Deleting unknown trailer ($extra bytes)\n"; |
6049
|
2
|
|
|
|
|
8
|
++$$self{CHANGED}; |
6050
|
|
|
|
|
|
|
} else { |
6051
|
|
|
|
|
|
|
# copy over unknown trailer |
6052
|
1
|
50
|
|
|
|
12
|
$verbose and print $out " Preserving unknown trailer ($extra bytes)\n"; |
6053
|
1
|
50
|
|
|
|
10
|
$raf->Seek($endPos, 0) or $err = 1; |
6054
|
1
|
50
|
|
|
|
6
|
CopyBlock($raf, $outfile, $extra) or $err = 1; |
6055
|
|
|
|
|
|
|
} |
6056
|
|
|
|
|
|
|
} |
6057
|
|
|
|
|
|
|
} |
6058
|
|
|
|
|
|
|
# write trailer if necessary |
6059
|
16
|
100
|
|
|
|
69
|
if ($trailInfo) { |
6060
|
11
|
50
|
|
|
|
95
|
$self->WriteTrailerBuffer($trailInfo, $outfile) or $err = 1; |
6061
|
11
|
|
|
|
|
98
|
undef $trailInfo; |
6062
|
|
|
|
|
|
|
} |
6063
|
16
|
|
|
|
|
67
|
last; # all done parsing file |
6064
|
|
|
|
|
|
|
|
6065
|
|
|
|
|
|
|
} elsif ($marker==0xd9 and $isEXV) { |
6066
|
|
|
|
|
|
|
# write EXV EOI (any trailer will be lost) |
6067
|
2
|
50
|
|
|
|
6
|
Write($outfile, "\xff\xd9") or $err = 1; |
6068
|
2
|
|
|
|
|
5
|
$rtnVal = 1; |
6069
|
2
|
|
|
|
|
11
|
last; |
6070
|
|
|
|
|
|
|
|
6071
|
|
|
|
|
|
|
} elsif ($marker==0x00 or $marker==0x01 or ($marker>=0xd0 and $marker<=0xd7)) { |
6072
|
0
|
0
|
0
|
|
|
0
|
$verbose and $marker and print $out "JPEG $markerName:\n"; |
6073
|
|
|
|
|
|
|
# handle stand-alone markers 0x00, 0x01 and 0xd0-0xd7 (NULL, TEM, RST0-RST7) |
6074
|
0
|
0
|
|
|
|
0
|
Write($outfile, $hdr) or $err = 1; |
6075
|
0
|
|
|
|
|
0
|
next; |
6076
|
|
|
|
|
|
|
} |
6077
|
|
|
|
|
|
|
# |
6078
|
|
|
|
|
|
|
# NOTE: A 'next' statement after this point will cause $$segDataPt |
6079
|
|
|
|
|
|
|
# not to be written if there is an output file, so in this case |
6080
|
|
|
|
|
|
|
# the $$self{CHANGED} flags must be updated |
6081
|
|
|
|
|
|
|
# |
6082
|
576
|
|
|
|
|
1198
|
my $segDataPt = \$segData; |
6083
|
576
|
|
|
|
|
1043
|
$length = length($segData); |
6084
|
576
|
100
|
|
|
|
1598
|
print $out "JPEG $markerName ($length bytes)\n" if $verbose; |
6085
|
|
|
|
|
|
|
# group delete of APP segments |
6086
|
576
|
100
|
|
|
|
1708
|
if ($$delGroup{$dirName}) { |
6087
|
55
|
50
|
|
|
|
122
|
$verbose and print $out " Deleting $dirName segment\n"; |
6088
|
55
|
100
|
|
|
|
149
|
$self->Warn('ICC_Profile deleted. Image colors may be affected') if $dirName eq 'ICC_Profile'; |
6089
|
55
|
|
|
|
|
117
|
++$$self{CHANGED}; |
6090
|
55
|
|
|
|
|
128
|
next Marker; |
6091
|
|
|
|
|
|
|
} |
6092
|
521
|
|
|
|
|
1082
|
my ($segType, $del); |
6093
|
|
|
|
|
|
|
# rewrite this segment only if we are changing a tag which is contained in its |
6094
|
|
|
|
|
|
|
# directory (or deleting '*', in which case we need to identify the segment type) |
6095
|
521
|
|
100
|
|
|
2679
|
while (exists $$editDirs{$markerName} or $$delGroup{'*'}) { |
6096
|
131
|
100
|
|
|
|
1442
|
if ($marker == 0xe0) { # APP0 (JFIF, CIFF) |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
6097
|
31
|
100
|
|
|
|
313
|
if ($$segDataPt =~ /^JFIF\0/) { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
6098
|
11
|
|
|
|
|
35
|
$segType = 'JFIF'; |
6099
|
11
|
50
|
|
|
|
62
|
$$delGroup{JFIF} and $del = 1, last; |
6100
|
11
|
50
|
|
|
|
49
|
last unless $$editDirs{JFIF}; |
6101
|
11
|
|
|
|
|
63
|
SetByteOrder('MM'); |
6102
|
11
|
|
|
|
|
90
|
my $tagTablePtr = GetTagTable('Image::ExifTool::JFIF::Main'); |
6103
|
11
|
|
|
|
|
105
|
my %dirInfo = ( |
6104
|
|
|
|
|
|
|
DataPt => $segDataPt, |
6105
|
|
|
|
|
|
|
DataPos => $segPos, |
6106
|
|
|
|
|
|
|
DataLen => $length, |
6107
|
|
|
|
|
|
|
DirStart => 5, # directory starts after identifier |
6108
|
|
|
|
|
|
|
DirLen => $length-5, |
6109
|
|
|
|
|
|
|
Parent => $markerName, |
6110
|
|
|
|
|
|
|
); |
6111
|
11
|
|
|
|
|
74
|
my $newData = $self->WriteDirectory(\%dirInfo, $tagTablePtr); |
6112
|
11
|
50
|
33
|
|
|
104
|
if (defined $newData and length $newData) { |
6113
|
11
|
|
|
|
|
73
|
$$segDataPt = "JFIF\0" . $newData; |
6114
|
|
|
|
|
|
|
} |
6115
|
|
|
|
|
|
|
} elsif ($$segDataPt =~ /^JFXX\0\x10/) { |
6116
|
8
|
|
|
|
|
30
|
$segType = 'JFXX'; |
6117
|
8
|
100
|
|
|
|
47
|
$$delGroup{JFIF} and $del = 1; |
6118
|
|
|
|
|
|
|
} elsif ($$segDataPt =~ /^(II|MM).{4}HEAPJPGM/s) { |
6119
|
6
|
|
|
|
|
20
|
$segType = 'CIFF'; |
6120
|
6
|
50
|
|
|
|
44
|
$$delGroup{CIFF} and $del = 1, last; |
6121
|
6
|
100
|
|
|
|
29
|
last unless $$editDirs{CIFF}; |
6122
|
4
|
|
|
|
|
20
|
my $newData = ''; |
6123
|
4
|
|
|
|
|
28
|
my %dirInfo = ( |
6124
|
|
|
|
|
|
|
RAF => new File::RandomAccess($segDataPt), |
6125
|
|
|
|
|
|
|
OutFile => \$newData, |
6126
|
|
|
|
|
|
|
); |
6127
|
4
|
|
|
|
|
47
|
require Image::ExifTool::CanonRaw; |
6128
|
4
|
50
|
|
|
|
44
|
if (Image::ExifTool::CanonRaw::WriteCRW($self, \%dirInfo) > 0) { |
6129
|
4
|
50
|
|
|
|
19
|
if (length $newData) { |
6130
|
4
|
|
|
|
|
13
|
$$segDataPt = $newData; |
6131
|
|
|
|
|
|
|
} else { |
6132
|
0
|
|
|
|
|
0
|
undef $segDataPt; |
6133
|
0
|
|
|
|
|
0
|
$del = 1; # delete this segment |
6134
|
|
|
|
|
|
|
} |
6135
|
|
|
|
|
|
|
} |
6136
|
|
|
|
|
|
|
} |
6137
|
|
|
|
|
|
|
} elsif ($marker == 0xe1) { # APP1 (EXIF, XMP) |
6138
|
|
|
|
|
|
|
# check for EXIF data |
6139
|
73
|
100
|
0
|
|
|
942
|
if ($$segDataPt =~ /^(.{0,4})Exif\0./is) { |
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
6140
|
52
|
|
|
|
|
196
|
my $hdrLen = length $exifAPP1hdr; |
6141
|
52
|
50
|
|
|
|
475
|
if (length $1) { |
|
|
50
|
|
|
|
|
|
6142
|
0
|
|
|
|
|
0
|
$hdrLen += length $1; |
6143
|
0
|
|
|
|
|
0
|
$self->Error('Unknown garbage at start of EXIF segment',1); |
6144
|
|
|
|
|
|
|
} elsif ($$segDataPt !~ /^Exif\0/) { |
6145
|
0
|
|
|
|
|
0
|
$self->Error('Incorrect EXIF segment identifier',1); |
6146
|
|
|
|
|
|
|
} |
6147
|
52
|
|
|
|
|
176
|
$segType = 'EXIF'; |
6148
|
52
|
100
|
|
|
|
716
|
last unless $$editDirs{IFD0}; |
6149
|
|
|
|
|
|
|
# add this data to the combined data if it exists |
6150
|
51
|
50
|
|
|
|
222
|
if (defined $combinedSegData) { |
6151
|
0
|
|
|
|
|
0
|
$combinedSegData .= substr($$segDataPt,$hdrLen); |
6152
|
0
|
|
|
|
|
0
|
$segDataPt = \$combinedSegData; |
6153
|
0
|
|
|
|
|
0
|
$segPos = $firstSegPos; |
6154
|
0
|
|
|
|
|
0
|
$length = length $combinedSegData; # update length |
6155
|
|
|
|
|
|
|
} |
6156
|
|
|
|
|
|
|
# peek ahead to see if the next segment is extended EXIF |
6157
|
51
|
50
|
|
|
|
245
|
if ($dirOrder[0] eq 'ExtendedEXIF') { |
6158
|
|
|
|
|
|
|
# initialize combined data if necessary |
6159
|
0
|
0
|
|
|
|
0
|
unless (defined $combinedSegData) { |
6160
|
0
|
|
|
|
|
0
|
$combinedSegData = $$segDataPt; |
6161
|
0
|
|
|
|
|
0
|
$firstSegPos = $segPos; |
6162
|
0
|
|
|
|
|
0
|
$self->Warn('File contains multi-segment EXIF',1); |
6163
|
|
|
|
|
|
|
} |
6164
|
0
|
|
|
|
|
0
|
next Marker; # get the next segment to combine |
6165
|
|
|
|
|
|
|
} |
6166
|
51
|
50
|
|
|
|
233
|
$doneDir{IFD0} and $self->Warn('Multiple APP1 EXIF records'); |
6167
|
51
|
|
|
|
|
164
|
$doneDir{IFD0} = 1; |
6168
|
|
|
|
|
|
|
# check del groups now so we can change byte order in one step |
6169
|
51
|
100
|
66
|
|
|
845
|
if ($$delGroup{IFD0} or $$delGroup{EXIF}) { |
6170
|
1
|
|
|
|
|
3
|
delete $doneDir{IFD0}; # delete so we will create a new one |
6171
|
1
|
|
|
|
|
4
|
$del = 1; |
6172
|
1
|
|
|
|
|
2
|
last; |
6173
|
|
|
|
|
|
|
} |
6174
|
|
|
|
|
|
|
# rewrite EXIF as if this were a TIFF file in memory |
6175
|
50
|
|
|
|
|
631
|
my %dirInfo = ( |
6176
|
|
|
|
|
|
|
DataPt => $segDataPt, |
6177
|
|
|
|
|
|
|
DataPos => -$hdrLen, # (remember: relative to Base!) |
6178
|
|
|
|
|
|
|
DirStart => $hdrLen, |
6179
|
|
|
|
|
|
|
Base => $segPos + $hdrLen, |
6180
|
|
|
|
|
|
|
Parent => $markerName, |
6181
|
|
|
|
|
|
|
DirName => 'IFD0', |
6182
|
|
|
|
|
|
|
); |
6183
|
|
|
|
|
|
|
# write new EXIF data to memory |
6184
|
50
|
|
|
|
|
309
|
my $tagTablePtr = GetTagTable('Image::ExifTool::Exif::Main'); |
6185
|
50
|
|
|
|
|
473
|
my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr, \&WriteTIFF); |
6186
|
50
|
50
|
|
|
|
303
|
if (defined $buff) { |
6187
|
50
|
|
|
|
|
182
|
undef $$segDataPt; # free the old buffer |
6188
|
50
|
|
|
|
|
150
|
$segDataPt = \$buff; |
6189
|
|
|
|
|
|
|
} else { |
6190
|
0
|
0
|
|
|
|
0
|
last Marker unless $self->Options('IgnoreMinorErrors'); |
6191
|
|
|
|
|
|
|
} |
6192
|
|
|
|
|
|
|
# delete segment if IFD contains no entries |
6193
|
50
|
100
|
|
|
|
256
|
length $$segDataPt or $del = 1, last; |
6194
|
46
|
50
|
|
|
|
261
|
if (length($$segDataPt) + length($exifAPP1hdr) > $maxSegmentLen) { |
6195
|
0
|
0
|
|
|
|
0
|
if ($self->Options('NoMultiExif')) { |
6196
|
0
|
|
|
|
|
0
|
$self->Error('EXIF is too large for JPEG segment'); |
6197
|
|
|
|
|
|
|
} else { |
6198
|
0
|
|
|
|
|
0
|
$self->Warn('Writing multi-segment EXIF',1); |
6199
|
|
|
|
|
|
|
} |
6200
|
|
|
|
|
|
|
} |
6201
|
|
|
|
|
|
|
# switch to buffered output if required |
6202
|
46
|
100
|
66
|
|
|
438
|
if (($$self{PREVIEW_INFO} or $$self{LeicaTrailer}) and not $oldOutfile) { |
|
|
|
66
|
|
|
|
|
6203
|
1
|
|
|
|
|
3
|
$writeBuffer = ''; |
6204
|
1
|
|
|
|
|
3
|
$oldOutfile = $outfile; |
6205
|
1
|
|
|
|
|
2
|
$outfile = \$writeBuffer; |
6206
|
|
|
|
|
|
|
# must account for segment, EXIF and TIFF headers |
6207
|
1
|
50
|
|
|
|
5
|
$$self{PREVIEW_INFO}{Fixup}{Start} += 18 if $$self{PREVIEW_INFO}; |
6208
|
1
|
50
|
|
|
|
6
|
$$self{LeicaTrailer}{Fixup}{Start} += 18 if $$self{LeicaTrailer}; |
6209
|
|
|
|
|
|
|
} |
6210
|
|
|
|
|
|
|
# write as multi-segment |
6211
|
46
|
|
|
|
|
308
|
my $n = WriteMultiSegment($outfile, $marker, $exifAPP1hdr, $segDataPt, 'EXIF'); |
6212
|
46
|
50
|
33
|
|
|
370
|
if (not $n) { |
|
|
50
|
|
|
|
|
|
6213
|
0
|
|
|
|
|
0
|
$err = 1; |
6214
|
|
|
|
|
|
|
} elsif ($n > 1 and $oldOutfile) { |
6215
|
|
|
|
|
|
|
# (punt on this because updating the pointers would be a real pain) |
6216
|
0
|
|
|
|
|
0
|
$self->Error("Can't write multi-segment EXIF with external pointers"); |
6217
|
|
|
|
|
|
|
} |
6218
|
46
|
|
|
|
|
160
|
undef $combinedSegData; |
6219
|
46
|
|
|
|
|
156
|
undef $$segDataPt; |
6220
|
46
|
|
|
|
|
431
|
next Marker; |
6221
|
|
|
|
|
|
|
# check for XMP data |
6222
|
|
|
|
|
|
|
} elsif ($$segDataPt =~ /^($xmpAPP1hdr|$xmpExtAPP1hdr)/) { |
6223
|
21
|
|
|
|
|
71
|
$segType = 'XMP'; |
6224
|
21
|
50
|
|
|
|
86
|
$$delGroup{XMP} and $del = 1, last; |
6225
|
21
|
|
100
|
|
|
130
|
$doneDir{XMP} = ($doneDir{XMP} || 0) + 1; |
6226
|
21
|
100
|
|
|
|
87
|
last unless $$editDirs{XMP}; |
6227
|
14
|
100
|
|
|
|
71
|
if ($doneDir{XMP} + $dirCount{XMP} > 1) { |
6228
|
|
|
|
|
|
|
# must assemble all XMP segments before writing |
6229
|
3
|
|
|
|
|
8
|
my ($guid, $extXMP); |
6230
|
3
|
100
|
|
|
|
31
|
if ($$segDataPt =~ /^$xmpExtAPP1hdr/) { |
6231
|
|
|
|
|
|
|
# save extended XMP data |
6232
|
2
|
50
|
|
|
|
6
|
if (length $$segDataPt < 75) { |
6233
|
0
|
|
|
|
|
0
|
$extendedXMP{Error} = 'Truncated data'; |
6234
|
|
|
|
|
|
|
} else { |
6235
|
2
|
|
|
|
|
10
|
my ($size, $off) = unpack('x67N2', $$segDataPt); |
6236
|
2
|
|
|
|
|
7
|
$guid = substr($$segDataPt, 35, 32); |
6237
|
2
|
50
|
|
|
|
9
|
if ($guid =~ /[^A-Za-z0-9]/) { # (technically, should be uppercase) |
6238
|
0
|
|
|
|
|
0
|
$extendedXMP{Error} = 'Invalid GUID'; |
6239
|
|
|
|
|
|
|
} else { |
6240
|
|
|
|
|
|
|
# remember extended data for each GUID |
6241
|
2
|
|
|
|
|
5
|
$extXMP = $extendedXMP{$guid}; |
6242
|
2
|
100
|
|
|
|
8
|
if ($extXMP) { |
6243
|
1
|
50
|
|
|
|
5
|
$size == $$extXMP{Size} or $extendedXMP{Error} = 'Inconsistent size'; |
6244
|
|
|
|
|
|
|
} else { |
6245
|
1
|
|
|
|
|
4
|
$extXMP = $extendedXMP{$guid} = { }; |
6246
|
|
|
|
|
|
|
} |
6247
|
2
|
|
|
|
|
7
|
$$extXMP{Size} = $size; |
6248
|
2
|
|
|
|
|
8
|
$$extXMP{$off} = substr($$segDataPt, 75); |
6249
|
|
|
|
|
|
|
} |
6250
|
|
|
|
|
|
|
} |
6251
|
|
|
|
|
|
|
} else { |
6252
|
|
|
|
|
|
|
# save all main XMP segments (should normally be only one) |
6253
|
1
|
50
|
|
|
|
7
|
$extendedXMP{Main} = [] unless $extendedXMP{Main}; |
6254
|
1
|
|
|
|
|
5
|
push @{$extendedXMP{Main}}, substr($$segDataPt, length $xmpAPP1hdr); |
|
1
|
|
|
|
|
5
|
|
6255
|
|
|
|
|
|
|
} |
6256
|
|
|
|
|
|
|
# continue processing only if we have read all the segments |
6257
|
3
|
100
|
|
|
|
15
|
next Marker if $dirCount{XMP}; |
6258
|
|
|
|
|
|
|
# reconstruct an XMP super-segment |
6259
|
1
|
|
|
|
|
3
|
$$segDataPt = $xmpAPP1hdr; |
6260
|
1
|
|
|
|
|
3
|
my $goodGuid = ''; |
6261
|
1
|
|
|
|
|
3
|
foreach (@{$extendedXMP{Main}}) { |
|
1
|
|
|
|
|
4
|
|
6262
|
|
|
|
|
|
|
# get the HasExtendedXMP GUID if it exists |
6263
|
1
|
50
|
|
|
|
9
|
if (/:HasExtendedXMP\s*(=\s*['"]|>)(\w{32})/) { |
6264
|
|
|
|
|
|
|
# warn of subsequent XMP blocks specifying a different |
6265
|
|
|
|
|
|
|
# HasExtendedXMP (have never seen this) |
6266
|
1
|
50
|
33
|
|
|
5
|
if ($goodGuid and $goodGuid ne $2) { |
6267
|
0
|
|
|
|
|
0
|
$self->WarnOnce('Multiple XMP segments specifying different extended XMP GUID'); |
6268
|
|
|
|
|
|
|
} |
6269
|
1
|
|
|
|
|
4
|
$goodGuid = $2; # GUID for the standard extended XMP |
6270
|
|
|
|
|
|
|
} |
6271
|
1
|
|
|
|
|
4
|
$$segDataPt .= $_; |
6272
|
|
|
|
|
|
|
} |
6273
|
|
|
|
|
|
|
# GUID of the extended XMP that we want to read |
6274
|
1
|
|
50
|
|
|
7
|
my $readGuid = $$self{OPTIONS}{ExtendedXMP} || 0; |
6275
|
1
|
50
|
|
|
|
5
|
$readGuid = $goodGuid if $readGuid eq '1'; |
6276
|
1
|
|
|
|
|
7
|
foreach $guid (sort keys %extendedXMP) { |
6277
|
2
|
100
|
|
|
|
8
|
next unless length $guid == 32; # ignore other (internal) keys |
6278
|
1
|
50
|
33
|
|
|
4
|
if ($guid ne $readGuid and $readGuid ne '2') { |
6279
|
0
|
0
|
|
|
|
0
|
my $non = $guid eq $goodGuid ? '' : 'non-'; |
6280
|
0
|
|
|
|
|
0
|
$self->Warn("Ignored ${non}standard extended XMP (GUID $guid)"); |
6281
|
0
|
|
|
|
|
0
|
next; |
6282
|
|
|
|
|
|
|
} |
6283
|
1
|
50
|
|
|
|
5
|
if ($guid ne $goodGuid) { |
6284
|
0
|
|
|
|
|
0
|
$self->Warn("Reading non-standard extended XMP (GUID $guid)"); |
6285
|
|
|
|
|
|
|
} |
6286
|
1
|
|
|
|
|
2
|
$extXMP = $extendedXMP{$guid}; |
6287
|
1
|
50
|
|
|
|
6
|
next unless ref $extXMP eq 'HASH'; # (just to be safe) |
6288
|
1
|
|
|
|
|
3
|
my $size = $$extXMP{Size}; |
6289
|
1
|
|
|
|
|
4
|
my (@offsets, $off); |
6290
|
1
|
|
|
|
|
5
|
for ($off=0; $off<$size; ) { |
6291
|
2
|
50
|
|
|
|
8
|
last unless defined $$extXMP{$off}; |
6292
|
2
|
|
|
|
|
4
|
push @offsets, $off; |
6293
|
2
|
|
|
|
|
7
|
$off += length $$extXMP{$off}; |
6294
|
|
|
|
|
|
|
} |
6295
|
1
|
50
|
|
|
|
5
|
if ($off == $size) { |
6296
|
|
|
|
|
|
|
# add all XMP to super-segment |
6297
|
1
|
|
|
|
|
7
|
$$segDataPt .= $$extXMP{$_} foreach @offsets; |
6298
|
|
|
|
|
|
|
} else { |
6299
|
0
|
|
|
|
|
0
|
$self->Error("Incomplete extended XMP (GUID $guid)", 1); |
6300
|
|
|
|
|
|
|
} |
6301
|
|
|
|
|
|
|
} |
6302
|
1
|
50
|
|
|
|
6
|
$self->Error("$extendedXMP{Error} in extended XMP", 1) if $extendedXMP{Error}; |
6303
|
|
|
|
|
|
|
} |
6304
|
12
|
|
|
|
|
43
|
my $start = length $xmpAPP1hdr; |
6305
|
12
|
|
|
|
|
66
|
my $tagTablePtr = GetTagTable('Image::ExifTool::XMP::Main'); |
6306
|
12
|
|
|
|
|
111
|
my %dirInfo = ( |
6307
|
|
|
|
|
|
|
DataPt => $segDataPt, |
6308
|
|
|
|
|
|
|
DirStart => $start, |
6309
|
|
|
|
|
|
|
Parent => $markerName, |
6310
|
|
|
|
|
|
|
# limit XMP size and create extended XMP if necessary |
6311
|
|
|
|
|
|
|
MaxDataLen => $maxXMPLen - length($xmpAPP1hdr), |
6312
|
|
|
|
|
|
|
); |
6313
|
12
|
|
|
|
|
97
|
my $newData = $self->WriteDirectory(\%dirInfo, $tagTablePtr); |
6314
|
12
|
100
|
|
|
|
62
|
if (defined $newData) { |
6315
|
9
|
|
|
|
|
32
|
undef %extendedXMP; |
6316
|
9
|
100
|
|
|
|
48
|
if (length $newData) { |
6317
|
|
|
|
|
|
|
# write multi-segment XMP (XMP plus extended XMP if necessary) |
6318
|
|
|
|
|
|
|
WriteMultiXMP($self, $outfile, \$newData, $dirInfo{ExtendedXMP}, |
6319
|
7
|
50
|
|
|
|
59
|
$dirInfo{ExtendedGUID}) or $err = 1; |
6320
|
7
|
|
|
|
|
29
|
undef $$segDataPt; # free the old buffer |
6321
|
7
|
|
|
|
|
58
|
next Marker; |
6322
|
|
|
|
|
|
|
} else { |
6323
|
2
|
|
|
|
|
7
|
$$segDataPt = ''; # delete the XMP |
6324
|
|
|
|
|
|
|
} |
6325
|
|
|
|
|
|
|
} else { |
6326
|
3
|
50
|
|
|
|
15
|
$verbose and print $out " [XMP rewritten with no changes]\n"; |
6327
|
3
|
50
|
|
|
|
16
|
if ($doneDir{XMP} > 1) { |
6328
|
|
|
|
|
|
|
# re-write original multi-segment XMP |
6329
|
0
|
|
|
|
|
0
|
my ($dat, $guid, $extXMP, $off); |
6330
|
0
|
|
|
|
|
0
|
foreach $dat (@{$extendedXMP{Main}}) { # main XMP |
|
0
|
|
|
|
|
0
|
|
6331
|
0
|
0
|
|
|
|
0
|
next unless length $dat; |
6332
|
0
|
|
|
|
|
0
|
$s = pack('n', length($xmpAPP1hdr) + length($dat) + 2); |
6333
|
0
|
0
|
|
|
|
0
|
Write($outfile, $hdr, $s, $xmpAPP1hdr, $dat) or $err = 1; |
6334
|
|
|
|
|
|
|
} |
6335
|
0
|
|
|
|
|
0
|
foreach $guid (sort keys %extendedXMP) { # extended XMP |
6336
|
0
|
0
|
|
|
|
0
|
next unless length $guid == 32; |
6337
|
0
|
|
|
|
|
0
|
$extXMP = $extendedXMP{$guid}; |
6338
|
0
|
0
|
|
|
|
0
|
next unless ref $extXMP eq 'HASH'; |
6339
|
0
|
0
|
|
|
|
0
|
my $size = $$extXMP{Size} or next; |
6340
|
0
|
|
|
|
|
0
|
for ($off=0; defined $$extXMP{$off}; $off += length $$extXMP{$off}) { |
6341
|
0
|
|
|
|
|
0
|
$s = pack('n', length($xmpExtAPP1hdr) + length($$extXMP{$off}) + 42); |
6342
|
|
|
|
|
|
|
Write($outfile, $hdr, $s, $xmpExtAPP1hdr, $guid, |
6343
|
0
|
0
|
|
|
|
0
|
pack('N2', $size, $off), $$extXMP{$off}) or $err = 1; |
6344
|
|
|
|
|
|
|
} |
6345
|
|
|
|
|
|
|
} |
6346
|
0
|
|
|
|
|
0
|
undef $$segDataPt; # free the old buffer |
6347
|
0
|
|
|
|
|
0
|
undef %extendedXMP; |
6348
|
0
|
|
|
|
|
0
|
next Marker; |
6349
|
|
|
|
|
|
|
} |
6350
|
|
|
|
|
|
|
# continue on to re-write original single-segment XMP |
6351
|
|
|
|
|
|
|
} |
6352
|
5
|
100
|
|
|
|
34
|
$del = 1 unless length $$segDataPt; |
6353
|
|
|
|
|
|
|
} elsif ($$segDataPt =~ /^http/ or $$segDataPt =~ /
|
6354
|
0
|
|
|
|
|
0
|
$self->Warn('Ignored APP1 XMP segment with non-standard header', 1); |
6355
|
|
|
|
|
|
|
} |
6356
|
|
|
|
|
|
|
} elsif ($marker == 0xe2) { # APP2 (ICC Profile, FPXR, MPF) |
6357
|
0
|
0
|
0
|
|
|
0
|
if ($$segDataPt =~ /^ICC_PROFILE\0/ and $length >= 14) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
6358
|
0
|
|
|
|
|
0
|
$segType = 'ICC_Profile'; |
6359
|
0
|
0
|
|
|
|
0
|
$$delGroup{ICC_Profile} and $del = 1, last; |
6360
|
|
|
|
|
|
|
# must concatenate blocks of profile |
6361
|
0
|
|
|
|
|
0
|
my $chunkNum = Get8u($segDataPt, 12); |
6362
|
0
|
|
|
|
|
0
|
my $chunksTot = Get8u($segDataPt, 13); |
6363
|
0
|
0
|
|
|
|
0
|
if (defined $iccChunksTotal) { |
6364
|
|
|
|
|
|
|
# abort parsing ICC_Profile if the total chunk count is inconsistent |
6365
|
0
|
0
|
0
|
|
|
0
|
if ($chunksTot != $iccChunksTotal and defined $iccChunkCount) { |
6366
|
|
|
|
|
|
|
# an error because the accumulated profile data will be lost |
6367
|
0
|
|
|
|
|
0
|
$self->Error('Inconsistent ICC_Profile chunk count', 1); |
6368
|
0
|
|
|
|
|
0
|
undef $iccChunkCount; # abort ICC_Profile parsing |
6369
|
0
|
|
|
|
|
0
|
undef $chunkNum; # avoid 2nd warning below |
6370
|
0
|
|
|
|
|
0
|
++$$self{CHANGED}; # we are deleting the bad chunks before this one |
6371
|
|
|
|
|
|
|
} |
6372
|
|
|
|
|
|
|
} else { |
6373
|
0
|
|
|
|
|
0
|
$iccChunkCount = 0; |
6374
|
0
|
|
|
|
|
0
|
$iccChunksTotal = $chunksTot; |
6375
|
0
|
0
|
|
|
|
0
|
$self->Warn('ICC_Profile chunk count is zero') if !$chunksTot; |
6376
|
|
|
|
|
|
|
} |
6377
|
0
|
0
|
|
|
|
0
|
if (defined $iccChunkCount) { |
|
|
0
|
|
|
|
|
|
6378
|
|
|
|
|
|
|
# save this chunk |
6379
|
0
|
0
|
|
|
|
0
|
if (defined $iccChunk[$chunkNum]) { |
6380
|
0
|
|
|
|
|
0
|
$self->Warn("Duplicate ICC_Profile chunk number $chunkNum"); |
6381
|
0
|
|
|
|
|
0
|
$iccChunk[$chunkNum] .= substr($$segDataPt, 14); |
6382
|
|
|
|
|
|
|
} else { |
6383
|
0
|
|
|
|
|
0
|
$iccChunk[$chunkNum] = substr($$segDataPt, 14); |
6384
|
|
|
|
|
|
|
} |
6385
|
|
|
|
|
|
|
# continue accumulating chunks unless we have all of them |
6386
|
0
|
0
|
|
|
|
0
|
next Marker unless ++$iccChunkCount >= $iccChunksTotal; |
6387
|
0
|
|
|
|
|
0
|
undef $iccChunkCount; # prevent reprocessing |
6388
|
0
|
|
|
|
|
0
|
$doneDir{ICC_Profile} = 1; |
6389
|
|
|
|
|
|
|
# combine the ICC_Profile chunks |
6390
|
0
|
|
|
|
|
0
|
my $icc_profile = ''; |
6391
|
0
|
|
0
|
|
|
0
|
defined $_ and $icc_profile .= $_ foreach @iccChunk; |
6392
|
0
|
|
|
|
|
0
|
undef @iccChunk; # free memory |
6393
|
0
|
|
|
|
|
0
|
$segDataPt = \$icc_profile; |
6394
|
0
|
|
|
|
|
0
|
$length = length $icc_profile; |
6395
|
0
|
|
|
|
|
0
|
my $tagTablePtr = GetTagTable('Image::ExifTool::ICC_Profile::Main'); |
6396
|
0
|
|
|
|
|
0
|
my %dirInfo = ( |
6397
|
|
|
|
|
|
|
DataPt => $segDataPt, |
6398
|
|
|
|
|
|
|
DataPos => $segPos + 14, |
6399
|
|
|
|
|
|
|
DataLen => $length, |
6400
|
|
|
|
|
|
|
DirStart => 0, |
6401
|
|
|
|
|
|
|
DirLen => $length, |
6402
|
|
|
|
|
|
|
Parent => $markerName, |
6403
|
|
|
|
|
|
|
); |
6404
|
0
|
|
|
|
|
0
|
my $newData = $self->WriteDirectory(\%dirInfo, $tagTablePtr); |
6405
|
0
|
0
|
|
|
|
0
|
if (defined $newData) { |
6406
|
0
|
|
|
|
|
0
|
undef $$segDataPt; # free the old buffer |
6407
|
0
|
|
|
|
|
0
|
$segDataPt = \$newData; |
6408
|
|
|
|
|
|
|
} |
6409
|
0
|
0
|
|
|
|
0
|
length $$segDataPt or $del = 1, last; |
6410
|
|
|
|
|
|
|
# write as ICC multi-segment |
6411
|
0
|
0
|
|
|
|
0
|
WriteMultiSegment($outfile, $marker, "ICC_PROFILE\0", $segDataPt, 'ICC') or $err = 1; |
6412
|
0
|
|
|
|
|
0
|
undef $$segDataPt; |
6413
|
0
|
|
|
|
|
0
|
next Marker; |
6414
|
|
|
|
|
|
|
} elsif (defined $chunkNum) { |
6415
|
0
|
|
|
|
|
0
|
$self->WarnOnce('Invalid or extraneous ICC_Profile chunk(s)'); |
6416
|
|
|
|
|
|
|
# fall through to preserve this extra profile... |
6417
|
|
|
|
|
|
|
} |
6418
|
|
|
|
|
|
|
} elsif ($$segDataPt =~ /^FPXR\0/) { |
6419
|
0
|
|
|
|
|
0
|
$segType = 'FPXR'; |
6420
|
0
|
0
|
|
|
|
0
|
$$delGroup{FlashPix} and $del = 1; |
6421
|
|
|
|
|
|
|
} elsif ($$segDataPt =~ /^MPF\0/) { |
6422
|
0
|
|
|
|
|
0
|
$segType = 'MPF'; |
6423
|
0
|
0
|
|
|
|
0
|
$$delGroup{MPF} and $del = 1; |
6424
|
|
|
|
|
|
|
} |
6425
|
|
|
|
|
|
|
} elsif ($marker == 0xe3) { # APP3 (Kodak Meta) |
6426
|
1
|
50
|
|
|
|
13
|
if ($$segDataPt =~ /^(Meta|META|Exif)\0\0/) { |
6427
|
1
|
|
|
|
|
5
|
$segType = 'Kodak Meta'; |
6428
|
1
|
50
|
|
|
|
7
|
$$delGroup{Meta} and $del = 1, last; |
6429
|
1
|
50
|
|
|
|
6
|
$doneDir{Meta} and $self->Warn('Multiple APP3 Meta segments'); |
6430
|
1
|
|
|
|
|
3
|
$doneDir{Meta} = 1; |
6431
|
1
|
50
|
|
|
|
5
|
last unless $$editDirs{Meta}; |
6432
|
|
|
|
|
|
|
# rewrite Meta IFD as if this were a TIFF file in memory |
6433
|
1
|
|
|
|
|
11
|
my %dirInfo = ( |
6434
|
|
|
|
|
|
|
DataPt => $segDataPt, |
6435
|
|
|
|
|
|
|
DataPos => -6, # (remember: relative to Base!) |
6436
|
|
|
|
|
|
|
DirStart => 6, |
6437
|
|
|
|
|
|
|
Base => $segPos + 6, |
6438
|
|
|
|
|
|
|
Parent => $markerName, |
6439
|
|
|
|
|
|
|
DirName => 'Meta', |
6440
|
|
|
|
|
|
|
); |
6441
|
|
|
|
|
|
|
# write new data to memory |
6442
|
1
|
|
|
|
|
6
|
my $tagTablePtr = GetTagTable('Image::ExifTool::Kodak::Meta'); |
6443
|
1
|
|
|
|
|
10
|
my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr, \&WriteTIFF); |
6444
|
1
|
50
|
|
|
|
8
|
if (defined $buff) { |
6445
|
|
|
|
|
|
|
# update segment with new data |
6446
|
1
|
|
|
|
|
7
|
$$segDataPt = substr($$segDataPt,0,6) . $buff; |
6447
|
|
|
|
|
|
|
} else { |
6448
|
0
|
0
|
|
|
|
0
|
last Marker unless $self->Options('IgnoreMinorErrors'); |
6449
|
|
|
|
|
|
|
} |
6450
|
|
|
|
|
|
|
# delete segment if IFD contains no entries |
6451
|
1
|
50
|
|
|
|
9
|
$del = 1 unless length($$segDataPt) > 6; |
6452
|
|
|
|
|
|
|
} |
6453
|
|
|
|
|
|
|
} elsif ($marker == 0xe5) { # APP5 (Ricoh RMETA) |
6454
|
0
|
0
|
|
|
|
0
|
if ($$segDataPt =~ /^RMETA\0/) { |
6455
|
0
|
|
|
|
|
0
|
$segType = 'Ricoh RMETA'; |
6456
|
0
|
0
|
|
|
|
0
|
$$delGroup{RMETA} and $del = 1; |
6457
|
|
|
|
|
|
|
} |
6458
|
|
|
|
|
|
|
} elsif ($marker == 0xec) { # APP12 (Ducky) |
6459
|
1
|
50
|
|
|
|
16
|
if ($$segDataPt =~ /^Ducky/) { |
6460
|
1
|
|
|
|
|
6
|
$segType = 'Ducky'; |
6461
|
1
|
50
|
|
|
|
10
|
$$delGroup{Ducky} and $del = 1, last; |
6462
|
1
|
50
|
|
|
|
6
|
$doneDir{Ducky} and $self->Warn('Multiple APP12 Ducky segments'); |
6463
|
1
|
|
|
|
|
4
|
$doneDir{Ducky} = 1; |
6464
|
1
|
50
|
|
|
|
9
|
last unless $$editDirs{Ducky}; |
6465
|
1
|
|
|
|
|
6
|
my $tagTablePtr = GetTagTable('Image::ExifTool::APP12::Ducky'); |
6466
|
1
|
|
|
|
|
16
|
my %dirInfo = ( |
6467
|
|
|
|
|
|
|
DataPt => $segDataPt, |
6468
|
|
|
|
|
|
|
DataPos => $segPos, |
6469
|
|
|
|
|
|
|
DataLen => $length, |
6470
|
|
|
|
|
|
|
DirStart => 5, # directory starts after identifier |
6471
|
|
|
|
|
|
|
DirLen => $length-5, |
6472
|
|
|
|
|
|
|
Parent => $markerName, |
6473
|
|
|
|
|
|
|
); |
6474
|
1
|
|
|
|
|
6
|
my $newData = $self->WriteDirectory(\%dirInfo, $tagTablePtr); |
6475
|
1
|
50
|
|
|
|
7
|
if (defined $newData) { |
6476
|
1
|
|
|
|
|
2
|
undef $$segDataPt; # free the old buffer |
6477
|
|
|
|
|
|
|
# add header to new segment unless empty |
6478
|
1
|
50
|
|
|
|
9
|
$newData = 'Ducky' . $newData if length $newData; |
6479
|
1
|
|
|
|
|
4
|
$segDataPt = \$newData; |
6480
|
|
|
|
|
|
|
} |
6481
|
1
|
50
|
|
|
|
6
|
$del = 1 unless length $$segDataPt; |
6482
|
|
|
|
|
|
|
} |
6483
|
|
|
|
|
|
|
} elsif ($marker == 0xed) { # APP13 (Photoshop) |
6484
|
9
|
100
|
|
|
|
153
|
if ($$segDataPt =~ /^$psAPP13hdr/) { |
6485
|
8
|
|
|
|
|
34
|
$segType = 'Photoshop'; |
6486
|
|
|
|
|
|
|
# add this data to the combined data if it exists |
6487
|
8
|
50
|
|
|
|
44
|
if (defined $combinedSegData) { |
6488
|
0
|
|
|
|
|
0
|
$combinedSegData .= substr($$segDataPt,length($psAPP13hdr)); |
6489
|
0
|
|
|
|
|
0
|
$segDataPt = \$combinedSegData; |
6490
|
0
|
|
|
|
|
0
|
$length = length $combinedSegData; # update length |
6491
|
|
|
|
|
|
|
} |
6492
|
|
|
|
|
|
|
# peek ahead to see if the next segment is photoshop data too |
6493
|
8
|
50
|
|
|
|
46
|
if ($dirOrder[0] eq 'Photoshop') { |
6494
|
|
|
|
|
|
|
# initialize combined data if necessary |
6495
|
0
|
0
|
|
|
|
0
|
$combinedSegData = $$segDataPt unless defined $combinedSegData; |
6496
|
0
|
|
|
|
|
0
|
next Marker; # get the next segment to combine |
6497
|
|
|
|
|
|
|
} |
6498
|
8
|
50
|
|
|
|
61
|
if ($doneDir{Photoshop}) { |
6499
|
0
|
|
|
|
|
0
|
$self->Warn('Multiple Photoshop records'); |
6500
|
|
|
|
|
|
|
# only rewrite the first Photoshop segment when deleting this group |
6501
|
|
|
|
|
|
|
# (to remove multiples when deleting and adding back in one step) |
6502
|
0
|
0
|
|
|
|
0
|
$$delGroup{Photoshop} and $del = 1, last; |
6503
|
|
|
|
|
|
|
} |
6504
|
8
|
|
|
|
|
41
|
$doneDir{Photoshop} = 1; |
6505
|
|
|
|
|
|
|
# process APP13 Photoshop record |
6506
|
8
|
|
|
|
|
34
|
my $tagTablePtr = GetTagTable('Image::ExifTool::Photoshop::Main'); |
6507
|
8
|
|
|
|
|
110
|
my %dirInfo = ( |
6508
|
|
|
|
|
|
|
DataPt => $segDataPt, |
6509
|
|
|
|
|
|
|
DataPos => $segPos, |
6510
|
|
|
|
|
|
|
DataLen => $length, |
6511
|
|
|
|
|
|
|
DirStart => 14, # directory starts after identifier |
6512
|
|
|
|
|
|
|
DirLen => $length-14, |
6513
|
|
|
|
|
|
|
Parent => $markerName, |
6514
|
|
|
|
|
|
|
); |
6515
|
8
|
|
|
|
|
49
|
my $newData = $self->WriteDirectory(\%dirInfo, $tagTablePtr); |
6516
|
8
|
50
|
|
|
|
47
|
if (defined $newData) { |
6517
|
8
|
|
|
|
|
29
|
undef $$segDataPt; # free the old buffer |
6518
|
8
|
|
|
|
|
28
|
$segDataPt = \$newData; |
6519
|
|
|
|
|
|
|
} |
6520
|
8
|
100
|
|
|
|
75
|
length $$segDataPt or $del = 1, last; |
6521
|
|
|
|
|
|
|
# write as multi-segment |
6522
|
6
|
50
|
|
|
|
33
|
WriteMultiSegment($outfile, $marker, $psAPP13hdr, $segDataPt) or $err = 1; |
6523
|
6
|
|
|
|
|
17
|
undef $combinedSegData; |
6524
|
6
|
|
|
|
|
23
|
undef $$segDataPt; |
6525
|
6
|
|
|
|
|
46
|
next Marker; |
6526
|
|
|
|
|
|
|
} |
6527
|
|
|
|
|
|
|
} elsif ($marker == 0xee) { # APP14 (Adobe) |
6528
|
4
|
50
|
|
|
|
34
|
if ($$segDataPt =~ /^Adobe/) { |
6529
|
4
|
|
|
|
|
14
|
$segType = 'Adobe'; |
6530
|
|
|
|
|
|
|
# delete it and replace it later if editing |
6531
|
4
|
50
|
33
|
|
|
34
|
if ($$delGroup{Adobe} or $$editDirs{Adobe}) { |
6532
|
0
|
|
|
|
|
0
|
$del = 1; |
6533
|
0
|
|
|
|
|
0
|
undef $doneDir{Adobe}; # so we can add it back again above |
6534
|
|
|
|
|
|
|
} |
6535
|
|
|
|
|
|
|
} |
6536
|
|
|
|
|
|
|
} elsif ($marker == 0xfe) { # COM (JPEG comment) |
6537
|
4
|
|
|
|
|
14
|
my $newComment; |
6538
|
4
|
50
|
|
|
|
26
|
unless ($doneDir{COM}) { |
6539
|
4
|
|
|
|
|
15
|
$doneDir{COM} = 1; |
6540
|
4
|
100
|
100
|
|
|
29
|
unless ($$delGroup{File} and $$delGroup{File} != 2) { |
6541
|
3
|
|
|
|
|
14
|
my $tagInfo = $Image::ExifTool::Extra{Comment}; |
6542
|
3
|
|
|
|
|
18
|
my $nvHash = $self->GetNewValueHash($tagInfo); |
6543
|
3
|
|
|
|
|
21
|
my $val = $segData; |
6544
|
3
|
|
|
|
|
14
|
$val =~ s/\0+$//; # allow for stupid software that adds NULL terminator |
6545
|
3
|
50
|
33
|
|
|
16
|
if ($self->IsOverwriting($nvHash, $val) or $$delGroup{File}) { |
6546
|
3
|
|
|
|
|
12
|
$newComment = $self->GetNewValue($nvHash); |
6547
|
|
|
|
|
|
|
} else { |
6548
|
0
|
|
|
|
|
0
|
delete $$editDirs{COM}; # we aren't editing COM after all |
6549
|
0
|
|
|
|
|
0
|
last; |
6550
|
|
|
|
|
|
|
} |
6551
|
|
|
|
|
|
|
} |
6552
|
|
|
|
|
|
|
} |
6553
|
4
|
|
|
|
|
36
|
$self->VerboseValue('- Comment', $$segDataPt); |
6554
|
4
|
100
|
|
|
|
21
|
if (defined $newComment) { |
6555
|
|
|
|
|
|
|
# write out the comments |
6556
|
2
|
|
|
|
|
12
|
$self->VerboseValue('+ Comment', $newComment); |
6557
|
2
|
50
|
|
|
|
15
|
WriteMultiSegment($outfile, 0xfe, '', \$newComment) or $err = 1; |
6558
|
|
|
|
|
|
|
} else { |
6559
|
2
|
50
|
|
|
|
8
|
$verbose and print $out " Deleting COM segment\n"; |
6560
|
|
|
|
|
|
|
} |
6561
|
4
|
|
|
|
|
14
|
++$$self{CHANGED}; # increment the changed flag |
6562
|
4
|
|
|
|
|
10
|
undef $segDataPt; # don't write existing comment |
6563
|
|
|
|
|
|
|
} |
6564
|
53
|
|
|
|
|
133
|
last; # didn't want to loop anyway |
6565
|
|
|
|
|
|
|
} |
6566
|
|
|
|
|
|
|
|
6567
|
|
|
|
|
|
|
# delete necessary segments (including unknown segments if deleting all) |
6568
|
460
|
100
|
100
|
|
|
2334
|
if ($del or ($$delGroup{'*'} and not $segType and $marker>=0xe0 and $marker<=0xef)) { |
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
6569
|
13
|
100
|
|
|
|
45
|
$segType = 'unknown' unless $segType; |
6570
|
13
|
50
|
|
|
|
49
|
$verbose and print $out " Deleting $markerName $segType segment\n"; |
6571
|
13
|
|
|
|
|
34
|
++$$self{CHANGED}; |
6572
|
13
|
|
|
|
|
41
|
next Marker; |
6573
|
|
|
|
|
|
|
} |
6574
|
|
|
|
|
|
|
# write out this segment if $segDataPt is still defined |
6575
|
447
|
100
|
66
|
|
|
2063
|
if (defined $segDataPt and defined $$segDataPt) { |
6576
|
|
|
|
|
|
|
# write the data for this record (the data could have been |
6577
|
|
|
|
|
|
|
# modified, so recalculate the length word) |
6578
|
443
|
|
|
|
|
890
|
my $size = length($$segDataPt); |
6579
|
443
|
50
|
|
|
|
1075
|
if ($size > $maxSegmentLen) { |
6580
|
0
|
0
|
|
|
|
0
|
$segType or $segType = 'Unknown'; |
6581
|
0
|
|
|
|
|
0
|
$self->Error("$segType $markerName segment too large! ($size bytes)"); |
6582
|
0
|
|
|
|
|
0
|
$err = 1; |
6583
|
|
|
|
|
|
|
} else { |
6584
|
443
|
|
|
|
|
1402
|
$s = pack('n', length($$segDataPt) + 2); |
6585
|
443
|
50
|
|
|
|
1309
|
Write($outfile, $hdr, $s, $$segDataPt) or $err = 1; |
6586
|
|
|
|
|
|
|
} |
6587
|
443
|
|
|
|
|
1145
|
undef $$segDataPt; # free the buffer |
6588
|
443
|
|
|
|
|
941
|
undef $segDataPt; |
6589
|
|
|
|
|
|
|
} |
6590
|
|
|
|
|
|
|
} |
6591
|
|
|
|
|
|
|
# make sure the ICC_Profile was complete |
6592
|
111
|
50
|
|
|
|
588
|
$self->Error('Incomplete ICC_Profile record', 1) if defined $iccChunkCount; |
6593
|
111
|
100
|
|
|
|
475
|
pop @$path if @$path > $pn; |
6594
|
|
|
|
|
|
|
# if oldOutfile is still set, there was an error copying the JPEG |
6595
|
111
|
50
|
|
|
|
372
|
$oldOutfile and return 0; |
6596
|
111
|
50
|
|
|
|
377
|
if ($rtnVal) { |
6597
|
|
|
|
|
|
|
# add any new trailers we are creating |
6598
|
111
|
|
|
|
|
804
|
my $trailPt = $self->AddNewTrailers(); |
6599
|
111
|
100
|
50
|
|
|
491
|
Write($outfile, $$trailPt) or $err = 1 if $trailPt; |
6600
|
|
|
|
|
|
|
} |
6601
|
|
|
|
|
|
|
# set return value to -1 if we only had a write error |
6602
|
111
|
50
|
33
|
|
|
786
|
$rtnVal = -1 if $rtnVal and $err; |
6603
|
111
|
50
|
66
|
|
|
522
|
if ($creatingEXV and $rtnVal > 0 and not $$self{CHANGED}) { |
|
|
|
66
|
|
|
|
|
6604
|
0
|
|
|
|
|
0
|
$self->Error('Nothing written'); |
6605
|
0
|
|
|
|
|
0
|
$rtnVal = -1; |
6606
|
|
|
|
|
|
|
} |
6607
|
111
|
|
|
|
|
1295
|
return $rtnVal; |
6608
|
|
|
|
|
|
|
} |
6609
|
|
|
|
|
|
|
|
6610
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
6611
|
|
|
|
|
|
|
# Validate an image for writing |
6612
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object reference, 1) raw value reference |
6613
|
|
|
|
|
|
|
# Returns: error string or undef on success |
6614
|
|
|
|
|
|
|
sub CheckImage($$) |
6615
|
|
|
|
|
|
|
{ |
6616
|
138
|
|
|
138
|
0
|
550
|
my ($self, $valPtr) = @_; |
6617
|
138
|
100
|
100
|
|
|
1206
|
if (length($$valPtr) and $$valPtr!~/^\xff\xd8/ and not |
|
|
|
100
|
|
|
|
|
6618
|
|
|
|
|
|
|
$self->Options('IgnoreMinorErrors')) |
6619
|
|
|
|
|
|
|
{ |
6620
|
25
|
|
|
|
|
272
|
return '[Minor] Not a valid image'; |
6621
|
|
|
|
|
|
|
} |
6622
|
113
|
|
|
|
|
984
|
return undef; |
6623
|
|
|
|
|
|
|
} |
6624
|
|
|
|
|
|
|
|
6625
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
6626
|
|
|
|
|
|
|
# check a value for validity |
6627
|
|
|
|
|
|
|
# Inputs: 0) value reference, 1) format string, 2) optional count |
6628
|
|
|
|
|
|
|
# Returns: error string, or undef on success |
6629
|
|
|
|
|
|
|
# Notes: May modify value (if a count is specified for a string, it is null-padded |
6630
|
|
|
|
|
|
|
# to the specified length, and floating point values are rounded to integer if required) |
6631
|
|
|
|
|
|
|
sub CheckValue($$;$) |
6632
|
|
|
|
|
|
|
{ |
6633
|
19175
|
|
|
19175
|
0
|
47081
|
my ($valPtr, $format, $count) = @_; |
6634
|
19175
|
|
|
|
|
34188
|
my (@vals, $val, $n); |
6635
|
|
|
|
|
|
|
|
6636
|
19175
|
100
|
100
|
|
|
72805
|
if ($format eq 'string' or $format eq 'undef') { |
6637
|
2487
|
100
|
66
|
|
|
11003
|
return undef unless $count and $count > 0; |
6638
|
301
|
|
|
|
|
718
|
my $len = length($$valPtr); |
6639
|
301
|
100
|
|
|
|
1052
|
if ($format eq 'string') { |
6640
|
198
|
100
|
|
|
|
675
|
$len >= $count and return 'String too long'; |
6641
|
|
|
|
|
|
|
} else { |
6642
|
103
|
50
|
|
|
|
394
|
$len > $count and return 'Data too long'; |
6643
|
|
|
|
|
|
|
} |
6644
|
291
|
100
|
|
|
|
811
|
if ($len < $count) { |
6645
|
232
|
|
|
|
|
880
|
$$valPtr .= "\0" x ($count - $len); |
6646
|
|
|
|
|
|
|
} |
6647
|
291
|
|
|
|
|
965
|
return undef; |
6648
|
|
|
|
|
|
|
} |
6649
|
16688
|
100
|
66
|
|
|
45004
|
if ($count and $count != 1) { |
6650
|
1923
|
|
|
|
|
6581
|
@vals = split(' ',$$valPtr); |
6651
|
1923
|
100
|
100
|
|
|
5099
|
$count < 0 and ($count = @vals or return undef); |
6652
|
|
|
|
|
|
|
} else { |
6653
|
14765
|
|
|
|
|
24106
|
$count = 1; |
6654
|
14765
|
|
|
|
|
32785
|
@vals = ( $$valPtr ); |
6655
|
|
|
|
|
|
|
} |
6656
|
16669
|
100
|
|
|
|
37935
|
if (@vals != $count) { |
6657
|
913
|
100
|
|
|
|
2394
|
my $str = @vals > $count ? 'Too many' : 'Not enough'; |
6658
|
913
|
|
|
|
|
3541
|
return "$str values specified ($count required)"; |
6659
|
|
|
|
|
|
|
} |
6660
|
15756
|
|
|
|
|
42566
|
for ($n=0; $n<$count; ++$n) { |
6661
|
18703
|
|
|
|
|
32790
|
$val = shift @vals; |
6662
|
18703
|
100
|
100
|
|
|
70535
|
if ($format =~ /^int/) { |
|
|
100
|
100
|
|
|
|
|
6663
|
|
|
|
|
|
|
# make sure the value is integer |
6664
|
17349
|
100
|
|
|
|
58462
|
unless (IsInt($val)) { |
6665
|
3032
|
100
|
|
|
|
7447
|
if (IsHex($val)) { |
6666
|
7
|
|
|
|
|
32
|
$val = $$valPtr = hex($val); |
6667
|
|
|
|
|
|
|
} else { |
6668
|
|
|
|
|
|
|
# round single floating point values to the nearest integer |
6669
|
3025
|
100
|
100
|
|
|
8556
|
return 'Not an integer' unless IsFloat($val) and $count == 1; |
6670
|
1267
|
100
|
|
|
|
5635
|
$val = $$valPtr = int($val + ($val < 0 ? -0.5 : 0.5)); |
6671
|
|
|
|
|
|
|
} |
6672
|
|
|
|
|
|
|
} |
6673
|
15591
|
50
|
|
|
|
48271
|
my $rng = $intRange{$format} or return "Bad int format: $format"; |
6674
|
15591
|
100
|
|
|
|
38268
|
return "Value below $format minimum" if $val < $$rng[0]; |
6675
|
|
|
|
|
|
|
# (allow 0xfeedfeed code as value for 16-bit pointers) |
6676
|
15290
|
100
|
66
|
|
|
53280
|
return "Value above $format maximum" if $val > $$rng[1] and $val != 0xfeedfeed; |
6677
|
|
|
|
|
|
|
} elsif ($format =~ /^rational/ or $format eq 'float' or $format eq 'double') { |
6678
|
|
|
|
|
|
|
# make sure the value is a valid floating point number |
6679
|
1351
|
100
|
|
|
|
4577
|
unless (IsFloat($val)) { |
6680
|
|
|
|
|
|
|
# allow 'inf', 'undef' and fractional rational values |
6681
|
268
|
100
|
|
|
|
1059
|
if ($format =~ /^rational/) { |
6682
|
232
|
100
|
66
|
|
|
1187
|
next if $val eq 'inf' or $val eq 'undef'; |
6683
|
231
|
100
|
|
|
|
890
|
if ($val =~ m{^([-+]?\d+)/(\d+)$}) { |
6684
|
70
|
50
|
66
|
|
|
419
|
next unless $1 < 0 and $format =~ /u$/; |
6685
|
0
|
|
|
|
|
0
|
return 'Must be an unsigned rational'; |
6686
|
|
|
|
|
|
|
} |
6687
|
|
|
|
|
|
|
} |
6688
|
197
|
|
|
|
|
720
|
return 'Not a floating point number'; |
6689
|
|
|
|
|
|
|
} |
6690
|
1083
|
50
|
66
|
|
|
6888
|
if ($format =~ /^rational\d+u$/ and $val < 0) { |
6691
|
0
|
|
|
|
|
0
|
return 'Must be a positive number'; |
6692
|
|
|
|
|
|
|
} |
6693
|
|
|
|
|
|
|
} |
6694
|
|
|
|
|
|
|
} |
6695
|
13496
|
|
|
|
|
35488
|
return undef; # success! |
6696
|
|
|
|
|
|
|
} |
6697
|
|
|
|
|
|
|
|
6698
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
6699
|
|
|
|
|
|
|
# check new value for binary data block |
6700
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object ref, 1) tagInfo hash ref, 2) raw value ref |
6701
|
|
|
|
|
|
|
# Returns: error string or undef (and may modify value) on success |
6702
|
|
|
|
|
|
|
sub CheckBinaryData($$$) |
6703
|
|
|
|
|
|
|
{ |
6704
|
11776
|
|
|
11776
|
0
|
24966
|
my ($self, $tagInfo, $valPtr) = @_; |
6705
|
11776
|
|
|
|
|
26981
|
my $format = $$tagInfo{Format}; |
6706
|
11776
|
100
|
|
|
|
24889
|
unless ($format) { |
6707
|
4426
|
|
|
|
|
7718
|
my $table = $$tagInfo{Table}; |
6708
|
4426
|
100
|
66
|
|
|
17820
|
if ($table and $$table{FORMAT}) { |
6709
|
3111
|
|
|
|
|
6943
|
$format = $$table{FORMAT}; |
6710
|
|
|
|
|
|
|
} else { |
6711
|
|
|
|
|
|
|
# use default 'int8u' unless specified |
6712
|
1315
|
|
|
|
|
2945
|
$format = 'int8u'; |
6713
|
|
|
|
|
|
|
} |
6714
|
|
|
|
|
|
|
} |
6715
|
11776
|
|
|
|
|
17603
|
my $count; |
6716
|
11776
|
100
|
|
|
|
40313
|
if ($format =~ /(.*)\[(.*)\]/) { |
6717
|
1637
|
|
|
|
|
4791
|
$format = $1; |
6718
|
1637
|
|
|
|
|
3076
|
$count = $2; |
6719
|
|
|
|
|
|
|
# can't evaluate $count now because we don't know $size yet |
6720
|
1637
|
50
|
|
|
|
3720
|
undef $count if $count =~ /\$size/; |
6721
|
|
|
|
|
|
|
} |
6722
|
11776
|
|
|
|
|
30517
|
return CheckValue($valPtr, $format, $count); |
6723
|
|
|
|
|
|
|
} |
6724
|
|
|
|
|
|
|
|
6725
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
6726
|
|
|
|
|
|
|
# Rename a file (with patch for Windows Unicode file names, and other problem) |
6727
|
|
|
|
|
|
|
# Inputs: 0) ExifTool ref, 1) old name, 2) new name |
6728
|
|
|
|
|
|
|
# Returns: true on success |
6729
|
|
|
|
|
|
|
sub Rename($$$) |
6730
|
|
|
|
|
|
|
{ |
6731
|
3
|
|
|
3
|
0
|
18
|
my ($self, $old, $new) = @_; |
6732
|
3
|
|
|
|
|
10
|
my ($result, $try, $winUni); |
6733
|
|
|
|
|
|
|
|
6734
|
3
|
50
|
|
|
|
19
|
if ($self->EncodeFileName($old)) { |
|
|
50
|
|
|
|
|
|
6735
|
0
|
|
|
|
|
0
|
$self->EncodeFileName($new, 1); |
6736
|
0
|
|
|
|
|
0
|
$winUni = 1; |
6737
|
|
|
|
|
|
|
} elsif ($self->EncodeFileName($new)) { |
6738
|
0
|
|
|
|
|
0
|
$old = $_[1]; |
6739
|
0
|
|
|
|
|
0
|
$self->EncodeFileName($old, 1); |
6740
|
0
|
|
|
|
|
0
|
$winUni = 1; |
6741
|
|
|
|
|
|
|
} |
6742
|
3
|
|
|
|
|
14
|
for (;;) { |
6743
|
3
|
50
|
|
|
|
19
|
if ($winUni) { |
6744
|
0
|
|
|
|
|
0
|
$result = eval { Win32API::File::MoveFileExW($old, $new, |
|
0
|
|
|
|
|
0
|
|
6745
|
|
|
|
|
|
|
Win32API::File::MOVEFILE_REPLACE_EXISTING() | |
6746
|
|
|
|
|
|
|
Win32API::File::MOVEFILE_COPY_ALLOWED()) }; |
6747
|
|
|
|
|
|
|
} else { |
6748
|
3
|
|
|
|
|
454
|
$result = rename($old, $new); |
6749
|
|
|
|
|
|
|
} |
6750
|
3
|
50
|
33
|
|
|
28
|
last if $result or $^O ne 'MSWin32'; |
6751
|
|
|
|
|
|
|
# keep trying for up to 0.5 seconds |
6752
|
|
|
|
|
|
|
# (patch for Windows denial-of-service susceptibility) |
6753
|
0
|
|
0
|
|
|
0
|
$try = ($try || 1) + 1; |
6754
|
0
|
0
|
|
|
|
0
|
last if $try > 50; |
6755
|
0
|
|
|
|
|
0
|
select(undef,undef,undef,0.01); # sleep for 0.01 sec |
6756
|
|
|
|
|
|
|
} |
6757
|
3
|
|
|
|
|
24
|
return $result; |
6758
|
|
|
|
|
|
|
} |
6759
|
|
|
|
|
|
|
|
6760
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
6761
|
|
|
|
|
|
|
# Delete a file (with patch for Windows Unicode file names) |
6762
|
|
|
|
|
|
|
# Inputs: 0) ExifTool ref, 1-N) names of files to delete |
6763
|
|
|
|
|
|
|
# Returns: number of files deleted |
6764
|
|
|
|
|
|
|
sub Unlink($@) |
6765
|
|
|
|
|
|
|
{ |
6766
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
6767
|
0
|
|
|
|
|
0
|
my $result = 0; |
6768
|
0
|
|
|
|
|
0
|
while (@_) { |
6769
|
0
|
|
|
|
|
0
|
my $file = shift; |
6770
|
0
|
0
|
|
|
|
0
|
if ($self->EncodeFileName($file)) { |
6771
|
0
|
0
|
|
|
|
0
|
++$result if eval { Win32API::File::DeleteFileW($file) }; |
|
0
|
|
|
|
|
0
|
|
6772
|
|
|
|
|
|
|
} else { |
6773
|
0
|
0
|
|
|
|
0
|
++$result if unlink $file; |
6774
|
|
|
|
|
|
|
} |
6775
|
|
|
|
|
|
|
} |
6776
|
0
|
|
|
|
|
0
|
return $result; |
6777
|
|
|
|
|
|
|
} |
6778
|
|
|
|
|
|
|
|
6779
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
6780
|
|
|
|
|
|
|
# Set file times (Unix seconds since the epoch) |
6781
|
|
|
|
|
|
|
# Inputs: 0) ExifTool ref, 1) file name or ref, 2) access time, 3) modification time, |
6782
|
|
|
|
|
|
|
# 4) inode change or creation time (or undef for any time to avoid setting) |
6783
|
|
|
|
|
|
|
# 5) flag to suppress warning |
6784
|
|
|
|
|
|
|
# Returns: 1 on success, 0 on error |
6785
|
|
|
|
|
|
|
my $k32SetFileTime; |
6786
|
|
|
|
|
|
|
sub SetFileTime($$;$$$$) |
6787
|
|
|
|
|
|
|
{ |
6788
|
0
|
|
|
0
|
0
|
0
|
my ($self, $file, $atime, $mtime, $ctime, $noWarn) = @_; |
6789
|
0
|
|
|
|
|
0
|
my $saveFile; |
6790
|
0
|
|
|
|
|
0
|
local *FH; |
6791
|
|
|
|
|
|
|
|
6792
|
|
|
|
|
|
|
# open file by name if necessary |
6793
|
0
|
0
|
|
|
|
0
|
unless (ref $file) { |
6794
|
|
|
|
|
|
|
# (file will be automatically closed when *FH goes out of scope) |
6795
|
0
|
0
|
|
|
|
0
|
unless ($self->Open(\*FH, $file, '+<')) { |
6796
|
0
|
|
|
|
|
0
|
my $success; |
6797
|
0
|
0
|
0
|
|
|
0
|
if (defined $atime or defined $mtime) { |
6798
|
0
|
|
|
|
|
0
|
my ($a, $m, $c) = $self->GetFileTime($file); |
6799
|
0
|
0
|
|
|
|
0
|
$atime = $a unless defined $atime; |
6800
|
0
|
0
|
|
|
|
0
|
$mtime = $m unless defined $mtime; |
6801
|
0
|
0
|
0
|
|
|
0
|
$success = eval { utime($atime, $mtime, $file) } if defined $atime and defined $mtime; |
|
0
|
|
|
|
|
0
|
|
6802
|
|
|
|
|
|
|
} |
6803
|
0
|
0
|
|
|
|
0
|
$self->Warn('Error opening file for update') unless $success; |
6804
|
0
|
|
|
|
|
0
|
return $success; |
6805
|
|
|
|
|
|
|
} |
6806
|
0
|
|
|
|
|
0
|
$saveFile = $file; |
6807
|
0
|
|
|
|
|
0
|
$file = \*FH; |
6808
|
|
|
|
|
|
|
} |
6809
|
|
|
|
|
|
|
# on Windows, try to work around incorrect file times when daylight saving time is in effect |
6810
|
0
|
0
|
|
|
|
0
|
if ($^O eq 'MSWin32') { |
6811
|
0
|
0
|
|
|
|
0
|
if (not eval { require Win32::API }) { |
|
0
|
0
|
|
|
|
0
|
|
6812
|
0
|
|
|
|
|
0
|
$self->WarnOnce('Install Win32::API for proper handling of Windows file times'); |
6813
|
0
|
|
|
|
|
0
|
} elsif (not eval { require Win32API::File }) { |
6814
|
0
|
|
|
|
|
0
|
$self->WarnOnce('Install Win32API::File for proper handling of Windows file times'); |
6815
|
|
|
|
|
|
|
} else { |
6816
|
|
|
|
|
|
|
# get Win32 handle, needed for SetFileTime |
6817
|
0
|
|
|
|
|
0
|
my $win32Handle = eval { Win32API::File::GetOsFHandle($file) }; |
|
0
|
|
|
|
|
0
|
|
6818
|
0
|
0
|
|
|
|
0
|
unless ($win32Handle) { |
6819
|
0
|
|
|
|
|
0
|
$self->Warn('Win32API::File::GetOsFHandle returned invalid handle'); |
6820
|
0
|
|
|
|
|
0
|
return 0; |
6821
|
|
|
|
|
|
|
} |
6822
|
|
|
|
|
|
|
# convert Unix seconds to FILETIME structs |
6823
|
0
|
|
|
|
|
0
|
my $time; |
6824
|
0
|
|
|
|
|
0
|
foreach $time ($atime, $mtime, $ctime) { |
6825
|
|
|
|
|
|
|
# set to NULL if not defined (i.e. do not change) |
6826
|
0
|
0
|
|
|
|
0
|
defined $time or $time = 0, next; |
6827
|
|
|
|
|
|
|
# convert to 100 ns intervals since 0:00 UTC Jan 1, 1601 |
6828
|
|
|
|
|
|
|
# (89 leap years between 1601 and 1970) |
6829
|
0
|
|
|
|
|
0
|
my $wt = ($time + (((1970-1601)*365+89)*24*3600)) * 1e7; |
6830
|
0
|
|
|
|
|
0
|
my $hi = int($wt / 4294967296); |
6831
|
0
|
|
|
|
|
0
|
$time = pack 'LL', int($wt - $hi * 4294967296), $hi; # pack FILETIME struct |
6832
|
|
|
|
|
|
|
} |
6833
|
0
|
0
|
|
|
|
0
|
unless ($k32SetFileTime) { |
6834
|
0
|
0
|
|
|
|
0
|
return 0 if defined $k32SetFileTime; |
6835
|
0
|
|
|
|
|
0
|
$k32SetFileTime = new Win32::API('KERNEL32', 'SetFileTime', 'NPPP', 'I'); |
6836
|
0
|
0
|
|
|
|
0
|
unless ($k32SetFileTime) { |
6837
|
0
|
|
|
|
|
0
|
$self->Warn('Error calling Win32::API::SetFileTime'); |
6838
|
0
|
|
|
|
|
0
|
$k32SetFileTime = 0; |
6839
|
0
|
|
|
|
|
0
|
return 0; |
6840
|
|
|
|
|
|
|
} |
6841
|
|
|
|
|
|
|
} |
6842
|
0
|
0
|
|
|
|
0
|
unless ($k32SetFileTime->Call($win32Handle, $ctime, $atime, $mtime)) { |
6843
|
0
|
|
|
|
|
0
|
$self->Warn('Win32::API::SetFileTime returned ' . Win32::GetLastError()); |
6844
|
0
|
|
|
|
|
0
|
return 0; |
6845
|
|
|
|
|
|
|
} |
6846
|
0
|
|
|
|
|
0
|
return 1; |
6847
|
|
|
|
|
|
|
} |
6848
|
|
|
|
|
|
|
} |
6849
|
|
|
|
|
|
|
# other OS (or Windows fallback) |
6850
|
0
|
0
|
0
|
|
|
0
|
if (defined $atime and defined $mtime) { |
6851
|
0
|
|
|
|
|
0
|
my $success; |
6852
|
0
|
|
|
|
|
0
|
local $SIG{'__WARN__'} = \&SetWarning; # (this may not be necessary) |
6853
|
0
|
|
|
|
|
0
|
for (;;) { |
6854
|
0
|
|
|
|
|
0
|
undef $evalWarning; |
6855
|
|
|
|
|
|
|
# (this may fail on the first try if futimes is not implemented) |
6856
|
0
|
|
|
|
|
0
|
$success = eval { utime($atime, $mtime, $file) }; |
|
0
|
|
|
|
|
0
|
|
6857
|
0
|
0
|
0
|
|
|
0
|
last if $success or not defined $saveFile; |
6858
|
0
|
|
|
|
|
0
|
close $file; |
6859
|
0
|
|
|
|
|
0
|
$file = $saveFile; |
6860
|
0
|
|
|
|
|
0
|
undef $saveFile; |
6861
|
|
|
|
|
|
|
} |
6862
|
0
|
0
|
|
|
|
0
|
unless ($noWarn) { |
6863
|
0
|
0
|
0
|
|
|
0
|
if ($@ or $evalWarning) { |
|
|
0
|
|
|
|
|
|
6864
|
0
|
|
0
|
|
|
0
|
$self->Warn(CleanWarning($@ || $evalWarning)); |
6865
|
|
|
|
|
|
|
} elsif (not $success) { |
6866
|
0
|
|
|
|
|
0
|
$self->Warn('Error setting file time'); |
6867
|
|
|
|
|
|
|
} |
6868
|
|
|
|
|
|
|
} |
6869
|
0
|
|
|
|
|
0
|
return $success; |
6870
|
|
|
|
|
|
|
} |
6871
|
0
|
|
|
|
|
0
|
return 1; # (nothing to do) |
6872
|
|
|
|
|
|
|
} |
6873
|
|
|
|
|
|
|
|
6874
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
6875
|
|
|
|
|
|
|
# Add data to MD5 checksum |
6876
|
|
|
|
|
|
|
# Inputs: 0) ExifTool ref, 1) RAF ref, 2) data size (or undef to read to end of file), |
6877
|
|
|
|
|
|
|
# 3) data name (or undef for no warnings or messages), 4) flag for no verbose message |
6878
|
|
|
|
|
|
|
# Returns: number of bytes read and MD5'd |
6879
|
|
|
|
|
|
|
sub ImageDataMD5($$$;$$) |
6880
|
|
|
|
|
|
|
{ |
6881
|
1
|
|
|
1
|
0
|
6
|
my ($self, $raf, $size, $type, $noMsg) = @_; |
6882
|
1
|
50
|
|
|
|
6
|
my $md5 = $$self{ImageDataMD5} or return; |
6883
|
0
|
|
|
|
|
0
|
my ($bytesRead, $n) = (0, 65536); |
6884
|
0
|
|
|
|
|
0
|
my $buff; |
6885
|
0
|
|
|
|
|
0
|
for (;;) { |
6886
|
0
|
0
|
|
|
|
0
|
if (defined $size) { |
6887
|
0
|
0
|
|
|
|
0
|
last unless $size; |
6888
|
0
|
0
|
|
|
|
0
|
$n = $size > 65536 ? 65536 : $size; |
6889
|
0
|
|
|
|
|
0
|
$size -= $n; |
6890
|
|
|
|
|
|
|
} |
6891
|
0
|
0
|
|
|
|
0
|
unless ($raf->Read($buff, $n)) { |
6892
|
0
|
0
|
0
|
|
|
0
|
$self->Warn("Error reading $type data") if $type and defined $size; |
6893
|
0
|
|
|
|
|
0
|
last; |
6894
|
|
|
|
|
|
|
} |
6895
|
0
|
|
|
|
|
0
|
$md5->add($buff); |
6896
|
0
|
|
|
|
|
0
|
$bytesRead += length $buff; |
6897
|
|
|
|
|
|
|
} |
6898
|
0
|
0
|
0
|
|
|
0
|
if ($$self{OPTIONS}{Verbose} and $bytesRead and $type and not $noMsg) { |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
6899
|
0
|
|
|
|
|
0
|
$self->VPrint(0, "$$self{INDENT}(ImageDataMD5: $bytesRead bytes of $type data)\n"); |
6900
|
|
|
|
|
|
|
} |
6901
|
0
|
|
|
|
|
0
|
return $bytesRead; |
6902
|
|
|
|
|
|
|
} |
6903
|
|
|
|
|
|
|
|
6904
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
6905
|
|
|
|
|
|
|
# Copy data block from RAF to output file in max 64kB chunks |
6906
|
|
|
|
|
|
|
# Inputs: 0) RAF ref, 1) outfile ref, 2) block size |
6907
|
|
|
|
|
|
|
# Returns: 1 on success, 0 on read error, undef on write error |
6908
|
|
|
|
|
|
|
sub CopyBlock($$$) |
6909
|
|
|
|
|
|
|
{ |
6910
|
69
|
|
|
69
|
0
|
248
|
my ($raf, $outfile, $size) = @_; |
6911
|
69
|
|
|
|
|
137
|
my $buff; |
6912
|
69
|
|
|
|
|
139
|
for (;;) { |
6913
|
122
|
100
|
|
|
|
396
|
last unless $size > 0; |
6914
|
53
|
50
|
|
|
|
173
|
my $n = $size > 65536 ? 65536 : $size; |
6915
|
53
|
50
|
|
|
|
211
|
$raf->Read($buff, $n) == $n or return 0; |
6916
|
53
|
50
|
|
|
|
285
|
Write($outfile, $buff) or return undef; |
6917
|
53
|
|
|
|
|
195
|
$size -= $n; |
6918
|
|
|
|
|
|
|
} |
6919
|
69
|
|
|
|
|
249
|
return 1; |
6920
|
|
|
|
|
|
|
} |
6921
|
|
|
|
|
|
|
|
6922
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
6923
|
|
|
|
|
|
|
# Copy image data from one file to another |
6924
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object reference |
6925
|
|
|
|
|
|
|
# 1) reference to list of image data [ position, size, pad bytes ] |
6926
|
|
|
|
|
|
|
# 2) output file ref |
6927
|
|
|
|
|
|
|
# Returns: true on success |
6928
|
|
|
|
|
|
|
sub CopyImageData($$$) |
6929
|
|
|
|
|
|
|
{ |
6930
|
13
|
|
|
13
|
0
|
59
|
my ($self, $imageDataBlocks, $outfile) = @_; |
6931
|
13
|
|
|
|
|
45
|
my $raf = $$self{RAF}; |
6932
|
13
|
|
|
|
|
31
|
my ($dataBlock, $err); |
6933
|
13
|
|
|
|
|
38
|
my $num = @$imageDataBlocks; |
6934
|
13
|
50
|
|
|
|
151
|
$self->VPrint(0, " Copying $num image data blocks\n") if $num; |
6935
|
13
|
|
|
|
|
49
|
foreach $dataBlock (@$imageDataBlocks) { |
6936
|
24
|
|
|
|
|
71
|
my ($pos, $size, $pad) = @$dataBlock; |
6937
|
24
|
50
|
|
|
|
99
|
$raf->Seek($pos, 0) or $err = 'read', last; |
6938
|
24
|
|
|
|
|
136
|
my $result = CopyBlock($raf, $outfile, $size); |
6939
|
24
|
0
|
|
|
|
86
|
$result or $err = defined $result ? 'read' : 'writ'; |
|
|
50
|
|
|
|
|
|
6940
|
|
|
|
|
|
|
# pad if necessary |
6941
|
24
|
100
|
50
|
|
|
80
|
Write($outfile, "\0" x $pad) or $err = 'writ' if $pad; |
6942
|
24
|
50
|
|
|
|
89
|
last if $err; |
6943
|
|
|
|
|
|
|
} |
6944
|
13
|
50
|
|
|
|
72
|
if ($err) { |
6945
|
0
|
|
|
|
|
0
|
$self->Error("Error ${err}ing image data"); |
6946
|
0
|
|
|
|
|
0
|
return 0; |
6947
|
|
|
|
|
|
|
} |
6948
|
13
|
|
|
|
|
60
|
return 1; |
6949
|
|
|
|
|
|
|
} |
6950
|
|
|
|
|
|
|
|
6951
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
6952
|
|
|
|
|
|
|
# Write to binary data block |
6953
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object ref, 1) source dirInfo ref, 2) tag table ref |
6954
|
|
|
|
|
|
|
# Returns: Binary data block or undefined on error |
6955
|
|
|
|
|
|
|
sub WriteBinaryData($$$) |
6956
|
|
|
|
|
|
|
{ |
6957
|
15010
|
|
|
15010
|
0
|
29670
|
my ($self, $dirInfo, $tagTablePtr) = @_; |
6958
|
15010
|
100
|
|
|
|
51294
|
$self or return 1; # allow dummy access to autoload this package |
6959
|
|
|
|
|
|
|
|
6960
|
|
|
|
|
|
|
# get default format ('int8u' unless specified) |
6961
|
458
|
50
|
|
|
|
1447
|
my $dataPt = $$dirInfo{DataPt} or return undef; |
6962
|
458
|
|
|
|
|
984
|
my $dataLen = length $$dataPt; |
6963
|
458
|
|
100
|
|
|
2045
|
my $defaultFormat = $$tagTablePtr{FORMAT} || 'int8u'; |
6964
|
458
|
|
|
|
|
1386
|
my $increment = FormatSize($defaultFormat); |
6965
|
458
|
50
|
|
|
|
1233
|
unless ($increment) { |
6966
|
0
|
|
|
|
|
0
|
warn "Unknown format $defaultFormat\n"; |
6967
|
0
|
|
|
|
|
0
|
return undef; |
6968
|
|
|
|
|
|
|
} |
6969
|
|
|
|
|
|
|
# extract data members first if necessary |
6970
|
458
|
|
|
|
|
839
|
my @varOffsets; |
6971
|
458
|
100
|
|
|
|
1845
|
if ($$tagTablePtr{DATAMEMBER}) { |
6972
|
195
|
|
|
|
|
526
|
$$dirInfo{DataMember} = $$tagTablePtr{DATAMEMBER}; |
6973
|
195
|
|
|
|
|
565
|
$$dirInfo{VarFormatData} = \@varOffsets; |
6974
|
195
|
|
|
|
|
897
|
$self->ProcessBinaryData($dirInfo, $tagTablePtr); |
6975
|
195
|
|
|
|
|
516
|
delete $$dirInfo{DataMember}; |
6976
|
195
|
|
|
|
|
393
|
delete $$dirInfo{VarFormatData}; |
6977
|
|
|
|
|
|
|
} |
6978
|
458
|
|
100
|
|
|
1536
|
my $dirStart = $$dirInfo{DirStart} || 0; |
6979
|
458
|
|
|
|
|
840
|
my $dirLen = $$dirInfo{DirLen}; |
6980
|
458
|
100
|
66
|
|
|
2074
|
$dirLen = $dataLen - $dirStart if not defined $dirLen or $dirLen > $dataLen - $dirStart; |
6981
|
458
|
50
|
|
|
|
1697
|
my $newData = substr($$dataPt, $dirStart, $dirLen) or return undef; |
6982
|
458
|
|
|
|
|
920
|
my $dirName = $$dirInfo{DirName}; |
6983
|
458
|
|
|
|
|
816
|
my $varSize = 0; |
6984
|
458
|
|
|
|
|
961
|
my @varInfo = @varOffsets; |
6985
|
458
|
|
|
|
|
648
|
my $tagInfo; |
6986
|
458
|
|
|
|
|
951
|
$dataPt = \$newData; |
6987
|
458
|
|
|
|
|
1565
|
foreach $tagInfo (sort { $$a{TagID} <=> $$b{TagID} } $self->GetNewTagInfoList($tagTablePtr)) { |
|
650
|
|
|
|
|
1160
|
|
6988
|
227
|
|
|
|
|
550
|
my $tagID = $$tagInfo{TagID}; |
6989
|
|
|
|
|
|
|
# evaluate conditional tags now if necessary |
6990
|
227
|
100
|
100
|
|
|
1194
|
if (ref $$tagTablePtr{$tagID} eq 'ARRAY' or $$tagInfo{Condition}) { |
6991
|
22
|
|
|
|
|
89
|
my $writeInfo = $self->GetTagInfo($tagTablePtr, $tagID); |
6992
|
22
|
100
|
100
|
|
|
177
|
next unless $writeInfo and $writeInfo eq $tagInfo; |
6993
|
|
|
|
|
|
|
} |
6994
|
|
|
|
|
|
|
# add offsets for variable-sized tags if necessary |
6995
|
218
|
|
100
|
|
|
680
|
while (@varInfo and $varInfo[0][0] < $tagID) { |
6996
|
10
|
|
|
|
|
23
|
$varSize = $varInfo[0][1]; # get accumulated variable size |
6997
|
10
|
|
|
|
|
30
|
shift @varInfo; |
6998
|
|
|
|
|
|
|
} |
6999
|
218
|
|
|
|
|
371
|
my $count = 1; |
7000
|
218
|
|
|
|
|
473
|
my $format = $$tagInfo{Format}; |
7001
|
218
|
|
|
|
|
478
|
my $entry = int($tagID) * $increment + $varSize; # relative offset of this entry |
7002
|
218
|
100
|
|
|
|
512
|
if ($format) { |
7003
|
87
|
100
|
|
|
|
387
|
if ($format =~ /(.*)\[(.*)\]/) { |
|
|
100
|
|
|
|
|
|
7004
|
36
|
|
|
|
|
105
|
$format = $1; |
7005
|
36
|
|
|
|
|
77
|
$count = $2; |
7006
|
36
|
|
|
|
|
56
|
my $size = $dirLen; # used in eval |
7007
|
|
|
|
|
|
|
# evaluate count to allow count to be based on previous values |
7008
|
|
|
|
|
|
|
#### eval Format size ($size, $self) - NOTE: %val not supported for writing |
7009
|
36
|
|
|
|
|
1716
|
$count = eval $count; |
7010
|
36
|
50
|
|
|
|
171
|
$@ and warn($@), next; |
7011
|
|
|
|
|
|
|
} elsif ($format eq 'string') { |
7012
|
|
|
|
|
|
|
# string with no specified count runs to end of block |
7013
|
1
|
50
|
|
|
|
5
|
$count = ($dirLen > $entry) ? $dirLen - $entry : 0; |
7014
|
|
|
|
|
|
|
} |
7015
|
|
|
|
|
|
|
} else { |
7016
|
131
|
|
|
|
|
246
|
$format = $defaultFormat; |
7017
|
|
|
|
|
|
|
} |
7018
|
|
|
|
|
|
|
# read/write using variable format if changed in Hook |
7019
|
218
|
100
|
66
|
|
|
557
|
$format = $varInfo[0][2] if @varInfo and $varInfo[0][0] == $tagID; |
7020
|
218
|
|
|
|
|
747
|
my $val = ReadValue($dataPt, $entry, $format, $count, $dirLen-$entry); |
7021
|
218
|
100
|
|
|
|
575
|
next unless defined $val; |
7022
|
215
|
|
|
|
|
946
|
my $nvHash = $self->GetNewValueHash($tagInfo, $$self{CUR_WRITE_GROUP}); |
7023
|
215
|
100
|
|
|
|
710
|
next unless $self->IsOverwriting($nvHash, $val) > 0; |
7024
|
214
|
|
|
|
|
578
|
my $newVal = $self->GetNewValue($nvHash); |
7025
|
214
|
100
|
|
|
|
514
|
next unless defined $newVal; # can't delete from a binary table |
7026
|
|
|
|
|
|
|
# update DataMember with new value if necessary |
7027
|
213
|
100
|
|
|
|
571
|
$$self{$$tagInfo{DataMember}} = $newVal if $$tagInfo{DataMember}; |
7028
|
|
|
|
|
|
|
# only write masked bits if specified |
7029
|
213
|
|
|
|
|
445
|
my $mask = $$tagInfo{Mask}; |
7030
|
213
|
100
|
|
|
|
458
|
$newVal = (($newVal << $$tagInfo{BitShift}) & $mask) | ($val & ~$mask) if $mask; |
7031
|
|
|
|
|
|
|
# set the size |
7032
|
213
|
50
|
33
|
|
|
643
|
if ($$tagInfo{DataTag} and not $$tagInfo{IsOffset}) { |
7033
|
0
|
0
|
|
|
|
0
|
warn 'Internal error' unless $newVal == 0xfeedfeed; |
7034
|
0
|
|
|
|
|
0
|
my $data = $self->GetNewValue($$tagInfo{DataTag}); |
7035
|
0
|
0
|
|
|
|
0
|
$newVal = length($data) if defined $data; |
7036
|
0
|
|
0
|
|
|
0
|
my $format = $$tagInfo{Format} || $$tagTablePtr{FORMAT} || 'int32u'; |
7037
|
0
|
0
|
0
|
|
|
0
|
if ($format =~ /^int16/ and $newVal > 0xffff) { |
7038
|
0
|
|
|
|
|
0
|
$self->Error("$$tagInfo{DataTag} is too large (64 kB max. for this file)"); |
7039
|
|
|
|
|
|
|
} |
7040
|
|
|
|
|
|
|
} |
7041
|
213
|
|
|
|
|
553
|
my $rtnVal = WriteValue($newVal, $format, $count, $dataPt, $entry); |
7042
|
213
|
50
|
|
|
|
552
|
if (defined $rtnVal) { |
7043
|
213
|
|
|
|
|
1185
|
$self->VerboseValue("- $dirName:$$tagInfo{Name}", $val); |
7044
|
213
|
|
|
|
|
724
|
$self->VerboseValue("+ $dirName:$$tagInfo{Name}", $newVal); |
7045
|
213
|
|
|
|
|
641
|
++$$self{CHANGED}; |
7046
|
|
|
|
|
|
|
} |
7047
|
|
|
|
|
|
|
} |
7048
|
|
|
|
|
|
|
# add necessary fixups for any offsets |
7049
|
458
|
50
|
66
|
|
|
1593
|
if ($$tagTablePtr{IS_OFFSET} and $$dirInfo{Fixup}) { |
7050
|
1
|
|
|
|
|
2
|
$varSize = 0; |
7051
|
1
|
|
|
|
|
3
|
@varInfo = @varOffsets; |
7052
|
1
|
|
|
|
|
3
|
my $fixup = $$dirInfo{Fixup}; |
7053
|
1
|
|
|
|
|
2
|
my $tagID; |
7054
|
1
|
|
|
|
|
2
|
foreach $tagID (@{$$tagTablePtr{IS_OFFSET}}) { |
|
1
|
|
|
|
|
6
|
|
7055
|
1
|
50
|
|
|
|
5
|
$tagInfo = $self->GetTagInfo($tagTablePtr, $tagID) or next; |
7056
|
1
|
|
33
|
|
|
5
|
while (@varInfo and $varInfo[0][0] < $tagID) { |
7057
|
0
|
|
|
|
|
0
|
$varSize = $varInfo[0][1]; |
7058
|
0
|
|
|
|
|
0
|
shift @varInfo; |
7059
|
|
|
|
|
|
|
} |
7060
|
1
|
|
|
|
|
2
|
my $entry = $tagID * $increment + $varSize; # (no offset to dirStart for new dir data) |
7061
|
1
|
50
|
|
|
|
4
|
next unless $entry <= $dirLen - 4; |
7062
|
|
|
|
|
|
|
# (Ricoh has 16-bit preview image offsets, so can't just assume int32u) |
7063
|
0
|
|
0
|
|
|
0
|
my $format = $$tagInfo{Format} || $$tagTablePtr{FORMAT} || 'int32u'; |
7064
|
0
|
|
|
|
|
0
|
my $offset = ReadValue($dataPt, $entry, $format, 1, $dirLen-$entry); |
7065
|
|
|
|
|
|
|
# ignore if offset is zero (eg. Ricoh DNG uses this to indicate no preview) |
7066
|
0
|
0
|
|
|
|
0
|
next unless $offset; |
7067
|
0
|
|
|
|
|
0
|
$fixup->AddFixup($entry, $$tagInfo{DataTag}, $format); |
7068
|
|
|
|
|
|
|
# handle the preview image now if this is a JPEG file |
7069
|
|
|
|
|
|
|
next unless $$self{FILE_TYPE} eq 'JPEG' and $$tagInfo{DataTag} and |
7070
|
0
|
0
|
0
|
|
|
0
|
$$tagInfo{DataTag} eq 'PreviewImage' and defined $$tagInfo{OffsetPair}; |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
7071
|
|
|
|
|
|
|
# NOTE: here we assume there are no var-sized tags between the |
7072
|
|
|
|
|
|
|
# OffsetPair tags. If this ever becomes possible we must recalculate |
7073
|
|
|
|
|
|
|
# $varSize for the OffsetPair tag here! |
7074
|
0
|
|
|
|
|
0
|
$entry = $$tagInfo{OffsetPair} * $increment + $varSize; |
7075
|
0
|
|
|
|
|
0
|
my $size = ReadValue($dataPt, $entry, $format, 1, $dirLen-$entry); |
7076
|
0
|
|
|
|
|
0
|
my $previewInfo = $$self{PREVIEW_INFO}; |
7077
|
|
|
|
|
|
|
$previewInfo or $previewInfo = $$self{PREVIEW_INFO} = { |
7078
|
0
|
0
|
|
|
|
0
|
Fixup => new Image::ExifTool::Fixup, |
7079
|
|
|
|
|
|
|
}; |
7080
|
|
|
|
|
|
|
# set flag indicating we are using short pointers |
7081
|
0
|
0
|
|
|
|
0
|
$$previewInfo{IsShort} = 1 unless $format eq 'int32u'; |
7082
|
0
|
0
|
0
|
|
|
0
|
$$previewInfo{Absolute} = 1 if $$tagInfo{IsOffset} and $$tagInfo{IsOffset} eq '3'; |
7083
|
|
|
|
|
|
|
# get the value of the Composite::PreviewImage tag |
7084
|
0
|
|
|
|
|
0
|
$$previewInfo{Data} = $self->GetNewValue(GetCompositeTagInfo('PreviewImage')); |
7085
|
0
|
0
|
|
|
|
0
|
unless (defined $$previewInfo{Data}) { |
7086
|
0
|
0
|
0
|
|
|
0
|
if ($offset >= 0 and $offset + $size <= $$dirInfo{DataLen}) { |
7087
|
0
|
|
|
|
|
0
|
$$previewInfo{Data} = substr(${$$dirInfo{DataPt}},$offset,$size); |
|
0
|
|
|
|
|
0
|
|
7088
|
|
|
|
|
|
|
} else { |
7089
|
0
|
|
|
|
|
0
|
$$previewInfo{Data} = 'LOAD_PREVIEW'; # flag to load preview later |
7090
|
|
|
|
|
|
|
} |
7091
|
|
|
|
|
|
|
} |
7092
|
|
|
|
|
|
|
} |
7093
|
|
|
|
|
|
|
} |
7094
|
|
|
|
|
|
|
# write any necessary SubDirectories |
7095
|
458
|
100
|
|
|
|
1203
|
if ($$tagTablePtr{IS_SUBDIR}) { |
7096
|
12
|
|
|
|
|
73
|
$varSize = 0; |
7097
|
12
|
|
|
|
|
44
|
@varInfo = @varOffsets; |
7098
|
12
|
|
|
|
|
44
|
my $tagID; |
7099
|
12
|
|
|
|
|
37
|
foreach $tagID (@{$$tagTablePtr{IS_SUBDIR}}) { |
|
12
|
|
|
|
|
55
|
|
7100
|
13
|
|
|
|
|
63
|
my $tagInfo = $self->GetTagInfo($tagTablePtr, $tagID); |
7101
|
13
|
100
|
|
|
|
70
|
next unless defined $tagInfo; |
7102
|
4
|
|
33
|
|
|
26
|
while (@varInfo and $varInfo[0][0] < $tagID) { |
7103
|
0
|
|
|
|
|
0
|
$varSize = $varInfo[0][1]; |
7104
|
0
|
|
|
|
|
0
|
shift @varInfo; |
7105
|
|
|
|
|
|
|
} |
7106
|
4
|
|
|
|
|
18
|
my $entry = int($tagID) * $increment + $varSize; |
7107
|
4
|
50
|
|
|
|
16
|
last if $entry >= $dirLen; |
7108
|
|
|
|
|
|
|
# get value for Condition if necessary |
7109
|
4
|
50
|
|
|
|
19
|
unless ($tagInfo) { |
7110
|
0
|
|
|
|
|
0
|
my $more = $dirLen - $entry; |
7111
|
0
|
0
|
|
|
|
0
|
$more = 128 if $more > 128; |
7112
|
0
|
|
|
|
|
0
|
my $v = substr($newData, $entry, $more); |
7113
|
0
|
|
|
|
|
0
|
$tagInfo = $self->GetTagInfo($tagTablePtr, $tagID, \$v); |
7114
|
0
|
0
|
|
|
|
0
|
next unless $tagInfo; |
7115
|
|
|
|
|
|
|
} |
7116
|
4
|
50
|
|
|
|
18
|
my $subdir = $$tagInfo{SubDirectory} or next; |
7117
|
4
|
|
|
|
|
10
|
my $start = $$subdir{Start}; |
7118
|
4
|
|
|
|
|
8
|
my $len; |
7119
|
4
|
50
|
|
|
|
15
|
if (not $start) { |
|
|
0
|
|
|
|
|
|
7120
|
4
|
|
|
|
|
9
|
$start = $entry; |
7121
|
4
|
|
|
|
|
13
|
$len = $dirLen - $start; |
7122
|
|
|
|
|
|
|
} elsif ($start =~ /\$/) { |
7123
|
0
|
|
|
|
|
0
|
my $count = 1; |
7124
|
0
|
|
0
|
|
|
0
|
my $format = $$tagInfo{Format} || $defaultFormat; |
7125
|
0
|
0
|
|
|
|
0
|
$format =~ /(.*)\[(.*)\]/ and ($format, $count) = ($1, $2); |
7126
|
0
|
|
|
|
|
0
|
my $val = ReadValue($dataPt, $entry, $format, $count, $dirLen - $entry); |
7127
|
|
|
|
|
|
|
# ignore directories with a zero offset (ie. missing Nikon ShotInfo entries) |
7128
|
0
|
0
|
|
|
|
0
|
next unless $val; |
7129
|
0
|
|
|
|
|
0
|
my $dirStart = 0; |
7130
|
|
|
|
|
|
|
#### eval Start ($val, $dirStart) |
7131
|
0
|
|
|
|
|
0
|
$start = eval($start); |
7132
|
0
|
0
|
0
|
|
|
0
|
next if $start < $dirStart or $start > $dataLen; |
7133
|
0
|
|
|
|
|
0
|
$len = $$subdir{DirLen}; |
7134
|
0
|
0
|
0
|
|
|
0
|
$len = $dataLen - $start unless $len and $len <= $dataLen - $start; |
7135
|
|
|
|
|
|
|
} |
7136
|
4
|
|
|
|
|
26
|
my %subdirInfo = ( |
7137
|
|
|
|
|
|
|
DataPt => \$newData, |
7138
|
|
|
|
|
|
|
DirStart => $start, |
7139
|
|
|
|
|
|
|
DirLen => $len, |
7140
|
|
|
|
|
|
|
TagInfo => $tagInfo, |
7141
|
|
|
|
|
|
|
); |
7142
|
4
|
|
|
|
|
25
|
my $dat = $self->WriteDirectory(\%subdirInfo, GetTagTable($$subdir{TagTable})); |
7143
|
4
|
50
|
33
|
|
|
68
|
substr($newData, $start, $len) = $dat if defined $dat and length $dat; |
7144
|
|
|
|
|
|
|
} |
7145
|
|
|
|
|
|
|
} |
7146
|
458
|
|
|
|
|
1760
|
return $newData; |
7147
|
|
|
|
|
|
|
} |
7148
|
|
|
|
|
|
|
|
7149
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
7150
|
|
|
|
|
|
|
# Write TIFF as a directory |
7151
|
|
|
|
|
|
|
# Inputs: 0) ExifTool object ref, 1) dirInfo ref, 2) tag table ref |
7152
|
|
|
|
|
|
|
# Returns: New directory data or undefined on error |
7153
|
|
|
|
|
|
|
sub WriteTIFF($$$) |
7154
|
|
|
|
|
|
|
{ |
7155
|
111
|
|
|
111
|
0
|
435
|
my ($self, $dirInfo, $tagTablePtr) = @_; |
7156
|
111
|
50
|
|
|
|
985
|
$self or return 1; # allow dummy access |
7157
|
111
|
|
|
|
|
369
|
my $buff = ''; |
7158
|
111
|
|
|
|
|
415
|
$$dirInfo{OutFile} = \$buff; |
7159
|
111
|
50
|
|
|
|
728
|
return $buff if $self->ProcessTIFF($dirInfo, $tagTablePtr) > 0; |
7160
|
0
|
|
|
|
|
|
return undef; |
7161
|
|
|
|
|
|
|
} |
7162
|
|
|
|
|
|
|
|
7163
|
|
|
|
|
|
|
1; # end |
7164
|
|
|
|
|
|
|
|
7165
|
|
|
|
|
|
|
__END__ |