WritePDF.pl 29 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771
  1. #------------------------------------------------------------------------------
  2. # File: WritePDF.pl
  3. #
  4. # Description: Write PDF meta information
  5. #
  6. # Revisions: 12/08/2007 - P. Harvey Created
  7. #
  8. # References: 1) http://partners.adobe.com/public/developer/pdf/index_reference.html
  9. #
  10. # Notes: The special "PDF-update" group can be deleted to revert exiftool updates
  11. #------------------------------------------------------------------------------
  12. package Image::ExifTool::PDF;
  13. use strict;
  14. use vars qw($lastFetched);
  15. sub WriteObject($$);
  16. sub EncodeString($);
  17. sub CryptObject($);
  18. # comments to mark beginning and end of ExifTool incremental update
  19. my $beginComment = '%BeginExifToolUpdate';
  20. my $endComment = '%EndExifToolUpdate ';
  21. my $keyExt; # crypt key extension
  22. my $pdfVer; # version of PDF file we are currently writing
  23. # internal tags used in dictionary objects
  24. my %myDictTags = (
  25. _tags => 1, _stream => 1, _decrypted => 1, _needCrypt => 1,
  26. _filtered => 1, _entry_size => 1, _table => 1,
  27. );
  28. # map for directories that we can add
  29. my %pdfMap = (
  30. XMP => 'PDF',
  31. );
  32. #------------------------------------------------------------------------------
  33. # Validate raw PDF values for writing (string date integer real boolean name)
  34. # Inputs: 0) ExifTool object ref, 1) tagInfo hash ref, 2) raw value ref
  35. # Returns: error string or undef (and possibly changes value) on success
  36. sub CheckPDF($$$)
  37. {
  38. my ($et, $tagInfo, $valPtr) = @_;
  39. my $format = $$tagInfo{Writable} || $tagInfo->{Table}->{WRITABLE};
  40. if (not $format) {
  41. return 'No writable format';
  42. } elsif ($format eq 'string') {
  43. # (encode later because list-type string tags need to be encoded as a unit)
  44. } elsif ($format eq 'date') {
  45. # be flexible about this for now
  46. return 'Bad date format' unless $$valPtr =~ /^\d{4}/;
  47. } elsif ($format eq 'integer') {
  48. return 'Not an integer' unless Image::ExifTool::IsInt($$valPtr);
  49. } elsif ($format eq 'real') {
  50. return 'Not a real number' unless $$valPtr =~ /^[+-]?(?=\d|\.\d)\d*(\.\d*)?$/;
  51. } elsif ($format eq 'boolean') {
  52. $$valPtr = ($$valPtr and $$valPtr !~ /^f/i) ? 'true' : 'false';
  53. } elsif ($format eq 'name') {
  54. return 'Invalid PDF name' if $$valPtr =~ /\0/;
  55. } else {
  56. return "Invalid PDF format '$format'";
  57. }
  58. return undef; # value is OK
  59. }
  60. #------------------------------------------------------------------------------
  61. # Format value for writing to PDF file
  62. # Inputs: 0) ExifTool ref, 1) value, 2) format string (string,date,integer,real,boolean,name)
  63. # Returns: formatted value or undef on error
  64. # Notes: Called at write time, so $pdfVer may be checked
  65. sub WritePDFValue($$$)
  66. {
  67. my ($et, $val, $format) = @_;
  68. if (not $format) {
  69. return undef;
  70. } elsif ($format eq 'string') {
  71. # encode as UCS2 if it contains any special characters
  72. $val = "\xfe\xff" . $et->Encode($val,'UCS2','MM') if $val =~ /[\x80-\xff]/;
  73. EncodeString(\$val);
  74. } elsif ($format eq 'date') {
  75. # convert date to "D:YYYYmmddHHMMSS+-HH'MM'" format
  76. $val =~ s/([-+]\d{2}):(\d{2})/$1'$2'/; # change timezone delimiters if necessary
  77. $val =~ tr/ ://d; # remove spaces and colons
  78. $val = "D:$val"; # add leading "D:"
  79. EncodeString(\$val);
  80. } elsif ($format =~ /^(integer|real|boolean)$/) {
  81. # no reformatting necessary
  82. } elsif ($format eq 'name') {
  83. return undef if $val =~ /\0/;
  84. if ($pdfVer >= 1.2) {
  85. $val =~ s/([\t\n\f\r ()<>[\]{}\/%#])/sprintf('#%.2x',ord $1)/sge;
  86. } else {
  87. return undef if $val =~ /[\t\n\f\r ()<>[\]{}\/%]/;
  88. }
  89. $val = "/$val"; # add leading '/'
  90. } else {
  91. return undef;
  92. }
  93. return $val;
  94. }
  95. #------------------------------------------------------------------------------
  96. # Encode PDF string
  97. # Inputs: 0) reference to PDF string
  98. # Returns: (updates string with encoded data)
  99. sub EncodeString($)
  100. {
  101. my $strPt = shift;
  102. if (ref $$strPt eq 'ARRAY') {
  103. my $str;
  104. foreach $str (@{$$strPt}) {
  105. EncodeString(\$str);
  106. }
  107. return;
  108. }
  109. Crypt($strPt, $keyExt, 1); # encrypt if necessary
  110. # encode as hex if we have any control characters (except tab)
  111. if ($$strPt=~/[\x00-\x08\x0a-\x1f\x7f\xff]/) {
  112. # encode as hex
  113. my $str='';
  114. my $len = length $$strPt;
  115. my $i = 0;
  116. for (;;) {
  117. my $n = $len - $i or last;
  118. $n = 40 if $n > 40; # break into reasonable-length lines
  119. $str .= $/ if $i;
  120. $str .= unpack('H*', substr($$strPt, $i, $n));
  121. $i += $n;
  122. }
  123. $$strPt = "<$str>";
  124. } else {
  125. $$strPt =~ s/([()\\])/\\$1/g; # must escape round brackets and backslashes
  126. $$strPt = "($$strPt)";
  127. }
  128. }
  129. #------------------------------------------------------------------------------
  130. # Encrypt an object
  131. # Inputs: 0) PDF object (encrypts in place)
  132. # Notes: Encrypts according to "_needCrypt" dictionary entry,
  133. # then deletes "_needCrypt" when done
  134. sub CryptObject($)
  135. {
  136. my $obj = $_[0];
  137. if (not ref $obj) {
  138. # only literal strings and hex strings are encrypted
  139. if ($obj =~ /^[(<]/) {
  140. undef $lastFetched; # (reset this just in case)
  141. my $val = ReadPDFValue($obj);
  142. EncodeString(\$val);
  143. $_[0] = $val;
  144. }
  145. } elsif (ref $obj eq 'HASH') {
  146. my $tag;
  147. my $needCrypt = $$obj{_needCrypt};
  148. foreach $tag (keys %$obj) {
  149. next if $myDictTags{$tag};
  150. # re-encrypt necessary objects only (others are still encrypted)
  151. # (this is really annoying, but is necessary because objects stored
  152. # in encrypted streams are decrypted when extracting, but strings stored
  153. # as direct objects are decrypted later since they must be decoded
  154. # before being decrypted)
  155. if ($needCrypt) {
  156. next unless defined $$needCrypt{$tag} ? $$needCrypt{$tag} : $$needCrypt{'*'};
  157. }
  158. CryptObject($$obj{$tag});
  159. }
  160. delete $$obj{_needCrypt}; # avoid re-re-crypting
  161. } elsif (ref $obj eq 'ARRAY') {
  162. my $val;
  163. foreach $val (@$obj) {
  164. CryptObject($val);
  165. }
  166. }
  167. }
  168. #------------------------------------------------------------------------------
  169. # Get free entries from xref stream dictionary that we wrote previously
  170. # Inputs: 0) xref dictionary reference
  171. # Returns: free entry hash (keys are object numbers, values are xref entry list refs)
  172. sub GetFreeEntries($)
  173. {
  174. my $dict = shift;
  175. my %xrefFree;
  176. # from the start we have only written xref stream entries in 'CNn' format,
  177. # so we can simplify things for now and only support this type of entry
  178. my $w = $$dict{W};
  179. if (ref $w eq 'ARRAY' and "@$w" eq '1 4 2') {
  180. my $size = $$dict{_entry_size}; # this will be 7 for 'CNn'
  181. my $index = $$dict{Index};
  182. my $len = length $$dict{_stream};
  183. # scan the table for free objects
  184. my $num = scalar(@$index) / 2;
  185. my $pos = 0;
  186. my ($i, $j);
  187. for ($i=0; $i<$num; ++$i) {
  188. my $start = $$index[$i*2];
  189. my $count = $$index[$i*2+1];
  190. for ($j=0; $j<$count; ++$j) {
  191. last if $pos + $size > $len;
  192. my @t = unpack("x$pos CNn", $$dict{_stream});
  193. # add entry if object was free
  194. $xrefFree{$start+$j} = [ $t[1], $t[2], 'f' ] if $t[0] == 0;
  195. $pos += $size; # step to next entry
  196. }
  197. }
  198. }
  199. return \%xrefFree;
  200. }
  201. #------------------------------------------------------------------------------
  202. # Write PDF object
  203. # Inputs: 0) output file or scalar ref, 1) PDF object
  204. # Returns: true on success
  205. # Notes: inserts white space before object, but none afterward
  206. sub WriteObject($$)
  207. {
  208. my ($outfile, $obj) = @_;
  209. if (ref $obj eq 'SCALAR') {
  210. Write($outfile, ' ', $$obj) or return 0;
  211. } elsif (ref $obj eq 'ARRAY') {
  212. # write array
  213. Write($outfile, @$obj > 10 ? $/ : ' ', '[') or return 0;
  214. my $item;
  215. foreach $item (@$obj) {
  216. WriteObject($outfile, $item) or return 0;
  217. }
  218. Write($outfile, ' ]') or return 0;
  219. } elsif (ref $obj eq 'HASH') {
  220. # write dictionary
  221. my $tag;
  222. Write($outfile, $/, '<<') or return 0;
  223. # prepare object as required if it has a stream
  224. if ($$obj{_stream}) {
  225. # encrypt stream if necessary (must be done before determining Length)
  226. CryptStream($obj, $keyExt) if $$obj{_decrypted};
  227. # write "Length" entry in dictionary
  228. $$obj{Length} = length $$obj{_stream};
  229. push @{$$obj{_tags}}, 'Length';
  230. # delete Filter-related entries since we don't yet write filtered streams
  231. delete $$obj{Filter};
  232. delete $$obj{DecodeParms};
  233. delete $$obj{DL};
  234. }
  235. # don't write my internal entries
  236. my %wrote = %myDictTags;
  237. # write tags in original order, adding new ones later alphabetically
  238. foreach $tag (@{$$obj{_tags}}, sort keys %$obj) {
  239. # ignore already-written or missing entries
  240. next if $wrote{$tag} or not defined $$obj{$tag};
  241. Write($outfile, $/, "/$tag") or return 0;
  242. WriteObject($outfile, $$obj{$tag}) or return 0;
  243. $wrote{$tag} = 1;
  244. }
  245. Write($outfile, $/, '>>') or return 0;
  246. if ($$obj{_stream}) {
  247. # write object stream
  248. # (a single 0x0d may not follow 'stream', so use 0x0d+0x0a here to be sure)
  249. Write($outfile, $/, "stream\x0d\x0a") or return 0;
  250. Write($outfile, $$obj{_stream}, $/, 'endstream') or return 0;
  251. }
  252. } else {
  253. # write string, number, name or object reference
  254. Write($outfile, ' ', $obj);
  255. }
  256. return 1;
  257. }
  258. #------------------------------------------------------------------------------
  259. # Write PDF File
  260. # Inputs: 0) ExifTool object reference, 1) dirInfo reference
  261. # Returns: 1 on success, 0 if not valid PDF file, -1 on write error
  262. # Notes: dictionary structure: Main --+--> Info
  263. # +--> Root --> Metadata
  264. sub WritePDF($$)
  265. {
  266. my ($et, $dirInfo) = @_;
  267. my $raf = $$dirInfo{RAF};
  268. my $outfile = $$dirInfo{OutFile};
  269. my ($buff, %capture, %newXRef, %newObj, $objRef);
  270. my ($out, $id, $gen, $obj);
  271. # make sure this is a PDF file
  272. my $pos = $raf->Tell();
  273. $raf->Read($buff, 10) >= 8 or return 0;
  274. $buff =~ /^%PDF-(\d+\.\d+)/ or return 0;
  275. $raf->Seek($pos, 0);
  276. # create a new ExifTool object and use it to read PDF and XMP information
  277. my $newTool = new Image::ExifTool;
  278. $newTool->Options(List => 1);
  279. $newTool->Options(Password => $et->Options('Password'));
  280. $$newTool{PDF_CAPTURE} = \%capture;
  281. my $info = $newTool->ImageInfo($raf, 'XMP', 'PDF:*', 'Error', 'Warning');
  282. # not a valid PDF file unless we got a version number
  283. # (note: can't just check $$info{PDFVersion} due to possibility of XMP-pdf:PDFVersion)
  284. my $vers = $newTool->GetInfo('PDF:PDFVersion');
  285. ($pdfVer) = values %$vers;
  286. $pdfVer or $et->Error('Missing PDF:PDFVersion'), return 0;
  287. # check version number
  288. if ($pdfVer > 1.7) {
  289. if ($pdfVer >= 2.0) {
  290. $et->Error("Can't yet write PDF version $pdfVer"); # (future major version changes)
  291. return 1;
  292. }
  293. $et->Warn("ExifTool is untested with PDF version $pdfVer files", 1);
  294. }
  295. # fail if we had any serious errors while extracting information
  296. if ($capture{Error} or $$info{Error}) {
  297. $et->Error($capture{Error} || $$info{Error});
  298. return 1;
  299. }
  300. # make sure we have everything we need to rewrite this file
  301. foreach $obj (qw(Main Root xref)) {
  302. next if $capture{$obj};
  303. # any warning we received may give a clue about why this object is missing
  304. $et->Error($$info{Warning}) if $$info{Warning};
  305. $et->Error("Can't find $obj object");
  306. return 1;
  307. }
  308. $et->InitWriteDirs(\%pdfMap, 'XMP');
  309. # copy file up to start of previous exiftool update or end of file
  310. # (comment, startxref & EOF with 11-digit offsets and 2-byte newlines is 63 bytes)
  311. $raf->Seek(-64,2) and $raf->Read($buff,64) and $raf->Seek(0,0) or return -1;
  312. my $rtn = 1;
  313. my $prevUpdate;
  314. # (now $endComment is before "startxref", but pre-7.41 we wrote it after the EOF)
  315. if ($buff =~ /$endComment(\d+)\s+(startxref\s+\d+\s+%%EOF\s+)?$/s) {
  316. $prevUpdate = $1;
  317. # rewrite the file up to the original EOF
  318. Image::ExifTool::CopyBlock($raf, $outfile, $prevUpdate) or $rtn = -1;
  319. # verify that we are now at the start of an ExifTool update
  320. unless ($raf->Read($buff, length $beginComment) and $buff eq $beginComment) {
  321. $et->Error('Previous ExifTool update is corrupted');
  322. return $rtn;
  323. }
  324. $raf->Seek($prevUpdate, 0) or $rtn = -1;
  325. if ($$et{DEL_GROUP}{'PDF-update'}) {
  326. $et->VPrint(0, " Reverted previous ExifTool updates\n");
  327. ++$$et{CHANGED};
  328. return $rtn;
  329. }
  330. } elsif ($$et{DEL_GROUP}{'PDF-update'}) {
  331. $et->Error('File contains no previous ExifTool update');
  332. return $rtn;
  333. } else {
  334. # rewrite the whole file
  335. while ($raf->Read($buff, 65536)) {
  336. Write($outfile, $buff) or $rtn = -1;
  337. }
  338. }
  339. $out = $et->Options('TextOut') if $et->Options('Verbose');
  340. #
  341. # create our new PDF objects to write
  342. #
  343. my $xref = $capture{xref};
  344. my $mainDict = $capture{Main};
  345. my $metaRef = $capture{Root}->{Metadata};
  346. my $nextObject;
  347. # start by finding reference for info object in case it was deleted
  348. # in a previous edit so we can re-use it here if adding PDF Info
  349. my $prevInfoRef;
  350. if ($prevUpdate) {
  351. unless ($capture{Prev}) {
  352. $et->Error("Can't locate trailer dictionary prior to last edit");
  353. return $rtn;
  354. }
  355. $prevInfoRef = $capture{Prev}->{Info};
  356. # start from previous size so the xref table doesn't continue
  357. # to grow if we repeatedly add and delete the Metadata object
  358. $nextObject = $capture{Prev}->{Size};
  359. # don't re-use Meta reference if object was added in a previous update
  360. undef $metaRef if $metaRef and $$metaRef=~/^(\d+)/ and $1 >= $nextObject;
  361. } else {
  362. $prevInfoRef = $$mainDict{Info};
  363. $nextObject = $$mainDict{Size};
  364. }
  365. # delete entire PDF group if specified
  366. my $infoChanged = 0;
  367. if ($$et{DEL_GROUP}{PDF} and $capture{Info}) {
  368. delete $capture{Info};
  369. $info = { XMP => $$info{XMP} }; # remove extracted PDF tags
  370. print $out " Deleting PDF Info dictionary\n" if $out;
  371. ++$infoChanged;
  372. }
  373. # create new Info dictionary if necessary
  374. $capture{Info} = { _tags => [ ] } unless $capture{Info};
  375. my $infoDict = $capture{Info};
  376. # must pre-determine Info reference to be used in encryption
  377. my $infoRef = $prevInfoRef || \ "$nextObject 0 R";
  378. $keyExt = $$infoRef;
  379. # must encrypt all values in dictionary if they came from an encrypted stream
  380. CryptObject($infoDict) if $$infoDict{_needCrypt};
  381. # must set line separator before calling WritePDFValue()
  382. local $/ = $capture{newline};
  383. # rewrite PDF Info tags
  384. my $newTags = $et->GetNewTagInfoHash(\%Image::ExifTool::PDF::Info);
  385. my $tagID;
  386. foreach $tagID (sort keys %$newTags) {
  387. my $tagInfo = $$newTags{$tagID};
  388. my $nvHash = $et->GetNewValueHash($tagInfo);
  389. my (@vals, $deleted);
  390. my $tag = $$tagInfo{Name};
  391. my $val = $$info{$tag};
  392. my $tagKey = $tag;
  393. unless (defined $val) {
  394. # must check for tag key with copy number
  395. ($tagKey) = grep /^$tag/, keys %$info;
  396. $val = $$info{$tagKey} if $tagKey;
  397. }
  398. if (defined $val) {
  399. my @oldVals;
  400. if (ref $val eq 'ARRAY') {
  401. @oldVals = @$val;
  402. $val = shift @oldVals;
  403. }
  404. for (;;) {
  405. if ($et->IsOverwriting($nvHash, $val) > 0) {
  406. $deleted = 1;
  407. $et->VerboseValue("- PDF:$tag", $val);
  408. ++$infoChanged;
  409. } else {
  410. push @vals, $val;
  411. }
  412. last unless @oldVals;
  413. $val = shift @oldVals;
  414. }
  415. # don't write this out if we deleted all values
  416. delete $$infoDict{$tagID} unless @vals;
  417. } elsif ($$nvHash{EditOnly}) {
  418. next;
  419. }
  420. # decide whether we want to write this tag
  421. # (native PDF information is always preferred, so don't check IsCreating)
  422. next unless $deleted or $$tagInfo{List} or not exists $$infoDict{$tagID};
  423. # add new values to existing ones
  424. my @newVals = $et->GetNewValue($nvHash);
  425. if (@newVals) {
  426. push @vals, @newVals;
  427. ++$infoChanged;
  428. if ($out) {
  429. foreach $val (@newVals) {
  430. $et->VerboseValue("+ PDF:$tag", $val);
  431. }
  432. }
  433. }
  434. unless (@vals) {
  435. # remove this entry from the Info dictionary if no values remain
  436. delete $$infoDict{$tagID};
  437. next;
  438. }
  439. # format value(s) for writing to PDF file
  440. my $writable = $$tagInfo{Writable} || $Image::ExifTool::PDF::Info{WRITABLE};
  441. if (not $$tagInfo{List}) {
  442. $val = WritePDFValue($et, shift(@vals), $writable);
  443. } elsif ($$tagInfo{List} eq 'array') {
  444. foreach $val (@vals) {
  445. $val = WritePDFValue($et, $val, $writable);
  446. defined $val or undef(@vals), last;
  447. }
  448. $val = @vals ? \@vals : undef;
  449. } else {
  450. $val = WritePDFValue($et, join($et->Options('ListSep'), @vals), $writable);
  451. }
  452. if (defined $val) {
  453. $$infoDict{$tagID} = $val;
  454. ++$infoChanged;
  455. } else {
  456. $et->Warn("Error converting $$tagInfo{Name} value");
  457. }
  458. }
  459. if ($infoChanged) {
  460. $$et{CHANGED} += $infoChanged;
  461. } elsif ($prevUpdate) {
  462. # must still write Info dictionary if it was previously updated
  463. my $oldPos = LocateObject($xref, $$infoRef);
  464. $infoChanged = 1 if $oldPos and $oldPos > $prevUpdate;
  465. }
  466. # create new Info dictionary if necessary
  467. if ($infoChanged) {
  468. # increment object count if we used a new object here
  469. if (scalar(keys %{$capture{Info}}) > 1) {
  470. $newObj{$$infoRef} = $capture{Info};# save to write later
  471. $$mainDict{Info} = $infoRef; # add reference to trailer dictionary
  472. ++$nextObject unless $prevInfoRef;
  473. } else {
  474. # remove Info from Main (trailer) dictionary
  475. delete $$mainDict{Info};
  476. # write free entry in xref table if Info existed prior to all edits
  477. $newObj{$$infoRef} = '' if $prevInfoRef;
  478. }
  479. }
  480. # rewrite XMP
  481. my %xmpInfo = (
  482. DataPt => $$info{XMP},
  483. Parent => 'PDF',
  484. );
  485. my $xmpTable = Image::ExifTool::GetTagTable('Image::ExifTool::XMP::Main');
  486. my $oldChanged = $$et{CHANGED};
  487. my $newXMP = $et->WriteDirectory(\%xmpInfo, $xmpTable);
  488. $newXMP = $$info{XMP} ? ${$$info{XMP}} : '' unless defined $newXMP;
  489. # WriteDirectory() will increment CHANGED erroneously if non-existent
  490. # XMP is deleted as a block -- so check for this
  491. unless ($newXMP or $$info{XMP}) {
  492. $$et{CHANGED} = $oldChanged;
  493. $et->VPrint(0, " (XMP not changed -- still empty)\n");
  494. }
  495. my ($metaChanged, $rootChanged);
  496. if ($$et{CHANGED} != $oldChanged and defined $newXMP) {
  497. $metaChanged = 1;
  498. } elsif ($prevUpdate and $capture{Root}->{Metadata}) {
  499. # must still write Metadata dictionary if it was previously updated
  500. my $oldPos = LocateObject($xref, ${$capture{Root}->{Metadata}});
  501. $metaChanged = 1 if $oldPos and $oldPos > $prevUpdate;
  502. }
  503. if ($metaChanged) {
  504. if ($newXMP) {
  505. unless ($metaRef) {
  506. # allocate new PDF object
  507. $metaRef = \ "$nextObject 0 R";
  508. ++$nextObject;
  509. $capture{Root}->{Metadata} = $metaRef;
  510. $rootChanged = 1; # set flag to replace Root dictionary
  511. }
  512. # create the new metadata dictionary to write later
  513. $newObj{$$metaRef} = {
  514. Type => '/Metadata',
  515. Subtype => '/XML',
  516. # Length => length $newXMP, (set by WriteObject)
  517. _tags => [ qw(Type Subtype) ],
  518. _stream => $newXMP,
  519. _decrypted => 1, # (this will be ignored if EncryptMetadata is false)
  520. };
  521. } elsif ($capture{Root}->{Metadata}) {
  522. # free existing metadata object
  523. $newObj{${$capture{Root}->{Metadata}}} = '';
  524. delete $capture{Root}->{Metadata};
  525. $rootChanged = 1; # set flag to replace Root dictionary
  526. }
  527. }
  528. # add new Root dictionary if necessary
  529. my $rootRef = $$mainDict{Root};
  530. unless ($rootRef) {
  531. $et->Error("Can't find Root dictionary");
  532. return $rtn;
  533. }
  534. if (not $rootChanged and $prevUpdate) {
  535. # must still write Root dictionary if it was previously updated
  536. my $oldPos = LocateObject($xref, $$rootRef);
  537. $rootChanged = 1 if $oldPos and $oldPos > $prevUpdate;
  538. }
  539. $newObj{$$rootRef} = $capture{Root} if $rootChanged;
  540. #
  541. # write incremental update if anything was changed
  542. #
  543. if ($$et{CHANGED}) {
  544. # remember position of original EOF
  545. my $oldEOF = Tell($outfile);
  546. Write($outfile, $beginComment) or $rtn = -1;
  547. # write new objects
  548. foreach $objRef (sort keys %newObj) {
  549. $objRef =~ /^(\d+) (\d+)/ or $rtn = -1, last;
  550. ($id, $gen) = ($1, $2);
  551. if (not $newObj{$objRef}) {
  552. ++$gen if $gen < 65535;
  553. # write free entry in xref table
  554. $newXRef{$id} = [ 0, $gen, 'f' ];
  555. next;
  556. }
  557. # create new entry for xref table
  558. $newXRef{$id} = [ Tell($outfile) + length($/), $gen, 'n' ];
  559. $keyExt = "$id $gen obj"; # (must set for stream encryption)
  560. Write($outfile, $/, $keyExt) or $rtn = -1;
  561. WriteObject($outfile, $newObj{$objRef}) or $rtn = -1;
  562. Write($outfile, $/, 'endobj') or $rtn = -1;
  563. }
  564. # Prev points to old xref table
  565. $$mainDict{Prev} = $capture{startxref} unless $prevUpdate;
  566. # add xref entry for head of free-object list
  567. $newXRef{0} = [ 0, 65535, 'f' ];
  568. # must insert free xref entries from previous exiftool update if applicable
  569. if ($prevUpdate) {
  570. my $mainFree;
  571. # extract free entries from our previous Main xref stream
  572. if ($$mainDict{Type} and $$mainDict{Type} eq '/XRef') {
  573. $mainFree = GetFreeEntries($xref->{dicts}->[0]);
  574. } else {
  575. # free entries from Main xref table already captured for us
  576. $mainFree = $capture{mainFree};
  577. }
  578. foreach $id (sort { $a <=> $b } keys %$mainFree) {
  579. $newXRef{$id} = $$mainFree{$id} unless $newXRef{$id};
  580. }
  581. }
  582. # connect linked list of free object in our xref table
  583. my $prevFree = 0;
  584. foreach $id (sort { $b <=> $a } keys %newXRef) { # (reverse sort)
  585. next unless $newXRef{$id}->[2] eq 'f'; # skip if not free
  586. # no need to add free entry for objects added by us
  587. # in previous edits then freed again
  588. if ($id >= $nextObject) {
  589. delete $newXRef{$id}; # Note: deleting newXRef entry!
  590. next;
  591. }
  592. $newXRef{$id}->[0] = $prevFree;
  593. $prevFree = $id;
  594. }
  595. # prepare our main dictionary for writing
  596. $$mainDict{Size} = $nextObject; # update number of objects
  597. # must change the ID if it exists
  598. if (ref $$mainDict{ID} eq 'ARRAY' and @{$$mainDict{ID}} > 1) {
  599. # increment first byte since this is an easy change to make
  600. $id = $mainDict->{ID}->[1];
  601. if ($id =~ /^<([0-9a-f]{2})/i) {
  602. my $byte = unpack('H2',chr((hex($1) + 1) & 0xff));
  603. substr($id, 1, 2) = $byte;
  604. } elsif ($id =~ /^\((.)/s and $1 ne '\\' and $1 ne ')' and $1 ne '(') {
  605. my $ch = chr((ord($1) + 1) & 0xff);
  606. # avoid generating characters that could cause problems
  607. $ch = 'a' if $ch =~ /[()\\\x00-\x08\x0a-\x1f\x7f\xff]/;
  608. substr($id, 1, 1) = $ch;
  609. }
  610. $mainDict->{ID}->[1] = $id;
  611. }
  612. # remember position of xref table in file (we will write this next)
  613. my $startxref = Tell($outfile) + length($/);
  614. # must write xref as a stream in xref-stream-only files
  615. if ($$mainDict{Type} and $$mainDict{Type} eq '/XRef') {
  616. # create entry for the xref stream object itself
  617. $newXRef{$nextObject++} = [ Tell($outfile) + length($/), 0, 'n' ];
  618. $$mainDict{Size} = $nextObject;
  619. # create xref stream and Index entry
  620. $$mainDict{W} = [ 1, 4, 2 ]; # int8u, int32u, int16u ('CNn')
  621. $$mainDict{Index} = [ ];
  622. $$mainDict{_stream} = '';
  623. my @ids = sort { $a <=> $b } keys %newXRef;
  624. while (@ids) {
  625. my $startID = $ids[0];
  626. for (;;) {
  627. $id = shift @ids;
  628. my ($pos, $gen, $type) = @{$newXRef{$id}};
  629. if ($pos > 0xffffffff) {
  630. $et->Error('Huge files not yet supported');
  631. last;
  632. }
  633. $$mainDict{_stream} .= pack('CNn', $type eq 'f' ? 0 : 1, $pos, $gen);
  634. last if not @ids or $ids[0] != $id + 1;
  635. }
  636. # add Index entries for this section of the xref stream
  637. push @{$$mainDict{Index}}, $startID, $id - $startID + 1;
  638. }
  639. # write the xref stream object
  640. $keyExt = "$id 0 obj"; # (set anyway, but xref stream should NOT be encrypted)
  641. Write($outfile, $/, $keyExt) or $rtn = -1;
  642. WriteObject($outfile, $mainDict) or $rtn = -1;
  643. Write($outfile, $/, 'endobj') or $rtn = -1;
  644. } else {
  645. # write new xref table
  646. Write($outfile, $/, 'xref', $/) or $rtn = -1;
  647. # lines must be exactly 20 bytes, so pad newline if necessary
  648. my $endl = (length($/) == 1 ? ' ' : '') . $/;
  649. my @ids = sort { $a <=> $b } keys %newXRef;
  650. while (@ids) {
  651. my $startID = $ids[0];
  652. $buff = '';
  653. for (;;) {
  654. $id = shift @ids;
  655. $buff .= sprintf("%.10d %.5d %s%s", @{$newXRef{$id}}, $endl);
  656. last if not @ids or $ids[0] != $id + 1;
  657. }
  658. # write this (contiguous-numbered object) section of the xref table
  659. Write($outfile, $startID, ' ', $id - $startID + 1, $/, $buff) or $rtn = -1;
  660. }
  661. # write main (trailer) dictionary
  662. Write($outfile, 'trailer') or $rtn = -1;
  663. WriteObject($outfile, $mainDict) or $rtn = -1;
  664. }
  665. # write trailing comment (marker to allow edits to be reverted)
  666. Write($outfile, $/, $endComment, $oldEOF, $/) or $rtn = -1;
  667. # write pointer to main xref table and EOF marker
  668. Write($outfile, 'startxref', $/, $startxref, $/, '%%EOF', $/) or $rtn = -1;
  669. } elsif ($prevUpdate) {
  670. # nothing new changed, so copy over previous incremental update
  671. $raf->Seek($prevUpdate, 0) or $rtn = -1;
  672. while ($raf->Read($buff, 65536)) {
  673. Write($outfile, $buff) or $rtn = -1;
  674. }
  675. }
  676. if ($rtn > 0 and $$et{CHANGED} and ($$et{DEL_GROUP}{PDF} or $$et{DEL_GROUP}{XMP})) {
  677. $et->Warn('ExifTool PDF edits are reversible. Deleted tags may be recovered!', 1);
  678. }
  679. undef $newTool;
  680. undef %capture;
  681. return $rtn;
  682. }
  683. 1; # end
  684. __END__
  685. =head1 NAME
  686. Image::ExifTool::WritePDF.pl - Write PDF meta information
  687. =head1 SYNOPSIS
  688. These routines are autoloaded by Image::ExifTool::PDF.
  689. =head1 DESCRIPTION
  690. This file contains routines to write PDF metadata.
  691. =head1 NOTES
  692. When writing a PDF, exiftool does not modify the existing data. Instead,
  693. the PDF file is appended with an incremental update which can easily be
  694. removed to revert the file (by using ExifTool to delete the special
  695. C<PDF-update> pseudo group).
  696. =head1 AUTHOR
  697. Copyright 2003-2016, Phil Harvey (phil at owl.phy.queensu.ca)
  698. This library is free software; you can redistribute it and/or modify it
  699. under the same terms as Perl itself.
  700. =head1 REFERENCES
  701. =over 4
  702. =item L<http://partners.adobe.com/public/developer/pdf/index_reference.html>
  703. =back
  704. =head1 SEE ALSO
  705. L<Image::ExifTool::PDF(3pm)|Image::ExifTool::PDF>,
  706. L<Image::ExifTool(3pm)|Image::ExifTool>
  707. =cut