WritePostScript.pl 29 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772
  1. #------------------------------------------------------------------------------
  2. # File: WritePostScript.pl
  3. #
  4. # Description: Write PostScript meta information
  5. #
  6. # Revisions: 03/03/2006 - P. Harvey Created
  7. #
  8. # References: (see references in PostScript.pm, plus:)
  9. # 1) http://www.adobe.com/products/postscript/pdfs/PLRM.pdf
  10. # 2) http://www-cdf.fnal.gov/offline/PostScript/PLRM2.pdf
  11. # 3) http://partners.adobe.com/public/developer/en/acrobat/sdk/pdf/pdf_creation_apis_and_specs/pdfmarkReference.pdf
  12. # 4) http://www.npes.org/standards/Tools/DCS20Spec.pdf
  13. #
  14. # Notes: (see NOTES in POD doc below)
  15. #------------------------------------------------------------------------------
  16. package Image::ExifTool::PostScript;
  17. use strict;
  18. # Structure of a DSC PS/EPS document:
  19. #
  20. # %!PS-Adobe-3.0 [plus " EPSF-3.0" for EPS]
  21. # <comments>
  22. # %%EndComments [optional]
  23. # %%BeginXxxx
  24. # <stuff to ignore>
  25. # %%EndXxxx
  26. # %%BeginProlog
  27. # <prolog stuff>
  28. # %%EndProlog
  29. # %%BeginSetup
  30. # <setup stuff>
  31. # %%EndSetup
  32. # %ImageData x x x x [written by Photoshop]
  33. # %BeginPhotoshop: xxxx
  34. # <ascii-hex IRB information>
  35. # %EndPhotosop
  36. # %%BeginICCProfile: (name) <num> <type>
  37. # <ICC Profile info>
  38. # %%EndICCProfile
  39. # %begin_xml_code
  40. # <postscript code to define and read the XMP stream object>
  41. # %begin_xml_packet: xxxx
  42. # <XMP data>
  43. # %end_xml_packet
  44. # <postscript code to add XMP stream to dictionary>
  45. # %end_xml_code
  46. # %%Page: x x [PS only (optional?)]
  47. # <graphics commands>
  48. # %%PageTrailer
  49. # %%Trailer
  50. # <a bit more code to bracket EPS content for distiller>
  51. # %%EOF
  52. # map of where information is stored in PS image
  53. my %psMap = (
  54. XMP => 'PostScript',
  55. Photoshop => 'PostScript',
  56. IPTC => 'Photoshop',
  57. EXIFInfo => 'Photoshop',
  58. IFD0 => 'EXIFInfo',
  59. IFD1 => 'IFD0',
  60. ICC_Profile => 'PostScript',
  61. ExifIFD => 'IFD0',
  62. GPS => 'IFD0',
  63. SubIFD => 'IFD0',
  64. GlobParamIFD => 'IFD0',
  65. PrintIM => 'IFD0',
  66. InteropIFD => 'ExifIFD',
  67. MakerNotes => 'ExifIFD',
  68. );
  69. #------------------------------------------------------------------------------
  70. # Write XMP directory to file, with begin/end tokens if necessary
  71. # Inputs: 0) outfile ref, 1) flags hash ref, 2-N) data to write
  72. # Returns: true on success
  73. sub WriteXMPDir($$@)
  74. {
  75. my $outfile = shift;
  76. my $flags = shift;
  77. my $success = 1;
  78. Write($outfile, "%begin_xml_code$/") or $success = 0 unless $$flags{WROTE_BEGIN};
  79. Write($outfile, @_) or $success = 0;
  80. Write($outfile, "%end_xml_code$/") or $success = 0 unless $$flags{WROTE_BEGIN};
  81. return $success;
  82. }
  83. #------------------------------------------------------------------------------
  84. # Write a directory inside a PS document
  85. # Inputs: 0) ExifTool object ref, 1) output file reference,
  86. # 2) Directory name, 3) data reference, 4) flags hash ref
  87. # Returns: 0=error, 1=nothing written, 2=dir written ok
  88. sub WritePSDirectory($$$$$)
  89. {
  90. my ($et, $outfile, $dirName, $dataPt, $flags) = @_;
  91. my $success = 2;
  92. my $len = $dataPt ? length($$dataPt) : 0;
  93. my $create = $len ? 0 : 1;
  94. my %dirInfo = (
  95. DataPt => $dataPt,
  96. DataLen => $len,
  97. DirStart => 0,
  98. DirLen => $len,
  99. DirName => $dirName,
  100. Parent => 'PostScript',
  101. );
  102. # Note: $$flags{WROTE_BEGIN} may be 1 for XMP (it is always 0 for
  103. # other dirs, but if 1, the begin/end markers were already written)
  104. #
  105. # prepare necessary postscript code to support embedded XMP
  106. #
  107. my ($beforeXMP, $afterXMP, $reportedLen);
  108. if ($dirName eq 'XMP' and $len) {
  109. # isolate the XMP
  110. pos($$dataPt) = 0;
  111. unless ($$dataPt =~ /(.*)(<\?xpacket begin=.{7,13}W5M0MpCehiHzreSzNTczkc9d)/sg) {
  112. $et->Warn('No XMP packet start');
  113. return WriteXMPDir($outfile, $flags, $$dataPt);
  114. }
  115. $beforeXMP = $1;
  116. my $xmp = $2;
  117. my $p1 = pos($$dataPt);
  118. unless ($$dataPt =~ m{<\?xpacket end=.(w|r).\?>}sg) {
  119. $et->Warn('No XMP packet end');
  120. return WriteXMPDir($outfile, $flags, $$dataPt);
  121. }
  122. my $p2 = pos($$dataPt);
  123. $xmp .= substr($$dataPt, $p1, $p2-$p1);
  124. $afterXMP = substr($$dataPt, $p2);
  125. # determine if we can adjust the XMP size
  126. if ($beforeXMP =~ /%begin_xml_packet: (\d+)/s) {
  127. $reportedLen = $1;
  128. my @matches= ($beforeXMP =~ /\b$reportedLen\b/sg);
  129. undef $reportedLen unless @matches == 2;
  130. }
  131. # must edit in place if we can't reliably change the XMP length
  132. $dirInfo{InPlace} = 1 unless $reportedLen;
  133. # process XMP only
  134. $dirInfo{DataLen} = $dirInfo{DirLen} = length $xmp;
  135. $dirInfo{DataPt} = \$xmp;
  136. }
  137. my $tagTablePtr = Image::ExifTool::GetTagTable("Image::ExifTool::${dirName}::Main");
  138. my $val = $et->WriteDirectory(\%dirInfo, $tagTablePtr);
  139. if (defined $val) {
  140. $dataPt = \$val; # use modified directory
  141. $len = length $val;
  142. } elsif ($dirName eq 'XMP') {
  143. return 1 unless $len;
  144. # just write the original XMP
  145. return WriteXMPDir($outfile, $flags, $$dataPt);
  146. }
  147. unless ($len) {
  148. return 1 if $create or $dirName ne 'XMP'; # nothing to create
  149. # it would be really difficult to delete the XMP,
  150. # so instead we write a blank XMP record
  151. $val = <<EMPTY_XMP;
  152. <?xpacket begin='' id='W5M0MpCehiHzreSzNTczkc9d'?>
  153. <x:xmpmeta xmlns:x='adobe:ns:meta/' x:xmptk='Image::ExifTool $Image::ExifTool::VERSION'>
  154. </x:xmpmeta>
  155. EMPTY_XMP
  156. $val .= ((' ' x 100) . "\n") x 24 unless $et->Options('Compact');
  157. $val .= q{<?xpacket end='w'?>};
  158. $dataPt = \$val;
  159. $len = length $val;
  160. }
  161. #
  162. # write XMP directory
  163. #
  164. if ($dirName eq 'XMP') {
  165. if ($create) {
  166. # create necessary PS/EPS code to support XMP
  167. $beforeXMP = <<HDR_END;
  168. /pdfmark where {pop true} {false} ifelse
  169. /currentdistillerparams where {pop currentdistillerparams
  170. /CoreDistVersion get 5000 ge } {false} ifelse
  171. and not {userdict /pdfmark /cleartomark load put} if
  172. [/NamespacePush pdfmark
  173. [/_objdef {exiftool_metadata_stream} /type /stream /OBJ pdfmark
  174. [{exiftool_metadata_stream} 2 dict begin /Type /Metadata def
  175. /Subtype /XML def currentdict end /PUT pdfmark
  176. /MetadataString $len string def % exact length of metadata
  177. /TempString 100 string def
  178. /ConsumeMetadata {
  179. currentfile TempString readline pop pop
  180. currentfile MetadataString readstring pop pop
  181. } bind def
  182. ConsumeMetadata
  183. %begin_xml_packet: $len
  184. HDR_END
  185. # note: use q() to get necessary linefeed before %end_xml_packet
  186. $afterXMP = q(
  187. %end_xml_packet
  188. [{exiftool_metadata_stream} MetadataString /PUT pdfmark
  189. );
  190. if ($$flags{EPS}) {
  191. $afterXMP .= <<EPS_AFTER;
  192. [/Document 1 dict begin
  193. /Metadata {exiftool_metadata_stream} def currentdict end /BDC pdfmark
  194. [/NamespacePop pdfmark
  195. EPS_AFTER
  196. # write this at end of file
  197. $$flags{TRAILER} = "[/EMC pdfmark$/";
  198. } else { # PS
  199. $afterXMP .= <<PS_AFTER;
  200. [{Catalog} {exiftool_metadata_stream} /Metadata pdfmark
  201. [/NamespacePop pdfmark
  202. PS_AFTER
  203. }
  204. $beforeXMP =~ s{\n}{$/}sg; # use proper newline characters
  205. $afterXMP =~ s{\n}{$/}sg;
  206. } else {
  207. # replace xmp size in PS code
  208. $reportedLen and $beforeXMP =~ s/\b$reportedLen\b/$len/sg;
  209. }
  210. WriteXMPDir($outfile, $flags, $beforeXMP, $$dataPt, $afterXMP) or $success = 0;
  211. #
  212. # Write Photoshop or ICC_Profile directory
  213. #
  214. } elsif ($dirName eq 'Photoshop' or $dirName eq 'ICC_Profile') {
  215. my ($startToken, $endToken);
  216. if ($dirName eq 'Photoshop') {
  217. $startToken = "%BeginPhotoshop: $len";
  218. $endToken = '%EndPhotoshop';
  219. } else {
  220. $startToken = '%%BeginICCProfile: (Photoshop Profile) -1 Hex';
  221. $endToken = '%%EndICCProfile';
  222. }
  223. Write($outfile, $startToken, $/) or $success = 0;
  224. # write as an ASCII-hex comment
  225. my $i;
  226. my $wid = 32;
  227. for ($i=0; $i<$len; $i+=$wid) {
  228. $wid > $len-$i and $wid = $len-$i;
  229. my $dat = substr($$dataPt, $i, $wid);
  230. Write($outfile, "% ", uc(unpack('H*',$dat)), $/) or $success = 0;
  231. }
  232. Write($outfile, $endToken, $/) or $success = 0;
  233. } else {
  234. $et->Warn("Can't write PS directory $dirName");
  235. }
  236. undef $val;
  237. return $success;
  238. }
  239. #------------------------------------------------------------------------------
  240. # Encode postscript tag/value
  241. # Inputs: 0) tag ID, 1) value
  242. # Returns: postscript comment
  243. # - adds brackets, escapes special characters, and limits line length
  244. sub EncodeTag($$)
  245. {
  246. my ($tag, $val) = @_;
  247. unless ($val =~ /^\d+$/) {
  248. $val =~ s/([()\\])/\\$1/g; # escape brackets and backslashes
  249. $val =~ s/\n/\\n/g; # escape newlines
  250. $val =~ s/\r/\\r/g; # escape carriage returns
  251. $val =~ s/\t/\\t/g; # escape tabs
  252. # use octal escape codes for other control characters
  253. $val =~ s/([\x00-\x1f\x7f\xff])/sprintf("\\%.3o",ord($1))/ge;
  254. $val = "($val)";
  255. }
  256. my $line = "%%$tag: $val";
  257. # postscript line limit is 255 characters (but it seems that
  258. # the limit may be 254 characters if the DOS CR/LF is used)
  259. # --> split if necessary using continuation comment "%%+"
  260. my $n;
  261. for ($n=254; length($line)>$n; $n+=254+length($/)) {
  262. substr($line, $n, 0) = "$/%%+";
  263. }
  264. return $line . $/;
  265. }
  266. #------------------------------------------------------------------------------
  267. # Write new tags information in comments section
  268. # Inputs: 0) ExifTool object ref, 1) output file ref, 2) reference to new tag hash
  269. # Returns: true on success
  270. sub WriteNewTags($$$)
  271. {
  272. my ($et, $outfile, $newTags) = @_;
  273. my $success = 1;
  274. my $tag;
  275. # get XMP hint and remove from tags hash
  276. my $xmpHint = $$newTags{XMP_HINT};
  277. delete $$newTags{XMP_HINT};
  278. foreach $tag (sort keys %$newTags) {
  279. my $tagInfo = $$newTags{$tag};
  280. my $nvHash = $et->GetNewValueHash($tagInfo);
  281. next unless $$nvHash{IsCreating};
  282. my $val = $et->GetNewValue($nvHash);
  283. $et->VerboseValue("+ PostScript:$$tagInfo{Name}", $val);
  284. Write($outfile, EncodeTag($tag, $val)) or $success = 0;
  285. ++$$et{CHANGED};
  286. }
  287. # write XMP hint if necessary
  288. Write($outfile, "%ADO_ContainsXMP: MainFirst$/") or $success = 0 if $xmpHint;
  289. %$newTags = (); # all done with new tags
  290. return $success;
  291. }
  292. #------------------------------------------------------------------------------
  293. # check to be sure we haven't read past end of PS data in DOS-style file
  294. # Inputs: 0) RAF ref, 1) pointer to end of PS, 2) data
  295. # - modifies data and sets RAF to EOF if end of PS is reached
  296. sub CheckPSEnd($$$)
  297. {
  298. my $pos = $_[0]->Tell();
  299. if ($pos >= $_[1]) {
  300. $_[0]->Seek(0, 2); # seek to end of file so we can't read any more
  301. $_[2] = substr($_[2], 0, length($_[2]) - $pos + $_[1]) if $pos > $_[1];
  302. }
  303. }
  304. #------------------------------------------------------------------------------
  305. # Split into lines ending in any CR, LF or CR+LF combination
  306. # (this is annoying, and could be avoided if EPS files didn't mix linefeeds!)
  307. # Inputs: 0) data pointer, 1) reference to lines array
  308. # Notes: Updates data to contain next line and fills list with remaining lines
  309. sub SplitLine($$)
  310. {
  311. my ($dataPt, $lines) = @_;
  312. for (;;) {
  313. my $endl;
  314. # find the position of the first LF (\x0a)
  315. $endl = pos($$dataPt), pos($$dataPt) = 0 if $$dataPt =~ /\x0a/g;
  316. if ($$dataPt =~ /\x0d/g) { # find the first CR (\x0d)
  317. if (defined $endl) {
  318. # (remember, CR+LF is a DOS newline...)
  319. $endl = pos($$dataPt) if pos($$dataPt) < $endl - 1;
  320. } else {
  321. $endl = pos($$dataPt);
  322. }
  323. } elsif (not defined $endl) {
  324. push @$lines, $$dataPt;
  325. last;
  326. }
  327. # split into separate lines
  328. if (length $$dataPt == $endl) {
  329. push @$lines, $$dataPt;
  330. last;
  331. } else {
  332. push @$lines, substr($$dataPt, 0, $endl);
  333. $$dataPt = substr($$dataPt, $endl);
  334. }
  335. }
  336. $$dataPt = shift @$lines; # set $$dataPt to first line
  337. }
  338. #------------------------------------------------------------------------------
  339. # Write PS file
  340. # Inputs: 0) ExifTool object reference, 1) source dirInfo reference
  341. # Returns: 1 on success, 0 if this wasn't a valid PS file,
  342. # or -1 if a write error occurred
  343. sub WritePS($$)
  344. {
  345. my ($et, $dirInfo) = @_;
  346. $et or return 1; # allow dummy access to autoload this package
  347. my $tagTablePtr = Image::ExifTool::GetTagTable('Image::ExifTool::PostScript::Main');
  348. my $raf = $$dirInfo{RAF};
  349. my $outfile = $$dirInfo{OutFile};
  350. my $verbose = $et->Options('Verbose');
  351. my $out = $et->Options('TextOut');
  352. my ($data, $buff, %flags, $err, $mode, $endToken);
  353. my ($dos, $psStart, $psEnd, $psNewStart, $xmpHint);
  354. $raf->Read($data, 4) == 4 or return 0;
  355. return 0 unless $data =~ /^(%!PS|%!Ad|\xc5\xd0\xd3\xc6)/;
  356. if ($data =~ /^%!Ad/) {
  357. # I've seen PS files start with "%!Adobe-PS"...
  358. return 0 unless $raf->Read($buff, 6) == 6 and $buff eq "obe-PS";
  359. $data .= $buff;
  360. } elsif ($data =~ /^\xc5\xd0\xd3\xc6/) {
  361. #
  362. # process DOS binary PS files
  363. #
  364. # save DOS header then seek ahead and check PS header
  365. $raf->Read($dos, 26) == 26 or return 0;
  366. $dos = $data . $dos;
  367. SetByteOrder('II');
  368. $psStart = Get32u(\$dos, 4);
  369. unless ($raf->Seek($psStart, 0) and
  370. $raf->Read($data, 4) == 4 and $data eq '%!PS')
  371. {
  372. $et->Error('Invalid PS header');
  373. return 1;
  374. }
  375. $psEnd = $psStart + Get32u(\$dos, 8);
  376. my $base = Get32u(\$dos, 20);
  377. Set16u(0xffff, \$dos, 28); # ignore checksum
  378. if ($base) {
  379. my %dirInfo = (
  380. Parent => 'PS',
  381. RAF => $raf,
  382. Base => $base,
  383. NoTiffEnd => 1, # no end-of-TIFF check
  384. );
  385. $buff = $et->WriteTIFF(\%dirInfo);
  386. SetByteOrder('II'); # (WriteTIFF may change this)
  387. if ($buff) {
  388. $buff = substr($buff, $base); # remove header written by WriteTIFF()
  389. } else {
  390. # error rewriting TIFF, so just copy over original data
  391. my $len = Get32u(\$dos, 24);
  392. unless ($raf->Seek($base, 0) and $raf->Read($buff, $len) == $len) {
  393. $et->Error('Error reading embedded TIFF');
  394. return 1;
  395. }
  396. $et->Warn('Bad embedded TIFF');
  397. }
  398. Set32u(0, \$dos, 12); # zero metafile pointer
  399. Set32u(0, \$dos, 16); # zero metafile length
  400. Set32u(length($dos), \$dos, 20); # set TIFF pointer
  401. Set32u(length($buff), \$dos, 24); # set TIFF length
  402. } elsif (($base = Get32u(\$dos, 12)) != 0) {
  403. # copy over metafile section
  404. my $len = Get32u(\$dos, 16);
  405. unless ($raf->Seek($base, 0) and $raf->Read($buff, $len) == $len) {
  406. $et->Error('Error reading metafile section');
  407. return 1;
  408. }
  409. Set32u(length($dos), \$dos, 12); # set metafile pointer
  410. } else {
  411. $buff = '';
  412. }
  413. $psNewStart = length($dos) + length($buff);
  414. Set32u($psNewStart, \$dos, 4); # set pointer to start of PS
  415. Write($outfile, $dos, $buff) or $err = 1;
  416. $raf->Seek($psStart + 4, 0); # seek back to where we were
  417. }
  418. #
  419. # rewrite PostScript data
  420. #
  421. local $/ = GetInputRecordSeparator($raf);
  422. unless ($/ and $raf->ReadLine($buff)) {
  423. $et->Error('Invalid PostScript data');
  424. return 1;
  425. }
  426. $data .= $buff;
  427. unless ($data =~ /^%!PS-Adobe-3\.(\d+)\b/ and $1 < 2) {
  428. if ($et->Error("Document does not conform to DSC spec. Metadata may be unreadable by other apps", 2)) {
  429. return 1;
  430. }
  431. }
  432. my $psRev = $1; # save PS revision number (3.x)
  433. Write($outfile, $data) or $err = 1;
  434. $flags{EPS} = 1 if $data =~ /EPSF/;
  435. # get hash of new information keyed by tagID and directories to add/edit
  436. my $newTags = $et->GetNewTagInfoHash($tagTablePtr);
  437. # figure out which directories we need to write (PostScript takes priority)
  438. $et->InitWriteDirs(\%psMap, 'PostScript');
  439. my $addDirs = $$et{ADD_DIRS};
  440. my $editDirs = $$et{EDIT_DIRS};
  441. my %doneDir;
  442. # set XMP hint flag (1 for adding, 0 for deleting, undef for no change)
  443. $xmpHint = 1 if $$addDirs{XMP};
  444. $xmpHint = 0 if $$et{DEL_GROUP}{XMP};
  445. $$newTags{XMP_HINT} = $xmpHint if $xmpHint; # add special tag to newTags list
  446. my (@lines, $changedNL);
  447. my $altnl = ($/ eq "\x0d") ? "\x0a" : "\x0d";
  448. for (;;) {
  449. if (@lines) {
  450. $data = shift @lines;
  451. } else {
  452. $raf->ReadLine($data) or last;
  453. $dos and CheckPSEnd($raf, $psEnd, $data);
  454. # split line if it contains other newline sequences
  455. if ($data =~ /$altnl/) {
  456. if (length($data) > 500000 and IsPC()) {
  457. # patch for Windows memory problem
  458. unless ($changedNL) {
  459. $changedNL = 1;
  460. my $t = $/;
  461. $/ = $altnl;
  462. $altnl = $t;
  463. $raf->Seek(-length($data), 1);
  464. next;
  465. }
  466. } else {
  467. # split into separate lines
  468. SplitLine(\$data, \@lines);
  469. }
  470. }
  471. }
  472. undef $changedNL;
  473. if ($endToken) {
  474. # look for end token
  475. if ($data =~ m/^$endToken\s*$/is) {
  476. undef $endToken;
  477. # found end: process this information
  478. if ($mode) {
  479. $doneDir{$mode} and $et->Error("Multiple $mode directories", 1);
  480. $doneDir{$mode} = 1;
  481. WritePSDirectory($et, $outfile, $mode, \$buff, \%flags) or $err = 1;
  482. # write end token if we wrote the begin token
  483. Write($outfile, $data) or $err = 1 if $flags{WROTE_BEGIN};
  484. undef $buff;
  485. } else {
  486. Write($outfile, $data) or $err = 1;
  487. }
  488. } else {
  489. # buffer data in current begin/end block
  490. if (not defined $mode) {
  491. # pick up XMP in unrecognized blocks for editing in place
  492. if ($data =~ /^<\?xpacket begin=.{7,13}W5M0MpCehiHzreSzNTczkc9d/ and
  493. $$editDirs{XMP})
  494. {
  495. $buff = $data;
  496. $mode = 'XMP';
  497. } else {
  498. Write($outfile, $data) or $err = 1;
  499. }
  500. } elsif ($mode eq 'XMP') {
  501. $buff .= $data;
  502. } else {
  503. # data is ASCII-hex encoded
  504. $data =~ tr/0-9A-Fa-f//dc; # remove all but hex characters
  505. $buff .= pack('H*', $data); # translate from hex
  506. }
  507. }
  508. next;
  509. } elsif ($data =~ m{^(%{1,2})(Begin)(?!Object:)(.*?)[:\x0d\x0a]}i) {
  510. # comments section is over... write any new tags now
  511. WriteNewTags($et, $outfile, $newTags) or $err = 1 if %$newTags;
  512. undef $xmpHint;
  513. # the beginning of a data block (can only write XMP and Photoshop)
  514. my %modeLookup = (
  515. _xml_code => 'XMP',
  516. photoshop => 'Photoshop',
  517. iccprofile => 'ICC_Profile',
  518. );
  519. $verbose > 1 and print $out "$2$3\n";
  520. $endToken = $1 . ($2 eq 'begin' ? 'end' : 'End') . $3;
  521. $mode = $modeLookup{lc($3)};
  522. if ($mode and $$editDirs{$mode}) {
  523. $buff = ''; # initialize buffer for this block
  524. $flags{WROTE_BEGIN} = 0;
  525. } else {
  526. undef $mode; # not editing this directory
  527. Write($outfile, $data) or $err = 1;
  528. $flags{WROTE_BEGIN} = 1;
  529. }
  530. next;
  531. } elsif ($data =~ /^%%(?!Page:|PlateFile:|BeginObject:)(\w+): ?(.*)/s) {
  532. # rewrite information from PostScript tags in comments
  533. my ($tag, $val) = ($1, $2);
  534. # handle Adobe Illustrator files specially
  535. # - EVENTUALLY IT WOULD BE BETTER TO FIND ANOTHER IDENTIFICATION METHOD
  536. # (because Illustrator doesn't care if the Creator is changed)
  537. if ($tag eq 'Creator' and $val =~ /^Adobe Illustrator/) {
  538. # disable writing XMP to PostScript-format Adobe Illustrator files
  539. # because it confuses Illustrator
  540. if ($$editDirs{XMP}) {
  541. $et->Warn("Can't write XMP to PostScript-format Illustrator files");
  542. # pretend like we wrote it already so we won't try to add it later
  543. $doneDir{XMP} = 1;
  544. }
  545. # don't allow "Creator" to be changed in Illustrator files
  546. # (we need it to be able to recognize these files)
  547. # --> find a better way to do this!
  548. if ($$newTags{$tag}) {
  549. $et->Warn("Can't change Postscript:Creator of Illustrator files");
  550. delete $$newTags{$tag};
  551. }
  552. }
  553. if ($$newTags{$tag}) {
  554. my $tagInfo = $$newTags{$tag};
  555. delete $$newTags{$tag}; # write it then forget it
  556. next unless ref $tagInfo;
  557. # decode comment string (reading continuation lines if necessary)
  558. $val = DecodeComment($val, $raf, \@lines, \$data);
  559. $val = join $et->Options('ListSep'), @$val if ref $val eq 'ARRAY';
  560. my $nvHash = $et->GetNewValueHash($tagInfo);
  561. if ($et->IsOverwriting($nvHash, $val)) {
  562. $et->VerboseValue("- PostScript:$$tagInfo{Name}", $val);
  563. $val = $et->GetNewValue($nvHash);
  564. ++$$et{CHANGED};
  565. next unless defined $val; # next if tag is being deleted
  566. $et->VerboseValue("+ PostScript:$$tagInfo{Name}", $val);
  567. $data = EncodeTag($tag, $val);
  568. }
  569. }
  570. # (note: Adobe InDesign doesn't put colon after %ADO_ContainsXMP -- doh!)
  571. } elsif (defined $xmpHint and $data =~ m{^%ADO_ContainsXMP:? ?(.+?)[\x0d\x0a]*$}s) {
  572. # change the XMP hint if necessary
  573. if ($xmpHint) {
  574. $data = "%ADO_ContainsXMP: MainFirst$/" if $1 eq 'NoMain';
  575. } else {
  576. $data = "%ADO_ContainsXMP: NoMain$/";
  577. }
  578. # delete XMP hint flags
  579. delete $$newTags{XMP_HINT};
  580. undef $xmpHint;
  581. } else {
  582. # look for end of comments section
  583. if (%$newTags and ($data !~ /^%\S/ or
  584. $data =~ /^%(%EndComments|%Page:|%PlateFile:|%BeginObject:|.*BeginLayer)/))
  585. {
  586. # write new tags at end of comments section
  587. WriteNewTags($et, $outfile, $newTags) or $err = 1;
  588. undef $xmpHint;
  589. }
  590. # look for start of drawing commands (AI uses "%AI5_BeginLayer",
  591. # and Helios uses "%%BeginObject:")
  592. if ($data =~ /^%(%Page:|%PlateFile:|%BeginObject:|.*BeginLayer)/ or
  593. $data !~ m{^(%.*|\s*)$}s)
  594. {
  595. # we have reached the first page or drawing command, so create necessary
  596. # directories and copy the rest of the file, then all done
  597. my $dir;
  598. my $plateFile = ($data =~ /^%%PlateFile:/);
  599. # create Photoshop first, then XMP if necessary
  600. foreach $dir (qw{Photoshop ICC_Profile XMP}) {
  601. next unless $$editDirs{$dir} and not $doneDir{$dir};
  602. if ($plateFile) {
  603. # PlateFile comments may contain offsets so we can't edit these files!
  604. $et->Warn("Can only edit PostScript information DCS Plate files");
  605. last;
  606. }
  607. next unless $$addDirs{$dir} or $dir eq 'XMP';
  608. $flags{WROTE_BEGIN} = 0;
  609. WritePSDirectory($et, $outfile, $dir, undef, \%flags) or $err = 1;
  610. $doneDir{$dir} = 1;
  611. }
  612. # copy rest of file
  613. if ($flags{TRAILER}) {
  614. # write trailer before %%EOF
  615. for (;;) {
  616. Write($outfile, $data) or $err = 1;
  617. if (@lines) {
  618. $data = shift @lines;
  619. } else {
  620. $raf->ReadLine($data) or undef($data), last;
  621. $dos and CheckPSEnd($raf, $psEnd, $data);
  622. if ($data =~ /[\x0d\x0a]%%EOF\b/g) {
  623. # split data before "%%EOF"
  624. # (necessary if data contains other newline sequences)
  625. my $pos = pos($data) - 5;
  626. push @lines, substr($data, $pos);
  627. $data = substr($data, 0, $pos);
  628. }
  629. }
  630. last if $data =~ /^%%EOF\b/;
  631. }
  632. Write($outfile, $flags{TRAILER}) or $err = 1;
  633. }
  634. # simply copy the rest of the file if any data is left
  635. if (defined $data) {
  636. Write($outfile, $data) or $err = 1;
  637. Write($outfile, @lines) or $err = 1 if @lines;
  638. while ($raf->Read($data, 65536)) {
  639. $dos and CheckPSEnd($raf, $psEnd, $data);
  640. Write($outfile, $data) or $err = 1;
  641. }
  642. }
  643. last; # all done!
  644. }
  645. }
  646. # write new information or copy existing line
  647. Write($outfile, $data) or $err = 1;
  648. }
  649. if ($dos and not $err) {
  650. # must go back and set length of PS section in DOS header (very dumb design)
  651. if (ref $outfile eq 'SCALAR') {
  652. Set32u(length($$outfile) - $psNewStart, $outfile, 8);
  653. } else {
  654. my $pos = tell $outfile;
  655. unless (seek($outfile, 8, 0) and
  656. print $outfile Set32u($pos - $psNewStart) and
  657. seek($outfile, $pos, 0))
  658. {
  659. $et->Error("Can't write DOS-style PS files in non-seekable stream");
  660. $err = 1;
  661. }
  662. }
  663. }
  664. # issue warning if we couldn't write any information
  665. unless ($err) {
  666. my (@notDone, $dir);
  667. delete $$newTags{XMP_HINT};
  668. push @notDone, 'PostScript' if %$newTags;
  669. foreach $dir (qw{Photoshop ICC_Profile XMP}) {
  670. push @notDone, $dir if $$editDirs{$dir} and not $doneDir{$dir} and
  671. not $$et{DEL_GROUP}{$dir};
  672. }
  673. @notDone and $et->Warn("Couldn't write ".join('/',@notDone).' information');
  674. }
  675. $endToken and $et->Error("File missing $endToken");
  676. return $err ? -1 : 1;
  677. }
  678. 1; # end
  679. __END__
  680. =head1 NAME
  681. Image::ExifTool::WritePostScript.pl - Write PostScript meta information
  682. =head1 SYNOPSIS
  683. This file is autoloaded by Image::ExifTool::PostScript.
  684. =head1 DESCRIPTION
  685. This file contains routines to write meta information in PostScript
  686. documents. Six forms of meta information may be written:
  687. 1) PostScript comments (Adobe DSC specification)
  688. 2) XMP information embedded in a document-level XMP stream
  689. 3) EXIF information embedded in a Photoshop record
  690. 4) IPTC information embedded in a PhotoShop record
  691. 5) ICC_Profile information embedded in an ICCProfile record
  692. 6) TIFF information embedded in DOS-style binary header
  693. =head1 NOTES
  694. Currently, information is written only in the outer-level document.
  695. Photoshop will discard meta information in a PostScript document if it has
  696. to rasterize the image, and it will rasterize anything that doesn't contain
  697. the Photoshop-specific 'ImageData' tag. So don't expect Photoshop to read
  698. any meta information added to EPS images that it didn't create.
  699. The following two acronyms may be confusing since they are so similar and
  700. have different meanings with respect to PostScript documents:
  701. DSC = Document Structuring Conventions
  702. DCS = Desktop Color Separation
  703. =head1 REFERENCES
  704. See references in L<PostScript.pm|Image::ExifTool::PostScript>, plus:
  705. =over 4
  706. =item L<http://www.adobe.com/products/postscript/pdfs/PLRM.pdf>
  707. =item L<http://www-cdf.fnal.gov/offline/PostScript/PLRM2.pdf>
  708. =item L<http://partners.adobe.com/public/developer/en/acrobat/sdk/pdf/pdf_creation_apis_and_specs/pdfmarkReference.pdf>
  709. =back
  710. =head1 ACKNOWLEDGEMENTS
  711. Thanks to Tim Kordick for his help testing the EPS writer.
  712. =head1 AUTHOR
  713. Copyright 2003-2016, Phil Harvey (phil at owl.phy.queensu.ca)
  714. This library is free software; you can redistribute it and/or modify it
  715. under the same terms as Perl itself.
  716. =head1 SEE ALSO
  717. L<Image::ExifTool::PostScript(3pm)|Image::ExifTool::PostScript>,
  718. L<Image::ExifTool(3pm)|Image::ExifTool>
  719. =cut