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

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

An (almost) complete copy of the perllib directory from a (circa SEP2011) head checkout from Greenstone 2 trunk - in order to try and make merging in this extension a little easier later on (as there have been some major changes to buildcol.pl commited in the main trunk but not in the x64 branch)
File size: 53.4 KB
Line 
1#------------------------------------------------------------------------------
2# File: WriteXMP.pl
3#
4# Description: Write XMP meta information
5#
6# Revisions: 12/19/2004 - P. Harvey Created
7#------------------------------------------------------------------------------
8package Image::ExifTool::XMP;
9
10use strict;
11use vars qw(%specialStruct %dateTimeInfo $xlatNamespace);
12
13use Image::ExifTool qw(:DataAccess :Utils);
14
15sub CheckXMP($$$);
16sub CaptureXMP($$$;$);
17sub SetPropertyPath($$;$$$$);
18
19my $debug = 0;
20my $numPadLines = 24; # number of blank padding lines
21
22# when writing extended XMP, resources bigger than this get placed in their own
23# rdf:Description so they can be moved to the extended segments if necessary
24my $newDescThresh = 10240; # 10 kB
25
26# individual resources and namespaces to place last in separate rdf:Description's
27# so they can be moved to extended XMP segments if required (see Oct. 2008 XMP spec)
28my %extendedRes = (
29 'photoshop:History' => 1,
30 'xap:Thumbnails' => 1,
31 'xmp:Thumbnails' => 1,
32 'crs' => 1,
33 'crss' => 1,
34);
35
36my $rdfDesc = 'rdf:Description';
37#
38# packet/xmp/rdf headers and trailers
39#
40my $pktOpen = "<?xpacket begin='\xef\xbb\xbf' id='W5M0MpCehiHzreSzNTczkc9d'?>\n";
41my $xmlOpen = "<?xml version='1.0' encoding='UTF-8'?>\n";
42my $xmpOpenPrefix = "<x:xmpmeta xmlns:x='$nsURI{x}'";
43my $rdfOpen = "<rdf:RDF xmlns:rdf='$nsURI{rdf}'>\n";
44my $rdfClose = "</rdf:RDF>\n";
45my $xmpClose = "</x:xmpmeta>\n";
46my $pktCloseW = "<?xpacket end='w'?>"; # writable by default
47my $pktCloseR = "<?xpacket end='r'?>";
48
49#------------------------------------------------------------------------------
50# Get XMP opening tag (and set x:xmptk appropriately)
51# Inputs: 0) ExifTool object ref
52# Returns: x:xmpmeta opening tag
53sub XMPOpen($)
54{
55 my $exifTool = shift;
56 my $nv = $exifTool->{NEW_VALUE}->{$Image::ExifTool::XMP::x{xmptk}};
57 my $tk;
58 if (defined $nv) {
59 $tk = Image::ExifTool::GetNewValues($nv);
60 $exifTool->VerboseValue(($tk ? '+' : '-') . ' XMP-x:XMPToolkit', $tk);
61 ++$exifTool->{CHANGED};
62 } else {
63 $tk = "Image::ExifTool $Image::ExifTool::VERSION";
64 }
65 my $str = $tk ? (" x:xmptk='" . EscapeXML($tk) . "'") : '';
66 return "$xmpOpenPrefix$str>\n";
67}
68
69#------------------------------------------------------------------------------
70# Validate XMP packet and set read or read/write mode
71# Inputs: 0) XMP data reference, 1) 'r' = read only, 'w' or undef = read/write
72# Returns: true if XMP is good (and adds packet header/trailer if necessary)
73sub ValidateXMP($;$)
74{
75 my ($xmpPt, $mode) = @_;
76 unless ($$xmpPt =~ /^\0*<\0*\?\0*x\0*p\0*a\0*c\0*k\0*e\0*t/) {
77 return '' unless $$xmpPt =~ /^<x(mp)?:x[ma]pmeta/;
78 # add required xpacket header/trailer
79 $$xmpPt = $pktOpen . $$xmpPt . $pktCloseW;
80 }
81 $mode = 'w' unless $mode;
82 my $end = substr($$xmpPt, -32, 32);
83 # check for proper xpacket trailer and set r/w mode if necessary
84 return '' unless $end =~ s/(e\0*n\0*d\0*=\0*['"]\0*)([rw])(\0*['"]\0*\?\0*>)/$1$mode$3/;
85 substr($$xmpPt, -32, 32) = $end if $2 ne $mode;
86 return 1;
87}
88
89#------------------------------------------------------------------------------
90# Check XMP date values for validity and format accordingly
91# Inputs: 1) date string
92# Returns: XMP date/time string (or undef on error)
93sub FormatXMPDate($)
94{
95 my $val = shift;
96 my ($y, $m, $d, $t, $tz);
97 if ($val =~ /(\d{4}):(\d{2}):(\d{2}) (\d{2}:\d{2}(?::\d{2}(?:\.\d*)?)?)(.*)/) {
98 ($y, $m, $d, $t, $tz) = ($1, $2, $3, $4, $5);
99 $val = "$y-$m-${d}T$t";
100 } elsif ($val =~ /^\s*\d{4}(:\d{2}){0,2}\s*$/) {
101 # this is just a date (YYYY, YYYY-mm or YYYY-mm-dd)
102 $val =~ tr/:/-/;
103 } elsif ($val =~ /^\s*(\d{2}:\d{2}(?::\d{2}(?:\.\d*)?)?)(.*)\s*$/) {
104 # this is just a time
105 ($t, $tz) = ($1, $2);
106 $val = $t;
107 } else {
108 return undef;
109 }
110 if ($tz) {
111 $tz =~ /^(Z|[+-]\d{2}:\d{2})$/ or return undef;
112 $val .= $tz;
113 }
114 return $val;
115}
116
117#------------------------------------------------------------------------------
118# Check XMP values for validity and format accordingly
119# Inputs: 0) ExifTool object ref, 1) tagInfo hash ref, 2) raw value ref
120# Returns: error string or undef (and may change value) on success
121# Note: copies structured information to avoid conflicts with calling code
122sub CheckXMP($$$)
123{
124 my ($exifTool, $tagInfo, $valPtr) = @_;
125
126 if ($$tagInfo{Struct}) {
127 require 'Image/ExifTool/XMPStruct.pl';
128 my ($item, $err, $w, $warn);
129 unless (ref $$valPtr) {
130 ($$valPtr, $warn) = InflateStruct($valPtr);
131 # expect a structure HASH ref or ARRAY of structures
132 ref $$valPtr or return 'Improperly formed structure';
133 }
134 if (ref $$valPtr eq 'ARRAY') {
135 return 'Not a list tag' unless $$tagInfo{List};
136 my @copy = ( @{$$valPtr} ); # copy the list for ExifTool to use
137 $$valPtr = \@copy; # return the copy
138 foreach $item (@copy) {
139 unless (ref $item eq 'HASH') {
140 ($item, $w) = InflateStruct(\$item); # deserialize structure
141 $w and $warn = $w;
142 next if ref $item eq 'HASH';
143 $err = 'Improperly formed structure';
144 last;
145 }
146 ($item, $err) = CheckStruct($exifTool, $item, $$tagInfo{Struct});
147 last if $err;
148 }
149 } else {
150 ($$valPtr, $err) = CheckStruct($exifTool, $$valPtr, $$tagInfo{Struct});
151 }
152 $warn and $$exifTool{CHECK_WARN} = $warn;
153 return $err;
154 }
155 my $format = $tagInfo->{Writable};
156 # (if no format specified, value is a simple string)
157 if (not $format or $format eq 'string' or $format eq 'lang-alt') {
158 # convert value to UTF8 if necessary
159 if ($exifTool->{OPTIONS}->{Charset} ne 'UTF8') {
160 if ($$valPtr =~ /[\x80-\xff]/) {
161 # convert from Charset to UTF-8
162 $$valPtr = $exifTool->Encode($$valPtr,'UTF8');
163 }
164 } else {
165 # translate invalid XML characters to "."
166 $$valPtr =~ tr/\0-\x08\x0b\x0c\x0e-\x1f/./;
167 # fix any malformed UTF-8 characters
168 if (FixUTF8($valPtr) and not $$exifTool{WarnBadUTF8}) {
169 $exifTool->Warn('Malformed UTF-8 character(s)');
170 $$exifTool{WarnBadUTF8} = 1;
171 }
172 }
173 return undef; # success
174 }
175 if ($format eq 'rational' or $format eq 'real') {
176 # make sure the value is a valid floating point number
177 unless (Image::ExifTool::IsFloat($$valPtr) or
178 # allow 'inf' and 'undef' rational values
179 ($format eq 'rational' and ($$valPtr eq 'inf' or
180 $$valPtr eq 'undef' or Image::ExifTool::IsRational($$valPtr))))
181 {
182 return 'Not a floating point number'
183 }
184 if ($format eq 'rational') {
185 $$valPtr = join('/', Image::ExifTool::Rationalize($$valPtr));
186 }
187 } elsif ($format eq 'integer') {
188 # make sure the value is integer
189 if (Image::ExifTool::IsInt($$valPtr)) {
190 # no conversion required (converting to 'int' would remove leading '+')
191 } elsif (Image::ExifTool::IsHex($$valPtr)) {
192 $$valPtr = hex($$valPtr);
193 } else {
194 return 'Not an integer';
195 }
196 } elsif ($format eq 'date') {
197 my $newDate = FormatXMPDate($$valPtr);
198 return "Invalid date/time (use YYYY:mm:dd HH:MM:SS[.ss][+/-HH:MM|Z])" unless $newDate;
199 $$valPtr = $newDate;
200 } elsif ($format eq 'boolean') {
201 if (not $$valPtr or $$valPtr =~ /false/i or $$valPtr =~ /^no$/i) {
202 $$valPtr = 'False';
203 } else {
204 $$valPtr = 'True';
205 }
206 } elsif ($format eq '1') {
207 # this is the entire XMP data block
208 return 'Invalid XMP data' unless ValidateXMP($valPtr);
209 } else {
210 return "Unknown XMP format: $format";
211 }
212 return undef; # success!
213}
214
215#------------------------------------------------------------------------------
216# Get PropertyPath for specified tagInfo
217# Inputs: 0) tagInfo reference
218# Returns: PropertyPath string
219sub GetPropertyPath($)
220{
221 my $tagInfo = shift;
222 SetPropertyPath($$tagInfo{Table}, $$tagInfo{TagID}) unless $$tagInfo{PropertyPath};
223 return $$tagInfo{PropertyPath};
224}
225
226#------------------------------------------------------------------------------
227# Set PropertyPath for specified tag (also for associated flattened tags and structure elements)
228# Inputs: 0) tagTable reference, 1) tagID, 2) tagID of parent structure,
229# 3) structure definition ref (or undef), 4) property list up to this point (or undef),
230# 5) flag set if any containing structure has a TYPE
231# Notes: also generates flattened tags if they don't already exist
232sub SetPropertyPath($$;$$$$)
233{
234 my ($tagTablePtr, $tagID, $parentID, $structPtr, $propList, $isType) = @_;
235 my $table = $structPtr || $tagTablePtr;
236 my $tagInfo = $$table{$tagID};
237
238 return if ref($tagInfo) ne 'HASH' or $$tagInfo{PropertyPath};
239
240 # don't override existing main table entry if already set by a Struct
241 if ($structPtr) {
242 $isType = 1 if $$structPtr{TYPE};
243 } else {
244 # use property path from original tagInfo if this is an alternate-language tag
245 my $srcInfo = $$tagInfo{SrcTagInfo};
246 $$tagInfo{PropertyPath} = GetPropertyPath($srcInfo) if $srcInfo;
247 return if $$tagInfo{PropertyPath};
248 # set property path for all flattened tags in structure if necessary
249 if ($$tagInfo{RootTagInfo}) {
250 SetPropertyPath($tagTablePtr, $$tagInfo{RootTagInfo}{TagID});
251 return if $$tagInfo{PropertyPath};
252 warn "Internal Error: Didn't set path from root for $tagID\n";
253 }
254 }
255 my $ns = $$tagInfo{Namespace} || $$table{NAMESPACE};
256 $ns or warn("No namespace for $tagID\n"), return;
257 my (@propList, $listType);
258 $propList and @propList = @$propList;
259 push @propList, "$ns:$tagID";
260 # lang-alt lists are handled specially, signified by Writable='lang-alt'
261 if ($$tagInfo{Writable} and $$tagInfo{Writable} eq 'lang-alt') {
262 $listType = 'Alt';
263 # remove language code from property path if it exists
264 $propList[-1] =~ s/-$$tagInfo{LangCode}$// if $$tagInfo{LangCode};
265 # handle lists of lang-alt lists (ie. XMP-plus:Custom tags)
266 if ($$tagInfo{List} and $$tagInfo{List} ne '1') {
267 push @propList, "rdf:$$tagInfo{List}", 'rdf:li 10';
268 }
269 } else {
270 $listType = $$tagInfo{List};
271 }
272 # add required properties if this is a list
273 push @propList, "rdf:$listType", 'rdf:li 10' if $listType and $listType ne '1';
274 # set PropertyPath for all flattened tags of this structure if necessary
275 # (note: don't do this for variable-namespace structures (undef NAMESPACE))
276 my $strTable = $$tagInfo{Struct};
277 if ($strTable and $$strTable{NAMESPACE}) {
278 # make sure the structure namespace has been registered
279 # (user-defined namespaces may not have been)
280 RegisterNamespace($strTable) if ref $$strTable{NAMESPACE};
281 my $tag;
282 foreach $tag (keys %$strTable) {
283 # ignore special fields and any lang-alt fields we may have added
284 next if $specialStruct{$tag} or $$strTable{$tag}{LangCode};
285 my $fullID = $parentID ? $parentID . ucfirst($tagID) : $tagID;
286 SetPropertyPath($tagTablePtr, $tag, $fullID, $strTable, \@propList, $isType);
287 }
288 }
289 # if this was a structure field and not a normal tag,
290 # we set PropertyPath in the corresponding flattened tag
291 if ($structPtr) {
292 my $flatID = $parentID . ucfirst($tagID);
293 $tagInfo = $$tagTablePtr{$flatID};
294 # create flattened tag now if necessary
295 # (could happen if we were just writing a structure)
296 unless ($tagInfo) {
297 $tagInfo = { Name => ucfirst($flatID), Flat => 1 };
298 Image::ExifTool::AddTagToTable($tagTablePtr, $flatID, $tagInfo);
299 }
300 # set StructType flag if any containing structure has a TYPE
301 $$tagInfo{StructType} = 1 if $isType;
302 }
303 # set property path for tagInfo in main table
304 $$tagInfo{PropertyPath} = join '/', @propList;
305}
306
307#------------------------------------------------------------------------------
308# Save XMP property name/value for rewriting
309# Inputs: 0) ExifTool object reference
310# 1) reference to array of XMP property path (last is current property)
311# 2) property value, 3) optional reference to hash of property attributes
312sub CaptureXMP($$$;$)
313{
314 my ($exifTool, $propList, $val, $attrs) = @_;
315 return unless defined $val and @$propList > 2;
316 if ($$propList[0] =~ /^x:x[ma]pmeta$/ and
317 $$propList[1] eq 'rdf:RDF' and
318 $$propList[2] =~ /$rdfDesc( |$)/)
319 {
320 # no properties to save yet if this is just the description
321 return unless @$propList > 3;
322 # ignore empty list properties
323 if ($$propList[-1] =~ /^rdf:(Bag|Seq|Alt)$/) {
324 $exifTool->Warn("Ignored empty $$propList[-1] list for $$propList[-2]", 1);
325 return;
326 }
327 # save information about this property
328 my $capture = $exifTool->{XMP_CAPTURE};
329 my $path = join('/', @$propList[3..$#$propList]);
330 if (defined $$capture{$path}) {
331 $exifTool->{XMP_ERROR} = "Duplicate XMP property: $path";
332 } else {
333 $$capture{$path} = [$val, $attrs || { }];
334 }
335 } elsif ($$propList[0] eq 'rdf:RDF' and
336 $$propList[1] =~ /$rdfDesc( |$)/)
337 {
338 # set flag so we don't write x:xmpmeta element
339 $exifTool->{XMP_NO_XMPMETA} = 1;
340 # add missing x:xmpmeta element and try again
341 unshift @$propList, 'x:xmpmeta';
342 CaptureXMP($exifTool, $propList, $val, $attrs);
343 } else {
344 $exifTool->{XMP_ERROR} = 'Improperly enclosed XMP property: ' . join('/',@$propList);
345 }
346}
347
348#------------------------------------------------------------------------------
349# Save information about resource containing blank node with nodeID
350# Inputs: 0) reference to blank node information hash
351# 1) reference to property list
352# 2) property value
353# 3) [optional] reference to attribute hash
354# Notes: This routine and ProcessBlankInfo() are also used for reading information, but
355# are uncommon so are put in this file to reduce compile time for the common case
356sub SaveBlankInfo($$$;$)
357{
358 my ($blankInfo, $propListPt, $val, $attrs) = @_;
359
360 my $propPath = join '/', @$propListPt;
361 my @ids = ($propPath =~ m{ #([^ /]*)}g);
362 my $id;
363 # split the property path at each nodeID
364 foreach $id (@ids) {
365 my ($pre, $prop, $post) = ($propPath =~ m{^(.*?)/([^/]*) #$id((/.*)?)$});
366 defined $pre or warn("internal error parsing nodeID's"), next;
367 # the element with the nodeID should be in the path prefix for subject
368 # nodes and the path suffix for object nodes
369 unless ($prop eq $rdfDesc) {
370 if ($post) {
371 $post = "/$prop$post";
372 } else {
373 $pre = "$pre/$prop";
374 }
375 }
376 $blankInfo->{Prop}->{$id}->{Pre}->{$pre} = 1;
377 if ((defined $post and length $post) or (defined $val and length $val)) {
378 # save the property value and attributes for each unique path suffix
379 $blankInfo->{Prop}->{$id}->{Post}->{$post} = [ $val, $attrs, $propPath ];
380 }
381 }
382}
383
384#------------------------------------------------------------------------------
385# Process blank-node information
386# Inputs: 0) ExifTool object ref, 1) tag table ref,
387# 2) blank node information hash ref, 3) flag set for writing
388sub ProcessBlankInfo($$$;$)
389{
390 my ($exifTool, $tagTablePtr, $blankInfo, $isWriting) = @_;
391 $exifTool->VPrint(1, " [Elements with nodeID set:]\n") unless $isWriting;
392 my ($id, $pre, $post);
393 # handle each nodeID separately
394 foreach $id (sort keys %{$$blankInfo{Prop}}) {
395 my $path = $blankInfo->{Prop}->{$id};
396 # flag all resource names so we can warn later if some are unused
397 my %unused;
398 foreach $post (keys %{$path->{Post}}) {
399 $unused{$post} = 1;
400 }
401 # combine property paths for all possible paths through this node
402 foreach $pre (sort keys %{$path->{Pre}}) {
403 # there will be no description for the object of a blank node
404 next unless $pre =~ m{/$rdfDesc/};
405 foreach $post (sort keys %{$path->{Post}}) {
406 my @propList = split m{/}, "$pre$post";
407 my ($val, $attrs) = @{$path->{Post}->{$post}};
408 if ($isWriting) {
409 CaptureXMP($exifTool, \@propList, $val, $attrs);
410 } else {
411 FoundXMP($exifTool, $tagTablePtr, \@propList, $val);
412 }
413 delete $unused{$post};
414 }
415 }
416 # save information from unused properties (if RDF is malformed like f-spot output)
417 if (%unused) {
418 $exifTool->Options('Verbose') and $exifTool->Warn('An XMP resource is about nothing');
419 foreach $post (sort keys %unused) {
420 my ($val, $attrs, $propPath) = @{$path->{Post}->{$post}};
421 my @propList = split m{/}, $propPath;
422 if ($isWriting) {
423 CaptureXMP($exifTool, \@propList, $val, $attrs);
424 } else {
425 FoundXMP($exifTool, $tagTablePtr, \@propList, $val);
426 }
427 }
428 }
429 }
430}
431
432#------------------------------------------------------------------------------
433# Convert path to namespace used in file (this is a pain, but the XMP
434# spec only suggests 'preferred' namespace prefixes...)
435# Inputs: 0) ExifTool object reference, 1) property path
436# Returns: conforming property path
437sub ConformPathToNamespace($$)
438{
439 my ($exifTool, $path) = @_;
440 my @propList = split('/',$path);
441 my $nsUsed = $exifTool->{XMP_NS};
442 my $prop;
443 foreach $prop (@propList) {
444 my ($ns, $tag) = $prop =~ /(.+?):(.*)/;
445 next if $$nsUsed{$ns};
446 my $uri = $nsURI{$ns};
447 unless ($uri) {
448 warn "No URI for namepace prefix $ns!\n";
449 next;
450 }
451 my $ns2;
452 foreach $ns2 (keys %$nsUsed) {
453 next unless $$nsUsed{$ns2} eq $uri;
454 # use the existing namespace prefix instead of ours
455 $prop = "$ns2:$tag";
456 last;
457 }
458 }
459 return join('/',@propList);
460}
461
462#------------------------------------------------------------------------------
463# Add necessary rdf:type element when writing structure
464# Inputs: 0) ExifTool ref, 1) tag table ref, 2) capture hash ref, 3) path string
465# 4) optional base path (already conformed to namespace) for elements in
466# variable-namespace structures
467sub AddStructType($$$$;$)
468{
469 my ($exifTool, $tagTablePtr, $capture, $path, $basePath) = @_;
470 my @props = split '/', $path;
471 my %doneID;
472 for (;;) {
473 pop @props;
474 last unless @props;
475 my $tagID = GetXMPTagID(\@props);
476 next if $doneID{$tagID};
477 $doneID{$tagID} = 1;
478 my $tagInfo = $$tagTablePtr{$tagID};
479 last unless ref $tagInfo eq 'HASH';
480 if ($$tagInfo{Struct}) {
481 my $type = $$tagInfo{Struct}{TYPE};
482 if ($type) {
483 my $pat = $$tagInfo{PropertyPath};
484 $pat or warn("Missing PropertyPath in AddStructType\n"), last;
485 $pat = ConformPathToNamespace($exifTool, $pat);
486 $pat =~ s/ \d+/ \\d\+/g;
487 $path =~ /^($pat)/ or warn("Wrong path in AddStructType\n"), last;
488 my $p = $1 . '/rdf:type';
489 $p = "$basePath/$p" if $basePath;
490 $$capture{$p} = [ '', { 'rdf:resource' => $type } ] unless $$capture{$p};
491 }
492 }
493 last unless $$tagInfo{StructType};
494 }
495}
496
497#------------------------------------------------------------------------------
498# Utility routine to encode data in base64
499# Inputs: 0) binary data string
500# Returns: base64-encoded string
501sub EncodeBase64($)
502{
503 # encode the data in 45-byte chunks
504 my $chunkSize = 45;
505 my $len = length $_[0];
506 my $str = '';
507 my $i;
508 for ($i=0; $i<$len; $i+=$chunkSize) {
509 my $n = $len - $i;
510 $n = $chunkSize if $n > $chunkSize;
511 # add uuencoded data to output (minus size byte, but including trailing newline)
512 $str .= substr(pack('u', substr($_[0], $i, $n)), 1);
513 }
514 # convert to base64 (remember that "\0" may be encoded as ' ' or '`')
515 $str =~ tr/` -_/AA-Za-z0-9+\//;
516 # convert pad characters at the end (remember to account for trailing newline)
517 my $pad = 3 - ($len % 3);
518 substr($str, -$pad-1, $pad) = ('=' x $pad) if $pad < 3;
519 return $str;
520}
521
522#------------------------------------------------------------------------------
523# sort tagInfo hash references by tag name
524sub ByTagName
525{
526 return $$a{Name} cmp $$b{Name};
527}
528
529#------------------------------------------------------------------------------
530# sort alphabetically, but with rdf:type first in the structure
531sub TypeFirst
532{
533 if ($a =~ /rdf:type$/) {
534 return substr($a, 0, -8) cmp $b unless $b =~ /rdf:type$/;
535 } elsif ($b =~ /rdf:type$/) {
536 return $a cmp substr($b, 0, -8);
537 }
538 return $a cmp $b;
539}
540
541#------------------------------------------------------------------------------
542# Limit size of XMP
543# Inputs: 0) ExifTool object ref, 1) XMP data ref (written up to start of $rdfClose),
544# 2) max XMP len, 3) rdf:about string, 4) list ref for description start offsets
545# 5) start offset of first description recommended for extended XMP
546# Returns: 0) extended XMP ref, 1) GUID and updates $$dataPt (or undef if no extended XMP)
547sub LimitXMPSize($$$$$$)
548{
549 my ($exifTool, $dataPt, $maxLen, $about, $startPt, $extStart) = @_;
550
551 # return straight away if it isn't too big
552 return undef if length($$dataPt) < $maxLen;
553
554 push @$startPt, length($$dataPt); # add end offset to list
555 my $newData = substr($$dataPt, 0, $$startPt[0]);
556 my $guid = '0' x 32;
557 # write the required xmpNote:HasExtendedXMP property
558 $newData .= "\n <$rdfDesc rdf:about='$about'\n xmlns:xmpNote='$nsURI{xmpNote}'>\n" .
559 " <xmpNote:HasExtendedXMP>$guid</xmpNote:HasExtendedXMP>\n" .
560 " </$rdfDesc>\n";
561
562 my ($i, %descSize, $start);
563 # calculate all description block sizes
564 for ($i=1; $i<@$startPt; ++$i) {
565 $descSize{$$startPt[$i-1]} = $$startPt[$i] - $$startPt[$i-1];
566 }
567 pop @$startPt; # remove end offset
568 # write the descriptions from smallest to largest, as many in main XMP as possible
569 my @descStart = sort { $descSize{$a} <=> $descSize{$b} } @$startPt;
570 my $extData = XMPOpen($exifTool) . $rdfOpen;
571 for ($i=0; $i<2; ++$i) {
572 foreach $start (@descStart) {
573 # write main XMP first (in order of size), then extended XMP afterwards (in order)
574 next if $i xor $start >= $extStart;
575 my $pt = (length($newData) + $descSize{$start} > $maxLen) ? \$extData : \$newData;
576 $$pt .= substr($$dataPt, $start, $descSize{$start});
577 }
578 }
579 $extData .= $rdfClose . $xmpClose; # close rdf:RDF and x:xmpmeta
580 # calculate GUID from MD5 of extended XMP data
581 if (eval 'require Digest::MD5') {
582 $guid = uc unpack('H*', Digest::MD5::md5($extData));
583 $newData =~ s/0{32}/$guid/; # update GUID in main XMP segment
584 }
585 $exifTool->VerboseValue('+ XMP-xmpNote:HasExtendedXMP', $guid);
586 $$dataPt = $newData; # return main XMP block
587 return (\$extData, $guid); # return extended XMP and its GUID
588}
589
590#------------------------------------------------------------------------------
591# Write XMP information
592# Inputs: 0) ExifTool object reference, 1) source dirInfo reference,
593# 2) [optional] tag table reference
594# Returns: with tag table: new XMP data (may be empty if no XMP data) or undef on error
595# without tag table: 1 on success, 0 if not valid XMP file, -1 on write error
596# Notes: May set dirInfo InPlace flag to rewrite with specified DirLen
597# May set dirInfo ReadOnly flag to write as read-only XMP ('r' mode and no padding)
598# May set dirInfo Compact flag to force compact (drops 2kB of padding)
599# May set dirInfo MaxDataLen to limit output data length -- this causes ExtendedXMP
600# and ExtendedGUID to be returned in dirInfo if extended XMP was required
601sub WriteXMP($$;$)
602{
603 my ($exifTool, $dirInfo, $tagTablePtr) = @_;
604 $exifTool or return 1; # allow dummy access to autoload this package
605 my $dataPt = $$dirInfo{DataPt};
606 my (%capture, %nsUsed, $xmpErr, $tagInfo, $about);
607 my $changed = 0;
608 my $xmpFile = (not $tagTablePtr); # this is an XMP data file if no $tagTablePtr
609 # prefer XMP over other metadata formats in some types of files
610 my $preferred = $xmpFile || ($$exifTool{PreferredGroup} and $$exifTool{PreferredGroup} eq 'XMP');
611 my $verbose = $exifTool->Options('Verbose');
612 my $dirLen = $$dirInfo{DirLen};
613 $dirLen = length($$dataPt) if not defined $dirLen and $dataPt;
614#
615# extract existing XMP information into %capture hash
616#
617 # define hash in ExifTool object to capture XMP information (also causes
618 # CaptureXMP() instead of FoundXMP() to be called from ParseXMPElement())
619 #
620 # The %capture hash is keyed on the complete property path beginning after
621 # rdf:RDF/rdf:Description/. The values are array references with the
622 # following entries: 0) value, 1) attribute hash reference.
623 $exifTool->{XMP_CAPTURE} = \%capture;
624 $exifTool->{XMP_NS} = \%nsUsed;
625 delete $exifTool->{XMP_NO_XMPMETA};
626 delete $exifTool->{XMP_NO_XPACKET};
627 delete $exifTool->{XMP_IS_XML};
628 delete $exifTool->{XMP_IS_SVG};
629
630 if ($xmpFile or $dirLen) {
631 delete $exifTool->{XMP_ERROR};
632 delete $exifTool->{XMP_ABOUT};
633 # extract all existing XMP information (to the XMP_CAPTURE hash)
634 my $success = ProcessXMP($exifTool, $dirInfo, $tagTablePtr);
635 # don't continue if there is nothing to parse or if we had a parsing error
636 unless ($success and not $exifTool->{XMP_ERROR}) {
637 my $err = $exifTool->{XMP_ERROR} || 'Error parsing XMP';
638 # may ignore this error only if we were successful
639 if ($xmpFile) {
640 my $raf = $$dirInfo{RAF};
641 # allow empty XMP data so we can create something from nothing
642 if ($success or not $raf->Seek(0,2) or $raf->Tell()) {
643 # no error message if not an XMP file
644 return 0 unless $exifTool->{XMP_ERROR};
645 if ($exifTool->Error($err, $success)) {
646 delete $exifTool->{XMP_CAPTURE};
647 return 0;
648 }
649 }
650 } else {
651 if ($exifTool->Warn($err, $success)) {
652 delete $exifTool->{XMP_CAPTURE};
653 return undef;
654 }
655 }
656 }
657 $tagInfo = $Image::ExifTool::XMP::rdf{about};
658 if (defined $exifTool->{NEW_VALUE}->{$tagInfo}) {
659 $about = Image::ExifTool::GetNewValues($exifTool->{NEW_VALUE}->{$tagInfo}) || '';
660 if ($verbose > 1) {
661 my $wasAbout = $exifTool->{XMP_ABOUT};
662 $exifTool->VerboseValue('- XMP-rdf:About', UnescapeXML($wasAbout)) if defined $wasAbout;
663 $exifTool->VerboseValue('+ XMP-rdf:About', $about);
664 }
665 $about = EscapeXML($about); # must escape for XML
666 ++$changed;
667 } else {
668 $about = $exifTool->{XMP_ABOUT} || '';
669 }
670 delete $exifTool->{XMP_ERROR};
671 delete $exifTool->{XMP_ABOUT};
672 } else {
673 $about = '';
674 }
675#
676# handle writing XMP as a block to XMP file
677#
678 if ($xmpFile) {
679 $tagInfo = $Image::ExifTool::Extra{XMP};
680 if ($tagInfo and $exifTool->{NEW_VALUE}->{$tagInfo}) {
681 my $rtnVal = 1;
682 my $newVal = Image::ExifTool::GetNewValues($exifTool->{NEW_VALUE}->{$tagInfo});
683 if (defined $newVal and length $newVal) {
684 $exifTool->VPrint(0, " Writing XMP as a block\n");
685 ++$exifTool->{CHANGED};
686 Write($$dirInfo{OutFile}, $newVal) or $rtnVal = -1;
687 }
688 delete $exifTool->{XMP_CAPTURE};
689 return $rtnVal;
690 }
691 }
692#
693# delete groups in family 1 if requested
694#
695 if (%{$exifTool->{DEL_GROUP}} and (grep /^XMP-.+$/, keys %{$exifTool->{DEL_GROUP}} or
696 # (logic is a bit more complex for group names in exiftool XML files)
697 grep m{^http://ns.exiftool.ca/}, values %nsUsed))
698 {
699 my $del = $exifTool->{DEL_GROUP};
700 my $path;
701 foreach $path (keys %capture) {
702 my @propList = split('/',$path); # get property list
703 my ($tag, $ns) = GetXMPTagID(\@propList);
704 # translate namespace if necessary
705 $ns = $$xlatNamespace{$ns} if $$xlatNamespace{$ns};
706 my ($grp, @g);
707 # no "XMP-" added to most groups in exiftool RDF/XML output file
708 if ($nsUsed{$ns} and (@g = ($nsUsed{$ns} =~ m{^http://ns.exiftool.ca/(.*?)/(.*?)/}))) {
709 if ($g[1] =~ /^\d/) {
710 $grp = "XML-$g[0]";
711 #(all XML-* groups stored as uppercase DEL_GROUP key)
712 my $ucg = uc $grp;
713 next unless $$del{$ucg} or ($$del{'XML-*'} and not $$del{"-$ucg"});
714 } else {
715 $grp = $g[1];
716 next unless $$del{$grp} or ($$del{$g[0]} and not $$del{"-$grp"});
717 }
718 } else {
719 $grp = "XMP-$ns";
720 my $ucg = uc $grp;
721 next unless $$del{$ucg} or ($$del{'XMP-*'} and not $$del{"-$ucg"});
722 }
723 $exifTool->VerboseValue("- $grp:$tag", $capture{$path}->[0]);
724 delete $capture{$path};
725 ++$changed;
726 }
727 }
728 # delete HasExtendedXMP tag (we create it as needed)
729 my $hasExtTag = 'xmpNote:HasExtendedXMP';
730 if ($capture{$hasExtTag}) {
731 $exifTool->VerboseValue("- XMP-$hasExtTag", $capture{$hasExtTag}->[0]);
732 delete $capture{$hasExtTag};
733 }
734 # set $xmpOpen now to to handle xmptk tag first
735 my $xmpOpen = $exifTool->{XMP_NO_XMPMETA} ? '' : XMPOpen($exifTool);
736#
737# add, delete or change information as specified
738#
739 # get hash of all information we want to change
740 # (sorted by tag name so alternate languages come last)
741 my @tagInfoList = sort ByTagName $exifTool->GetNewTagInfoList();
742 foreach $tagInfo (@tagInfoList) {
743 next unless $exifTool->GetGroup($tagInfo, 0) eq 'XMP';
744 my $tag = $$tagInfo{TagID};
745 my $path = GetPropertyPath($tagInfo);
746 unless ($path) {
747 $exifTool->Warn("Can't write XMP:$tag (namespace unknown)");
748 next;
749 }
750 # skip tags that were handled specially
751 if ($path eq 'rdf:about' or $path eq 'x:xmptk') {
752 ++$changed;
753 next;
754 }
755 my $isStruct = $$tagInfo{Struct};
756 # change our property path namespace prefixes to conform
757 # to the ones used in this file
758 $path = ConformPathToNamespace($exifTool, $path);
759 # find existing property
760 my $cap = $capture{$path};
761 # MicrosoftPhoto screws up the case of some tags, and some other software,
762 # including Adobe software, has been known to write the wrong list type or
763 # not properly enclose properties in a list, so we check for this
764 # (NOTE: we don't currently do these tests when writing structures!
765 # --> add this to DeleteStruct() below if it turns out to be a problem)
766 unless ($cap or $isStruct) {
767 my $regex = quotemeta $path;
768 # also allow for missing structure fields in lists of structures
769 $regex =~ s/ \d+/ \\d\+/g;
770 my $ok = $regex; # regular expression to match standard property names
771 # also check for incorrect list types which can cause problems
772 if ($regex =~ s{\\/rdf\\:(Bag|Seq|Alt)\\/}{/rdf:(Bag|Seq|Alt)/}g) {
773 # also look for missing bottom-level list
774 $regex =~ s{/rdf:\(Bag\|Seq\|Alt\)\/rdf\\:li\\ \\d\+$}{(/.*)?};
775 }
776 my @matches = sort grep m{^$regex$}i, keys %capture;
777 if (@matches) {
778 if ($matches[0] =~ /^$ok$/) {
779 $path = $matches[0]; # use existing property path
780 $cap = $capture{$path};
781 } else {
782 # property list was wrong, so issue a warning and fix it
783 my ($match, @fixed, %fixed, $err);
784 foreach $match (@matches) {
785 my $fixed = $path;
786 # set list indices
787 while ($match =~ / (\d+)/g) {
788 my $idx = $1;
789 # insert leading "X" so we don't replace this one again
790 $fixed =~ s/ \d+/ X$idx/;
791 }
792 $fixed =~ s/ X/ /g if $fixed ne $path; # remove "X"s
793 $err = 1 if $capture{$fixed} or $fixed{$fixed};
794 push @fixed, $fixed;
795 $fixed{$fixed} = 1;
796 }
797 my $tg = $exifTool->GetGroup($tagInfo, 1) . ':' . $$tagInfo{Name};
798 my $wrn = lc($path) eq lc($matches[0]) ? 'tag ID case' : 'list type';
799 if ($err) {
800 $exifTool->Warn("Incorrect $wrn for $tg conflicts with existing tag");
801 } else {
802 # fix the incorrect property paths for all values of this tag
803 foreach $match (@matches) {
804 my $fixed = shift @fixed;
805 $capture{$fixed} = $capture{$match};
806 delete $capture{$match};
807 }
808 $cap = $capture{$path} || $capture{$fixed[0]};
809 $exifTool->Warn("Fixed incorrect $wrn for $tg", 1);
810 }
811 }
812 }
813 }
814 my $nvHash = $exifTool->GetNewValueHash($tagInfo);
815 my $overwrite = Image::ExifTool::IsOverwriting($nvHash);
816 my $writable = $$tagInfo{Writable} || '';
817 my (%attrs, $deleted, $added);
818 # delete existing entry if necessary
819 if ($isStruct) {
820 require 'Image/ExifTool/XMPStruct.pl';
821 ($deleted, $added) = DeleteStruct($exifTool, \%capture, \$path, $nvHash, \$changed);
822 } elsif ($cap) {
823 # take attributes from old values if they exist
824 %attrs = %{$$cap[1]};
825 if ($overwrite) {
826 my ($delPath, $oldLang, $delLang, $addLang, @matchingPaths);
827 # check to see if this is an indexed list item
828 if ($path =~ / /) {
829 my $pp;
830 ($pp = $path) =~ s/ \d+/ \\d\+/g;
831 @matchingPaths = sort grep(/^$pp$/, keys %capture);
832 } else {
833 push @matchingPaths, $path;
834 }
835 foreach $path (@matchingPaths) {
836 my ($val, $attrs) = @{$capture{$path}};
837 if ($writable eq 'lang-alt') {
838 unless (defined $addLang) {
839 # add to lang-alt list by default if creating this tag from scratch
840 $addLang = Image::ExifTool::IsCreating($nvHash) ? 1 : 0;
841 }
842 # get original language code (lc for comparisons)
843 $oldLang = lc($$attrs{'xml:lang'} || 'x-default');
844 if ($overwrite < 0) {
845 my $newLang = lc($$tagInfo{LangCode} || 'x-default');
846 next unless $oldLang eq $newLang;
847 # only add new tag if we are overwriting this one
848 # (note: this won't match if original XML contains CDATA!)
849 $addLang = Image::ExifTool::IsOverwriting($nvHash, UnescapeXML($val));
850 next unless $addLang;
851 }
852 # delete all if deleting "x-default" and writing with no LangCode
853 # (XMP spec requires x-default language exist and be first in list)
854 if ($oldLang eq 'x-default' and not $$tagInfo{LangCode}) {
855 $delLang = 1; # delete all languages
856 $overwrite = 1; # force overwrite
857 } elsif ($$tagInfo{LangCode} and not $delLang) {
858 # only overwrite specified language
859 next unless lc($$tagInfo{LangCode}) eq $oldLang;
860 }
861 } elsif ($overwrite < 0) {
862 # only overwrite specific values
863 # (note: this won't match if original XML contains CDATA!)
864 next unless Image::ExifTool::IsOverwriting($nvHash, UnescapeXML($val));
865 }
866 if ($verbose > 1) {
867 my $grp = $exifTool->GetGroup($tagInfo, 1);
868 my $tagName = $$tagInfo{Name};
869 $tagName =~ s/-$$tagInfo{LangCode}$// if $$tagInfo{LangCode};
870 $tagName .= '-' . $$attrs{'xml:lang'} if $$attrs{'xml:lang'};
871 $exifTool->VerboseValue("- $grp:$tagName", $val);
872 }
873 # save attributes and path from first deleted property
874 # so we can replace it exactly
875 unless ($delPath) {
876 %attrs = %$attrs;
877 $delPath = $path;
878 }
879 # delete this tag
880 delete $capture{$path};
881 ++$changed;
882 # delete rdf:type tag if it is the only thing left in this structure
883 if ($path =~ /^(.*)\// and $capture{"$1/rdf:type"}) {
884 my $pp = $1;
885 my @a = grep /^\Q$pp\E\/[^\/]+/, keys %capture;
886 delete $capture{"$pp/rdf:type"} if @a == 1;
887 }
888 }
889 next unless $delPath or $$tagInfo{List} or $addLang;
890 if ($delPath) {
891 $path = $delPath;
892 $deleted = 1;
893 } else {
894 # don't change tag if we couldn't delete old copy
895 # unless this is a list or an lang-alt tag
896 next unless $$tagInfo{List} or $oldLang;
897 # (match last index to put in same lang-alt list for Bag of lang-alt items)
898 $path =~ m/.* (\d+)/g or warn "Internal error: no list index!\n", next;
899 $added = $1;
900 }
901 } else {
902 # are never overwriting, so we must be adding to a list
903 # match the last index unless this is a list of lang-alt lists
904 my $pat = $writable eq 'lang-alt' ? '.* (\d+)(.*? \d+)' : '.* (\d+)';
905 if ($path =~ m/$pat/g) {
906 $added = $1;
907 # set position to end of matching index number
908 pos($path) = pos($path) - length($2) if $2;
909 }
910 }
911 if (defined $added) {
912 my $len = length $added;
913 my $pos = pos($path) - $len;
914 my $nxt = substr($added, 1) + 1;
915 # always insert x-default lang-alt entry first (as per XMP spec)
916 # (need to test $overwrite because this will be a new lang-alt entry otherwise)
917 if ($overwrite and $writable eq 'lang-alt' and (not $$tagInfo{LangCode} or
918 $$tagInfo{LangCode} eq 'x-default'))
919 {
920 my $saveCap = $capture{$path};
921 for (;;) {
922 my $p = $path;
923 substr($p, $pos, $len) = length($nxt) . $nxt;
924 # increment index in the path of the existing item
925 my $nextCap = $capture{$p};
926 $capture{$p} = $saveCap;
927 last unless $nextCap;
928 $saveCap = $nextCap;
929 ++$nxt;
930 }
931 } else {
932 # add to end of list
933 for (;;) {
934 my $try = length($nxt) . $nxt;
935 substr($path, $pos, $len) = $try;
936 last unless $capture{$path};
937 $len = length $try;
938 ++$nxt;
939 }
940 }
941 }
942 }
943 # check to see if we want to create this tag
944 # (create non-avoided tags in XMP data files by default)
945 my $isCreating = (Image::ExifTool::IsCreating($nvHash) or $isStruct or
946 ($preferred and not $$tagInfo{Avoid} and
947 not defined $$nvHash{Shift}));
948
949 # don't add new values unless...
950 # ...tag existed before and was deleted, or we added it to a list
951 next unless $deleted or defined $added or
952 # ...tag didn't exist before and we are creating it
953 (not $cap and $isCreating);
954
955 # get list of new values (all done if no new values specified)
956 my @newValues = Image::ExifTool::GetNewValues($nvHash) or next;
957
958 # set language attribute for lang-alt lists
959 $attrs{'xml:lang'} = $$tagInfo{LangCode} || 'x-default' if $writable eq 'lang-alt';
960
961 # add new value(s) to %capture hash
962 my $subIdx;
963 for (;;) {
964 my $newValue = shift @newValues;
965 if ($isStruct) {
966 ++$changed if AddNewStruct($exifTool, $tagInfo, \%capture,
967 $path, $newValue, $$tagInfo{Struct});
968 } else {
969 $newValue = EscapeXML($newValue);
970 if ($$tagInfo{Resource}) {
971 $capture{$path} = [ '', { %attrs, 'rdf:resource' => $newValue } ];
972 } else {
973 $capture{$path} = [ $newValue, \%attrs ];
974 }
975 if ($verbose > 1) {
976 my $grp = $exifTool->GetGroup($tagInfo, 1);
977 $exifTool->VerboseValue("+ $grp:$$tagInfo{Name}", $newValue);
978 }
979 ++$changed;
980 # add rdf:type if necessary
981 if ($$tagInfo{StructType}) {
982 AddStructType($exifTool, $$tagInfo{Table}, \%capture, $path);
983 }
984 }
985 last unless @newValues;
986 # match last index except for lang-alt items where we want to put each
987 # item in a different lang-alt list (so match the 2nd-last for these)
988 my $pat = $writable eq 'lang-alt' ? '.* (\d+)(.*? \d+)' : '.* (\d+)';
989 $path =~ m/$pat/g or warn("Internal error: no list index for $tag!\n"), next;
990 my $idx = $1;
991 my $len = length $1;
992 my $pos = pos($path) - $len - ($2 ? length $2 : 0);
993 # generate unique list sub-indices to store additional values in sequence
994 if ($subIdx) {
995 $idx = substr($idx, 0, -length($subIdx)); # remove old sub-index
996 $subIdx = substr($subIdx, 1) + 1;
997 $subIdx = length($subIdx) . $subIdx;
998 } else {
999 $subIdx = '10';
1000 }
1001 substr($path, $pos, $len) = $idx . $subIdx;
1002 }
1003 }
1004 # remove the ExifTool members we created
1005 delete $exifTool->{XMP_CAPTURE};
1006 delete $exifTool->{XMP_NS};
1007
1008 my $maxDataLen = $$dirInfo{MaxDataLen};
1009 # get DataPt again because it may have been set by ProcessXMP
1010 $dataPt = $$dirInfo{DataPt};
1011 # return now if we didn't change anything
1012 unless ($changed or ($maxDataLen and $dataPt and defined $$dataPt and
1013 length($$dataPt) > $maxDataLen))
1014 {
1015 return undef unless $xmpFile; # just rewrite original XMP
1016 Write($$dirInfo{OutFile}, $$dataPt) or return -1 if $dataPt and defined $$dataPt;
1017 return 1;
1018 }
1019#
1020# write out the new XMP information (serialize it)
1021#
1022 # start writing the XMP data
1023 my $newData = '';
1024 if ($$exifTool{XMP_NO_XPACKET}) {
1025 # write BOM if flag is set
1026 $newData .= "\xef\xbb\xbf" if $$exifTool{XMP_NO_XPACKET} == 2;
1027 } else {
1028 $newData .= $pktOpen;
1029 }
1030 $newData .= $xmlOpen if $$exifTool{XMP_IS_XML};
1031 $newData .= $xmpOpen . $rdfOpen;
1032
1033 # initialize current property path list
1034 my (@curPropList, @writeLast, @descStart, $extStart);
1035 my (%nsCur, $prop, $n, $path);
1036 my @pathList = sort TypeFirst keys %capture;
1037 # order properties to write large values last if we have a MaxDataLen limit
1038 if ($maxDataLen and @pathList) {
1039 my @pathTmp;
1040 my ($lastProp, $lastNS, $propSize) = ('', '', 0);
1041 my @pathLoop = (@pathList, ''); # add empty path to end of list for loop
1042 undef @pathList;
1043 foreach $path (@pathLoop) {
1044 $path =~ /^((\w*)[^\/]*)/; # get path element ($1) and ns ($2)
1045 if ($1 eq $lastProp) {
1046 push @pathTmp, $path; # accumulate all paths with same root
1047 } else {
1048 # put in list to write last if recommended or values are too large
1049 if ($extendedRes{$lastProp} or $extendedRes{$lastNS} or
1050 $propSize > $newDescThresh)
1051 {
1052 push @writeLast, @pathTmp;
1053 } else {
1054 push @pathList, @pathTmp;
1055 }
1056 last unless $path; # all done if we hit empty path
1057 @pathTmp = ( $path );
1058 ($lastProp, $lastNS, $propSize) = ($1, $2, 0);
1059 }
1060 $propSize += length $capture{$path}->[0];
1061 }
1062 }
1063
1064 # write out all properties
1065 for (;;) {
1066 my (%nsNew, $newDesc);
1067 unless (@pathList) {
1068 last unless @writeLast;
1069 @pathList = @writeLast;
1070 undef @writeLast;
1071 $extStart = length $newData;
1072 $newDesc = 1; # start with a new description
1073 }
1074 $path = shift @pathList;
1075 my @propList = split('/',$path); # get property list
1076 # must open/close rdf:Description too
1077 unshift @propList, $rdfDesc;
1078 # make sure we have defined all necessary namespaces
1079 foreach $prop (@propList) {
1080 $prop =~ /(.*):/ or next;
1081 $1 eq 'rdf' and next; # rdf namespace already defined
1082 my $uri = $nsUsed{$1};
1083 unless ($uri) {
1084 $uri = $nsURI{$1}; # we must have added a namespace
1085 $uri or $xmpErr = "Undefined XMP namespace: $1", next;
1086 }
1087 $nsNew{$1} = $uri;
1088 # need a new description if any new namespaces
1089 $newDesc = 1 unless $nsCur{$1};
1090 }
1091 my $closeTo = 0;
1092 if ($newDesc) {
1093 # look forward to see if we will want to also open other namespaces
1094 # at this level (this is necessary to keep lists and structures from
1095 # being broken if a property introduces a new namespace; plus it
1096 # improves formatting)
1097 my ($path2, $ns2);
1098 foreach $path2 (@pathList) {
1099 my @ns2s = ($path2 =~ m{(?:^|/)([^/]+?):}g);
1100 my $opening = 0;
1101 foreach $ns2 (@ns2s) {
1102 next if $ns2 eq 'rdf';
1103 $nsNew{$ns2} and ++$opening, next;
1104 last unless $opening;
1105 # get URI for this existing or new namespace
1106 my $uri = $nsUsed{$ns2} || $nsURI{$ns2} or last;
1107 $nsNew{$ns2} = $uri; # also open this namespace
1108 }
1109 last unless $opening;
1110 }
1111 } else {
1112 # find first property where the current path differs from the new path
1113 for ($closeTo=0; $closeTo<@curPropList; ++$closeTo) {
1114 last unless $closeTo < @propList;
1115 last unless $propList[$closeTo] eq $curPropList[$closeTo];
1116 }
1117 }
1118 # close out properties down to the common base path
1119 while (@curPropList > $closeTo) {
1120 ($prop = pop @curPropList) =~ s/ .*//;
1121 $newData .= (' ' x scalar(@curPropList)) . " </$prop>\n";
1122 }
1123 if ($newDesc) {
1124 # save rdf:Description start positions so we can reorder them if necessary
1125 push @descStart, length($newData) if $maxDataLen;
1126 # open the new description
1127 $prop = $rdfDesc;
1128 %nsCur = %nsNew; # save current namespaces
1129 $newData .= "\n <$prop rdf:about='$about'";
1130 my @ns = sort keys %nsCur;
1131 # generate et:toolkit attribute if this is an exiftool RDF/XML output file
1132 if (@ns and $nsCur{$ns[0]} =~ m{^http://ns.exiftool.ca/}) {
1133 $newData .= "\n xmlns:et='http://ns.exiftool.ca/1.0/'" .
1134 " et:toolkit='Image::ExifTool $Image::ExifTool::VERSION'";
1135 }
1136 foreach (@ns) {
1137 $newData .= "\n xmlns:$_='$nsCur{$_}'";
1138 }
1139 $newData .= ">\n";
1140 push @curPropList, $prop;
1141 }
1142 # loop over all values for this new property
1143 my ($val, $attrs) = @{$capture{$path}};
1144 $debug and print "$path = $val\n";
1145 # open new properties
1146 my $attr;
1147 for ($n=@curPropList; $n<$#propList; ++$n) {
1148 $prop = $propList[$n];
1149 push @curPropList, $prop;
1150 # remove list index if it exists
1151 $prop =~ s/ .*//;
1152 $attr = '';
1153 if ($prop ne $rdfDesc and ($propList[$n+1] !~ /^rdf:/ or
1154 ($propList[$n+1] eq 'rdf:type' and $n+1 == $#propList)))
1155 {
1156 # need parseType='Resource' to avoid new 'rdf:Description'
1157 $attr = " rdf:parseType='Resource'";
1158 }
1159 $newData .= (' ' x scalar(@curPropList)) . "<$prop$attr>\n";
1160 }
1161 my $prop2 = pop @propList; # get new property name
1162 $prop2 =~ s/ .*//; # remove list index if it exists
1163 $newData .= (' ' x scalar(@curPropList)) . " <$prop2";
1164 # write out attributes
1165 foreach $attr (sort keys %$attrs) {
1166 my $attrVal = $$attrs{$attr};
1167 my $quot = ($attrVal =~ /'/) ? '"' : "'";
1168 $newData .= " $attr=$quot$attrVal$quot";
1169 }
1170 $newData .= length $val ? ">$val</$prop2>\n" : "/>\n";
1171 }
1172 # close off any open elements
1173 while ($prop = pop @curPropList) {
1174 $prop =~ s/ .*//; # remove list index if it exists
1175 $newData .= (' ' x scalar(@curPropList)) . " </$prop>\n";
1176 }
1177 # limit XMP length and re-arrange if necessary to fit inside specified size
1178 my $compact = $$dirInfo{Compact} || $exifTool->Options('Compact');
1179 if ($maxDataLen) {
1180 # adjust maxDataLen to allow room for closing elements
1181 $maxDataLen -= length($rdfClose) + length($xmpClose) + length($pktCloseW);
1182 $extStart or $extStart = length $newData;
1183 my @rtn = LimitXMPSize($exifTool, \$newData, $maxDataLen, $about, \@descStart, $extStart);
1184 # return extended XMP information in $dirInfo
1185 $$dirInfo{ExtendedXMP} = $rtn[0];
1186 $$dirInfo{ExtendedGUID} = $rtn[1];
1187 # compact if necessary to fit
1188 $compact = 1 if length($newData) + 101 * $numPadLines > $maxDataLen;
1189 }
1190#
1191# close out the XMP, clean up, and return our data
1192#
1193 $newData .= $rdfClose;
1194 $newData .= $xmpClose unless $exifTool->{XMP_NO_XMPMETA};
1195
1196 # remove the ExifTool members we created
1197 delete $exifTool->{XMP_CAPTURE};
1198 delete $exifTool->{XMP_NS};
1199 delete $exifTool->{XMP_NO_XMPMETA};
1200
1201 # (the XMP standard recommends writing 2k-4k of white space before the
1202 # packet trailer, with a newline every 100 characters)
1203 unless ($$exifTool{XMP_NO_XPACKET}) {
1204 my $pad = (' ' x 100) . "\n";
1205 if ($$dirInfo{InPlace}) {
1206 # pad to specified DirLen
1207 my $len = length($newData) + length($pktCloseW);
1208 if ($len > $dirLen) {
1209 $exifTool->Warn('Not enough room to edit XMP in place');
1210 return undef;
1211 }
1212 my $num = int(($dirLen - $len) / length($pad));
1213 if ($num) {
1214 $newData .= $pad x $num;
1215 $len += length($pad) * $num;
1216 }
1217 $len < $dirLen and $newData .= (' ' x ($dirLen - $len - 1)) . "\n";
1218 } elsif (not $compact and not $xmpFile and not $$dirInfo{ReadOnly}) {
1219 $newData .= $pad x $numPadLines;
1220 }
1221 $newData .= ($$dirInfo{ReadOnly} ? $pktCloseR : $pktCloseW);
1222 }
1223 # return empty data if no properties exist and this is allowed
1224 unless (%capture or $xmpFile or $$dirInfo{InPlace} or $$dirInfo{NoDelete}) {
1225 $newData = '';
1226 }
1227 if ($xmpErr) {
1228 if ($xmpFile) {
1229 $exifTool->Error($xmpErr);
1230 return -1;
1231 }
1232 $exifTool->Warn($xmpErr);
1233 return undef;
1234 }
1235 $exifTool->{CHANGED} += $changed;
1236 $debug > 1 and $newData and print $newData,"\n";
1237 return $newData unless $xmpFile;
1238 Write($$dirInfo{OutFile}, $newData) or return -1;
1239 return 1;
1240}
1241
1242
12431; # end
1244
1245__END__
1246
1247=head1 NAME
1248
1249Image::ExifTool::WriteXMP.pl - Write XMP meta information
1250
1251=head1 SYNOPSIS
1252
1253These routines are autoloaded by Image::ExifTool::XMP.
1254
1255=head1 DESCRIPTION
1256
1257This file contains routines to write XMP metadata.
1258
1259=head1 AUTHOR
1260
1261Copyright 2003-2011, Phil Harvey (phil at owl.phy.queensu.ca)
1262
1263This library is free software; you can redistribute it and/or modify it
1264under the same terms as Perl itself.
1265
1266=head1 SEE ALSO
1267
1268L<Image::ExifTool::XMP(3pm)|Image::ExifTool::XMP>,
1269L<Image::ExifTool(3pm)|Image::ExifTool>
1270
1271=cut
Note: See TracBrowser for help on using the repository browser.