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