libt1 support is deprecated
[imager.git] / fileformatdocs / pngdump.pl
CommitLineData
07979161
TC
1#!perl
2use strict;
2d78f29c
TC
3use IO::Uncompress::Inflate qw(inflate);
4use Getopt::Long;
5
6my $dumpall = 0;
3c5bdd14
TC
7my $image = 0;
8GetOptions(dumpall => \$dumpall,
9 image => \$image);
07979161
TC
10
11my $file = shift
12 or die "Usage: $0 filename\n";
13
14open my $fh, "<", $file
15 or die "$0: cannot open '$file': $!\n";
16
17binmode $fh;
18
19my $head;
20read($fh, $head, 8) == 8
21 or die "Cann't read header: $!\n";
22
23my $offset = 0;
24dump_data($offset, $head);
25print " Header\n";
26$offset += length $head;
27unless ($head eq "\x89PNG\x0d\x0A\cZ\x0A") {
28 die "Header isn't a PNG header\n";
29}
30
31my $colour_type;
6fa6c8ee 32my $bits;
3c5bdd14
TC
33my $sline_len;
34my $sline_left = 0;
35my $row = 0;
07979161
TC
36while (my ($dlen, $data, $len, $type, $payload, $crc) = read_chunk($fh)) {
37 dump_data($offset, $data);
38 $offset += $dlen;
2d78f29c
TC
39 my $calc_crc = crc($type . $payload);
40 my $src_crc = unpack("N", $crc);
07979161
TC
41
42 $type =~ s/([^ -\x7f])/sprintf("\\x%02x", ord $1)/ge;
43 print " Type: $type\n";
44 print " Length: $len\n";
2d78f29c 45 printf " CRC: %x (calculated: %x)\n", $src_crc, $calc_crc;
07979161
TC
46 if ($type eq 'IHDR') {
47 my ($w, $h, $d, $ct, $comp, $filter, $inter) =
48 unpack("NNCCCCC", $payload);
49 print <<EOS;
50 Width : $w
51 Height: $h
52 Depth: $d
53 Colour type: $ct
54 Filter: $filter
2d78f29c 55 Interlace: $inter
07979161
TC
56EOS
57 $colour_type = $ct;
6fa6c8ee 58 $bits = $d;
3df92d25 59 my $channels = $ct == 2 ? 3 : $ct == 4 ? 2 : $ct == 6 ? 4 : 1;
3c5bdd14
TC
60 my $bitspp = $channels * $d;
61 $sline_len = int((($w * $bitspp) + 7) / 8);
62 ++$sline_len; # filter byte
3df92d25 63 print " Line length: $sline_len\n";
07979161
TC
64 }
65 elsif ($type eq 'sRGB') {
66 print " Rendering intent: ", ord($payload), "\n";
67 }
68 elsif ($type eq 'PLTE') {
69 my $index = 0;
70 while ($index * 3 < $len) {
71 my @rgb = unpack("CCC", substr($payload, $index * 3, 3));
72 print " $index: @rgb\n";
73 ++$index;
74 }
75 }
76 elsif ($type eq 'tRNS') {
77 if ($colour_type == 0) {
78 my $g = unpack("n", $payload);
79 printf " Grey: %d (%x)\n", $g, $g;
80 }
81 elsif ($colour_type == 2) {
82 my @rgb = unpack("nnn", $payload);
83 printf " RGB: %d, %d, %d (%x, %x, %x)\n", @rgb, @rgb;
84 }
85 elsif ($colour_type == 3) {
86 my $index = 0;
87 for my $alpha (unpack("C*", $payload)) {
88 print " Index: $index: $alpha\n";
89 ++$index;
90 }
91 }
92 else {
93 print " Unexpected tRNS for colour type $colour_type\n";
94 }
95 }
96 elsif ($type eq 'pHYs') {
97 my ($hres, $vres, $unit) = unpack("NNC", $payload);
98 my $unitname = $unit == 1 ? "metre" : "unknown";
99 print <<EOS;
100 hRes: $hres / $unitname
101 vRes: $vres / $unitname
102 Unit: $unit ($unitname)
103EOS
104 }
2d78f29c
TC
105 elsif ($type eq 'tEXt') {
106 my ($key, $value) = split /\0/, $payload, 2;
107 print <<EOS;
108 Keyword: $key
109 Value: $value
110EOS
111 do_more_text($key, $value);
112 }
113 elsif ($type eq 'zTXt') {
114 my ($key, $rest) = split /\0/, $payload, 2;
115 my $ctype = ord $rest;
116 my $ztxt = substr($rest, 1);
117 my $value = do_inflate($ztxt);
118 print <<EOS;
119 Keyword: $key
120 Value: $value
121EOS
122 do_more_text($key, $value);
123 }
3c5bdd14
TC
124 elsif ($type eq 'tIME') {
125 my @when = unpack("nCCCCC", $payload);
126 printf " Date: %d-%02d-%02d %02d:%02d:%02d\n", @when;
127 }
6fa6c8ee
TC
128 elsif ($type eq 'bKGD') {
129 if ($colour_type == 2 || $colour_type == 6) {
130 my @rgb = unpack("nnn", $payload);
131 printf " Background: rgb$bits(%d,%d,%d)\n", @rgb;
132 }
133 elsif ($colour_type == 0 || $colour_type == 4) {
134 my $g = unpack("n", $payload);
135 printf " Background: grey$bits(%d)\n", $g;
136 }
137 if ($colour_type == 3) {
138 my $index = unpack("C", $payload);
139 printf " Background: index(%d)\n", $index;
140 }
141 }
3c5bdd14
TC
142 elsif ($type eq "IDAT" && $image) {
143 $sline_len
144 or die "IDAT before IHDR!?";
145 my $raw = do_inflate($payload);
146 if ($sline_left) {
147 print " Continuing $row:\n";
148 print " ", unpack("H*", substr($raw, 0, $sline_left, "")), "\n";
149 $sline_left = 0;
150 ++$row;
151 }
152 while (length $raw >= $sline_len) {
153 my $row_data = substr($raw, 0, $sline_len, "");
154 my ($filter, $data) = unpack("CH*", $row_data);
155 print " Row $row, filter $filter\n";
156 print " $data\n";
157 ++$row;
158 }
159 if (length $raw) {
160 $sline_left = $sline_len - length $raw;
161 my ($filter, $data) = unpack("CH*", $raw);
162 print " Row $row, filter $filter (partial)\n";
163 print " $data\n" if length $data;
164 }
165 }
07979161
TC
166
167 $type eq "IEND"
168 and last;
169}
170
2d78f29c
TC
171sub do_more_text {
172 my ($key, $text) = @_;
173
174 if ($key eq 'Raw profile type xmp'
175 && $text =~ s/^\s*xmp\s+\d+\s+//) {
176 print " XMP: ", pack("H*", join('', split ' ', $text)), "\n";
177 }
178}
179
07979161
TC
180sub read_chunk {
181 my ($fh) = @_;
182
183 my $rlen;
184 read($fh, $rlen, 4)
185 or die "Cannot read chunk length\n";
186 my $len = unpack("N", $rlen);
187 my $type;
188 read($fh, $type, 4)
189 or die "Cannot read chunk type\n";
190 my $payload = "";
191 if ($rlen) {
192 read($fh, $payload, $len) == $len
193 or die "Cannot read payload\n";
194 }
195 my $crc;
196 read($fh, $crc, 4) == 4
197 or die "Cannot read CRC\n";
198
199 return ( $len + 12, $rlen . $type . $payload . $crc, $len, $type, $payload, $crc );
200}
201
202sub dump_data {
203 my ($offset, $data) = @_;
204
2d78f29c
TC
205 if (length $data > 28) {
206 if ($dumpall) {
207 for my $i (0 .. int((15 + length $data) / 16) - 1) {
208 my $row = substr($data, $i * 16, 16);
209 (my $clean = $row) =~ tr/ -~/./c;
210 printf("%08x: %-32s %s\n", $offset, unpack("H*", $row), $clean);
211 }
212 }
213 else {
214 printf "%08x: %s...\n", $offset, unpack("H*", substr($data, 0, 26));
215 }
07979161
TC
216 }
217 else {
2d78f29c 218 printf "%08x: %s\n", $offset, unpack("H*", $data), "\n";
07979161
TC
219 }
220}
2d78f29c
TC
221
222#unsigned long crc_table[256];
223my @crc_table;
224
225#/* Flag: has the table been computed? Initially false. */
226# int crc_table_computed = 0;
227
228# /* Make the table for a fast CRC. */
229# void make_crc_table(void)
230# {
231sub make_crc_table {
232# unsigned long c;
233# int n, k;
234#
235# for (n = 0; n < 256; n++) {
236 for my $n (0 .. 255) {
237# c = (unsigned long) n;
238 my $c = $n;
239# for (k = 0; k < 8; k++) {
240 for my $k (0 .. 7) {
241# if (c & 1)
242# c = 0xedb88320L ^ (c >> 1);
243# else
244# c = c >> 1;
245 if ($c & 1) {
246 $c = 0xedb88320 ^ ($c >> 1);
247 }
248 else {
249 $c = $c >> 1;
250 }
251# }
252 }
253# crc_table[n] = c;
254 $crc_table[$n] = $c;
255# }
256 }
257# crc_table_computed = 1;
258# }
259}
260
261# /* Update a running CRC with the bytes buf[0..len-1]--the CRC
262# should be initialized to all 1's, and the transmitted value
263# is the 1's complement of the final running CRC (see the
264# crc() routine below). */
265
266# unsigned long update_crc(unsigned long crc, unsigned char *buf,
267# int len)
268# {
269sub update_crc {
270 my ($crc, $data) = @_;
271# unsigned long c = crc;
272# int n;
273
274# if (!crc_table_computed)
275# make_crc_table();
276 @crc_table or make_crc_table();
277# for (n = 0; n < len; n++) {
278# c = crc_table[(c ^ buf[n]) & 0xff] ^ (c >> 8);
279# }
280 for my $code (unpack("C*", $data)) {
281 $crc = $crc_table[($crc ^ $code) & 0xFF] ^ ($crc >> 8);
282 }
283# return c;
284# }
285 return $crc;
286}
287
288# /* Return the CRC of the bytes buf[0..len-1]. */
289# unsigned long crc(unsigned char *buf, int len)
290# {
291# return update_crc(0xffffffffL, buf, len) ^ 0xffffffffL;
292# }
293
294sub crc {
295 my $data = shift;
296
297 return update_crc(0xFFFFFFFF, $data) ^ 0xFFFFFFFF;
298}
299
300sub do_inflate {
301 my $z = shift;
302 my $out = '';
303 inflate(\$z, \$out);
304
305 return $out;
306}
3c5bdd14
TC
307
308=head HEAD
309
310pngdump.pl - dump the structure of a PNG image file.
311
312=head1 SYNOPSIS
313
ee507265 314 perl pngdump.pl [-dumpall] [-image] filename
3c5bdd14
TC
315
316=head1 DESCRIPTION
317
318Dumps the structure of a PNG image file, listing chunk types, length,
319CRC and optionally the entire content of each chunk.
320
321Options:
322
323=over
324
325=item *
326
327C<-dumpall> - dump the entire contents of each chunk rather than just
328the leading bytes.
329
330=item *
331
332C<-image> - decompress the image data (IDAT chunk) and break the
333result into rows, listing the filter and filtered (raw) data for each
334row.
335
336=back
337
338Several chunk types are extracted and displayed in a more readable
339form.
340
341=cut