source: main/trunk/greenstone2/perllib/cpan/Image/ExifTool/WritePNG.pl@ 34921

Last change on this file since 34921 was 34921, checked in by anupama, 3 years ago

Committing the improvements to EmbeddedMetaPlugin's processing of Keywords vs other metadata fields. Keywords were literally stored as arrays of words rather than phrases in PDFs (at least in Diego's sample PDF), whereas other meta fields like Subjects and Creators stored them as arrays of phrases. To get both to work, Kathy updated EXIF to a newer version, to retrieve the actual EXIF values stored in the PDF. And Kathy and Dr Bainbridge came up with a new option that I added called apply_join_before_split_to_metafields that's a regex which can list the metadata fields to apply the join_before_split to and whcih previously always got applied to all metadata fields. Now it's applied to any *Keywords metafields by default, as that's the metafield we have experience of that behaves differently to the others, as it stores by word instead of phrases. Tested on Diego's sample PDF. Diego has double-checked it to works on his sample PDF too, setting the split char to ; and turning on the join_before_split and leaving apply_join_before_split_to_metafields at its default of .*Keywords. File changes are strings.properties for the tooltip, the plugin introducing the option and working with it and Kathy's EXIF updates affecting cpan/File and cpan/Image.

File size: 15.1 KB
Line 
1#------------------------------------------------------------------------------
2# File: WritePNG.pl
3#
4# Description: Write PNG meta information
5#
6# Revisions: 09/16/2005 - P. Harvey Created
7#
8# References: 1) http://www.libpng.org/pub/png/spec/1.2/
9#------------------------------------------------------------------------------
10package Image::ExifTool::PNG;
11
12use strict;
13
14#------------------------------------------------------------------------------
15# Calculate CRC or update running CRC (ref 1)
16# Inputs: 0) data reference, 1) running crc to update (undef initially)
17# 2) data position (undef for 0), 3) data length (undef for all data),
18# Returns: updated CRC
19my @crcTable;
20sub CalculateCRC($;$$$)
21{
22 my ($dataPt, $crc, $pos, $len) = @_;
23 $crc = 0 unless defined $crc;
24 $pos = 0 unless defined $pos;
25 $len = length($$dataPt) - $pos unless defined $len;
26 $crc ^= 0xffffffff; # undo 1's complement
27 # build lookup table unless done already
28 unless (@crcTable) {
29 my ($c, $n, $k);
30 for ($n=0; $n<256; ++$n) {
31 for ($k=0, $c=$n; $k<8; ++$k) {
32 $c = ($c & 1) ? 0xedb88320 ^ ($c >> 1) : $c >> 1;
33 }
34 $crcTable[$n] = $c;
35 }
36 }
37 # calculate the CRC
38 foreach (unpack("x${pos}C$len", $$dataPt)) {
39 $crc = $crcTable[($crc^$_) & 0xff] ^ ($crc >> 8);
40 }
41 return $crc ^ 0xffffffff; # return 1's complement
42}
43
44#------------------------------------------------------------------------------
45# Encode data in ASCII Hex
46# Inputs: 0) input data reference
47# Returns: Hex-encoded data (max 72 chars per line)
48sub HexEncode($)
49{
50 my $dataPt = shift;
51 my $len = length($$dataPt);
52 my $hex = '';
53 my $pos;
54 for ($pos = 0; $pos < $len; $pos += 36) {
55 my $n = $len - $pos;
56 $n > 36 and $n = 36;
57 $hex .= unpack('H*',substr($$dataPt,$pos,$n)) . "\n";
58 }
59 return $hex;
60}
61
62#------------------------------------------------------------------------------
63# Write profile chunk (possibly compressed if Zlib is available)
64# Inputs: 0) outfile, 1) Raw profile type, 2) data ref
65# 3) profile header type (undef if not a text profile)
66# Returns: 1 on success
67sub WriteProfile($$$;$)
68{
69 my ($outfile, $rawType, $dataPt, $profile) = @_;
70 my ($buff, $prefix, $chunk, $deflate);
71 if ($rawType ne $stdCase{exif} and eval { require Compress::Zlib }) {
72 $deflate = Compress::Zlib::deflateInit();
73 }
74 if (not defined $profile) {
75 # write ICC profile as compressed iCCP chunk if possible
76 if ($rawType eq 'icm') {
77 return 0 unless $deflate;
78 $chunk = 'iCCP';
79 $prefix = "$rawType\0\0";
80 } else {
81 $chunk = $rawType;
82 if ($rawType eq $stdCase{zxif}) {
83 $prefix = "\0" . pack('N', length $$dataPt); # (proposed compressed EXIF)
84 } else {
85 $prefix = ''; # standard EXIF
86 }
87 }
88 if ($deflate) {
89 $buff = $deflate->deflate($$dataPt);
90 return 0 unless defined $buff;
91 $buff .= $deflate->flush();
92 $dataPt = \$buff;
93 }
94 } else {
95 # write as ASCII-hex encoded profile in tEXt or zTXt chunk
96 my $txtHdr = sprintf("\n$profile profile\n%8d\n", length($$dataPt));
97 $buff = $txtHdr . HexEncode($dataPt);
98 $chunk = 'tEXt'; # write as tEXt if deflate not available
99 $prefix = "Raw profile type $rawType\0";
100 $dataPt = \$buff;
101 # write profile as zTXt chunk if possible
102 if ($deflate) {
103 my $buf2 = $deflate->deflate($buff);
104 if (defined $buf2) {
105 $dataPt = \$buf2;
106 $buf2 .= $deflate->flush();
107 $chunk = 'zTXt';
108 $prefix .= "\0"; # compression type byte (0=deflate)
109 }
110 }
111 }
112 my $hdr = pack('Na4', length($prefix) + length($$dataPt), $chunk) . $prefix;
113 my $crc = CalculateCRC(\$hdr, undef, 4);
114 $crc = CalculateCRC($dataPt, $crc);
115 return Write($outfile, $hdr, $$dataPt, pack('N',$crc));
116}
117
118#------------------------------------------------------------------------------
119# Add iCCP chunk to the PNG image if necessary (must come before PLTE and IDAT)
120# Inputs: 0) ExifTool object ref, 1) output file or scalar ref
121# Returns: true on success
122sub Add_iCCP($$)
123{
124 my ($et, $outfile) = @_;
125 if ($$et{ADD_DIRS}{ICC_Profile}) {
126 # write new ICC data
127 my $tagTablePtr = Image::ExifTool::GetTagTable('Image::ExifTool::ICC_Profile::Main');
128 my %dirInfo = ( Parent => 'PNG', DirName => 'ICC_Profile' );
129 my $buff = $et->WriteDirectory(\%dirInfo, $tagTablePtr);
130 if (defined $buff and length $buff and WriteProfile($outfile, 'icm', \$buff)) {
131 $et->VPrint(0, "Created ICC profile\n");
132 delete $$et{ADD_DIRS}{ICC_Profile}; # don't add it again
133 }
134 }
135 return 1;
136}
137
138#------------------------------------------------------------------------------
139# This routine is called after we edit an existing directory
140# Inputs: 0) ExifTool ref, 1) dir name, 2) output data ref
141# 3) flag set if location is non-standard (to update, but not create from scratch)
142# - on return, $$outBuff is set to '' if the directory is to be deleted
143sub DoneDir($$$;$)
144{
145 my ($et, $dir, $outBuff, $nonStandard) = @_;
146 my $saveDir = $dir;
147 $dir = 'EXIF' if $dir eq 'IFD0';
148 # don't add this directory again unless this is in a non-standard location
149 if (not $nonStandard) {
150 delete $$et{ADD_DIRS}{$dir};
151 delete $$et{ADD_DIRS}{IFD0} if $dir eq 'EXIF';
152 } elsif ($$et{DEL_GROUP}{$dir} or $$et{DEL_GROUP}{$saveDir}) {
153 $et->VPrint(0," Deleting non-standard $dir\n");
154 $$outBuff = '';
155 }
156}
157
158#------------------------------------------------------------------------------
159# Generate tEXt, zTXt or iTXt data for writing
160# Inputs: 0) ExifTool ref, 1) tagID, 2) tagInfo ref, 3) value string, 4) language code
161# Returns: chunk data (not including 8-byte chunk header)
162# Notes: Sets ExifTool TextChunkType member to the type of chunk written
163sub BuildTextChunk($$$$$)
164{
165 my ($et, $tag, $tagInfo, $val, $lang) = @_;
166 my ($xtra, $compVal, $iTXt, $comp);
167 if ($$tagInfo{SubDirectory}) {
168 if ($$tagInfo{Name} eq 'XMP') {
169 $iTXt = 2; # write as iTXt but flag to avoid encoding
170 # (never compress XMP)
171 } else {
172 $comp = 2; # compress raw profile if possible
173 }
174 } else {
175 # compress if specified
176 $comp = 1 if $et->Options('Compress');
177 if ($lang) {
178 $iTXt = 1; # write as iTXt if it has a language code
179 $tag =~ s/-$lang$//; # remove language code from tagID
180 } elsif ($$et{OPTIONS}{Charset} ne 'Latin' and $val =~ /[\x80-\xff]/) {
181 $iTXt = 1; # write as iTXt if it contains non-Latin special characters
182 }
183 }
184 if ($comp) {
185 my $warn;
186 if (eval { require Compress::Zlib }) {
187 my $deflate = Compress::Zlib::deflateInit();
188 $compVal = $deflate->deflate($val) if $deflate;
189 if (defined $compVal) {
190 $compVal .= $deflate->flush();
191 # only compress if it actually saves space
192 unless (length($compVal) < length($val)) {
193 undef $compVal;
194 $warn = 'uncompressed data is smaller';
195 }
196 } else {
197 $warn = 'deflate error';
198 }
199 } else {
200 $warn = 'Compress::Zlib not available';
201 }
202 # warn if any user-specified compression fails
203 if ($warn and $comp == 1) {
204 $et->Warn("PNG:$$tagInfo{Name} not compressed ($warn)", 1);
205 }
206 }
207 # decide whether to write as iTXt, zTXt or tEXt
208 if ($iTXt) {
209 $$et{TextChunkType} = 'iTXt';
210 $xtra = (defined $compVal ? "\x01\0" : "\0\0") . ($lang || '') . "\0\0";
211 # iTXt is encoded as UTF-8 (but note that XMP is already UTF-8)
212 $val = $et->Encode($val, 'UTF8') if $iTXt == 1;
213 } elsif (defined $compVal) {
214 $$et{TextChunkType} = 'zTXt';
215 $xtra = "\0";
216 } else {
217 $$et{TextChunkType} = 'tEXt';
218 $xtra = '';
219 }
220 return $tag . "\0" . $xtra . (defined $compVal ? $compVal : $val);
221}
222
223#------------------------------------------------------------------------------
224# Add any outstanding new chunks to the PNG image
225# Inputs: 0) ExifTool object ref, 1) output file or scalar ref
226# 2-N) dirs to add (empty to add all except EXIF 'IFD0', including PNG tags)
227# Returns: true on success
228sub AddChunks($$;@)
229{
230 my ($et, $outfile, @add) = @_;
231 my ($addTags, $tag, $dir, $err, $tagTablePtr, $specified);
232
233 if (@add) {
234 $addTags = { }; # don't add any PNG tags
235 $specified = 1;
236 } else {
237 $addTags = $$et{ADD_PNG}; # add all PNG tags...
238 delete $$et{ADD_PNG}; # ...once
239 # add all directories
240 @add = sort keys %{$$et{ADD_DIRS}};
241 }
242 # write any outstanding PNG tags
243 foreach $tag (sort keys %$addTags) {
244 my $tagInfo = $$addTags{$tag};
245 my $nvHash = $et->GetNewValueHash($tagInfo);
246 # (native PNG information is always preferred, so don't check IsCreating)
247 next unless $et->IsOverwriting($nvHash);
248 my $val = $et->GetNewValue($nvHash);
249 if (defined $val) {
250 next if $$nvHash{EditOnly};
251 my $data;
252 if ($$tagInfo{Table} eq \%Image::ExifTool::PNG::TextualData) {
253 $data = BuildTextChunk($et, $tag, $tagInfo, $val, $$tagInfo{LangCode});
254 $data = $$et{TextChunkType} . $data;
255 delete $$et{TextChunkType};
256 } else {
257 $data = "$tag$val";
258 }
259 my $hdr = pack('N', length($data) - 4);
260 my $cbuf = pack('N', CalculateCRC(\$data, undef));
261 Write($outfile, $hdr, $data, $cbuf) or $err = 1;
262 $et->VerboseValue("+ PNG:$$tagInfo{Name}", $val);
263 ++$$et{CHANGED};
264 }
265 }
266 # create any necessary directories
267 foreach $dir (@add) {
268 next unless $$et{ADD_DIRS}{$dir}; # make sure we want to add it first
269 my $buff;
270 my %dirInfo = (
271 Parent => 'PNG',
272 DirName => $dir,
273 );
274 if ($dir eq 'IFD0') {
275 next unless $specified; # wait until specifically asked to write EXIF 'IFD0'
276 my $chunk = $stdCase{exif};
277 # (zxIf was not adopted)
278 #if ($et->Options('Compress')) {
279 # if (eval { require Compress::Zlib }) {
280 # $chunk = $stdCase{zxif};
281 # } else {
282 # $et->Warn("Creating uncompressed $stdCase{exif} chunk (Compress::Zlib not available)");
283 # }
284 #}
285 $et->VPrint(0, "Creating $chunk chunk:\n");
286 $$et{TIFF_TYPE} = 'APP1';
287 $tagTablePtr = Image::ExifTool::GetTagTable('Image::ExifTool::Exif::Main');
288 $buff = $et->WriteDirectory(\%dirInfo, $tagTablePtr, \&Image::ExifTool::WriteTIFF);
289 if (defined $buff and length $buff) {
290 WriteProfile($outfile, $chunk, \$buff) or $err = 1;
291 }
292 } elsif ($dir eq 'XMP') {
293 $et->VPrint(0, "Creating XMP iTXt chunk:\n");
294 $tagTablePtr = Image::ExifTool::GetTagTable('Image::ExifTool::XMP::Main');
295 $dirInfo{ReadOnly} = 1;
296 $buff = $et->WriteDirectory(\%dirInfo, $tagTablePtr);
297 if (defined $buff and length $buff and
298 # the packet is read-only (because of CRC)
299 Image::ExifTool::XMP::ValidateXMP(\$buff, 'r'))
300 {
301 # (previously, XMP was created as a non-standard XMP profile chunk)
302 # $buff = $Image::ExifTool::xmpAPP1hdr . $buff;
303 # WriteProfile($outfile, 'APP1', \$buff, 'generic') or $err = 1;
304 # (but now write XMP iTXt chunk according to XMP specification)
305 $buff = "iTXtXML:com.adobe.xmp\0\0\0\0\0" . $buff;
306 my $hdr = pack('N', length($buff) - 4);
307 my $cbuf = pack('N', CalculateCRC(\$buff, undef));
308 Write($outfile, $hdr, $buff, $cbuf) or $err = 1;
309 }
310 } elsif ($dir eq 'IPTC') {
311 $et->Warn('Creating non-standard IPTC in PNG', 1);
312 $et->VPrint(0, "Creating IPTC profile:\n");
313 # write new IPTC data (stored in a Photoshop directory)
314 $dirInfo{DirName} = 'Photoshop';
315 $tagTablePtr = Image::ExifTool::GetTagTable('Image::ExifTool::Photoshop::Main');
316 $buff = $et->WriteDirectory(\%dirInfo, $tagTablePtr);
317 if (defined $buff and length $buff) {
318 WriteProfile($outfile, 'iptc', \$buff, 'IPTC') or $err = 1;
319 }
320 } elsif ($dir eq 'ICC_Profile') {
321 $et->VPrint(0, "Creating ICC profile:\n");
322 # write new ICC data (only done if we couldn't create iCCP chunk)
323 $tagTablePtr = Image::ExifTool::GetTagTable('Image::ExifTool::ICC_Profile::Main');
324 $buff = $et->WriteDirectory(\%dirInfo, $tagTablePtr);
325 if (defined $buff and length $buff) {
326 WriteProfile($outfile, 'icm', \$buff, 'ICC') or $err = 1;
327 $et->Warn('Wrote ICC as a raw profile (no Compress::Zlib)');
328 }
329 } elsif ($dir eq 'PNG-pHYs') {
330 $et->VPrint(0, "Creating pHYs chunk (default 2834 pixels per meter):\n");
331 $tagTablePtr = Image::ExifTool::GetTagTable('Image::ExifTool::PNG::PhysicalPixel');
332 my $blank = "\0\0\x0b\x12\0\0\x0b\x12\x01"; # 2834 pixels per meter (72 dpi)
333 $dirInfo{DataPt} = \$blank;
334 $buff = $et->WriteDirectory(\%dirInfo, $tagTablePtr);
335 if (defined $buff and length $buff) {
336 $buff = 'pHYs' . $buff; # CRC includes chunk name
337 my $hdr = pack('N', length($buff) - 4);
338 my $cbuf = pack('N', CalculateCRC(\$buff, undef));
339 Write($outfile, $hdr, $buff, $cbuf) or $err = 1;
340 }
341 } else {
342 next;
343 }
344 delete $$et{ADD_DIRS}{$dir}; # don't add again
345 }
346 return not $err;
347}
348
349
3501; # end
351
352__END__
353
354=head1 NAME
355
356Image::ExifTool::WritePNG.pl - Write PNG meta information
357
358=head1 SYNOPSIS
359
360These routines are autoloaded by Image::ExifTool::PNG.
361
362=head1 DESCRIPTION
363
364This file contains routines to write PNG metadata.
365
366=head1 NOTES
367
368Compress::Zlib is required to write compressed text.
369
370Existing text tags are always rewritten in their original form (compressed
371zTXt, uncompressed tEXt or international iTXt), so pre-existing compressed
372information can only be modified if Compress::Zlib is available.
373
374Newly created textual information is written in uncompressed tEXt form by
375default, or as compressed zTXt if the Compress option is used and
376Compress::Zlib is available (but only if the resulting compressed data is
377smaller than the original text, which isn't always the case for short text
378strings).
379
380=head1 AUTHOR
381
382Copyright 2003-2021, Phil Harvey (philharvey66 at gmail.com)
383
384This library is free software; you can redistribute it and/or modify it
385under the same terms as Perl itself.
386
387=head1 SEE ALSO
388
389L<Image::ExifTool::PNG(3pm)|Image::ExifTool::PNG>,
390L<Image::ExifTool(3pm)|Image::ExifTool>
391
392=cut
Note: See TracBrowser for help on using the repository browser.