view release on metacpan or  search on metacpan

lib/Image/ExifTool/WriteXMP.pl  view on Meta::CPAN

            # 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+)';
            pos($path) = 0;
            $path =~ m/$pat/g or warn("Internal error: no list index for $tag ($path) ($pat)!\n"), next;
            my $idx = $1;
            my $len = length $1;
            my $pos = pos($path) - $len - ($2 ? length $2 : 0);
            # use sub-indices if necessary 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;
            } elsif (@delPaths) {
                $path = shift @delPaths;
                # make sure new path is unique
                while ($capture{$path}) {
                    last unless $path =~ s/ \d(\d+)$/' '.length($1+1).($1+1)/e;
                }
                next;
            } 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 (@long, @short, @resFlag);
    $long[0] = $long[1] = $short[0] = '';
    if ($$et{XMP_NO_XPACKET}) {
        # write BOM if flag is set
        $long[-2] .= "\xef\xbb\xbf" if $$et{XMP_NO_XPACKET} == 2;
    } else {
        $long[-2] .= $pktOpen;
    }
    $long[-2] .= $xmlOpen if $$et{XMP_IS_XML};
    $long[-2] .= $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;
            $newDesc = 2;   # start with a new description for the extended data
        }
        $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
                unless ($uri) {
                    # (namespace prefix may be empty if trying to write empty XMP structure, forum12384)