Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

source: gsdl/trunk/perllib/cpan/Image/ExifTool/Writer.pl@ 16842

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats: