#------------------------------------------------------------------------------ # File: WriteXMP.pl # # Description: Write XMP meta information # # Revisions: 12/19/2004 - P. Harvey Created #------------------------------------------------------------------------------ package Image::ExifTool::XMP; use strict; use vars qw(%specialStruct %dateTimeInfo %stdXlatNS); use Image::ExifTool qw(:DataAccess :Utils); sub CheckXMP($$$); sub CaptureXMP($$$;$); sub SetPropertyPath($$;$$$$); my $debug = 0; my $numPadLines = 24; # number of blank padding lines # when writing extended XMP, resources bigger than this get placed in their own # rdf:Description so they can be moved to the extended segments if necessary my $newDescThresh = 10240; # 10 kB # individual resources and namespaces to place last in separate rdf:Description's # so they can be moved to extended XMP segments if required (see Oct. 2008 XMP spec) my %extendedRes = ( 'photoshop:History' => 1, 'xap:Thumbnails' => 1, 'xmp:Thumbnails' => 1, 'crs' => 1, 'crss' => 1, ); my $rdfDesc = 'rdf:Description'; # # packet/xmp/rdf headers and trailers # my $pktOpen = "\n"; my $xmlOpen = "\n"; my $xmpOpenPrefix = "GetNewValue($nv); $et->VerboseValue(($tk ? '+' : '-') . ' XMP-x:XMPToolkit', $tk); ++$$et{CHANGED}; } else { $tk = "Image::ExifTool $Image::ExifTool::VERSION"; } my $str = $tk ? (" x:xmptk='" . EscapeXML($tk) . "'") : ''; return "$xmpOpenPrefix$str>\n"; } #------------------------------------------------------------------------------ # Validate XMP packet and set read or read/write mode # Inputs: 0) XMP data reference, 1) 'r' = read only, 'w' or undef = read/write # Returns: true if XMP is good (and adds packet header/trailer if necessary) sub ValidateXMP($;$) { my ($xmpPt, $mode) = @_; $$xmpPt =~ s/^\s*\s*//s; # remove leading comment if it exists unless ($$xmpPt =~ /^\0*<\0*\?\0*x\0*p\0*a\0*c\0*k\0*e\0*t/) { return '' unless $$xmpPt =~ /^)/$1$mode$3/; substr($$xmpPt, -32, 32) = $end if $2 ne $mode; return 1; } #------------------------------------------------------------------------------ # Check XMP date values for validity and format accordingly # Inputs: 1) date string # Returns: XMP date/time string (or undef on error) sub FormatXMPDate($) { my $val = shift; my ($y, $m, $d, $t, $tz); if ($val =~ /(\d{4}):(\d{2}):(\d{2}) (\d{2}:\d{2}(?::\d{2}(?:\.\d*)?)?)(.*)/) { ($y, $m, $d, $t, $tz) = ($1, $2, $3, $4, $5); $val = "$y-$m-${d}T$t"; } elsif ($val =~ /^\s*\d{4}(:\d{2}){0,2}\s*$/) { # this is just a date (YYYY, YYYY-mm or YYYY-mm-dd) $val =~ tr/:/-/; } elsif ($val =~ /^\s*(\d{2}:\d{2}(?::\d{2}(?:\.\d*)?)?)(.*)\s*$/) { # this is just a time ($t, $tz) = ($1, $2); $val = $t; } else { return undef; } if ($tz) { $tz =~ /^(Z|[+-]\d{2}:\d{2})$/ or return undef; $val .= $tz; } return $val; } #------------------------------------------------------------------------------ # Check XMP values for validity and format accordingly # Inputs: 0) ExifTool object ref, 1) tagInfo hash ref, 2) raw value ref # Returns: error string or undef (and may change value) on success # Note: copies structured information to avoid conflicts with calling code sub CheckXMP($$$) { my ($et, $tagInfo, $valPtr) = @_; if ($$tagInfo{Struct}) { require 'Image/ExifTool/XMPStruct.pl'; my ($item, $err, $w, $warn); unless (ref $$valPtr) { ($$valPtr, $warn) = InflateStruct($valPtr); # expect a structure HASH ref or ARRAY of structures unless (ref $$valPtr) { $$valPtr eq '' and $$valPtr = { }, return undef; # allow empty structures return 'Improperly formed structure'; } } if (ref $$valPtr eq 'ARRAY') { return 'Not a list tag' unless $$tagInfo{List}; my @copy = ( @{$$valPtr} ); # copy the list for ExifTool to use $$valPtr = \@copy; # return the copy foreach $item (@copy) { unless (ref $item eq 'HASH') { ($item, $w) = InflateStruct(\$item); # deserialize structure $w and $warn = $w; next if ref $item eq 'HASH'; $err = 'Improperly formed structure'; last; } ($item, $err) = CheckStruct($et, $item, $$tagInfo{Struct}); last if $err; } } else { ($$valPtr, $err) = CheckStruct($et, $$valPtr, $$tagInfo{Struct}); } $warn and $$et{CHECK_WARN} = $warn; return $err; } my $format = $$tagInfo{Writable}; # (if no format specified, value is a simple string) if (not $format or $format eq 'string' or $format eq 'lang-alt') { # convert value to UTF8 if necessary if ($$et{OPTIONS}{Charset} ne 'UTF8') { if ($$valPtr =~ /[\x80-\xff]/) { # convert from Charset to UTF-8 $$valPtr = $et->Encode($$valPtr,'UTF8'); } } else { # translate invalid XML characters to "." $$valPtr =~ tr/\0-\x08\x0b\x0c\x0e-\x1f/./; # fix any malformed UTF-8 characters if (FixUTF8($valPtr) and not $$et{WarnBadUTF8}) { $et->Warn('Malformed UTF-8 character(s)'); $$et{WarnBadUTF8} = 1; } } return undef; # success } if ($format eq 'rational' or $format eq 'real') { # make sure the value is a valid floating point number unless (Image::ExifTool::IsFloat($$valPtr) or # allow 'inf' and 'undef' rational values ($format eq 'rational' and ($$valPtr eq 'inf' or $$valPtr eq 'undef' or Image::ExifTool::IsRational($$valPtr)))) { return 'Not a floating point number'; } if ($format eq 'rational') { $$valPtr = join('/', Image::ExifTool::Rationalize($$valPtr)); } } elsif ($format eq 'integer') { # make sure the value is integer if (Image::ExifTool::IsInt($$valPtr)) { # no conversion required (converting to 'int' would remove leading '+') } elsif (Image::ExifTool::IsHex($$valPtr)) { $$valPtr = hex($$valPtr); } else { return 'Not an integer'; } } elsif ($format eq 'date') { my $newDate = FormatXMPDate($$valPtr); return "Invalid date/time (use YYYY:mm:dd HH:MM:SS[.ss][+/-HH:MM|Z])" unless $newDate; $$valPtr = $newDate; } elsif ($format eq 'boolean') { if (not $$valPtr or $$valPtr =~ /false/i or $$valPtr =~ /^no$/i) { $$valPtr = 'False'; } else { $$valPtr = 'True'; } } elsif ($format eq '1') { # this is the entire XMP data block return 'Invalid XMP data' unless ValidateXMP($valPtr); } else { return "Unknown XMP format: $format"; } return undef; # success! } #------------------------------------------------------------------------------ # Get PropertyPath for specified tagInfo # Inputs: 0) tagInfo reference # Returns: PropertyPath string sub GetPropertyPath($) { my $tagInfo = shift; SetPropertyPath($$tagInfo{Table}, $$tagInfo{TagID}) unless $$tagInfo{PropertyPath}; return $$tagInfo{PropertyPath}; } #------------------------------------------------------------------------------ # Set PropertyPath for specified tag (also for associated flattened tags and structure elements) # Inputs: 0) tagTable reference, 1) tagID, 2) tagID of parent structure, # 3) structure definition ref (or undef), 4) property list up to this point (or undef), # 5) flag set if any containing structure has a TYPE # Notes: also generates flattened tags if they don't already exist sub SetPropertyPath($$;$$$$) { my ($tagTablePtr, $tagID, $parentID, $structPtr, $propList, $isType) = @_; my $table = $structPtr || $tagTablePtr; my $tagInfo = $$table{$tagID}; my $flatInfo; return if ref($tagInfo) ne 'HASH'; # (shouldn't happen) if ($structPtr) { my $flatID = $parentID . ucfirst($tagID); $flatInfo = $$tagTablePtr{$flatID}; if ($flatInfo) { return if $$flatInfo{PropertyPath}; } else { # flattened tag doesn't exist, so create it now # (could happen if we were just writing a structure) $flatInfo = { Name => ucfirst($flatID), Flat => 1 }; AddTagToTable($tagTablePtr, $flatID, $flatInfo); } $isType = 1 if $$structPtr{TYPE}; } else { # don't override existing main table entry if already set by a Struct return if $$tagInfo{PropertyPath}; # use property path from original tagInfo if this is an alternate-language tag my $srcInfo = $$tagInfo{SrcTagInfo}; $$tagInfo{PropertyPath} = GetPropertyPath($srcInfo) if $srcInfo; return if $$tagInfo{PropertyPath}; # set property path for all flattened tags in structure if necessary if ($$tagInfo{RootTagInfo}) { SetPropertyPath($tagTablePtr, $$tagInfo{RootTagInfo}{TagID}); return if $$tagInfo{PropertyPath}; warn "Internal Error: Didn't set path from root for $tagID\n"; } } my $ns = $$tagInfo{Namespace} || $$table{NAMESPACE}; $ns or warn("No namespace for $tagID\n"), return; my (@propList, $listType); $propList and @propList = @$propList; push @propList, "$ns:$tagID"; # lang-alt lists are handled specially, signified by Writable='lang-alt' if ($$tagInfo{Writable} and $$tagInfo{Writable} eq 'lang-alt') { $listType = 'Alt'; # remove language code from property path if it exists $propList[-1] =~ s/-$$tagInfo{LangCode}$// if $$tagInfo{LangCode}; # handle lists of lang-alt lists (eg. XMP-plus:Custom tags) if ($$tagInfo{List} and $$tagInfo{List} ne '1') { push @propList, "rdf:$$tagInfo{List}", 'rdf:li 10'; } } else { $listType = $$tagInfo{List}; } # add required properties if this is a list push @propList, "rdf:$listType", 'rdf:li 10' if $listType and $listType ne '1'; # set PropertyPath for all flattened tags of this structure if necessary # (note: don't do this for variable-namespace structures (undef NAMESPACE)) my $strTable = $$tagInfo{Struct}; if ($strTable and $$strTable{NAMESPACE} and not ($parentID and # must test NoSubStruct flag to avoid infinite recursion (($$tagTablePtr{$parentID} and $$tagTablePtr{$parentID}{NoSubStruct}) or length $parentID > 500))) # avoid deep recursion { # make sure the structure namespace has been registered # (user-defined namespaces may not have been) RegisterNamespace($strTable) if ref $$strTable{NAMESPACE}; my $tag; foreach $tag (keys %$strTable) { # ignore special fields and any lang-alt fields we may have added next if $specialStruct{$tag} or $$strTable{$tag}{LangCode}; my $fullID = $parentID ? $parentID . ucfirst($tagID) : $tagID; SetPropertyPath($tagTablePtr, $tag, $fullID, $strTable, \@propList, $isType); } } # if this was a structure field and not a normal tag, # we set PropertyPath in the corresponding flattened tag if ($structPtr) { $tagInfo = $flatInfo; # set StructType flag if any containing structure has a TYPE $$tagInfo{StructType} = 1 if $isType; } # set property path for tagInfo in main table $$tagInfo{PropertyPath} = join '/', @propList; } #------------------------------------------------------------------------------ # Save XMP property name/value for rewriting # Inputs: 0) ExifTool object reference # 1) reference to array of XMP property path (last is current property) # 2) property value, 3) optional reference to hash of property attributes sub CaptureXMP($$$;$) { my ($et, $propList, $val, $attrs) = @_; return unless defined $val and @$propList > 2; if ($$propList[0] =~ /^x:x[ma]pmeta$/ and $$propList[1] eq 'rdf:RDF' and $$propList[2] =~ /$rdfDesc( |$)/) { # no properties to save yet if this is just the description return unless @$propList > 3; # ignore empty list properties if ($$propList[-1] =~ /^rdf:(Bag|Seq|Alt)$/) { $et->Warn("Ignored empty $$propList[-1] list for $$propList[-2]", 1); return; } # save information about this property my $capture = $$et{XMP_CAPTURE}; my $path = join('/', @$propList[3..$#$propList]); if (defined $$capture{$path}) { $$et{XMP_ERROR} = "Duplicate XMP property: $path"; } else { $$capture{$path} = [$val, $attrs || { }]; } } elsif ($$propList[0] eq 'rdf:RDF' and $$propList[1] =~ /$rdfDesc( |$)/) { # set flag so we don't write x:xmpmeta element $$et{XMP_NO_XMPMETA} = 1; # add missing x:xmpmeta element and try again unshift @$propList, 'x:xmpmeta'; CaptureXMP($et, $propList, $val, $attrs); } else { $$et{XMP_ERROR} = 'Improperly enclosed XMP property: ' . join('/',@$propList); } } #------------------------------------------------------------------------------ # Save information about resource containing blank node with nodeID # Inputs: 0) reference to blank node information hash # 1) reference to property list # 2) property value # 3) [optional] reference to attribute hash # Notes: This routine and ProcessBlankInfo() are also used for reading information, but # are uncommon so are put in this file to reduce compile time for the common case sub SaveBlankInfo($$$;$) { my ($blankInfo, $propListPt, $val, $attrs) = @_; my $propPath = join '/', @$propListPt; my @ids = ($propPath =~ m{ #([^ /]*)}g); my $id; # split the property path at each nodeID foreach $id (@ids) { my ($pre, $prop, $post) = ($propPath =~ m{^(.*?)/([^/]*) #$id((/.*)?)$}); defined $pre or warn("internal error parsing nodeID's"), next; # the element with the nodeID should be in the path prefix for subject # nodes and the path suffix for object nodes unless ($prop eq $rdfDesc) { if ($post) { $post = "/$prop$post"; } else { $pre = "$pre/$prop"; } } $$blankInfo{Prop}{$id}{Pre}{$pre} = 1; if ((defined $post and length $post) or (defined $val and length $val)) { # save the property value and attributes for each unique path suffix $$blankInfo{Prop}{$id}{Post}{$post} = [ $val, $attrs, $propPath ]; } } } #------------------------------------------------------------------------------ # Process blank-node information # Inputs: 0) ExifTool object ref, 1) tag table ref, # 2) blank node information hash ref, 3) flag set for writing sub ProcessBlankInfo($$$;$) { my ($et, $tagTablePtr, $blankInfo, $isWriting) = @_; $et->VPrint(1, " [Elements with nodeID set:]\n") unless $isWriting; my ($id, $pre, $post); # handle each nodeID separately foreach $id (sort keys %{$$blankInfo{Prop}}) { my $path = $$blankInfo{Prop}{$id}; # flag all resource names so we can warn later if some are unused my %unused; foreach $post (keys %{$$path{Post}}) { $unused{$post} = 1; } # combine property paths for all possible paths through this node foreach $pre (sort keys %{$$path{Pre}}) { # there will be no description for the object of a blank node next unless $pre =~ m{/$rdfDesc/}; foreach $post (sort keys %{$$path{Post}}) { my @propList = split m{/}, "$pre$post"; my ($val, $attrs) = @{$$path{Post}{$post}}; if ($isWriting) { CaptureXMP($et, \@propList, $val, $attrs); } else { FoundXMP($et, $tagTablePtr, \@propList, $val); } delete $unused{$post}; } } # save information from unused properties (if RDF is malformed like f-spot output) if (%unused) { $et->Options('Verbose') and $et->Warn('An XMP resource is about nothing'); foreach $post (sort keys %unused) { my ($val, $attrs, $propPath) = @{$$path{Post}{$post}}; my @propList = split m{/}, $propPath; if ($isWriting) { CaptureXMP($et, \@propList, $val, $attrs); } else { FoundXMP($et, $tagTablePtr, \@propList, $val); } } } } } #------------------------------------------------------------------------------ # Convert path to namespace used in file (this is a pain, but the XMP # spec only suggests 'preferred' namespace prefixes...) # Inputs: 0) ExifTool object reference, 1) property path # Returns: conforming property path sub ConformPathToNamespace($$) { my ($et, $path) = @_; my @propList = split('/',$path); my $nsUsed = $$et{XMP_NS}; my $prop; foreach $prop (@propList) { my ($ns, $tag) = $prop =~ /(.+?):(.*)/; next if $$nsUsed{$ns}; my $uri = $nsURI{$ns}; unless ($uri) { warn "No URI for namepace prefix $ns!\n"; next; } my $ns2; foreach $ns2 (keys %$nsUsed) { next unless $$nsUsed{$ns2} eq $uri; # use the existing namespace prefix instead of ours $prop = "$ns2:$tag"; last; } } return join('/',@propList); } #------------------------------------------------------------------------------ # Add necessary rdf:type element when writing structure # Inputs: 0) ExifTool ref, 1) tag table ref, 2) capture hash ref, 3) path string # 4) optional base path (already conformed to namespace) for elements in # variable-namespace structures sub AddStructType($$$$;$) { my ($et, $tagTablePtr, $capture, $path, $basePath) = @_; my @props = split '/', $path; my %doneID; for (;;) { pop @props; last unless @props; my $tagID = GetXMPTagID(\@props); next if $doneID{$tagID}; $doneID{$tagID} = 1; my $tagInfo = $$tagTablePtr{$tagID}; last unless ref $tagInfo eq 'HASH'; if ($$tagInfo{Struct}) { my $type = $$tagInfo{Struct}{TYPE}; if ($type) { my $pat = $$tagInfo{PropertyPath}; $pat or warn("Missing PropertyPath in AddStructType\n"), last; $pat = ConformPathToNamespace($et, $pat); $pat =~ s/ \d+/ \\d\+/g; $path =~ /^($pat)/ or warn("Wrong path in AddStructType\n"), last; my $p = $1 . '/rdf:type'; $p = "$basePath/$p" if $basePath; $$capture{$p} = [ '', { 'rdf:resource' => $type } ] unless $$capture{$p}; } } last unless $$tagInfo{StructType}; } } #------------------------------------------------------------------------------ # Utility routine to encode data in base64 # Inputs: 0) binary data string, 1) flag to avoid inserting newlines # Returns: base64-encoded string sub EncodeBase64($;$) { # encode the data in 45-byte chunks my $chunkSize = 45; my $len = length $_[0]; my $str = ''; my $i; for ($i=0; $i<$len; $i+=$chunkSize) { my $n = $len - $i; $n = $chunkSize if $n > $chunkSize; # add uuencoded data to output (minus size byte, but including trailing newline) $str .= substr(pack('u', substr($_[0], $i, $n)), 1); } # convert to base64 (remember that "\0" may be encoded as ' ' or '`') $str =~ tr/` -_/AA-Za-z0-9+\//; # convert pad characters at the end (remember to account for trailing newline) my $pad = 3 - ($len % 3); substr($str, -$pad-1, $pad) = ('=' x $pad) if $pad < 3; $str =~ tr/\n//d if $_[1]; # remove newlines if specified return $str; } #------------------------------------------------------------------------------ # sort tagInfo hash references by tag name sub ByTagName { return $$a{Name} cmp $$b{Name}; } #------------------------------------------------------------------------------ # sort alphabetically, but with rdf:type first in the structure sub TypeFirst { if ($a =~ /rdf:type$/) { return substr($a, 0, -8) cmp $b unless $b =~ /rdf:type$/; } elsif ($b =~ /rdf:type$/) { return $a cmp substr($b, 0, -8); } return $a cmp $b; } #------------------------------------------------------------------------------ # Limit size of XMP # Inputs: 0) ExifTool object ref, 1) XMP data ref (written up to start of $rdfClose), # 2) max XMP len, 3) rdf:about string, 4) list ref for description start offsets # 5) start offset of first description recommended for extended XMP # Returns: 0) extended XMP ref, 1) GUID and updates $$dataPt (or undef if no extended XMP) sub LimitXMPSize($$$$$$) { my ($et, $dataPt, $maxLen, $about, $startPt, $extStart) = @_; # return straight away if it isn't too big return undef if length($$dataPt) < $maxLen; push @$startPt, length($$dataPt); # add end offset to list my $newData = substr($$dataPt, 0, $$startPt[0]); my $guid = '0' x 32; # write the required xmpNote:HasExtendedXMP property $newData .= "\n <$rdfDesc rdf:about='$about'\n xmlns:xmpNote='$nsURI{xmpNote}'>\n" . " $guid\n" . " \n"; my ($i, %descSize, $start); # calculate all description block sizes for ($i=1; $i<@$startPt; ++$i) { $descSize{$$startPt[$i-1]} = $$startPt[$i] - $$startPt[$i-1]; } pop @$startPt; # remove end offset # write the descriptions from smallest to largest, as many in main XMP as possible my @descStart = sort { $descSize{$a} <=> $descSize{$b} } @$startPt; my $extData = XMPOpen($et) . $rdfOpen; for ($i=0; $i<2; ++$i) { foreach $start (@descStart) { # write main XMP first (in order of size), then extended XMP afterwards (in order) next if $i xor $start >= $extStart; my $pt = (length($newData) + $descSize{$start} > $maxLen) ? \$extData : \$newData; $$pt .= substr($$dataPt, $start, $descSize{$start}); } } $extData .= $rdfClose . $xmpClose; # close rdf:RDF and x:xmpmeta # calculate GUID from MD5 of extended XMP data if (eval { require Digest::MD5 }) { $guid = uc unpack('H*', Digest::MD5::md5($extData)); $newData =~ s/0{32}/$guid/; # update GUID in main XMP segment } $et->VerboseValue('+ XMP-xmpNote:HasExtendedXMP', $guid); $$dataPt = $newData; # return main XMP block return (\$extData, $guid); # return extended XMP and its GUID } #------------------------------------------------------------------------------ # Write XMP information # Inputs: 0) ExifTool object reference, 1) source dirInfo reference, # 2) [optional] tag table reference # Returns: with tag table: new XMP data (may be empty if no XMP data) or undef on error # without tag table: 1 on success, 0 if not valid XMP file, -1 on write error # Notes: May set dirInfo InPlace flag to rewrite with specified DirLen # May set dirInfo ReadOnly flag to write as read-only XMP ('r' mode and no padding) # May set dirInfo Compact flag to force compact (drops 2kB of padding) # May set dirInfo MaxDataLen to limit output data length -- this causes ExtendedXMP # and ExtendedGUID to be returned in dirInfo if extended XMP was required sub WriteXMP($$;$) { my ($et, $dirInfo, $tagTablePtr) = @_; $et or return 1; # allow dummy access to autoload this package my $dataPt = $$dirInfo{DataPt}; my (%capture, %nsUsed, $xmpErr, $tagInfo, $about); my $changed = 0; my $xmpFile = (not $tagTablePtr); # this is an XMP data file if no $tagTablePtr # prefer XMP over other metadata formats in some types of files my $preferred = $xmpFile || ($$et{PreferredGroup} and $$et{PreferredGroup} eq 'XMP'); my $verbose = $et->Options('Verbose'); my $dirLen = $$dirInfo{DirLen}; $dirLen = length($$dataPt) if not defined $dirLen and $dataPt; # # extract existing XMP information into %capture hash # # define hash in ExifTool object to capture XMP information (also causes # CaptureXMP() instead of FoundXMP() to be called from ParseXMPElement()) # # The %capture hash is keyed on the complete property path beginning after # rdf:RDF/rdf:Description/. The values are array references with the # following entries: 0) value, 1) attribute hash reference. $$et{XMP_CAPTURE} = \%capture; $$et{XMP_NS} = \%nsUsed; delete $$et{XMP_NO_XMPMETA}; delete $$et{XMP_NO_XPACKET}; delete $$et{XMP_IS_XML}; delete $$et{XMP_IS_SVG}; if ($xmpFile or $dirLen) { delete $$et{XMP_ERROR}; delete $$et{XMP_ABOUT}; # extract all existing XMP information (to the XMP_CAPTURE hash) my $success = ProcessXMP($et, $dirInfo, $tagTablePtr); # don't continue if there is nothing to parse or if we had a parsing error unless ($success and not $$et{XMP_ERROR}) { my $err = $$et{XMP_ERROR} || 'Error parsing XMP'; # may ignore this error only if we were successful if ($xmpFile) { my $raf = $$dirInfo{RAF}; # allow empty XMP data so we can create something from nothing if ($success or not $raf->Seek(0,2) or $raf->Tell()) { # no error message if not an XMP file return 0 unless $$et{XMP_ERROR}; if ($et->Error($err, $success)) { delete $$et{XMP_CAPTURE}; return 0; } } } else { if ($et->Warn($err, $success)) { delete $$et{XMP_CAPTURE}; return undef; } } } $tagInfo = $Image::ExifTool::XMP::rdf{about}; if (defined $$et{NEW_VALUE}{$tagInfo}) { $about = $et->GetNewValue($$et{NEW_VALUE}{$tagInfo}) || ''; if ($verbose > 1) { my $wasAbout = $$et{XMP_ABOUT}; $et->VerboseValue('- XMP-rdf:About', UnescapeXML($wasAbout)) if defined $wasAbout; $et->VerboseValue('+ XMP-rdf:About', $about); } $about = EscapeXML($about); # must escape for XML ++$changed; } else { $about = $$et{XMP_ABOUT} || ''; } delete $$et{XMP_ERROR}; delete $$et{XMP_ABOUT}; } else { $about = ''; } # # handle writing XMP as a block to XMP file # if ($xmpFile) { $tagInfo = $Image::ExifTool::Extra{XMP}; if ($tagInfo and $$et{NEW_VALUE}{$tagInfo}) { my $rtnVal = 1; my $newVal = $et->GetNewValue($$et{NEW_VALUE}{$tagInfo}); if (defined $newVal and length $newVal) { $et->VPrint(0, " Writing XMP as a block\n"); ++$$et{CHANGED}; Write($$dirInfo{OutFile}, $newVal) or $rtnVal = -1; } delete $$et{XMP_CAPTURE}; return $rtnVal; } } # # delete groups in family 1 if requested # if (%{$$et{DEL_GROUP}} and (grep /^XMP-.+$/, keys %{$$et{DEL_GROUP}} or # (logic is a bit more complex for group names in exiftool XML files) grep m{^http://ns.exiftool.ca/}, values %nsUsed)) { my $del = $$et{DEL_GROUP}; my $path; foreach $path (keys %capture) { my @propList = split('/',$path); # get property list my ($tag, $ns) = GetXMPTagID(\@propList); # translate namespace if necessary $ns = $stdXlatNS{$ns} if $stdXlatNS{$ns}; my ($grp, @g); # no "XMP-" added to most groups in exiftool RDF/XML output file if ($nsUsed{$ns} and (@g = ($nsUsed{$ns} =~ m{^http://ns.exiftool.ca/(.*?)/(.*?)/}))) { if ($g[1] =~ /^\d/) { $grp = "XML-$g[0]"; #(all XML-* groups stored as uppercase DEL_GROUP key) my $ucg = uc $grp; next unless $$del{$ucg} or ($$del{'XML-*'} and not $$del{"-$ucg"}); } else { $grp = $g[1]; next unless $$del{$grp} or ($$del{$g[0]} and not $$del{"-$grp"}); } } else { $grp = "XMP-$ns"; my $ucg = uc $grp; next unless $$del{$ucg} or ($$del{'XMP-*'} and not $$del{"-$ucg"}); } $et->VerboseValue("- $grp:$tag", $capture{$path}->[0]); delete $capture{$path}; ++$changed; } } # delete HasExtendedXMP tag (we create it as needed) my $hasExtTag = 'xmpNote:HasExtendedXMP'; if ($capture{$hasExtTag}) { $et->VerboseValue("- XMP-$hasExtTag", $capture{$hasExtTag}->[0]); delete $capture{$hasExtTag}; } # set $xmpOpen now to to handle xmptk tag first my $xmpOpen = $$et{XMP_NO_XMPMETA} ? '' : XMPOpen($et); # # add, delete or change information as specified # # get hash of all information we want to change # (sorted by tag name so alternate languages come last, but with structures # first so flattened tags may be used to override individual structure elements) my @tagInfoList; foreach $tagInfo (sort ByTagName $et->GetNewTagInfoList()) { next unless $et->GetGroup($tagInfo, 0) eq 'XMP'; next if $$tagInfo{Name} eq 'XMP'; # (ignore full XMP block if we didn't write it already) if ($$tagInfo{Struct}) { unshift @tagInfoList, $tagInfo; } else { push @tagInfoList, $tagInfo; } } foreach $tagInfo (@tagInfoList) { my $tag = $$tagInfo{TagID}; my $path = GetPropertyPath($tagInfo); unless ($path) { $et->Warn("Can't write XMP:$tag (namespace unknown)"); next; } # skip tags that were handled specially if ($path eq 'rdf:about' or $path eq 'x:xmptk') { ++$changed; next; } my $isStruct = $$tagInfo{Struct}; # change our property path namespace prefixes to conform # to the ones used in this file $path = ConformPathToNamespace($et, $path); # find existing property my $cap = $capture{$path}; # MicrosoftPhoto screws up the case of some tags, and some other software, # including Adobe software, has been known to write the wrong list type or # not properly enclose properties in a list, so we check for this until ($cap) { # find and fix all incorrect property names if this is a structure or a flattened tag my @fixInfo; if ($isStruct or defined $$tagInfo{Flat}) { # get tagInfo for all containing (possibly nested) structures my @props = split '/', $path; my $tbl = $$tagInfo{Table}; while (@props) { my $info = $$tbl{GetXMPTagID(\@props)}; unshift @fixInfo, $info if ref $info eq 'HASH' and $$info{Struct} and (not @fixInfo or $fixInfo[0] ne $info); pop @props; } $et->WarnOnce("Error finding parent structure for $$tagInfo{Name}") unless @fixInfo; } # fix property path for this tag (last in the @fixInfo list) push @fixInfo, $tagInfo unless @fixInfo and $isStruct; # start from outermost containing structure, fixing incorrect list types, etc, # finally fixing the actual tag properties after all containing structures my $err; while (@fixInfo) { my $fixInfo = shift @fixInfo; my $fixPath = ConformPathToNamespace($et, GetPropertyPath($fixInfo)); my $regex = quotemeta($fixPath); $regex =~ s/ \d+/ \\d\+/g; # match any list index my $ok = $regex; my ($ok2, $match, $i, @fixed, %fixed, $fixed); # check for incorrect list types if ($regex =~ s{\\/rdf\\:(Bag|Seq|Alt)\\/}{/rdf:(Bag|Seq|Alt)/}g) { # also look for missing bottom-level list if ($regex =~ s{/rdf:\(Bag\|Seq\|Alt\)\/rdf\\:li\\ \\d\+$}{}) { $regex .= '(/.*)?' unless @fixInfo; } } elsif (not @fixInfo) { $ok2 = $regex; # check for properties in lists that shouldn't be (ref forum4325) $regex .= '(/rdf:(Bag|Seq|Alt)/rdf:li \d+)?'; } if (@fixInfo) { $regex .= '(/.*)?'; $ok .= '(/.*)?'; } my @matches = sort grep m{^$regex$}i, keys %capture; last unless @matches; if ($matches[0] =~ m{^$ok$}) { unless (@fixInfo) { $path = $matches[0]; $cap = $capture{$path}; } next; } # needs fixing... my @fixProps = split '/', $fixPath; foreach $match (@matches) { my @matchProps = split '/', $match; # remove superfluous list properties if necessary $#matchProps = $#fixProps if $ok2 and $#matchProps > $#fixProps; for ($i=0; $i<@fixProps; ++$i) { defined $matchProps[$i] or $matchProps[$i] = $fixProps[$i], next; next if $matchProps[$i] =~ / \d+$/ or $matchProps[$i] eq $fixProps[$i]; $matchProps[$i] = $fixProps[$i]; } $fixed = join '/', @matchProps; $err = 1 if $fixed{$fixed} or ($capture{$fixed} and $match ne $fixed); push @fixed, $fixed; $fixed{$fixed} = 1; } my $tg = $et->GetGroup($fixInfo, 1) . ':' . $$fixInfo{Name}; my $wrn = lc($fixed[0]) eq lc($matches[0]) ? 'tag ID case' : 'list type'; if ($err) { $et->Warn("Incorrect $wrn for existing $tg (not changed)"); } else { # fix the incorrect property paths for all values of this tag my $didFix; foreach $fixed (@fixed) { my $match = shift @matches; next if $fixed eq $match; $capture{$fixed} = $capture{$match}; delete $capture{$match}; # remove xml:lang attribute from incorrect lang-alt list if necessary delete $capture{$fixed}[1]{'xml:lang'} if $ok2 and $match !~ /^$ok2$/; $didFix = 1; } $cap = $capture{$path} || $capture{$fixed[0]} unless @fixInfo; if ($didFix) { $et->Warn("Fixed incorrect $wrn for $tg", 1); ++$changed; } } } last; } my $nvHash = $et->GetNewValueHash($tagInfo); my $overwrite = $et->IsOverwriting($nvHash); my $writable = $$tagInfo{Writable} || ''; my (%attrs, $deleted, $added, $existed); # delete existing entry if necessary if ($isStruct) { require 'Image/ExifTool/XMPStruct.pl'; ($deleted, $added, $existed) = DeleteStruct($et, \%capture, \$path, $nvHash, \$changed); next unless $deleted or $added or $et->IsOverwriting($nvHash); next if $existed and $$nvHash{CreateOnly}; } elsif ($cap) { next if $$nvHash{CreateOnly}; # (necessary for List-type tags) # take attributes from old values if they exist %attrs = %{$$cap[1]}; if ($overwrite) { my ($delPath, $oldLang, $delLang, $addLang, @matchingPaths); # check to see if this is an indexed list item if ($path =~ / /) { my $pp; ($pp = $path) =~ s/ \d+/ \\d\+/g; @matchingPaths = sort grep(/^$pp$/, keys %capture); } else { push @matchingPaths, $path; } foreach $path (@matchingPaths) { my ($val, $attrs) = @{$capture{$path}}; if ($writable eq 'lang-alt') { unless (defined $addLang) { # add to lang-alt list by default if creating this tag from scratch $addLang = $$nvHash{IsCreating} ? 1 : 0; } # get original language code (lc for comparisons) $oldLang = lc($$attrs{'xml:lang'} || 'x-default'); if ($overwrite < 0) { my $newLang = lc($$tagInfo{LangCode} || 'x-default'); next unless $oldLang eq $newLang; # only add new tag if we are overwriting this one # (note: this won't match if original XML contains CDATA!) $addLang = $et->IsOverwriting($nvHash, UnescapeXML($val)); next unless $addLang; } # delete all if deleting "x-default" and writing with no LangCode # (XMP spec requires x-default language exist and be first in list) if ($oldLang eq 'x-default' and not $$tagInfo{LangCode}) { $delLang = 1; # delete all languages $overwrite = 1; # force overwrite } elsif ($$tagInfo{LangCode} and not $delLang) { # only overwrite specified language next unless lc($$tagInfo{LangCode}) eq $oldLang; } } elsif ($overwrite < 0) { # only overwrite specific values if ($$nvHash{Shift}) { # values to be shifted are checked (hence re-formatted) late, # so we must un-format the to-be-shifted value for IsOverwriting() my $fmt = $$tagInfo{Writable} || ''; if ($fmt eq 'rational') { ConvertRational($val); } elsif ($fmt eq 'date') { $val = ConvertXMPDate($val); } } # (note: this won't match if original XML contains CDATA!) next unless $et->IsOverwriting($nvHash, UnescapeXML($val)); } if ($verbose > 1) { my $grp = $et->GetGroup($tagInfo, 1); my $tagName = $$tagInfo{Name}; $tagName =~ s/-$$tagInfo{LangCode}$// if $$tagInfo{LangCode}; $tagName .= '-' . $$attrs{'xml:lang'} if $$attrs{'xml:lang'}; $et->VerboseValue("- $grp:$tagName", $val); } # save attributes and path from first deleted property # so we can replace it exactly unless ($delPath) { %attrs = %$attrs; $delPath = $path; } # delete this tag delete $capture{$path}; ++$changed; # delete rdf:type tag if it is the only thing left in this structure if ($path =~ /^(.*)\// and $capture{"$1/rdf:type"}) { my $pp = $1; my @a = grep /^\Q$pp\E\/[^\/]+/, keys %capture; delete $capture{"$pp/rdf:type"} if @a == 1; } } next unless $delPath or $$tagInfo{List} or $addLang; if ($delPath) { $path = $delPath; $deleted = 1; } else { # don't change tag if we couldn't delete old copy # unless this is a list or an lang-alt tag next unless $$tagInfo{List} or $oldLang; # (match last index to put in same lang-alt list for Bag of lang-alt items) $path =~ m/.* (\d+)/g or warn "Internal error: no list index!\n", next; $added = $1; } } else { # we are never overwriting, so we must be adding to a list # match the last index unless this is a list of lang-alt lists my $pat = $writable eq 'lang-alt' ? '.* (\d+)(.*? \d+)' : '.* (\d+)'; if ($path =~ m/$pat/g) { $added = $1; # set position to end of matching index number pos($path) = pos($path) - length($2) if $2; } } if (defined $added) { my $len = length $added; my $pos = pos($path) - $len; my $nxt = substr($added, 1) + 1; # always insert x-default lang-alt entry first (as per XMP spec) # (need to test $overwrite because this will be a new lang-alt entry otherwise) if ($overwrite and $writable eq 'lang-alt' and (not $$tagInfo{LangCode} or $$tagInfo{LangCode} eq 'x-default')) { my $saveCap = $capture{$path}; for (;;) { my $p = $path; substr($p, $pos, $len) = length($nxt) . $nxt; # increment index in the path of the existing item my $nextCap = $capture{$p}; $capture{$p} = $saveCap; last unless $nextCap; $saveCap = $nextCap; ++$nxt; } } else { # add to end of list for (;;) { my $try = length($nxt) . $nxt; substr($path, $pos, $len) = $try; last unless $capture{$path}; $len = length $try; ++$nxt; } } } } # check to see if we want to create this tag # (create non-avoided tags in XMP data files by default) my $isCreating = ($$nvHash{IsCreating} or (($isStruct or ($preferred and not $$tagInfo{Avoid} and not defined $$nvHash{Shift})) and not $$nvHash{EditOnly})); # don't add new values unless... # ...tag existed before and was deleted, or we added it to a list next unless $deleted or defined $added or # ...tag didn't exist before and we are creating it (not $cap and $isCreating); # get list of new values (all done if no new values specified) my @newValues = $et->GetNewValue($nvHash) or next; # set language attribute for lang-alt lists $attrs{'xml:lang'} = $$tagInfo{LangCode} || 'x-default' if $writable eq 'lang-alt'; # add new value(s) to %capture hash my $subIdx; for (;;) { my $newValue = shift @newValues; if ($isStruct) { ++$changed if AddNewStruct($et, $tagInfo, \%capture, $path, $newValue, $$tagInfo{Struct}); } else { $newValue = EscapeXML($newValue); for (;;) { # (a cheap 'goto') if ($$tagInfo{Resource}) { # only store as a resource if it doesn't contain any illegal characters if ($newValue !~ /[^a-z0-9\:\/\?\#\[\]\@\!\$\&\'\(\)\*\+\,\;\=\.\-\_\~]/i) { $capture{$path} = [ '', { %attrs, 'rdf:resource' => $newValue } ]; last; } my $grp = $et->GetGroup($tagInfo, 1); $et->Warn("$grp:$$tagInfo{Name} written as a literal because value is not a valid URI", 1); # fall through to write as a string literal } delete $attrs{'rdf:resource'}; # (remove existing resource if necessary) $capture{$path} = [ $newValue, \%attrs ]; last; } if ($verbose > 1) { my $grp = $et->GetGroup($tagInfo, 1); $et->VerboseValue("+ $grp:$$tagInfo{Name}", $newValue); } ++$changed; # add rdf:type if necessary if ($$tagInfo{StructType}) { AddStructType($et, $$tagInfo{Table}, \%capture, $path); } } last unless @newValues; # match last index except for lang-alt items where we want to put each # item in a different lang-alt list (so match the 2nd-last for these) my $pat = $writable eq 'lang-alt' ? '.* (\d+)(.*? \d+)' : '.* (\d+)'; $path =~ m/$pat/g or warn("Internal error: no list index for $tag!\n"), next; my $idx = $1; my $len = length $1; my $pos = pos($path) - $len - ($2 ? length $2 : 0); # generate unique list sub-indices to store additional values in sequence if ($subIdx) { $idx = substr($idx, 0, -length($subIdx)); # remove old sub-index $subIdx = substr($subIdx, 1) + 1; $subIdx = length($subIdx) . $subIdx; } else { $subIdx = '10'; } substr($path, $pos, $len) = $idx . $subIdx; } # make sure any empty structures are deleted # (ExifTool shouldn't write these, but other software may) if (defined $$tagInfo{Flat}) { my $p = $path; while ($p =~ s/\/[^\/]+$//) { next unless $capture{$p}; # it is an error if this property has a value $et->Error("Improperly structured XMP ($p)",1) if $capture{$p}[0] =~ /\S/; delete $capture{$p}; # delete the (hopefully) empty structure } } } # remove the ExifTool members we created delete $$et{XMP_CAPTURE}; delete $$et{XMP_NS}; my $maxDataLen = $$dirInfo{MaxDataLen}; # get DataPt again because it may have been set by ProcessXMP $dataPt = $$dirInfo{DataPt}; # return now if we didn't change anything unless ($changed or ($maxDataLen and $dataPt and defined $$dataPt and length($$dataPt) > $maxDataLen)) { return undef unless $xmpFile; # just rewrite original XMP Write($$dirInfo{OutFile}, $$dataPt) or return -1 if $dataPt and defined $$dataPt; return 1; } # # write out the new XMP information (serialize it) # # start writing the XMP data my $newData = ''; if ($$et{XMP_NO_XPACKET}) { # write BOM if flag is set $newData .= "\xef\xbb\xbf" if $$et{XMP_NO_XPACKET} == 2; } else { $newData .= $pktOpen; } $newData .= $xmlOpen if $$et{XMP_IS_XML}; $newData .= $xmpOpen . $rdfOpen; # initialize current property path list my (@curPropList, @writeLast, @descStart, $extStart); my (%nsCur, $prop, $n, $path); my @pathList = sort TypeFirst keys %capture; # order properties to write large values last if we have a MaxDataLen limit if ($maxDataLen and @pathList) { my @pathTmp; my ($lastProp, $lastNS, $propSize) = ('', '', 0); my @pathLoop = (@pathList, ''); # add empty path to end of list for loop undef @pathList; foreach $path (@pathLoop) { $path =~ /^((\w*)[^\/]*)/; # get path element ($1) and ns ($2) if ($1 eq $lastProp) { push @pathTmp, $path; # accumulate all paths with same root } else { # put in list to write last if recommended or values are too large if ($extendedRes{$lastProp} or $extendedRes{$lastNS} or $propSize > $newDescThresh) { push @writeLast, @pathTmp; } else { push @pathList, @pathTmp; } last unless $path; # all done if we hit empty path @pathTmp = ( $path ); ($lastProp, $lastNS, $propSize) = ($1, $2, 0); } $propSize += length $capture{$path}->[0]; } } # write out all properties for (;;) { my (%nsNew, $newDesc); unless (@pathList) { last unless @writeLast; @pathList = @writeLast; undef @writeLast; $extStart = length $newData; $newDesc = 1; # start with a new description } $path = shift @pathList; my @propList = split('/',$path); # get property list # must open/close rdf:Description too unshift @propList, $rdfDesc; # make sure we have defined all necessary namespaces foreach $prop (@propList) { $prop =~ /(.*):/ or next; $1 eq 'rdf' and next; # rdf namespace already defined my $uri = $nsUsed{$1}; unless ($uri) { $uri = $nsURI{$1}; # we must have added a namespace $uri or $xmpErr = "Undefined XMP namespace: $1", next; } $nsNew{$1} = $uri; # need a new description if any new namespaces $newDesc = 1 unless $nsCur{$1}; } my $closeTo = 0; if ($newDesc) { # look forward to see if we will want to also open other namespaces # at this level (this is necessary to keep lists and structures from # being broken if a property introduces a new namespace; plus it # improves formatting) my ($path2, $ns2); foreach $path2 (@pathList) { my @ns2s = ($path2 =~ m{(?:^|/)([^/]+?):}g); my $opening = 0; foreach $ns2 (@ns2s) { next if $ns2 eq 'rdf'; $nsNew{$ns2} and ++$opening, next; last unless $opening; # get URI for this existing or new namespace my $uri = $nsUsed{$ns2} || $nsURI{$ns2} or last; $nsNew{$ns2} = $uri; # also open this namespace } last unless $opening; } } else { # find first property where the current path differs from the new path for ($closeTo=0; $closeTo<@curPropList; ++$closeTo) { last unless $closeTo < @propList; last unless $propList[$closeTo] eq $curPropList[$closeTo]; } } # close out properties down to the common base path while (@curPropList > $closeTo) { ($prop = pop @curPropList) =~ s/ .*//; $newData .= (' ' x scalar(@curPropList)) . " \n"; } if ($newDesc) { # save rdf:Description start positions so we can reorder them if necessary push @descStart, length($newData) if $maxDataLen; # open the new description $prop = $rdfDesc; %nsCur = %nsNew; # save current namespaces $newData .= "\n <$prop rdf:about='$about'"; my @ns = sort keys %nsCur; # generate et:toolkit attribute if this is an exiftool RDF/XML output file if (@ns and $nsCur{$ns[0]} =~ m{^http://ns.exiftool.ca/}) { $newData .= "\n xmlns:et='http://ns.exiftool.ca/1.0/'" . " et:toolkit='Image::ExifTool $Image::ExifTool::VERSION'"; } foreach (@ns) { $newData .= "\n xmlns:$_='$nsCur{$_}'"; } $newData .= ">\n"; push @curPropList, $prop; } # loop over all values for this new property my ($val, $attrs) = @{$capture{$path}}; $debug and print "$path = $val\n"; # open new properties my ($attr, $dummy); for ($n=@curPropList; $n<$#propList; ++$n) { $prop = $propList[$n]; push @curPropList, $prop; # remove list index if it exists $prop =~ s/ .*//; $attr = ''; if ($prop ne $rdfDesc and ($propList[$n+1] !~ /^rdf:/ or ($propList[$n+1] eq 'rdf:type' and $n+1 == $#propList))) { # need parseType='Resource' to avoid new 'rdf:Description' $attr = " rdf:parseType='Resource'"; # check for empty structure if ($propList[$n+1] =~ /:~dummy~$/) { $newData .= (' ' x scalar(@curPropList)) . "<$prop$attr/>\n"; pop @curPropList; $dummy = 1; last; } } $newData .= (' ' x scalar(@curPropList)) . "<$prop$attr>\n"; } my $prop2 = pop @propList; # get new property name # add element unless it was a dummy structure field unless ($dummy or ($val eq '' and $prop2 =~ /:~dummy~$/)) { $prop2 =~ s/ .*//; # remove list index if it exists $newData .= (' ' x scalar(@curPropList)) . " <$prop2"; # write out attributes foreach $attr (sort keys %$attrs) { my $attrVal = $$attrs{$attr}; my $quot = ($attrVal =~ /'/) ? '"' : "'"; $newData .= " $attr=$quot$attrVal$quot"; } $newData .= length $val ? ">$val\n" : "/>\n"; } } # close off any open elements while ($prop = pop @curPropList) { $prop =~ s/ .*//; # remove list index if it exists $newData .= (' ' x scalar(@curPropList)) . " \n"; } # limit XMP length and re-arrange if necessary to fit inside specified size my $compact = $$dirInfo{Compact} || $et->Options('Compact'); if ($maxDataLen) { # adjust maxDataLen to allow room for closing elements $maxDataLen -= length($rdfClose) + length($xmpClose) + length($pktCloseW); $extStart or $extStart = length $newData; my @rtn = LimitXMPSize($et, \$newData, $maxDataLen, $about, \@descStart, $extStart); # return extended XMP information in $dirInfo $$dirInfo{ExtendedXMP} = $rtn[0]; $$dirInfo{ExtendedGUID} = $rtn[1]; # compact if necessary to fit $compact = 1 if length($newData) + 101 * $numPadLines > $maxDataLen; } # # close out the XMP, clean up, and return our data # $newData .= $rdfClose; $newData .= $xmpClose unless $$et{XMP_NO_XMPMETA}; # remove the ExifTool members we created delete $$et{XMP_CAPTURE}; delete $$et{XMP_NS}; delete $$et{XMP_NO_XMPMETA}; # (the XMP standard recommends writing 2k-4k of white space before the # packet trailer, with a newline every 100 characters) unless ($$et{XMP_NO_XPACKET}) { my $pad = (' ' x 100) . "\n"; if ($$dirInfo{InPlace}) { # pad to specified DirLen my $len = length($newData) + length($pktCloseW); if ($len > $dirLen) { $et->Warn('Not enough room to edit XMP in place'); return undef; } my $num = int(($dirLen - $len) / length($pad)); if ($num) { $newData .= $pad x $num; $len += length($pad) * $num; } $len < $dirLen and $newData .= (' ' x ($dirLen - $len - 1)) . "\n"; } elsif (not $compact and not $xmpFile and not $$dirInfo{ReadOnly}) { $newData .= $pad x $numPadLines; } $newData .= ($$dirInfo{ReadOnly} ? $pktCloseR : $pktCloseW); } # return empty data if no properties exist and this is allowed unless (%capture or $xmpFile or $$dirInfo{InPlace} or $$dirInfo{NoDelete}) { $newData = ''; } if ($xmpErr) { if ($xmpFile) { $et->Error($xmpErr); return -1; } $et->Warn($xmpErr); return undef; } $$et{CHANGED} += $changed; $debug > 1 and $newData and print $newData,"\n"; return $newData unless $xmpFile; Write($$dirInfo{OutFile}, $newData) or return -1; return 1; } 1; # end __END__ =head1 NAME Image::ExifTool::WriteXMP.pl - Write XMP meta information =head1 SYNOPSIS These routines are autoloaded by Image::ExifTool::XMP. =head1 DESCRIPTION This file contains routines to write XMP metadata. =head1 AUTHOR Copyright 2003-2016, Phil Harvey (phil at owl.phy.queensu.ca) This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L =cut