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