PostScript.pm 26 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699
  1. #------------------------------------------------------------------------------
  2. # File: PostScript.pm
  3. #
  4. # Description: Read PostScript meta information
  5. #
  6. # Revisions: 07/08/2005 - P. Harvey Created
  7. #
  8. # References: 1) http://partners.adobe.com/public/developer/en/ps/5002.EPSF_Spec.pdf
  9. # 2) http://partners.adobe.com/public/developer/en/ps/5001.DSC_Spec.pdf
  10. # 3) http://partners.adobe.com/public/developer/en/illustrator/sdk/AI7FileFormat.pdf
  11. #------------------------------------------------------------------------------
  12. package Image::ExifTool::PostScript;
  13. use strict;
  14. use vars qw($VERSION $AUTOLOAD);
  15. use Image::ExifTool qw(:DataAccess :Utils);
  16. $VERSION = '1.41';
  17. sub WritePS($$);
  18. sub ProcessPS($$;$);
  19. # PostScript tag table
  20. %Image::ExifTool::PostScript::Main = (
  21. PROCESS_PROC => \&ProcessPS,
  22. WRITE_PROC => \&WritePS,
  23. PREFERRED => 1, # always add these tags when writing
  24. GROUPS => { 2 => 'Image' },
  25. # Note: Make all of these tags priority 0 since the first one found at
  26. # the start of the file should take priority (in case multiples exist)
  27. Author => { Priority => 0, Groups => { 2 => 'Author' }, Writable => 'string' },
  28. BoundingBox => { Priority => 0 },
  29. Copyright => { Priority => 0, Writable => 'string' }, #2
  30. CreationDate => {
  31. Name => 'CreateDate',
  32. Priority => 0,
  33. Groups => { 2 => 'Time' },
  34. Writable => 'string',
  35. PrintConv => '$self->ConvertDateTime($val)',
  36. PrintConvInv => '$self->InverseDateTime($val)',
  37. },
  38. Creator => { Priority => 0, Writable => 'string' },
  39. ImageData => { Priority => 0 },
  40. For => { Priority => 0, Writable => 'string', Notes => 'for whom the document was prepared'},
  41. Keywords => { Priority => 0, Writable => 'string' },
  42. ModDate => {
  43. Name => 'ModifyDate',
  44. Priority => 0,
  45. Groups => { 2 => 'Time' },
  46. Writable => 'string',
  47. PrintConv => '$self->ConvertDateTime($val)',
  48. PrintConvInv => '$self->InverseDateTime($val)',
  49. },
  50. Pages => { Priority => 0 },
  51. Routing => { Priority => 0, Writable => 'string' }, #2
  52. Subject => { Priority => 0, Writable => 'string' },
  53. Title => { Priority => 0, Writable => 'string' },
  54. Version => { Priority => 0, Writable => 'string' }, #2
  55. # these subdirectories for documentation only
  56. BeginPhotoshop => {
  57. Name => 'PhotoshopData',
  58. SubDirectory => {
  59. TagTable => 'Image::ExifTool::Photoshop::Main',
  60. },
  61. },
  62. BeginICCProfile => {
  63. Name => 'ICC_Profile',
  64. SubDirectory => {
  65. TagTable => 'Image::ExifTool::ICC_Profile::Main',
  66. },
  67. },
  68. begin_xml_packet => {
  69. Name => 'XMP',
  70. SubDirectory => {
  71. TagTable => 'Image::ExifTool::XMP::Main',
  72. },
  73. },
  74. TIFFPreview => {
  75. Groups => { 2 => 'Preview' },
  76. Binary => 1,
  77. Notes => q{
  78. not a real tag ID, but used to represent the TIFF preview extracted from DOS
  79. EPS images
  80. },
  81. },
  82. BeginDocument => {
  83. Name => 'EmbeddedFile',
  84. SubDirectory => {
  85. TagTable => 'Image::ExifTool::PostScript::Main',
  86. },
  87. Notes => 'extracted with ExtractEmbedded option',
  88. },
  89. EmbeddedFileName => {
  90. Notes => q{
  91. not a real tag ID, but the file name from a BeginDocument statement.
  92. Extracted with document metadata when ExtractEmbedded option is used
  93. },
  94. },
  95. );
  96. # composite tags
  97. %Image::ExifTool::PostScript::Composite = (
  98. GROUPS => { 2 => 'Image' },
  99. # BoundingBox is in points, not pixels,
  100. # but use it anyway if ImageData is not available
  101. ImageWidth => {
  102. Desire => {
  103. 0 => 'Main:PostScript:ImageData',
  104. 1 => 'PostScript:BoundingBox',
  105. },
  106. ValueConv => 'Image::ExifTool::PostScript::ImageSize(\@val, 0)',
  107. },
  108. ImageHeight => {
  109. Desire => {
  110. 0 => 'Main:PostScript:ImageData',
  111. 1 => 'PostScript:BoundingBox',
  112. },
  113. ValueConv => 'Image::ExifTool::PostScript::ImageSize(\@val, 1)',
  114. },
  115. );
  116. # add our composite tags
  117. Image::ExifTool::AddCompositeTags('Image::ExifTool::PostScript');
  118. #------------------------------------------------------------------------------
  119. # AutoLoad our writer routines when necessary
  120. #
  121. sub AUTOLOAD
  122. {
  123. return Image::ExifTool::DoAutoLoad($AUTOLOAD, @_);
  124. }
  125. #------------------------------------------------------------------------------
  126. # Is this a PC system
  127. # Returns: true for PC systems
  128. my %isPC = (MSWin32 => 1, os2 => 1, dos => 1, NetWare => 1, symbian => 1, cygwin => 1);
  129. sub IsPC()
  130. {
  131. return $isPC{$^O};
  132. }
  133. #------------------------------------------------------------------------------
  134. # Get image width or height
  135. # Inputs: 0) value list ref (ImageData, BoundingBox), 1) true to get height
  136. sub ImageSize($$)
  137. {
  138. my ($vals, $getHeight) = @_;
  139. my ($w, $h);
  140. if ($$vals[0] and $$vals[0] =~ /^(\d+) (\d+)/) {
  141. ($w, $h) = ($1, $2);
  142. } elsif ($$vals[1] and $$vals[1] =~ /^(\d+) (\d+) (\d+) (\d+)/) {
  143. ($w, $h) = ($3 - $1, $4 - $2);
  144. }
  145. return $getHeight ? $h : $w;
  146. }
  147. #------------------------------------------------------------------------------
  148. # Set PostScript format error warning
  149. # Inputs: 0) ExifTool object reference, 1) error string
  150. # Returns: 1
  151. sub PSErr($$)
  152. {
  153. my ($et, $str) = @_;
  154. # set file type if not done already
  155. my $ext = $$et{FILE_EXT};
  156. $et->SetFileType(($ext and $ext eq 'AI') ? 'AI' : 'PS');
  157. $et->Warn("PostScript format error ($str)");
  158. return 1;
  159. }
  160. #------------------------------------------------------------------------------
  161. # Return input record separator to use for the specified file
  162. # Inputs: 0) RAF reference
  163. # Returns: Input record separator or undef on error
  164. sub GetInputRecordSeparator($)
  165. {
  166. my $raf = shift;
  167. my $pos = $raf->Tell(); # save current position
  168. my ($data, $sep);
  169. $raf->Read($data,256) or return undef;
  170. my ($a, $d) = (999,999);
  171. $a = pos($data), pos($data) = 0 if $data =~ /\x0a/g;
  172. $d = pos($data) if $data =~ /\x0d/g;
  173. my $diff = $a - $d;
  174. if ($diff eq 1) {
  175. $sep = "\x0d\x0a";
  176. } elsif ($diff eq -1) {
  177. $sep = "\x0a\x0d";
  178. } elsif ($diff > 0) {
  179. $sep = "\x0d";
  180. } elsif ($diff < 0) {
  181. $sep = "\x0a";
  182. } # else error
  183. $raf->Seek($pos, 0); # restore original position
  184. return $sep;
  185. }
  186. #------------------------------------------------------------------------------
  187. # Decode comment from PostScript file
  188. # Inputs: 0) comment string, 1) RAF ref, 2) reference to lines array
  189. # 3) optional data reference for extra lines read from file
  190. # Returns: Decoded comment string (may be an array reference)
  191. # - handles multi-line comments and escape sequences
  192. sub DecodeComment($$$;$)
  193. {
  194. my ($val, $raf, $lines, $dataPt) = @_;
  195. $val =~ s/\x0d*\x0a*$//; # remove trailing CR, LF or CR/LF
  196. # check for continuation comments
  197. for (;;) {
  198. unless (@$lines) {
  199. my $buff;
  200. $raf->ReadLine($buff) or last;
  201. my $altnl = $/ eq "\x0d" ? "\x0a" : "\x0d";
  202. if ($buff =~ /$altnl/) {
  203. chomp $buff if $/ eq "\x0d\x0a"; # remove DOS newline before splitting
  204. # split into separate lines
  205. @$lines = split /$altnl/, $buff, -1;
  206. # handle case of DOS newline data inside file using Unix newlines
  207. @$lines = ( $$lines[0] . $$lines[1] ) if @$lines == 2 and $$lines[1] eq $/;
  208. # add back trailing DOS newline if necessary
  209. @$lines ? @$lines[-1] .= $/ : push @$lines, $/ if $/ eq "\x0d\x0a";
  210. } else {
  211. push @$lines, $buff;
  212. }
  213. }
  214. last unless $$lines[0] =~ /^%%\+/; # is the next line a continuation?
  215. $$dataPt .= $$lines[0] if $dataPt; # add to data if necessary
  216. $$lines[0] =~ s/\x0d*\x0a*$//; # remove trailing CR, LF or CR/LF
  217. $val .= substr(shift(@$lines), 3); # add to value (without leading "%%+")
  218. }
  219. my @vals;
  220. # handle bracketed string values
  221. if ($val =~ s/^\((.*)\)$/$1/) { # remove brackets if necessary
  222. # split into an array of strings if necessary
  223. my $nesting = 1;
  224. while ($val =~ /(\(|\))/g) {
  225. my $bra = $1;
  226. my $pos = pos($val) - 2;
  227. my $backslashes = 0;
  228. while ($pos and substr($val, $pos, 1) eq '\\') {
  229. --$pos;
  230. ++$backslashes;
  231. }
  232. next if $backslashes & 0x01; # escaped if odd number
  233. if ($bra eq '(') {
  234. ++$nesting;
  235. } else {
  236. --$nesting;
  237. unless ($nesting) {
  238. push @vals, substr($val, 0, pos($val)-1);
  239. $val = substr($val, pos($val));
  240. ++$nesting if $val =~ s/\s*\(//;
  241. }
  242. }
  243. }
  244. push @vals, $val;
  245. foreach $val (@vals) {
  246. # decode escape sequences in bracketed strings
  247. # (similar to code in PDF.pm, but without line continuation)
  248. while ($val =~ /\\(.)/sg) {
  249. my $n = pos($val) - 2;
  250. my $c = $1;
  251. my $r;
  252. if ($c =~ /[0-7]/) {
  253. # get up to 2 more octal digits
  254. $c .= $1 if $val =~ /\G([0-7]{1,2})/g;
  255. # convert octal escape code
  256. $r = chr(oct($c) & 0xff);
  257. } else {
  258. # convert escaped characters
  259. ($r = $c) =~ tr/nrtbf/\n\r\t\b\f/;
  260. }
  261. substr($val, $n, length($c)+1) = $r;
  262. # continue search after this character
  263. pos($val) = $n + length($r);
  264. }
  265. }
  266. $val = @vals > 1 ? \@vals : $vals[0];
  267. }
  268. return $val;
  269. }
  270. #------------------------------------------------------------------------------
  271. # Unescape PostScript string
  272. # Inputs: 0) string
  273. # Returns: unescaped string
  274. sub UnescapePostScript($)
  275. {
  276. my $str = shift;
  277. # decode escape sequences in literal strings
  278. while ($str =~ /\\(.)/sg) {
  279. my $n = pos($str) - 2;
  280. my $c = $1;
  281. my $r;
  282. if ($c =~ /[0-7]/) {
  283. # get up to 2 more octal digits
  284. $c .= $1 if $str =~ /\G([0-7]{1,2})/g;
  285. # convert octal escape code
  286. $r = chr(oct($c) & 0xff);
  287. } elsif ($c eq "\x0d") {
  288. # the string is continued if the line ends with '\'
  289. # (also remove "\x0d\x0a")
  290. $c .= $1 if $str =~ /\G(\x0a)/g;
  291. $r = '';
  292. } elsif ($c eq "\x0a") {
  293. $r = '';
  294. } else {
  295. # convert escaped characters
  296. ($r = $c) =~ tr/nrtbf/\n\r\t\b\f/;
  297. }
  298. substr($str, $n, length($c)+1) = $r;
  299. # continue search after this character
  300. pos($str) = $n + length($r);
  301. }
  302. return $str;
  303. }
  304. #------------------------------------------------------------------------------
  305. # Extract information from EPS, PS or AI file
  306. # Inputs: 0) ExifTool object reference, 1) dirInfo reference, 2) optional tag table ref
  307. # Returns: 1 if this was a valid PostScript file
  308. sub ProcessPS($$;$)
  309. {
  310. my ($et, $dirInfo, $tagTablePtr) = @_;
  311. my $raf = $$dirInfo{RAF};
  312. my $embedded = $et->Options('ExtractEmbedded');
  313. my ($data, $dos, $endDoc, $fontTable, $comment);
  314. # allow read from data
  315. unless ($raf) {
  316. $raf = new File::RandomAccess($$dirInfo{DataPt});
  317. $et->VerboseDir('PostScript');
  318. }
  319. #
  320. # determine if this is a postscript file
  321. #
  322. $raf->Read($data, 4) == 4 or return 0;
  323. # accept either ASCII or DOS binary postscript file format
  324. return 0 unless $data =~ /^(%!PS|%!Ad|%!Fo|\xc5\xd0\xd3\xc6)/;
  325. if ($data =~ /^%!Ad/) {
  326. # I've seen PS files start with "%!Adobe-PS"...
  327. return 0 unless $raf->Read($data, 6) == 6 and $data eq "obe-PS";
  328. } elsif ($data =~ /^\xc5\xd0\xd3\xc6/) {
  329. # process DOS binary file header
  330. # - save DOS header then seek ahead and check PS header
  331. $raf->Read($dos, 26) == 26 or return 0;
  332. SetByteOrder('II');
  333. unless ($raf->Seek(Get32u(\$dos, 0), 0) and
  334. $raf->Read($data, 4) == 4 and $data eq '%!PS')
  335. {
  336. return PSErr($et, 'invalid header');
  337. }
  338. } else {
  339. # check for PostScript font file (PFA or PFB)
  340. my $d2;
  341. $data .= $d2 if $raf->Read($d2,12);
  342. if ($data =~ /^%!(PS-(AdobeFont-|Bitstream )|FontType1-)/) {
  343. $et->SetFileType('PFA'); # PostScript ASCII font file
  344. $fontTable = GetTagTable('Image::ExifTool::Font::PSInfo');
  345. # PostScript font files may contain an unformatted comments which may
  346. # contain useful information, so accumulate these for the Comment tag
  347. $comment = 1;
  348. }
  349. $raf->Seek(-length($data), 1);
  350. }
  351. #
  352. # set the newline type based on the first newline found in the file
  353. #
  354. local $/ = GetInputRecordSeparator($raf);
  355. $/ or return PSErr($et, 'invalid PS data');
  356. # set file type (PostScript or EPS)
  357. $raf->ReadLine($data) or $data = '';
  358. my $type;
  359. if ($data =~ /EPSF/) {
  360. $type = 'EPS';
  361. } else {
  362. # read next line to see if this is an Illustrator file
  363. my $line2;
  364. my $pos = $raf->Tell();
  365. if ($raf->ReadLine($line2) and $line2 =~ /^%%Creator: Adobe Illustrator/) {
  366. $type = 'AI';
  367. } else {
  368. $type = 'PS';
  369. }
  370. $raf->Seek($pos, 0);
  371. }
  372. $et->SetFileType($type);
  373. return 1 if $$et{OPTIONS}{FastScan} and $$et{OPTIONS}{FastScan} == 3;
  374. #
  375. # extract TIFF information from DOS header
  376. #
  377. $tagTablePtr or $tagTablePtr = GetTagTable('Image::ExifTool::PostScript::Main');
  378. if ($dos) {
  379. my $base = Get32u(\$dos, 16);
  380. if ($base) {
  381. my $pos = $raf->Tell();
  382. # extract the TIFF preview
  383. my $len = Get32u(\$dos, 20);
  384. my $val = $et->ExtractBinary($base, $len, 'TIFFPreview');
  385. if (defined $val and $val =~ /^(MM\0\x2a|II\x2a\0|Binary)/) {
  386. $et->HandleTag($tagTablePtr, 'TIFFPreview', $val);
  387. } else {
  388. $et->Warn('Bad TIFF preview image');
  389. }
  390. # extract information from TIFF in DOS header
  391. # (set Parent to '' to avoid setting FileType tag again)
  392. my %dirInfo = (
  393. Parent => '',
  394. RAF => $raf,
  395. Base => $base,
  396. );
  397. $et->ProcessTIFF(\%dirInfo) or $et->Warn('Bad embedded TIFF');
  398. # position file pointer to extract PS information
  399. $raf->Seek($pos, 0);
  400. }
  401. }
  402. #
  403. # parse the postscript
  404. #
  405. my ($buff, $mode, $beginToken, $endToken, $docNum, $subDocNum, $changedNL);
  406. my (@lines, $altnl);
  407. if ($/ eq "\x0d") {
  408. $altnl = "\x0a";
  409. } else {
  410. $/ = "\x0a"; # end on any LF (even if DOS CR+LF)
  411. $altnl = "\x0d";
  412. }
  413. for (;;) {
  414. if (@lines) {
  415. $data = shift @lines;
  416. } else {
  417. $raf->ReadLine($data) or last;
  418. # check for alternate newlines as efficiently as possible
  419. if ($data =~ /$altnl/) {
  420. if (length($data) > 500000 and IsPC()) {
  421. # Windows can't split very long lines due to poor memory handling,
  422. # so re-read the file with the other newline character instead
  423. # (slower but uses less memory)
  424. unless ($changedNL) {
  425. $changedNL = 1;
  426. my $t = $/;
  427. $/ = $altnl;
  428. $altnl = $t;
  429. $raf->Seek(-length($data), 1);
  430. next;
  431. }
  432. } else {
  433. # split into separate lines
  434. @lines = split /$altnl/, $data, -1;
  435. $data = shift @lines;
  436. if (@lines == 1 and $lines[0] eq $/) {
  437. # handle case of DOS newline data inside file using Unix newlines
  438. $data .= $lines[0];
  439. undef @lines;
  440. }
  441. }
  442. }
  443. }
  444. undef $changedNL;
  445. if ($mode) {
  446. if (not $endToken) {
  447. $buff .= $data;
  448. next unless $data =~ m{<\?xpacket end=.(w|r).\?>($/|$)};
  449. } elsif ($data !~ /^$endToken/i) {
  450. if ($mode eq 'XMP') {
  451. $buff .= $data;
  452. } elsif ($mode eq 'Document') {
  453. # ignore embedded documents, but keep track of nesting level
  454. $docNum .= '-1' if $data =~ /^$beginToken/;
  455. } else {
  456. # data is ASCII-hex encoded
  457. $data =~ tr/0-9A-Fa-f//dc; # remove all but hex characters
  458. $buff .= pack('H*', $data); # translate from hex
  459. }
  460. next;
  461. } elsif ($mode eq 'Document') {
  462. $docNum =~ s/-?\d+$//; # decrement document nesting level
  463. # done with Document mode if we are back at the top level
  464. undef $mode unless $docNum;
  465. next;
  466. }
  467. } elsif ($endDoc and $data =~ /^$endDoc/i) {
  468. $docNum =~ s/-?(\d+)$//; # decrement nesting level
  469. $subDocNum = $1; # remember our last sub-document number
  470. $$et{DOC_NUM} = $docNum;
  471. undef $endDoc unless $docNum; # done with document if top level
  472. next;
  473. } elsif ($data =~ /^(%{1,2})(Begin)(_xml_packet|Photoshop|ICCProfile|Document|Binary)/i) {
  474. # the beginning of a data block
  475. my %modeLookup = (
  476. _xml_packet => 'XMP',
  477. photoshop => 'Photoshop',
  478. iccprofile => 'ICC_Profile',
  479. document => 'Document',
  480. binary => undef, # (we will try to skip this)
  481. );
  482. $mode = $modeLookup{lc $3};
  483. unless ($mode) {
  484. if (not @lines and $data =~ /^%{1,2}BeginBinary:\s*(\d+)/i) {
  485. $raf->Seek($1, 1) or last; # skip binary data
  486. }
  487. next;
  488. }
  489. $buff = '';
  490. $beginToken = $1 . $2 . $3;
  491. $endToken = $1 . ($2 eq 'begin' ? 'end' : 'End') . $3;
  492. if ($mode eq 'Document') {
  493. # this is either the 1st sub-document or Nth document
  494. if ($docNum) {
  495. # increase nesting level
  496. $docNum .= '-' . (++$subDocNum);
  497. } else {
  498. # this is the Nth document
  499. $docNum = $$et{DOC_COUNT} + 1;
  500. }
  501. $subDocNum = 0; # new level, so reset subDocNum
  502. next unless $embedded; # skip over this document
  503. # set document number for family 4-7 group names
  504. $$et{DOC_NUM} = $docNum;
  505. $$et{LIST_TAGS} = { }; # don't build lists across different documents
  506. $$et{PROCESSED} = { }; # re-initialize processed directory lookup too
  507. $endDoc = $endToken; # parse to EndDocument token
  508. # reset mode to allow parsing into sub-directories
  509. undef $endToken;
  510. undef $mode;
  511. # save document name if available
  512. if ($data =~ /^$beginToken:\s+([^\n\r]+)/i) {
  513. my $docName = $1;
  514. # remove brackets if necessary
  515. $docName = $1 if $docName =~ /^\((.*)\)$/;
  516. $et->HandleTag($tagTablePtr, 'EmbeddedFileName', $docName);
  517. }
  518. }
  519. next;
  520. } elsif ($data =~ /^<\?xpacket begin=.{7,13}W5M0MpCehiHzreSzNTczkc9d/) {
  521. # pick up any stray XMP data
  522. $mode = 'XMP';
  523. $buff = $data;
  524. undef $endToken; # no end token (just look for xpacket end)
  525. # XMP could be contained in a single line (if newlines are different)
  526. next unless $data =~ m{<\?xpacket end=.(w|r).\?>($/|$)};
  527. } elsif ($data =~ /^%%?(\w+): ?(.*)/s and $$tagTablePtr{$1}) {
  528. my ($tag, $val) = ($1, $2);
  529. # only allow 'ImageData' to have single leading '%'
  530. next unless $data =~ /^%%/ or $1 eq 'ImageData';
  531. # decode comment string (reading continuation lines if necessary)
  532. $val = DecodeComment($val, $raf, \@lines);
  533. $et->HandleTag($tagTablePtr, $tag, $val);
  534. next;
  535. } elsif ($embedded and $data =~ /^%AI12_CompressedData/) {
  536. # the rest of the file is compressed
  537. unless (eval { require Compress::Zlib }) {
  538. $et->Warn('Install Compress::Zlib to extract compressed embedded data');
  539. last;
  540. }
  541. # seek back to find the start of the compressed data in the file
  542. my $tlen = length($data) + @lines;
  543. $tlen += length $_ foreach @lines;
  544. my $backTo = $raf->Tell() - $tlen - 64;
  545. $backTo = 0 if $backTo < 0;
  546. last unless $raf->Seek($backTo, 0) and $raf->Read($data, 2048);
  547. last unless $data =~ s/.*?%AI12_CompressedData//;
  548. my $inflate = Compress::Zlib::inflateInit();
  549. $inflate or $et->Warn('Error initializing inflate'), last;
  550. # generate a PS-like file in memory from the compressed data
  551. my $verbose = $et->Options('Verbose');
  552. if ($verbose > 1) {
  553. $et->VerboseDir('AI12_CompressedData (first 4kB)');
  554. $et->VerboseDump(\$data);
  555. }
  556. # remove header if it exists (Windows AI files only)
  557. $data =~ s/^.{0,256}EndData[\x0d\x0a]+//s;
  558. my $val;
  559. for (;;) {
  560. my ($v2, $stat) = $inflate->inflate($data);
  561. $stat == Compress::Zlib::Z_STREAM_END() and $val .= $v2, last;
  562. $stat != Compress::Zlib::Z_OK() and undef($val), last;
  563. if (defined $val) {
  564. $val .= $v2;
  565. } elsif ($v2 =~ /^%!PS/) {
  566. $val = $v2;
  567. } else {
  568. # add postscript header (for file recognition) if it doesn't exist
  569. $val = "%!PS-Adobe-3.0$/" . $v2;
  570. }
  571. $raf->Read($data, 65536) or last;
  572. }
  573. defined $val or $et->Warn('Error inflating AI compressed data'), last;
  574. if ($verbose > 1) {
  575. $et->VerboseDir('Uncompressed AI12 Data');
  576. $et->VerboseDump(\$val);
  577. }
  578. # extract information from embedded images in the uncompressed data
  579. $val = # add PS header in case it needs one
  580. ProcessPS($et, { DataPt => \$val });
  581. last;
  582. } elsif ($fontTable) {
  583. if (defined $comment) {
  584. # extract initial comments from PostScript Font files
  585. if ($data =~ /^%\s+(.*?)[\x0d\x0a]/) {
  586. $comment .= "\n" if $comment;
  587. $comment .= $1;
  588. next;
  589. } elsif ($data !~ /^%/) {
  590. # stop extracting comments at the first non-comment line
  591. $et->FoundTag('Comment', $comment) if length $comment;
  592. undef $comment;
  593. }
  594. }
  595. if ($data =~ m{^\s*/(\w+)\s*(.*)} and $$fontTable{$1}) {
  596. my ($tag, $val) = ($1, $2);
  597. if ($val =~ /^\((.*)\)/) {
  598. $val = UnescapePostScript($1);
  599. } elsif ($val =~ m{/?(\S+)}) {
  600. $val = $1;
  601. }
  602. $et->HandleTag($fontTable, $tag, $val);
  603. } elsif ($data =~ /^currentdict end/) {
  604. # only extract tags from initial FontInfo dict
  605. undef $fontTable;
  606. }
  607. next;
  608. } else {
  609. next;
  610. }
  611. # extract information from buffered data
  612. my %dirInfo = (
  613. DataPt => \$buff,
  614. DataLen => length $buff,
  615. DirStart => 0,
  616. DirLen => length $buff,
  617. Parent => 'PostScript',
  618. );
  619. my $subTablePtr = GetTagTable("Image::ExifTool::${mode}::Main");
  620. unless ($et->ProcessDirectory(\%dirInfo, $subTablePtr)) {
  621. $et->Warn("Error processing $mode information in PostScript file");
  622. }
  623. undef $buff;
  624. undef $mode;
  625. }
  626. $mode = 'Document' if $endDoc and not $mode;
  627. $mode and PSErr($et, "unterminated $mode data");
  628. return 1;
  629. }
  630. #------------------------------------------------------------------------------
  631. # Extract information from EPS file
  632. # Inputs: 0) ExifTool object reference, 1) dirInfo reference
  633. # Returns: 1 if this was a valid PostScript file
  634. sub ProcessEPS($$)
  635. {
  636. return ProcessPS($_[0],$_[1]);
  637. }
  638. 1; # end
  639. __END__
  640. =head1 NAME
  641. Image::ExifTool::PostScript - Read PostScript meta information
  642. =head1 SYNOPSIS
  643. This module is loaded automatically by Image::ExifTool when required.
  644. =head1 DESCRIPTION
  645. This code reads meta information from EPS (Encapsulated PostScript), PS
  646. (PostScript) and AI (Adobe Illustrator) files.
  647. =head1 AUTHOR
  648. Copyright 2003-2016, Phil Harvey (phil at owl.phy.queensu.ca)
  649. This library is free software; you can redistribute it and/or modify it
  650. under the same terms as Perl itself.
  651. =head1 REFERENCES
  652. =over 4
  653. =item L<http://partners.adobe.com/public/developer/en/ps/5002.EPSF_Spec.pdf>
  654. =item L<http://partners.adobe.com/public/developer/en/ps/5001.DSC_Spec.pdf>
  655. =item L<http://partners.adobe.com/public/developer/en/illustrator/sdk/AI7FileFormat.pdf>
  656. =back
  657. =head1 SEE ALSO
  658. L<Image::ExifTool::TagNames/PostScript Tags>,
  659. L<Image::ExifTool(3pm)|Image::ExifTool>
  660. =cut