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 %stdXlatNS); 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'?>"; 48my ($sp, $nl); 49 50#------------------------------------------------------------------------------ 51# Get XMP opening tag (and set x:xmptk appropriately) 52# Inputs: 0) ExifTool object ref 53# Returns: x:xmpmeta opening tag 54sub XMPOpen($) 55{ 56 my $et = shift; 57 my $nv = $$et{NEW_VALUE}{$Image::ExifTool::XMP::x{xmptk}}; 58 my $tk; 59 if (defined $nv) { 60 $tk = $et->GetNewValue($nv); 61 $et->VerboseValue(($tk ? '+' : '-') . ' XMP-x:XMPToolkit', $tk); 62 ++$$et{CHANGED}; 63 } else { 64 $tk = "Image::ExifTool $Image::ExifTool::VERSION"; 65 } 66 my $str = $tk ? (" x:xmptk='" . EscapeXML($tk) . "'") : ''; 67 return "$xmpOpenPrefix$str>\n"; 68} 69 70#------------------------------------------------------------------------------ 71# Validate XMP packet and set read or read/write mode 72# Inputs: 0) XMP data reference, 1) 'r' = read only, 'w' or undef = read/write 73# Returns: true if XMP is good (and adds packet header/trailer if necessary) 74sub ValidateXMP($;$) 75{ 76 my ($xmpPt, $mode) = @_; 77 $$xmpPt =~ s/^\s*<!--.*?-->\s*//s; # remove leading comment if it exists 78 unless ($$xmpPt =~ /^\0*<\0*\?\0*x\0*p\0*a\0*c\0*k\0*e\0*t/) { 79 return '' unless $$xmpPt =~ /^<x(mp)?:x[ma]pmeta/; 80 # add required xpacket header/trailer 81 $$xmpPt = $pktOpen . $$xmpPt . $pktCloseW; 82 } 83 $mode = 'w' unless $mode; 84 my $end = substr($$xmpPt, -32, 32); 85 # check for proper xpacket trailer and set r/w mode if necessary 86 return '' unless $end =~ s/(e\0*n\0*d\0*=\0*['"]\0*)([rw])(\0*['"]\0*\?\0*>)/$1$mode$3/; 87 substr($$xmpPt, -32, 32) = $end if $2 ne $mode; 88 return 1; 89} 90 91#------------------------------------------------------------------------------ 92# Validate XMP property 93# Inputs: 0) ExifTool ref, 1) validate hash ref, 2) attribute hash ref 94# - issues warnings if problems detected 95sub ValidateProperty($$;$) 96{ 97 my ($et, $propList, $attr) = @_; 98 99 if ($$et{XmpValidate} and @$propList > 2) { 100 if ($$propList[0] =~ /^x:x[ma]pmeta$/ and 101 $$propList[1] eq 'rdf:RDF' and 102 $$propList[2] =~ /rdf:Description( |$)/) 103 { 104 if (@$propList > 3) { 105 if ($$propList[-1] =~ /^rdf:(Bag|Seq|Alt)$/) { 106 $et->Warn("Ignored empty $$propList[-1] list for $$propList[-2]", 1); 107 } else { 108 if ($$propList[-2] eq 'rdf:Alt' and $attr) { 109 my $lang = $$attr{'xml:lang'}; 110 if ($lang and @$propList >= 5) { 111 my $langPath = join('/', @$propList[3..($#$propList-2)]); 112 my $valLang = $$et{XmpValidateLangAlt} || ($$et{XmpValidateLangAlt} = { }); 113 $$valLang{$langPath} or $$valLang{$langPath} = { }; 114 if ($$valLang{$langPath}{$lang}) { 115 $et->WarnOnce("Duplicate language ($lang) in lang-alt list: $langPath"); 116 } else { 117 $$valLang{$langPath}{$lang} = 1; 118 } 119 } 120 } 121 my $xmpValidate = $$et{XmpValidate}; 122 my $path = join('/', @$propList[3..$#$propList]); 123 if (defined $$xmpValidate{$path}) { 124 $et->Warn("Duplicate XMP property: $path"); 125 } else { 126 $$xmpValidate{$path} = 1; 127 } 128 } 129 } 130 } elsif ($$propList[0] ne 'rdf:RDF' or 131 $$propList[1] !~ /rdf:Description( |$)/) 132 { 133 $et->Warn('Improperly enclosed XMP property: ' . join('/',@$propList)); 134 } 135 } 136} 137 138#------------------------------------------------------------------------------ 139# Check XMP date values for validity and format accordingly 140# Inputs: 1) EXIF-format date string 141# Returns: XMP date/time string (or undef on error) 142sub FormatXMPDate($) 143{ 144 my $val = shift; 145 my ($y, $m, $d, $t, $tz); 146 if ($val =~ /(\d{4}):(\d{2}):(\d{2}) (\d{2}:\d{2}(?::\d{2}(?:\.\d*)?)?)(.*)/) { 147 ($y, $m, $d, $t, $tz) = ($1, $2, $3, $4, $5); 148 $val = "$y-$m-${d}T$t"; 149 } elsif ($val =~ /^\s*\d{4}(:\d{2}){0,2}\s*$/) { 150 # this is just a date (YYYY, YYYY-mm or YYYY-mm-dd) 151 $val =~ tr/:/-/; 152 } elsif ($val =~ /^\s*(\d{2}:\d{2}(?::\d{2}(?:\.\d*)?)?)(.*)\s*$/) { 153 # this is just a time 154 ($t, $tz) = ($1, $2); 155 $val = $t; 156 } else { 157 return undef; 158 } 159 if ($tz) { 160 $tz =~ /^(Z|[+-]\d{2}:\d{2})$/ or return undef; 161 $val .= $tz; 162 } 163 return $val; 164} 165 166#------------------------------------------------------------------------------ 167# Check XMP values for validity and format accordingly 168# Inputs: 0) ExifTool object ref, 1) tagInfo hash ref, 2) raw value ref, 3) conversion type 169# Returns: error string or undef (and may change value) on success 170# Note: copies structured information to avoid conflicts with calling code 171sub CheckXMP($$$;$) 172{ 173 my ($et, $tagInfo, $valPtr, $convType) = @_; 174 175 if ($$tagInfo{Struct}) { 176 require 'Image/ExifTool/XMPStruct.pl'; 177 my ($item, $err, $w, $warn); 178 unless (ref $$valPtr) { 179 ($$valPtr, $warn) = InflateStruct($valPtr); 180 # expect a structure HASH ref or ARRAY of structures 181 unless (ref $$valPtr) { 182 $$valPtr eq '' and $$valPtr = { }, return undef; # allow empty structures 183 return 'Improperly formed structure'; 184 } 185 } 186 if (ref $$valPtr eq 'ARRAY') { 187 return 'Not a list tag' unless $$tagInfo{List}; 188 my @copy = ( @{$$valPtr} ); # copy the list for ExifTool to use 189 $$valPtr = \@copy; # return the copy 190 foreach $item (@copy) { 191 unless (ref $item eq 'HASH') { 192 ($item, $w) = InflateStruct(\$item); # deserialize structure 193 $w and $warn = $w; 194 next if ref $item eq 'HASH'; 195 $err = 'Improperly formed structure'; 196 last; 197 } 198 ($item, $err) = CheckStruct($et, $item, $$tagInfo{Struct}); 199 last if $err; 200 } 201 } else { 202 ($$valPtr, $err) = CheckStruct($et, $$valPtr, $$tagInfo{Struct}); 203 } 204 $warn and $$et{CHECK_WARN} = $warn; 205 return $err; 206 } 207 my $format = $$tagInfo{Writable}; 208 # (if no format specified, value is a simple string) 209 if (not $format or $format eq 'string' or $format eq 'lang-alt') { 210 # convert value to UTF8 if necessary 211 if ($$et{OPTIONS}{Charset} ne 'UTF8') { 212 if ($$valPtr =~ /[\x80-\xff]/) { 213 # convert from Charset to UTF-8 214 $$valPtr = $et->Encode($$valPtr,'UTF8'); 215 } 216 } else { 217 # translate invalid XML characters to "." 218 $$valPtr =~ tr/\0-\x08\x0b\x0c\x0e-\x1f/./; 219 # fix any malformed UTF-8 characters 220 if (FixUTF8($valPtr) and not $$et{WarnBadUTF8}) { 221 $et->Warn('Malformed UTF-8 character(s)'); 222 $$et{WarnBadUTF8} = 1; 223 } 224 } 225 return undef; # success 226 } 227 if ($format eq 'rational' or $format eq 'real') { 228 # make sure the value is a valid floating point number 229 unless (Image::ExifTool::IsFloat($$valPtr) or 230 # allow 'inf' and 'undef' rational values 231 ($format eq 'rational' and ($$valPtr eq 'inf' or 232 $$valPtr eq 'undef' or Image::ExifTool::IsRational($$valPtr)))) 233 { 234 return 'Not a floating point number'; 235 } 236 if ($format eq 'rational') { 237 $$valPtr = join('/', Image::ExifTool::Rationalize($$valPtr)); 238 } 239 } elsif ($format eq 'integer') { 240 # make sure the value is integer 241 if (Image::ExifTool::IsInt($$valPtr)) { 242 # no conversion required (converting to 'int' would remove leading '+') 243 } elsif (Image::ExifTool::IsHex($$valPtr)) { 244 $$valPtr = hex($$valPtr); 245 } else { 246 return 'Not an integer'; 247 } 248 } elsif ($format eq 'date') { 249 my $newDate = FormatXMPDate($$valPtr); 250 return "Invalid date/time (use YYYY:mm:dd HH:MM:SS[.ss][+/-HH:MM|Z])" unless $newDate; 251 $$valPtr = $newDate; 252 } elsif ($format eq 'boolean') { 253 # (allow lower-case 'true' and 'false' if not setting PrintConv value) 254 if (not $$valPtr or $$valPtr =~ /false/i or $$valPtr =~ /^no$/i) { 255 if (not $$valPtr or $$valPtr ne 'false' or not $convType or $convType eq 'PrintConv') { 256 $$valPtr = 'False'; 257 } 258 } elsif ($$valPtr ne 'true' or not $convType or $convType eq 'PrintConv') { 259 $$valPtr = 'True'; 260 } 261 } elsif ($format eq '1') { 262 # this is the entire XMP data block 263 return 'Invalid XMP data' unless ValidateXMP($valPtr); 264 } else { 265 return "Unknown XMP format: $format"; 266 } 267 return undef; # success! 268} 269 270#------------------------------------------------------------------------------ 271# Get PropertyPath for specified tagInfo 272# Inputs: 0) tagInfo reference 273# Returns: PropertyPath string 274sub GetPropertyPath($) 275{ 276 my $tagInfo = shift; 277 SetPropertyPath($$tagInfo{Table}, $$tagInfo{TagID}) unless $$tagInfo{PropertyPath}; 278 return $$tagInfo{PropertyPath}; 279} 280 281#------------------------------------------------------------------------------ 282# Set PropertyPath for specified tag (also for associated flattened tags and structure elements) 283# Inputs: 0) tagTable reference, 1) tagID, 2) tagID of parent structure, 284# 3) structure definition ref (or undef), 4) property list up to this point (or undef), 285# 5) flag set if any containing structure has a TYPE 286# Notes: also generates flattened tags if they don't already exist 287sub SetPropertyPath($$;$$$$) 288{ 289 my ($tagTablePtr, $tagID, $parentID, $structPtr, $propList, $isType) = @_; 290 my $table = $structPtr || $tagTablePtr; 291 my $tagInfo = $$table{$tagID}; 292 my $flatInfo; 293 294 return if ref($tagInfo) ne 'HASH'; # (shouldn't happen) 295 296 if ($structPtr) { 297 my $flatID = $parentID . ucfirst($tagID); 298 $flatInfo = $$tagTablePtr{$flatID}; 299 if ($flatInfo) { 300 return if $$flatInfo{PropertyPath}; 301 } else { 302 # flattened tag doesn't exist, so create it now 303 # (could happen if we were just writing a structure) 304 $flatInfo = { Name => ucfirst($flatID), Flat => 1 }; 305 AddTagToTable($tagTablePtr, $flatID, $flatInfo); 306 } 307 $isType = 1 if $$structPtr{TYPE}; 308 } else { 309 # don't override existing main table entry if already set by a Struct 310 return if $$tagInfo{PropertyPath}; 311 # use property path from original tagInfo if this is an alternate-language tag 312 my $srcInfo = $$tagInfo{SrcTagInfo}; 313 $$tagInfo{PropertyPath} = GetPropertyPath($srcInfo) if $srcInfo; 314 return if $$tagInfo{PropertyPath}; 315 # set property path for all flattened tags in structure if necessary 316 if ($$tagInfo{RootTagInfo}) { 317 SetPropertyPath($tagTablePtr, $$tagInfo{RootTagInfo}{TagID}); 318 return if $$tagInfo{PropertyPath}; 319 warn "Internal Error: Didn't set path from root for $tagID\n"; 320 warn "(Is the Struct NAMESPACE defined?)\n"; 321 } 322 } 323 my $ns = $$tagInfo{Namespace} || $$table{NAMESPACE}; 324 $ns or warn("No namespace for $tagID\n"), return; 325 my (@propList, $listType); 326 $propList and @propList = @$propList; 327 push @propList, "$ns:$tagID"; 328 # lang-alt lists are handled specially, signified by Writable='lang-alt' 329 if ($$tagInfo{Writable} and $$tagInfo{Writable} eq 'lang-alt') { 330 $listType = 'Alt'; 331 # remove language code from property path if it exists 332 $propList[-1] =~ s/-$$tagInfo{LangCode}$// if $$tagInfo{LangCode}; 333 # handle lists of lang-alt lists (eg. XMP-plus:Custom tags) 334 if ($$tagInfo{List} and $$tagInfo{List} ne '1') { 335 push @propList, "rdf:$$tagInfo{List}", 'rdf:li 10'; 336 } 337 } else { 338 $listType = $$tagInfo{List}; 339 } 340 # add required properties if this is a list 341 push @propList, "rdf:$listType", 'rdf:li 10' if $listType and $listType ne '1'; 342 # set PropertyPath for all flattened tags of this structure if necessary 343 my $strTable = $$tagInfo{Struct}; 344 if ($strTable and not ($parentID and 345 # must test NoSubStruct flag to avoid infinite recursion 346 (($$tagTablePtr{$parentID} and $$tagTablePtr{$parentID}{NoSubStruct}) or 347 length $parentID > 500))) # avoid deep recursion 348 { 349 # make sure the structure namespace has been registered 350 # (user-defined namespaces may not have been) 351 RegisterNamespace($strTable) if ref $$strTable{NAMESPACE}; 352 my $tag; 353 foreach $tag (keys %$strTable) { 354 # ignore special fields and any lang-alt fields we may have added 355 next if $specialStruct{$tag} or $$strTable{$tag}{LangCode}; 356 my $fullID = $parentID ? $parentID . ucfirst($tagID) : $tagID; 357 SetPropertyPath($tagTablePtr, $tag, $fullID, $strTable, \@propList, $isType); 358 } 359 } 360 # if this was a structure field and not a normal tag, 361 # we set PropertyPath in the corresponding flattened tag 362 if ($structPtr) { 363 $tagInfo = $flatInfo; 364 # set StructType flag if any containing structure has a TYPE 365 $$tagInfo{StructType} = 1 if $isType; 366 } 367 # set property path for tagInfo in main table 368 $$tagInfo{PropertyPath} = join '/', @propList; 369} 370 371#------------------------------------------------------------------------------ 372# Save XMP property name/value for rewriting 373# Inputs: 0) ExifTool object reference 374# 1) reference to array of XMP property path (last is current property) 375# 2) property value, 3) optional reference to hash of property attributes 376sub CaptureXMP($$$;$) 377{ 378 my ($et, $propList, $val, $attrs) = @_; 379 return unless defined $val and @$propList > 2; 380 if ($$propList[0] =~ /^x:x[ma]pmeta$/ and 381 $$propList[1] eq 'rdf:RDF' and 382 $$propList[2] =~ /$rdfDesc( |$)/) 383 { 384 # no properties to save yet if this is just the description 385 return unless @$propList > 3; 386 # ignore empty list properties 387 if ($$propList[-1] =~ /^rdf:(Bag|Seq|Alt)$/) { 388 $et->Warn("Ignored empty $$propList[-1] list for $$propList[-2]", 1); 389 return; 390 } 391 # save information about this property 392 my $capture = $$et{XMP_CAPTURE}; 393 my $path = join('/', @$propList[3..$#$propList]); 394 if (defined $$capture{$path}) { 395 $$et{XMP_ERROR} = "Duplicate XMP property: $path"; 396 } else { 397 $$capture{$path} = [$val, $attrs || { }]; 398 } 399 } elsif ($$propList[0] eq 'rdf:RDF' and 400 $$propList[1] =~ /$rdfDesc( |$)/) 401 { 402 # set flag so we don't write x:xmpmeta element 403 $$et{XMP_NO_XMPMETA} = 1; 404 # add missing x:xmpmeta element and try again 405 unshift @$propList, 'x:xmpmeta'; 406 CaptureXMP($et, $propList, $val, $attrs); 407 } else { 408 $$et{XMP_ERROR} = 'Improperly enclosed XMP property: ' . join('/',@$propList); 409 } 410} 411 412#------------------------------------------------------------------------------ 413# Save information about resource containing blank node with nodeID 414# Inputs: 0) reference to blank node information hash 415# 1) reference to property list 416# 2) property value 417# 3) [optional] reference to attribute hash 418# Notes: This routine and ProcessBlankInfo() are also used for reading information, but 419# are uncommon so are put in this file to reduce compile time for the common case 420sub SaveBlankInfo($$$;$) 421{ 422 my ($blankInfo, $propListPt, $val, $attrs) = @_; 423 424 my $propPath = join '/', @$propListPt; 425 my @ids = ($propPath =~ m{ #([^ /]*)}g); 426 my $id; 427 # split the property path at each nodeID 428 foreach $id (@ids) { 429 my ($pre, $prop, $post) = ($propPath =~ m{^(.*?)/([^/]*) #$id((/.*)?)$}); 430 defined $pre or warn("internal error parsing nodeID's"), next; 431 # the element with the nodeID should be in the path prefix for subject 432 # nodes and the path suffix for object nodes 433 unless ($prop eq $rdfDesc) { 434 if ($post) { 435 $post = "/$prop$post"; 436 } else { 437 $pre = "$pre/$prop"; 438 } 439 } 440 $$blankInfo{Prop}{$id}{Pre}{$pre} = 1; 441 if ((defined $post and length $post) or (defined $val and length $val)) { 442 # save the property value and attributes for each unique path suffix 443 $$blankInfo{Prop}{$id}{Post}{$post} = [ $val, $attrs, $propPath ]; 444 } 445 } 446} 447 448#------------------------------------------------------------------------------ 449# Process blank-node information 450# Inputs: 0) ExifTool object ref, 1) tag table ref, 451# 2) blank node information hash ref, 3) flag set for writing 452sub ProcessBlankInfo($$$;$) 453{ 454 my ($et, $tagTablePtr, $blankInfo, $isWriting) = @_; 455 $et->VPrint(1, " [Elements with nodeID set:]\n") unless $isWriting; 456 my ($id, $pre, $post); 457 # handle each nodeID separately 458 foreach $id (sort keys %{$$blankInfo{Prop}}) { 459 my $path = $$blankInfo{Prop}{$id}; 460 # flag all resource names so we can warn later if some are unused 461 my %unused; 462 foreach $post (keys %{$$path{Post}}) { 463 $unused{$post} = 1; 464 } 465 # combine property paths for all possible paths through this node 466 foreach $pre (sort keys %{$$path{Pre}}) { 467 # there will be no description for the object of a blank node 468 next unless $pre =~ m{/$rdfDesc/}; 469 foreach $post (sort keys %{$$path{Post}}) { 470 my @propList = split m{/}, "$pre$post"; 471 my ($val, $attrs) = @{$$path{Post}{$post}}; 472 if ($isWriting) { 473 CaptureXMP($et, \@propList, $val, $attrs); 474 } else { 475 FoundXMP($et, $tagTablePtr, \@propList, $val); 476 } 477 delete $unused{$post}; 478 } 479 } 480 # save information from unused properties (if RDF is malformed like f-spot output) 481 if (%unused) { 482 $et->Options('Verbose') and $et->Warn('An XMP resource is about nothing'); 483 foreach $post (sort keys %unused) { 484 my ($val, $attrs, $propPath) = @{$$path{Post}{$post}}; 485 my @propList = split m{/}, $propPath; 486 if ($isWriting) { 487 CaptureXMP($et, \@propList, $val, $attrs); 488 } else { 489 FoundXMP($et, $tagTablePtr, \@propList, $val); 490 } 491 } 492 } 493 } 494} 495 496#------------------------------------------------------------------------------ 497# Convert path to namespace used in file (this is a pain, but the XMP 498# spec only suggests 'preferred' namespace prefixes...) 499# Inputs: 0) ExifTool object reference, 1) property path 500# Returns: conforming property path 501sub ConformPathToNamespace($$) 502{ 503 my ($et, $path) = @_; 504 my @propList = split('/',$path); 505 my $nsUsed = $$et{XMP_NS}; 506 my $prop; 507 foreach $prop (@propList) { 508 my ($ns, $tag) = $prop =~ /(.+?):(.*)/; 509 next if not defined $ns or $$nsUsed{$ns}; 510 my $uri = $nsURI{$ns}; 511 unless ($uri) { 512 warn "No URI for namespace prefix $ns!\n"; 513 next; 514 } 515 my $ns2; 516 foreach $ns2 (keys %$nsUsed) { 517 next unless $$nsUsed{$ns2} eq $uri; 518 # use the existing namespace prefix instead of ours 519 $prop = "$ns2:$tag"; 520 last; 521 } 522 } 523 return join('/',@propList); 524} 525 526#------------------------------------------------------------------------------ 527# Add necessary rdf:type element when writing structure 528# Inputs: 0) ExifTool ref, 1) tag table ref, 2) capture hash ref, 3) path string 529# 4) optional base path (already conformed to namespace) for elements in 530# variable-namespace structures 531sub AddStructType($$$$;$) 532{ 533 my ($et, $tagTablePtr, $capture, $path, $basePath) = @_; 534 my @props = split '/', $path; 535 my %doneID; 536 for (;;) { 537 pop @props; 538 last unless @props; 539 my $tagID = GetXMPTagID(\@props); 540 next if $doneID{$tagID}; 541 $doneID{$tagID} = 1; 542 my $tagInfo = $$tagTablePtr{$tagID}; 543 last unless ref $tagInfo eq 'HASH'; 544 if ($$tagInfo{Struct}) { 545 my $type = $$tagInfo{Struct}{TYPE}; 546 if ($type) { 547 my $pat = $$tagInfo{PropertyPath}; 548 $pat or warn("Missing PropertyPath in AddStructType\n"), last; 549 $pat = ConformPathToNamespace($et, $pat); 550 $pat =~ s/ \d+/ \\d\+/g; 551 $path =~ /^($pat)/ or warn("Wrong path in AddStructType\n"), last; 552 my $p = $1 . '/rdf:type'; 553 $p = "$basePath/$p" if $basePath; 554 $$capture{$p} = [ '', { 'rdf:resource' => $type } ] unless $$capture{$p}; 555 } 556 } 557 last unless $$tagInfo{StructType}; 558 } 559} 560 561#------------------------------------------------------------------------------ 562# Hack to use XMP writer for SphericalVideoXML 563# Inputs: 0) ExifTool ref, 1) dirInfo ref, 2) tag table ref 564# Returns: SphericalVideoXML data 565sub WriteGSpherical($$$) 566{ 567 my ($et, $dirInfo, $tagTablePtr) = @_; 568 $$dirInfo{Compact} = 1, 569 my $dataPt = $$dirInfo{DataPt}; 570 if ($dataPt and $$dataPt) { 571 # make it look like XMP for writing 572 my $buff = $$dataPt; 573 $buff =~ s/<rdf:SphericalVideo/<?xpacket begin='.*?' id='W5M0MpCehiHzreSzNTczkc9d'?>\n<x:xmpmeta xmlns:x='adobe:ns:meta\/'><rdf:RDF/; 574 $buff =~ s/\s*xmlns:GSpherical/>\n<rdf:Description xmlns:GSpherical/s; 575 $buff =~ s/<\/rdf:SphericalVideo>/<\/rdf:Description>/; 576 $buff .= "</rdf:RDF></x:xmpmeta><?xpacket end='w'?>"; 577 $$dirInfo{DataPt} = \$buff; 578 $$dirInfo{DirLen} = length($buff) - ($$dirInfo{DirStart} || 0); 579 } 580 my $xmp = Image::ExifTool::XMP::WriteXMP($et, $dirInfo, $tagTablePtr); 581 if ($xmp) { 582 # change back to rdf:SphericalVideo structure 583 $xmp =~ s/^<\?xpacket begin.*?<rdf:RDF/<rdf:SphericalVideo\n/s; 584 $xmp =~ s/>\s*<rdf:Description rdf:about=''\s*/\n /; 585 $xmp =~ s/\s*<\/rdf:Description>\s*(<\/rdf:RDF>)/\n<\/rdf:SphericalVideo>$1/s; 586 $xmp =~ s/\s*<\/rdf:RDF>\s*<\/x:xmpmeta>.*//s; 587 } 588 return $xmp; 589} 590 591#------------------------------------------------------------------------------ 592# Utility routine to encode data in base64 593# Inputs: 0) binary data string, 1) flag to avoid inserting newlines 594# Returns: base64-encoded string 595sub EncodeBase64($;$) 596{ 597 # encode the data in 45-byte chunks 598 my $chunkSize = 45; 599 my $len = length $_[0]; 600 my $str = ''; 601 my $i; 602 for ($i=0; $i<$len; $i+=$chunkSize) { 603 my $n = $len - $i; 604 $n = $chunkSize if $n > $chunkSize; 605 # add uuencoded data to output (minus size byte, but including trailing newline) 606 $str .= substr(pack('u', substr($_[0], $i, $n)), 1); 607 } 608 # convert to base64 (remember that "\0" may be encoded as ' ' or '`') 609 $str =~ tr/` -_/AA-Za-z0-9+\//; 610 # convert pad characters at the end (remember to account for trailing newline) 611 my $pad = 3 - ($len % 3); 612 substr($str, -$pad-1, $pad) = ('=' x $pad) if $pad < 3; 613 $str =~ tr/\n//d if $_[1]; # remove newlines if specified 614 return $str; 615} 616 617#------------------------------------------------------------------------------ 618# sort tagInfo hash references by tag name 619sub ByTagName 620{ 621 return $$a{Name} cmp $$b{Name}; 622} 623 624#------------------------------------------------------------------------------ 625# sort alphabetically, but with rdf:type first in the structure 626sub TypeFirst 627{ 628 if ($a =~ /rdf:type$/) { 629 return substr($a, 0, -8) cmp $b unless $b =~ /rdf:type$/; 630 } elsif ($b =~ /rdf:type$/) { 631 return $a cmp substr($b, 0, -8); 632 } 633 return $a cmp $b; 634} 635 636#------------------------------------------------------------------------------ 637# Limit size of XMP 638# Inputs: 0) ExifTool object ref, 1) XMP data ref (written up to start of $rdfClose), 639# 2) max XMP len, 3) rdf:about string, 4) list ref for description start offsets 640# 5) start offset of first description recommended for extended XMP 641# Returns: 0) extended XMP ref, 1) GUID and updates $$dataPt (or undef if no extended XMP) 642sub LimitXMPSize($$$$$$) 643{ 644 my ($et, $dataPt, $maxLen, $about, $startPt, $extStart) = @_; 645 646 # return straight away if it isn't too big 647 return undef if length($$dataPt) < $maxLen; 648 649 push @$startPt, length($$dataPt); # add end offset to list 650 my $newData = substr($$dataPt, 0, $$startPt[0]); 651 my $guid = '0' x 32; 652 # write the required xmpNote:HasExtendedXMP property 653 $newData .= "$nl$sp<$rdfDesc rdf:about='${about}'\n$sp${sp}xmlns:xmpNote='$nsURI{xmpNote}'"; 654 if ($$et{OPTIONS}{Compact}{Shorthand}) { 655 $newData .= "\n$sp${sp}xmpNote:HasExtendedXMP='${guid}'/>\n"; 656 } else { 657 $newData .= ">$nl$sp$sp<xmpNote:HasExtendedXMP>$guid</xmpNote:HasExtendedXMP>$nl$sp</$rdfDesc>\n"; 658 } 659 660 my ($i, %descSize, $start); 661 # calculate all description block sizes 662 for ($i=1; $i<@$startPt; ++$i) { 663 $descSize{$$startPt[$i-1]} = $$startPt[$i] - $$startPt[$i-1]; 664 } 665 pop @$startPt; # remove end offset 666 # write the descriptions from smallest to largest, as many in main XMP as possible 667 my @descStart = sort { $descSize{$a} <=> $descSize{$b} } @$startPt; 668 my $extData = XMPOpen($et) . $rdfOpen; 669 for ($i=0; $i<2; ++$i) { 670 foreach $start (@descStart) { 671 # write main XMP first (in order of size), then extended XMP afterwards (in order) 672 next if $i xor $start >= $extStart; 673 my $pt = (length($newData) + $descSize{$start} > $maxLen) ? \$extData : \$newData; 674 $$pt .= substr($$dataPt, $start, $descSize{$start}); 675 } 676 } 677 $extData .= $rdfClose . $xmpClose; # close rdf:RDF and x:xmpmeta 678 # calculate GUID from MD5 of extended XMP data 679 if (eval { require Digest::MD5 }) { 680 $guid = uc unpack('H*', Digest::MD5::md5($extData)); 681 $newData =~ s/0{32}/$guid/; # update GUID in main XMP segment 682 } 683 $et->VerboseValue('+ XMP-xmpNote:HasExtendedXMP', $guid); 684 $$dataPt = $newData; # return main XMP block 685 return (\$extData, $guid); # return extended XMP and its GUID 686} 687 688#------------------------------------------------------------------------------ 689# Close out bottom-level property 690# Inputs: 0) current property path list ref, 1) longhand properties at each resource 691# level, 2) shorthand properties at each resource level, 3) resource flag for 692# each property path level (set only if Shorthand is enabled) 693sub CloseProperty($$$$) 694{ 695 my ($curPropList, $long, $short, $resFlag) = @_; 696 697 my $prop = pop @$curPropList; 698 $prop =~ s/ .*//; # remove list index if it exists 699 my $pad = $sp x (scalar(@$curPropList) + 1); 700 if ($$resFlag[@$curPropList]) { 701 # close this XMP structure with possible shorthand properties 702 if (length $$short[-1]) { 703 if (length $$long[-1]) { 704 # require a new Description if both longhand and shorthand properties 705 $$long[-2] .= ">$nl$pad<$rdfDesc"; 706 $$short[-1] .= ">$nl"; 707 $$long[-1] .= "$pad</$rdfDesc>$nl"; 708 } else { 709 # simply close empty property if all shorthand 710 $$short[-1] .= "/>$nl"; 711 } 712 } else { 713 # use "parseType" instead of opening a new Description 714 $$long[-2] .= ' rdf:parseType="Resource"'; 715 $$short[-1] = length $$long[-1] ? ">$nl" : "/>$nl"; 716 } 717 $$long[-1] .= "$pad</$prop>$nl" if length $$long[-1]; 718 $$long[-2] .= $$short[-1] . $$long[-1]; 719 pop @$short; 720 pop @$long; 721 } elsif (defined $$resFlag[@$curPropList]) { 722 # close this top level Description with possible shorthand values 723 if (length $$long[-1]) { 724 $$long[-2] .= $$short[-1] . ">$nl" . $$long[-1] . "$pad</$prop>$nl"; 725 } else { 726 $$long[-2] .= $$short[-1] . "/>$nl"; # empty element (ie. all shorthand) 727 } 728 $$short[-1] = $$long[-1] = ''; 729 } else { 730 # close this property (no chance of shorthand) 731 $$long[-1] .= "$pad</$prop>$nl"; 732 unless (@$curPropList) { 733 # add properties now that this top-level Description is complete 734 $$long[-2] .= ">$nl" . $$long[-1]; 735 $$long[-1] = ''; 736 } 737 } 738 $#$resFlag = $#$curPropList; # remove expired resource flags 739} 740 741#------------------------------------------------------------------------------ 742# Write XMP information 743# Inputs: 0) ExifTool ref, 1) source dirInfo ref (with optional WriteGroup), 744# 2) [optional] tag table ref 745# Returns: with tag table: new XMP data (may be empty if no XMP data) or undef on error 746# without tag table: 1 on success, 0 if not valid XMP file, -1 on write error 747# Notes: May set dirInfo InPlace flag to rewrite with specified DirLen (=2 to allow larger) 748# May set dirInfo ReadOnly flag to write as read-only XMP ('r' mode and no padding) 749# May set dirInfo Compact flag to force compact (drops 2kB of padding) 750# May set dirInfo MaxDataLen to limit output data length -- this causes ExtendedXMP 751# and ExtendedGUID to be returned in dirInfo if extended XMP was required 752sub WriteXMP($$;$) 753{ 754 my ($et, $dirInfo, $tagTablePtr) = @_; 755 $et or return 1; # allow dummy access to autoload this package 756 my $dataPt = $$dirInfo{DataPt}; 757 my (%capture, %nsUsed, $xmpErr, $about); 758 my $changed = 0; 759 my $xmpFile = (not $tagTablePtr); # this is an XMP data file if no $tagTablePtr 760 # prefer XMP over other metadata formats in some types of files 761 my $preferred = $xmpFile || ($$et{PreferredGroup} and $$et{PreferredGroup} eq 'XMP'); 762 my $verbose = $$et{OPTIONS}{Verbose}; 763 my %compact = ( %{$$et{OPTIONS}{Compact}} ); # (make a copy so we can change settings) 764 my $dirLen = $$dirInfo{DirLen}; 765 $dirLen = length($$dataPt) if not defined $dirLen and $dataPt; 766# 767# extract existing XMP information into %capture hash 768# 769 # define hash in ExifTool object to capture XMP information (also causes 770 # CaptureXMP() instead of FoundXMP() to be called from ParseXMPElement()) 771 # 772 # The %capture hash is keyed on the complete property path beginning after 773 # rdf:RDF/rdf:Description/. The values are array references with the 774 # following entries: 0) value, 1) attribute hash reference. 775 $$et{XMP_CAPTURE} = \%capture; 776 $$et{XMP_NS} = \%nsUsed; 777 delete $$et{XMP_NO_XMPMETA}; 778 delete $$et{XMP_NO_XPACKET}; 779 delete $$et{XMP_IS_XML}; 780 delete $$et{XMP_IS_SVG}; 781 782 # set current padding characters 783 ($sp, $nl) = ($compact{NoIndent} ? '' : ' ', $compact{NoNewline} ? '' : "\n"); 784 785 # get value for new rdf:about 786 my $tagInfo = $Image::ExifTool::XMP::rdf{about}; 787 if (defined $$et{NEW_VALUE}{$tagInfo}) { 788 $about = $et->GetNewValue($$et{NEW_VALUE}{$tagInfo}) || ''; 789 } 790 791 if ($xmpFile or $dirLen) { 792 delete $$et{XMP_ERROR}; 793 # extract all existing XMP information (to the XMP_CAPTURE hash) 794 my $success = ProcessXMP($et, $dirInfo, $tagTablePtr); 795 # don't continue if there is nothing to parse or if we had a parsing error 796 unless ($success and not $$et{XMP_ERROR}) { 797 my $err = $$et{XMP_ERROR} || 'Error parsing XMP'; 798 # may ignore this error only if we were successful 799 if ($xmpFile) { 800 my $raf = $$dirInfo{RAF}; 801 # allow empty XMP data so we can create something from nothing 802 if ($success or not $raf->Seek(0,2) or $raf->Tell()) { 803 # no error message if not an XMP file 804 return 0 unless $$et{XMP_ERROR}; 805 if ($et->Error($err, $success)) { 806 delete $$et{XMP_CAPTURE}; 807 return 0; 808 } 809 } 810 } else { 811 $success = 2 if $success and $success eq '1'; 812 if ($et->Warn($err, $success)) { 813 delete $$et{XMP_CAPTURE}; 814 return undef; 815 } 816 } 817 } 818 if (defined $about) { 819 if ($verbose > 1) { 820 my $wasAbout = $$et{XmpAbout}; 821 $et->VerboseValue('- XMP-rdf:About', UnescapeXML($wasAbout)) if defined $wasAbout; 822 $et->VerboseValue('+ XMP-rdf:About', $about); 823 } 824 $about = EscapeXML($about); # must escape for XML 825 ++$changed; 826 } else { 827 $about = $$et{XmpAbout} || ''; 828 } 829 delete $$et{XMP_ERROR}; 830 831 # call InitWriteDirs to initialize FORCE_WRITE flags if necessary 832 $et->InitWriteDirs({}, 'XMP') if $xmpFile and $et->GetNewValue('ForceWrite'); 833 # set changed if we are ForceWrite tag was set to "XMP" 834 ++$changed if $$et{FORCE_WRITE}{XMP}; 835 836 } elsif (defined $about) { 837 $et->VerboseValue('+ XMP-rdf:About', $about); 838 $about = EscapeXML($about); # must escape for XML 839 # (don't increment $changed here because we need another tag to be written) 840 } else { 841 $about = ''; 842 } 843# 844# handle writing XMP as a block to XMP file 845# 846 if ($xmpFile) { 847 $tagInfo = $Image::ExifTool::Extra{XMP}; 848 if ($tagInfo and $$et{NEW_VALUE}{$tagInfo}) { 849 my $rtnVal = 1; 850 my $newVal = $et->GetNewValue($$et{NEW_VALUE}{$tagInfo}); 851 if (defined $newVal and length $newVal) { 852 $et->VPrint(0, " Writing XMP as a block\n"); 853 ++$$et{CHANGED}; 854 Write($$dirInfo{OutFile}, $newVal) or $rtnVal = -1; 855 } 856 delete $$et{XMP_CAPTURE}; 857 return $rtnVal; 858 } 859 } 860# 861# delete groups in family 1 if requested 862# 863 if (%{$$et{DEL_GROUP}} and (grep /^XMP-.+$/, keys %{$$et{DEL_GROUP}} or 864 # (logic is a bit more complex for group names in exiftool XML files) 865 grep m{^http://ns.exiftool.(?:ca|org)/}, values %nsUsed)) 866 { 867 my $del = $$et{DEL_GROUP}; 868 my $path; 869 foreach $path (keys %capture) { 870 my @propList = split('/',$path); # get property list 871 my ($tag, $ns) = GetXMPTagID(\@propList); 872 # translate namespace if necessary 873 $ns = $stdXlatNS{$ns} if $stdXlatNS{$ns}; 874 my ($grp, @g); 875 # no "XMP-" added to most groups in exiftool RDF/XML output file 876 if ($nsUsed{$ns} and (@g = ($nsUsed{$ns} =~ m{^http://ns.exiftool.(?:ca|org)/(.*?)/(.*?)/}))) { 877 if ($g[1] =~ /^\d/) { 878 $grp = "XML-$g[0]"; 879 #(all XML-* groups stored as uppercase DEL_GROUP key) 880 my $ucg = uc $grp; 881 next unless $$del{$ucg} or ($$del{'XML-*'} and not $$del{"-$ucg"}); 882 } else { 883 $grp = $g[1]; 884 next unless $$del{$grp} or ($$del{$g[0]} and not $$del{"-$grp"}); 885 } 886 } else { 887 $grp = "XMP-$ns"; 888 my $ucg = uc $grp; 889 next unless $$del{$ucg} or ($$del{'XMP-*'} and not $$del{"-$ucg"}); 890 } 891 $et->VerboseValue("- $grp:$tag", $capture{$path}->[0]); 892 delete $capture{$path}; 893 ++$changed; 894 } 895 } 896 # delete HasExtendedXMP tag (we create it as needed) 897 my $hasExtTag = 'xmpNote:HasExtendedXMP'; 898 if ($capture{$hasExtTag}) { 899 $et->VerboseValue("- XMP-$hasExtTag", $capture{$hasExtTag}->[0]); 900 delete $capture{$hasExtTag}; 901 } 902 # set $xmpOpen now to to handle xmptk tag first 903 my $xmpOpen = $$et{XMP_NO_XMPMETA} ? '' : XMPOpen($et); 904# 905# add, delete or change information as specified 906# 907 # get hash of all information we want to change 908 # (sorted by tag name so alternate languages come last, but with structures 909 # first so flattened tags may be used to override individual structure elements) 910 my (@tagInfoList, $delLangPath, %delLangPaths, %delAllLang, $firstNewPath); 911 my $writeGroup = $$dirInfo{WriteGroup}; 912 foreach $tagInfo (sort ByTagName $et->GetNewTagInfoList()) { 913 next unless $et->GetGroup($tagInfo, 0) eq 'XMP'; 914 next if $$tagInfo{Name} eq 'XMP'; # (ignore full XMP block if we didn't write it already) 915 next if $writeGroup and $writeGroup ne $$et{NEW_VALUE}{$tagInfo}{WriteGroup}; 916 if ($$tagInfo{Struct}) { 917 unshift @tagInfoList, $tagInfo; 918 } else { 919 push @tagInfoList, $tagInfo; 920 } 921 } 922 foreach $tagInfo (@tagInfoList) { 923 my @delPaths; # list of deleted paths 924 my $tag = $$tagInfo{TagID}; 925 my $path = GetPropertyPath($tagInfo); 926 unless ($path) { 927 $et->Warn("Can't write XMP:$tag (namespace unknown)"); 928 next; 929 } 930 # skip tags that were handled specially 931 if ($path eq 'rdf:about' or $path eq 'x:xmptk') { 932 ++$changed; 933 next; 934 } 935 my $isStruct = $$tagInfo{Struct}; 936 # change our property path namespace prefixes to conform 937 # to the ones used in this file 938 $path = ConformPathToNamespace($et, $path); 939 # find existing property 940 my $cap = $capture{$path}; 941 # MicrosoftPhoto screws up the case of some tags, and some other software, 942 # including Adobe software, has been known to write the wrong list type or 943 # not properly enclose properties in a list, so we check for this 944 until ($cap) { 945 # find and fix all incorrect property names if this is a structure or a flattened tag 946 my @fixInfo; 947 if ($isStruct or defined $$tagInfo{Flat}) { 948 # get tagInfo for all containing (possibly nested) structures 949 my @props = split '/', $path; 950 my $tbl = $$tagInfo{Table}; 951 while (@props) { 952 my $info = $$tbl{GetXMPTagID(\@props)}; 953 unshift @fixInfo, $info if ref $info eq 'HASH' and $$info{Struct} and 954 (not @fixInfo or $fixInfo[0] ne $info); 955 pop @props; 956 } 957 $et->WarnOnce("Error finding parent structure for $$tagInfo{Name}") unless @fixInfo; 958 } 959 # fix property path for this tag (last in the @fixInfo list) 960 push @fixInfo, $tagInfo unless @fixInfo and $isStruct; 961 # start from outermost containing structure, fixing incorrect list types, etc, 962 # finally fixing the actual tag properties after all containing structures 963 my $err; 964 while (@fixInfo) { 965 my $fixInfo = shift @fixInfo; 966 my $fixPath = ConformPathToNamespace($et, GetPropertyPath($fixInfo)); 967 my $regex = quotemeta($fixPath); 968 $regex =~ s/ \d+/ \\d\+/g; # match any list index 969 my $ok = $regex; 970 my ($ok2, $match, $i, @fixed, %fixed, $fixed); 971 # check for incorrect list types 972 if ($regex =~ s{\\/rdf\\:(Bag|Seq|Alt)\\/}{/rdf:(Bag|Seq|Alt)/}g) { 973 # also look for missing bottom-level list 974 if ($regex =~ s{/rdf:\(Bag\|Seq\|Alt\)\/rdf\\:li\\ \\d\+$}{}) { 975 $regex .= '(/.*)?' unless @fixInfo; 976 } 977 } elsif (not @fixInfo) { 978 $ok2 = $regex; 979 # check for properties in lists that shouldn't be (ref forum4325) 980 $regex .= '(/rdf:(Bag|Seq|Alt)/rdf:li \d+)?'; 981 } 982 if (@fixInfo) { 983 $regex .= '(/.*)?'; 984 $ok .= '(/.*)?'; 985 } 986 my @matches = sort grep m{^$regex$}i, keys %capture; 987 last unless @matches; 988 if ($matches[0] =~ m{^$ok$}) { 989 unless (@fixInfo) { 990 $path = $matches[0]; 991 $cap = $capture{$path}; 992 } 993 next; 994 } 995 # needs fixing... 996 my @fixProps = split '/', $fixPath; 997 foreach $match (@matches) { 998 my @matchProps = split '/', $match; 999 # remove superfluous list properties if necessary 1000 $#matchProps = $#fixProps if $ok2 and $#matchProps > $#fixProps; 1001 for ($i=0; $i<@fixProps; ++$i) { 1002 defined $matchProps[$i] or $matchProps[$i] = $fixProps[$i], next; 1003 next if $matchProps[$i] =~ / \d+$/ or $matchProps[$i] eq $fixProps[$i]; 1004 $matchProps[$i] = $fixProps[$i]; 1005 } 1006 $fixed = join '/', @matchProps; 1007 $err = 1 if $fixed{$fixed} or ($capture{$fixed} and $match ne $fixed); 1008 push @fixed, $fixed; 1009 $fixed{$fixed} = 1; 1010 } 1011 my $tg = $et->GetGroup($fixInfo, 1) . ':' . $$fixInfo{Name}; 1012 my $wrn = lc($fixed[0]) eq lc($matches[0]) ? 'tag ID case' : 'list type'; 1013 if ($err) { 1014 $et->Warn("Incorrect $wrn for existing $tg (not changed)"); 1015 } else { 1016 # fix the incorrect property paths for all values of this tag 1017 my $didFix; 1018 foreach $fixed (@fixed) { 1019 my $match = shift @matches; 1020 next if $fixed eq $match; 1021 $capture{$fixed} = $capture{$match}; 1022 delete $capture{$match}; 1023 # remove xml:lang attribute from incorrect lang-alt list if necessary 1024 delete $capture{$fixed}[1]{'xml:lang'} if $ok2 and $match !~ /^$ok2$/; 1025 $didFix = 1; 1026 } 1027 $cap = $capture{$path} || $capture{$fixed[0]} unless @fixInfo; 1028 if ($didFix) { 1029 $et->Warn("Fixed incorrect $wrn for $tg", 1); 1030 ++$changed; 1031 } 1032 } 1033 } 1034 last; 1035 } 1036 my $nvHash = $et->GetNewValueHash($tagInfo); 1037 my $overwrite = $et->IsOverwriting($nvHash); 1038 my $writable = $$tagInfo{Writable} || ''; 1039 my (%attrs, $deleted, $added, $existed, $newLang); 1040 # set up variables to save/restore paths of deleted lang-alt tags 1041 if ($writable eq 'lang-alt') { 1042 $newLang = lc($$tagInfo{LangCode} || 'x-default'); 1043 if ($delLangPath and $delLangPath eq $path) { 1044 # restore paths of deleted entries for this language 1045 @delPaths = @{$delLangPaths{$newLang}} if $delLangPaths{$newLang}; 1046 } else { 1047 undef %delLangPaths; 1048 $delLangPath = $path; # base path for deleted lang-alt tags 1049 undef %delAllLang; 1050 undef $firstNewPath; # reset first path for new lang-alt tag 1051 } 1052 if (%delAllLang) { 1053 # add missing paths to delete list for entries where all languages were deleted 1054 my ($prefix, $reSort); 1055 foreach $prefix (keys %delAllLang) { 1056 next if grep /^$prefix/, @delPaths; 1057 push @delPaths, "${prefix}10"; 1058 $reSort = 1; 1059 } 1060 @delPaths = sort @delPaths if $reSort; 1061 } 1062 } 1063 # delete existing entry if necessary 1064 if ($isStruct) { 1065 # delete all structure (or pseudo-structure) elements 1066 require 'Image/ExifTool/XMPStruct.pl'; 1067 ($deleted, $added, $existed) = DeleteStruct($et, \%capture, \$path, $nvHash, \$changed); 1068 next unless $deleted or $added or $et->IsOverwriting($nvHash); 1069 next if $existed and $$nvHash{CreateOnly}; 1070 } elsif ($cap) { 1071 next if $$nvHash{CreateOnly}; # (necessary for List-type tags) 1072 # take attributes from old values if they exist 1073 %attrs = %{$$cap[1]}; 1074 if ($overwrite) { 1075 my ($oldLang, $delLang, $addLang, @matchingPaths, $langPathPat, %langsHere); 1076 # check to see if this is an indexed list item 1077 if ($path =~ / /) { 1078 my $pp; 1079 ($pp = $path) =~ s/ \d+/ \\d\+/g; 1080 @matchingPaths = sort grep(/^$pp$/, keys %capture); 1081 } else { 1082 push @matchingPaths, $path; 1083 } 1084 my $oldOverwrite = $overwrite; 1085 foreach $path (@matchingPaths) { 1086 my ($val, $attrs) = @{$capture{$path}}; 1087 if ($writable eq 'lang-alt') { 1088 # get original language code (lc for comparisons) 1089 $oldLang = lc($$attrs{'xml:lang'} || 'x-default'); 1090 # revert to original overwrite flag if this is in a different structure 1091 if (not $langPathPat or $path !~ /^$langPathPat$/) { 1092 $overwrite = $oldOverwrite; 1093 ($langPathPat = $path) =~ s/\d+$/\\d+/; 1094 } 1095 # remember languages in this lang-alt list 1096 $langsHere{$langPathPat}{$oldLang} = 1; 1097 unless (defined $addLang) { 1098 # add to lang-alt list by default if creating this tag from scratch 1099 $addLang = $$nvHash{IsCreating} ? 1 : 0; 1100 } 1101 if ($overwrite < 0) { 1102 next unless $oldLang eq $newLang; 1103 # only add new tag if we are overwriting this one 1104 # (note: this won't match if original XML contains CDATA!) 1105 $addLang = $et->IsOverwriting($nvHash, UnescapeXML($val)); 1106 next unless $addLang; 1107 } 1108 # delete all if deleting "x-default" and writing with no LangCode 1109 # (XMP spec requires x-default language exist and be first in list) 1110 if ($oldLang eq 'x-default' and not $$tagInfo{LangCode}) { 1111 $delLang = 1; # delete all languages 1112 $overwrite = 1; # force overwrite 1113 } elsif ($$tagInfo{LangCode} and not $delLang) { 1114 # only overwrite specified language 1115 next unless lc($$tagInfo{LangCode}) eq $oldLang; 1116 } 1117 } elsif ($overwrite < 0) { 1118 # only overwrite specific values 1119 if ($$nvHash{Shift}) { 1120 # values to be shifted are checked (hence re-formatted) late, 1121 # so we must un-format the to-be-shifted value for IsOverwriting() 1122 my $fmt = $$tagInfo{Writable} || ''; 1123 if ($fmt eq 'rational') { 1124 ConvertRational($val); 1125 } elsif ($fmt eq 'date') { 1126 $val = ConvertXMPDate($val); 1127 } 1128 } 1129 # (note: this won't match if original XML contains CDATA!) 1130 next unless $et->IsOverwriting($nvHash, UnescapeXML($val)); 1131 } 1132 if ($verbose > 1) { 1133 my $grp = $et->GetGroup($tagInfo, 1); 1134 my $tagName = $$tagInfo{Name}; 1135 $tagName =~ s/-$$tagInfo{LangCode}$// if $$tagInfo{LangCode}; 1136 $tagName .= '-' . $$attrs{'xml:lang'} if $$attrs{'xml:lang'}; 1137 $et->VerboseValue("- $grp:$tagName", $val); 1138 } 1139 # save attributes and path from first deleted property 1140 # so we can replace it exactly 1141 %attrs = %$attrs unless @delPaths; 1142 if ($writable eq 'lang-alt') { 1143 $langsHere{$langPathPat}{$oldLang} = 0; # (lang was deleted) 1144 } 1145 # save deleted paths so we can replace the same elements 1146 # (separately for each language of a lang-alt list) 1147 if ($writable ne 'lang-alt' or $oldLang eq $newLang) { 1148 push @delPaths, $path; 1149 } else { 1150 $delLangPaths{$oldLang} or $delLangPaths{$oldLang} = [ ]; 1151 push @{$delLangPaths{$oldLang}}, $path; 1152 } 1153 # keep track of paths where we deleted all languages of a lang-alt tag 1154 if ($delLang) { 1155 my $p; 1156 ($p = $path) =~ s/\d+$//; 1157 $delAllLang{$p} = 1; 1158 } 1159 # delete this tag 1160 delete $capture{$path}; 1161 ++$changed; 1162 # delete rdf:type tag if it is the only thing left in this structure 1163 if ($path =~ /^(.*)\// and $capture{"$1/rdf:type"}) { 1164 my $pp = $1; 1165 my @a = grep /^\Q$pp\E\/[^\/]+/, keys %capture; 1166 delete $capture{"$pp/rdf:type"} if @a == 1; 1167 } 1168 } 1169 next unless @delPaths or $$tagInfo{List} or $addLang; 1170 if (@delPaths) { 1171 $path = shift @delPaths; 1172 # make sure new path is unique 1173 while ($capture{$path}) { 1174 last unless $path =~ s/ \d(\d+)$/' '.length($1+1).($1+1)/e; 1175 } 1176 $deleted = 1; 1177 } else { 1178 # don't change tag if we couldn't delete old copy 1179 # unless this is a list or an lang-alt tag 1180 next unless $$tagInfo{List} or $oldLang; 1181 # avoid adding duplicate entry to lang-alt in a list 1182 if ($writable eq 'lang-alt' and %langsHere) { 1183 foreach (sort keys %langsHere) { 1184 next unless $path =~ /^$_$/; 1185 last unless $langsHere{$_}{$newLang}; 1186 $path =~ /(.* )\d(\d+)(.*? \d+)$/ or $et->Error('Internal error writing lang-alt list'), last; 1187 my $nxt = $2 + 1; 1188 $path = $1 . length($nxt) . ($nxt) . $3; # step to next index 1189 } 1190 } 1191 # (match last index to put in same lang-alt list for Bag of lang-alt items) 1192 $path =~ m/.* (\d+)/g or warn "Internal error: no list index!\n", next; 1193 $added = $1; 1194 } 1195 } else { 1196 # we are never overwriting, so we must be adding to a list 1197 # match the last index unless this is a list of lang-alt lists 1198 my $pat = '.* (\d+)'; 1199 if ($writable eq 'lang-alt') { 1200 if ($firstNewPath) { 1201 $path = $firstNewPath; 1202 $overwrite = 1; # necessary to put x-default entry first below 1203 } else { 1204 $pat = '.* (\d+)(.*? \d+)'; 1205 } 1206 } 1207 if ($path =~ m/$pat/g) { 1208 $added = $1; 1209 # set position to end of matching index number 1210 pos($path) = pos($path) - length($2) if $2; 1211 } 1212 } 1213 if (defined $added) { 1214 my $len = length $added; 1215 my $pos = pos($path) - $len; 1216 my $nxt = substr($added, 1) + 1; 1217 # always insert x-default lang-alt entry first (as per XMP spec) 1218 # (need to test $overwrite because this will be a new lang-alt entry otherwise) 1219 if ($overwrite and $writable eq 'lang-alt' and (not $$tagInfo{LangCode} or 1220 $$tagInfo{LangCode} eq 'x-default')) 1221 { 1222 my $saveCap = $capture{$path}; 1223 while ($saveCap) { 1224 my $p = $path; 1225 substr($p, $pos, $len) = length($nxt) . $nxt; 1226 # increment index in the path of the existing item 1227 my $nextCap = $capture{$p}; 1228 $capture{$p} = $saveCap; 1229 last unless $nextCap; 1230 $saveCap = $nextCap; 1231 ++$nxt; 1232 } 1233 } else { 1234 # add to end of list 1235 while ($capture{$path}) { 1236 my $try = length($nxt) . $nxt; 1237 substr($path, $pos, $len) = $try; 1238 $len = length $try; 1239 ++$nxt; 1240 } 1241 } 1242 } 1243 } 1244 # check to see if we want to create this tag 1245 # (create non-avoided tags in XMP data files by default) 1246 my $isCreating = ($$nvHash{IsCreating} or (($isStruct or 1247 ($preferred and not $$tagInfo{Avoid} and 1248 not defined $$nvHash{Shift})) and not $$nvHash{EditOnly})); 1249 1250 # don't add new values unless... 1251 # ...tag existed before and was deleted, or we added it to a list 1252 next unless $deleted or defined $added or 1253 # ...tag didn't exist before and we are creating it 1254 (not $cap and $isCreating); 1255 1256 # get list of new values (all done if no new values specified) 1257 my @newValues = $et->GetNewValue($nvHash) or next; 1258 1259 # set language attribute for lang-alt lists 1260 if ($writable eq 'lang-alt') { 1261 $attrs{'xml:lang'} = $$tagInfo{LangCode} || 'x-default'; 1262 $firstNewPath = $path if defined $added; # save path of first lang-alt tag added 1263 } 1264 # add new value(s) to %capture hash 1265 my $subIdx; 1266 for (;;) { 1267 my $newValue = shift @newValues; 1268 if ($isStruct) { 1269 ++$changed if AddNewStruct($et, $tagInfo, \%capture, 1270 $path, $newValue, $$tagInfo{Struct}); 1271 } else { 1272 $newValue = EscapeXML($newValue); 1273 for (;;) { # (a cheap 'goto') 1274 if ($$tagInfo{Resource}) { 1275 # only store as a resource if it doesn't contain any illegal characters 1276 if ($newValue !~ /[^a-z0-9\:\/\?\#\[\]\@\!\$\&\'\(\)\*\+\,\;\=\.\-\_\~]/i) { 1277 $capture{$path} = [ '', { %attrs, 'rdf:resource' => $newValue } ]; 1278 last; 1279 } 1280 my $grp = $et->GetGroup($tagInfo, 1); 1281 $et->Warn("$grp:$$tagInfo{Name} written as a literal because value is not a valid URI", 1); 1282 # fall through to write as a string literal 1283 } 1284 # remove existing value and/or resource attribute if they exist 1285 delete $attrs{'rdf:value'}; 1286 delete $attrs{'rdf:resource'}; 1287 $capture{$path} = [ $newValue, \%attrs ]; 1288 last; 1289 } 1290 if ($verbose > 1) { 1291 my $grp = $et->GetGroup($tagInfo, 1); 1292 $et->VerboseValue("+ $grp:$$tagInfo{Name}", $newValue); 1293 } 1294 ++$changed; 1295 # add rdf:type if necessary 1296 if ($$tagInfo{StructType}) { 1297 AddStructType($et, $$tagInfo{Table}, \%capture, $path); 1298 } 1299 } 1300 last unless @newValues; 1301 # match last index except for lang-alt items where we want to put each 1302 # item in a different lang-alt list (so match the 2nd-last for these) 1303 my $pat = $writable eq 'lang-alt' ? '.* (\d+)(.*? \d+)' : '.* (\d+)'; 1304 pos($path) = 0; 1305 $path =~ m/$pat/g or warn("Internal error: no list index for $tag ($path) ($pat)!\n"), next; 1306 my $idx = $1; 1307 my $len = length $1; 1308 my $pos = pos($path) - $len - ($2 ? length $2 : 0); 1309 # use sub-indices if necessary to store additional values in sequence 1310 if ($subIdx) { 1311 $idx = substr($idx, 0, -length($subIdx)); # remove old sub-index 1312 $subIdx = substr($subIdx, 1) + 1; 1313 $subIdx = length($subIdx) . $subIdx; 1314 } elsif (@delPaths) { 1315 $path = shift @delPaths; 1316 # make sure new path is unique 1317 while ($capture{$path}) { 1318 last unless $path =~ s/ \d(\d+)$/' '.length($1+1).($1+1)/e; 1319 } 1320 next; 1321 } else { 1322 $subIdx = '10'; 1323 } 1324 substr($path, $pos, $len) = $idx . $subIdx; 1325 } 1326 # make sure any empty structures are deleted 1327 # (ExifTool shouldn't write these, but other software may) 1328 if (defined $$tagInfo{Flat}) { 1329 my $p = $path; 1330 while ($p =~ s/\/[^\/]+$//) { 1331 next unless $capture{$p}; 1332 # it is an error if this property has a value 1333 $et->Error("Improperly structured XMP ($p)",1) if $capture{$p}[0] =~ /\S/; 1334 delete $capture{$p}; # delete the (hopefully) empty structure 1335 } 1336 } 1337 } 1338 # remove the ExifTool members we created 1339 delete $$et{XMP_CAPTURE}; 1340 delete $$et{XMP_NS}; 1341 1342 my $maxDataLen = $$dirInfo{MaxDataLen}; 1343 # get DataPt again because it may have been set by ProcessXMP 1344 $dataPt = $$dirInfo{DataPt}; 1345 1346 # return now if we didn't change anything 1347 unless ($changed or ($maxDataLen and $dataPt and defined $$dataPt and 1348 length($$dataPt) > $maxDataLen)) 1349 { 1350 return undef unless $xmpFile; # just rewrite original XMP 1351 Write($$dirInfo{OutFile}, $$dataPt) or return -1 if $dataPt and defined $$dataPt; 1352 return 1; 1353 } 1354# 1355# write out the new XMP information (serialize it) 1356# 1357 # start writing the XMP data 1358 my (@long, @short, @resFlag); 1359 $long[0] = $long[1] = $short[0] = ''; 1360 if ($$et{XMP_NO_XPACKET}) { 1361 # write BOM if flag is set 1362 $long[-2] .= "\xef\xbb\xbf" if $$et{XMP_NO_XPACKET} == 2; 1363 } else { 1364 $long[-2] .= $pktOpen; 1365 } 1366 $long[-2] .= $xmlOpen if $$et{XMP_IS_XML}; 1367 $long[-2] .= $xmpOpen . $rdfOpen; 1368 1369 # initialize current property path list 1370 my (@curPropList, @writeLast, @descStart, $extStart); 1371 my (%nsCur, $prop, $n, $path); 1372 my @pathList = sort TypeFirst keys %capture; 1373 # order properties to write large values last if we have a MaxDataLen limit 1374 if ($maxDataLen and @pathList) { 1375 my @pathTmp; 1376 my ($lastProp, $lastNS, $propSize) = ('', '', 0); 1377 my @pathLoop = (@pathList, ''); # add empty path to end of list for loop 1378 undef @pathList; 1379 foreach $path (@pathLoop) { 1380 $path =~ /^((\w*)[^\/]*)/; # get path element ($1) and ns ($2) 1381 if ($1 eq $lastProp) { 1382 push @pathTmp, $path; # accumulate all paths with same root 1383 } else { 1384 # put in list to write last if recommended or values are too large 1385 if ($extendedRes{$lastProp} or $extendedRes{$lastNS} or 1386 $propSize > $newDescThresh) 1387 { 1388 push @writeLast, @pathTmp; 1389 } else { 1390 push @pathList, @pathTmp; 1391 } 1392 last unless $path; # all done if we hit empty path 1393 @pathTmp = ( $path ); 1394 ($lastProp, $lastNS, $propSize) = ($1, $2, 0); 1395 } 1396 $propSize += length $capture{$path}->[0]; 1397 } 1398 } 1399 1400 # write out all properties 1401 for (;;) { 1402 my (%nsNew, $newDesc); 1403 unless (@pathList) { 1404 last unless @writeLast; 1405 @pathList = @writeLast; 1406 undef @writeLast; 1407 $newDesc = 2; # start with a new description for the extended data 1408 } 1409 $path = shift @pathList; 1410 my @propList = split('/',$path); # get property list 1411 # must open/close rdf:Description too 1412 unshift @propList, $rdfDesc; 1413 # make sure we have defined all necessary namespaces 1414 foreach $prop (@propList) { 1415 $prop =~ /(.*):/ or next; 1416 $1 eq 'rdf' and next; # rdf namespace already defined 1417 my $uri = $nsUsed{$1}; 1418 unless ($uri) { 1419 $uri = $nsURI{$1}; # we must have added a namespace 1420 unless ($uri) { 1421 # (namespace may be empty if trying to write empty XMP structure, forum12384) 1422 $xmpErr = "Undefined XMP namespace: $1" if length $uri; 1423 next; 1424 } 1425 } 1426 $nsNew{$1} = $uri; 1427 # need a new description if any new namespaces 1428 $newDesc = 1 unless $nsCur{$1}; 1429 } 1430 my $closeTo = 0; 1431 if ($newDesc) { 1432 # look forward to see if we will want to also open other namespaces 1433 # at this level (this is necessary to keep lists and structures from 1434 # being broken if a property introduces a new namespace; plus it 1435 # improves formatting) 1436 my ($path2, $ns2); 1437 foreach $path2 (@pathList) { 1438 my @ns2s = ($path2 =~ m{(?:^|/)([^/]+?):}g); 1439 my $opening = $compact{OneDesc} ? 1 : 0; 1440 foreach $ns2 (@ns2s) { 1441 next if $ns2 eq 'rdf'; 1442 $nsNew{$ns2} and ++$opening, next; 1443 last unless $opening; 1444 # get URI for this existing or new namespace 1445 my $uri = $nsUsed{$ns2} || $nsURI{$ns2} or last; 1446 $nsNew{$ns2} = $uri; # also open this namespace 1447 } 1448 last unless $opening; 1449 } 1450 } else { 1451 # find first property where the current path differs from the new path 1452 for ($closeTo=0; $closeTo<@curPropList; ++$closeTo) { 1453 last unless $closeTo < @propList; 1454 last unless $propList[$closeTo] eq $curPropList[$closeTo]; 1455 } 1456 } 1457 # close out properties down to the common base path 1458 CloseProperty(\@curPropList, \@long, \@short, \@resFlag) while @curPropList > $closeTo; 1459 1460 # open new description if necessary 1461 if ($newDesc) { 1462 $extStart = length($long[-2]) if $newDesc == 2; # extended data starts after this 1463 # save rdf:Description start positions so we can reorder them if necessary 1464 push @descStart, length($long[-2]) if $maxDataLen; 1465 # open the new description 1466 $prop = $rdfDesc; 1467 %nsCur = %nsNew; # save current namespaces 1468 my @ns = sort keys %nsCur; 1469 $long[-2] .= "$nl$sp<$prop rdf:about='${about}'"; 1470 # generate et:toolkit attribute if this is an exiftool RDF/XML output file 1471 if (@ns and $nsCur{$ns[0]} =~ m{^http://ns.exiftool.(?:ca|org)/}) { 1472 $long[-2] .= "\n$sp${sp}xmlns:et='http://ns.exiftool.org/1.0/'" . 1473 " et:toolkit='Image::ExifTool $Image::ExifTool::VERSION'"; 1474 } 1475 $long[-2] .= "\n$sp${sp}xmlns:$_='$nsCur{$_}'" foreach @ns; 1476 push @curPropList, $prop; 1477 # set resFlag to 0 to indicate base description when Shorthand enabled 1478 $resFlag[0] = 0 if $compact{Shorthand}; 1479 } 1480 my ($val, $attrs) = @{$capture{$path}}; 1481 $debug and print "$path = $val\n"; 1482 # open new properties if necessary 1483 my ($attr, $dummy); 1484 for ($n=@curPropList; $n<$#propList; ++$n) { 1485 $prop = $propList[$n]; 1486 push @curPropList, $prop; 1487 $prop =~ s/ .*//; # remove list index if it exists 1488 # (we may add parseType and shorthand properties later, 1489 # so leave off the trailing ">" for now) 1490 $long[-1] .= ($compact{NoIndent} ? '' : ' ' x scalar(@curPropList)) . "<$prop"; 1491 if ($prop ne $rdfDesc and ($propList[$n+1] !~ /^rdf:/ or 1492 ($propList[$n+1] eq 'rdf:type' and $n+1 == $#propList))) 1493 { 1494 # check for empty structure 1495 if ($propList[$n+1] =~ /:~dummy~$/) { 1496 $long[-1] .= " rdf:parseType='Resource'/>$nl"; 1497 pop @curPropList; 1498 $dummy = 1; 1499 last; 1500 } 1501 if ($compact{Shorthand}) { 1502 $resFlag[$#curPropList] = 1; 1503 push @long, ''; 1504 push @short, ''; 1505 } else { 1506 # use rdf:parseType='Resource' to avoid new 'rdf:Description' 1507 $long[-1] .= " rdf:parseType='Resource'>$nl"; 1508 } 1509 } else { 1510 $long[-1] .= ">$nl"; # (will be no shorthand properties) 1511 } 1512 } 1513 my $prop2 = pop @propList; # get new property name 1514 # add element unless it was a dummy structure field 1515 unless ($dummy or ($val eq '' and $prop2 =~ /:~dummy~$/)) { 1516 $prop2 =~ s/ .*//; # remove list index if it exists 1517 my $pad = $compact{NoIndent} ? '' : ' ' x (scalar(@curPropList) + 1); 1518 # (can't write as shortcut if it has attributes or CDATA) 1519 if (defined $resFlag[$#curPropList] and not %$attrs and $val !~ /<!\[CDATA\[/) { 1520 $short[-1] .= "\n$pad$prop2='${val}'"; 1521 } else { 1522 $long[-1] .= "$pad<$prop2"; 1523 # write out attributes 1524 foreach $attr (sort keys %$attrs) { 1525 my $attrVal = $$attrs{$attr}; 1526 my $quot = ($attrVal =~ /'/) ? '"' : "'"; 1527 $long[-1] .= " $attr=$quot$attrVal$quot"; 1528 } 1529 $long[-1] .= length $val ? ">$val</$prop2>$nl" : "/>$nl"; 1530 } 1531 } 1532 } 1533 # close out all open properties 1534 CloseProperty(\@curPropList, \@long, \@short, \@resFlag) while @curPropList; 1535 1536 # limit XMP length and re-arrange if necessary to fit inside specified size 1537 if ($maxDataLen) { 1538 # adjust maxDataLen to allow room for closing elements 1539 $maxDataLen -= length($rdfClose) + length($xmpClose) + length($pktCloseW); 1540 $extStart or $extStart = length $long[-2]; 1541 my @rtn = LimitXMPSize($et, \$long[-2], $maxDataLen, $about, \@descStart, $extStart); 1542 # return extended XMP information in $dirInfo 1543 $$dirInfo{ExtendedXMP} = $rtn[0]; 1544 $$dirInfo{ExtendedGUID} = $rtn[1]; 1545 # compact if necessary to fit 1546 $compact{NoPadding} = 1 if length($long[-2]) + 101 * $numPadLines > $maxDataLen; 1547 } 1548 $compact{NoPadding} = 1 if $$dirInfo{Compact}; 1549# 1550# close out the XMP, clean up, and return our data 1551# 1552 $long[-2] .= $rdfClose; 1553 $long[-2] .= $xmpClose unless $$et{XMP_NO_XMPMETA}; 1554 1555 # remove the ExifTool members we created 1556 delete $$et{XMP_CAPTURE}; 1557 delete $$et{XMP_NS}; 1558 delete $$et{XMP_NO_XMPMETA}; 1559 1560 # (the XMP standard recommends writing 2k-4k of white space before the 1561 # packet trailer, with a newline every 100 characters) 1562 unless ($$et{XMP_NO_XPACKET}) { 1563 my $pad = (' ' x 100) . "\n"; 1564 # get current XMP length without padding 1565 my $len = length($long[-2]) + length($pktCloseW); 1566 if ($$dirInfo{InPlace} and not ($$dirInfo{InPlace} == 2 and $len > $dirLen)) { 1567 # pad to specified DirLen 1568 if ($len > $dirLen) { 1569 my $str = 'Not enough room to edit XMP in place'; 1570 $str .= '. Try Shorthand feature' unless $compact{Shorthand}; 1571 $et->Warn($str); 1572 return undef; 1573 } 1574 my $num = int(($dirLen - $len) / length($pad)); 1575 if ($num) { 1576 $long[-2] .= $pad x $num; 1577 $len += length($pad) * $num; 1578 } 1579 $len < $dirLen and $long[-2] .= (' ' x ($dirLen - $len - 1)) . "\n"; 1580 } elsif (not $compact{NoPadding} and not $xmpFile and not $$dirInfo{ReadOnly}) { 1581 $long[-2] .= $pad x $numPadLines; 1582 } 1583 $long[-2] .= ($$dirInfo{ReadOnly} ? $pktCloseR : $pktCloseW); 1584 } 1585 # return empty data if no properties exist and this is allowed 1586 unless (%capture or $xmpFile or $$dirInfo{InPlace} or $$dirInfo{NoDelete}) { 1587 $long[-2] = ''; 1588 } 1589 if ($xmpErr) { 1590 if ($xmpFile) { 1591 $et->Error($xmpErr); 1592 return -1; 1593 } 1594 $et->Warn($xmpErr); 1595 return undef; 1596 } 1597 $$et{CHANGED} += $changed; 1598 $debug > 1 and $long[-2] and print $long[-2],"\n"; 1599 return $long[-2] unless $xmpFile; 1600 Write($$dirInfo{OutFile}, $long[-2]) or return -1; 1601 return 1; 1602} 1603 1604 16051; # end 1606 1607__END__ 1608 1609=head1 NAME 1610 1611Image::ExifTool::WriteXMP.pl - Write XMP meta information 1612 1613=head1 SYNOPSIS 1614 1615These routines are autoloaded by Image::ExifTool::XMP. 1616 1617=head1 DESCRIPTION 1618 1619This file contains routines to write XMP metadata. 1620 1621=head1 AUTHOR 1622 1623Copyright 2003-2021, Phil Harvey (philharvey66 at gmail.com) 1624 1625This library is free software; you can redistribute it and/or modify it 1626under the same terms as Perl itself. 1627 1628=head1 SEE ALSO 1629 1630L<Image::ExifTool::XMP(3pm)|Image::ExifTool::XMP>, 1631L<Image::ExifTool(3pm)|Image::ExifTool> 1632 1633=cut 1634