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 GetOptions(dumpall => \$dumpall);
   8
   9 my $file = shift
  10   or die "Usage: $0 filename\n";
  11
  12 open my $fh, "<", $file
  13   or die "$0: cannot open '$file': $!\n";
  14
  15 binmode $fh;
  16
  17 my $head;
  18 read($fh, $head, 8) == 8
  19   or die "Cann't read header: $!\n";
  20
  21 my $offset = 0;
  22 dump_data($offset, $head);
  23 print "  Header\n";
  24 $offset += length $head;
  25 unless ($head eq "\x89PNG\x0d\x0A\cZ\x0A") {
  26   die "Header isn't a PNG header\n";
  27 }
  28
  29 my $colour_type;
  30 while (my ($dlen, $data, $len, $type, $payload, $crc) = read_chunk($fh)) {
  31   dump_data($offset, $data);
  32   $offset += $dlen;
  33   my $calc_crc = crc($type . $payload);
  34   my $src_crc = unpack("N", $crc);
  35
  36   $type =~ s/([^ -\x7f])/sprintf("\\x%02x", ord $1)/ge;
  37   print "  Type: $type\n";
  38   print "  Length: $len\n";
  39   printf "  CRC: %x (calculated: %x)\n", $src_crc, $calc_crc;
  40   if ($type eq 'IHDR') {
  41     my ($w, $h, $d, $ct, $comp, $filter, $inter) =
  42       unpack("NNCCCCC", $payload);
  43     print <<EOS;
  44   Width : $w
  45   Height: $h
  46   Depth: $d
  47   Colour type: $ct
  48   Filter: $filter
  49   Interlace: $inter
  50 EOS
  51     $colour_type = $ct;
  52   }
  53   elsif ($type eq 'sRGB') {
  54     print "  Rendering intent: ", ord($payload), "\n";
  55   }
  56   elsif ($type eq 'PLTE') {
  57     my $index = 0;
  58     while ($index * 3 < $len) {
  59       my @rgb = unpack("CCC", substr($payload, $index * 3, 3));
  60       print "  $index: @rgb\n";
  61       ++$index;
  62     }
  63   }
  64   elsif ($type eq 'tRNS') {
  65     if ($colour_type == 0) {
  66       my $g = unpack("n", $payload);
  67       printf "  Grey: %d (%x)\n", $g, $g;
  68     }
  69     elsif ($colour_type == 2) {
  70       my @rgb = unpack("nnn", $payload);
  71       printf "  RGB: %d, %d, %d (%x, %x, %x)\n", @rgb, @rgb;
  72     }
  73     elsif ($colour_type == 3) {
  74       my $index = 0;
  75       for my $alpha (unpack("C*", $payload)) {
  76         print "  Index: $index: $alpha\n";
  77         ++$index;
  78       }
  79     }
  80     else {
  81       print "  Unexpected tRNS for colour type $colour_type\n";
  82     }
  83   }
  84   elsif ($type eq 'pHYs') {
  85     my ($hres, $vres, $unit) = unpack("NNC", $payload);
  86     my $unitname = $unit == 1 ? "metre" : "unknown";
  87     print <<EOS;
  88   hRes: $hres / $unitname
  89   vRes: $vres / $unitname
  90   Unit: $unit ($unitname)
  91 EOS
  92   }
  93   elsif ($type eq 'tEXt') {
  94     my ($key, $value) = split /\0/, $payload, 2;
  95     print <<EOS;
  96   Keyword: $key
  97   Value: $value
  98 EOS
  99     do_more_text($key, $value);
 100   }
 101   elsif ($type eq 'zTXt') {
 102     my ($key, $rest) = split /\0/, $payload, 2;
 103     my $ctype = ord $rest;
 104     my $ztxt = substr($rest, 1);
 105     my $value = do_inflate($ztxt);
 106     print <<EOS;
 107   Keyword: $key
 108   Value: $value
 109 EOS
 110     do_more_text($key, $value);
 111   }
 112
 113   $type eq "IEND"
 114     and last;
 115 }
 116
 117 sub do_more_text {
 118   my ($key, $text) = @_;
 119
 120   if ($key eq 'Raw profile type xmp'
 121      && $text =~ s/^\s*xmp\s+\d+\s+//) {
 122     print "  XMP: ", pack("H*", join('', split ' ', $text)), "\n";
 123   }
 124 }
 125
 126 sub read_chunk {
 127   my ($fh) = @_;
 128
 129   my $rlen;
 130   read($fh, $rlen, 4)
 131     or die "Cannot read chunk length\n";
 132   my $len = unpack("N", $rlen);
 133   my $type;
 134   read($fh, $type, 4)
 135     or die "Cannot read chunk type\n";
 136   my $payload = "";
 137   if ($rlen) {
 138     read($fh, $payload, $len) == $len
 139       or die "Cannot read payload\n";
 140   }
 141   my $crc;
 142   read($fh, $crc, 4) == 4
 143     or die "Cannot read CRC\n";
 144
 145   return ( $len + 12, $rlen . $type . $payload . $crc, $len, $type, $payload, $crc );
 146 }
 147
 148 sub dump_data {
 149   my ($offset, $data) = @_;
 150
 151   if (length $data > 28) {
 152     if ($dumpall) {
 153       for my $i (0 .. int((15 + length $data) / 16) - 1) {
 154         my $row = substr($data, $i * 16, 16);
 155         (my $clean = $row) =~ tr/ -~/./c;
 156         printf("%08x: %-32s %s\n", $offset, unpack("H*", $row), $clean);
 157       }
 158     }
 159     else {
 160       printf "%08x: %s...\n", $offset, unpack("H*", substr($data, 0, 26));
 161     }
 162   }
 163   else {
 164     printf "%08x: %s\n", $offset, unpack("H*", $data), "\n";
 165   }
 166 }
 167
 168 #unsigned long crc_table[256];
 169 my @crc_table;
 170
 171 #/* Flag: has the table been computed? Initially false. */
 172 #   int crc_table_computed = 0;
 173
 174 #   /* Make the table for a fast CRC. */
 175 #   void make_crc_table(void)
 176 #   {
 177 sub make_crc_table {
 178 #     unsigned long c;
 179 #     int n, k;
 180 #
 181 #     for (n = 0; n < 256; n++) {
 182   for my $n (0 .. 255) {
 183 #       c = (unsigned long) n;
 184     my $c = $n;
 185 #       for (k = 0; k < 8; k++) {
 186     for my $k (0 .. 7) {
 187 #         if (c & 1)
 188 #           c = 0xedb88320L ^ (c >> 1);
 189 #         else
 190 #           c = c >> 1;
 191       if ($c & 1) {
 192         $c = 0xedb88320 ^ ($c >> 1);
 193       }
 194       else {
 195         $c = $c >> 1;
 196       }
 197 #   }
 198     }
 199 #       crc_table[n] = c;
 200     $crc_table[$n] = $c;
 201 #     }
 202   }
 203 #     crc_table_computed = 1;
 204 #   }
 205 }
 206
 207 # /* Update a running CRC with the bytes buf[0..len-1]--the CRC
 208 #    should be initialized to all 1's, and the transmitted value
 209 #    is the 1's complement of the final running CRC (see the
 210 #    crc() routine below). */
 211
 212 # unsigned long update_crc(unsigned long crc, unsigned char *buf,
 213 #                          int len)
 214 #   {
 215 sub update_crc {
 216   my ($crc, $data) = @_;
 217 #     unsigned long c = crc;
 218 #     int n;
 219
 220 #     if (!crc_table_computed)
 221 #       make_crc_table();
 222   @crc_table or make_crc_table();
 223 #     for (n = 0; n < len; n++) {
 224 #       c = crc_table[(c ^ buf[n]) & 0xff] ^ (c >> 8);
 225 #     }
 226   for my $code (unpack("C*", $data)) {
 227     $crc = $crc_table[($crc ^ $code) & 0xFF] ^ ($crc >> 8);
 228   }
 229 #     return c;
 230 #   }
 231   return $crc;
 232 }
 233
 234 #   /* Return the CRC of the bytes buf[0..len-1]. */
 235 #   unsigned long crc(unsigned char *buf, int len)
 236 #   {
 237 #     return update_crc(0xffffffffL, buf, len) ^ 0xffffffffL;
 238 #   }
 239
 240 sub crc {
 241   my $data = shift;
 242
 243   return update_crc(0xFFFFFFFF, $data) ^ 0xFFFFFFFF;
 244 }
 245
 246 sub do_inflate {
 247   my $z = shift;
 248   my $out = '';
 249   inflate(\$z, \$out);
 250
 251   return $out;
 252 }