source: gs2-extensions/parallel-building/trunk/src/perllib/cpan/Image/ExifTool/Writer.pl@ 24626

Last change on this file since 24626 was 24626, checked in by jmt12, 13 years ago

An (almost) complete copy of the perllib directory from a (circa SEP2011) head checkout from Greenstone 2 trunk - in order to try and make merging in this extension a little easier later on (as there have been some major changes to buildcol.pl commited in the main trunk but not in the x64 branch)
File size: 222.4 KB
Line 
1#------------------------------------------------------------------------------
2# File: Writer.pl
3#
4# Description: ExifTool write routines
5#
6# Notes: Also contains some less used ExifTool functions
7#
8# URL: http://owl.phy.queensu.ca/~phil/exiftool/
9#
10# Revisions: 12/16/2004 - P. Harvey Created
11#------------------------------------------------------------------------------
12
13package Image::ExifTool;
14
15use strict;
16
17use Image::ExifTool::TagLookup qw(FindTagInfo TagExists);
18use Image::ExifTool::Fixup;
19
20sub AssembleRational($$@);
21sub LastInList($);
22sub CreateDirectory($);
23sub RemoveNewValueHash($$$);
24sub RemoveNewValuesForGroup($$);
25sub GetWriteGroup1($$);
26sub Sanitize($$);
27sub ConvInv($$$$$;$$);
28
29my $loadedAllTables; # flag indicating we loaded all tables
30
31# the following is a road map of where we write each directory
32# in the different types of files.
33my %tiffMap = (
34 IFD0 => 'TIFF',
35 IFD1 => 'IFD0',
36 XMP => 'IFD0',
37 ICC_Profile => 'IFD0',
38 ExifIFD => 'IFD0',
39 GPS => 'IFD0',
40 SubIFD => 'IFD0',
41 GlobParamIFD => 'IFD0',
42 PrintIM => 'IFD0',
43 IPTC => 'IFD0',
44 Photoshop => 'IFD0',
45 InteropIFD => 'ExifIFD',
46 MakerNotes => 'ExifIFD',
47 CanonVRD => 'MakerNotes', # (so VRDOffset will get updated)
48 NikonCapture => 'MakerNotes', # (to allow delete by group)
49);
50my %exifMap = (
51 IFD1 => 'IFD0',
52 EXIF => 'IFD0', # to write EXIF as a block
53 ExifIFD => 'IFD0',
54 GPS => 'IFD0',
55 SubIFD => 'IFD0',
56 GlobParamIFD => 'IFD0',
57 PrintIM => 'IFD0',
58 InteropIFD => 'ExifIFD',
59 MakerNotes => 'ExifIFD',
60 NikonCapture => 'MakerNotes', # (to allow delete by group)
61 # (no CanonVRD trailer allowed)
62);
63my %jpegMap = (
64 %exifMap, # covers all JPEG EXIF mappings
65 JFIF => 'APP0',
66 CIFF => 'APP0',
67 IFD0 => 'APP1',
68 XMP => 'APP1',
69 ICC_Profile => 'APP2',
70 FlashPix => 'APP2',
71 Meta => 'APP3',
72 MetaIFD => 'Meta',
73 RMETA => 'APP5',
74 Ducky => 'APP12',
75 Photoshop => 'APP13',
76 IPTC => 'Photoshop',
77 MakerNotes => ['ExifIFD', 'CIFF'], # (first parent is the default)
78 CanonVRD => 'MakerNotes', # (so VRDOffset will get updated)
79 NikonCapture => 'MakerNotes', # (to allow delete by group)
80 Comment => 'COM',
81);
82my %dirMap = (
83 JPEG => \%jpegMap,
84 TIFF => \%tiffMap,
85 ORF => \%tiffMap,
86 RAW => \%tiffMap,
87 EXIF => \%exifMap,
88);
89
90# groups we are allowed to delete
91# Notes:
92# 1) these names must either exist in %dirMap, or be translated in InitWriteDirs())
93# 2) any dependencies must be added to %excludeGroups
94my @delGroups = qw(
95 AFCP CanonVRD CIFF Ducky EXIF ExifIFD File FlashPix FotoStation GlobParamIFD
96 GPS ICC_Profile IFD0 IFD1 InteropIFD IPTC JFIF MakerNotes Meta MetaIFD MIE
97 NikonCapture PDF PDF-update PhotoMechanic Photoshop PNG PrintIM RMETA RSRC
98 SubIFD Trailer XML XML-* XMP XMP-*
99);
100# other group names of new tag values to remove when deleting an entire group
101my %removeGroups = (
102 IFD0 => [ 'EXIF', 'MakerNotes' ],
103 EXIF => [ 'MakerNotes' ],
104 ExifIFD => [ 'MakerNotes', 'InteropIFD' ],
105 Trailer => [ 'CanonVRD' ], #(because we can add back CanonVRD as a block)
106);
107# related family 0/1 groups in @delGroups (and not already in %jpegMap)
108# that must be removed from delete list when excluding a group
109my %excludeGroups = (
110 EXIF => [ qw(IFD0 IFD1 ExifIFD GPS MakerNotes GlobParamIFD InteropIFD PrintIM SubIFD) ],
111 IFD0 => [ 'EXIF' ],
112 IFD1 => [ 'EXIF' ],
113 ExifIFD => [ 'EXIF' ],
114 GPS => [ 'EXIF' ],
115 MakerNotes => [ 'EXIF' ],
116 InteropIFD => [ 'EXIF' ],
117 GlobParamIFD => [ 'EXIF' ],
118 PrintIM => [ 'EXIF' ],
119 CIFF => [ 'MakerNotes' ],
120 # technically correct, but very uncommon and not a good reason to avoid deleting trailer
121 # IPTC => [ qw(AFCP FotoStation Trailer) ],
122 AFCP => [ 'Trailer' ],
123 FotoStation => [ 'Trailer' ],
124 CanonVRD => [ 'Trailer' ],
125 PhotoMechanic=> [ 'Trailer' ],
126 MIE => [ 'Trailer' ],
127);
128# group names to translate for writing
129my %translateWriteGroup = (
130 EXIF => 'ExifIFD',
131 Meta => 'MetaIFD',
132 File => 'Comment',
133 MIE => 'MIE',
134);
135# names of valid EXIF and Meta directories:
136my %exifDirs = (
137 gps => 'GPS',
138 exififd => 'ExifIFD',
139 subifd => 'SubIFD',
140 globparamifd => 'GlobParamIFD',
141 interopifd => 'InteropIFD',
142 makernotes => 'MakerNotes',
143 previewifd => 'PreviewIFD', # (in MakerNotes)
144 metaifd => 'MetaIFD', # Kodak APP3 Meta
145);
146# min/max values for integer formats
147my %intRange = (
148 'int8u' => [0, 0xff],
149 'int8s' => [-0x80, 0x7f],
150 'int16u' => [0, 0xffff],
151 'int16uRev' => [0, 0xffff],
152 'int16s' => [-0x8000, 0x7fff],
153 'int32u' => [0, 0xffffffff],
154 'int32s' => [-0x80000000, 0x7fffffff],
155);
156# lookup for file types with block-writable EXIF
157my %blockExifTypes = ( JPEG=>1, PNG=>1, JP2=>1, MIE=>1, EXIF=>1 );
158
159my $maxSegmentLen = 0xfffd; # maximum length of data in a JPEG segment
160my $maxXMPLen = $maxSegmentLen; # maximum length of XMP data in JPEG
161
162# value separators when conversion list is used (in SetNewValue)
163my %listSep = ( PrintConv => '; ?', ValueConv => ' ' );
164
165# printConv hash keys to ignore when doing reverse lookup
166my %ignorePrintConv = ( OTHER => 1, BITMASK => 1, Notes => 1 );
167
168#------------------------------------------------------------------------------
169# Set tag value
170# Inputs: 0) ExifTool object reference
171# 1) tag key, tag name, or '*' (optionally prefixed by group name),
172# or undef to reset all previous SetNewValue() calls
173# 2) new value (scalar, scalar ref or list ref), or undef to delete tag
174# 3-N) Options:
175# Type => PrintConv, ValueConv or Raw - specifies value type
176# AddValue => true to add to list of existing values instead of overwriting
177# DelValue => true to delete this existing value value from a list
178# Group => family 0 or 1 group name (case insensitive)
179# Replace => 0, 1 or 2 - overwrite previous new values (2=reset)
180# Protected => bitmask to write tags with specified protections
181# EditOnly => true to only edit existing tags (don't create new tag)
182# EditGroup => true to only edit existing groups (don't create new group)
183# Shift => undef, 0, +1 or -1 - shift value if possible
184# NoShortcut => true to prevent looking up shortcut tags
185# CreateGroups => [internal use] createGroups hash ref from related tags
186# ListOnly => [internal use] set only list or non-list tags
187# SetTags => [internal use] hash ref to return tagInfo refs of set tags
188# Returns: number of tags set (plus error string in list context)
189# Notes: For tag lists (like Keywords), call repeatedly with the same tag name for
190# each value in the list. Internally, the new information is stored in
191# the following members of the $self->{NEW_VALUE}{$tagInfo} hash:
192# TagInfo - tag info ref
193# DelValue - list ref for values to delete
194# Value - list ref for values to add
195# IsCreating - must be set for the tag to be added, otherwise just
196# changed if it already exists. Set to 2 to not create group
197# CreateGroups - hash of all family 0 group names where tag may be created
198# WriteGroup - group name where information is being written (correct case)
199# WantGroup - group name as specified in call to function (case insensitive)
200# Next - pointer to next new value hash (if more than one)
201# Self - ExifTool object reference
202# Shift - shift value
203# MAKER_NOTE_FIXUP - pointer to fixup if necessary for a maker note value
204sub SetNewValue($;$$%)
205{
206 local $_;
207 my ($self, $tag, $value, %options) = @_;
208 my ($err, $tagInfo);
209 my $verbose = $self->{OPTIONS}{Verbose};
210 my $out = $self->{OPTIONS}{TextOut};
211 my $protected = $options{Protected} || 0;
212 my $listOnly = $options{ListOnly};
213 my $setTags = $options{SetTags};
214 my $numSet = 0;
215
216 unless (defined $tag) {
217 # remove any existing set values
218 delete $self->{NEW_VALUE};
219 $self->{DEL_GROUP} = { };
220 $verbose > 1 and print $out "Cleared new values\n";
221 return 1;
222 }
223 # allow value to be scalar or list reference
224 if (ref $value) {
225 if (ref $value eq 'ARRAY') {
226 # (since value is an ARRAY, it will have more than one entry)
227 # set all list-type tags first
228 my $replace = $options{Replace};
229 foreach (@$value) {
230 my ($n, $e) = SetNewValue($self, $tag, $_, %options, ListOnly => 1);
231 $err = $e if $e;
232 $numSet += $n;
233 delete $options{Replace}; # don't replace earlier values in list
234 }
235 # and now set only non-list tags
236 $value = join $self->{OPTIONS}{ListSep}, @$value;
237 $options{Replace} = $replace;
238 $listOnly = $options{ListOnly} = 0;
239 } elsif (ref $value eq 'SCALAR') {
240 $value = $$value;
241 }
242 }
243 # un-escape as necessary and make sure the Perl UTF-8 flag is OFF for the value
244 # if perl is 5.6 or greater (otherwise our byte manipulations get corrupted!!)
245 $self->Sanitize(\$value) if defined $value and not ref $value;
246
247 # set group name in options if specified
248 if ($tag =~ /(.*):(.+)/) {
249 $options{Group} = $1 if $1 ne '*' and lc($1) ne 'all';
250 $tag = $2;
251 }
252 # allow trailing '#' for ValueConv value
253 $options{Type} = 'ValueConv' if $tag =~ s/#$//;
254 # ignore leading family number if 0 or 1 specified
255 if ($options{Group} and $options{Group} =~ /^(\d+)(.*)/ and $1 < 2) {
256 $options{Group} = $2;
257 }
258#
259# get list of tags we want to set
260#
261 my $wantGroup = $options{Group};
262 $tag =~ s/ .*//; # convert from tag key to tag name if necessary
263 my @matchingTags = FindTagInfo($tag);
264 until (@matchingTags) {
265 if ($tag eq '*' or lc($tag) eq 'all') {
266 # set groups to delete
267 if (defined $value) {
268 $err = "Can't set value for all tags";
269 } else {
270 my (@del, $grp);
271 my $remove = ($options{Replace} and $options{Replace} > 1);
272 if ($wantGroup) {
273 @del = grep /^$wantGroup$/i, @delGroups unless $wantGroup =~ /^XM[LP]-\*$/i;
274 # remove associated groups when excluding from mass delete
275 if (@del and $remove) {
276 # remove associated groups in other family
277 push @del, @{$excludeGroups{$del[0]}} if $excludeGroups{$del[0]};
278 # remove upstream groups according to JPEG map
279 my $dirName = $del[0];
280 my @dirNames;
281 for (;;) {
282 my $parent = $jpegMap{$dirName};
283 if (ref $parent) {
284 push @dirNames, @$parent;
285 $parent = pop @dirNames;
286 }
287 $dirName = $parent || shift @dirNames or last;
288 push @del, $dirName; # exclude this too
289 }
290 }
291 # allow MIE groups to be deleted by number,
292 # and allow any XMP family 1 group to be deleted
293 push @del, uc($wantGroup) if $wantGroup =~ /^(MIE\d+|XM[LP]-[-\w]+)$/i;
294 } else {
295 # push all groups plus '*', except IFD1 and a few others
296 push @del, (grep !/^(IFD1|SubIFD|InteropIFD|GlobParamIFD|PDF-update)$/, @delGroups), '*';
297 }
298 if (@del) {
299 ++$numSet;
300 my @donegrps;
301 my $delGroup = $self->{DEL_GROUP};
302 foreach $grp (@del) {
303 if ($remove) {
304 my $didExcl;
305 if ($grp =~ /^(XM[LP])(-.*)?$/) {
306 my $x = $1;
307 if ($grp eq $x) {
308 # exclude all related family 1 groups too
309 foreach (keys %$delGroup) {
310 next unless /^-?$x-/;
311 push @donegrps, $_ if /^$x/;
312 delete $$delGroup{$_};
313 }
314 } elsif ($$delGroup{"$x-*"} and not $$delGroup{"-$grp"}) {
315 # must also exclude XMP or XML to prevent bulk delete
316 if ($$delGroup{$x}) {
317 push @donegrps, $x;
318 delete $$delGroup{$x};
319 }
320 # flag XMP/XML family 1 group for exclusion with leading '-'
321 $$delGroup{"-$grp"} = 1;
322 $didExcl = 1;
323 }
324 }
325 if (exists $$delGroup{$grp}) {
326 delete $$delGroup{$grp};
327 } else {
328 next unless $didExcl;
329 }
330 } else {
331 $$delGroup{$grp} = 1;
332 # add flag for XMP/XML family 1 groups if deleting all XMP
333 if ($grp =~ /^XM[LP]$/) {
334 $$delGroup{"$grp-*"} = 1;
335 push @donegrps, "$grp-*";
336 }
337 # remove all of this group from previous new values
338 $self->RemoveNewValuesForGroup($grp);
339 }
340 push @donegrps, $grp;
341 }
342 if ($verbose > 1 and @donegrps) {
343 @donegrps = sort @donegrps;
344 my $msg = $remove ? 'Excluding from deletion' : 'Deleting tags in';
345 print $out " $msg: @donegrps\n";
346 }
347 } else {
348 $err = "Not a deletable group: $wantGroup";
349 }
350 }
351 } else {
352 my $origTag = $tag;
353 my $langCode;
354 # allow language suffix of form "-en_CA" or "-<rfc3066>" on tag name
355 if ($tag =~ /^(\w+)-([a-z]{2})(_[a-z]{2})$/i or # MIE
356 $tag =~ /^(\w+)-([a-z]{2,3}|[xi])(-[a-z\d]{2,8}(-[a-z\d]{1,8})*)?$/i) # XMP/PNG
357 {
358 $tag = $1;
359 # normalize case of language codes
360 $langCode = lc($2);
361 $langCode .= (length($3) == 3 ? uc($3) : lc($3)) if $3;
362 my @newMatches = FindTagInfo($tag);
363 foreach $tagInfo (@newMatches) {
364 # only allow language codes in tables which support them
365 next unless $$tagInfo{Table};
366 my $langInfoProc = $tagInfo->{Table}{LANG_INFO} or next;
367 my $langInfo = &$langInfoProc($tagInfo, $langCode);
368 push @matchingTags, $langInfo if $langInfo;
369 }
370 last if @matchingTags;
371 } else {
372 # look for a shortcut or alias
373 require Image::ExifTool::Shortcuts;
374 my ($match) = grep /^\Q$tag\E$/i, keys %Image::ExifTool::Shortcuts::Main;
375 undef $err;
376 if ($match and not $options{NoShortcut}) {
377 if (@{$Image::ExifTool::Shortcuts::Main{$match}} == 1) {
378 $tag = $Image::ExifTool::Shortcuts::Main{$match}[0];
379 @matchingTags = FindTagInfo($tag);
380 last if @matchingTags;
381 } else {
382 $options{NoShortcut} = 1;
383 foreach $tag (@{$Image::ExifTool::Shortcuts::Main{$match}}) {
384 my ($n, $e) = $self->SetNewValue($tag, $value, %options);
385 $numSet += $n;
386 $e and $err = $e;
387 }
388 undef $err if $numSet; # no error if any set successfully
389 return ($numSet, $err) if wantarray;
390 $err and warn "$err\n";
391 return $numSet;
392 }
393 }
394 }
395 if (not TagExists($tag)) {
396 $err = "Tag '$origTag' does not exist";
397 $err .= ' or has a bad language code' if $origTag =~ /-/;
398 } elsif ($langCode) {
399 $err = "Tag '$tag' does not support alternate languages";
400 } elsif ($wantGroup) {
401 $err = "Sorry, $wantGroup:$origTag doesn't exist or isn't writable";
402 } else {
403 $err = "Sorry, $origTag is not writable";
404 }
405 $verbose > 2 and print $out "$err\n";
406 }
407 # all done
408 return ($numSet, $err) if wantarray;
409 $err and warn "$err\n";
410 return $numSet;
411 }
412 # get group name that we're looking for
413 my $foundMatch = 0;
414 my ($ifdName, $mieGroup);
415 if ($wantGroup) {
416 # set $ifdName if this group is a valid IFD or SubIFD name
417 if ($wantGroup =~ /^IFD(\d+)$/i) {
418 $ifdName = "IFD$1";
419 } elsif ($wantGroup =~ /^SubIFD(\d+)$/i) {
420 $ifdName = "SubIFD$1";
421 } elsif ($wantGroup =~ /^Version(\d+)$/i) {
422 $ifdName = "Version$1"; # Sony IDC VersionIFD
423 } elsif ($wantGroup =~ /^MIE(\d*-?)(\w+)$/i) {
424 $mieGroup = "MIE$1" . ucfirst(lc($2));
425 } else {
426 $ifdName = $exifDirs{lc($wantGroup)};
427 if (not $ifdName and $wantGroup =~ /^XMP\b/i) {
428 # must load XMP table to set group1 names
429 my $table = GetTagTable('Image::ExifTool::XMP::Main');
430 my $writeProc = $table->{WRITE_PROC};
431 $writeProc and &$writeProc();
432 }
433 }
434 }
435#
436# determine the groups for all tags found, and the tag with
437# the highest priority group
438#
439 my (@tagInfoList, @writeAlsoList, %writeGroup, %preferred, %tagPriority, $avoid, $wasProtected);
440 my $highestPriority = -1;
441 foreach $tagInfo (@matchingTags) {
442 $tag = $tagInfo->{Name}; # set tag so warnings will use proper case
443 my ($writeGroup, $priority);
444 if ($wantGroup) {
445 my $lcWant = lc($wantGroup);
446 # only set tag in specified group
447 $writeGroup = $self->GetGroup($tagInfo, 0);
448 unless (lc($writeGroup) eq $lcWant) {
449 if ($writeGroup eq 'EXIF' or $writeGroup eq 'SonyIDC') {
450 next unless $ifdName;
451 # can't yet write PreviewIFD tags
452 $ifdName eq 'PreviewIFD' and ++$foundMatch, next;
453 $writeGroup = $ifdName; # write to the specified IFD
454 } elsif ($writeGroup eq 'MIE') {
455 next unless $mieGroup;
456 $writeGroup = $mieGroup; # write to specific MIE group
457 # set specific write group with document number if specified
458 if ($writeGroup =~ /^MIE\d+$/ and $tagInfo->{Table}{WRITE_GROUP}) {
459 $writeGroup = $tagInfo->{Table}{WRITE_GROUP};
460 $writeGroup =~ s/^MIE/$mieGroup/;
461 }
462 } elsif (not $$tagInfo{AllowGroup} or $wantGroup !~ /^$$tagInfo{AllowGroup}$/i) {
463 # allow group1 name to be specified
464 my $grp1 = $self->GetGroup($tagInfo, 1);
465 unless ($grp1 and lc($grp1) eq $lcWant) {
466 # must also check group1 name directly in case it is different
467 $grp1 = $tagInfo->{Groups}{1};
468 next unless $grp1 and lc($grp1) eq $lcWant;
469 }
470 }
471 }
472 $priority = 1000; # highest priority since group was specified
473 }
474 ++$foundMatch;
475 # must do a dummy call to the write proc to autoload write package
476 # before checking Writable flag
477 my $table = $tagInfo->{Table};
478 my $writeProc = $table->{WRITE_PROC};
479 # load source table if this was a user-defined table
480 if ($$table{SRC_TABLE}) {
481 my $src = GetTagTable($$table{SRC_TABLE});
482 $writeProc = $$src{WRITE_PROC} unless $writeProc;
483 }
484 next unless $writeProc and &$writeProc();
485 # must still check writable flags in case of UserDefined tags
486 my $writable = $tagInfo->{Writable};
487 next unless $writable or ($table->{WRITABLE} and
488 not defined $writable and not $$tagInfo{SubDirectory});
489 # set specific write group (if we didn't already)
490 if (not $writeGroup or $translateWriteGroup{$writeGroup}) {
491 # use default write group
492 $writeGroup = $tagInfo->{WriteGroup} || $tagInfo->{Table}{WRITE_GROUP};
493 # use group 0 name if no WriteGroup specified
494 my $group0 = $self->GetGroup($tagInfo, 0);
495 $writeGroup or $writeGroup = $group0;
496 # get priority for this group
497 unless ($priority) {
498 $priority = $self->{WRITE_PRIORITY}{lc($writeGroup)};
499 unless ($priority) {
500 $priority = $self->{WRITE_PRIORITY}{lc($group0)} || 0;
501 }
502 }
503 }
504 # don't write tag if protected
505 if ($tagInfo->{Protected}) {
506 my $prot = $tagInfo->{Protected} & ~$protected;
507 if ($prot) {
508 my %lkup = ( 1=>'unsafe', 2=>'protected', 3=>'unsafe and protected');
509 $wasProtected = $lkup{$prot};
510 if ($verbose > 1) {
511 my $wgrp1 = $self->GetWriteGroup1($tagInfo, $writeGroup);
512 print $out "Not writing $wgrp1:$tag ($wasProtected)\n";
513 }
514 next;
515 }
516 }
517 # set priority for this tag
518 $tagPriority{$tagInfo} = $priority;
519 if ($priority > $highestPriority) {
520 $highestPriority = $priority;
521 %preferred = ( $tagInfo => 1 );
522 $avoid = 0;
523 ++$avoid if $$tagInfo{Avoid};
524 } elsif ($priority == $highestPriority) {
525 # create all tags with highest priority
526 $preferred{$tagInfo} = 1;
527 ++$avoid if $$tagInfo{Avoid};
528 }
529 if ($$tagInfo{WriteAlso}) {
530 # store WriteAlso tags separately so we can set them first
531 push @writeAlsoList, $tagInfo;
532 } else {
533 push @tagInfoList, $tagInfo;
534 }
535 $writeGroup{$tagInfo} = $writeGroup;
536 }
537 # sort tag info list in reverse order of priority (higest number last)
538 # so we get the highest priority error message in the end
539 @tagInfoList = sort { $tagPriority{$a} <=> $tagPriority{$b} } @tagInfoList;
540 # must write any tags which also write other tags first
541 unshift @tagInfoList, @writeAlsoList if @writeAlsoList;
542
543 # don't create tags with priority 0 if group priorities are set
544 if ($highestPriority == 0 and %{$self->{WRITE_PRIORITY}}) {
545 undef %preferred;
546 }
547 # avoid creating tags with 'Avoid' flag set if there are other alternatives
548 if ($avoid and %preferred) {
549 if ($avoid < scalar(keys %preferred)) {
550 # just remove the 'Avoid' tags since there are other preferred tags
551 foreach $tagInfo (@tagInfoList) {
552 delete $preferred{$tagInfo} if $$tagInfo{Avoid};
553 }
554 } elsif ($highestPriority < 1000) {
555 # look for another priority tag to create instead
556 my $nextHighest = 0;
557 my @nextBestTags;
558 foreach $tagInfo (@tagInfoList) {
559 my $priority = $tagPriority{$tagInfo} or next;
560 next if $priority == $highestPriority;
561 next if $priority < $nextHighest;
562 next if $$tagInfo{Avoid} or $$tagInfo{Permanent};
563 next if $writeGroup{$tagInfo} eq 'MakerNotes';
564 if ($nextHighest < $priority) {
565 $nextHighest = $priority;
566 undef @nextBestTags;
567 }
568 push @nextBestTags, $tagInfo;
569 }
570 if (@nextBestTags) {
571 # change our preferred tags to the next best tags
572 undef %preferred;
573 foreach $tagInfo (@nextBestTags) {
574 $preferred{$tagInfo} = 1;
575 }
576 }
577 }
578 }
579#
580# generate new value hash for each tag
581#
582 my ($prioritySet, $createGroups, %alsoWrote);
583
584 delete $$self{CHECK_WARN}; # reset CHECK_PROC warnings
585
586 # loop through all valid tags to find the one(s) to write
587 foreach $tagInfo (@tagInfoList) {
588 next if $alsoWrote{$tagInfo}; # don't rewrite tags we already wrote
589 # only process List or non-List tags if specified
590 next if defined $listOnly and ($listOnly xor $$tagInfo{List});
591 my $noConv;
592 my $writeGroup = $writeGroup{$tagInfo};
593 my $permanent = $$tagInfo{Permanent};
594 $writeGroup eq 'MakerNotes' and $permanent = 1 unless defined $permanent;
595 my $wgrp1 = $self->GetWriteGroup1($tagInfo, $writeGroup);
596 $tag = $tagInfo->{Name}; # get proper case for tag name
597 my $shift = $options{Shift};
598 if (defined $shift) {
599 # (can't currently shift List-type tags)
600 if ($tagInfo->{Shift} and not $tagInfo->{List}) {
601 unless ($shift) {
602 # set shift according to AddValue/DelValue
603 $shift = 1 if $options{AddValue};
604 $shift = -1 if $options{DelValue};
605 }
606 if ($shift and (not defined $value or not length $value)) {
607 # (now allow -= to be used for shiftable tag - v8.05)
608 #$err = "No value for time shift of $wgrp1:$tag";
609 #$verbose > 2 and print $out "$err\n";
610 #next;
611 undef $shift;
612 }
613 } elsif ($shift) {
614 $err = "$wgrp1:$tag is not shiftable";
615 $verbose > 2 and print $out "$err\n";
616 next;
617 }
618 }
619 my $val = $value;
620 if (defined $val) {
621 # check to make sure this is a List or Shift tag if adding
622 if ($options{AddValue} and not ($shift or $tagInfo->{List})) {
623 $err = "Can't add $wgrp1:$tag (not a List type)";
624 $verbose > 2 and print $out "$err\n";
625 next;
626 }
627 if ($shift) {
628 # add '+' or '-' prefix to indicate shift direction
629 $val = ($shift > 0 ? '+' : '-') . $val;
630 # check the shift for validity
631 require 'Image/ExifTool/Shift.pl';
632 my $err2 = CheckShift($tagInfo->{Shift}, $val);
633 if ($err2) {
634 $err = "$err2 for $wgrp1:$tag";
635 $verbose > 2 and print $out "$err\n";
636 next;
637 }
638 $noConv = 1; # no conversions if shifting tag
639 } elsif (not length $val and $options{DelValue}) {
640 $noConv = 1; # no conversions for deleting empty value
641 } elsif (ref $val eq 'HASH' and not $$tagInfo{Struct}) {
642 $err = "Can't write a structure to $wgrp1:$tag";
643 $verbose > 2 and print $out "$err\n";
644 next;
645 }
646 } elsif ($permanent) {
647 # can't delete permanent tags, so set them to DelValue or empty string instead
648 if (defined $$tagInfo{DelValue}) {
649 $val = $$tagInfo{DelValue};
650 $noConv = 1; # DelValue is the raw value, so no conversion necessary
651 } else {
652 $val = '';
653 }
654 } elsif ($options{AddValue} or $options{DelValue}) {
655 $err = "No value to add or delete in $wgrp1:$tag";
656 $verbose > 2 and print $out "$err\n";
657 next;
658 } else {
659 if ($tagInfo->{DelCheck}) {
660 #### eval DelCheck ($self, $tagInfo, $wantGroup)
661 my $err2 = eval $tagInfo->{DelCheck};
662 $@ and warn($@), $err2 = 'Error evaluating DelCheck';
663 if ($err2) {
664 $err2 .= ' for' unless $err2 =~ /delete$/;
665 $err = "$err2 $wgrp1:$tag";
666 $verbose > 2 and print $out "$err\n";
667 next;
668 } elsif (defined $err2) {
669 ++$numSet; # (allow other tags to be set using DelCheck as a hook)
670 goto WriteAlso;
671 }
672 }
673 $noConv = 1; # value is not defined, so don't do conversion
674 }
675 # apply inverse PrintConv and ValueConv conversions
676 # save ValueConv setting for use in ConvInv()
677 unless ($noConv) {
678 # set default conversion type used by ConvInv() and CHECK_PROC routines
679 $$self{ConvType} = $options{Type} || ($self->{OPTIONS}{PrintConv} ? 'PrintConv' : 'ValueConv');
680 my $e;
681 ($val,$e) = $self->ConvInv($val, $tagInfo, $tag, $wgrp1, $$self{ConvType}, $wantGroup);
682 if (defined $e) {
683 if ($e) {
684 ($err = $e) =~ s/\$wgrp1/$wgrp1/g;
685 } else {
686 ++$numSet; # an empty error string causes error to be ignored
687 }
688 }
689 }
690 if (not defined $val and defined $value) {
691 # if value conversion failed, we must still add a NEW_VALUE
692 # entry for this tag it it was a DelValue
693 next unless $options{DelValue};
694 $val = 'xxx never delete xxx';
695 }
696 $self->{NEW_VALUE} or $self->{NEW_VALUE} = { };
697 if ($options{Replace}) {
698 # delete the previous new value
699 $self->GetNewValueHash($tagInfo, $writeGroup, 'delete');
700 # also delete related tag previous new values
701 if ($$tagInfo{WriteAlso}) {
702 my $wtag;
703 foreach $wtag (keys %{$$tagInfo{WriteAlso}}) {
704 my ($n,$e) = $self->SetNewValue($wtag, undef, Replace=>2);
705 $numSet += $n;
706 }
707 }
708 $options{Replace} == 2 and ++$numSet, next;
709 }
710
711 if (defined $val) {
712 # we are editing this tag, so create a NEW_VALUE hash entry
713 my $nvHash = $self->GetNewValueHash($tagInfo, $writeGroup, 'create');
714 $nvHash->{WantGroup} = $wantGroup;
715 # save maker note information if writing maker notes
716 if ($$tagInfo{MakerNotes}) {
717 $nvHash->{MAKER_NOTE_FIXUP} = $self->{MAKER_NOTE_FIXUP};
718 }
719 if ($options{DelValue} or $options{AddValue} or $shift) {
720 # flag any AddValue or DelValue by creating the DelValue list
721 $nvHash->{DelValue} or $nvHash->{DelValue} = [ ];
722 if ($shift) {
723 # add shift value to list
724 $nvHash->{Shift} = $val;
725 } elsif ($options{DelValue}) {
726 # don't create if we are replacing a specific value
727 $nvHash->{IsCreating} = 0 unless $val eq '' or $tagInfo->{List};
728 # add delete value to list
729 push @{$nvHash->{DelValue}}, ref $val eq 'ARRAY' ? @$val : $val;
730 if ($verbose > 1) {
731 my $verb = $permanent ? 'Replacing' : 'Deleting';
732 my $fromList = $tagInfo->{List} ? ' from list' : '';
733 my @vals = (ref $val eq 'ARRAY' ? @$val : $val);
734 foreach (@vals) {
735 if (ref $_ eq 'HASH') {
736 require 'Image/ExifTool/XMPStruct.pl';
737 $_ = Image::ExifTool::XMP::SerializeStruct($_);
738 }
739 print $out "$verb $wgrp1:$tag$fromList if value is '$_'\n";
740 }
741 }
742 }
743 }
744 # set priority flag to add only the high priority info
745 # (will only create the priority tag if it doesn't exist,
746 # others get changed only if they already exist)
747 if ($preferred{$tagInfo} or $tagInfo->{Table}{PREFERRED}) {
748 if ($permanent or $shift) {
749 # don't create permanent or Shift-ed tag but define IsCreating
750 # so we know that it is the preferred tag
751 $nvHash->{IsCreating} = 0;
752 } elsif (($tagInfo->{List} and not $options{DelValue}) or
753 not ($nvHash->{DelValue} and @{$nvHash->{DelValue}}) or
754 # also create tag if any DelValue value is empty ('')
755 grep(/^$/,@{$nvHash->{DelValue}}))
756 {
757 $nvHash->{IsCreating} = $options{EditOnly} ? 0 : ($options{EditGroup} ? 2 : 1);
758 # add to hash of groups where this tag is being created
759 $createGroups or $createGroups = $options{CreateGroups} || { };
760 $$createGroups{$self->GetGroup($tagInfo, 0)} = 1;
761 $nvHash->{CreateGroups} = $createGroups;
762 }
763 }
764 if (%{$self->{DEL_GROUP}} and $nvHash->{IsCreating}) {
765 my ($grp, @grps);
766 foreach $grp (keys %{$self->{DEL_GROUP}}) {
767 next if $self->{DEL_GROUP}{$grp} == 2;
768 # set flag indicating tags were written after this group was deleted
769 $self->{DEL_GROUP}{$grp} = 2;
770 push @grps, $grp;
771 }
772 if ($verbose > 1 and @grps) {
773 @grps = sort @grps;
774 print $out " Writing new tags after deleting groups: @grps\n";
775 }
776 }
777 if ($shift or not $options{DelValue}) {
778 $nvHash->{Value} or $nvHash->{Value} = [ ];
779 if (not $tagInfo->{List}) {
780 # not a List tag -- overwrite existing value
781 $nvHash->{Value}[0] = $val;
782 } else {
783 # add to existing list
784 push @{$nvHash->{Value}}, ref $val eq 'ARRAY' ? @$val : $val;
785 }
786 if ($verbose > 1) {
787 my $ifExists = $nvHash->{IsCreating} ?
788 ($nvHash->{IsCreating} == 2 ? " if $writeGroup exists" : '') :
789 (($nvHash->{DelValue} and @{$nvHash->{DelValue}}) ?
790 ' if tag was deleted' : ' if tag exists');
791 my $verb = ($shift ? 'Shifting' : ($options{AddValue} ? 'Adding' : 'Writing'));
792 print $out "$verb $wgrp1:$tag$ifExists\n";
793 }
794 }
795 } elsif ($permanent) {
796 $err = "Can't delete $wgrp1:$tag";
797 $verbose > 1 and print $out "$err\n";
798 next;
799 } elsif ($options{AddValue} or $options{DelValue}) {
800 $verbose > 1 and print $out "Adding/Deleting nothing does nothing\n";
801 next;
802 } else {
803 # create empty new value hash entry to delete this tag
804 $self->GetNewValueHash($tagInfo, $writeGroup, 'delete');
805 my $nvHash = $self->GetNewValueHash($tagInfo, $writeGroup, 'create');
806 $nvHash->{WantGroup} = $wantGroup;
807 $verbose > 1 and print $out "Deleting $wgrp1:$tag\n";
808 }
809 ++$numSet;
810 $$setTags{$tagInfo} = 1 if $setTags;
811 $prioritySet = 1 if $preferred{$tagInfo};
812WriteAlso:
813 # also write related tags
814 my $writeAlso = $$tagInfo{WriteAlso};
815 if ($writeAlso) {
816 my ($wtag, $n);
817 local $SIG{'__WARN__'} = \&SetWarning;
818 foreach $wtag (keys %$writeAlso) {
819 my %opts = (
820 Type => 'ValueConv',
821 Protected => $protected | 0x02,
822 AddValue => $options{AddValue},
823 DelValue => $options{DelValue},
824 CreateGroups => $createGroups,
825 SetTags => \%alsoWrote, # remember tags already written
826 );
827 undef $evalWarning;
828 #### eval WriteAlso ($val)
829 my $v = eval $writeAlso->{$wtag};
830 $@ and $evalWarning = $@;
831 unless ($evalWarning) {
832 ($n,$evalWarning) = $self->SetNewValue($wtag, $v, %opts);
833 $numSet += $n;
834 # count this as being set if any related tag is set
835 $prioritySet = 1 if $n and $preferred{$tagInfo};
836 }
837 if ($evalWarning and (not $err or $verbose > 2)) {
838 my $str = CleanWarning();
839 if ($str) {
840 $str .= " for $wtag" unless $str =~ / for [-\w:]+$/;
841 $str .= " in $wgrp1:$tag (WriteAlso)";
842 $err or $err = $str;
843 print $out "$str\n" if $verbose > 2;
844 }
845 }
846 }
847 }
848 }
849 # print warning if we couldn't set our priority tag
850 if (defined $err and not $prioritySet) {
851 warn "$err\n" if $err and not wantarray;
852 } elsif (not $numSet) {
853 my $pre = $wantGroup ? ($ifdName || $wantGroup) . ':' : '';
854 if ($wasProtected) {
855 $err = "Tag '$pre$tag' is $wasProtected for writing";
856 } elsif ($foundMatch) {
857 $err = "Sorry, $pre$tag is not writable";
858 } else {
859 $err = "Tag '$pre$tag' does not exist";
860 }
861 $verbose > 2 and print $out "$err\n";
862 warn "$err\n" unless wantarray;
863 } elsif ($$self{CHECK_WARN}) {
864 $err = $$self{CHECK_WARN};
865 $verbose > 2 and print $out "$err\n";
866 } elsif ($err and not $verbose) {
867 undef $err;
868 }
869 return ($numSet, $err) if wantarray;
870 return $numSet;
871}
872
873#------------------------------------------------------------------------------
874# set new values from information in specified file
875# Inputs: 0) ExifTool object reference, 1) source file name or reference, etc
876# 2-N) List of tags to set (or all if none specified), or reference(s) to
877# hash for options to pass to SetNewValue. The Replace option defaults
878# to 1 for SetNewValuesFromFile -- set this to 0 to allow multiple tags
879# to be copied to a list
880# Returns: Hash of information set successfully (includes Warning or Error messages)
881# Notes: Tag names may contain a group prefix, a leading '-' to exclude from copy,
882# and/or a trailing '#' to copy the ValueConv value. The tag name '*' may
883# be used to represent all tags in a group. An optional destination tag
884# may be specified with '>DSTTAG' ('DSTTAG<TAG' also works, but in this
885# case the source tag may also be an expression involving tag names).
886sub SetNewValuesFromFile($$;@)
887{
888 local $_;
889 my ($self, $srcFile, @setTags) = @_;
890 my $key;
891
892 # get initial SetNewValuesFromFile options
893 my %opts = ( Replace => 1 ); # replace existing list items by default
894 while (ref $setTags[0] eq 'HASH') {
895 $_ = shift @setTags;
896 foreach $key (keys %$_) {
897 $opts{$key} = $_->{$key};
898 }
899 }
900 # expand shortcuts
901 @setTags and ExpandShortcuts(\@setTags);
902 my $srcExifTool = new Image::ExifTool;
903 my $options = $self->{OPTIONS};
904 # set options for our extraction tool
905 $srcExifTool->{TAGS_FROM_FILE} = 1;
906 # +------------------------------------------+
907 # ! DON'T FORGET!! Must consider each new !
908 # ! option to decide how it is handled here. !
909 # +------------------------------------------+
910 $srcExifTool->Options(
911 Binary => 1,
912 Charset => $$options{Charset},
913 CharsetID3 => $$options{CharsetID3},
914 CharsetIPTC => $$options{CharsetIPTC},
915 CharsetPhotoshop => $$options{CharsetPhotoshop},
916 Composite => $$options{Composite},
917 CoordFormat => $$options{CoordFormat} || '%d %d %.8f', # copy coordinates at high resolution unless otherwise specified
918 DateFormat => $$options{DateFormat},
919 Duplicates => 1,
920 Escape => $$options{Escape},
921 ExtractEmbedded => $$options{ExtractEmbedded},
922 FastScan => $$options{FastScan},
923 FixBase => $$options{FixBase},
924 IgnoreMinorErrors => $$options{IgnoreMinorErrors},
925 Lang => $$options{Lang},
926 LargeFileSupport => $$options{LargeFileSupport},
927 List => 1,
928 MakerNotes => 1,
929 MissingTagValue => $$options{MissingTagValue},
930 Password => $$options{Password},
931 PrintConv => $$options{PrintConv},
932 ScanForXMP => $$options{ScanForXMP},
933 StrictDate => 1,
934 Struct => ($$options{Struct} or not defined $$options{Struct}) ? 1 : 0,
935 Unknown => $$options{Unknown},
936 );
937 my $printConv = $$options{PrintConv};
938 if ($opts{Type}) {
939 # save source type separately because it may be different than dst Type
940 $opts{SrcType} = $opts{Type};
941 # override PrintConv option with initial Type if given
942 $printConv = ($opts{Type} eq 'PrintConv' ? 1 : 0);
943 $srcExifTool->Options(PrintConv => $printConv);
944 }
945 my $srcType = $printConv ? 'PrintConv' : 'ValueConv';
946
947 # get all tags from source file (including MakerNotes block)
948 my $info = $srcExifTool->ImageInfo($srcFile);
949 return $info if $$info{Error} and $$info{Error} eq 'Error opening file';
950 delete $srcExifTool->{VALUE}{Error}; # delete so we can check this later
951
952 # sort tags in reverse order so we get priority tag last
953 my @tags = reverse sort keys %$info;
954 my $tag;
955#
956# simply transfer all tags from source image if no tags specified
957#
958 unless (@setTags) {
959 # transfer maker note information to this object
960 $self->{MAKER_NOTE_FIXUP} = $srcExifTool->{MAKER_NOTE_FIXUP};
961 $self->{MAKER_NOTE_BYTE_ORDER} = $srcExifTool->{MAKER_NOTE_BYTE_ORDER};
962 foreach $tag (@tags) {
963 # don't try to set errors or warnings
964 next if $tag =~ /^(Error|Warning)\b/;
965 # get approprite value type if necessary
966 if ($opts{SrcType} and $opts{SrcType} ne $srcType) {
967 $$info{$tag} = $srcExifTool->GetValue($tag, $opts{SrcType});
968 }
969 # set value for this tag
970 my ($n, $e) = $self->SetNewValue($tag, $$info{$tag}, %opts);
971 # delete this tag if we could't set it
972 $n or delete $$info{$tag};
973 }
974 return $info;
975 }
976#
977# transfer specified tags in the proper order
978#
979 # 1) loop through input list of tags to set, and build @setList
980 my (@setList, $set, %setMatches);
981 foreach (@setTags) {
982 if (ref $_ eq 'HASH') {
983 # update current options
984 foreach $key (keys %$_) {
985 $opts{$key} = $_->{$key};
986 }
987 next;
988 }
989 # make a copy of the current options for this setTag
990 # (also use this hash to store expression and wildcard flags, EXPR and WILD)
991 my $opts = { %opts };
992 $tag = lc($_); # change tag/group names to all lower case
993 my ($fam, $grp, $dst, $dstGrp, $dstTag, $isExclude);
994 # handle redirection to another tag
995 if ($tag =~ /(.+?)\s*(>|<)\s*(.+)/) {
996 $dstGrp = '';
997 my $opt;
998 if ($2 eq '>') {
999 ($tag, $dstTag) = ($1, $3);
1000 # flag add and delete (ie. '+<' and '-<') redirections
1001 $opt = $1 if $tag =~ s/\s*([-+])$// or $dstTag =~ s/^([-+])\s*//;
1002 } else {
1003 ($tag, $dstTag) = ($3, $1);
1004 $opt = $1 if $dstTag =~ s/\s*([-+])$//;
1005 # handle expressions
1006 if ($tag =~ /\$/) {
1007 $tag = $_; # restore original case
1008 # recover leading whitespace (except for initial single space)
1009 $tag =~ s/(.+?)\s*(>|<) ?//;
1010 $$opts{EXPR} = 1; # flag this expression
1011 $grp = '';
1012 } else {
1013 $opt = $1 if $tag =~ s/^([-+])\s*//;
1014 }
1015 }
1016 # translate '+' and '-' to appropriate SetNewValue option
1017 if ($opt) {
1018 $$opts{{ '+' => 'AddValue', '-' => 'DelValue' }->{$opt}} = 1;
1019 $$opts{Shift} = 0; # shift if this is a date/time tag
1020 }
1021 ($dstGrp, $dstTag) = ($1, $2) if $dstTag =~ /(.*):(.+)/;
1022 # ValueConv may be specified separately on the destination with '#'
1023 $$opts{Type} = 'ValueConv' if $dstTag =~ s/#$//;
1024 # ignore leading family number
1025 $dstGrp = $2 if $dstGrp =~ /^(\d+)(.*)/ and $1 < 2;
1026 # replace 'all' with '*' in tag and group names
1027 $dstTag = '*' if $dstTag eq 'all';
1028 $dstGrp = '*' if $dstGrp eq 'all';
1029 }
1030 unless ($$opts{EXPR}) {
1031 $isExclude = ($tag =~ s/^-//);
1032 if ($tag =~ /^([-\w]*?|\*):(.+)/) {
1033 ($grp, $tag) = ($1, $2);
1034 # separate leading family number
1035 ($fam, $grp) = ($1, $2) if $grp =~ /^(\d+)(.*)/;
1036 } else {
1037 $grp = ''; # flag for don't care about group
1038 }
1039 # allow ValueConv to be specified by a '#' on the tag name
1040 if ($tag =~ s/#$//) {
1041 $$opts{SrcType} = 'ValueConv';
1042 $$opts{Type} = 'ValueConv' unless $dstTag;
1043 }
1044 # replace 'all' with '*' in tag and group names
1045 $tag = '*' if $tag eq 'all';
1046 $grp = '*' if $grp eq 'all';
1047 # allow wildcards in tag names
1048 if ($tag =~ /[?*]/ and $tag ne '*') {
1049 $$opts{WILD} = 1; # set flag indicating wildcards were used
1050 $tag =~ s/\*/[-\\w]*/g;
1051 $tag =~ s/\?/[-\\w]/g;
1052 }
1053 }
1054 # redirect, exclude or set this tag (Note: $grp is '' if we don't care)
1055 if ($dstTag) {
1056 # redirect this tag
1057 $isExclude and return { Error => "Can't redirect excluded tag" };
1058 if ($dstTag ne '*') {
1059 if ($dstTag =~ /[?*]/) {
1060 if ($dstTag eq $tag) {
1061 $dstTag = '*';
1062 } else {
1063 return { Error => "Invalid use of wildcards in destination tag" };
1064 }
1065 } elsif ($tag eq '*') {
1066 return { Error => "Can't redirect from all tags to one tag" };
1067 }
1068 }
1069 # set destination group the same as source if necessary
1070 # (removed in 7.72 so '-xmp:*>*:*' will preserve XMP family 1 groups)
1071 # $dstGrp = $grp if $dstGrp eq '*' and $grp;
1072 # write to specified destination group/tag
1073 $dst = [ $dstGrp, $dstTag ];
1074 } elsif ($isExclude) {
1075 # implicitly assume '*' if first entry is an exclusion
1076 unshift @setList, [ undef, '*', '*', [ '', '*' ], $opts ] unless @setList;
1077 # exclude this tag by leaving $dst undefined
1078 } else {
1079 $dst = [ $grp, $$opts{WILD} ? '*' : $tag ]; # copy to same group
1080 }
1081 $grp or $grp = '*'; # use '*' for any group
1082 # save in reverse order so we don't set tags before an exclude
1083 unshift @setList, [ $fam, $grp, $tag, $dst, $opts ];
1084 }
1085 # 2) initialize lists of matching tags for each setTag
1086 foreach $set (@setList) {
1087 $$set[3] and $setMatches{$set} = [ ];
1088 }
1089 # 3) loop through all tags in source image and save tags matching each setTag
1090 my %rtnInfo;
1091 foreach $tag (@tags) {
1092 # don't try to set errors or warnings
1093 if ($tag =~ /^(Error|Warning)( |$)/) {
1094 $rtnInfo{$tag} = $$info{$tag};
1095 next;
1096 }
1097 # only set specified tags
1098 my $lcTag = lc(GetTagName($tag));
1099 my (@grp, %grp);
1100 foreach $set (@setList) {
1101 # check first for matching tag
1102 unless ($$set[2] eq $lcTag or $$set[2] eq '*') {
1103 # handle wildcards
1104 next unless $$set[4]{WILD} and $lcTag =~ /^$$set[2]$/;
1105 }
1106 # then check for matching group
1107 unless ($$set[1] eq '*') {
1108 # get lower case group names if not done already
1109 unless (@grp) {
1110 @grp = map(lc, $srcExifTool->GetGroup($tag));
1111 $grp{$_} = 1 foreach @grp;
1112 }
1113 # handle leading family number
1114 if (defined $$set[0]) {
1115 next unless $grp[$$set[0]] and $$set[1] eq $grp[$$set[0]];
1116 } else {
1117 next unless $grp{$$set[1]};
1118 }
1119 }
1120 last unless $$set[3]; # all done if we hit an exclude
1121 # add to the list of tags matching this setTag
1122 push @{$setMatches{$set}}, $tag;
1123 }
1124 }
1125 # 4) loop through each setTag in original order, setting new tag values
1126 foreach $set (reverse @setList) {
1127 # get options for SetNewValue
1128 my $opts = $$set[4];
1129 # handle expressions
1130 if ($$opts{EXPR}) {
1131 my $val = $srcExifTool->InsertTagValues(\@tags, $$set[2], 'Error');
1132 unless (defined $val) {
1133 # return warning if one of the tags didn't exist
1134 $tag = NextTagKey(\%rtnInfo, 'Warning');
1135 $rtnInfo{$tag} = $srcExifTool->GetValue('Error');
1136 delete $srcExifTool->{VALUE}{Error};
1137 next;
1138 }
1139 my ($dstGrp, $dstTag) = @{$$set[3]};
1140 $$opts{Protected} = 1;
1141 $$opts{Group} = $dstGrp if $dstGrp;
1142 my @rtnVals = $self->SetNewValue($dstTag, $val, %$opts);
1143 $rtnInfo{$dstTag} = $val if $rtnVals[0]; # tag was set successfully
1144 next;
1145 }
1146 foreach $tag (@{$setMatches{$set}}) {
1147 my ($val, $noWarn);
1148 if ($$opts{SrcType} and $$opts{SrcType} ne $srcType) {
1149 $val = $srcExifTool->GetValue($tag, $$opts{SrcType});
1150 } else {
1151 $val = $$info{$tag};
1152 }
1153 my ($dstGrp, $dstTag) = @{$$set[3]};
1154 if ($dstGrp) {
1155 if ($dstGrp eq '*') {
1156 $dstGrp = $srcExifTool->GetGroup($tag, 1);
1157 $noWarn = 1; # don't warn on wildcard destinations
1158 }
1159 $$opts{Group} = $dstGrp;
1160 } else {
1161 delete $$opts{Group};
1162 }
1163 # transfer maker note information if setting this tag
1164 if ($srcExifTool->{TAG_INFO}{$tag}{MakerNotes}) {
1165 $self->{MAKER_NOTE_FIXUP} = $srcExifTool->{MAKER_NOTE_FIXUP};
1166 $self->{MAKER_NOTE_BYTE_ORDER} = $srcExifTool->{MAKER_NOTE_BYTE_ORDER};
1167 }
1168 if ($dstTag eq '*') {
1169 $dstTag = $tag;
1170 $noWarn = 1;
1171 }
1172 # allow protected tags to be copied if specified explicitly
1173 $$opts{Protected} = ($$set[2] eq '*' ? undef : 1);
1174 # set value(s) for this tag
1175 my ($rtn, $wrn) = $self->SetNewValue($dstTag, $val, %$opts);
1176 if ($wrn and not $noWarn) {
1177 # return this warning
1178 $rtnInfo{NextTagKey(\%rtnInfo, 'Warning')} = $wrn;
1179 $noWarn = 1;
1180 }
1181 $rtnInfo{$tag} = $val if $rtn; # tag was set successfully
1182 }
1183 }
1184 return \%rtnInfo; # return information that we set
1185}
1186
1187#------------------------------------------------------------------------------
1188# Get new value(s) for tag
1189# Inputs: 0) ExifTool object reference, 1) tag name or tagInfo hash ref
1190# 2) optional pointer to return new value hash reference (not part of public API)
1191# or 0) new value hash reference (not part of public API)
1192# Returns: List of new Raw values (list may be empty if tag is being deleted)
1193# Notes: 1) Preferentially returns new value from Extra table if writable Extra tag exists
1194# 2) Must call AFTER IsOverwriting() returns 1 to get proper value for shifted times
1195# 3) Tag name is case sensitive and may be prefixed by family 0 or 1 group name
1196sub GetNewValues($;$$)
1197{
1198 local $_;
1199 my $nvHash;
1200 if (ref $_[0] eq 'HASH') {
1201 $nvHash = shift;
1202 } else {
1203 my ($self, $tag, $newValueHashPt) = @_;
1204 if ($self->{NEW_VALUE}) {
1205 my ($group, $tagInfo);
1206 if (ref $tag) {
1207 $nvHash = $self->GetNewValueHash($tag);
1208 } elsif (defined($tagInfo = $Image::ExifTool::Extra{$tag}) and
1209 $$tagInfo{Writable})
1210 {
1211 $nvHash = $self->GetNewValueHash($tagInfo);
1212 } else {
1213 # separate group from tag name
1214 $group = $1 if $tag =~ s/(.*)://;
1215 my @tagInfoList = FindTagInfo($tag);
1216 # decide which tag we want
1217GNV_TagInfo: foreach $tagInfo (@tagInfoList) {
1218 my $nvh = $self->GetNewValueHash($tagInfo) or next;
1219 # select tag in specified group if necessary
1220 while ($group and $group ne $$nvh{WriteGroup}) {
1221 my @grps = $self->GetGroup($tagInfo);
1222 if ($grps[0] eq $$nvh{WriteGroup}) {
1223 # check family 1 group only if WriteGroup is not specific
1224 last if $group eq $grps[1];
1225 } else {
1226 # otherwise check family 0 group
1227 last if $group eq $grps[0];
1228 }
1229 # step to next entry in list
1230 $nvh = $$nvh{Next} or next GNV_TagInfo;
1231 }
1232 $nvHash = $nvh;
1233 # give priority to the one we are creating
1234 last if defined $nvHash->{IsCreating};
1235 }
1236 }
1237 }
1238 # return new value hash if requested
1239 $newValueHashPt and $$newValueHashPt = $nvHash;
1240 }
1241 if ($nvHash and $nvHash->{Value}) {
1242 my $vals = $nvHash->{Value};
1243 # do inverse raw conversion if necessary
1244 if ($nvHash->{TagInfo}{RawConvInv}) {
1245 my @copyVals = @$vals; # modify a copy of the values
1246 $vals = \@copyVals;
1247 my $tagInfo = $$nvHash{TagInfo};
1248 my $conv = $$tagInfo{RawConvInv};
1249 my $self = $nvHash->{Self};
1250 my ($val, $checkProc);
1251 my $table = $tagInfo->{Table};
1252 $checkProc = $$table{CHECK_PROC} if $table;
1253 local $SIG{'__WARN__'} = \&SetWarning;
1254 undef $evalWarning;
1255 foreach $val (@$vals) {
1256 if (ref($conv) eq 'CODE') {
1257 $val = &$conv($val, $self);
1258 } else {
1259 #### eval RawConvInv ($self, $val, $taginfo)
1260 $val = eval $conv;
1261 $@ and $evalWarning = $@;
1262 }
1263 if ($evalWarning) {
1264 # an empty warning ("\n") ignores tag with no error
1265 if ($evalWarning ne "\n") {
1266 my $err = CleanWarning() . " in $$tagInfo{Name} (RawConvInv)";
1267 $self->Warn($err);
1268 }
1269 @$vals = ();
1270 last;
1271 }
1272 # must check value now
1273 next unless $checkProc;
1274 my $err = &$checkProc($self, $tagInfo, \$val);
1275 if ($err or not defined $val) {
1276 $err or $err = 'Error generating raw value';
1277 $self->Warn("$err for $$tagInfo{Name}");
1278 @$vals = ();
1279 last;
1280 }
1281 }
1282 }
1283 # return our value(s)
1284 return @$vals if wantarray;
1285 return $$vals[0];
1286 }
1287 return () if wantarray; # return empty list
1288 return undef;
1289}
1290
1291#------------------------------------------------------------------------------
1292# Return the total number of new values set
1293# Inputs: 0) ExifTool object reference
1294# Returns: Scalar context) Number of new values that have been set
1295# List context) Number of new values, number of "pseudo" values
1296# ("pseudo" values are those which don't require rewriting the file to change)
1297sub CountNewValues($)
1298{
1299 my $self = shift;
1300 my $newVal = $self->{NEW_VALUE};
1301 my $num = 0;
1302 my $tag;
1303 if ($newVal) {
1304 $num += scalar keys %$newVal;
1305 # don't count "fake" tags (only in Extra table)
1306 foreach $tag (qw{Geotag Geosync}) {
1307 --$num if defined $$newVal{$Image::ExifTool::Extra{$tag}};
1308 }
1309 }
1310 $num += scalar keys %{$self->{DEL_GROUP}};
1311 return $num unless wantarray;
1312 my $pseudo = 0;
1313 if ($newVal) {
1314 # (Note: all writable "pseudo" tags must be found in Extra table)
1315 foreach $tag (qw{FileName Directory FileModifyDate}) {
1316 ++$pseudo if defined $$newVal{$Image::ExifTool::Extra{$tag}};
1317 }
1318 }
1319 return ($num, $pseudo);
1320}
1321
1322#------------------------------------------------------------------------------
1323# Save new values for subsequent restore
1324# Inputs: 0) ExifTool object reference
1325sub SaveNewValues($)
1326{
1327 my $self = shift;
1328 my $newValues = $self->{NEW_VALUE};
1329 my $key;
1330 foreach $key (keys %$newValues) {
1331 my $nvHash = $$newValues{$key};
1332 while ($nvHash) {
1333 $nvHash->{Save} = 1; # set Save flag
1334 $nvHash = $nvHash->{Next};
1335 }
1336 }
1337 # initialize hash for saving overwritten new values
1338 $self->{SAVE_NEW_VALUE} = { };
1339 # make a copy of the delete group hash
1340 if ($self->{DEL_GROUP}) {
1341 my %delGrp = %{$self->{DEL_GROUP}};
1342 $self->{SAVE_DEL_GROUP} = \%delGrp;
1343 } else {
1344 delete $self->{SAVE_DEL_GROUP};
1345 }
1346}
1347
1348#------------------------------------------------------------------------------
1349# Restore new values to last saved state
1350# Inputs: 0) ExifTool object reference
1351# Notes: Restores saved new values, but currently doesn't restore them in the
1352# original order, so there may be some minor side-effects when restoring tags
1353# with overlapping groups. ie) XMP:Identifier, XMP-dc:Identifier
1354sub RestoreNewValues($)
1355{
1356 my $self = shift;
1357 my $newValues = $self->{NEW_VALUE};
1358 my $savedValues = $self->{SAVE_NEW_VALUE};
1359 my $key;
1360 # 1) remove any new values which don't have the Save flag set
1361 if ($newValues) {
1362 my @keys = keys %$newValues;
1363 foreach $key (@keys) {
1364 my $lastHash;
1365 my $nvHash = $$newValues{$key};
1366 while ($nvHash) {
1367 if ($nvHash->{Save}) {
1368 $lastHash = $nvHash;
1369 } else {
1370 # remove this entry from the list
1371 if ($lastHash) {
1372 $lastHash->{Next} = $nvHash->{Next};
1373 } elsif ($nvHash->{Next}) {
1374 $$newValues{$key} = $nvHash->{Next};
1375 } else {
1376 delete $$newValues{$key};
1377 }
1378 }
1379 $nvHash = $nvHash->{Next};
1380 }
1381 }
1382 }
1383 # 2) restore saved new values
1384 if ($savedValues) {
1385 $newValues or $newValues = $self->{NEW_VALUE} = { };
1386 foreach $key (keys %$savedValues) {
1387 if ($$newValues{$key}) {
1388 # add saved values to end of list
1389 my $nvHash = LastInList($$newValues{$key});
1390 $nvHash->{Next} = $$savedValues{$key};
1391 } else {
1392 $$newValues{$key} = $$savedValues{$key};
1393 }
1394 }
1395 $self->{SAVE_NEW_VALUE} = { }; # reset saved new values
1396 }
1397 # 3) restore delete groups
1398 if ($self->{SAVE_DEL_GROUP}) {
1399 my %delGrp = %{$self->{SAVE_DEL_GROUP}};
1400 $self->{DEL_GROUP} = \%delGrp;
1401 } else {
1402 delete $self->{DEL_GROUP};
1403 }
1404}
1405
1406#------------------------------------------------------------------------------
1407# Set file modification time from FileModifyDate tag
1408# Inputs: 0) ExifTool object reference, 1) file name or file ref
1409# 2) modify time (-M) of original file (needed for time shift)
1410# Returns: 1=time changed OK, 0=nothing done, -1=error setting time
1411# (and increments CHANGED flag if time was changed)
1412sub SetFileModifyDate($$;$)
1413{
1414 my ($self, $file, $originalTime) = @_;
1415 my $nvHash;
1416 my $val = $self->GetNewValues('FileModifyDate', \$nvHash);
1417 return 0 unless defined $val;
1418 my $isOverwriting = IsOverwriting($nvHash);
1419 return 0 unless $isOverwriting;
1420 if ($isOverwriting < 0) { # are we shifting time?
1421 # use original time of this file if not specified
1422 $originalTime = -M $file unless defined $originalTime;
1423 return 0 unless defined $originalTime;
1424 return 0 unless IsOverwriting($nvHash, $^T - $originalTime*(24*3600));
1425 $val = $nvHash->{Value}[0]; # get shifted value
1426 }
1427 unless (utime($val, $val, $file)) {
1428 $self->Warn('Error setting FileModifyDate');
1429 return -1;
1430 }
1431 ++$self->{CHANGED};
1432 $self->VerboseValue('+ FileModifyDate', $val);
1433 return 1;
1434}
1435
1436#------------------------------------------------------------------------------
1437# Change file name and/or directory from FileName and Directory tags
1438# Inputs: 0) ExifTool object reference, 1) current file name (including path)
1439# 2) New name (or undef to build from FileName and Directory tags)
1440# Returns: 1=name changed OK, 0=nothing changed, -1=error changing name
1441# (and increments CHANGED flag if filename changed)
1442# Notes: Will not overwrite existing file. Creates directories as necessary.
1443sub SetFileName($$;$)
1444{
1445 my ($self, $file, $newName) = @_;
1446 my ($nvHash, $doName, $doDir);
1447 # determine the new file name
1448 unless (defined $newName) {
1449 my $filename = $self->GetNewValues('FileName', \$nvHash);
1450 $doName = 1 if defined $filename and IsOverwriting($nvHash, $file);
1451 my $dir = $self->GetNewValues('Directory', \$nvHash);
1452 $doDir = 1 if defined $dir and IsOverwriting($nvHash, $file);
1453 return 0 unless $doName or $doDir; # nothing to do
1454 if ($doName) {
1455 $newName = GetNewFileName($file, $filename);
1456 $newName = GetNewFileName($newName, $dir) if $doDir;
1457 } else {
1458 $newName = GetNewFileName($file, $dir);
1459 }
1460 }
1461 if (-e $newName) {
1462 # don't replace existing file
1463 $self->Warn("File '$newName' already exists");
1464 return -1;
1465 }
1466 # create directory for new file if necessary
1467 my $result;
1468 if (($result = CreateDirectory($newName)) != 0) {
1469 if ($result < 0) {
1470 $self->Warn("Error creating directory for '$newName'");
1471 return -1;
1472 }
1473 $self->VPrint(0, "Created directory for '$newName'");
1474 }
1475 # attempt to rename the file
1476 unless (rename $file, $newName) {
1477 local (*EXIFTOOL_SFN_IN, *EXIFTOOL_SFN_OUT);
1478 # renaming didn't work, so copy the file instead
1479 unless (open EXIFTOOL_SFN_IN, $file) {
1480 $self->Warn("Error opening '$file'");
1481 return -1;
1482 }
1483 unless (open EXIFTOOL_SFN_OUT, ">$newName") {
1484 close EXIFTOOL_SFN_IN;
1485 $self->Warn("Error creating '$newName'");
1486 return -1;
1487 }
1488 binmode EXIFTOOL_SFN_IN;
1489 binmode EXIFTOOL_SFN_OUT;
1490 my ($buff, $err);
1491 while (read EXIFTOOL_SFN_IN, $buff, 65536) {
1492 print EXIFTOOL_SFN_OUT $buff or $err = 1;
1493 }
1494 close EXIFTOOL_SFN_OUT or $err = 1;
1495 close EXIFTOOL_SFN_IN;
1496 if ($err) {
1497 unlink $newName; # erase bad output file
1498 $self->Warn("Error writing '$newName'");
1499 return -1;
1500 }
1501 # preserve modification time
1502 my $modTime = $^T - (-M $file) * (24 * 3600);
1503 my $accTime = $^T - (-A $file) * (24 * 3600);
1504 utime($accTime, $modTime, $newName);
1505 # remove the original file
1506 unlink $file or $self->Warn('Error removing old file');
1507 }
1508 ++$self->{CHANGED};
1509 $self->VerboseValue('+ FileName', $newName);
1510 return 1;
1511}
1512
1513#------------------------------------------------------------------------------
1514# Write information back to file
1515# Inputs: 0) ExifTool object reference,
1516# 1) input filename, file ref, or scalar ref (or '' or undef to create from scratch)
1517# 2) output filename, file ref, or scalar ref (or undef to overwrite)
1518# 3) optional output file type (required only if input file is not specified
1519# and output file is a reference)
1520# Returns: 1=file written OK, 2=file written but no changes made, 0=file write error
1521sub WriteInfo($$;$$)
1522{
1523 local ($_, *EXIFTOOL_FILE2, *EXIFTOOL_OUTFILE);
1524 my ($self, $infile, $outfile, $outType) = @_;
1525 my (@fileTypeList, $fileType, $tiffType, $hdr, $seekErr, $type, $tmpfile);
1526 my ($inRef, $outRef, $closeIn, $closeOut, $outPos, $outBuff, $eraseIn);
1527 my $oldRaf = $self->{RAF};
1528 my $rtnVal = 0;
1529
1530 # initialize member variables
1531 $self->Init();
1532
1533 # first, save original file modify date if necessary
1534 # (do this now in case we are modifying file in place and shifting date)
1535 my ($nvHash, $originalTime);
1536 my $fileModifyDate = $self->GetNewValues('FileModifyDate', \$nvHash);
1537 if (defined $fileModifyDate and IsOverwriting($nvHash) < 0 and
1538 defined $infile and ref $infile ne 'SCALAR')
1539 {
1540 $originalTime = -M $infile;
1541 }
1542#
1543# do quick in-place change of file dir/name or date if that is all we are doing
1544#
1545 my ($numNew, $numPseudo) = $self->CountNewValues();
1546 if (not defined $outfile and defined $infile) {
1547 my $newFileName = $self->GetNewValues('FileName', \$nvHash);
1548 if ($numNew == $numPseudo) {
1549 $rtnVal = 2;
1550 if (defined $fileModifyDate and (not ref $infile or UNIVERSAL::isa($infile,'GLOB'))) {
1551 $self->SetFileModifyDate($infile) > 0 and $rtnVal = 1;
1552 }
1553 if (defined $newFileName and not ref $infile) {
1554 $self->SetFileName($infile) > 0 and $rtnVal = 1;
1555 }
1556 return $rtnVal;
1557 } elsif (defined $newFileName and length $newFileName) {
1558 # can't simply rename file, so just set the output name if new FileName
1559 # --> in this case, must erase original copy
1560 if (ref $infile) {
1561 $outfile = $newFileName;
1562 # can't delete original
1563 } elsif (IsOverwriting($nvHash, $infile)) {
1564 $outfile = GetNewFileName($infile, $newFileName);
1565 $eraseIn = 1; # delete original
1566 }
1567 }
1568 }
1569#
1570# set up input file
1571#
1572 if (ref $infile) {
1573 $inRef = $infile;
1574 if (UNIVERSAL::isa($inRef,'GLOB')) {
1575 seek($inRef, 0, 0); # make sure we are at the start of the file
1576 } elsif ($] >= 5.006 and (eval 'require Encode; Encode::is_utf8($$inRef)' or $@)) {
1577 # convert image data from UTF-8 to character stream if necessary
1578 my $buff = $@ ? pack('C*',unpack('U0C*',$$inRef)) : Encode::encode('utf8',$$inRef);
1579 if (defined $outfile) {
1580 $inRef = \$buff;
1581 } else {
1582 $$inRef = $buff;
1583 }
1584 }
1585 } elsif (defined $infile and $infile ne '') {
1586 # write to a temporary file if no output file given
1587 $outfile = $tmpfile = "${infile}_exiftool_tmp" unless defined $outfile;
1588 if (open(EXIFTOOL_FILE2, $infile)) {
1589 $fileType = GetFileType($infile);
1590 @fileTypeList = GetFileType($infile);
1591 $tiffType = $$self{FILE_EXT} = GetFileExtension($infile);
1592 $self->VPrint(0, "Rewriting $infile...\n");
1593 $inRef = \*EXIFTOOL_FILE2;
1594 $closeIn = 1; # we must close the file since we opened it
1595 } else {
1596 $self->Error('Error opening file');
1597 return 0;
1598 }
1599 } elsif (not defined $outfile) {
1600 $self->Error("WriteInfo(): Must specify infile or outfile\n");
1601 return 0;
1602 } else {
1603 # create file from scratch
1604 $outType = GetFileExtension($outfile) unless $outType or ref $outfile;
1605 if (CanCreate($outType)) {
1606 $fileType = $tiffType = $outType; # use output file type if no input file
1607 $infile = "$fileType file"; # make bogus file name
1608 $self->VPrint(0, "Creating $infile...\n");
1609 $inRef = \ ''; # set $inRef to reference to empty data
1610 } elsif ($outType) {
1611 $self->Error("Can't create $outType files");
1612 return 0;
1613 } else {
1614 $self->Error("Can't create file (unknown type)");
1615 return 0;
1616 }
1617 }
1618 unless (@fileTypeList) {
1619 if ($fileType) {
1620 @fileTypeList = ( $fileType );
1621 } else {
1622 @fileTypeList = @fileTypes;
1623 $tiffType = 'TIFF';
1624 }
1625 }
1626#
1627# set up output file
1628#
1629 if (ref $outfile) {
1630 $outRef = $outfile;
1631 if (UNIVERSAL::isa($outRef,'GLOB')) {
1632 binmode($outRef);
1633 $outPos = tell($outRef);
1634 } else {
1635 # initialize our output buffer if necessary
1636 defined $$outRef or $$outRef = '';
1637 $outPos = length($$outRef);
1638 }
1639 } elsif (not defined $outfile) {
1640 # editing in place, so write to memory first
1641 # (only when infile is a file ref or scalar ref)
1642 $outBuff = '';
1643 $outRef = \$outBuff;
1644 $outPos = 0;
1645 } elsif (-e $outfile) {
1646 $self->Error("File already exists: $outfile");
1647 } elsif (open(EXIFTOOL_OUTFILE, ">$outfile")) {
1648 $outRef = \*EXIFTOOL_OUTFILE;
1649 $closeOut = 1; # we must close $outRef
1650 binmode($outRef);
1651 $outPos = 0;
1652 } else {
1653 my $tmp = $tmpfile ? ' temporary' : '';
1654 $self->Error("Error creating$tmp file: $outfile");
1655 }
1656#
1657# write the file
1658#
1659 until ($self->{VALUE}{Error}) {
1660 # create random access file object (disable seek test in case of straight copy)
1661 my $raf = new File::RandomAccess($inRef, 1);
1662 $raf->BinMode();
1663 if ($numNew == $numPseudo) {
1664 $rtnVal = 1;
1665 # just do a straight copy of the file (no "real" tags are being changed)
1666 my $buff;
1667 while ($raf->Read($buff, 65536)) {
1668 Write($outRef, $buff) or $rtnVal = -1, last;
1669 }
1670 last;
1671 } elsif (not ref $infile and ($infile eq '-' or $infile =~ /\|$/)) {
1672 # patch for Windows command shell pipe
1673 $raf->{TESTED} = -1; # force buffering
1674 } else {
1675 $raf->SeekTest();
1676 }
1677 # $raf->Debug() and warn " RAF debugging enabled!\n";
1678 my $inPos = $raf->Tell();
1679 $self->{RAF} = $raf;
1680 my %dirInfo = (
1681 RAF => $raf,
1682 OutFile => $outRef,
1683 );
1684 $raf->Read($hdr, 1024) or $hdr = '';
1685 $raf->Seek($inPos, 0) or $seekErr = 1;
1686 my $wrongType;
1687 until ($seekErr) {
1688 $type = shift @fileTypeList;
1689 # do quick test to see if this is the right file type
1690 if ($magicNumber{$type} and length($hdr) and $hdr !~ /^$magicNumber{$type}/s) {
1691 next if @fileTypeList;
1692 $wrongType = 1;
1693 last;
1694 }
1695 # save file type in member variable
1696 $dirInfo{Parent} = $self->{FILE_TYPE} = $self->{PATH}[0] = $type;
1697 # determine which directories we must write for this file type
1698 $self->InitWriteDirs($type);
1699 if ($type eq 'JPEG') {
1700 $rtnVal = $self->WriteJPEG(\%dirInfo);
1701 } elsif ($type eq 'TIFF') {
1702 # disallow writing of some TIFF-based RAW images:
1703 if (grep /^$tiffType$/, @{$noWriteFile{TIFF}}) {
1704 $fileType = $tiffType;
1705 undef $rtnVal;
1706 } else {
1707 $dirInfo{Parent} = $tiffType;
1708 $rtnVal = $self->ProcessTIFF(\%dirInfo);
1709 }
1710 } elsif ($type eq 'GIF') {
1711 require Image::ExifTool::GIF;
1712 $rtnVal = Image::ExifTool::GIF::ProcessGIF($self,\%dirInfo);
1713 } elsif ($type eq 'CRW') {
1714 require Image::ExifTool::CanonRaw;
1715 $rtnVal = Image::ExifTool::CanonRaw::WriteCRW($self, \%dirInfo);
1716 } elsif ($type eq 'MRW') {
1717 require Image::ExifTool::MinoltaRaw;
1718 $rtnVal = Image::ExifTool::MinoltaRaw::ProcessMRW($self, \%dirInfo);
1719 } elsif ($type eq 'RAF') {
1720 require Image::ExifTool::FujiFilm;
1721 $rtnVal = Image::ExifTool::FujiFilm::WriteRAF($self, \%dirInfo);
1722 } elsif ($type eq 'ORF' or $type eq 'RAW') {
1723 $rtnVal = $self->ProcessTIFF(\%dirInfo);
1724 } elsif ($type eq 'X3F') {
1725 require Image::ExifTool::SigmaRaw;
1726 $rtnVal = Image::ExifTool::SigmaRaw::ProcessX3F($self, \%dirInfo);
1727 } elsif ($type eq 'PNG') {
1728 require Image::ExifTool::PNG;
1729 $rtnVal = Image::ExifTool::PNG::ProcessPNG($self, \%dirInfo);
1730 } elsif ($type eq 'MIE') {
1731 require Image::ExifTool::MIE;
1732 $rtnVal = Image::ExifTool::MIE::ProcessMIE($self, \%dirInfo);
1733 } elsif ($type eq 'XMP') {
1734 require Image::ExifTool::XMP;
1735 $rtnVal = Image::ExifTool::XMP::WriteXMP($self, \%dirInfo);
1736 } elsif ($type eq 'PPM') {
1737 require Image::ExifTool::PPM;
1738 $rtnVal = Image::ExifTool::PPM::ProcessPPM($self, \%dirInfo);
1739 } elsif ($type eq 'PSD') {
1740 require Image::ExifTool::Photoshop;
1741 $rtnVal = Image::ExifTool::Photoshop::ProcessPSD($self, \%dirInfo);
1742 } elsif ($type eq 'EPS' or $type eq 'PS') {
1743 require Image::ExifTool::PostScript;
1744 $rtnVal = Image::ExifTool::PostScript::WritePS($self, \%dirInfo);
1745 } elsif ($type eq 'PDF') {
1746 require Image::ExifTool::PDF;
1747 $rtnVal = Image::ExifTool::PDF::WritePDF($self, \%dirInfo);
1748 } elsif ($type eq 'ICC') {
1749 require Image::ExifTool::ICC_Profile;
1750 $rtnVal = Image::ExifTool::ICC_Profile::WriteICC($self, \%dirInfo);
1751 } elsif ($type eq 'VRD') {
1752 require Image::ExifTool::CanonVRD;
1753 $rtnVal = Image::ExifTool::CanonVRD::ProcessVRD($self, \%dirInfo);
1754 } elsif ($type eq 'JP2') {
1755 require Image::ExifTool::Jpeg2000;
1756 $rtnVal = Image::ExifTool::Jpeg2000::ProcessJP2($self, \%dirInfo);
1757 } elsif ($type eq 'IND') {
1758 require Image::ExifTool::InDesign;
1759 $rtnVal = Image::ExifTool::InDesign::ProcessIND($self, \%dirInfo);
1760 } elsif ($type eq 'EXIF') {
1761 # go through WriteDirectory so block writes, etc are handled
1762 my $tagTablePtr = GetTagTable('Image::ExifTool::Exif::Main');
1763 my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr, \&WriteTIFF);
1764 if (defined $buff) {
1765 $rtnVal = Write($outRef, $buff) ? 1 : -1;
1766 } else {
1767 $rtnVal = 0;
1768 }
1769 } else {
1770 undef $rtnVal; # flag that we don't write this type of file
1771 }
1772 # all done unless we got the wrong type
1773 last if $rtnVal;
1774 last unless @fileTypeList;
1775 # seek back to original position in files for next try
1776 $raf->Seek($inPos, 0) or $seekErr = 1, last;
1777 if (UNIVERSAL::isa($outRef,'GLOB')) {
1778 seek($outRef, 0, $outPos);
1779 } else {
1780 $$outRef = substr($$outRef, 0, $outPos);
1781 }
1782 }
1783 # print file format errors
1784 unless ($rtnVal) {
1785 my $err;
1786 if ($seekErr) {
1787 $err = 'Error seeking in file';
1788 } elsif ($fileType and defined $rtnVal) {
1789 if ($self->{VALUE}{Error}) {
1790 # existing error message will do
1791 } elsif ($fileType eq 'RAW') {
1792 $err = 'Writing this type of RAW file is not supported';
1793 } else {
1794 if ($wrongType) {
1795 $err = "Not a valid $fileType";
1796 # do a quick check to see what this file looks like
1797 foreach $type (@fileTypes) {
1798 next unless $magicNumber{$type};
1799 next unless $hdr =~ /^$magicNumber{$type}/s;
1800 $err .= " (looks more like a $type)";
1801 last;
1802 }
1803 } else {
1804 $err = 'Format error in file';
1805 }
1806 }
1807 } elsif ($fileType) {
1808 # get specific type of file from extension
1809 $fileType = GetFileExtension($infile) if $infile and GetFileType($infile);
1810 $err = "Writing of $fileType files is not yet supported";
1811 } else {
1812 $err = 'Writing of this type of file is not supported';
1813 }
1814 $self->Error($err) if $err;
1815 $rtnVal = 0; # (in case it was undef)
1816 }
1817 # $raf->Close(); # only used to force debug output
1818 last; # (didn't really want to loop)
1819 }
1820 # don't return success code if any error occurred
1821 if ($rtnVal > 0) {
1822 unless (Tell($outRef) or $self->{VALUE}{Error}) {
1823 # don't write a file with zero length
1824 if (defined $hdr and length $hdr) {
1825 $self->Error("Can't delete all meta information from $type file");
1826 } else {
1827 $self->Error('Nothing to write');
1828 }
1829 }
1830 $rtnVal = 0 if $self->{VALUE}{Error};
1831 }
1832
1833 # rewrite original file in place if required
1834 if (defined $outBuff) {
1835 if ($rtnVal <= 0 or not $self->{CHANGED}) {
1836 # nothing changed, so no need to write $outBuff
1837 } elsif (UNIVERSAL::isa($inRef,'GLOB')) {
1838 my $len = length($outBuff);
1839 my $size;
1840 $rtnVal = -1 unless
1841 seek($inRef, 0, 2) and # seek to the end of file
1842 ($size = tell $inRef) >= 0 and # get the file size
1843 seek($inRef, 0, 0) and # seek back to the start
1844 print $inRef $outBuff and # write the new data
1845 ($len >= $size or # if necessary:
1846 eval 'truncate($inRef, $len)'); # shorten output file
1847 } else {
1848 $$inRef = $outBuff; # replace original data
1849 }
1850 $outBuff = ''; # free memory but leave $outBuff defined
1851 }
1852 # close input file if we opened it
1853 if ($closeIn) {
1854 # errors on input file are significant if we edited the file in place
1855 $rtnVal and $rtnVal = -1 unless close($inRef) or not defined $outBuff;
1856 if ($rtnVal > 0) {
1857 # copy Mac OS resource fork if it exists
1858 if ($^O eq 'darwin' and -s "$infile/rsrc") {
1859 if ($$self{DEL_GROUP} and $$self{DEL_GROUP}{RSRC}) {
1860 $self->VPrint(0,"Deleting Mac OS resource fork\n");
1861 ++$$self{CHANGED};
1862 } else {
1863 $self->VPrint(0,"Copying Mac OS resource fork\n");
1864 my ($buf, $err);
1865 local (*SRC, *DST);
1866 if (open SRC, "$infile/rsrc") {
1867 if (open DST, ">$outfile/rsrc") {
1868 binmode SRC; # (not necessary for Darwin, but let's be thorough)
1869 binmode DST;
1870 while (read SRC, $buf, 65536) {
1871 print DST $buf or $err = 'copying', last;
1872 }
1873 close DST or $err or $err = 'closing';
1874 } else {
1875 # (this is normal if the destination filesystem isn't Mac OS)
1876 $self->Warn('Error creating Mac OS resource fork');
1877 }
1878 close SRC;
1879 } else {
1880 $err = 'opening';
1881 }
1882 $rtnVal = 0 if $err and $self->Error("Error $err Mac OS resource fork", 1);
1883 }
1884 }
1885 # erase input file if renaming while editing information in place
1886 unlink $infile or $self->Warn('Error erasing original file') if $eraseIn;
1887 }
1888 }
1889 # close output file if we created it
1890 if ($closeOut) {
1891 # close file and set $rtnVal to -1 if there was an error
1892 $rtnVal and $rtnVal = -1 unless close($outRef);
1893 # erase the output file if we weren't successful
1894 if ($rtnVal <= 0) {
1895 unlink $outfile;
1896 # else rename temporary file if necessary
1897 } elsif ($tmpfile) {
1898 CopyFileAttrs($infile, $tmpfile); # copy attributes to new file
1899 unless (rename($tmpfile, $infile)) {
1900 # some filesystems won't overwrite with 'rename', so try erasing original
1901 if (not unlink($infile)) {
1902 unlink $tmpfile;
1903 $self->Error('Error renaming temporary file');
1904 $rtnVal = 0;
1905 } elsif (not rename($tmpfile, $infile)) {
1906 $self->Error('Error renaming temporary file after deleting original');
1907 $rtnVal = 0;
1908 }
1909 }
1910 }
1911 }
1912 # set FileModifyDate if requested (and if possible!)
1913 if (defined $fileModifyDate and $rtnVal > 0 and
1914 ($closeOut or ($closeIn and defined $outBuff)) and
1915 $self->SetFileModifyDate($closeOut ? $outfile : $infile, $originalTime) > 0)
1916 {
1917 ++$self->{CHANGED}; # we changed something
1918 }
1919 # check for write error and set appropriate error message and return value
1920 if ($rtnVal < 0) {
1921 $self->Error('Error writing output file') unless $$self{VALUE}{Error};
1922 $rtnVal = 0; # return 0 on failure
1923 } elsif ($rtnVal > 0) {
1924 ++$rtnVal unless $self->{CHANGED};
1925 }
1926 # set things back to the way they were
1927 $self->{RAF} = $oldRaf;
1928
1929 return $rtnVal;
1930}
1931
1932#------------------------------------------------------------------------------
1933# Get list of all available tags for specified group
1934# Inputs: 0) optional group name (or string of names separated by colons)
1935# Returns: tag list (sorted alphabetically)
1936# Notes: Can't get tags for specific IFD
1937sub GetAllTags(;$)
1938{
1939 local $_;
1940 my $group = shift;
1941 my (%allTags, @groups);
1942 @groups = split ':', $group if $group;
1943
1944 my $exifTool = new Image::ExifTool;
1945 LoadAllTables(); # first load all our tables
1946 my @tableNames = keys %allTables;
1947
1948 # loop through all tables and save tag names to %allTags hash
1949 while (@tableNames) {
1950 my $table = GetTagTable(pop @tableNames);
1951 my $tagID;
1952 foreach $tagID (TagTableKeys($table)) {
1953 my @infoArray = GetTagInfoList($table,$tagID);
1954 my $tagInfo;
1955GATInfo: foreach $tagInfo (@infoArray) {
1956 my $tag = $$tagInfo{Name};
1957 $tag or warn("no name for tag!\n"), next;
1958 # don't list subdirectories unless they are writable
1959 next if $$tagInfo{SubDirectory} and not $$tagInfo{Writable};
1960 next if $$tagInfo{Hidden}; # ignore hidden tags
1961 if (@groups) {
1962 my @tg = $exifTool->GetGroup($tagInfo);
1963 foreach $group (@groups) {
1964 next GATInfo unless grep /^$group$/i, @tg;
1965 }
1966 }
1967 $allTags{$tag} = 1;
1968 }
1969 }
1970 }
1971 return sort keys %allTags;
1972}
1973
1974#------------------------------------------------------------------------------
1975# Get list of all writable tags
1976# Inputs: 0) optional group name (or names separated by colons)
1977# Returns: tag list (sorted alphbetically)
1978sub GetWritableTags(;$)
1979{
1980 local $_;
1981 my $group = shift;
1982 my (%writableTags, @groups);
1983 @groups = split ':', $group if $group;
1984
1985 my $exifTool = new Image::ExifTool;
1986 LoadAllTables();
1987 my @tableNames = keys %allTables;
1988
1989 while (@tableNames) {
1990 my $tableName = pop @tableNames;
1991 my $table = GetTagTable($tableName);
1992 # attempt to load Write tables if autoloaded
1993 my @path = split(/::/,$tableName);
1994 if (@path > 3) {
1995 my $i = $#path - 1;
1996 $path[$i] = "Write$path[$i]"; # add 'Write' before class name
1997 my $module = join('::',@path[0..($#path-1)]);
1998 eval "require $module"; # (fails silently if nothing loaded)
1999 }
2000 my $tagID;
2001 foreach $tagID (TagTableKeys($table)) {
2002 my @infoArray = GetTagInfoList($table,$tagID);
2003 my $tagInfo;
2004GWTInfo: foreach $tagInfo (@infoArray) {
2005 my $tag = $$tagInfo{Name};
2006 $tag or warn("no name for tag!\n"), next;
2007 my $writable = $$tagInfo{Writable};
2008 next unless $writable or ($table->{WRITABLE} and
2009 not defined $writable and not $$tagInfo{SubDirectory});
2010 next if $$tagInfo{Hidden}; # ignore hidden tags
2011 if (@groups) {
2012 my @tg = $exifTool->GetGroup($tagInfo);
2013 foreach $group (@groups) {
2014 next GWTInfo unless grep /^$group$/i, @tg;
2015 }
2016 }
2017 $writableTags{$tag} = 1;
2018 }
2019 }
2020 }
2021 return sort keys %writableTags;
2022}
2023
2024#------------------------------------------------------------------------------
2025# Get list of all group names
2026# Inputs: 1) Group family number
2027# Returns: List of group names (sorted alphabetically)
2028sub GetAllGroups($)
2029{
2030 local $_;
2031 my $family = shift || 0;
2032
2033 $family == 3 and return('Doc#', 'Main');
2034 $family == 4 and return('Copy#');
2035
2036 LoadAllTables(); # first load all our tables
2037
2038 my @tableNames = keys %allTables;
2039
2040 # loop through all tag tables and get all group names
2041 my %allGroups;
2042 while (@tableNames) {
2043 my $table = GetTagTable(pop @tableNames);
2044 my ($grps, $grp, $tag, $tagInfo);
2045 $allGroups{$grp} = 1 if ($grps = $$table{GROUPS}) and ($grp = $$grps{$family});
2046 foreach $tag (TagTableKeys($table)) {
2047 my @infoArray = GetTagInfoList($table, $tag);
2048 foreach $tagInfo (@infoArray) {
2049 next unless ($grps = $$tagInfo{Groups}) and ($grp = $$grps{$family});
2050 $allGroups{$grp} = 1;
2051 }
2052 }
2053 }
2054 return sort keys %allGroups;
2055}
2056
2057#------------------------------------------------------------------------------
2058# get priority group list for new values
2059# Inputs: 0) ExifTool object reference
2060# Returns: List of group names
2061sub GetNewGroups($)
2062{
2063 my $self = shift;
2064 return @{$self->{WRITE_GROUPS}};
2065}
2066
2067#------------------------------------------------------------------------------
2068# Get list of all deletable group names
2069# Returns: List of group names (sorted alphabetically)
2070sub GetDeleteGroups()
2071{
2072 return sort @delGroups;
2073}
2074
2075#==============================================================================
2076# Functions below this are not part of the public API
2077
2078#------------------------------------------------------------------------------
2079# Un-escape string according to options settings and clear UTF-8 flag
2080# Inputs: 0) ExifTool ref, 1) string ref or string ref ref
2081# Notes: also de-references SCALAR values
2082sub Sanitize($$)
2083{
2084 my ($self, $valPt) = @_;
2085 # de-reference SCALAR references
2086 $$valPt = $$$valPt if ref $$valPt eq 'SCALAR';
2087 # make sure the Perl UTF-8 flag is OFF for the value if perl 5.6 or greater
2088 # (otherwise our byte manipulations get corrupted!!)
2089 if ($] >= 5.006 and (eval 'require Encode; Encode::is_utf8($$valPt)' or $@)) {
2090 # repack by hand if Encode isn't available
2091 $$valPt = $@ ? pack('C*',unpack('U0C*',$$valPt)) : Encode::encode('utf8',$$valPt);
2092 }
2093 # un-escape value if necessary
2094 if ($$self{OPTIONS}{Escape}) {
2095 # (XMP.pm and HTML.pm were require'd as necessary when option was set)
2096 if ($$self{OPTIONS}{Escape} eq 'XML') {
2097 $$valPt = Image::ExifTool::XMP::UnescapeXML($$valPt);
2098 } elsif ($$self{OPTIONS}{Escape} eq 'HTML') {
2099 $$valPt = Image::ExifTool::HTML::UnescapeHTML($$valPt);
2100 }
2101 }
2102}
2103
2104#------------------------------------------------------------------------------
2105# Apply inverse conversions
2106# Inputs: 0) ExifTool ref, 1) value, 2) tagInfo (or Struct item) ref,
2107# 3) tag name, 4) group 1 name, 5) conversion type (or undef),
2108# 6) [optional] want group
2109# Returns: 0) converted value, 1) error string (or undef on success)
2110# Notes: Uses ExifTool "ConvType" member to specify conversion type
2111sub ConvInv($$$$$;$$)
2112{
2113 my ($self, $val, $tagInfo, $tag, $wgrp1, $convType, $wantGroup) = @_;
2114 my ($err, $type);
2115
2116Conv: for (;;) {
2117 if (not defined $type) {
2118 # split value into list if necessary
2119 if ($$tagInfo{List}) {
2120 my $listSplit = $$tagInfo{AutoSplit} || $self->{OPTIONS}{ListSplit};
2121 if (defined $listSplit) {
2122 $listSplit = ',?\s+' if $listSplit eq '1' and $$tagInfo{AutoSplit};
2123 my @splitVal = split /$listSplit/, $val;
2124 $val = \@splitVal if @splitVal > 1;
2125 }
2126 }
2127 $type = $convType || $$self{ConvType} || 'PrintConv';
2128 } elsif ($type ne 'ValueConv') {
2129 $type = 'ValueConv';
2130 } else {
2131 # finally, do our value check
2132 my ($err2, $v);
2133 if ($tagInfo->{WriteCheck}) {
2134 #### eval WriteCheck ($self, $tagInfo, $val)
2135 $err2 = eval $tagInfo->{WriteCheck};
2136 $@ and warn($@), $err2 = 'Error evaluating WriteCheck';
2137 }
2138 unless ($err2) {
2139 my $table = $tagInfo->{Table};
2140 if ($table and $table->{CHECK_PROC} and not $$tagInfo{RawConvInv}) {
2141 my $checkProc = $table->{CHECK_PROC};
2142 if (ref $val eq 'ARRAY') {
2143 # loop through array values
2144 foreach $v (@$val) {
2145 $err2 = &$checkProc($self, $tagInfo, \$v);
2146 last if $err2;
2147 }
2148 } else {
2149 $err2 = &$checkProc($self, $tagInfo, \$val);
2150 }
2151 }
2152 }
2153 if (defined $err2) {
2154 # skip writing this tag if error string is empty
2155 $err2 or goto WriteAlso;
2156 $err = "$err2 for $wgrp1:$tag";
2157 $self->VPrint(2, "$err\n");
2158 undef $val; # value was invalid
2159 }
2160 last;
2161 }
2162 my $conv = $tagInfo->{$type};
2163 my $convInv = $tagInfo->{"${type}Inv"};
2164 # nothing to do at this level if no conversion defined
2165 next unless defined $conv or defined $convInv;
2166
2167 my (@valList, $index, $convList, $convInvList);
2168 if (ref $val eq 'ARRAY') {
2169 # handle ValueConv of ListSplit and AutoSplit values
2170 @valList = @$val;
2171 $val = $valList[$index = 0];
2172 } elsif (ref $conv eq 'ARRAY' or ref $convInv eq 'ARRAY') {
2173 # handle conversion lists
2174 @valList = split /$listSep{$type}/, $val;
2175 $val = $valList[$index = 0];
2176 if (ref $conv eq 'ARRAY') {
2177 $convList = $conv;
2178 $conv = $$conv[0];
2179 }
2180 if (ref $convInv eq 'ARRAY') {
2181 $convInvList = $convInv;
2182 $convInv = $$convInv[0];
2183 }
2184 }
2185 # loop through multiple values if necessary
2186 for (;;) {
2187 if ($convInv) {
2188 # capture eval warnings too
2189 local $SIG{'__WARN__'} = \&SetWarning;
2190 undef $evalWarning;
2191 if (ref($convInv) eq 'CODE') {
2192 $val = &$convInv($val, $self);
2193 } else {
2194 #### eval PrintConvInv/ValueConvInv ($val, $self, $wantGroup)
2195 $val = eval $convInv;
2196 $@ and $evalWarning = $@;
2197 }
2198 if ($evalWarning) {
2199 # an empty warning ("\n") ignores tag with no error
2200 if ($evalWarning eq "\n") {
2201 $err = '' unless defined $err;
2202 } else {
2203 $err = CleanWarning() . " in $wgrp1:$tag (${type}Inv)";
2204 $self->VPrint(2, "$err\n");
2205 }
2206 undef $val;
2207 last Conv;
2208 } elsif (not defined $val) {
2209 $err = "Error converting value for $wgrp1:$tag (${type}Inv)";
2210 $self->VPrint(2, "$err\n");
2211 last Conv;
2212 }
2213 } elsif ($conv) {
2214 if (ref $conv eq 'HASH') {
2215 my ($multi, $lc);
2216 # insert alternate language print conversions if required
2217 if ($$self{CUR_LANG} and $type eq 'PrintConv' and
2218 ref($lc = $self->{CUR_LANG}{$tag}) eq 'HASH' and
2219 ($lc = $$lc{PrintConv}))
2220 {
2221 my %newConv;
2222 foreach (keys %$conv) {
2223 my $val = $$conv{$_};
2224 defined $$lc{$val} or $newConv{$_} = $val, next;
2225 $newConv{$_} = $self->Decode($$lc{$val}, 'UTF8');
2226 }
2227 if ($$conv{BITMASK}) {
2228 foreach (keys %{$$conv{BITMASK}}) {
2229 my $val = $$conv{BITMASK}{$_};
2230 defined $$lc{$val} or $newConv{BITMASK}{$_} = $val, next;
2231 $newConv{BITMASK}{$_} = $self->Decode($$lc{$val}, 'UTF8');
2232 }
2233 }
2234 $conv = \%newConv;
2235 }
2236 if ($$conv{BITMASK}) {
2237 my $lookupBits = $$conv{BITMASK};
2238 my ($val2, $err2) = EncodeBits($val, $lookupBits);
2239 if ($err2) {
2240 # ok, try matching a straight value
2241 ($val, $multi) = ReverseLookup($val, $conv);
2242 unless (defined $val) {
2243 $err = "Can't encode $wgrp1:$tag ($err2)";
2244 $self->VPrint(2, "$err\n");
2245 last Conv;
2246 }
2247 } elsif (defined $val2) {
2248 $val = $val2;
2249 } else {
2250 delete $$conv{BITMASK};
2251 ($val, $multi) = ReverseLookup($val, $conv);
2252 $$conv{BITMASK} = $lookupBits;
2253 }
2254 } else {
2255 ($val, $multi) = ReverseLookup($val, $conv);
2256 }
2257 unless (defined $val) {
2258 $err = "Can't convert $wgrp1:$tag (" .
2259 ($multi ? 'matches more than one' : 'not in') . " $type)";
2260 $self->VPrint(2, "$err\n");
2261 last Conv;
2262 }
2263 } elsif (not $$tagInfo{WriteAlso}) {
2264 $err = "Can't convert value for $wgrp1:$tag (no ${type}Inv)";
2265 $self->VPrint(2, "$err\n");
2266 undef $val;
2267 last Conv;
2268 }
2269 }
2270 last unless @valList;
2271 $valList[$index] = $val;
2272 if (++$index >= @valList) {
2273 # leave AutoSplit lists in ARRAY form, or join conversion lists
2274 $val = $$tagInfo{List} ? \@valList : join ' ', @valList;
2275 last;
2276 }
2277 $conv = $$convList[$index] if $convList;
2278 $convInv = $$convInvList[$index] if $convInvList;
2279 $val = $valList[$index];
2280 }
2281 } # end ValueConv/PrintConv loop
2282
2283 return($val, $err);
2284}
2285
2286#------------------------------------------------------------------------------
2287# convert tag names to values in a string (ie. "${EXIF:ISO}x $$" --> "100x $")
2288# Inputs: 0) ExifTool object ref, 1) reference to list of found tags
2289# 2) string with embedded tag names, 3) Options:
2290# undef - set missing tags to ''
2291# 'Error' - issue minor error on missing tag (and return undef)
2292# 'Warn' - issue minor warning on missing tag (and return undef)
2293# Hash ref - hash for return of tag/value pairs
2294# Returns: string with embedded tag values (or '$info{TAGNAME}' entries with Hash ref option)
2295# Notes:
2296# - tag names are not case sensitive and may end with '#' for ValueConv value
2297# - uses MissingTagValue option if set
2298sub InsertTagValues($$$;$)
2299{
2300 my ($self, $foundTags, $line, $opt) = @_;
2301 my $rtnStr = '';
2302 while ($line =~ /(.*?)\$(\{?)([-\w]+|\$|\/)(.*)/s) {
2303 my (@tags, $pre, $var, $bra, $val, $tg, @vals, $type);
2304 ($pre, $bra, $var, $line) = ($1, $2, $3, $4);
2305 # "$$" represents a "$" symbol, and "$/" is a newline
2306 if ($var eq '$' or $var eq '/') {
2307 $var = "\n" if $var eq '/';
2308 $rtnStr .= "$pre$var";
2309 $line =~ s/^\}// if $bra;
2310 next;
2311 }
2312 # allow multiple group names
2313 while ($line =~ /^:([-\w]+)(.*)/s) {
2314 my $group = $var;
2315 ($var, $line) = ($1, $2);
2316 $var = "$group:$var";
2317 }
2318 # allow trailing '#' to indicate ValueConv value
2319 $type = 'ValueConv' if $line =~ s/^#//;
2320 # remove trailing bracket if there was a leading one
2321 $line =~ s/^\}// if $bra;
2322 push @tags, $var;
2323 ExpandShortcuts(\@tags);
2324 @tags or $rtnStr .= $pre, next;
2325
2326 for (;;) {
2327 my $tag = shift @tags;
2328 if ($tag =~ /(.*):(.+)/) {
2329 my $group;
2330 ($group, $tag) = ($1, $2);
2331 # find the specified tag
2332 my @matches = grep /^$tag(\s|$)/i, @$foundTags;
2333 @matches = $self->GroupMatches($group, \@matches);
2334 foreach $tg (@matches) {
2335 if (defined $val and $tg =~ / \((\d+)\)$/) {
2336 # take the most recently extracted tag
2337 my $tagNum = $1;
2338 next if $tag !~ / \((\d+)\)$/ or $1 > $tagNum;
2339 }
2340 $val = $self->GetValue($tg, $type);
2341 $tag = $tg;
2342 last unless $tag =~ / /; # all done if we got our best match
2343 }
2344 } else {
2345 # get the tag value
2346 $val = $self->GetValue($tag, $type);
2347 unless (defined $val) {
2348 # check for tag name with different case
2349 ($tg) = grep /^$tag$/i, @$foundTags;
2350 if (defined $tg) {
2351 $val = $self->GetValue($tg, $type);
2352 $tag = $tg;
2353 }
2354 }
2355 }
2356 if (ref $val eq 'ARRAY') {
2357 $val = join($self->{OPTIONS}{ListSep}, @$val);
2358 } elsif (ref $val eq 'SCALAR') {
2359 if ($self->{OPTIONS}{Binary} or $$val =~ /^Binary data/) {
2360 $val = $$val;
2361 } else {
2362 $val = 'Binary data ' . length($$val) . ' bytes';
2363 }
2364 } elsif (not defined $val) {
2365 last unless @tags;
2366 next;
2367 }
2368 last unless @tags;
2369 push @vals, $val;
2370 undef $val;
2371 }
2372 if (@vals) {
2373 push @vals, $val if defined $val;
2374 $val = join '', @vals;
2375 }
2376 unless (defined $val or ref $opt) {
2377 $val = $self->{OPTIONS}{MissingTagValue};
2378 unless (defined $val) {
2379 no strict 'refs';
2380 return undef if $opt and &$opt($self, "Tag '$var' not defined", 1);
2381 $val = '';
2382 }
2383 }
2384 if (ref $opt eq 'HASH') {
2385 $var .= '#' if $type;
2386 $rtnStr .= "$pre\$info{'$var'}";
2387 $$opt{$var} = $val;
2388 } else {
2389 $rtnStr .= "$pre$val";
2390 }
2391 }
2392 return $rtnStr . $line;
2393}
2394
2395#------------------------------------------------------------------------------
2396# Is specified tag writable
2397# Inputs: 0) tag name, case insensitive (optional group name currently ignored)
2398# Returns: 0=exists but not writable, 1=writable, undef=doesn't exist
2399sub IsWritable($)
2400{
2401 my $tag = shift;
2402 $tag =~ s/^(.*)://; # ignore group name
2403 my @tagInfo = FindTagInfo($tag);
2404 unless (@tagInfo) {
2405 return 0 if TagExists($tag);
2406 return undef;
2407 }
2408 my $tagInfo;
2409 foreach $tagInfo (@tagInfo) {
2410 return 1 if $$tagInfo{Writable} or $tagInfo->{Table}{WRITABLE};
2411 # must call WRITE_PROC to autoload writer because this may set the writable tag
2412 my $writeProc = $tagInfo->{Table}{WRITE_PROC};
2413 next unless $writeProc;
2414 &$writeProc(); # dummy call to autoload writer
2415 return 1 if $$tagInfo{Writable};
2416 }
2417 return 0;
2418}
2419
2420#------------------------------------------------------------------------------
2421# Create directory for specified file
2422# Inputs: 0) complete file name including path
2423# Returns: 1 = directory created, 0 = nothing done, -1 = error
2424sub CreateDirectory($)
2425{
2426 local $_;
2427 my $file = shift;
2428 my $rtnVal = 0;
2429 my $dir;
2430 ($dir = $file) =~ s/[^\/]*$//; # remove filename from path specification
2431 if ($dir and not -d $dir) {
2432 my @parts = split /\//, $dir;
2433 $dir = '';
2434 foreach (@parts) {
2435 $dir .= $_;
2436 if (length $dir and not -d $dir) {
2437 # create directory since it doesn't exist
2438 mkdir($dir, 0777) or return -1;
2439 $rtnVal = 1;
2440 }
2441 $dir .= '/';
2442 }
2443 }
2444 return $rtnVal;
2445}
2446
2447#------------------------------------------------------------------------------
2448# Copy file attributes from one file to another
2449# Inputs: 0) source file name, 1) destination file name
2450# Notes: eventually add support for extended attributes?
2451sub CopyFileAttrs($$)
2452{
2453 my ($src, $dst) = @_;
2454 my ($mode, $uid, $gid) = (stat($src))[2, 4, 5];
2455 eval { chmod($mode & 07777, $dst) } if defined $mode;
2456 eval { chown($uid, $gid, $dst) } if defined $uid and defined $gid;
2457}
2458
2459#------------------------------------------------------------------------------
2460# Get new file name
2461# Inputs: 0) existing name, 1) new name
2462# Returns: new file path name
2463sub GetNewFileName($$)
2464{
2465 my ($oldName, $newName) = @_;
2466 my ($dir, $name) = ($oldName =~ m{(.*/)(.*)});
2467 ($dir, $name) = ('', $oldName) unless defined $dir;
2468 if ($newName =~ m{/$}) {
2469 $newName = "$newName$name"; # change dir only
2470 } elsif ($newName !~ m{/}) {
2471 $newName = "$dir$newName"; # change name only if newname doesn't specify dir
2472 } # else change dir and name
2473 return $newName;
2474}
2475
2476#------------------------------------------------------------------------------
2477# Get next available tag key
2478# Inputs: 0) hash reference (keys are tag keys), 1) tag name
2479# Returns: next available tag key
2480sub NextTagKey($$)
2481{
2482 my ($info, $tag) = @_;
2483 return $tag unless exists $$info{$tag};
2484 my $i;
2485 for ($i=1; ; ++$i) {
2486 my $key = "$tag ($i)";
2487 return $key unless exists $$info{$key};
2488 }
2489}
2490
2491#------------------------------------------------------------------------------
2492# Reverse hash lookup
2493# Inputs: 0) value, 1) hash reference
2494# Returns: Hash key or undef if not found (plus flag for multiple matches in list context)
2495sub ReverseLookup($$)
2496{
2497 my ($val, $conv) = @_;
2498 return undef unless defined $val;
2499 my $multi;
2500 if ($val =~ /^Unknown\s*\((.*)\)$/i) {
2501 $val = $1; # was unknown
2502 if ($val =~ /^0x([\da-fA-F]+)$/) {
2503 $val = hex($val); # convert hex value
2504 }
2505 } else {
2506 my $qval = quotemeta $val;
2507 my @patterns = (
2508 "^$qval\$", # exact match
2509 "^(?i)$qval\$", # case-insensitive
2510 "^(?i)$qval", # beginning of string
2511 "(?i)$qval", # substring
2512 );
2513 # hash entries to ignore in reverse lookup
2514 my ($pattern, $found, $matches);
2515PAT: foreach $pattern (@patterns) {
2516 $matches = scalar grep /$pattern/, values(%$conv);
2517 next unless $matches;
2518 # multiple matches are bad unless they were exact
2519 if ($matches > 1 and $pattern !~ /\$$/) {
2520 # don't match entries that we should ignore
2521 foreach (keys %ignorePrintConv) {
2522 --$matches if defined $$conv{$_} and $$conv{$_} =~ /$pattern/;
2523 }
2524 last if $matches > 1;
2525 }
2526 foreach (sort keys %$conv) {
2527 next if $$conv{$_} !~ /$pattern/ or $ignorePrintConv{$_};
2528 $val = $_;
2529 $found = 1;
2530 last PAT;
2531 }
2532 }
2533 unless ($found) {
2534 # call OTHER conversion routine if available
2535 $val = $$conv{OTHER} ? &{$$conv{OTHER}}($val,1,$conv) : undef;
2536 $multi = 1 if $matches > 1;
2537 }
2538 }
2539 return ($val, $multi) if wantarray;
2540 return $val;
2541}
2542
2543#------------------------------------------------------------------------------
2544# Return true if we are deleting or overwriting the specified tag
2545# Inputs: 0) new value hash reference
2546# 1) optional tag value (before RawConv) if deleting specific values
2547# Returns: >0 - tag should be overwritten
2548# =0 - the tag should be preserved
2549# <0 - not sure, we need the value to know
2550sub IsOverwriting($;$)
2551{
2552 my ($nvHash, $val) = @_;
2553 return 0 unless $nvHash;
2554 # overwrite regardless if no DelValues specified
2555 return 1 unless $$nvHash{DelValue};
2556 # never overwrite if DelValue list exists but is empty
2557 my $shift = $$nvHash{Shift};
2558 return 0 unless @{$$nvHash{DelValue}} or defined $shift;
2559 # return "don't know" if we don't have a value to test
2560 return -1 unless defined $val;
2561 # apply raw conversion if necessary
2562 my $tagInfo = $$nvHash{TagInfo};
2563 my $conv = $$tagInfo{RawConv};
2564 if ($conv) {
2565 local $SIG{'__WARN__'} = \&SetWarning;
2566 undef $evalWarning;
2567 if (ref $conv eq 'CODE') {
2568 $val = &$conv($val, $$nvHash{Self});
2569 } else {
2570 my $self = $$nvHash{Self};
2571 my $tag = $$tagInfo{Name};
2572 #### eval RawConv ($self, $val, $tag, $tagInfo)
2573 $val = eval $conv;
2574 $@ and $evalWarning = $@;
2575 }
2576 return -1 unless defined $val;
2577 }
2578 # apply time shift if necessary
2579 if (defined $shift) {
2580 require 'Image/ExifTool/Shift.pl';
2581 my $err = ApplyShift($$tagInfo{Shift}, $shift, $val, $nvHash);
2582 if ($err) {
2583 $nvHash->{Self}->Warn("$err when shifting $$tagInfo{Name}");
2584 return 0;
2585 }
2586 # don't bother overwriting if value is the same
2587 return 0 if $val eq $$nvHash{Value}[0];
2588 return 1;
2589 }
2590 # return 1 if value matches a DelValue
2591 my $delVal;
2592 foreach $delVal (@{$$nvHash{DelValue}}) {
2593 return 1 if $val eq $delVal;
2594 }
2595 return 0;
2596}
2597
2598#------------------------------------------------------------------------------
2599# Return true if we are creating the specified tag even if it didn't exist before
2600# Inputs: 0) new value hash reference
2601# Returns: true if we should add the tag
2602sub IsCreating($)
2603{
2604 return $_[0]{IsCreating};
2605}
2606
2607#------------------------------------------------------------------------------
2608# Get write group for specified tag
2609# Inputs: 0) new value hash reference
2610# Returns: Write group name
2611sub GetWriteGroup($)
2612{
2613 return $_[0]{WriteGroup};
2614}
2615
2616#------------------------------------------------------------------------------
2617# Get name of write group or family 1 group
2618# Inputs: 0) ExifTool ref, 1) tagInfo ref, 2) write group name
2619# Returns: Name of group for verbose message
2620sub GetWriteGroup1($$)
2621{
2622 my ($self, $tagInfo, $writeGroup) = @_;
2623 return $writeGroup unless $writeGroup =~ /^(MakerNotes|XMP|Composite)$/;
2624 return $self->GetGroup($tagInfo, 1);
2625}
2626
2627#------------------------------------------------------------------------------
2628# Get new value hash for specified tagInfo/writeGroup
2629# Inputs: 0) ExifTool object reference, 1) reference to tag info hash
2630# 2) Write group name, 3) Options: 'delete' or 'create'
2631# Returns: new value hash reference for specified write group
2632# (or first new value hash in linked list if write group not specified)
2633sub GetNewValueHash($$;$$)
2634{
2635 my ($self, $tagInfo, $writeGroup, $opts) = @_;
2636 my $nvHash = $self->{NEW_VALUE}{$tagInfo};
2637
2638 my %opts; # quick lookup for options
2639 $opts and $opts{$opts} = 1;
2640 $writeGroup = '' unless defined $writeGroup;
2641
2642 if ($writeGroup) {
2643 # find the new value in the list with the specified write group
2644 while ($nvHash and $nvHash->{WriteGroup} ne $writeGroup) {
2645 $nvHash = $nvHash->{Next};
2646 }
2647 }
2648 # remove this entry if deleting, or if creating a new entry and
2649 # this entry is marked with "Save" flag
2650 if (defined $nvHash and ($opts{'delete'} or
2651 ($opts{'create'} and $nvHash->{Save})))
2652 {
2653 if ($opts{'delete'}) {
2654 $self->RemoveNewValueHash($nvHash, $tagInfo);
2655 undef $nvHash;
2656 } else {
2657 # save a copy of this new value hash
2658 my %copy = %$nvHash;
2659 my $key;
2660 # make copy of Value and DelValue lists
2661 foreach $key (keys %copy) {
2662 next unless ref $copy{$key} eq 'ARRAY';
2663 $copy{$key} = [ @{$copy{$key}} ];
2664 }
2665 my $saveHash = $self->{SAVE_NEW_VALUE};
2666 # add to linked list of saved new value hashes
2667 $copy{Next} = $saveHash->{$tagInfo};
2668 $saveHash->{$tagInfo} = \%copy;
2669 delete $nvHash->{Save}; # don't save it again
2670 }
2671 }
2672 if (not defined $nvHash and $opts{'create'}) {
2673 # create a new entry
2674 $nvHash = {
2675 TagInfo => $tagInfo,
2676 WriteGroup => $writeGroup,
2677 Self => $self,
2678 };
2679 # add entry to our NEW_VALUE hash
2680 if ($self->{NEW_VALUE}{$tagInfo}) {
2681 # add to end of linked list
2682 my $lastHash = LastInList($self->{NEW_VALUE}{$tagInfo});
2683 $lastHash->{Next} = $nvHash;
2684 } else {
2685 $self->{NEW_VALUE}{$tagInfo} = $nvHash;
2686 }
2687 }
2688 return $nvHash;
2689}
2690
2691#------------------------------------------------------------------------------
2692# Load all tag tables
2693sub LoadAllTables()
2694{
2695 return if $loadedAllTables;
2696
2697 # load all of our non-referenced tables (first our modules)
2698 my $table;
2699 foreach $table (@loadAllTables) {
2700 my $tableName = "Image::ExifTool::$table";
2701 $tableName .= '::Main' unless $table =~ /:/;
2702 GetTagTable($tableName);
2703 }
2704 # (then our special tables)
2705 GetTagTable('Image::ExifTool::Extra');
2706 GetTagTable('Image::ExifTool::Composite');
2707 # recursively load all tables referenced by the current tables
2708 my @tableNames = keys %allTables;
2709 my %pushedTables;
2710 while (@tableNames) {
2711 $table = GetTagTable(shift @tableNames);
2712 # call write proc if it exists in case it adds tags to the table
2713 my $writeProc = $table->{WRITE_PROC};
2714 $writeProc and &$writeProc();
2715 # recursively scan through tables in subdirectories
2716 foreach (TagTableKeys($table)) {
2717 my @infoArray = GetTagInfoList($table,$_);
2718 my $tagInfo;
2719 foreach $tagInfo (@infoArray) {
2720 my $subdir = $$tagInfo{SubDirectory} or next;
2721 my $tableName = $$subdir{TagTable} or next;
2722 # next if table already loaded or queued for loading
2723 next if $allTables{$tableName} or $pushedTables{$tableName};
2724 push @tableNames, $tableName; # must scan this one too
2725 $pushedTables{$tableName} = 1;
2726 }
2727 }
2728 }
2729 $loadedAllTables = 1;
2730}
2731
2732#------------------------------------------------------------------------------
2733# Remove new value hash from linked list (and save if necessary)
2734# Inputs: 0) ExifTool object reference, 1) new value hash ref, 2) tagInfo ref
2735sub RemoveNewValueHash($$$)
2736{
2737 my ($self, $nvHash, $tagInfo) = @_;
2738 my $firstHash = $self->{NEW_VALUE}{$tagInfo};
2739 if ($nvHash eq $firstHash) {
2740 # remove first entry from linked list
2741 if ($nvHash->{Next}) {
2742 $self->{NEW_VALUE}{$tagInfo} = $nvHash->{Next};
2743 } else {
2744 delete $self->{NEW_VALUE}{$tagInfo};
2745 }
2746 } else {
2747 # find the list element pointing to this hash
2748 $firstHash = $firstHash->{Next} while $firstHash->{Next} ne $nvHash;
2749 # remove from linked list
2750 $firstHash->{Next} = $nvHash->{Next};
2751 }
2752 # save the existing entry if necessary
2753 if ($nvHash->{Save}) {
2754 my $saveHash = $self->{SAVE_NEW_VALUE};
2755 # add to linked list of saved new value hashes
2756 $nvHash->{Next} = $saveHash->{$tagInfo};
2757 $saveHash->{$tagInfo} = $nvHash;
2758 }
2759}
2760
2761#------------------------------------------------------------------------------
2762# Remove all new value entries for specified group
2763# Inputs: 0) ExifTool object reference, 1) group name
2764sub RemoveNewValuesForGroup($$)
2765{
2766 my ($self, $group) = @_;
2767
2768 return unless $self->{NEW_VALUE};
2769
2770 # make list of all groups we must remove
2771 my @groups = ( $group );
2772 push @groups, @{$removeGroups{$group}} if $removeGroups{$group};
2773
2774 my ($out, @keys, $hashKey);
2775 $out = $self->{OPTIONS}{TextOut} if $self->{OPTIONS}{Verbose} > 1;
2776
2777 # loop though all new values, and remove any in this group
2778 @keys = keys %{$self->{NEW_VALUE}};
2779 foreach $hashKey (@keys) {
2780 my $nvHash = $self->{NEW_VALUE}{$hashKey};
2781 # loop through each entry in linked list
2782 for (;;) {
2783 my $nextHash = $nvHash->{Next};
2784 my $tagInfo = $nvHash->{TagInfo};
2785 my ($grp0,$grp1) = $self->GetGroup($tagInfo);
2786 my $wgrp = $nvHash->{WriteGroup};
2787 # use group1 if write group is not specific
2788 $wgrp = $grp1 if $wgrp eq $grp0;
2789 if (grep /^($grp0|$wgrp)$/i, @groups) {
2790 $out and print $out "Removed new value for $wgrp:$$tagInfo{Name}\n";
2791 # remove from linked list
2792 $self->RemoveNewValueHash($nvHash, $tagInfo);
2793 }
2794 $nvHash = $nextHash or last;
2795 }
2796 }
2797}
2798
2799#------------------------------------------------------------------------------
2800# Get list of tagInfo hashes for all new data
2801# Inputs: 0) ExifTool object reference, 1) optional tag table pointer
2802# Returns: list of tagInfo hashes
2803sub GetNewTagInfoList($;$)
2804{
2805 my ($self, $tagTablePtr) = @_;
2806 my @tagInfoList;
2807 my $nv = $self->{NEW_VALUE};
2808 if ($nv) {
2809 my $hashKey;
2810 foreach $hashKey (keys %$nv) {
2811 my $tagInfo = $nv->{$hashKey}{TagInfo};
2812 next if $tagTablePtr and $tagTablePtr ne $tagInfo->{Table};
2813 push @tagInfoList, $tagInfo;
2814 }
2815 }
2816 return @tagInfoList;
2817}
2818
2819#------------------------------------------------------------------------------
2820# Get hash of tagInfo references keyed on tagID for a specific table
2821# Inputs: 0) ExifTool object reference, 1-N) tag table pointers
2822# Returns: hash reference
2823sub GetNewTagInfoHash($@)
2824{
2825 my $self = shift;
2826 my (%tagInfoHash, $hashKey);
2827 my $nv = $self->{NEW_VALUE};
2828 while ($nv) {
2829 my $tagTablePtr = shift || last;
2830 foreach $hashKey (keys %$nv) {
2831 my $tagInfo = $nv->{$hashKey}{TagInfo};
2832 next if $tagTablePtr and $tagTablePtr ne $tagInfo->{Table};
2833 $tagInfoHash{$$tagInfo{TagID}} = $tagInfo;
2834 }
2835 }
2836 return \%tagInfoHash;
2837}
2838
2839#------------------------------------------------------------------------------
2840# Get a tagInfo/tagID hash for subdirectories we need to add
2841# Inputs: 0) ExifTool object reference, 1) parent tag table reference
2842# 2) parent directory name (taken from GROUP0 of tag table if not defined)
2843# Returns: Reference to Hash of subdirectory tagInfo references keyed by tagID
2844# (plus Reference to edit directory hash in list context)
2845sub GetAddDirHash($$;$)
2846{
2847 my ($self, $tagTablePtr, $parent) = @_;
2848 $parent or $parent = $tagTablePtr->{GROUPS}{0};
2849 my $tagID;
2850 my %addDirHash;
2851 my %editDirHash;
2852 my $addDirs = $self->{ADD_DIRS};
2853 my $editDirs = $self->{EDIT_DIRS};
2854 foreach $tagID (TagTableKeys($tagTablePtr)) {
2855 my @infoArray = GetTagInfoList($tagTablePtr,$tagID);
2856 my $tagInfo;
2857 foreach $tagInfo (@infoArray) {
2858 next unless $$tagInfo{SubDirectory};
2859 # get name for this sub directory
2860 # (take directory name from SubDirectory DirName if it exists,
2861 # otherwise Group0 name of SubDirectory TagTable or tag Group1 name)
2862 my $dirName = $tagInfo->{SubDirectory}{DirName};
2863 unless ($dirName) {
2864 # use tag name for directory name and save for next time
2865 $dirName = $$tagInfo{Name};
2866 $tagInfo->{SubDirectory}{DirName} = $dirName;
2867 }
2868 # save this directory information if we are writing it
2869 if ($$editDirs{$dirName} and $$editDirs{$dirName} eq $parent) {
2870 $editDirHash{$tagID} = $tagInfo;
2871 $addDirHash{$tagID} = $tagInfo if $$addDirs{$dirName};
2872 }
2873 }
2874 }
2875 return (\%addDirHash, \%editDirHash) if wantarray;
2876 return \%addDirHash;
2877}
2878
2879#------------------------------------------------------------------------------
2880# Get localized version of tagInfo hash (used by MIE, XMP, PNG and QuickTime)
2881# Inputs: 0) tagInfo hash ref, 1) locale code (ie. "en_CA" for MIE)
2882# Returns: new tagInfo hash ref, or undef if invalid
2883# - sets LangCode member in new tagInfo
2884sub GetLangInfo($$)
2885{
2886 my ($tagInfo, $langCode) = @_;
2887 # make a new tagInfo hash for this locale
2888 my $table = $$tagInfo{Table};
2889 my $tagID = $$tagInfo{TagID} . '-' . $langCode;
2890 my $langInfo = $$table{$tagID};
2891 unless ($langInfo) {
2892 # make a new tagInfo entry for this locale
2893 $langInfo = {
2894 %$tagInfo,
2895 Name => $$tagInfo{Name} . '-' . $langCode,
2896 Description => Image::ExifTool::MakeDescription($$tagInfo{Name}) .
2897 " ($langCode)",
2898 LangCode => $langCode,
2899 };
2900 AddTagToTable($table, $tagID, $langInfo);
2901 }
2902 return $langInfo;
2903}
2904
2905#------------------------------------------------------------------------------
2906# initialize ADD_DIRS and EDIT_DIRS hashes for all directories that need
2907# need to be created or will have tags changed in them
2908# Inputs: 0) ExifTool object reference, 1) file type string (or map hash ref)
2909# 2) preferred family 0 group name for creating tags
2910# Notes: The ADD_DIRS and EDIT_DIRS keys are the directory names, and the values
2911# are the names of the parent directories (undefined for a top-level directory)
2912sub InitWriteDirs($$;$)
2913{
2914 my ($self, $fileType, $preferredGroup) = @_;
2915 my $editDirs = $self->{EDIT_DIRS} = { };
2916 my $addDirs = $self->{ADD_DIRS} = { };
2917 my $fileDirs = $dirMap{$fileType};
2918 unless ($fileDirs) {
2919 return unless ref $fileType eq 'HASH';
2920 $fileDirs = $fileType;
2921 }
2922 my @tagInfoList = $self->GetNewTagInfoList();
2923 my ($tagInfo, $nvHash);
2924
2925 # save the preferred group
2926 $$self{PreferredGroup} = $preferredGroup;
2927
2928 foreach $tagInfo (@tagInfoList) {
2929 # cycle through all hashes in linked list
2930 for ($nvHash=$self->GetNewValueHash($tagInfo); $nvHash; $nvHash=$$nvHash{Next}) {
2931 # are we creating this tag? (otherwise just deleting or editing it)
2932 my $isCreating = $nvHash->{IsCreating};
2933 if ($isCreating) {
2934 # if another group is taking priority, only create
2935 # directory if specifically adding tags to this group
2936 # or if this tag isn't being added to the priority group
2937 $isCreating = 0 if $preferredGroup and
2938 $preferredGroup ne $self->GetGroup($tagInfo, 0) and
2939 $nvHash->{CreateGroups}{$preferredGroup};
2940 } else {
2941 # creating this directory if any tag is preferred and has a value
2942 $isCreating = 1 if $preferredGroup and $$nvHash{Value} and
2943 $preferredGroup eq $self->GetGroup($tagInfo, 0);
2944 }
2945 # tag belongs to directory specified by WriteGroup, or by
2946 # the Group0 name if WriteGroup not defined
2947 my $dirName = $nvHash->{WriteGroup};
2948 # remove MIE copy number(s) if they exist
2949 if ($dirName =~ /^MIE\d*(-[a-z]+)?\d*$/i) {
2950 $dirName = 'MIE' . ($1 || '');
2951 }
2952 my @dirNames;
2953 while ($dirName) {
2954 my $parent = $$fileDirs{$dirName};
2955 if (ref $parent) {
2956 push @dirNames, reverse @$parent;
2957 $parent = pop @dirNames;
2958 }
2959 $$editDirs{$dirName} = $parent;
2960 $$addDirs{$dirName} = $parent if $isCreating and $isCreating != 2;
2961 $dirName = $parent || shift @dirNames
2962 }
2963 }
2964 }
2965 if (%{$self->{DEL_GROUP}}) {
2966 # add delete groups to list of edited groups
2967 foreach (keys %{$self->{DEL_GROUP}}) {
2968 next if /^-/; # ignore excluded groups
2969 my $dirName = $_;
2970 # translate necessary group 0 names
2971 $dirName = $translateWriteGroup{$dirName} if $translateWriteGroup{$dirName};
2972 # convert XMP group 1 names
2973 $dirName = 'XMP' if $dirName =~ /^XMP-/;
2974 my @dirNames;
2975 while ($dirName) {
2976 my $parent = $$fileDirs{$dirName};
2977 if (ref $parent) {
2978 push @dirNames, reverse @$parent;
2979 $parent = pop @dirNames;
2980 }
2981 $$editDirs{$dirName} = $parent;
2982 $dirName = $parent || shift @dirNames
2983 }
2984 }
2985 }
2986 # special case to edit JFIF to get resolutions if editing EXIF information
2987 if ($$editDirs{IFD0} and $$fileDirs{JFIF}) {
2988 $$editDirs{JFIF} = 'IFD1';
2989 $$editDirs{APP0} = undef;
2990 }
2991
2992 if ($self->{OPTIONS}{Verbose}) {
2993 my $out = $self->{OPTIONS}{TextOut};
2994 print $out " Editing tags in: ";
2995 foreach (sort keys %$editDirs) { print $out "$_ "; }
2996 print $out "\n";
2997 return unless $self->{OPTIONS}{Verbose} > 1;
2998 print $out " Creating tags in: ";
2999 foreach (sort keys %$addDirs) { print $out "$_ "; }
3000 print $out "\n";
3001 }
3002}
3003
3004#------------------------------------------------------------------------------
3005# Write an image directory
3006# Inputs: 0) ExifTool object reference, 1) source directory information reference
3007# 2) tag table reference, 3) optional reference to writing procedure
3008# Returns: New directory data or undefined on error
3009sub WriteDirectory($$$;$)
3010{
3011 my ($self, $dirInfo, $tagTablePtr, $writeProc) = @_;
3012 my ($out, $nvHash);
3013
3014 $tagTablePtr or return undef;
3015 $out = $self->{OPTIONS}{TextOut} if $self->{OPTIONS}{Verbose};
3016 # set directory name from default group0 name if not done already
3017 my $dirName = $$dirInfo{DirName};
3018 my $dataPt = $$dirInfo{DataPt};
3019 my $grp0 = $tagTablePtr->{GROUPS}{0};
3020 $dirName or $dirName = $$dirInfo{DirName} = $grp0;
3021 if (%{$self->{DEL_GROUP}}) {
3022 my $delGroup = $self->{DEL_GROUP};
3023 # delete entire directory if specified
3024 my $grp1 = $dirName;
3025 my $delFlag = ($$delGroup{$grp0} or $$delGroup{$grp1});
3026 if ($delFlag) {
3027 unless ($blockExifTypes{$$self{FILE_TYPE}}) {
3028 # restrict delete logic to prevent entire tiff image from being killed
3029 # (don't allow IFD0 to be deleted, and delete only ExifIFD if EXIF specified)
3030 if ($$self{FILE_TYPE} eq 'PSD') {
3031 # don't delete Photoshop directories from PSD image
3032 undef $grp1 if $grp0 eq 'Photoshop';
3033 } elsif ($$self{FILE_TYPE} =~ /^(EPS|PS)$/) {
3034 # allow anything to be deleted from PostScript files
3035 } elsif ($grp1 eq 'IFD0') {
3036 my $type = $self->{TIFF_TYPE} || $self->{FILE_TYPE};
3037 $$delGroup{IFD0} and $self->Warn("Can't delete IFD0 from $type",1);
3038 undef $grp1;
3039 } elsif ($grp0 eq 'EXIF' and $$delGroup{$grp0}) {
3040 undef $grp1 unless $$delGroup{$grp1} or $grp1 eq 'ExifIFD';
3041 }
3042 }
3043 if ($grp1) {
3044 if ($dataPt or $$dirInfo{RAF}) {
3045 ++$self->{CHANGED};
3046 $out and print $out " Deleting $grp1\n";
3047 # can no longer validate TIFF_END if deleting an entire IFD
3048 delete $self->{TIFF_END} if $dirName =~ /IFD/;
3049 }
3050 # don't add back into the wrong location
3051 my $right = $$self{ADD_DIRS}{$grp1};
3052 # (take care because EXIF directory name may be either EXIF or IFD0,
3053 # but IFD0 will be the one that appears in the directory map)
3054 $right = $$self{ADD_DIRS}{IFD0} if not $right and $grp1 eq 'EXIF';
3055 if ($delFlag == 2 and $right) {
3056 # also check grandparent because some routines create 2 levels in 1
3057 my $right2 = $$self{ADD_DIRS}{$right} || '';
3058 if (not $$dirInfo{Parent} or $$dirInfo{Parent} eq $right or
3059 $$dirInfo{Parent} eq $right2)
3060 {
3061 # create new empty directory
3062 my $data = '';
3063 my %dirInfo = (
3064 DirName => $$dirInfo{DirName},
3065 Parent => $$dirInfo{Parent},
3066 DirStart => 0,
3067 DirLen => 0,
3068 DataPt => \$data,
3069 NewDataPos => $$dirInfo{NewDataPos},
3070 Fixup => $$dirInfo{Fixup},
3071 );
3072 $dirInfo = \%dirInfo;
3073 } else {
3074 $self->Warn("Not recreating $grp1 in $$dirInfo{Parent} (should be in $right)",1);
3075 return '';
3076 }
3077 } else {
3078 return '' unless $$dirInfo{NoDelete};
3079 }
3080 }
3081 }
3082 }
3083 # use default proc from tag table if no proc specified
3084 $writeProc or $writeProc = $$tagTablePtr{WRITE_PROC} or return undef;
3085
3086 # copy or delete new directory as a block if specified
3087 my $blockName = $dirName;
3088 $blockName = 'EXIF' if $blockName eq 'IFD0';
3089 my $tagInfo = $Image::ExifTool::Extra{$blockName} || $$dirInfo{TagInfo};
3090 while ($tagInfo and ($nvHash = $self->{NEW_VALUE}{$tagInfo}) and IsOverwriting($nvHash)) {
3091 # protect against writing EXIF to wrong file types, etc
3092 if ($blockName eq 'EXIF') {
3093 unless ($blockExifTypes{$$self{FILE_TYPE}}) {
3094 $self->Warn("Can't write EXIF as a block to $$self{FILE_TYPE} file");
3095 last;
3096 }
3097 unless ($writeProc eq \&Image::ExifTool::WriteTIFF) {
3098 # this could happen if we called WriteDirectory for an EXIF directory
3099 # without going through WriteTIFF as the WriteProc, which would be bad
3100 # because the EXIF block could end up with two TIFF headers
3101 $self->Warn('Internal error writing EXIF -- please report');
3102 last;
3103 }
3104 }
3105 my $verb = 'Writing';
3106 my $newVal = GetNewValues($nvHash);
3107 unless (defined $newVal and length $newVal) {
3108 $verb = 'Deleting';
3109 $newVal = '';
3110 }
3111 $$dirInfo{BlockWrite} = 1; # set flag indicating we did a block write
3112 $out and print $out " $verb $blockName as a block\n";
3113 ++$self->{CHANGED};
3114 return $newVal;
3115 }
3116 # guard against writing the same directory twice
3117 if (defined $dataPt and defined $$dirInfo{DirStart} and defined $$dirInfo{DataPos}) {
3118 my $addr = $$dirInfo{DirStart} + $$dirInfo{DataPos} + ($$dirInfo{Base}||0) + $$self{BASE};
3119 # (Phase One P25 IIQ files have ICC_Profile duplicated in IFD0 and IFD1)
3120 if ($self->{PROCESSED}{$addr} and ($dirName ne 'ICC_Profile' or $$self{TIFF_TYPE} ne 'IIQ')) {
3121 if ($self->Error("$dirName pointer references previous $self->{PROCESSED}{$addr} directory", 1)) {
3122 return undef;
3123 } else {
3124 $self->Warn("Deleting duplicate $dirName directory");
3125 $out and print $out " Deleting $dirName\n";
3126 return ''; # delete the duplicate directory
3127 }
3128 }
3129 $self->{PROCESSED}{$addr} = $dirName;
3130 }
3131 my $oldDir = $self->{DIR_NAME};
3132 my $isRewriting = ($$dirInfo{DirLen} or (defined $dataPt and length $$dataPt) or $$dirInfo{RAF});
3133 my $name;
3134 if ($out) {
3135 $name = ($dirName eq 'MakerNotes' and $$dirInfo{TagInfo}) ?
3136 $dirInfo->{TagInfo}{Name} : $dirName;
3137 if (not defined $oldDir or $oldDir ne $name) {
3138 my $verb = $isRewriting ? 'Rewriting' : 'Creating';
3139 print $out " $verb $name\n";
3140 }
3141 }
3142 my $saveOrder = GetByteOrder();
3143 my $oldChanged = $self->{CHANGED};
3144 $self->{DIR_NAME} = $dirName;
3145 push @{$self->{PATH}}, $$dirInfo{DirName};
3146 $$dirInfo{IsWriting} = 1;
3147 my $newData = &$writeProc($self, $dirInfo, $tagTablePtr);
3148 pop @{$self->{PATH}};
3149 # nothing changed if error occurred or nothing was created
3150 $self->{CHANGED} = $oldChanged unless defined $newData and (length($newData) or $isRewriting);
3151 $self->{DIR_NAME} = $oldDir;
3152 SetByteOrder($saveOrder);
3153 print $out " Deleting $name\n" if $out and defined $newData and not length $newData;
3154 return $newData;
3155}
3156
3157#------------------------------------------------------------------------------
3158# Uncommon utility routines to for reading binary data values
3159# Inputs: 0) data reference, 1) offset into data
3160sub Get64s($$)
3161{
3162 my ($dataPt, $pos) = @_;
3163 my $pt = GetByteOrder() eq 'MM' ? 0 : 4; # get position of high word
3164 my $hi = Get32s($dataPt, $pos + $pt); # preserve sign bit of high word
3165 my $lo = Get32u($dataPt, $pos + 4 - $pt);
3166 return $hi * 4294967296 + $lo;
3167}
3168sub Get64u($$)
3169{
3170 my ($dataPt, $pos) = @_;
3171 my $pt = GetByteOrder() eq 'MM' ? 0 : 4; # get position of high word
3172 my $hi = Get32u($dataPt, $pos + $pt); # (unsigned this time)
3173 my $lo = Get32u($dataPt, $pos + 4 - $pt);
3174 return $hi * 4294967296 + $lo;
3175}
3176# Decode extended 80-bit float used by Apple SANE and Intel 8087
3177# (note: different than the IEEE standard 80-bit float)
3178sub GetExtended($$)
3179{
3180 my ($dataPt, $pos) = @_;
3181 my $pt = GetByteOrder() eq 'MM' ? 0 : 2; # get position of exponent
3182 my $exp = Get16u($dataPt, $pos + $pt);
3183 my $sig = Get64u($dataPt, $pos + 2 - $pt); # get significand as int64u
3184 my $sign = $exp & 0x8000 ? -1 : 1;
3185 $exp = ($exp & 0x7fff) - 16383 - 63; # (-63 to fractionalize significand)
3186 return $sign * $sig * 2 ** $exp;
3187}
3188
3189#------------------------------------------------------------------------------
3190# Dump data in hex and ASCII to console
3191# Inputs: 0) data reference, 1) length or undef, 2-N) Options:
3192# Options: Start => offset to start of data (default=0)
3193# Addr => address to print for data start (default=DataPos+Start)
3194# DataPos => address of start of data
3195# Width => width of printout (bytes, default=16)
3196# Prefix => prefix to print at start of line (default='')
3197# MaxLen => maximum length to dump
3198# Out => output file reference
3199# Len => data length
3200sub HexDump($;$%)
3201{
3202 my $dataPt = shift;
3203 my $len = shift;
3204 my %opts = @_;
3205 my $start = $opts{Start} || 0;
3206 my $addr = $opts{Addr};
3207 my $wid = $opts{Width} || 16;
3208 my $prefix = $opts{Prefix} || '';
3209 my $out = $opts{Out} || \*STDOUT;
3210 my $maxLen = $opts{MaxLen};
3211 my $datLen = length($$dataPt) - $start;
3212 my $more;
3213 $len = $opts{Len} if defined $opts{Len};
3214
3215 $addr = $start + ($opts{DataPos} || 0) unless defined $addr;
3216 $len = $datLen unless defined $len;
3217 if ($maxLen and $len > $maxLen) {
3218 # print one line less to allow for $more line below
3219 $maxLen = int(($maxLen - 1) / $wid) * $wid;
3220 $more = $len - $maxLen;
3221 $len = $maxLen;
3222 }
3223 if ($len > $datLen) {
3224 print $out "$prefix Warning: Attempted dump outside data\n";
3225 print $out "$prefix ($len bytes specified, but only $datLen available)\n";
3226 $len = $datLen;
3227 }
3228 my $format = sprintf("%%-%ds", $wid * 3);
3229 my $tmpl = 'H2' x $wid; # ('(H2)*' would have been nice, but older perl versions don't support it)
3230 my $i;
3231 for ($i=0; $i<$len; $i+=$wid) {
3232 $wid > $len-$i and $wid = $len-$i, $tmpl = 'H2' x $wid;
3233 printf $out "$prefix%8.4x: ", $addr+$i;
3234 my $dat = substr($$dataPt, $i+$start, $wid);
3235 my $s = join(' ', unpack($tmpl, $dat));
3236 printf $out $format, $s;
3237 $dat =~ tr /\x00-\x1f\x7f-\xff/./;
3238 print $out "[$dat]\n";
3239 }
3240 $more and printf $out "$prefix [snip $more bytes]\n";
3241}
3242
3243#------------------------------------------------------------------------------
3244# Print verbose tag information
3245# Inputs: 0) ExifTool object reference, 1) tag ID
3246# 2) tag info reference (or undef)
3247# 3-N) extra parms:
3248# Parms: Index => Index of tag in menu (starting at 0)
3249# Value => Tag value
3250# DataPt => reference to value data block
3251# DataPos => location of data block in file
3252# Size => length of value data within block
3253# Format => value format string
3254# Count => number of values
3255# Extra => Extra Verbose=2 information to put after tag number
3256# Table => Reference to tag table
3257# --> plus any of these HexDump() options: Start, Addr, Width
3258sub VerboseInfo($$$%)
3259{
3260 my ($self, $tagID, $tagInfo, %parms) = @_;
3261 my $verbose = $self->{OPTIONS}{Verbose};
3262 my $out = $self->{OPTIONS}{TextOut};
3263 my ($tag, $line, $hexID);
3264
3265 # generate hex number if tagID is numerical
3266 if (defined $tagID) {
3267 $tagID =~ /^\d+$/ and $hexID = sprintf("0x%.4x", $tagID);
3268 } else {
3269 $tagID = 'Unknown';
3270 }
3271 # get tag name
3272 if ($tagInfo and $$tagInfo{Name}) {
3273 $tag = $$tagInfo{Name};
3274 } else {
3275 my $prefix;
3276 $prefix = $parms{Table}{TAG_PREFIX} if $parms{Table};
3277 if ($prefix or $hexID) {
3278 $prefix = 'Unknown' unless $prefix;
3279 $tag = $prefix . '_' . ($hexID ? $hexID : $tagID);
3280 } else {
3281 $tag = $tagID;
3282 }
3283 }
3284 my $dataPt = $parms{DataPt};
3285 my $size = $parms{Size};
3286 $size = length $$dataPt unless defined $size or not $dataPt;
3287 my $indent = $self->{INDENT};
3288
3289 # Level 1: print tag/value information
3290 $line = $indent;
3291 my $index = $parms{Index};
3292 if (defined $index) {
3293 $line .= $index . ') ';
3294 $line .= ' ' if length($index) < 2;
3295 $indent .= ' '; # indent everything else to align with tag name
3296 }
3297 $line .= $tag;
3298 if ($tagInfo and $$tagInfo{SubDirectory}) {
3299 $line .= ' (SubDirectory) -->';
3300 } else {
3301 my $maxLen = 90 - length($line);
3302 if (defined $parms{Value}) {
3303 $line .= ' = ' . $self->Printable($parms{Value}, $maxLen);
3304 } elsif ($dataPt) {
3305 my $start = $parms{Start} || 0;
3306 $line .= ' = ' . $self->Printable(substr($$dataPt,$start,$size), $maxLen);
3307 }
3308 }
3309 print $out "$line\n";
3310
3311 # Level 2: print detailed information about the tag
3312 if ($verbose > 1 and ($parms{Extra} or $parms{Format} or
3313 $parms{DataPt} or defined $size or $tagID =~ /\//))
3314 {
3315 $line = $indent . '- Tag ';
3316 if ($hexID) {
3317 $line .= $hexID;
3318 } else {
3319 $tagID =~ s/([\0-\x1f\x7f-\xff])/sprintf('\\x%.2x',ord $1)/ge;
3320 $line .= "'$tagID'";
3321 }
3322 $line .= $parms{Extra} if defined $parms{Extra};
3323 my $format = $parms{Format};
3324 if ($format or defined $size) {
3325 $line .= ' (';
3326 if (defined $size) {
3327 $line .= "$size bytes";
3328 $line .= ', ' if $format;
3329 }
3330 if ($format) {
3331 $line .= $format;
3332 $line .= '['.$parms{Count}.']' if $parms{Count};
3333 }
3334 $line .= ')';
3335 }
3336 $line .= ':' if $verbose > 2 and $parms{DataPt};
3337 print $out "$line\n";
3338 }
3339
3340 # Level 3: do hex dump of value
3341 if ($verbose > 2 and $parms{DataPt}) {
3342 $parms{Out} = $out;
3343 $parms{Prefix} = $indent;
3344 # limit dump length if Verbose < 5
3345 $parms{MaxLen} = $verbose == 3 ? 96 : 2048 if $verbose < 5;
3346 HexDump($dataPt, $size, %parms);
3347 }
3348}
3349
3350#------------------------------------------------------------------------------
3351# Dump trailer information
3352# Inputs: 0) ExifTool object ref, 1) dirInfo hash (RAF, DirName, DataPos, DirLen)
3353# Notes: Restores current file position before returning
3354sub DumpTrailer($$)
3355{
3356 my ($self, $dirInfo) = @_;
3357 my $raf = $$dirInfo{RAF};
3358 my $curPos = $raf->Tell();
3359 my $trailer = $$dirInfo{DirName} || 'Unknown';
3360 my $pos = $$dirInfo{DataPos};
3361 my $verbose = $self->{OPTIONS}{Verbose};
3362 my $htmlDump = $self->{HTML_DUMP};
3363 my ($buff, $buf2);
3364 my $size = $$dirInfo{DirLen};
3365 $pos = $curPos unless defined $pos;
3366
3367 # get full trailer size if not specified
3368 for (;;) {
3369 unless ($size) {
3370 $raf->Seek(0, 2) or last;
3371 $size = $raf->Tell() - $pos;
3372 last unless $size;
3373 }
3374 $raf->Seek($pos, 0) or last;
3375 if ($htmlDump) {
3376 my $num = $raf->Read($buff, $size) or return;
3377 my $desc = "$trailer trailer";
3378 $desc = "[$desc]" if $trailer eq 'Unknown';
3379 $self->HDump($pos, $num, $desc, undef, 0x08);
3380 last;
3381 }
3382 my $out = $self->{OPTIONS}{TextOut};
3383 printf $out "$trailer trailer (%d bytes at offset 0x%.4x):\n", $size, $pos;
3384 last unless $verbose > 2;
3385 my $num = $size; # number of bytes to read
3386 # limit size if not very verbose
3387 if ($verbose < 5) {
3388 my $limit = $verbose < 4 ? 96 : 512;
3389 $num = $limit if $num > $limit;
3390 }
3391 $raf->Read($buff, $num) == $num or return;
3392 # read the end of the trailer too if not done already
3393 if ($size > 2 * $num) {
3394 $raf->Seek($pos + $size - $num, 0);
3395 $raf->Read($buf2, $num);
3396 } elsif ($size > $num) {
3397 $raf->Seek($pos + $num, 0);
3398 $raf->Read($buf2, $size - $num);
3399 $buff .= $buf2;
3400 undef $buf2;
3401 }
3402 HexDump(\$buff, undef, Addr => $pos, Out => $out);
3403 if (defined $buf2) {
3404 print $out " [snip ", $size - $num * 2, " bytes]\n";
3405 HexDump(\$buf2, undef, Addr => $pos + $size - $num, Out => $out);
3406 }
3407 last;
3408 }
3409 $raf->Seek($curPos, 0);
3410}
3411
3412#------------------------------------------------------------------------------
3413# Dump unknown trailer information
3414# Inputs: 0) ExifTool ref, 1) dirInfo ref (with RAF, DataPos and DirLen defined)
3415# Notes: changes dirInfo elements
3416sub DumpUnknownTrailer($$)
3417{
3418 my ($self, $dirInfo) = @_;
3419 my $pos = $$dirInfo{DataPos};
3420 my $endPos = $pos + $$dirInfo{DirLen};
3421 # account for preview/MPF image trailer
3422 my $prePos = $self->{VALUE}{PreviewImageStart} || $$self{PreviewImageStart};
3423 my $preLen = $self->{VALUE}{PreviewImageLength} || $$self{PreviewImageLength};
3424 my $tag = 'PreviewImage';
3425 my $mpImageNum = 0;
3426 my (%image, $lastOne);
3427 for (;;) {
3428 # add to Preview block list if valid and in the trailer
3429 $image{$prePos} = [$tag, $preLen] if $prePos and $preLen and $prePos+$preLen > $pos;
3430 last if $lastOne; # checked all images
3431 # look for MPF images (in the the proper order)
3432 ++$mpImageNum;
3433 $prePos = $self->{VALUE}{"MPImageStart ($mpImageNum)"};
3434 if (defined $prePos) {
3435 $preLen = $self->{VALUE}{"MPImageLength ($mpImageNum)"};
3436 } else {
3437 $prePos = $self->{VALUE}{'MPImageStart'};
3438 $preLen = $self->{VALUE}{'MPImageLength'};
3439 $lastOne = 1;
3440 }
3441 $tag = "MPImage$mpImageNum";
3442 }
3443 # dump trailer sections in order
3444 $image{$endPos} = [ '', 0 ]; # add terminator "image"
3445 foreach $prePos (sort { $a <=> $b } keys %image) {
3446 if ($pos < $prePos) {
3447 # dump unknown trailer data
3448 $$dirInfo{DirName} = 'Unknown';
3449 $$dirInfo{DataPos} = $pos;
3450 $$dirInfo{DirLen} = $prePos - $pos;
3451 $self->DumpTrailer($dirInfo);
3452 }
3453 ($tag, $preLen) = @{$image{$prePos}};
3454 last unless $preLen;
3455 # dump image if verbose (it is htmlDump'd by ExtractImage)
3456 if ($self->{OPTIONS}{Verbose}) {
3457 $$dirInfo{DirName} = $tag;
3458 $$dirInfo{DataPos} = $prePos;
3459 $$dirInfo{DirLen} = $preLen;
3460 $self->DumpTrailer($dirInfo);
3461 }
3462 $pos = $prePos + $preLen;
3463 }
3464}
3465
3466#------------------------------------------------------------------------------
3467# Find last element in linked list
3468# Inputs: 0) element in list
3469# Returns: Last element in list
3470sub LastInList($)
3471{
3472 my $element = shift;
3473 while ($element->{Next}) {
3474 $element = $element->{Next};
3475 }
3476 return $element;
3477}
3478
3479#------------------------------------------------------------------------------
3480# Print verbose directory information
3481# Inputs: 0) ExifTool object reference, 1) directory name or dirInfo ref
3482# 2) number of entries in directory (or 0 if unknown)
3483# 3) optional size of directory in bytes
3484sub VerboseDir($$;$$)
3485{
3486 my ($self, $name, $entries, $size) = @_;
3487 return unless $self->{OPTIONS}{Verbose};
3488 if (ref $name eq 'HASH') {
3489 $size = $$name{DirLen} unless $size;
3490 $name = $$name{Name} || $$name{DirName};
3491 }
3492 my $indent = substr($self->{INDENT}, 0, -2);
3493 my $out = $self->{OPTIONS}{TextOut};
3494 my $str = $entries ? " with $entries entries" : '';
3495 $str .= ", $size bytes" if $size;
3496 print $out "$indent+ [$name directory$str]\n";
3497}
3498
3499#------------------------------------------------------------------------------
3500# Print verbose value while writing
3501# Inputs: 0) ExifTool object ref, 1) heading "ie. '+ IPTC:Keywords',
3502# 2) value, 3) [optional] extra text after value
3503sub VerboseValue($$$;$)
3504{
3505 return unless $_[0]{OPTIONS}{Verbose} > 1;
3506 my ($self, $str, $val, $xtra) = @_;
3507 my $out = $self->{OPTIONS}{TextOut};
3508 $xtra or $xtra = '';
3509 my $maxLen = 81 - length($str) - length($xtra);
3510 $val = $self->Printable($val, $maxLen);
3511 print $out " $str = '$val'$xtra\n";
3512}
3513
3514#------------------------------------------------------------------------------
3515# Pack Unicode numbers into UTF8 string
3516# Inputs: 0-N) list of Unicode numbers
3517# Returns: Packed UTF-8 string
3518sub PackUTF8(@)
3519{
3520 my @out;
3521 while (@_) {
3522 my $ch = pop;
3523 unshift(@out, $ch), next if $ch < 0x80;
3524 unshift(@out, 0x80 | ($ch & 0x3f));
3525 $ch >>= 6;
3526 unshift(@out, 0xc0 | $ch), next if $ch < 0x20;
3527 unshift(@out, 0x80 | ($ch & 0x3f));
3528 $ch >>= 6;
3529 unshift(@out, 0xe0 | $ch), next if $ch < 0x10;
3530 unshift(@out, 0x80 | ($ch & 0x3f));
3531 $ch >>= 6;
3532 unshift(@out, 0xf0 | ($ch & 0x07));
3533 }
3534 return pack('C*', @out);
3535}
3536
3537#------------------------------------------------------------------------------
3538# Unpack numbers from UTF8 string
3539# Inputs: 0) UTF-8 string
3540# Returns: List of Unicode numbers (sets $evalWarning on error)
3541sub UnpackUTF8($)
3542{
3543 my (@out, $pos);
3544 pos($_[0]) = $pos = 0; # start at beginning of string
3545 for (;;) {
3546 my ($ch, $newPos, $val, $byte);
3547 if ($_[0] =~ /([\x80-\xff])/g) {
3548 $ch = ord($1);
3549 $newPos = pos($_[0]) - 1;
3550 } else {
3551 $newPos = length $_[0];
3552 }
3553 # unpack 7-bit characters
3554 my $len = $newPos - $pos;
3555 push @out, unpack("x${pos}C$len",$_[0]) if $len;
3556 last unless defined $ch;
3557 $pos = $newPos + 1;
3558 # minimum lead byte for 2-byte sequence is 0xc2 (overlong sequences
3559 # not allowed), 0xf8-0xfd are restricted by RFC 3629 (no 5 or 6 byte
3560 # sequences), and 0xfe and 0xff are not valid in UTF-8 strings
3561 if ($ch < 0xc2 or $ch >= 0xf8) {
3562 push @out, ord('?'); # invalid UTF-8
3563 $evalWarning = 'Bad UTF-8';
3564 next;
3565 }
3566 # decode 2, 3 and 4-byte sequences
3567 my $n = 1;
3568 if ($ch < 0xe0) {
3569 $val = $ch & 0x1f; # 2-byte sequence
3570 } elsif ($ch < 0xf0) {
3571 $val = $ch & 0x0f; # 3-byte sequence
3572 ++$n;
3573 } else {
3574 $val = $ch & 0x07; # 4-byte sequence
3575 $n += 2;
3576 }
3577 unless ($_[0] =~ /\G([\x80-\xbf]{$n})/g) {
3578 pos($_[0]) = $pos; # restore position
3579 push @out, ord('?'); # invalid UTF-8
3580 $evalWarning = 'Bad UTF-8';
3581 next;
3582 }
3583 foreach $byte (unpack 'C*', $1) {
3584 $val = ($val << 6) | ($byte & 0x3f);
3585 }
3586 push @out, $val; # save Unicode character value
3587 $pos += $n; # position at end of UTF-8 character
3588 }
3589 return @out;
3590}
3591
3592#------------------------------------------------------------------------------
3593# Inverse date/time print conversion (reformat to YYYY:mm:dd HH:MM:SS[.ss][+-HH:MM|Z])
3594# Inputs: 0) ExifTool object ref, 1) Date/Time string, 2) timezone flag:
3595# 0 - remove timezone and sub-seconds if they exist
3596# 1 - add timezone if it doesn't exist
3597# undef - leave timezone alone
3598# 3) flag to allow date-only (YYYY, YYYY:mm or YYYY:mm:dd) or time without seconds
3599# Returns: formatted date/time string (or undef and issues warning on error)
3600# Notes: currently accepts different separators, but doesn't use DateFormat yet
3601sub InverseDateTime($$;$$)
3602{
3603 my ($self, $val, $tzFlag, $dateOnly) = @_;
3604 my ($rtnVal, $tz);
3605 # strip off timezone first if it exists
3606 if ($val =~ s/([+-])(\d{1,2}):?(\d{2})$//i) {
3607 $tz = sprintf("$1%.2d:$3", $2);
3608 } elsif ($val =~ s/Z$//i) {
3609 $tz = 'Z';
3610 } else {
3611 $tz = '';
3612 }
3613 # strip of sub seconds
3614 my $fs = $val =~ /(\.\d+)$/ ? $1 : '';
3615 if ($val =~ /(\d{4})/g) { # get YYYY
3616 my $yr = $1;
3617 my @a = ($val =~ /\d{2}/g); # get mm, dd, HH, and maybe MM, SS
3618 if (@a >= 3) {
3619 my $ss = $a[4]; # get SS
3620 push @a, '00' while @a < 5; # add MM, SS if not given
3621 # add/remove timezone if necessary
3622 if ($tzFlag) {
3623 if (not $tz) {
3624 if (eval 'require Time::Local') {
3625 # determine timezone offset for this time
3626 my @args = ($a[4],$a[3],$a[2],$a[1],$a[0]-1,$yr-1900);
3627 my $diff = Time::Local::timegm(@args) - TimeLocal(@args);
3628 $tz = TimeZoneString($diff / 60);
3629 } else {
3630 $tz = 'Z'; # don't know time zone
3631 }
3632 }
3633 } elsif (defined $tzFlag) {
3634 $tz = $fs = ''; # remove timezone and sub-seconds
3635 }
3636 if (defined $ss) {
3637 $ss = ":$ss";
3638 } elsif ($dateOnly) {
3639 $ss = '';
3640 } else {
3641 $ss = ':00';
3642 }
3643 # construct properly formatted date/time string
3644 $rtnVal = "$yr:$a[0]:$a[1] $a[2]:$a[3]$ss$fs$tz";
3645 } elsif ($dateOnly) {
3646 $rtnVal = join ':', $yr, @a;
3647 }
3648 }
3649 $rtnVal or warn "Invalid date/time (use YYYY:mm:dd HH:MM:SS[.ss][+/-HH:MM|Z])\n";
3650 return $rtnVal;
3651}
3652
3653#------------------------------------------------------------------------------
3654# Set byte order according to our current preferences
3655# Inputs: 0) ExifTool object ref
3656# Returns: new byte order ('II' or 'MM') and sets current byte order
3657# Notes: takes the first of the following that is valid:
3658# 1) ByteOrder option
3659# 2) new value for ExifByteOrder
3660# 3) makenote byte order from last file read
3661# 4) big endian
3662sub SetPreferredByteOrder($)
3663{
3664 my $self = shift;
3665 my $byteOrder = $self->Options('ByteOrder') ||
3666 $self->GetNewValues('ExifByteOrder') ||
3667 $self->{MAKER_NOTE_BYTE_ORDER} || 'MM';
3668 unless (SetByteOrder($byteOrder)) {
3669 warn "Invalid byte order '$byteOrder'\n" if $self->Options('Verbose');
3670 $byteOrder = $self->{MAKER_NOTE_BYTE_ORDER} || 'MM';
3671 SetByteOrder($byteOrder);
3672 }
3673 return GetByteOrder();
3674}
3675
3676#------------------------------------------------------------------------------
3677# Assemble a continuing fraction into a rational value
3678# Inputs: 0) numerator, 1) denominator
3679# 2-N) list of fraction denominators, deepest first
3680# Returns: numerator, denominator (in list context)
3681sub AssembleRational($$@)
3682{
3683 @_ < 3 and return @_;
3684 my ($num, $denom, $frac) = splice(@_, 0, 3);
3685 return AssembleRational($frac*$num+$denom, $num, @_);
3686}
3687
3688#------------------------------------------------------------------------------
3689# Convert a floating point number (or 'inf' or 'undef' or a fraction) into a rational
3690# Inputs: 0) floating point number, 1) optional maximum value (defaults to 0x7fffffff)
3691# Returns: numerator, denominator (in list context)
3692# Notes:
3693# - the returned rational will be accurate to at least 8 significant figures if possible
3694# - ie. an input of 3.14159265358979 returns a rational of 104348/33215,
3695# which equals 3.14159265392142 and is accurate to 10 significant figures
3696# - these routines were a bit tricky, but fun to write!
3697sub Rationalize($;$)
3698{
3699 my $val = shift;
3700 return (1, 0) if $val eq 'inf';
3701 return (0, 0) if $val eq 'undef';
3702 return ($1,$2) if $val =~ m{^([-+]?\d+)/(\d+)$}; # accept fractional values
3703 # Note: Just testing "if $val" doesn't work because '0.0' is true! (ugghh!)
3704 return (0, 1) if $val == 0;
3705 my $sign = $val < 0 ? ($val = -$val, -1) : 1;
3706 my ($num, $denom, @fracs);
3707 my $frac = $val;
3708 my $maxInt = shift || 0x7fffffff;
3709 for (;;) {
3710 my ($n, $d) = AssembleRational(int($frac + 0.5), 1, @fracs);
3711 if ($n > $maxInt or $d > $maxInt) {
3712 last if defined $num;
3713 return ($sign, $maxInt) if $val < 1;
3714 return ($sign * $maxInt, 1);
3715 }
3716 ($num, $denom) = ($n, $d); # save last good values
3717 my $err = ($n/$d-$val) / $val; # get error of this rational
3718 last if abs($err) < 1e-8; # all done if error is small
3719 my $int = int($frac);
3720 unshift @fracs, $int;
3721 last unless $frac -= $int;
3722 $frac = 1 / $frac;
3723 }
3724 return ($num * $sign, $denom);
3725}
3726
3727#------------------------------------------------------------------------------
3728# Utility routines to for writing binary data values
3729# Inputs: 0) value, 1) data ref, 2) offset
3730# Notes: prototype is (@) so values can be passed from list if desired
3731sub Set16s(@)
3732{
3733 my $val = shift;
3734 $val < 0 and $val += 0x10000;
3735 return Set16u($val, @_);
3736}
3737sub Set32s(@)
3738{
3739 my $val = shift;
3740 $val < 0 and $val += 0xffffffff, ++$val;
3741 return Set32u($val, @_);
3742}
3743sub SetRational64u(@) {
3744 my ($numer,$denom) = Rationalize($_[0],0xffffffff);
3745 my $val = Set32u($numer) . Set32u($denom);
3746 $_[1] and substr(${$_[1]}, $_[2], length($val)) = $val;
3747 return $val;
3748}
3749sub SetRational64s(@) {
3750 my ($numer,$denom) = Rationalize($_[0]);
3751 my $val = Set32s($numer) . Set32u($denom);
3752 $_[1] and substr(${$_[1]}, $_[2], length($val)) = $val;
3753 return $val;
3754}
3755sub SetRational32u(@) {
3756 my ($numer,$denom) = Rationalize($_[0],0xffff);
3757 my $val = Set16u($numer) . Set16u($denom);
3758 $_[1] and substr(${$_[1]}, $_[2], length($val)) = $val;
3759 return $val;
3760}
3761sub SetRational32s(@) {
3762 my ($numer,$denom) = Rationalize($_[0],0x7fff);
3763 my $val = Set16s($numer) . Set16u($denom);
3764 $_[1] and substr(${$_[1]}, $_[2], length($val)) = $val;
3765 return $val;
3766}
3767sub SetFixed16u(@) {
3768 my $val = int(shift() * 0x100 + 0.5);
3769 return Set16u($val, @_);
3770}
3771sub SetFixed16s(@) {
3772 my $val = shift;
3773 return Set16s(int($val * 0x100 + ($val < 0 ? -0.5 : 0.5)), @_);
3774}
3775sub SetFixed32u(@) {
3776 my $val = int(shift() * 0x10000 + 0.5);
3777 return Set32u($val, @_);
3778}
3779sub SetFixed32s(@) {
3780 my $val = shift;
3781 return Set32s(int($val * 0x10000 + ($val < 0 ? -0.5 : 0.5)), @_);
3782}
3783sub SetFloat(@) {
3784 my $val = SwapBytes(pack('f',$_[0]), 4);
3785 $_[1] and substr(${$_[1]}, $_[2], length($val)) = $val;
3786 return $val;
3787}
3788sub SetDouble(@) {
3789 # swap 32-bit words (ARM quirk) and bytes if necessary
3790 my $val = SwapBytes(SwapWords(pack('d',$_[0])), 8);
3791 $_[1] and substr(${$_[1]}, $_[2], length($val)) = $val;
3792 return $val;
3793}
3794#------------------------------------------------------------------------------
3795# hash lookups for writing binary data values
3796my %writeValueProc = (
3797 int8s => \&Set8s,
3798 int8u => \&Set8u,
3799 int16s => \&Set16s,
3800 int16u => \&Set16u,
3801 int16uRev => \&Set16uRev,
3802 int32s => \&Set32s,
3803 int32u => \&Set32u,
3804 rational32s => \&SetRational32s,
3805 rational32u => \&SetRational32u,
3806 rational64s => \&SetRational64s,
3807 rational64u => \&SetRational64u,
3808 fixed16u => \&SetFixed16u,
3809 fixed16s => \&SetFixed16s,
3810 fixed32u => \&SetFixed32u,
3811 fixed32s => \&SetFixed32s,
3812 float => \&SetFloat,
3813 double => \&SetDouble,
3814 ifd => \&Set32u,
3815);
3816# verify that we can write floats on this platform
3817{
3818 my %writeTest = (
3819 float => [ -3.14159, 'c0490fd0' ],
3820 double => [ -3.14159, 'c00921f9f01b866e' ],
3821 );
3822 my $format;
3823 my $oldOrder = GetByteOrder();
3824 SetByteOrder('MM');
3825 foreach $format (keys %writeTest) {
3826 my ($val, $hex) = @{$writeTest{$format}};
3827 # add floating point entries if we can write them
3828 next if unpack('H*', &{$writeValueProc{$format}}($val)) eq $hex;
3829 delete $writeValueProc{$format}; # we can't write them
3830 }
3831 SetByteOrder($oldOrder);
3832}
3833
3834#------------------------------------------------------------------------------
3835# write binary data value (with current byte ordering)
3836# Inputs: 0) value, 1) format string
3837# 2) optional number of values (1 or string length if not specified)
3838# 3) optional data reference, 4) value offset
3839# Returns: packed value (and sets value in data) or undef on error
3840sub WriteValue($$;$$$$)
3841{
3842 my ($val, $format, $count, $dataPt, $offset) = @_;
3843 my $proc = $writeValueProc{$format};
3844 my $packed;
3845
3846 if ($proc) {
3847 my @vals = split(' ',$val);
3848 if ($count) {
3849 $count = @vals if $count < 0;
3850 } else {
3851 $count = 1; # assume 1 if count not specified
3852 }
3853 $packed = '';
3854 while ($count--) {
3855 $val = shift @vals;
3856 return undef unless defined $val;
3857 # validate numerical formats
3858 if ($format =~ /^int/) {
3859 return undef unless IsInt($val) or IsHex($val);
3860 } elsif (not IsFloat($val)) {
3861 return undef unless $format =~ /^rational/ and ($val eq 'inf' or
3862 $val eq 'undef' or IsRational($val));
3863 }
3864 $packed .= &$proc($val);
3865 }
3866 } elsif ($format eq 'string' or $format eq 'undef') {
3867 $format eq 'string' and $val .= "\0"; # null-terminate strings
3868 if ($count and $count > 0) {
3869 my $diff = $count - length($val);
3870 if ($diff) {
3871 #warn "wrong string length!\n";
3872 # adjust length of string to match specified count
3873 if ($diff < 0) {
3874 if ($format eq 'string') {
3875 return undef unless $count;
3876 $val = substr($val, 0, $count - 1) . "\0";
3877 } else {
3878 $val = substr($val, 0, $count);
3879 }
3880 } else {
3881 $val .= "\0" x $diff;
3882 }
3883 }
3884 } else {
3885 $count = length($val);
3886 }
3887 $dataPt and substr($$dataPt, $offset, $count) = $val;
3888 return $val;
3889 } else {
3890 warn "Sorry, Can't write $format values on this platform\n";
3891 return undef;
3892 }
3893 $dataPt and substr($$dataPt, $offset, length($packed)) = $packed;
3894 return $packed;
3895}
3896
3897#------------------------------------------------------------------------------
3898# Encode bit mask (the inverse of DecodeBits())
3899# Inputs: 0) value to encode, 1) Reference to hash for encoding (or undef)
3900# 2) optional number of bits per word (defaults to 32), 3) total bits
3901# Returns: bit mask or undef on error (plus error string in list context)
3902sub EncodeBits($$;$$)
3903{
3904 my ($val, $lookup, $bits, $num) = @_;
3905 $bits or $bits = 32;
3906 $num or $num = $bits;
3907 my $words = int(($num + $bits - 1) / $bits);
3908 my @outVal = (0) x $words;
3909 if ($val ne '(none)') {
3910 my @vals = split /\s*,\s*/, $val;
3911 foreach $val (@vals) {
3912 my $bit;
3913 if ($lookup) {
3914 $bit = ReverseLookup($val, $lookup);
3915 # (Note: may get non-numerical $bit values from Unknown() tags)
3916 unless (defined $bit) {
3917 if ($val =~ /\[(\d+)\]/) { # numerical bit specification
3918 $bit = $1;
3919 } else {
3920 # don't return error string unless more than one value
3921 return undef unless @vals > 1 and wantarray;
3922 return (undef, "no match for '$val'");
3923 }
3924 }
3925 } else {
3926 $bit = $val;
3927 }
3928 unless (IsInt($bit) and $bit < $num) {
3929 return undef unless wantarray;
3930 return (undef, IsInt($bit) ? 'bit number too high' : 'not an integer');
3931 }
3932 my $word = int($bit / $bits);
3933 $outVal[$word] |= (1 << ($bit - $word * $bits));
3934 }
3935 }
3936 return "@outVal";
3937}
3938
3939#------------------------------------------------------------------------------
3940# get current position in output file
3941# Inputs: 0) file or scalar reference
3942# Returns: Current position or -1 on error
3943sub Tell($)
3944{
3945 my $outfile = shift;
3946 if (UNIVERSAL::isa($outfile,'GLOB')) {
3947 return tell($outfile);
3948 } else {
3949 return length($$outfile);
3950 }
3951}
3952
3953#------------------------------------------------------------------------------
3954# write to file or memory
3955# Inputs: 0) file or scalar reference, 1-N) list of stuff to write
3956# Returns: true on success
3957sub Write($@)
3958{
3959 my $outfile = shift;
3960 if (UNIVERSAL::isa($outfile,'GLOB')) {
3961 return print $outfile @_;
3962 } elsif (ref $outfile eq 'SCALAR') {
3963 $$outfile .= join('', @_);
3964 return 1;
3965 }
3966 return 0;
3967}
3968
3969#------------------------------------------------------------------------------
3970# Write trailer buffer to file (applying fixups if necessary)
3971# Inputs: 0) ExifTool object ref, 1) trailer dirInfo ref, 2) output file ref
3972# Returns: 1 on success
3973sub WriteTrailerBuffer($$$)
3974{
3975 my ($self, $trailInfo, $outfile) = @_;
3976 if ($self->{DEL_GROUP}{Trailer}) {
3977 $self->VPrint(0, " Deleting trailer ($$trailInfo{Offset} bytes)\n");
3978 ++$self->{CHANGED};
3979 return 1;
3980 }
3981 my $pos = Tell($outfile);
3982 my $trailPt = $$trailInfo{OutFile};
3983 # apply fixup if necessary (AFCP requires this)
3984 if ($$trailInfo{Fixup}) {
3985 if ($pos > 0) {
3986 # shift offsets to final AFCP location and write it out
3987 $trailInfo->{Fixup}{Shift} += $pos;
3988 $trailInfo->{Fixup}->ApplyFixup($trailPt);
3989 } else {
3990 $self->Error("Can't get file position for trailer offset fixup",1);
3991 }
3992 }
3993 return Write($outfile, $$trailPt);
3994}
3995
3996#------------------------------------------------------------------------------
3997# Add trailers as a block
3998# Inputs: 0) ExifTool object ref, 1) [optional] trailer data raf,
3999# 1 or 2-N) trailer types to add (or none to add all)
4000# Returns: new trailer ref, or undef
4001# - increments CHANGED if trailer was added
4002sub AddNewTrailers($;@)
4003{
4004 my ($self, @types) = @_;
4005 my $trailPt;
4006 ref $types[0] and $trailPt = shift @types;
4007 $types[0] or shift @types; # (in case undef data ref is passed)
4008 # add all possible trailers if none specified (currently only CanonVRD)
4009 @types or @types = qw(CanonVRD);
4010 # add trailers as a block
4011 my $type;
4012 foreach $type (@types) {
4013 next unless $self->{NEW_VALUE}{$Image::ExifTool::Extra{$type}};
4014 my $val = $self->GetNewValues($type) or next;
4015 my $verb = $trailPt ? 'Writing' : 'Adding';
4016 $self->VPrint(0, " $verb $type as a block\n");
4017 if ($trailPt) {
4018 $$trailPt .= $val;
4019 } else {
4020 $trailPt = \$val;
4021 }
4022 ++$$self{CHANGED};
4023 }
4024 return $trailPt;
4025}
4026
4027#------------------------------------------------------------------------------
4028# Write segment, splitting up into multiple segments if necessary
4029# Inputs: 0) file or scalar reference, 1) segment marker
4030# 2) segment header, 3) segment data ref, 4) segment type
4031# Returns: number of segments written, or 0 on error
4032sub WriteMultiSegment($$$$;$)
4033{
4034 my ($outfile, $marker, $header, $dataPt, $type) = @_;
4035 $type or $type = '';
4036 my $len = length($$dataPt);
4037 my $hdr = "\xff" . chr($marker);
4038 my $count = 0;
4039 my $maxLen = $maxSegmentLen - length($header);
4040 $maxLen -= 2 if $type eq 'ICC'; # leave room for segment counters
4041 my $num = int(($len + $maxLen - 1) / $maxLen); # number of segments to write
4042 my $n;
4043 # write data, splitting into multiple segments if necessary
4044 # (each segment gets its own header)
4045 for ($n=0; $n<$len; $n+=$maxLen) {
4046 ++$count;
4047 my $size = $len - $n;
4048 $size > $maxLen and $size = $maxLen;
4049 my $buff = substr($$dataPt,$n,$size);
4050 $size += length($header);
4051 if ($type eq 'ICC') {
4052 $buff = pack('CC', $count, $num) . $buff;
4053 $size += 2;
4054 }
4055 # write the new segment with appropriate header
4056 my $segHdr = $hdr . pack('n', $size + 2);
4057 Write($outfile, $segHdr, $header, $buff) or return 0;
4058 }
4059 return $count;
4060}
4061
4062#------------------------------------------------------------------------------
4063# Write XMP segment(s) to JPEG file
4064# Inputs: 0) ExifTool object ref, 1) outfile ref, 2) XMP data ref,
4065# 3) extended XMP data ref, 4) 32-char extended XMP GUID (or undef if no extended data)
4066# Returns: true on success, false on write error
4067sub WriteMultiXMP($$$$$)
4068{
4069 my ($self, $outfile, $dataPt, $extPt, $guid) = @_;
4070 my $success = 1;
4071
4072 # write main XMP segment
4073 my $size = length($$dataPt) + length($xmpAPP1hdr);
4074 if ($size > $maxXMPLen) {
4075 $self->Error("XMP block too large for JPEG segment! ($size bytes)", 1);
4076 return 1;
4077 }
4078 my $app1hdr = "\xff\xe1" . pack('n', $size + 2);
4079 Write($outfile, $app1hdr, $xmpAPP1hdr, $$dataPt) or $success = 0;
4080 # write extended XMP segment(s) if necessary
4081 if (defined $guid) {
4082 $size = length($$extPt);
4083 my $maxLen = $maxXMPLen - 75; # maximum size without 75 byte header
4084 my $off;
4085 for ($off=0; $off<$size; $off+=$maxLen) {
4086 # header(75) = signature(35) + guid(32) + size(4) + offset(4)
4087 my $len = $size - $off;
4088 $len = $maxLen if $len > $maxLen;
4089 $app1hdr = "\xff\xe1" . pack('n', $len + 75 + 2);
4090 $self->VPrint(0, "Writing extended XMP segment ($len bytes)\n");
4091 Write($outfile, $app1hdr, $xmpExtAPP1hdr, $guid, pack('N2', $size, $off),
4092 substr($$extPt, $off, $len)) or $success = 0;
4093 }
4094 }
4095 return $success;
4096}
4097
4098#------------------------------------------------------------------------------
4099# WriteJPEG : Write JPEG image
4100# Inputs: 0) ExifTool object reference, 1) dirInfo reference
4101# Returns: 1 on success, 0 if this wasn't a valid JPEG file, or -1 if
4102# an output file was specified and a write error occurred
4103sub WriteJPEG($$)
4104{
4105 my ($self, $dirInfo) = @_;
4106 my $outfile = $$dirInfo{OutFile};
4107 my $raf = $$dirInfo{RAF};
4108 my ($ch,$s,$length);
4109 my $verbose = $self->{OPTIONS}{Verbose};
4110 my $out = $self->{OPTIONS}{TextOut};
4111 my $rtnVal = 0;
4112 my ($err, %doneDir);
4113 my %dumpParms = ( Out => $out );
4114 my ($writeBuffer, $oldOutfile); # used to buffer writing until PreviewImage position is known
4115
4116 # check to be sure this is a valid JPG file
4117 return 0 unless $raf->Read($s,2) == 2 and $s eq "\xff\xd8";
4118 $dumpParms{MaxLen} = 128 unless $verbose > 3;
4119
4120 delete $self->{PREVIEW_INFO}; # reset preview information
4121 delete $self->{DEL_PREVIEW}; # reset flag to delete preview
4122
4123 Write($outfile, $s) or $err = 1;
4124 # figure out what segments we need to write for the tags we have set
4125 my $addDirs = $self->{ADD_DIRS};
4126 my $editDirs = $self->{EDIT_DIRS};
4127 my $delGroup = $self->{DEL_GROUP};
4128 my $path = $$self{PATH};
4129 my $pn = scalar @$path;
4130
4131 # set input record separator to 0xff (the JPEG marker) to make reading quicker
4132 local $/ = "\xff";
4133#
4134# pre-scan image to determine if any create-able segment already exists
4135#
4136 my $pos = $raf->Tell();
4137 my ($marker, @dirOrder, %dirCount);
4138 Prescan: for (;;) {
4139 # read up to next marker (JPEG markers begin with 0xff)
4140 $raf->ReadLine($s) or last;
4141 # JPEG markers can be padded with unlimited 0xff's
4142 for (;;) {
4143 $raf->Read($ch, 1) or last Prescan;
4144 $marker = ord($ch);
4145 last unless $marker == 0xff;
4146 }
4147 # SOS signifies end of meta information
4148 if ($marker == 0xda) {
4149 push(@dirOrder, 'SOS');
4150 $dirCount{SOS} = 1;
4151 last;
4152 }
4153 my $dirName;
4154 # handle SOF markers: SOF0-SOF15, except DHT(0xc4), JPGA(0xc8) and DAC(0xcc)
4155 if (($marker & 0xf0) == 0xc0 and ($marker == 0xc0 or $marker & 0x03)) {
4156 last unless $raf->Seek(7, 1);
4157 # read data for all markers except stand-alone
4158 # markers 0x00, 0x01 and 0xd0-0xd7 (NULL, TEM, RST0-RST7)
4159 } elsif ($marker!=0x00 and $marker!=0x01 and ($marker<0xd0 or $marker>0xd7)) {
4160 # read record length word
4161 last unless $raf->Read($s, 2) == 2;
4162 my $len = unpack('n',$s); # get data length
4163 last unless defined($len) and $len >= 2;
4164 $len -= 2; # subtract size of length word
4165 if (($marker & 0xf0) == 0xe0) { # is this an APP segment?
4166 my $n = $len < 64 ? $len : 64;
4167 $raf->Read($s, $n) == $n or last;
4168 $len -= $n;
4169 # (Note: only necessary to recognize APP segments that we can create)
4170 if ($marker == 0xe0) {
4171 $s =~ /^JFIF\0/ and $dirName = 'JFIF';
4172 $s =~ /^JFXX\0\x10/ and $dirName = 'JFXX';
4173 } elsif ($marker == 0xe1) {
4174 $s =~ /^$exifAPP1hdr/ and $dirName = 'IFD0';
4175 $s =~ /^$xmpAPP1hdr/ and $dirName = 'XMP';
4176 $s =~ /^$xmpExtAPP1hdr/ and $dirName = 'XMP';
4177 } elsif ($marker == 0xe2) {
4178 $s =~ /^ICC_PROFILE\0/ and $dirName = 'ICC_Profile';
4179 } elsif ($marker == 0xec) {
4180 $s =~ /^Ducky/ and $dirName = 'Ducky';
4181 } elsif ($marker == 0xed) {
4182 $s =~ /^$psAPP13hdr/ and $dirName = 'Photoshop';
4183 }
4184 # initialize doneDir as a flag that the directory exists
4185 # (unless we are deleting it anyway)
4186 $doneDir{$dirName} = 0 if defined $dirName and not $$delGroup{$dirName};
4187 }
4188 $raf->Seek($len, 1) or last;
4189 }
4190 $dirName or $dirName = JpegMarkerName($marker);
4191 $dirCount{$dirName} = ($dirCount{$dirName} || 0) + 1;
4192 push @dirOrder, $dirName;
4193 }
4194 unless ($marker and $marker == 0xda) {
4195 $self->Error('Corrupted JPEG image');
4196 return 1;
4197 }
4198 $raf->Seek($pos, 0) or $self->Error('Seek error'), return 1;
4199#
4200# re-write the image
4201#
4202 my ($combinedSegData, $segPos, %extendedXMP);
4203 # read through each segment in the JPEG file
4204 Marker: for (;;) {
4205
4206 # read up to next marker (JPEG markers begin with 0xff)
4207 my $segJunk;
4208 $raf->ReadLine($segJunk) or $segJunk = '';
4209 # remove the 0xff but write the rest of the junk up to this point
4210 chomp($segJunk);
4211 Write($outfile, $segJunk) if length $segJunk;
4212 # JPEG markers can be padded with unlimited 0xff's
4213 for (;;) {
4214 $raf->Read($ch, 1) or $self->Error('Format error'), return 1;
4215 $marker = ord($ch);
4216 last unless $marker == 0xff;
4217 }
4218 # read the segment data
4219 my $segData;
4220 # handle SOF markers: SOF0-SOF15, except DHT(0xc4), JPGA(0xc8) and DAC(0xcc)
4221 if (($marker & 0xf0) == 0xc0 and ($marker == 0xc0 or $marker & 0x03)) {
4222 last unless $raf->Read($segData, 7) == 7;
4223 # read data for all markers except stand-alone
4224 # markers 0x00, 0x01 and 0xd0-0xd7 (NULL, TEM, RST0-RST7)
4225 } elsif ($marker!=0x00 and $marker!=0x01 and ($marker<0xd0 or $marker>0xd7)) {
4226 # read record length word
4227 last unless $raf->Read($s, 2) == 2;
4228 my $len = unpack('n',$s); # get data length
4229 last unless defined($len) and $len >= 2;
4230 $segPos = $raf->Tell();
4231 $len -= 2; # subtract size of length word
4232 last unless $raf->Read($segData, $len) == $len;
4233 }
4234 # initialize variables for this segment
4235 my $hdr = "\xff" . chr($marker); # segment header
4236 my $markerName = JpegMarkerName($marker);
4237 my $dirName = shift @dirOrder; # get directory name
4238 $$path[$pn] = $markerName;
4239#
4240# create all segments that must come before this one
4241# (nothing comes before SOI or after SOS)
4242#
4243 while ($markerName ne 'SOI') {
4244 if (exists $$addDirs{JFIF} and not defined $doneDir{JFIF}) {
4245 $doneDir{JFIF} = 1;
4246 if ($verbose) {
4247 print $out "Creating APP0:\n";
4248 print $out " Creating JFIF with default values\n";
4249 }
4250 my $jfif = "\x01\x02\x01\0\x48\0\x48\0\0";
4251 SetByteOrder('MM');
4252 my $tagTablePtr = GetTagTable('Image::ExifTool::JFIF::Main');
4253 my %dirInfo = (
4254 DataPt => \$jfif,
4255 DirStart => 0,
4256 DirLen => length $jfif,
4257 );
4258 # must temporarily remove JFIF from DEL_GROUP so we can
4259 # delete JFIF and add it back again in a single step
4260 my $delJFIF = $$delGroup{JFIF};
4261 delete $$delGroup{JFIF};
4262 my $newData = $self->WriteDirectory(\%dirInfo, $tagTablePtr);
4263 $$delGroup{JFIF} = $delJFIF if defined $delJFIF;
4264 if (defined $newData and length $newData) {
4265 my $app0hdr = "\xff\xe0" . pack('n', length($newData) + 7);
4266 Write($outfile,$app0hdr,"JFIF\0",$newData) or $err = 1;
4267 }
4268 }
4269 # don't create anything before APP0 or APP1 EXIF (containing IFD0)
4270 last if $markerName eq 'APP0' or $dirCount{IFD0};
4271 # EXIF information must come immediately after APP0
4272 if (exists $$addDirs{IFD0} and not defined $doneDir{IFD0}) {
4273 $doneDir{IFD0} = 1;
4274 $verbose and print $out "Creating APP1:\n";
4275 # write new EXIF data
4276 $self->{TIFF_TYPE} = 'APP1';
4277 my $tagTablePtr = GetTagTable('Image::ExifTool::Exif::Main');
4278 my %dirInfo = (
4279 DirName => 'IFD0',
4280 Parent => 'APP1',
4281 );
4282 my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr, \&WriteTIFF);
4283 if (defined $buff and length $buff) {
4284 my $size = length($buff) + length($exifAPP1hdr);
4285 if ($size <= $maxSegmentLen) {
4286 # switch to buffered output if required
4287 if (($$self{PREVIEW_INFO} or $$self{LeicaTrailer}) and not $oldOutfile) {
4288 $writeBuffer = '';
4289 $oldOutfile = $outfile;
4290 $outfile = \$writeBuffer;
4291 # account for segment, EXIF and TIFF headers
4292 $$self{PREVIEW_INFO}{Fixup}{Start} += 18 if $$self{PREVIEW_INFO};
4293 $$self{LeicaTrailer}{Fixup}{Start} += 18 if $$self{LeicaTrailer};
4294 }
4295 # write the new segment with appropriate header
4296 my $app1hdr = "\xff\xe1" . pack('n', $size + 2);
4297 Write($outfile,$app1hdr,$exifAPP1hdr,$buff) or $err = 1;
4298 } else {
4299 delete $self->{PREVIEW_INFO};
4300 $self->Warn("EXIF APP1 segment too large! ($size bytes)");
4301 }
4302 }
4303 }
4304 # APP13 Photoshop segment next
4305 last if $dirCount{Photoshop};
4306 if (exists $$addDirs{Photoshop} and not defined $doneDir{Photoshop}) {
4307 $doneDir{Photoshop} = 1;
4308 $verbose and print $out "Creating APP13:\n";
4309 # write new APP13 Photoshop record to memory
4310 my $tagTablePtr = GetTagTable('Image::ExifTool::Photoshop::Main');
4311 my %dirInfo = (
4312 Parent => 'APP13',
4313 );
4314 my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr);
4315 if (defined $buff and length $buff) {
4316 WriteMultiSegment($outfile, 0xed, $psAPP13hdr, \$buff) or $err = 1;
4317 ++$self->{CHANGED};
4318 }
4319 }
4320 # then APP1 XMP segment
4321 last if $dirCount{XMP};
4322 if (exists $$addDirs{XMP} and not defined $doneDir{XMP}) {
4323 $doneDir{XMP} = 1;
4324 $verbose and print $out "Creating APP1:\n";
4325 # write new XMP data
4326 my $tagTablePtr = GetTagTable('Image::ExifTool::XMP::Main');
4327 my %dirInfo = (
4328 Parent => 'APP1',
4329 # specify MaxDataLen so XMP is split if required
4330 MaxDataLen => $maxXMPLen - length($xmpAPP1hdr),
4331 );
4332 my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr);
4333 if (defined $buff and length $buff) {
4334 WriteMultiXMP($self, $outfile, \$buff, $dirInfo{ExtendedXMP},
4335 $dirInfo{ExtendedGUID}) or $err = 1;
4336 }
4337 }
4338 # then APP2 ICC_Profile segment
4339 last if $dirCount{ICC_Profile};
4340 if (exists $$addDirs{ICC_Profile} and not defined $doneDir{ICC_Profile}) {
4341 $doneDir{ICC_Profile} = 1;
4342 next if $$delGroup{ICC_Profile} and $$delGroup{ICC_Profile} != 2;
4343 $verbose and print $out "Creating APP2:\n";
4344 # write new ICC_Profile data
4345 my $tagTablePtr = GetTagTable('Image::ExifTool::ICC_Profile::Main');
4346 my %dirInfo = (
4347 Parent => 'APP2',
4348 );
4349 my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr);
4350 if (defined $buff and length $buff) {
4351 WriteMultiSegment($outfile, 0xe2, "ICC_PROFILE\0", \$buff, 'ICC') or $err = 1;
4352 ++$self->{CHANGED};
4353 }
4354 }
4355 # then APP12 Ducky segment
4356 last if $dirCount{Ducky};
4357 if (exists $$addDirs{Ducky} and not defined $doneDir{Ducky}) {
4358 $doneDir{Ducky} = 1;
4359 $verbose and print $out "Creating APP12 Ducky:\n";
4360 # write new Ducky segment data
4361 my $tagTablePtr = GetTagTable('Image::ExifTool::APP12::Ducky');
4362 my %dirInfo = (
4363 Parent => 'APP12',
4364 );
4365 my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr);
4366 if (defined $buff and length $buff) {
4367 my $size = length($buff) + 5;
4368 if ($size <= $maxSegmentLen) {
4369 # write the new segment with appropriate header
4370 my $app12hdr = "\xff\xec" . pack('n', $size + 2);
4371 Write($outfile, $app12hdr, 'Ducky', $buff) or $err = 1;
4372 } else {
4373 $self->Warn("Ducky APP12 segment too large! ($size bytes)");
4374 }
4375 }
4376 }
4377 # finally, COM segment
4378 last if $dirCount{COM};
4379 if (exists $$addDirs{COM} and not defined $doneDir{COM}) {
4380 $doneDir{COM} = 1;
4381 next if $$delGroup{File} and $$delGroup{File} != 2;
4382 my $newComment = $self->GetNewValues('Comment');
4383 if (defined $newComment and length($newComment)) {
4384 if ($verbose) {
4385 print $out "Creating COM:\n";
4386 $self->VerboseValue('+ Comment', $newComment);
4387 }
4388 WriteMultiSegment($outfile, 0xfe, '', \$newComment) or $err = 1;
4389 ++$self->{CHANGED};
4390 }
4391 }
4392 last; # didn't want to loop anyway
4393 }
4394 # decrement counter for this directory since we are about to process it
4395 --$dirCount{$dirName};
4396#
4397# rewrite existing segments
4398#
4399 # handle SOF markers: SOF0-SOF15, except DHT(0xc4), JPGA(0xc8) and DAC(0xcc)
4400 if (($marker & 0xf0) == 0xc0 and ($marker == 0xc0 or $marker & 0x03)) {
4401 $verbose and print $out "JPEG $markerName:\n";
4402 Write($outfile, $hdr, $segData) or $err = 1;
4403 next;
4404 } elsif ($marker == 0xda) { # SOS
4405 pop @$path;
4406 $verbose and print $out "JPEG SOS\n";
4407 # write SOS segment
4408 $s = pack('n', length($segData) + 2);
4409 Write($outfile, $hdr, $s, $segData) or $err = 1;
4410 my ($buff, $endPos, $trailInfo);
4411 my $delPreview = $self->{DEL_PREVIEW};
4412 $trailInfo = IdentifyTrailer($raf) unless $$delGroup{Trailer};
4413 unless ($oldOutfile or $delPreview or $trailInfo or $$delGroup{Trailer}) {
4414 # blindly copy the rest of the file
4415 while ($raf->Read($buff, 65536)) {
4416 Write($outfile, $buff) or $err = 1, last;
4417 }
4418 $rtnVal = 1; # success unless we have a file write error
4419 last; # all done
4420 }
4421 # write the rest of the image (as quickly as possible) up to the EOI
4422 my $endedWithFF;
4423 for (;;) {
4424 my $n = $raf->Read($buff, 65536) or last Marker;
4425 if (($endedWithFF and $buff =~ m/^\xd9/sg) or
4426 $buff =~ m/\xff\xd9/sg)
4427 {
4428 $rtnVal = 1; # the JPEG is OK
4429 # write up to the EOI
4430 my $pos = pos($buff);
4431 Write($outfile, substr($buff, 0, $pos)) or $err = 1;
4432 $buff = substr($buff, $pos);
4433 last;
4434 }
4435 unless ($n == 65536) {
4436 $self->Error('JPEG EOI marker not found');
4437 last Marker;
4438 }
4439 Write($outfile, $buff) or $err = 1;
4440 $endedWithFF = substr($buff, 65535, 1) eq "\xff" ? 1 : 0;
4441 }
4442 # remember position of last data copied
4443 $endPos = $raf->Tell() - length($buff);
4444 # rewrite trailers if they exist
4445 if ($trailInfo) {
4446 my $tbuf = '';
4447 $raf->Seek(-length($buff), 1); # seek back to just after EOI
4448 $$trailInfo{OutFile} = \$tbuf; # rewrite the trailer
4449 $$trailInfo{ScanForAFCP} = 1; # scan if necessary
4450 $self->ProcessTrailers($trailInfo) or undef $trailInfo;
4451 }
4452 if (not $oldOutfile) {
4453 # do nothing special
4454 } elsif ($$self{LeicaTrailer}) {
4455 my $trailLen;
4456 if ($trailInfo) {
4457 $trailLen = $$trailInfo{DataPos} - $endPos;
4458 } else {
4459 $raf->Seek(0, 2) or $err = 1;
4460 $trailLen = $raf->Tell() - $endPos;
4461 }
4462 my $fixup = $$self{LeicaTrailer}{Fixup};
4463 $$self{LeicaTrailer}{TrailPos} = $endPos;
4464 $$self{LeicaTrailer}{TrailLen} = $trailLen;
4465 # get _absolute_ position of new Leica trailer
4466 my $absPos = Tell($oldOutfile) + length($$outfile);
4467 require Image::ExifTool::Panasonic;
4468 my $dat = Image::ExifTool::Panasonic::ProcessLeicaTrailer($self, $absPos);
4469 # allow some junk before Leica trailer (just in case)
4470 my $junk = $$self{LeicaTrailerPos} - $endPos;
4471 # set MakerNote pointer and size (subtract 10 for segment and EXIF headers)
4472 $fixup->SetMarkerPointers($outfile, 'LeicaTrailer', length($$outfile) - 10 + $junk);
4473 # use this fixup to set the size too (sneaky)
4474 my $trailSize = defined($dat) ? length($dat) - $junk : $$self{LeicaTrailer}{Size};
4475 $fixup->{Start} -= 4; $fixup->{Shift} += 4;
4476 $fixup->SetMarkerPointers($outfile, 'LeicaTrailer', $trailSize);
4477 $fixup->{Start} += 4; $fixup->{Shift} -= 4;
4478 # clean up and write the buffered data
4479 $outfile = $oldOutfile;
4480 undef $oldOutfile;
4481 Write($outfile, $writeBuffer) or $err = 1;
4482 undef $writeBuffer;
4483 if (defined $dat) {
4484 Write($outfile, $dat) or $err = 1; # write new Leica trailer
4485 $delPreview = 1; # delete existing Leica trailer
4486 }
4487 } else {
4488 # locate preview image and fix up preview offsets
4489 my $scanLen = $$self{Make} =~ /Sony/i ? 65536 : 1024;
4490 if (length($buff) < $scanLen) { # make sure we have enough trailer to scan
4491 my $buf2;
4492 $buff .= $buf2 if $raf->Read($buf2, $scanLen - length($buff));
4493 }
4494 # get new preview image position, relative to EXIF base
4495 my $newPos = length($$outfile) - 10; # (subtract 10 for segment and EXIF headers)
4496 my $junkLen;
4497 # adjust position if image isn't at the start (ie. Olympus E-1/E-300)
4498 if ($buff =~ m/(\xff\xd8\xff.|.\xd8\xff\xdb)/sg) {
4499 $junkLen = pos($buff) - 4;
4500 # Sony previewimage trailer has a 32 byte header
4501 $junkLen -= 32 if $$self{Make} =~/SONY/i and $junkLen > 32;
4502 $newPos += $junkLen;
4503 }
4504 # fix up the preview offsets to point to the start of the new image
4505 my $previewInfo = $self->{PREVIEW_INFO};
4506 delete $self->{PREVIEW_INFO};
4507 my $fixup = $$previewInfo{Fixup};
4508 $newPos += ($$previewInfo{BaseShift} || 0);
4509 # adjust to absolute file offset if necessary (Samsung STMN)
4510 $newPos += Tell($oldOutfile) + 10 if $$previewInfo{Absolute};
4511 if ($$previewInfo{Relative}) {
4512 # adjust for our base by looking at how far the pointer got shifted
4513 $newPos -= $fixup->GetMarkerPointers($outfile, 'PreviewImage');
4514 } elsif ($$previewInfo{ChangeBase}) {
4515 # Leica S2 uses relative offsets for the preview only (leica sucks)
4516 my $makerOffset = $fixup->GetMarkerPointers($outfile, 'LeicaTrailer');
4517 $newPos -= $makerOffset if $makerOffset;
4518 }
4519 $fixup->SetMarkerPointers($outfile, 'PreviewImage', $newPos);
4520 # clean up and write the buffered data
4521 $outfile = $oldOutfile;
4522 undef $oldOutfile;
4523 Write($outfile, $writeBuffer) or $err = 1;
4524 undef $writeBuffer;
4525 # write preview image
4526 if ($$previewInfo{Data} ne 'LOAD_PREVIEW') {
4527 # write any junk that existed before the preview image
4528 Write($outfile, substr($buff,0,$junkLen)) or $err = 1 if $junkLen;
4529 # write the saved preview image
4530 Write($outfile, $$previewInfo{Data}) or $err = 1;
4531 delete $$previewInfo{Data};
4532 # (don't increment CHANGED because we could be rewriting existing preview)
4533 $delPreview = 1; # remove old preview
4534 }
4535 }
4536 # copy over preview image if necessary
4537 unless ($delPreview) {
4538 my $extra;
4539 if ($trailInfo) {
4540 # copy everything up to start of first processed trailer
4541 $extra = $$trailInfo{DataPos} - $endPos;
4542 } else {
4543 # copy everything up to end of file
4544 $raf->Seek(0, 2) or $err = 1;
4545 $extra = $raf->Tell() - $endPos;
4546 }
4547 if ($extra > 0) {
4548 if ($$delGroup{Trailer}) {
4549 $verbose and print $out " Deleting unknown trailer ($extra bytes)\n";
4550 ++$self->{CHANGED};
4551 } else {
4552 # copy over unknown trailer
4553 $verbose and print $out " Preserving unknown trailer ($extra bytes)\n";
4554 $raf->Seek($endPos, 0) or $err = 1;
4555 CopyBlock($raf, $outfile, $extra) or $err = 1;
4556 }
4557 }
4558 }
4559 # write trailer if necessary
4560 if ($trailInfo) {
4561 $self->WriteTrailerBuffer($trailInfo, $outfile) or $err = 1;
4562 undef $trailInfo;
4563 }
4564 last; # all done parsing file
4565
4566 } elsif ($marker==0x00 or $marker==0x01 or ($marker>=0xd0 and $marker<=0xd7)) {
4567 $verbose and $marker and print $out "JPEG $markerName:\n";
4568 # handle stand-alone markers 0x00, 0x01 and 0xd0-0xd7 (NULL, TEM, RST0-RST7)
4569 Write($outfile, $hdr) or $err = 1;
4570 next;
4571 }
4572 #
4573 # NOTE: A 'next' statement after this point will cause $$segDataPt
4574 # not to be written if there is an output file, so in this case
4575 # the $self->{CHANGED} flags must be updated
4576 #
4577 my $segDataPt = \$segData;
4578 $length = length($segData);
4579 if ($verbose) {
4580 print $out "JPEG $markerName ($length bytes):\n";
4581 if ($verbose > 2 and $markerName =~ /^APP/) {
4582 HexDump($segDataPt, undef, %dumpParms);
4583 }
4584 }
4585 my ($segType, $del);
4586 # rewrite this segment only if we are changing a tag which is contained in its
4587 # directory (or deleting '*', in which case we need to identify the segment type)
4588 while (exists $$editDirs{$markerName} or $$delGroup{'*'}) {
4589 my $oldChanged = $self->{CHANGED};
4590 if ($marker == 0xe0) { # APP0 (JFIF, CIFF)
4591 if ($$segDataPt =~ /^JFIF\0/) {
4592 $segType = 'JFIF';
4593 $$delGroup{JFIF} and $del = 1, last;
4594 last unless $$editDirs{JFIF};
4595 SetByteOrder('MM');
4596 my $tagTablePtr = GetTagTable('Image::ExifTool::JFIF::Main');
4597 my %dirInfo = (
4598 DataPt => $segDataPt,
4599 DataPos => $segPos,
4600 DataLen => $length,
4601 DirStart => 5, # directory starts after identifier
4602 DirLen => $length-5,
4603 Parent => $markerName,
4604 );
4605 my $newData = $self->WriteDirectory(\%dirInfo, $tagTablePtr);
4606 if (defined $newData and length $newData) {
4607 $$segDataPt = "JFIF\0" . $newData;
4608 }
4609 } elsif ($$segDataPt =~ /^JFXX\0\x10/) {
4610 $segType = 'JFXX';
4611 $$delGroup{JFIF} and $del = 1;
4612 } elsif ($$segDataPt =~ /^(II|MM).{4}HEAPJPGM/s) {
4613 $segType = 'CIFF';
4614 $$delGroup{CIFF} and $del = 1, last;
4615 last unless $$editDirs{CIFF};
4616 my $newData = '';
4617 my %dirInfo = (
4618 RAF => new File::RandomAccess($segDataPt),
4619 OutFile => \$newData,
4620 );
4621 require Image::ExifTool::CanonRaw;
4622 if (Image::ExifTool::CanonRaw::WriteCRW($self, \%dirInfo) > 0) {
4623 if (length $newData) {
4624 $$segDataPt = $newData;
4625 } else {
4626 undef $segDataPt;
4627 $del = 1; # delete this segment
4628 }
4629 }
4630 }
4631 } elsif ($marker == 0xe1) { # APP1 (EXIF, XMP)
4632 # check for EXIF data
4633 if ($$segDataPt =~ /^$exifAPP1hdr/) {
4634 $segType = 'EXIF';
4635 $doneDir{IFD0} and $self->Warn('Multiple APP1 EXIF segments');
4636 $doneDir{IFD0} = 1;
4637 last unless $$editDirs{IFD0};
4638 # check del groups now so we can change byte order in one step
4639 if ($$delGroup{IFD0} or $$delGroup{EXIF}) {
4640 delete $doneDir{IFD0}; # delete so we will create a new one
4641 $del = 1;
4642 last;
4643 }
4644 # rewrite EXIF as if this were a TIFF file in memory
4645 my %dirInfo = (
4646 DataPt => $segDataPt,
4647 DataPos => $segPos,
4648 DirStart => 6,
4649 Base => $segPos + 6,
4650 Parent => $markerName,
4651 DirName => 'IFD0',
4652 );
4653 # write new EXIF data to memory
4654 my $tagTablePtr = GetTagTable('Image::ExifTool::Exif::Main');
4655 my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr, \&WriteTIFF);
4656 if (defined $buff) {
4657 # update segment with new data
4658 $$segDataPt = $exifAPP1hdr . $buff;
4659 } else {
4660 last Marker unless $self->Options('IgnoreMinorErrors');
4661 $self->{CHANGED} = $oldChanged; # nothing changed
4662 }
4663 # switch to buffered output if required
4664 if (($$self{PREVIEW_INFO} or $$self{LeicaTrailer}) and not $oldOutfile) {
4665 $writeBuffer = '';
4666 $oldOutfile = $outfile;
4667 $outfile = \$writeBuffer;
4668 # must account for segment, EXIF and TIFF headers
4669 $$self{PREVIEW_INFO}{Fixup}{Start} += 18 if $$self{PREVIEW_INFO};
4670 $$self{LeicaTrailer}{Fixup}{Start} += 18 if $$self{LeicaTrailer};
4671 }
4672 # delete segment if IFD contains no entries
4673 $del = 1 unless length($$segDataPt) > length($exifAPP1hdr);
4674 # check for XMP data
4675 } elsif ($$segDataPt =~ /^($xmpAPP1hdr|$xmpExtAPP1hdr)/) {
4676 $segType = 'XMP';
4677 $$delGroup{XMP} and $del = 1, last;
4678 $doneDir{XMP} = ($doneDir{XMP} || 0) + 1;
4679 last unless $$editDirs{XMP};
4680 if ($doneDir{XMP} + $dirCount{XMP} > 1) {
4681 # must assemble all XMP segments before writing
4682 my ($guid, $extXMP);
4683 if ($$segDataPt =~ /^$xmpExtAPP1hdr/) {
4684 # save extended XMP data
4685 if (length $$segDataPt < 75) {
4686 $extendedXMP{Error} = 'Truncated data';
4687 } else {
4688 my ($size, $off) = unpack('x67N2', $$segDataPt);
4689 $guid = substr($$segDataPt, 35, 32);
4690 # remember extended data for each GUID
4691 $extXMP = $extendedXMP{$guid};
4692 if ($extXMP) {
4693 $size == $$extXMP{Size} or $extendedXMP{Error} = 'Invalid size';
4694 } else {
4695 $extXMP = $extendedXMP{$guid} = { };
4696 }
4697 $$extXMP{Size} = $size;
4698 $$extXMP{$off} = substr($$segDataPt, 75);
4699 }
4700 } else {
4701 # save all main XMP segments (should normally be only one)
4702 $extendedXMP{Main} = [] unless $extendedXMP{Main};
4703 push @{$extendedXMP{Main}}, substr($$segDataPt, length $xmpAPP1hdr);
4704 }
4705 # continue processing only if we have read all the segments
4706 next Marker if $dirCount{XMP};
4707 # reconstruct an XMP super-segment
4708 $$segDataPt = $xmpAPP1hdr;
4709 $$segDataPt .= $_ foreach @{$extendedXMP{Main}};
4710 foreach $guid (sort keys %extendedXMP) {
4711 next unless length $guid == 32; # ignore other keys
4712 $extXMP = $extendedXMP{$guid};
4713 next unless ref $extXMP eq 'HASH'; # (just to be safe)
4714 my $size = $$extXMP{Size};
4715 my (@offsets, $off);
4716 for ($off=0; $off<$size; ) {
4717 last unless defined $$extXMP{$off};
4718 push @offsets, $off;
4719 $off += length $$extXMP{$off};
4720 }
4721 if ($off == $size) {
4722 # add all XMP to super-segment
4723 $$segDataPt .= $$extXMP{$_} foreach @offsets;
4724 } else {
4725 $extendedXMP{Error} = 'Missing XMP data';
4726 }
4727 }
4728 $self->Error("$extendedXMP{Error} in extended XMP", 1) if $extendedXMP{Error};
4729 }
4730 my $start = length $xmpAPP1hdr;
4731 my $tagTablePtr = GetTagTable('Image::ExifTool::XMP::Main');
4732 my %dirInfo = (
4733 DataPt => $segDataPt,
4734 DirStart => $start,
4735 Parent => $markerName,
4736 # limit XMP size and create extended XMP if necessary
4737 MaxDataLen => $maxXMPLen - length($xmpAPP1hdr),
4738 );
4739 my $newData = $self->WriteDirectory(\%dirInfo, $tagTablePtr);
4740 if (defined $newData) {
4741 undef %extendedXMP;
4742 if (length $newData) {
4743 # write multi-segment XMP (XMP plus extended XMP if necessary)
4744 WriteMultiXMP($self, $outfile, \$newData, $dirInfo{ExtendedXMP},
4745 $dirInfo{ExtendedGUID}) or $err = 1;
4746 undef $$segDataPt; # free the old buffer
4747 next Marker;
4748 } else {
4749 $$segDataPt = ''; # delete the XMP
4750 }
4751 } else {
4752 $self->{CHANGED} = $oldChanged;
4753 $verbose and print $out " [XMP rewritten with no changes]\n";
4754 if ($doneDir{XMP} > 1) {
4755 # re-write original multi-segment XMP
4756 my ($dat, $guid, $extXMP, $off);
4757 foreach $dat (@{$extendedXMP{Main}}) { # main XMP
4758 next unless length $dat;
4759 $s = pack('n', length($xmpAPP1hdr) + length($dat) + 2);
4760 Write($outfile, $hdr, $s, $xmpAPP1hdr, $dat) or $err = 1;
4761 }
4762 foreach $guid (sort keys %extendedXMP) { # extended XMP
4763 next unless length $guid == 32;
4764 $extXMP = $extendedXMP{$guid};
4765 next unless ref $extXMP eq 'HASH';
4766 my $size = $$extXMP{Size} or next;
4767 for ($off=0; defined $$extXMP{$off}; $off += length $$extXMP{$off}) {
4768 $s = pack('n', length($xmpExtAPP1hdr) + length($$extXMP{$off}) + 42);
4769 Write($outfile, $hdr, $s, $xmpExtAPP1hdr, $guid,
4770 pack('N2', $size, $off), $$extXMP{$off}) or $err = 1;
4771 }
4772 }
4773 undef $$segDataPt; # free the old buffer
4774 undef %extendedXMP;
4775 next Marker;
4776 }
4777 # continue on to re-write original single-segment XMP
4778 }
4779 $del = 1 unless length $$segDataPt;
4780 } elsif ($$segDataPt =~ /^http/ or $$segDataPt =~ /<exif:/) {
4781 $self->Warn('Ignored APP1 XMP segment with non-standard header', 1);
4782 }
4783 } elsif ($marker == 0xe2) { # APP2 (ICC Profile, FPXR)
4784 if ($$segDataPt =~ /^ICC_PROFILE\0/) {
4785 $segType = 'ICC_Profile';
4786 $$delGroup{ICC_Profile} and $del = 1, last;
4787 # must concatenate blocks of profile
4788 my $block_num = ord(substr($$segDataPt, 12, 1));
4789 my $blocks_tot = ord(substr($$segDataPt, 13, 1));
4790 $combinedSegData = '' if $block_num == 1;
4791 unless (defined $combinedSegData) {
4792 $self->Warn('APP2 ICC_Profile segments out of sequence');
4793 next Marker;
4794 }
4795 $combinedSegData .= substr($$segDataPt, 14);
4796 # continue accumulating segments unless this is the last
4797 next Marker unless $block_num == $blocks_tot;
4798 $doneDir{ICC_Profile} and $self->Warn('Multiple ICC_Profile records');
4799 $doneDir{ICC_Profile} = 1;
4800 $segDataPt = \$combinedSegData;
4801 $length = length $combinedSegData;
4802 my $tagTablePtr = GetTagTable('Image::ExifTool::ICC_Profile::Main');
4803 my %dirInfo = (
4804 DataPt => $segDataPt,
4805 DataPos => $segPos + 14,
4806 DataLen => $length,
4807 DirStart => 0,
4808 DirLen => $length,
4809 Parent => $markerName,
4810 );
4811 my $newData = $self->WriteDirectory(\%dirInfo, $tagTablePtr);
4812 if (defined $newData) {
4813 undef $$segDataPt; # free the old buffer
4814 $segDataPt = \$newData;
4815 }
4816 length $$segDataPt or $del = 1, last;
4817 # write as ICC multi-segment
4818 WriteMultiSegment($outfile, $marker, "ICC_PROFILE\0", $segDataPt, 'ICC') or $err = 1;
4819 undef $combinedSegData;
4820 undef $$segDataPt;
4821 next Marker;
4822 } elsif ($$segDataPt =~ /^FPXR\0/) {
4823 $segType = 'FPXR';
4824 $$delGroup{FlashPix} and $del = 1;
4825 }
4826 } elsif ($marker == 0xe3) { # APP3 (Kodak Meta)
4827 if ($$segDataPt =~ /^(Meta|META|Exif)\0\0/) {
4828 $segType = 'Kodak Meta';
4829 $$delGroup{Meta} and $del = 1, last;
4830 $doneDir{Meta} and $self->Warn('Multiple APP3 Meta segments');
4831 $doneDir{Meta} = 1;
4832 last unless $$editDirs{Meta};
4833 # rewrite Meta IFD as if this were a TIFF file in memory
4834 my %dirInfo = (
4835 DataPt => $segDataPt,
4836 DataPos => $segPos,
4837 DirStart => 6,
4838 Base => $segPos + 6,
4839 Parent => $markerName,
4840 DirName => 'Meta',
4841 );
4842 # write new data to memory
4843 my $tagTablePtr = GetTagTable('Image::ExifTool::Kodak::Meta');
4844 my $buff = $self->WriteDirectory(\%dirInfo, $tagTablePtr, \&WriteTIFF);
4845 if (defined $buff) {
4846 # update segment with new data
4847 $$segDataPt = substr($$segDataPt,0,6) . $buff;
4848 } else {
4849 last Marker unless $self->Options('IgnoreMinorErrors');
4850 $self->{CHANGED} = $oldChanged; # nothing changed
4851 }
4852 # delete segment if IFD contains no entries
4853 $del = 1 unless length($$segDataPt) > 6;
4854 }
4855 } elsif ($marker == 0xe5) { # APP5 (Ricoh RMETA)
4856 if ($$segDataPt =~ /^RMETA\0/) {
4857 $segType = 'Ricoh RMETA';
4858 $$delGroup{RMETA} and $del = 1;
4859 }
4860 } elsif ($marker == 0xec) { # APP12 (Ducky)
4861 if ($$segDataPt =~ /^Ducky/) {
4862 $segType = 'Ducky';
4863 $$delGroup{Ducky} and $del = 1, last;
4864 $doneDir{Ducky} and $self->Warn('Multiple APP12 Ducky segments');
4865 $doneDir{Ducky} = 1;
4866 last unless $$editDirs{Ducky};
4867 my $tagTablePtr = GetTagTable('Image::ExifTool::APP12::Ducky');
4868 my %dirInfo = (
4869 DataPt => $segDataPt,
4870 DataPos => $segPos,
4871 DataLen => $length,
4872 DirStart => 5, # directory starts after identifier
4873 DirLen => $length-5,
4874 Parent => $markerName,
4875 );
4876 my $newData = $self->WriteDirectory(\%dirInfo, $tagTablePtr);
4877 if (defined $newData) {
4878 undef $$segDataPt; # free the old buffer
4879 # add header to new segment unless empty
4880 $newData = 'Ducky' . $newData if length $newData;
4881 $segDataPt = \$newData;
4882 } else {
4883 $self->{CHANGED} = $oldChanged;
4884 }
4885 $del = 1 unless length $$segDataPt;
4886 }
4887 } elsif ($marker == 0xed) { # APP13 (Photoshop)
4888 if ($$segDataPt =~ /^$psAPP13hdr/) {
4889 $segType = 'Photoshop';
4890 # add this data to the combined data if it exists
4891 if (defined $combinedSegData) {
4892 $combinedSegData .= substr($$segDataPt,length($psAPP13hdr));
4893 $segDataPt = \$combinedSegData;
4894 $length = length $combinedSegData; # update length
4895 }
4896 # peek ahead to see if the next segment is photoshop data too
4897 if ($dirOrder[0] eq 'Photoshop') {
4898 # initialize combined data if necessary
4899 $combinedSegData = $$segDataPt unless defined $combinedSegData;
4900 next Marker; # get the next segment to combine
4901 }
4902 if ($doneDir{Photoshop}) {
4903 $self->Warn('Multiple Photoshop records');
4904 # only rewrite the first Photoshop segment when deleting this group
4905 # (to remove multiples when deleting and adding back in one step)
4906 $$delGroup{Photoshop} and $del = 1, last;
4907 }
4908 $doneDir{Photoshop} = 1;
4909 # process APP13 Photoshop record
4910 my $tagTablePtr = GetTagTable('Image::ExifTool::Photoshop::Main');
4911 my %dirInfo = (
4912 DataPt => $segDataPt,
4913 DataPos => $segPos,
4914 DataLen => $length,
4915 DirStart => 14, # directory starts after identifier
4916 DirLen => $length-14,
4917 Parent => $markerName,
4918 );
4919 my $newData = $self->WriteDirectory(\%dirInfo, $tagTablePtr);
4920 if (defined $newData) {
4921 undef $$segDataPt; # free the old buffer
4922 $segDataPt = \$newData;
4923 } else {
4924 $self->{CHANGED} = $oldChanged;
4925 }
4926 length $$segDataPt or $del = 1, last;
4927 # write as multi-segment
4928 WriteMultiSegment($outfile, $marker, $psAPP13hdr, $segDataPt) or $err = 1;
4929 undef $combinedSegData;
4930 undef $$segDataPt;
4931 next Marker;
4932 }
4933 } elsif ($marker == 0xfe) { # COM (JPEG comment)
4934 my $newComment;
4935 unless ($doneDir{COM}) {
4936 $doneDir{COM} = 1;
4937 unless ($$delGroup{File} and $$delGroup{File} != 2) {
4938 my $tagInfo = $Image::ExifTool::Extra{Comment};
4939 my $nvHash = $self->GetNewValueHash($tagInfo);
4940 if (IsOverwriting($nvHash, $segData) or $$delGroup{File}) {
4941 $newComment = GetNewValues($nvHash);
4942 } else {
4943 delete $$editDirs{COM}; # we aren't editing COM after all
4944 last;
4945 }
4946 }
4947 }
4948 $self->VerboseValue('- Comment', $$segDataPt);
4949 if (defined $newComment and length $newComment) {
4950 # write out the comments
4951 $self->VerboseValue('+ Comment', $newComment);
4952 WriteMultiSegment($outfile, 0xfe, '', \$newComment) or $err = 1;
4953 } else {
4954 $verbose and print $out " Deleting COM segment\n";
4955 }
4956 ++$self->{CHANGED}; # increment the changed flag
4957 undef $segDataPt; # don't write existing comment
4958 }
4959 last; # didn't want to loop anyway
4960 }
4961 # delete necessary segments (including unknown segments if deleting all)
4962 if ($del or ($$delGroup{'*'} and not $segType and $marker>=0xe0 and $marker<=0xef)) {
4963 $segType = 'unknown' unless $segType;
4964 $verbose and print $out " Deleting $markerName $segType segment\n";
4965 ++$self->{CHANGED};
4966 next Marker;
4967 }
4968 # write out this segment if $segDataPt is still defined
4969 if (defined $segDataPt) {
4970 # write the data for this record (the data could have been
4971 # modified, so recalculate the length word)
4972 my $size = length($$segDataPt);
4973 if ($size > $maxSegmentLen) {
4974 $segType or $segType = 'Unknown';
4975 $self->Error("$segType $markerName segment too large! ($size bytes)");
4976 $err = 1;
4977 } else {
4978 $s = pack('n', length($$segDataPt) + 2);
4979 Write($outfile, $hdr, $s, $$segDataPt) or $err = 1;
4980 }
4981 undef $$segDataPt; # free the buffer
4982 }
4983 }
4984 pop @$path if @$path > $pn;
4985 # if oldOutfile is still set, there was an error copying the JPEG
4986 $oldOutfile and return 0;
4987 if ($rtnVal) {
4988 # add any new trailers we are creating
4989 my $trailPt = $self->AddNewTrailers();
4990 Write($outfile, $$trailPt) or $err = 1 if $trailPt;
4991 }
4992 # set return value to -1 if we only had a write error
4993 $rtnVal = -1 if $rtnVal and $err;
4994 return $rtnVal;
4995}
4996
4997#------------------------------------------------------------------------------
4998# Validate an image for writing
4999# Inputs: 0) ExifTool object reference, 1) raw value reference
5000# Returns: error string or undef on success
5001sub CheckImage($$)
5002{
5003 my ($self, $valPtr) = @_;
5004 if (length($$valPtr) and $$valPtr!~/^\xff\xd8/ and not
5005 $self->Options('IgnoreMinorErrors'))
5006 {
5007 return '[minor] Not a valid image';
5008 }
5009 return undef;
5010}
5011
5012#------------------------------------------------------------------------------
5013# check a value for validity
5014# Inputs: 0) value reference, 1) format string, 2) optional count
5015# Returns: error string, or undef on success
5016# Notes: May modify value (if a count is specified for a string, it is null-padded
5017# to the specified length, and floating point values are rounded to integer if required)
5018sub CheckValue($$;$)
5019{
5020 my ($valPtr, $format, $count) = @_;
5021 my (@vals, $val, $n);
5022
5023 if ($format eq 'string' or $format eq 'undef') {
5024 return undef unless $count and $count > 0;
5025 my $len = length($$valPtr);
5026 if ($format eq 'string') {
5027 $len >= $count and return 'String too long';
5028 } else {
5029 $len > $count and return 'Data too long';
5030 }
5031 if ($len < $count) {
5032 $$valPtr .= "\0" x ($count - $len);
5033 }
5034 return undef;
5035 }
5036 if ($count and $count != 1) {
5037 @vals = split(' ',$$valPtr);
5038 $count < 0 and ($count = @vals or return undef);
5039 } else {
5040 $count = 1;
5041 @vals = ( $$valPtr );
5042 }
5043 if (@vals != $count) {
5044 my $str = @vals > $count ? 'Too many' : 'Not enough';
5045 return "$str values specified ($count required)";
5046 }
5047 for ($n=0; $n<$count; ++$n) {
5048 $val = shift @vals;
5049 if ($format =~ /^int/) {
5050 # make sure the value is integer
5051 unless (IsInt($val)) {
5052 if (IsHex($val)) {
5053 $val = $$valPtr = hex($val);
5054 } else {
5055 # round single floating point values to the nearest integer
5056 return 'Not an integer' unless IsFloat($val) and $count == 1;
5057 $val = $$valPtr = int($val + ($val < 0 ? -0.5 : 0.5));
5058 }
5059 }
5060 my $rng = $intRange{$format} or return "Bad int format: $format";
5061 return "Value below $format minimum" if $val < $$rng[0];
5062 # (allow 0xfeedfeed code as value for 16-bit pointers)
5063 return "Value above $format maximum" if $val > $$rng[1] and $val != 0xfeedfeed;
5064 } elsif ($format =~ /^rational/ or $format eq 'float' or $format eq 'double') {
5065 # make sure the value is a valid floating point number
5066 unless (IsFloat($val)) {
5067 # allow 'inf', 'undef' and fractional rational values
5068 if ($format =~ /^rational/) {
5069 next if $val eq 'inf' or $val eq 'undef';
5070 if ($val =~ m{^([-+]?\d+)/(\d+)$}) {
5071 next unless $1 < 0 and $format =~ /u$/;
5072 return 'Must be an unsigned rational';
5073 }
5074 }
5075 return 'Not a floating point number'
5076 }
5077 if ($format =~ /^rational\d+u$/ and $val < 0) {
5078 return 'Must be a positive number';
5079 }
5080 }
5081 }
5082 return undef; # success!
5083}
5084
5085#------------------------------------------------------------------------------
5086# check new value for binary data block
5087# Inputs: 0) ExifTool object ref, 1) tagInfo hash ref, 2) raw value ref
5088# Returns: error string or undef (and may modify value) on success
5089sub CheckBinaryData($$$)
5090{
5091 my ($self, $tagInfo, $valPtr) = @_;
5092 my $format = $$tagInfo{Format};
5093 unless ($format) {
5094 my $table = $$tagInfo{Table};
5095 if ($table and $$table{FORMAT}) {
5096 $format = $$table{FORMAT};
5097 } else {
5098 # use default 'int8u' unless specified
5099 $format = 'int8u';
5100 }
5101 }
5102 my $count;
5103 if ($format =~ /(.*)\[(.*)\]/) {
5104 $format = $1;
5105 $count = $2;
5106 # can't evaluate $count now because we don't know $size yet
5107 undef $count if $count =~ /\$size/;
5108 }
5109 return CheckValue($valPtr, $format, $count);
5110}
5111
5112#------------------------------------------------------------------------------
5113# Copy data block from RAF to output file in max 64kB chunks
5114# Inputs: 0) RAF ref, 1) outfile ref, 2) block size
5115# Returns: 1 on success, 0 on read error, undef on write error
5116sub CopyBlock($$$)
5117{
5118 my ($raf, $outfile, $size) = @_;
5119 my $buff;
5120 for (;;) {
5121 last unless $size > 0;
5122 my $n = $size > 65536 ? 65536 : $size;
5123 $raf->Read($buff, $n) == $n or return 0;
5124 Write($outfile, $buff) or return undef;
5125 $size -= $n;
5126 }
5127 return 1;
5128}
5129
5130#------------------------------------------------------------------------------
5131# copy image data from one file to another
5132# Inputs: 0) ExifTool object reference
5133# 1) reference to list of image data [ position, size, pad bytes ]
5134# 2) output file ref
5135# Returns: true on success
5136sub CopyImageData($$$)
5137{
5138 my ($self, $imageDataBlocks, $outfile) = @_;
5139 my $raf = $self->{RAF};
5140 my ($dataBlock, $err);
5141 my $num = @$imageDataBlocks;
5142 $self->VPrint(0, " Copying $num image data blocks\n") if $num;
5143 foreach $dataBlock (@$imageDataBlocks) {
5144 my ($pos, $size, $pad) = @$dataBlock;
5145 $raf->Seek($pos, 0) or $err = 'read', last;
5146 my $result = CopyBlock($raf, $outfile, $size);
5147 $result or $err = defined $result ? 'read' : 'writ';
5148 # pad if necessary
5149 Write($outfile, "\0" x $pad) or $err = 'writ' if $pad;
5150 last if $err;
5151 }
5152 if ($err) {
5153 $self->Error("Error ${err}ing image data");
5154 return 0;
5155 }
5156 return 1;
5157}
5158
5159#------------------------------------------------------------------------------
5160# write to binary data block
5161# Inputs: 0) ExifTool object ref, 1) source dirInfo ref, 2) tag table ref
5162# Returns: Binary data block or undefined on error
5163sub WriteBinaryData($$$)
5164{
5165 my ($self, $dirInfo, $tagTablePtr) = @_;
5166 $self or return 1; # allow dummy access to autoload this package
5167
5168 # get default format ('int8u' unless specified)
5169 my $dataPt = $$dirInfo{DataPt} or return undef;
5170 my $defaultFormat = $$tagTablePtr{FORMAT} || 'int8u';
5171 my $increment = FormatSize($defaultFormat);
5172 unless ($increment) {
5173 warn "Unknown format $defaultFormat\n";
5174 return undef;
5175 }
5176 # extract data members first if necessary
5177 my @varOffsets;
5178 if ($$tagTablePtr{DATAMEMBER}) {
5179 $$dirInfo{DataMember} = $$tagTablePtr{DATAMEMBER};
5180 $$dirInfo{VarFormatData} = \@varOffsets;
5181 $self->ProcessBinaryData($dirInfo, $tagTablePtr);
5182 delete $$dirInfo{DataMember};
5183 delete $$dirInfo{VarFormatData};
5184 }
5185 my $dirStart = $$dirInfo{DirStart} || 0;
5186 my $dirLen = $$dirInfo{DirLen} || length($$dataPt) - $dirStart;
5187 my $newData = substr($$dataPt, $dirStart, $dirLen) or return undef;
5188 my $dirName = $$dirInfo{DirName};
5189 my $varSize = 0;
5190 my @varInfo = @varOffsets;
5191 my $tagInfo;
5192 $dataPt = \$newData;
5193 foreach $tagInfo ($self->GetNewTagInfoList($tagTablePtr)) {
5194 my $tagID = $tagInfo->{TagID};
5195 # evaluate conditional tags now if necessary
5196 if (ref $$tagTablePtr{$tagID} eq 'ARRAY' or $$tagInfo{Condition}) {
5197 my $writeInfo = $self->GetTagInfo($tagTablePtr, $tagID);
5198 next unless $writeInfo and $writeInfo eq $tagInfo;
5199 }
5200 # add offsets for variable-sized tags if necessary
5201 while (@varInfo and $varInfo[0] < $tagID) {
5202 shift @varInfo; # discard index
5203 $varSize = shift @varInfo; # get accumulated variable size
5204 }
5205 my $count = 1;
5206 my $format = $$tagInfo{Format};
5207 my $entry = int($tagID) * $increment + $varSize; # relative offset of this entry
5208 if ($format) {
5209 if ($format =~ /(.*)\[(.*)\]/) {
5210 $format = $1;
5211 $count = $2;
5212 my $size = $dirLen; # used in eval
5213 # evaluate count to allow count to be based on previous values
5214 #### eval Format size ($size, $self) - NOTE: %val not supported for writing
5215 $count = eval $count;
5216 $@ and warn($@), next;
5217 } elsif ($format eq 'string') {
5218 # string with no specified count runs to end of block
5219 $count = ($dirLen > $entry) ? $dirLen - $entry : 0;
5220 }
5221 } else {
5222 $format = $defaultFormat;
5223 }
5224 my $val = ReadValue($dataPt, $entry, $format, $count, $dirLen-$entry);
5225 next unless defined $val;
5226 my $nvHash = $self->GetNewValueHash($tagInfo);
5227 next unless IsOverwriting($nvHash, $val);
5228 my $newVal = GetNewValues($nvHash);
5229 next unless defined $newVal; # can't delete from a binary table
5230 # only write masked bits if specified
5231 my $mask = $$tagInfo{Mask};
5232 $newVal = ($newVal & $mask) | ($val & ~$mask) if defined $mask;
5233 # set the size
5234 if ($$tagInfo{DataTag} and not $$tagInfo{IsOffset}) {
5235 warn 'Internal error' unless $newVal == 0xfeedfeed;
5236 my $data = $self->GetNewValues($$tagInfo{DataTag});
5237 $newVal = length($data) if defined $data;
5238 my $format = $$tagInfo{Format} || $$tagTablePtr{FORMAT} || 'int32u';
5239 if ($format =~ /^int16/ and $newVal > 0xffff) {
5240 $self->Error("$$tagInfo{DataTag} is too large (64 kB max. for this file)");
5241 }
5242 }
5243 my $rtnVal = WriteValue($newVal, $format, $count, $dataPt, $entry);
5244 if (defined $rtnVal) {
5245 $self->VerboseValue("- $dirName:$$tagInfo{Name}", $val);
5246 $self->VerboseValue("+ $dirName:$$tagInfo{Name}", $newVal);
5247 ++$self->{CHANGED};
5248 }
5249 }
5250 # add necessary fixups for any offsets
5251 if ($$tagTablePtr{IS_OFFSET} and $$dirInfo{Fixup}) {
5252 $varSize = 0;
5253 @varInfo = @varOffsets;
5254 my $fixup = $$dirInfo{Fixup};
5255 my $tagID;
5256 foreach $tagID (@{$tagTablePtr->{IS_OFFSET}}) {
5257 $tagInfo = $self->GetTagInfo($tagTablePtr, $tagID) or next;
5258 while (@varInfo and $varInfo[0] < $tagID) {
5259 shift @varInfo;
5260 $varSize = shift @varInfo;
5261 }
5262 my $entry = $tagID * $increment + $varSize; # (no offset to dirStart for new dir data)
5263 next unless $entry <= $dirLen - 4;
5264 # (Ricoh has 16-bit preview image offsets, so can't just assume int32u)
5265 my $format = $$tagInfo{Format} || $$tagTablePtr{FORMAT} || 'int32u';
5266 my $offset = ReadValue($dataPt, $entry, $format, 1, $dirLen-$entry);
5267 # ignore if offset is zero (ie. Ricoh DNG uses this to indicate no preview)
5268 next unless $offset;
5269 $fixup->AddFixup($entry, $$tagInfo{DataTag}, $format);
5270 # handle the preview image now if this is a JPEG file
5271 next unless $self->{FILE_TYPE} eq 'JPEG' and $$tagInfo{DataTag} and
5272 $$tagInfo{DataTag} eq 'PreviewImage' and defined $$tagInfo{OffsetPair};
5273 # NOTE: here we assume there are no var-sized tags between the
5274 # OffsetPair tags. If this ever becomes possible we must recalculate
5275 # $varSize for the OffsetPair tag here!
5276 $entry = $$tagInfo{OffsetPair} * $increment + $varSize;
5277 my $size = ReadValue($dataPt, $entry, $format, 1, $dirLen-$entry);
5278 my $previewInfo = $self->{PREVIEW_INFO};
5279 $previewInfo or $previewInfo = $self->{PREVIEW_INFO} = { };
5280 # set flag indicating we are using short pointers
5281 $$previewInfo{IsShort} = 1 unless $format eq 'int32u';
5282 $$previewInfo{Absolute} = 1 if $$tagInfo{IsOffset} and $$tagInfo{IsOffset} eq '3';
5283 # get the value of the Composite::PreviewImage tag
5284 $$previewInfo{Data} = $self->GetNewValues($Image::ExifTool::Composite{PreviewImage});
5285 unless (defined $$previewInfo{Data}) {
5286 if ($offset >= 0 and $offset + $size <= $$dirInfo{DataLen}) {
5287 $$previewInfo{Data} = substr(${$$dirInfo{DataPt}},$offset,$size);
5288 } else {
5289 $$previewInfo{Data} = 'LOAD_PREVIEW'; # flag to load preview later
5290 }
5291 }
5292 }
5293 }
5294 # write any necessary SubDirectories
5295 if ($$tagTablePtr{IS_SUBDIR}) {
5296 $varSize = 0;
5297 @varInfo = @varOffsets;
5298 my $tagID;
5299 foreach $tagID (@{$$tagTablePtr{IS_SUBDIR}}) {
5300 my $tagInfo = $self->GetTagInfo($tagTablePtr, $tagID);
5301 next unless defined $tagInfo;
5302 while (@varInfo and $varInfo[0] < $tagID) {
5303 shift @varInfo;
5304 $varSize = shift @varInfo;
5305 }
5306 my $entry = int($tagID) * $increment + $varSize;
5307 last if $entry >= $dirLen;
5308 # get value for Condition if necessary
5309 unless ($tagInfo) {
5310 my $more = $dirLen - $entry;
5311 $more = 128 if $more > 128;
5312 my $v = substr($newData, $entry, $more);
5313 $tagInfo = $self->GetTagInfo($tagTablePtr, $tagID, \$v);
5314 next unless $tagInfo;
5315 }
5316 next unless $$tagInfo{SubDirectory}; # (just to be safe)
5317 my %subdirInfo = ( DataPt => \$newData, DirStart => $entry );
5318 my $subTablePtr = GetTagTable($tagInfo->{SubDirectory}{TagTable});
5319 my $dat = $self->WriteDirectory(\%subdirInfo, $subTablePtr);
5320 substr($newData, $entry) = $dat if defined $dat and length $dat;
5321 }
5322 }
5323 return $newData;
5324}
5325
5326#------------------------------------------------------------------------------
5327# Write TIFF as a directory
5328# Inputs: 0) ExifTool object ref, 1) dirInfo ref, 2) tag table ref
5329# Returns: New directory data or undefined on error
5330sub WriteTIFF($$$)
5331{
5332 my ($self, $dirInfo, $tagTablePtr) = @_;
5333 my $buff = '';
5334 $$dirInfo{OutFile} = \$buff;
5335 return $buff if $self->ProcessTIFF($dirInfo, $tagTablePtr) > 0;
5336 return undef;
5337}
5338
53391; # end
5340
5341__END__
5342
5343=head1 NAME
5344
5345Image::ExifTool::Writer.pl - ExifTool routines for writing meta information
5346
5347=head1 SYNOPSIS
5348
5349These routines are autoloaded by Image::ExifTool when required.
5350
5351=head1 DESCRIPTION
5352
5353This module contains ExifTool write routines and other infrequently
5354used routines.
5355
5356=head1 AUTHOR
5357
5358Copyright 2003-2011, Phil Harvey (phil at owl.phy.queensu.ca)
5359
5360This library is free software; you can redistribute it and/or modify it
5361under the same terms as Perl itself.
5362
5363=head1 SEE ALSO
5364
5365L<Image::ExifTool(3pm)|Image::ExifTool>
5366
5367=cut
Note: See TracBrowser for help on using the repository browser.