source: gsdl/trunk/perllib/cpan/Image/ExifTool/WritePNG.pl@ 16842

Last change on this file since 16842 was 16842, checked in by davidb, 16 years ago

ExifTool added to cpan area to support metadata extraction from files such as JPEG. Primarily targetted as Image files (hence the Image folder name decided upon by the ExifTool author) it also can handle video such as flash and audio such as Wav
File size: 11.4 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 intially)
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 to tEXt or zTXt chunk (zTXt 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 (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 return 0 unless $deflate;
77 $buff = $deflate->deflate($$dataPt);
78 return 0 unless defined $buff;
79 $buff .= $deflate->flush();
80 my %rawTypeChunk = ( icm => 'iCCP' );
81 $chunk = $rawTypeChunk{$rawType} or return 0;
82 $prefix = "$rawType\0\0";
83 $dataPt = \$buff;
84 } else {
85 # write as ASCII-hex encoded profile in tEXt or zTXt chunk
86 my $txtHdr = sprintf("\n$profile profile\n%8d\n", length($$dataPt));
87 $buff = $txtHdr . HexEncode($dataPt);
88 $chunk = 'tEXt'; # write as tEXt if deflate not available
89 $prefix = "Raw profile type $rawType\0";
90 $dataPt = \$buff;
91 # write profile as zTXt chunk if possible
92 if ($deflate) {
93 my $buf2 = $deflate->deflate($buff);
94 if (defined $buf2) {
95 $dataPt = \$buf2;
96 $buf2 .= $deflate->flush();
97 $chunk = 'zTXt';
98 $prefix .= "\0"; # compression type byte (0=deflate)
99 }
100 }
101 }
102 my $hdr = pack('Na4', length($prefix) + length($$dataPt), $chunk) . $prefix;
103 my $crc = CalculateCRC(\$hdr, undef, 4);
104 $crc = CalculateCRC($dataPt, $crc);
105 return Write($outfile, $hdr, $$dataPt, pack('N',$crc));
106}
107
108#------------------------------------------------------------------------------
109# Add iCCP to the PNG image if necessary (must come before PLTE and IDAT)
110# Inputs: 0) ExifTool object ref, 1) output file or scalar ref
111# Returns: true on success
112sub Add_iCCP($$)
113{
114 my ($exifTool, $outfile) = @_;
115 if ($exifTool->{ADD_DIRS}->{ICC_Profile}) {
116 # write new ICC data
117 my $tagTablePtr = GetTagTable('Image::ExifTool::ICC_Profile::Main');
118 my %dirInfo = ( Parent => 'PNG', DirName => 'ICC_Profile' );
119 my $buff = $exifTool->WriteDirectory(\%dirInfo, $tagTablePtr);
120 if (defined $buff and length $buff and WriteProfile($outfile, 'icm', \$buff)) {
121 $exifTool->VPrint(0, "Created ICC profile\n");
122 delete $exifTool->{ADD_DIRS}->{ICC_Profile}; # don't add it again
123 }
124 }
125 return 1;
126}
127
128#------------------------------------------------------------------------------
129# Add any outstanding new chunks to the PNG image
130# Inputs: 0) ExifTool object ref, 1) output file or scalar ref
131# Returns: true on success
132sub AddChunks($$)
133{
134 my ($exifTool, $outfile) = @_;
135 # write any outstanding PNG tags
136 my $addTags = $exifTool->{ADD_PNG};
137 delete $exifTool->{ADD_PNG};
138 my ($tag, $dir, $err, $tagTablePtr);
139
140 foreach $tag (sort keys %$addTags) {
141 my $tagInfo = $$addTags{$tag};
142 my $newValueHash = $exifTool->GetNewValueHash($tagInfo);
143 # (always create native PNG information, so don't check IsCreating())
144 next unless Image::ExifTool::IsOverwriting($newValueHash) > 0;
145 my $val = Image::ExifTool::GetNewValues($newValueHash);
146 if (defined $val) {
147 my $data;
148 if ($$tagInfo{Table} eq \%Image::ExifTool::PNG::TextualData) {
149 $data = "tEXt$tag\0$val";
150 } else {
151 $data = "$tag$val";
152 }
153 # write as compressed zTXt if specified
154 if ($exifTool->Options('Compress')) {
155 my $warn;
156 if (eval 'require Compress::Zlib') {
157 my $buff;
158 my $deflate = Compress::Zlib::deflateInit();
159 $buff = $deflate->deflate($val) if $deflate;
160 if (defined $buff) {
161 $buff .= $deflate->flush();
162 # only write as zTXt if it actually saves space
163 if (length($buff) < length($val) - 1) {
164 $data = "zTXt$tag\0\0$buff";
165 } else {
166 $warn = 'uncompressed data is smaller';
167 }
168 } else {
169 $warn = 'deflate error';
170 }
171 } else {
172 $warn = 'Compress::Zlib not available';
173 }
174 $warn and $exifTool->Warn("PNG:$$tagInfo{Name} not compressed ($warn)", 1);
175 }
176 my $hdr = pack('N', length($data) - 4);
177 my $cbuf = pack('N', CalculateCRC(\$data, undef));
178 Write($outfile, $hdr, $data, $cbuf) or $err = 1;
179 $exifTool->VPrint(1, " + PNG:$$tagInfo{Name} = '",$exifTool->Printable($val),"'\n");
180 ++$exifTool->{CHANGED};
181 }
182 }
183 $addTags = { }; # prevent from adding tags again
184 # create any necessary directories
185 foreach $dir (sort keys %{$exifTool->{ADD_DIRS}}) {
186 my $buff;
187 my %dirInfo = (
188 Parent => 'PNG',
189 DirName => $dir,
190 );
191 if ($dir eq 'IFD0') {
192 $exifTool->VPrint(0, "Creating EXIF profile:\n");
193 $exifTool->{TIFF_TYPE} = 'APP1';
194 $tagTablePtr = GetTagTable('Image::ExifTool::Exif::Main');
195 # use specified byte ordering or ordering from maker notes if set
196 my $byteOrder = $exifTool->Options('ByteOrder') ||
197 $exifTool->GetNewValues('ExifByteOrder') || $exifTool->{MAKER_NOTE_BYTE_ORDER} || 'MM';
198 unless (SetByteOrder($byteOrder)) {
199 warn "Invalid byte order '$byteOrder'\n";
200 $byteOrder = $exifTool->{MAKER_NOTE_BYTE_ORDER} || 'MM';
201 SetByteOrder($byteOrder);
202 }
203 $dirInfo{NewDataPos} = 8, # new data will come after TIFF header
204 $buff = $exifTool->WriteDirectory(\%dirInfo, $tagTablePtr);
205 if (defined $buff and length $buff) {
206 my $tiffHdr = $byteOrder . Set16u(42) . Set32u(8);
207 $buff = $Image::ExifTool::exifAPP1hdr . $tiffHdr . $buff;
208 WriteProfile($outfile, 'APP1', \$buff, 'generic') or $err = 1;
209 }
210 } elsif ($dir eq 'XMP') {
211 $exifTool->VPrint(0, "Creating XMP iTXt chunk:\n");
212 $tagTablePtr = GetTagTable('Image::ExifTool::XMP::Main');
213 $dirInfo{ReadOnly} = 1;
214 $buff = $exifTool->WriteDirectory(\%dirInfo, $tagTablePtr);
215 if (defined $buff and length $buff and
216 # the packet is read-only (because of CRC)
217 Image::ExifTool::XMP::ValidateXMP(\$buff, 'r'))
218 {
219 # (previously, XMP was created as a non-standard XMP profile chunk)
220 # $buff = $Image::ExifTool::xmpAPP1hdr . $buff;
221 # WriteProfile($outfile, 'APP1', \$buff, 'generic') or $err = 1;
222 # (but now write XMP iTXt chunk according to XMP specification)
223 $buff = "iTXtXML:com.adobe.xmp\0\0\0\0\0" . $buff;
224 my $hdr = pack('N', length($buff) - 4);
225 my $cbuf = pack('N', CalculateCRC(\$buff, undef));
226 Write($outfile, $hdr, $buff, $cbuf) or $err = 1;
227 }
228 } elsif ($dir eq 'IPTC') {
229 $exifTool->VPrint(0, "Creating IPTC profile:\n");
230 # write new IPTC data
231 $tagTablePtr = GetTagTable('Image::ExifTool::Photoshop::Main');
232 $buff = $exifTool->WriteDirectory(\%dirInfo, $tagTablePtr);
233 if (defined $buff and length $buff) {
234 WriteProfile($outfile, 'iptc', \$buff, 'IPTC') or $err = 1;
235 }
236 } elsif ($dir eq 'ICC_Profile') {
237 $exifTool->VPrint(0, "Creating ICC profile:\n");
238 # write new ICC data (only done if we couldn't create iCCP chunk)
239 $tagTablePtr = GetTagTable('Image::ExifTool::ICC_Profile::Main');
240 $buff = $exifTool->WriteDirectory(\%dirInfo, $tagTablePtr);
241 if (defined $buff and length $buff) {
242 WriteProfile($outfile, 'icm', \$buff, 'ICC') or $err = 1;
243 $exifTool->Warn('Wrote ICC as generic profile (no Compress::Zlib)');
244 }
245 }
246 }
247 $exifTool->{ADD_DIRS} = { }; # prevent from adding dirs again
248 return not $err;
249}
250
251
2521; # end
253
254__END__
255
256=head1 NAME
257
258Image::ExifTool::WritePNG.pl - Write PNG meta information
259
260=head1 SYNOPSIS
261
262These routines are autoloaded by Image::ExifTool::PNG.
263
264=head1 DESCRIPTION
265
266This file contains routines to write PNG metadata.
267
268=head1 NOTES
269
270Compress::Zlib is required to write compressed text.
271
272Existing text tags are always rewritten in their original form (compressed
273zTXt, uncompressed tEXt or internation iTXt), so pre-existing compressed
274information can only be modified if Compress::Zlib is available.
275
276Newly created textual information is written in uncompressed tEXt form by
277default, or as compressed zTXt if the Compress option is used and
278Compress::Zlib is available (but only if the resulting compressed data is
279smaller than the original text, which isn't always the case for short text
280strings).
281
282=head1 AUTHOR
283
284Copyright 2003-2007, Phil Harvey (phil at owl.phy.queensu.ca)
285
286This library is free software; you can redistribute it and/or modify it
287under the same terms as Perl itself.
288
289=head1 SEE ALSO
290
291L<Image::ExifTool::PNG(3pm)|Image::ExifTool::PNG>,
292L<Image::ExifTool(3pm)|Image::ExifTool>
293
294=cut
Note: See TracBrowser for help on using the repository browser.