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