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

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

An (almost) complete copy of the perllib directory from a (circa SEP2011) head checkout from Greenstone 2 trunk - in order to try and make merging in this extension a little easier later on (as there have been some major changes to buildcol.pl commited in the main trunk but not in the x64 branch)
  • Property svn:executable set to *
File size: 32.3 KB
Line 
1#------------------------------------------------------------------------------
2# File: XMPStruct.pl
3#
4# Description: XMP structure support
5#
6# Revisions: 01/01/2011 - P. Harvey Created
7#------------------------------------------------------------------------------
8
9package Image::ExifTool::XMP;
10
11use strict;
12use vars qw(%specialStruct $xlatNamespace);
13
14use Image::ExifTool qw(:Utils);
15use Image::ExifTool::XMP;
16
17sub SerializeStruct($;$);
18sub InflateStruct($;$);
19sub DumpStruct($;$);
20sub CheckStruct($$$);
21sub AddNewStruct($$$$$$);
22sub ConvertStruct($$$$;$);
23
24#------------------------------------------------------------------------------
25# Serialize a structure (or other object) into a simple string
26# Inputs: 0) HASH ref, ARRAY ref, or SCALAR, 1) closing bracket (or undef)
27# Returns: serialized structure string
28# ie) "{field=text with {braces|}|, and a comma, field2=val2,field3={field4=[a,b]}}"
29sub SerializeStruct($;$)
30{
31 my ($obj, $ket) = @_;
32 my ($key, $val, @vals, $rtnVal);
33
34 if (ref $obj eq 'HASH') {
35 foreach $key (sort keys %$obj) {
36 push @vals, $key . '=' . SerializeStruct($$obj{$key}, '}');
37 }
38 $rtnVal = '{' . join(',', @vals) . '}';
39 } elsif (ref $obj eq 'ARRAY') {
40 foreach $val (@$obj) {
41 push @vals, SerializeStruct($val, ']');
42 }
43 $rtnVal = '[' . join(',', @vals) . ']';
44 } elsif (defined $obj) {
45 $obj = $$obj if ref $obj eq 'SCALAR';
46 # escape necessary characters in string (closing bracket plus "," and "|")
47 my $pat = $ket ? "\\$ket|,|\\|" : ',|\\|';
48 ($rtnVal = $obj) =~ s/($pat)/|$1/g;
49 # also must escape opening bracket or whitespace at start of string
50 $rtnVal =~ s/^([\s\[\{])/|$1/;
51 } else {
52 $rtnVal = ''; # allow undefined list items
53 }
54 return $rtnVal;
55}
56
57#------------------------------------------------------------------------------
58# Inflate structure (or other object) from a serialized string
59# Inputs: 0) reference to object in string form (serialized using the '|' escape)
60# 1) extra delimiter for scalar values delimiters
61# Returns: 0) object as a SCALAR, HASH ref, or ARRAY ref (or undef on error),
62# 1) warning string (or undef)
63# Notes: modifies input string to remove parsed objects
64sub InflateStruct($;$)
65{
66 my ($obj, $delim) = @_;
67 my ($val, $warn, $part);
68
69 if ($$obj =~ s/^\s*\{//) {
70 my %struct;
71 while ($$obj =~ s/^\s*([-\w:]+#?)\s*=//s) {
72 my $tag = $1;
73 my ($v, $w) = InflateStruct($obj, '}');
74 $warn = $w if $w and not $warn;
75 return(undef, $warn) unless defined $v;
76 $struct{$tag} = $v;
77 # eat comma separator, or all done if there wasn't one
78 last unless $$obj =~ s/^\s*,//s;
79 }
80 # eat closing brace and warn if we didn't find one
81 unless ($$obj =~ s/^\s*\}//s or $warn) {
82 if (length $$obj) {
83 ($part = $$obj) =~ s/^\s*//s;
84 $part =~ s/[\x0d\x0a].*//s;
85 $part = substr($part,0,27) . '...' if length($part) > 30;
86 $warn = "Invalid structure field at '$part'";
87 } else {
88 $warn = 'Missing closing brace for structure';
89 }
90 }
91 $val = \%struct;
92 } elsif ($$obj =~ s/^\s*\[//) {
93 my @list;
94 for (;;) {
95 my ($v, $w) = InflateStruct($obj, ']');
96 $warn = $w if $w and not $warn;
97 return(undef, $warn) unless defined $v;
98 push @list, $v;
99 last unless $$obj =~ s/^\s*,//s;
100 }
101 # eat closing bracket and warn if we didn't find one
102 $$obj =~ s/^\s*\]//s or $warn or $warn = 'Missing closing bracket for list';
103 $val = \@list;
104 } else {
105 $$obj =~ s/^\s+//s; # remove leading whitespace
106 # read scalar up to specified delimiter (or "," if not defined)
107 $val = '';
108 $delim = $delim ? "\\$delim|,|\\||\$" : ',|\\||$';
109 for (;;) {
110 $$obj =~ s/^(.*?)($delim)//s and $val .= $1;
111 last unless $2;
112 $2 eq '|' or $$obj = $2 . $$obj, last;
113 $$obj =~ s/^(.)//s and $val .= $1; # add escaped character
114 }
115 }
116 return($val, $warn);
117}
118
119#------------------------------------------------------------------------------
120# Get XMP language code from tag name string
121# Inputs: 0) tag name string
122# Returns: 0) separated tag name, 1) language code (in standard case), or '' if
123# language code was 'x-default', or undef if the tag had no language code
124sub GetLangCode($)
125{
126 my $tag = shift;
127 if ($tag =~ /^(\w+)[-_]([a-z]{2,3}|[xi])([-_][a-z\d]{2,8}([-_][a-z\d]{1,8})*)?$/i) {
128 # normalize case of language codes
129 my ($tg, $langCode) = ($1, lc($2));
130 $langCode .= (length($3) == 3 ? uc($3) : lc($3)) if $3;
131 $langCode =~ tr/_/-/; # RFC 3066 specifies '-' as a separator
132 $langCode = '' if lc($langCode) eq 'x-default';
133 return($tg, $langCode);
134 } else {
135 return($tag, undef);
136 }
137}
138
139#------------------------------------------------------------------------------
140# Debugging routine to dump a structure, list or scalar
141# Inputs: 0) scalar, ARRAY ref or HASH ref, 1) indent (or undef)
142sub DumpStruct($;$)
143{
144 local $_;
145 my ($obj, $indent) = @_;
146
147 $indent or $indent = '';
148 if (ref $obj eq 'HASH') {
149 print "{\n";
150 foreach (sort keys %$obj) {
151 print "$indent $_ = ";
152 DumpStruct($$obj{$_}, "$indent ");
153 }
154 print $indent, "},\n";
155 } elsif (ref $obj eq 'ARRAY') {
156 print "[\n";
157 foreach (@$obj) {
158 print "$indent ";
159 DumpStruct($_, "$indent ");
160 }
161 print $indent, "],\n",
162 } else {
163 print "\"$obj\",\n";
164 }
165}
166
167#------------------------------------------------------------------------------
168# Recursively validate structure fields (tags)
169# Inputs: 0) ExifTool ref, 1) Structure ref, 2) structure table definition ref
170# Returns: 0) validated structure ref, 1) error string, or undef on success
171# Notes:
172# - fixes field names in structure and applies inverse conversions to values
173# - copies structure to avoid interdependencies with calling code on referenced values
174# - handles lang-alt tags, and '#' on field names
175# - resets UTF-8 flag of SCALAR values
176# - un-escapes for XML or HTML as per Escape option setting
177sub CheckStruct($$$)
178{
179 my ($exifTool, $struct, $strTable) = @_;
180
181 my $strName = $$strTable{STRUCT_NAME} || RegisterNamespace($strTable);
182 ref $struct eq 'HASH' or return wantarray ? (undef, "Expecting $strName structure") : undef;
183
184 my ($key, $err, $warn, %copy, $rtnVal, $val);
185Key:
186 foreach $key (keys %$struct) {
187 my $tag = $key;
188 # allow trailing '#' to disable print conversion on a per-field basis
189 my ($type, $fieldInfo);
190 $type = 'ValueConv' if $tag =~ s/#$//;
191 $fieldInfo = $$strTable{$tag} unless $specialStruct{$tag};
192 # fix case of field name if necessary
193 unless ($fieldInfo) {
194 # (sort in reverse to get lower case (not special) tags first)
195 my ($fix) = reverse sort grep /^$tag$/i, keys %$strTable;
196 $fieldInfo = $$strTable{$tag = $fix} if $fix and not $specialStruct{$fix};
197 }
198 until (ref $fieldInfo eq 'HASH') {
199 # generate wildcard fields on the fly (ie. mwg-rs:Extensions)
200 unless ($$strTable{NAMESPACE}) {
201 my ($grp, $tg, $langCode);
202 ($grp, $tg) = $tag =~ /^(.+):(.+)/ ? (lc $1, $2) : ('', $tag);
203 undef $grp if $grp eq 'XMP'; # (a group of 'XMP' is implied)
204 require Image::ExifTool::TagLookup;
205 my @matches = Image::ExifTool::TagLookup::FindTagInfo($tg);
206 # also look for lang-alt tags
207 unless (@matches) {
208 ($tg, $langCode) = GetLangCode($tg);
209 @matches = Image::ExifTool::TagLookup::FindTagInfo($tg) if defined $langCode;
210 }
211 my ($tagInfo, $priority, $ti, $g1);
212 # find best matching tag
213 foreach $ti (@matches) {
214 my @grps = $exifTool->GetGroup($ti);
215 next unless $grps[0] eq 'XMP';
216 next if $grp and $grp ne lc $grps[1];
217 # must be lang-alt tag if we are writing an alternate language
218 next if defined $langCode and not ($$ti{Writable} and $$ti{Writable} eq 'lang-alt');
219 my $pri = $$ti{Priority} || 1;
220 $pri -= 10 if $$ti{Avoid};
221 next if defined $priority and $priority >= $pri;
222 $priority = $pri;
223 $tagInfo = $ti;
224 $g1 = $grps[1];
225 }
226 $tagInfo or $warn = "'$tag' is not a writable XMP tag", next Key;
227 GetPropertyPath($tagInfo); # make sure property path is generated for this tag
228 $tag = $$tagInfo{Name};
229 $tag = "$g1:$tag" if $grp;
230 $tag .= "-$langCode" if $langCode;
231 $fieldInfo = $$strTable{$tag};
232 # create new structure field if necessary
233 $fieldInfo or $fieldInfo = $$strTable{$tag} = {
234 %$tagInfo, # (also copies the necessary TagID and PropertyPath)
235 Namespace => $$tagInfo{Table}{NAMESPACE},
236 LangCode => $langCode,
237 };
238 # delete stuff we don't need (shouldn't cause harm, but better safe than sorry)
239 # - need to keep StructType and Table in case we need to call AddStructType later
240 delete $$fieldInfo{Description};
241 delete $$fieldInfo{Groups};
242 last; # write this dynamically-generated field
243 }
244 # generate lang-alt fields on the fly (ie. Iptc4xmpExt:AOTitle)
245 my ($tg, $langCode) = GetLangCode($tag);
246 if (defined $langCode) {
247 $fieldInfo = $$strTable{$tg} unless $specialStruct{$tg};
248 unless ($fieldInfo) {
249 my ($fix) = reverse sort grep /^$tg$/i, keys %$strTable;
250 $fieldInfo = $$strTable{$tg = $fix} if $fix and not $specialStruct{$fix};
251 }
252 if (ref $fieldInfo eq 'HASH' and $$fieldInfo{Writable} and
253 $$fieldInfo{Writable} eq 'lang-alt')
254 {
255 my $srcInfo = $fieldInfo;
256 $tag = $tg . '-' . $langCode if $langCode;
257 $fieldInfo = $$strTable{$tag};
258 # create new structure field if necessary
259 $fieldInfo or $fieldInfo = $$strTable{$tag} = {
260 %$srcInfo,
261 TagID => $tg,
262 LangCode => $langCode,
263 };
264 last; # write this lang-alt field
265 }
266 }
267 $warn = "'$tag' is not a field of $strName";
268 next Key;
269 }
270 if (ref $$struct{$key} eq 'HASH') {
271 $$fieldInfo{Struct} or $warn = "$tag is not a structure in $strName", next Key;
272 # recursively check this structure
273 ($val, $err) = CheckStruct($exifTool, $$struct{$key}, $$fieldInfo{Struct});
274 $err and $warn = $err, next Key;
275 $copy{$tag} = $val;
276 } elsif (ref $$struct{$key} eq 'ARRAY') {
277 $$fieldInfo{List} or $warn = "$tag is not a list in $strName", next Key;
278 # check all items in the list
279 my ($item, @copy);
280 my $i = 0;
281 foreach $item (@{$$struct{$key}}) {
282 if (not ref $item) {
283 $item = '' unless defined $item; # use empty string for missing items
284 $$fieldInfo{Struct} and $warn = "$tag items are not valid structures", next Key;
285 $exifTool->Sanitize(\$item);
286 ($copy[$i],$err) = $exifTool->ConvInv($item,$fieldInfo,$tag,$strName,$type);
287 $err and $warn = $err, next Key;
288 $err = CheckXMP($exifTool, $fieldInfo, \$copy[$i]);
289 $err and $warn = "$err in $strName $tag", next Key;
290 } elsif (ref $item eq 'HASH') {
291 $$fieldInfo{Struct} or $warn = "$tag is not a structure in $strName", next Key;
292 ($copy[$i], $err) = CheckStruct($exifTool, $item, $$fieldInfo{Struct});
293 $err and $warn = $err, next Key;
294 } else {
295 $warn = "Invalid value for $tag in $strName";
296 next Key;
297 }
298 ++$i;
299 }
300 $copy{$tag} = \@copy;
301 } elsif ($$fieldInfo{Struct}) {
302 $warn = "Improperly formed structure in $strName $tag";
303 } else {
304 $exifTool->Sanitize(\$$struct{$key});
305 ($val,$err) = $exifTool->ConvInv($$struct{$key},$fieldInfo,$tag,$strName,$type);
306 $err and $warn = $err, next Key;
307 $err = CheckXMP($exifTool, $fieldInfo, \$val);
308 $err and $warn = "$err in $strName $tag", next Key;
309 # turn this into a list if necessary
310 $copy{$tag} = $$fieldInfo{List} ? [ $val ] : $val;
311 }
312 }
313 if (%copy) {
314 $rtnVal = \%copy;
315 undef $err;
316 $$exifTool{CHECK_WARN} = $warn if $warn;
317 } else {
318 $err = $warn || 'Structure has no fields';
319 }
320 return wantarray ? ($rtnVal, $err) : $rtnVal;
321}
322
323#------------------------------------------------------------------------------
324# Delete matching structures from existing linearized XMP
325# Inputs: 0) ExifTool ref, 1) capture hash ref, 2) structure path ref,
326# 3) new value hash ref, 4) reference to change counter
327# Returns: 0) delete flag, 1) list index of deleted structure if adding to list
328# Notes: updates path to new base path for structure to be added
329sub DeleteStruct($$$$$)
330{
331 my ($exifTool, $capture, $pathPt, $nvHash, $changed) = @_;
332 my ($deleted, $added, $p, $pp, $val, $delPath);
333 my (@structPaths, @matchingPaths, @delPaths);
334
335 # find all existing elements belonging to this structure
336 ($pp = $$pathPt) =~ s/ \d+/ \\d\+/g;
337 @structPaths = sort grep(/^$pp\//, keys %$capture);
338
339 # delete only structures with matching fields if necessary
340 if ($$nvHash{DelValue}) {
341 if (@{$$nvHash{DelValue}}) {
342 my $strTable = $$nvHash{TagInfo}{Struct};
343 # all fields must match corresponding elements in the same
344 # root structure for it to be deleted
345 foreach $val (@{$$nvHash{DelValue}}) {
346 next unless ref $val eq 'HASH';
347 my (%cap, $p2, %match);
348 next unless AddNewStruct(undef, undef, \%cap, $$pathPt, $val, $strTable);
349 foreach $p (keys %cap) {
350 if ($p =~ / /) {
351 ($p2 = $p) =~ s/ \d+/ \\d\+/g;
352 @matchingPaths = sort grep(/^$p2$/, @structPaths);
353 } else {
354 push @matchingPaths, $p;
355 }
356 foreach $p2 (@matchingPaths) {
357 $p2 =~ /^($pp)/ or next;
358 # language attribute must also match if it exists
359 my $attr = $cap{$p}[1];
360 if ($$attr{'xml:lang'}) {
361 my $a2 = $$capture{$p2}[1];
362 next unless $$a2{'xml:lang'} and $$a2{'xml:lang'} eq $$attr{'xml:lang'};
363 }
364 if ($$capture{$p2}[0] eq $cap{$p}[0]) {
365 # ($1 contains root path for this structure)
366 $match{$1} = ($match{$1} || 0) + 1;
367 }
368 }
369 }
370 my $num = scalar(keys %cap);
371 foreach $p (keys %match) {
372 # do nothing unless all fields matched the same structure
373 next unless $match{$p} == $num;
374 # delete all elements of this structure
375 foreach $p2 (@structPaths) {
376 push @delPaths, $p2 if $p2 =~ /^$p/;
377 }
378 # remember path of first deleted structure
379 $delPath = $p if not $delPath or $delPath gt $p;
380 }
381 }
382 } # (else don't delete anything)
383 } elsif (@structPaths) {
384 @delPaths = @structPaths; # delete all
385 $structPaths[0] =~ /^($pp)/;
386 $delPath = $1;
387 }
388 if (@delPaths) {
389 my $verbose = $exifTool->Options('Verbose');
390 @delPaths = sort @delPaths if $verbose > 1;
391 foreach $p (@delPaths) {
392 $exifTool->VerboseValue("- XMP-$p", $$capture{$p}[0]) if $verbose > 1;
393 delete $$capture{$p};
394 $deleted = 1;
395 ++$$changed;
396 }
397 $delPath or warn("Internal error 1 in DeleteStruct\n"), return(undef,undef);
398 $$pathPt = $delPath; # return path of first element deleted
399 } else {
400 my $tagInfo = $$nvHash{TagInfo};
401 if ($$tagInfo{List}) {
402 # NOTE: we don't yet properly handle lang-alt elements!!!!
403 if (@structPaths) {
404 $structPaths[-1] =~ /^($pp)/ or warn("Internal error 2 in DeleteStruct\n"), return(undef,undef);
405 my $path = $1;
406 # (match last index to put in same lang-alt list for Bag of lang-alt items)
407 $path =~ m/.* (\d+)/g or warn("Internal error 3 in DeleteStruct\n"), return(undef,undef);
408 $added = $1;
409 # add after last item in list
410 my $len = length $added;
411 my $pos = pos($path) - $len;
412 my $nxt = substr($added, 1) + 1;
413 substr($path, $pos, $len) = length($nxt) . $nxt;
414 $$pathPt = $path;
415 } else {
416 $added = '10';
417 }
418 }
419 }
420 return($deleted, $added);
421}
422
423#------------------------------------------------------------------------------
424# Add new element to XMP capture hash
425# Inputs: 0) ExifTool ref, 1) TagInfo ref, 2) capture hash ref,
426# 3) resource path, 4) value ref, 5) hash ref for last used index numbers
427sub AddNewTag($$$$$$)
428{
429 my ($exifTool, $tagInfo, $capture, $path, $valPtr, $langIdx) = @_;
430 my $val = EscapeXML($$valPtr);
431 my %attrs;
432 # support writing RDF "resource" values
433 if ($$tagInfo{Resource}) {
434 $attrs{'rdf:resource'} = $val;
435 $val = '';
436 }
437 if ($$tagInfo{Writable} and $$tagInfo{Writable} eq 'lang-alt') {
438 # write the lang-alt tag
439 my $langCode = $$tagInfo{LangCode};
440 # add indexed lang-alt list properties
441 my $i = $$langIdx{$path} || 0;
442 $$langIdx{$path} = $i + 1; # save next list index
443 if ($i) {
444 my $idx = length($i) . $i;
445 $path =~ s/(.*) \d+/$1 $idx/; # set list index
446 }
447 $attrs{'xml:lang'} = $langCode || 'x-default';
448 }
449 $$capture{$path} = [ $val, \%attrs ];
450 # print verbose message
451 if ($exifTool and $exifTool->Options('Verbose') > 1) {
452 $exifTool->VerboseValue("+ XMP-$path", $val);
453 }
454}
455
456#------------------------------------------------------------------------------
457# Add new structure to capture hash for writing
458# Inputs: 0) ExifTool object ref (or undef for no warnings),
459# 1) tagInfo ref (or undef if no ExifTool), 2) capture hash ref,
460# 3) base path, 4) struct ref, 5) struct hash ref
461# Returns: number of tags changed
462# Notes: Escapes values for XML
463sub AddNewStruct($$$$$$)
464{
465 my ($exifTool, $tagInfo, $capture, $basePath, $struct, $strTable) = @_;
466 my $verbose = $exifTool ? $exifTool->Options('Verbose') : 0;
467 my ($tag, %langIdx);
468
469 my $ns = $$strTable{NAMESPACE} || '';
470 my $changed = 0;
471
472 foreach $tag (sort keys %$struct) {
473 my $fieldInfo = $$strTable{$tag} or next;
474 my $val = $$struct{$tag};
475 my $propPath = $$fieldInfo{PropertyPath};
476 unless ($propPath) {
477 $propPath = ($$fieldInfo{Namespace} || $ns) . ':' . ($$fieldInfo{TagID} || $tag);
478 if ($$fieldInfo{List}) {
479 $propPath .= "/rdf:$$fieldInfo{List}/rdf:li 10";
480 }
481 if ($$fieldInfo{Writable} and $$fieldInfo{Writable} eq 'lang-alt') {
482 $propPath .= "/rdf:Alt/rdf:li 10";
483 }
484 $$fieldInfo{PropertyPath} = $propPath; # save for next time
485 }
486 my $path = $basePath . '/' . ConformPathToNamespace($exifTool, $propPath);
487 my $addedTag;
488 if (ref $val eq 'HASH') {
489 my $subStruct = $$fieldInfo{Struct} or next;
490 $changed += AddNewStruct($exifTool, $tagInfo, $capture, $path, $val, $subStruct);
491 } elsif (ref $val eq 'ARRAY') {
492 next unless $$fieldInfo{List};
493 my $i = 0;
494 my ($item, $p);
495 # loop through all list items (note: can't yet write multi-dimensional lists)
496 foreach $item (@{$val}) {
497 if ($i) {
498 # update first index in field property (may be list of lang-alt lists)
499 $p = ConformPathToNamespace($exifTool, $propPath);
500 my $idx = length($i) . $i;
501 $p =~ s/ \d+/ $idx/;
502 $p = "$basePath/$p";
503 } else {
504 $p = $path;
505 }
506 if (ref $item eq 'HASH') {
507 my $subStruct = $$fieldInfo{Struct} or next;
508 AddNewStruct($exifTool, $tagInfo, $capture, $p, $item, $subStruct) or next;
509 } elsif (length $item) { # don't write empty items in list
510 AddNewTag($exifTool, $fieldInfo, $capture, $p, \$item, \%langIdx);
511 $addedTag = 1;
512 }
513 ++$changed;
514 ++$i;
515 }
516 } else {
517 AddNewTag($exifTool, $fieldInfo, $capture, $path, \$val, \%langIdx);
518 $addedTag = 1;
519 ++$changed;
520 }
521 # this is tricky, but we must add the rdf:type for contained structures
522 # in the case that a whole hierarchy was added at once by writing a
523 # flattened tag inside a variable-namespace structure
524 if ($addedTag and $$fieldInfo{StructType} and $$fieldInfo{Table}) {
525 AddStructType($exifTool, $$fieldInfo{Table}, $capture, $propPath, $basePath);
526 }
527 }
528 # add 'rdf:type' property if necessary
529 if ($$strTable{TYPE} and $changed) {
530 my $path = $basePath . '/' . ConformPathToNamespace($exifTool, "rdf:type");
531 unless ($$capture{$path}) {
532 $$capture{$path} = [ '', { 'rdf:resource' => $$strTable{TYPE} } ];
533 $exifTool->VerboseValue("+ XMP-$path", $$strTable{TYPE}) if $verbose > 1;
534 }
535 }
536 return $changed;
537}
538
539#------------------------------------------------------------------------------
540# Convert structure field values for printing
541# Inputs: 0) ExifTool ref, 1) tagInfo ref for structure tag, 2) value,
542# 3) conversion type: PrintConv, ValueConv or Raw (Both not allowed)
543# 4) tagID of parent structure (needed only if there was no flattened tag)
544# Notes: Makes a copy of the hash so any applied escapes won't affect raw values
545sub ConvertStruct($$$$;$)
546{
547 my ($exifTool, $tagInfo, $value, $type, $parentID) = @_;
548 if (ref $value eq 'HASH') {
549 my (%struct, $key);
550 my $table = $$tagInfo{Table};
551 $parentID = $$tagInfo{TagID} unless $parentID;
552 foreach $key (keys %$value) {
553 my $tagID = $parentID . ucfirst($key);
554 my $flatInfo = $$table{$tagID};
555 unless ($flatInfo) {
556 # handle variable-namespace structures
557 if ($key =~ /^XMP-(.*?:)(.*)/) {
558 $tagID = $1 . $parentID . ucfirst($2);
559 $flatInfo = $$table{$tagID};
560 }
561 $flatInfo or $flatInfo = $tagInfo;
562 }
563 my $v = $$value{$key};
564 if (ref $v) {
565 $v = ConvertStruct($exifTool, $flatInfo, $v, $type, $tagID);
566 } else {
567 $v = $exifTool->GetValue($flatInfo, $type, $v);
568 }
569 $struct{$key} = $v if defined $v; # save the converted value
570 }
571 return \%struct;
572 } elsif (ref $value eq 'ARRAY') {
573 my (@list, $val);
574 foreach $val (@$value) {
575 my $v = ConvertStruct($exifTool, $tagInfo, $val, $type, $parentID);
576 push @list, $v if defined $v;
577 }
578 return \@list;
579 } else {
580 return $exifTool->GetValue($tagInfo, $type, $value);
581 }
582}
583
584#------------------------------------------------------------------------------
585# Restore XMP structures in extracted information
586# Inputs: 0) ExifTool object ref
587# Notes: also restores lists (including multi-dimensional)
588sub RestoreStruct($)
589{
590 local $_;
591 my $exifTool = shift;
592 my ($key, %structs, %var, %lists, $si, %listKeys);
593 my $ex = $$exifTool{TAG_EXTRA};
594 foreach $key (keys %{$$exifTool{TAG_INFO}}) {
595 $$ex{$key} or next;
596 my ($err, $i);
597 my $structProps = $$ex{$key}{Struct} or next;
598 my $tagInfo = $$exifTool{TAG_INFO}{$key}; # tagInfo for flattened tag
599 my $table = $$tagInfo{Table};
600 my $prop = shift @$structProps;
601 my $tag = $$prop[0];
602 # get reference to structure tag (or normal list tag if not a structure)
603 my $strInfo = @$structProps ? $$table{$tag} : $tagInfo;
604 if ($strInfo) {
605 ref $strInfo eq 'HASH' or next; # (just to be safe)
606 if (@$structProps and not $$strInfo{Struct}) {
607 # this could happen for invalid XMP containing mixed lists
608 # (or for something like this -- what should we do here?:
609 # <meta:user-defined meta:name="License">test</meta:user-defined>)
610 $exifTool->Warn("$$strInfo{Name} is not a structure!");
611 next;
612 }
613 } else {
614 # create new entry in tag table for this structure
615 my $g1 = $$table{GROUPS}{0} || 'XMP';
616 my $name = $tag;
617 if ($tag =~ /(.+):(.+)/) {
618 my $ns;
619 ($ns, $name) = ($1, $2);
620 $ns = $$xlatNamespace{$ns} if $$xlatNamespace{$ns};
621 $g1 .= "-$ns";
622 }
623 $strInfo = {
624 Name => ucfirst $name,
625 Groups => { 1 => $g1 },
626 Struct => 'Unknown',
627 };
628 # add Struct entry if this is a structure
629 if (@$structProps) {
630 # this is a structure
631 $$strInfo{Struct} = { STRUCT_NAME => 'Unknown' } if @$structProps;
632 } elsif ($$tagInfo{LangCode}) {
633 # this is lang-alt list
634 $tag = $tag . '-' . $$tagInfo{LangCode};
635 $$strInfo{LangCode} = $$tagInfo{LangCode};
636 }
637 Image::ExifTool::AddTagToTable($table, $tag, $strInfo);
638 }
639 # use strInfo ref for base key to avoid collisions
640 $tag = $strInfo;
641 my $struct = \%structs;
642 my $oldStruct = $structs{$strInfo};
643 # (fyi: 'lang-alt' Writable type will be valid even if tag is not pre-defined)
644 my $writable = $$tagInfo{Writable} || '';
645 # walk through the stored structure property information
646 # to rebuild this structure
647 for (;;) {
648 my $index = $$prop[1];
649 if ($index and not @$structProps) {
650 # ignore this list if it is a simple lang-alt tag
651 if ($writable eq 'lang-alt') {
652 pop @$prop; # remove lang-alt index
653 undef $index if @$prop < 2;
654 }
655 # add language code if necessary
656 if ($$tagInfo{LangCode} and not ref $tag) {
657 $tag = $tag . '-' . $$tagInfo{LangCode};
658 }
659 }
660 my $nextStruct = $$struct{$tag};
661 if (defined $index) {
662 # the field is a list
663 $index = substr $index, 1; # remove digit count
664 if ($nextStruct) {
665 ref $nextStruct eq 'ARRAY' or $err = 2, last;
666 $struct = $nextStruct;
667 } else {
668 $struct = $$struct{$tag} = [ ];
669 }
670 $nextStruct = $$struct[$index];
671 # descend into multi-dimensional lists
672 for ($i=2; $$prop[$i]; ++$i) {
673 if ($nextStruct) {
674 ref $nextStruct eq 'ARRAY' or last;
675 $struct = $nextStruct;
676 } else {
677 $lists{$struct} = $struct;
678 $struct = $$struct[$index] = [ ];
679 }
680 $nextStruct = $$struct[$index];
681 $index = substr $$prop[$i], 1;
682 }
683 if (ref $nextStruct eq 'HASH') {
684 $struct = $nextStruct; # continue building sub-structure
685 } elsif (@$structProps) {
686 $lists{$struct} = $struct;
687 $struct = $$struct[$index] = { };
688 } else {
689 $lists{$struct} = $struct;
690 $$struct[$index] = $$exifTool{VALUE}{$key};
691 last;
692 }
693 } else {
694 if ($nextStruct) {
695 ref $nextStruct eq 'HASH' or $err = 3, last;
696 $struct = $nextStruct;
697 } elsif (@$structProps) {
698 $struct = $$struct{$tag} = { };
699 } else {
700 $$struct{$tag} = $$exifTool{VALUE}{$key};
701 last;
702 }
703 }
704 $prop = shift @$structProps or last;
705 $tag = $$prop[0];
706 if ($tag =~ /(.+):(.+)/) {
707 # tag in variable-namespace tables will have a leading
708 # XMP namespace on the tag name. In this case, add
709 # the corresponding group1 name to the tag ID.
710 my ($ns, $name) = ($1, $2);
711 $ns = $$xlatNamespace{$ns} if $$xlatNamespace{$ns};
712 $tag = "XMP-$ns:" . ucfirst $name;
713 } else {
714 $tag = ucfirst $tag;
715 }
716 }
717 if ($err) {
718 # this may happen if we have a structural error in the XMP
719 # (like an improperly contained list for example)
720 $exifTool->Warn("Error $err placing $$tagInfo{Name} in structure", 1);
721 delete $structs{$strInfo} unless $oldStruct;
722 } elsif ($tagInfo eq $strInfo) {
723 # just a regular list tag
724 if ($oldStruct) {
725 # keep tag with lowest numbered key (well, not exactly, since
726 # "Tag (10)" is lt "Tag (2)", but at least "Tag" is lt
727 # everything else, and this is really what we care about)
728 my $k = $listKeys{$oldStruct};
729 $k lt $key and $exifTool->DeleteTag($key), next;
730 $exifTool->DeleteTag($k); # remove tag with greater copy number
731 }
732 # replace existing value with new list
733 $$exifTool{VALUE}{$key} = $structs{$strInfo};
734 $listKeys{$structs{$strInfo}} = $key; # save key for this list tag
735 } else {
736 # save strInfo ref and file order
737 $var{$strInfo} = [ $strInfo, $$exifTool{FILE_ORDER}{$key} ];
738 $exifTool->DeleteTag($key);
739 }
740 }
741 # fill in undefined items in lists. In theory, undefined list items should
742 # be fine, but in practice the calling code may not check for this (and
743 # historically this wasn't necessary, so do this for backward compatibility)
744 foreach $si (keys %lists) {
745 defined $_ or $_ = '' foreach @{$lists{$si}};
746 }
747 # save new structure tags
748 foreach $si (keys %structs) {
749 next unless $var{$si}; # already handled regular lists
750 $key = $exifTool->FoundTag($var{$si}[0], '');
751 $$exifTool{VALUE}{$key} = $structs{$si};
752 $$exifTool{FILE_ORDER}{$key} = $var{$si}[1];
753 }
754}
755
756
7571; #end
758
759__END__
760
761=head1 NAME
762
763Image::ExifTool::XMPStruct.pl - XMP structure support
764
765=head1 SYNOPSIS
766
767This module is loaded automatically by Image::ExifTool when required.
768
769=head1 DESCRIPTION
770
771This file contains routines to provide read/write support of structured XMP
772information.
773
774=head1 AUTHOR
775
776Copyright 2003-2011, Phil Harvey (phil at owl.phy.queensu.ca)
777
778This library is free software; you can redistribute it and/or modify it
779under the same terms as Perl itself.
780
781=head1 SEE ALSO
782
783L<Image::ExifTool::TagNames/XMP Tags>,
784L<Image::ExifTool(3pm)|Image::ExifTool>
785
786=cut
Note: See TracBrowser for help on using the repository browser.