/usr/share/perl5/Image/ExifTool/WritePDF.pl

#------------------------------------------------------------------------------
# File:         WritePDF.pl
#
# Description:  Write PDF meta information
#
# Revisions:    12/08/2007 - P. Harvey Created
#
# References:   1) http://partners.adobe.com/public/developer/pdf/index_reference.html
#
# Notes:        The special "PDF-update" group can be deleted to revert exiftool updates
#------------------------------------------------------------------------------
package Image::ExifTool::PDF;

use strict;
use vars qw($lastFetched);

sub WriteObject($$);
sub EncodeString($);
sub CryptObject($);

# comments to mark beginning and end of ExifTool incremental update
my $beginComment = '%BeginExifToolUpdate';
my $endComment   = '%EndExifToolUpdate ';

my $keyExt;     # crypt key extension
my $pdfVer;     # version of PDF file we are currently writing

# internal tags used in dictionary objects
my %myDictTags = (
    _tags => 1, _stream => 1, _decrypted => 1, _needCrypt => 1,
    _filtered => 1, _entry_size => 1, _table => 1,
);

# map for directories that we can add
my %pdfMap = (
    XMP => 'PDF',
);

#------------------------------------------------------------------------------
# Validate raw PDF values for writing (string date integer real boolean name)
# Inputs: 0) ExifTool object ref, 1) tagInfo hash ref, 2) raw value ref
# Returns: error string or undef (and possibly changes value) on success
sub CheckPDF($$$)
{
    my ($et, $tagInfo, $valPtr) = @_;
    my $format = $$tagInfo{Writable} || $tagInfo->{Table}->{WRITABLE};
    if (not $format) {
        return 'No writable format';
    } elsif ($format eq 'string') {
        # (encode later because list-type string tags need to be encoded as a unit)
    } elsif ($format eq 'date') {
        # be flexible about this for now
        return 'Bad date format' unless $$valPtr =~ /^\d{4}/;
    } elsif ($format eq 'integer') {
        return 'Not an integer' unless Image::ExifTool::IsInt($$valPtr);
    } elsif ($format eq 'real') {
        return 'Not a real number' unless $$valPtr =~ /^[+-]?(?=\d|\.\d)\d*(\.\d*)?$/;
    } elsif ($format eq 'boolean') {
        $$valPtr = ($$valPtr and $$valPtr !~ /^f/i) ? 'true' : 'false';
    } elsif ($format eq 'name') {
        return 'Invalid PDF name' if $$valPtr =~ /\0/;
    } else {
        return "Invalid PDF format '${format}'";
    }
    return undef;   # value is OK
}

#------------------------------------------------------------------------------
# Format value for writing to PDF file
# Inputs: 0) ExifTool ref, 1) value, 2) format string (string,date,integer,real,boolean,name)
# Returns: formatted value or undef on error
# Notes: Called at write time, so $pdfVer may be checked
sub WritePDFValue($$$)
{
    my ($et, $val, $format) = @_;
    if (not $format) {
        return undef;
    } elsif ($format eq 'string') {
        # encode as UCS2 if it contains any special characters
        $val = "\xfe\xff" . $et->Encode($val,'UCS2','MM') if $val =~ /[\x80-\xff]/;
        EncodeString(\$val);
    } elsif ($format eq 'date') {
        # convert date to "D:YYYYmmddHHMMSS+-HH'MM'" format
        $val =~ s/([-+]\d{2}):(\d{2})/${1}'${2}'/;  # change timezone delimiters if necessary
        $val =~ tr/ ://d;                       # remove spaces and colons
        $val =  "D:$val";                       # add leading "D:"
        EncodeString(\$val);
    } elsif ($format =~ /^(integer|real|boolean)$/) {
        # no reformatting necessary
    } elsif ($format eq 'name') {
        return undef if $val =~ /\0/;
        if ($pdfVer >= 1.2) {
            $val =~ s/([\t\n\f\r ()<>[\]{}\/%#])/sprintf('#%.2x',ord $1)/sge;
        } else {
            return undef if $val =~ /[\t\n\f\r ()<>[\]{}\/%]/;
        }
        $val = "/$val"; # add leading '/'
    } else {
        return undef;
    }
    return $val;
}

#------------------------------------------------------------------------------
# Encode PDF string
# Inputs: 0) reference to PDF string
# Returns: (updates string with encoded data)
sub EncodeString($)
{
    my $strPt = shift;
    if (ref $$strPt eq 'ARRAY') {
        my $str;
        foreach $str (@{$$strPt}) {
            EncodeString(\$str);
        }
        return;
    }
    Crypt($strPt, $keyExt, 1);  # encrypt if necessary
    # encode as hex if we have any control characters (except tab)
    if ($$strPt=~/[\x00-\x08\x0a-\x1f\x7f\xff]/) {
        # encode as hex
        my $str='';
        my $len = length $$strPt;
        my $i = 0;
        for (;;) {
            my $n = $len - $i or last;
            $n = 40 if $n > 40; # break into reasonable-length lines
            $str .= $/ if $i;
            $str .= unpack('H*', substr($$strPt, $i, $n));
            $i += $n;
        }
        $$strPt = "<$str>";
    } else {
        $$strPt =~ s/([()\\])/\\$1/g;   # must escape round brackets and backslashes
        $$strPt = "($$strPt)";
    }
}

#------------------------------------------------------------------------------
# Encrypt an object
# Inputs: 0) PDF object (encrypts in place)
# Notes: Encrypts according to "_needCrypt" dictionary entry,
#        then deletes "_needCrypt" when done
sub CryptObject($)
{
    my $obj = $_[0];
    if (not ref $obj) {
        # only literal strings and hex strings are encrypted
        if ($obj =~ /^[(<]/) {
            undef $lastFetched; # (reset this just in case)
            my $val = ReadPDFValue($obj);
            EncodeString(\$val);
            $_[0] = $val;
        }
    } elsif (ref $obj eq 'HASH') {
        my $tag;
        my $needCrypt = $$obj{_needCrypt};
        foreach $tag (keys %$obj) {
            next if $myDictTags{$tag};
            # re-encrypt necessary objects only (others are still encrypted)
            # (this is really annoying, but is necessary because objects stored
            # in encrypted streams are decrypted when extracting, but strings stored
            # as direct objects are decrypted later since they must be decoded
            # before being decrypted)
            if ($needCrypt) {
                next unless defined $$needCrypt{$tag} ? $$needCrypt{$tag} : $$needCrypt{'*'};
            }
            CryptObject($$obj{$tag});
        }
        delete $$obj{_needCrypt};   # avoid re-re-crypting
    } elsif (ref $obj eq 'ARRAY') {
        my $val;
        foreach $val (@$obj) {
            CryptObject($val);
        }
    }
}

#------------------------------------------------------------------------------
# Get free entries from xref stream dictionary that we wrote previously
# Inputs: 0) xref dictionary reference
# Returns: free entry hash (keys are object numbers, values are xref entry list refs)
sub GetFreeEntries($)
{
    my $dict = shift;
    my %xrefFree;
    # from the start we have only written xref stream entries in 'CNn' format,
    # so we can simplify things for now and only support this type of entry
    my $w = $$dict{W};
    if (ref $w eq 'ARRAY' and "@$w" eq '1 4 2') {
        my $size = $$dict{_entry_size}; # this will be 7 for 'CNn'
        my $index = $$dict{Index};
        my $len = length $$dict{_stream};
        # scan the table for free objects
        my $num = scalar(@$index) / 2;
        my $pos = 0;
        my ($i, $j);
        for ($i=0; $i<$num; ++$i) {
            my $start = $$index[$i*2];
            my $count = $$index[$i*2+1];
            for ($j=0; $j<$count; ++$j) {
                last if $pos + $size > $len;
                my @t = unpack("x$pos CNn", $$dict{_stream});
                # add entry if object was free
                $xrefFree{$start+$j} = [ $t[1], $t[2], 'f' ] if $t[0] == 0;
                $pos += $size;  # step to next entry
            }
        }
    }
    return \%xrefFree;
}

#------------------------------------------------------------------------------
# Write PDF object
# Inputs: 0) output file or scalar ref, 1) PDF object
# Returns: true on success
# Notes: inserts white space before object, but none afterward
sub WriteObject($$)
{
    my ($outfile, $obj) = @_;
    if (ref $obj eq 'SCALAR') {
        Write($outfile, ' ', $$obj) or return 0;
    } elsif (ref $obj eq 'ARRAY') {
        # write array
        Write($outfile, @$obj > 10 ? $/ : ' ', '[') or return 0;
        my $item;
        foreach $item (@$obj) {
            WriteObject($outfile, $item) or return 0;
        }
        Write($outfile, ' ]') or return 0;
    } elsif (ref $obj eq 'HASH') {
        # write dictionary
        my $tag;
        Write($outfile, $/, '<<') or return 0;
        # prepare object as required if it has a stream
        if ($$obj{_stream}) {
            # encrypt stream if necessary (must be done before determining Length)
            CryptStream($obj, $keyExt) if $$obj{_decrypted};
            # write "Length" entry in dictionary
            $$obj{Length} = length $$obj{_stream};
            push @{$$obj{_tags}}, 'Length';
            # delete Filter-related entries since we don't yet write filtered streams
            delete $$obj{Filter};
            delete $$obj{DecodeParms};
            delete $$obj{DL};
        }
        # don't write my internal entries
        my %wrote = %myDictTags;
        # write tags in original order, adding new ones later alphabetically
        foreach $tag (@{$$obj{_tags}}, sort keys %$obj) {
            # ignore already-written or missing entries
            next if $wrote{$tag} or not defined $$obj{$tag};
            Write($outfile, $/, "/$tag") or return 0;
            WriteObject($outfile, $$obj{$tag}) or return 0;
            $wrote{$tag} = 1;
        }
        Write($outfile, $/, '>>') or return 0;
        if ($$obj{_stream}) {
            # write object stream
            # (a single 0x0d may not follow 'stream', so use 0x0d+0x0a here to be sure)
            Write($outfile, $/, "stream\x0d\x0a") or return 0;
            Write($outfile, $$obj{_stream}, $/, 'endstream') or return 0;
        }
    } else {
        # write string, number, name or object reference
        Write($outfile, ' ', $obj);
    }
    return 1;
}

#------------------------------------------------------------------------------
# Write PDF File
# Inputs: 0) ExifTool object reference, 1) dirInfo reference
# Returns: 1 on success, 0 if not valid PDF file, -1 on write error
# Notes: dictionary structure:  Main --+--> Info
#                                      +--> Root --> Metadata
sub WritePDF($$)
{
    my ($et, $dirInfo) = @_;
    my $raf = $$dirInfo{RAF};
    my $outfile = $$dirInfo{OutFile};
    my ($buff, %capture, %newXRef, %newObj, $objRef);
    my ($out, $id, $gen, $obj);

    # make sure this is a PDF file
    my $pos = $raf->Tell();
    $raf->Read($buff, 10) >= 8 or return 0;
    $buff =~ /^%PDF-(\d+\.\d+)/ or return 0;
    $raf->Seek($pos, 0);

    # create a new ExifTool object and use it to read PDF and XMP information
    my $newTool = new Image::ExifTool;
    $newTool->Options(List => 1);
    $newTool->Options(Password => $et->Options('Password'));
    $$newTool{PDF_CAPTURE} = \%capture;
    my $info = $newTool->ImageInfo($raf, 'XMP', 'PDF:*', 'Error', 'Warning');
    # not a valid PDF file unless we got a version number
    # (note: can't just check $$info{PDFVersion} due to possibility of XMP-pdf:PDFVersion)
    my $vers = $newTool->GetInfo('PDF:PDFVersion');
    ($pdfVer) = values %$vers;
    $pdfVer or $et->Error('Missing PDF:PDFVersion'), return 0;
    # check version number
    if ($pdfVer > 1.7) {
        if ($pdfVer >= 2.0) {
            $et->Error("Can't yet write PDF version $pdfVer"); # (future major version changes)
            return 1;
        }
        $et->Warn("ExifTool is untested with PDF version $pdfVer files", 1);
    }
    # fail if we had any serious errors while extracting information
    if ($capture{Error} or $$info{Error}) {
        $et->Error($capture{Error} || $$info{Error});
        return 1;
    }
    # make sure we have everything we need to rewrite this file
    foreach $obj (qw(Main Root xref)) {
        next if $capture{$obj};
        # any warning we received may give a clue about why this object is missing
        $et->Error($$info{Warning}) if $$info{Warning};
        $et->Error("Can't find $obj object");
        return 1;
    }
    $et->InitWriteDirs(\%pdfMap, 'XMP');

    # copy file up to start of previous exiftool update or end of file
    # (comment, startxref & EOF with 11-digit offsets and 2-byte newlines is 63 bytes)
    $raf->Seek(-64,2) and $raf->Read($buff,64) and $raf->Seek(0,0) or return -1;
    my $rtn = 1;
    my $prevUpdate;
    # (now $endComment is before "startxref", but pre-7.41 we wrote it after the EOF)
    if ($buff =~ /$endComment(\d+)\s+(startxref\s+\d+\s+%%EOF\s+)?$/s) {
        $prevUpdate = $1;
        # rewrite the file up to the original EOF
        Image::ExifTool::CopyBlock($raf, $outfile, $prevUpdate) or $rtn = -1;
        # verify that we are now at the start of an ExifTool update
        unless ($raf->Read($buff, length $beginComment) and $buff eq $beginComment) {
            $et->Error('Previous ExifTool update is corrupted');
            return $rtn;
        }
        $raf->Seek($prevUpdate, 0) or $rtn = -1;
        if ($$et{DEL_GROUP}{'PDF-update'}) {
            $et->VPrint(0, "  Reverted previous ExifTool updates\n");
            ++$$et{CHANGED};
            return $rtn;
        }
    } elsif ($$et{DEL_GROUP}{'PDF-update'}) {
        $et->Error('File contains no previous ExifTool update');
        return $rtn;
    } else {
        # rewrite the whole file
        while ($raf->Read($buff, 65536)) {
            Write($outfile, $buff) or $rtn = -1;
        }
    }
    $out = $et->Options('TextOut') if $et->Options('Verbose');
#
# create our new PDF objects to write
#
    my $xref = $capture{xref};
    my $mainDict = $capture{Main};
    my $metaRef = $capture{Root}->{Metadata};
    my $nextObject;

    # start by finding reference for info object in case it was deleted
    # in a previous edit so we can re-use it here if adding PDF Info
    my $prevInfoRef;
    if ($prevUpdate) {
        unless ($capture{Prev}) {
            $et->Error("Can't locate trailer dictionary prior to last edit");
            return $rtn;
        }
        $prevInfoRef = $capture{Prev}->{Info};
        # start from previous size so the xref table doesn't continue
        # to grow if we repeatedly add and delete the Metadata object
        $nextObject = $capture{Prev}->{Size};
        # don't re-use Meta reference if object was added in a previous update
        undef $metaRef if $metaRef and $$metaRef=~/^(\d+)/ and $1 >= $nextObject;
    } else {
        $prevInfoRef = $$mainDict{Info};
        $nextObject = $$mainDict{Size};
    }

    # delete entire PDF group if specified
    my $infoChanged = 0;
    if ($$et{DEL_GROUP}{PDF} and $capture{Info}) {
        delete $capture{Info};
        $info = { XMP => $$info{XMP} }; # remove extracted PDF tags
        print $out "  Deleting PDF Info dictionary\n" if $out;
        ++$infoChanged;
    }

    # create new Info dictionary if necessary
    $capture{Info} = { _tags => [ ] } unless $capture{Info};
    my $infoDict = $capture{Info};

    # must pre-determine Info reference to be used in encryption
    my $infoRef = $prevInfoRef || \ "$nextObject 0 R";
    $keyExt = $$infoRef;

    # must encrypt all values in dictionary if they came from an encrypted stream
    CryptObject($infoDict) if $$infoDict{_needCrypt};

    # must set line separator before calling WritePDFValue()
    local $/ = $capture{newline};

    # rewrite PDF Info tags
    my $newTags = $et->GetNewTagInfoHash(\%Image::ExifTool::PDF::Info);
    my $tagID;
    foreach $tagID (sort keys %$newTags) {
        my $tagInfo = $$newTags{$tagID};
        my $nvHash = $et->GetNewValueHash($tagInfo);
        my (@vals, $deleted);
        my $tag = $$tagInfo{Name};
        my $val = $$info{$tag};
        my $tagKey = $tag;
        unless (defined $val) {
            # must check for tag key with copy number
            ($tagKey) = grep /^$tag/, keys %$info;
            $val = $$info{$tagKey} if $tagKey;
        }
        if (defined $val) {
            my @oldVals;
            if (ref $val eq 'ARRAY') {
                @oldVals = @$val;
                $val = shift @oldVals;
            }
            for (;;) {
                if ($et->IsOverwriting($nvHash, $val) > 0) {
                    $deleted = 1;
                    $et->VerboseValue("- PDF:$tag", $val);
                    ++$infoChanged;
                } else {
                    push @vals, $val;
                }
                last unless @oldVals;
                $val = shift @oldVals;
            }
            # don't write this out if we deleted all values
            delete $$infoDict{$tagID} unless @vals;
        } elsif ($$nvHash{EditOnly}) {
            next;
        }
        # decide whether we want to write this tag
        # (native PDF information is always preferred, so don't check IsCreating)
        next unless $deleted or $$tagInfo{List} or not exists $$infoDict{$tagID};

        # add new values to existing ones
        my @newVals = $et->GetNewValue($nvHash);
        if (@newVals) {
            push @vals, @newVals;
            ++$infoChanged;
            if ($out) {
                foreach $val (@newVals) {
                    $et->VerboseValue("+ PDF:$tag", $val);
                }
            }
        }
        unless (@vals) {
            # remove this entry from the Info dictionary if no values remain
            delete $$infoDict{$tagID};
            next;
        }
        # format value(s) for writing to PDF file
        my $writable = $$tagInfo{Writable} || $Image::ExifTool::PDF::Info{WRITABLE};
        if (not $$tagInfo{List}) {
            $val = WritePDFValue($et, shift(@vals), $writable);
        } elsif ($$tagInfo{List} eq 'array') {
            foreach $val (@vals) {
                $val = WritePDFValue($et, $val, $writable);
                defined $val or undef(@vals), last;
            }
            $val = @vals ? \@vals : undef;
        } else {
            $val = WritePDFValue($et, join($et->Options('ListSep'), @vals), $writable);
        }
        if (defined $val) {
            $$infoDict{$tagID} = $val;
            ++$infoChanged;
        } else {
            $et->Warn("Error converting $$tagInfo{Name} value");
        }
    }
    if ($infoChanged) {
        $$et{CHANGED} += $infoChanged;
    } elsif ($prevUpdate) {
        # must still write Info dictionary if it was previously updated
        my $oldPos = LocateObject($xref, $$infoRef);
        $infoChanged = 1 if $oldPos and $oldPos > $prevUpdate;
    }

    # create new Info dictionary if necessary
    if ($infoChanged) {
        # increment object count if we used a new object here
        if (scalar(keys %{$capture{Info}}) > 1) {
            $newObj{$$infoRef} = $capture{Info};# save to write later
            $$mainDict{Info} = $infoRef;        # add reference to trailer dictionary
            ++$nextObject unless $prevInfoRef;
        } else {
            # remove Info from Main (trailer) dictionary
            delete $$mainDict{Info};
            # write free entry in xref table if Info existed prior to all edits
            $newObj{$$infoRef} = '' if $prevInfoRef;
        }
    }

    # rewrite XMP
    my %xmpInfo = (
        DataPt => $$info{XMP},
        Parent => 'PDF',
    );
    my $xmpTable = Image::ExifTool::GetTagTable('Image::ExifTool::XMP::Main');
    my $oldChanged = $$et{CHANGED};
    my $newXMP = $et->WriteDirectory(\%xmpInfo, $xmpTable);
    $newXMP = $$info{XMP} ? ${$$info{XMP}} : '' unless defined $newXMP;

    # WriteDirectory() will increment CHANGED erroneously if non-existent
    # XMP is deleted as a block -- so check for this
    unless ($newXMP or $$info{XMP}) {
        $$et{CHANGED} = $oldChanged;
        $et->VPrint(0, "  (XMP not changed -- still empty)\n");
    }
    my ($metaChanged, $rootChanged);

    if ($$et{CHANGED} != $oldChanged and defined $newXMP) {
        $metaChanged = 1;
    } elsif ($prevUpdate and $capture{Root}->{Metadata}) {
        # must still write Metadata dictionary if it was previously updated
        my $oldPos = LocateObject($xref, ${$capture{Root}->{Metadata}});
        $metaChanged = 1 if $oldPos and $oldPos > $prevUpdate;
    }
    if ($metaChanged) {
        if ($newXMP) {
            unless ($metaRef) {
                # allocate new PDF object
                $metaRef = \ "$nextObject 0 R";
                ++$nextObject;
                $capture{Root}->{Metadata} = $metaRef;
                $rootChanged = 1;   # set flag to replace Root dictionary
            }
            # create the new metadata dictionary to write later
            $newObj{$$metaRef} = {
                Type       => '/Metadata',
                Subtype    => '/XML',
              # Length     => length $newXMP, (set by WriteObject)
                _tags      => [ qw(Type Subtype) ],
                _stream    => $newXMP,
                _decrypted => 1, # (this will be ignored if EncryptMetadata is false)
            };
        } elsif ($capture{Root}->{Metadata}) {
            # free existing metadata object
            $newObj{${$capture{Root}->{Metadata}}} = '';
            delete $capture{Root}->{Metadata};
            $rootChanged = 1;   # set flag to replace Root dictionary
        }
    }
    # add new Root dictionary if necessary
    my $rootRef = $$mainDict{Root};
    unless ($rootRef) {
        $et->Error("Can't find Root dictionary");
        return $rtn;
    }
    if (not $rootChanged and $prevUpdate) {
        # must still write Root dictionary if it was previously updated
        my $oldPos = LocateObject($xref, $$rootRef);
        $rootChanged = 1 if $oldPos and $oldPos > $prevUpdate;
    }
    $newObj{$$rootRef} = $capture{Root} if $rootChanged;
#
# write incremental update if anything was changed
#
    if ($$et{CHANGED}) {
        # remember position of original EOF
        my $oldEOF = Tell($outfile);
        Write($outfile, $beginComment) or $rtn = -1;

        # write new objects
        foreach $objRef (sort keys %newObj) {
            $objRef =~ /^(\d+) (\d+)/ or $rtn = -1, last;
            ($id, $gen) = ($1, $2);
            if (not $newObj{$objRef}) {
                ++$gen if $gen < 65535;
                # write free entry in xref table
                $newXRef{$id} = [ 0, $gen, 'f' ];
                next;
            }
            # create new entry for xref table
            $newXRef{$id} = [ Tell($outfile) + length($/), $gen, 'n' ];
            $keyExt = "$id $gen obj";  # (must set for stream encryption)
            Write($outfile, $/, $keyExt) or $rtn = -1;
            WriteObject($outfile, $newObj{$objRef}) or $rtn = -1;
            Write($outfile, $/, 'endobj') or $rtn = -1;
        }

        # Prev points to old xref table
        $$mainDict{Prev} = $capture{startxref} unless $prevUpdate;

        # add xref entry for head of free-object list
        $newXRef{0} = [ 0, 65535, 'f' ];

        # must insert free xref entries from previous exiftool update if applicable
        if ($prevUpdate) {
            my $mainFree;
            # extract free entries from our previous Main xref stream
            if ($$mainDict{Type} and $$mainDict{Type} eq '/XRef') {
                $mainFree = GetFreeEntries($xref->{dicts}->[0]);
            } else {
                # free entries from Main xref table already captured for us
                $mainFree = $capture{mainFree};
            }
            foreach $id (sort { $a <=> $b } keys %$mainFree) {
                $newXRef{$id} = $$mainFree{$id} unless $newXRef{$id};
            }
        }

        # connect linked list of free object in our xref table
        my $prevFree = 0;
        foreach $id (sort { $b <=> $a } keys %newXRef) { # (reverse sort)
            next unless $newXRef{$id}->[2] eq 'f';  # skip if not free
            # no need to add free entry for objects added by us
            # in previous edits then freed again
            if ($id >= $nextObject) {
                delete $newXRef{$id};   # Note: deleting newXRef entry!
                next;
            }
            $newXRef{$id}->[0] = $prevFree;
            $prevFree = $id;
        }

        # prepare our main dictionary for writing
        $$mainDict{Size} = $nextObject;    # update number of objects
        # must change the ID if it exists
        if (ref $$mainDict{ID} eq 'ARRAY' and @{$$mainDict{ID}} > 1) {
            # increment first byte since this is an easy change to make
            $id = $mainDict->{ID}->[1];
            if ($id =~ /^<([0-9a-f]{2})/i) {
                my $byte = unpack('H2',chr((hex($1) + 1) & 0xff));
                substr($id, 1, 2) = $byte;
            } elsif ($id =~ /^\((.)/s and $1 ne '\\' and $1 ne ')' and $1 ne '(') {
                my $ch = chr((ord($1) + 1) & 0xff);
                # avoid generating characters that could cause problems
                $ch = 'a' if $ch =~ /[()\\\x00-\x08\x0a-\x1f\x7f\xff]/;
                substr($id, 1, 1) = $ch;
            }
            $mainDict->{ID}->[1] = $id;
        }

        # remember position of xref table in file (we will write this next)
        my $startxref = Tell($outfile) + length($/);

        # must write xref as a stream in xref-stream-only files
        if ($$mainDict{Type} and $$mainDict{Type} eq '/XRef') {

            # create entry for the xref stream object itself
            $newXRef{$nextObject++} = [ Tell($outfile) + length($/), 0, 'n' ];
            $$mainDict{Size} = $nextObject;
            # create xref stream and Index entry
            $$mainDict{W} = [ 1, 4, 2 ];    # int8u, int32u, int16u ('CNn')
            $$mainDict{Index} = [ ];
            $$mainDict{_stream} = '';
            my @ids = sort { $a <=> $b } keys %newXRef;
            while (@ids) {
                my $startID = $ids[0];
                for (;;) {
                    $id = shift @ids;
                    my ($pos, $gen, $type) = @{$newXRef{$id}};
                    if ($pos > 0xffffffff) {
                        $et->Error('Huge files not yet supported');
                        last;
                    }
                    $$mainDict{_stream} .= pack('CNn', $type eq 'f' ? 0 : 1, $pos, $gen);
                    last if not @ids or $ids[0] != $id + 1;
                }
                # add Index entries for this section of the xref stream
                push @{$$mainDict{Index}}, $startID, $id - $startID + 1;
            }
            # write the xref stream object
            $keyExt = "$id 0 obj";  # (set anyway, but xref stream should NOT be encrypted)
            Write($outfile, $/, $keyExt) or $rtn = -1;
            WriteObject($outfile, $mainDict) or $rtn = -1;
            Write($outfile, $/, 'endobj') or $rtn = -1;

        } else {

            # write new xref table
            Write($outfile, $/, 'xref', $/) or $rtn = -1;
            # lines must be exactly 20 bytes, so pad newline if necessary
            my $endl = (length($/) == 1 ? ' ' : '') . $/;
            my @ids = sort { $a <=> $b } keys %newXRef;
            while (@ids) {
                my $startID = $ids[0];
                $buff = '';
                for (;;) {
                    $id = shift @ids;
                    $buff .= sprintf("%.10d %.5d %s%s", @{$newXRef{$id}}, $endl);
                    last if not @ids or $ids[0] != $id + 1;
                }
                # write this (contiguous-numbered object) section of the xref table
                Write($outfile, $startID, ' ', $id - $startID + 1, $/, $buff) or $rtn = -1;
            }

            # write main (trailer) dictionary
            Write($outfile, 'trailer') or $rtn = -1;
            WriteObject($outfile, $mainDict) or $rtn = -1;
        }
        # write trailing comment (marker to allow edits to be reverted)
        Write($outfile, $/, $endComment, $oldEOF, $/) or $rtn = -1;

        # write pointer to main xref table and EOF marker
        Write($outfile, 'startxref', $/, $startxref, $/, '%%EOF', $/) or $rtn = -1;

    } elsif ($prevUpdate) {

        # nothing new changed, so copy over previous incremental update
        $raf->Seek($prevUpdate, 0) or $rtn = -1;
        while ($raf->Read($buff, 65536)) {
            Write($outfile, $buff) or $rtn = -1;
        }
    }
    if ($rtn > 0 and $$et{CHANGED} and ($$et{DEL_GROUP}{PDF} or $$et{DEL_GROUP}{XMP})) {
        $et->Warn('ExifTool PDF edits are reversible. Deleted tags may be recovered!', 1);
    }
    undef $newTool;
    undef %capture;
    return $rtn;
}


1; # end

__END__

=head1 NAME

Image::ExifTool::WritePDF.pl - Write PDF meta information

=head1 SYNOPSIS

These routines are autoloaded by Image::ExifTool::PDF.

=head1 DESCRIPTION

This file contains routines to write PDF metadata.

=head1 NOTES

When writing a PDF, exiftool does not modify the existing data.  Instead,
the PDF file is appended with an incremental update which can easily be
removed to revert the file (by using ExifTool to delete the special
C<PDF-update> pseudo group).

=head1 AUTHOR

Copyright 2003-2018, 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 REFERENCES

=over 4

=item L<http://partners.adobe.com/public/developer/pdf/index_reference.html>

=back

=head1 SEE ALSO

L<Image::ExifTool::PDF(3pm)|Image::ExifTool::PDF>,
L<Image::ExifTool(3pm)|Image::ExifTool>

=cut
libimage-exiftool-perl 10.80-1 / usr / share / perl5 / Image / ExifTool / WritePDF.pl
