prevent an unsigned overflow in FT1 has_chars() implementation
[imager.git] / fileformatdocs / pngdump.pl
1 #!perl
2 use strict;
3 use IO::Uncompress::Inflate qw(inflate);
4 use Getopt::Long;
5
6 my $dumpall = 0;
7 my $image = 0;
8 GetOptions(dumpall => \$dumpall,
9            image => \$image);
10
11 my $file = shift
12   or die "Usage: $0 filename\n";
13
14 open my $fh, "<", $file
15   or die "$0: cannot open '$file': $!\n";
16
17 binmode $fh;
18
19 my $head;
20 read($fh, $head, 8) == 8
21   or die "Cann't read header: $!\n";
22
23 my $offset = 0;
24 dump_data($offset, $head);
25 print "  Header\n";
26 $offset += length $head;
27 unless ($head eq "\x89PNG\x0d\x0A\cZ\x0A") {
28   die "Header isn't a PNG header\n";
29 }
30
31 my $colour_type;
32 my $bits;
33 my $sline_len;
34 my $sline_left = 0;
35 my $row = 0;
36 while (my ($dlen, $data, $len, $type, $payload, $crc) = read_chunk($fh)) {
37   dump_data($offset, $data);
38   $offset += $dlen;
39   my $calc_crc = crc($type . $payload);
40   my $src_crc = unpack("N", $crc);
41
42   $type =~ s/([^ -\x7f])/sprintf("\\x%02x", ord $1)/ge;
43   print "  Type: $type\n";
44   print "  Length: $len\n";
45   printf "  CRC: %x (calculated: %x)\n", $src_crc, $calc_crc;
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
55   Interlace: $inter
56 EOS
57     $colour_type = $ct;
58     $bits = $d;
59     my $channels = $ct == 2 ? 3 : $ct == 4 ? 2 : $ct == 6 ? 4 : 1;
60     my $bitspp = $channels * $d;
61     $sline_len = int((($w * $bitspp) + 7) / 8);
62     ++$sline_len; # filter byte
63     print "  Line length: $sline_len\n";
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)
103 EOS
104   }
105   elsif ($type eq 'tEXt') {
106     my ($key, $value) = split /\0/, $payload, 2;
107     print <<EOS;
108   Keyword: $key
109   Value: $value
110 EOS
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
121 EOS
122     do_more_text($key, $value);
123   }
124   elsif ($type eq 'tIME') {
125     my @when = unpack("nCCCCC", $payload);
126     printf "  Date: %d-%02d-%02d %02d:%02d:%02d\n", @when;
127   }
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   }
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   }
166
167   $type eq "IEND"
168     and last;
169 }
170
171 sub 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
180 sub 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
202 sub dump_data {
203   my ($offset, $data) = @_;
204
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     }
216   }
217   else {
218     printf "%08x: %s\n", $offset, unpack("H*", $data), "\n";
219   }
220 }
221
222 #unsigned long crc_table[256];
223 my @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 #   {
231 sub 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 #   {
269 sub 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
294 sub crc {
295   my $data = shift;
296
297   return update_crc(0xFFFFFFFF, $data) ^ 0xFFFFFFFF;
298 }
299
300 sub do_inflate {
301   my $z = shift;
302   my $out = '';
303   inflate(\$z, \$out);
304
305   return $out;
306 }
307
308 =head HEAD
309
310 pngdump.pl - dump the structure of a PNG image file.
311
312 =head1 SYNOPSIS
313
314   perl [-dumpall] [-image] pngdump.pl filename
315
316 =head1 DESCRIPTION
317
318 Dumps the structure of a PNG image file, listing chunk types, length,
319 CRC and optionally the entire content of each chunk.
320
321 Options:
322
323 =over
324
325 =item *
326
327 C<-dumpall> - dump the entire contents of each chunk rather than just
328 the leading bytes.
329
330 =item *
331
332 C<-image> - decompress the image data (IDAT chunk) and break the
333 result into rows, listing the filter and filtered (raw) data for each
334 row.
335
336 =back
337
338 Several chunk types are extracted and displayed in a more readable
339 form.
340
341 =cut