123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771 |
- #------------------------------------------------------------------------------
- # 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-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 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
|