#!/usr/bin/perl -w

=head1 title

PNGstat.perl - simple PNG file lister.

=head1 author
by John M. Dlugosz, http://www.dlugosz.com/

=head1 docs

Give 1 or more file names on the command line.  This script will
list information on each "chunk" in the file, including the interesting information
as to image resolution.

=head1 revision history

11-March-1999	Initial release.  Reads the whole file, and decodes the values
of immediate interest to me.

=cut

require 5.005;
use strict;


sub validate_signature()
 {
 my $sig;
 read (FILE, $sig, 8);
 $sig eq "\x89PNG\r\n\x1a\n"  and  return 1;
 print "File signature bad.  Not a PNG file.\n";
 return 0;
 }
 
############################

my ($IDAT_total, $IDAT_count);
my %colortypes=
 ( 0=>"grayscale", 2=>"RGB", 3=>"paletted", 4=>"grayscale+Alpha", 6=>"RGB+Alpha");

sub process_chunk ()
 {
 my $input;
 my $lenread= read (FILE, $input, 8);
 return 0  if $lenread!=8;
 my ($length, $type)= unpack ("N A4", $input);
 $lenread= read (FILE, $input, $length+4);
 if ($lenread != $length+4) {
    print "premature end of file error\n";
    return 0;
    }
 # OK, I have the data.  Now what?
 if ($type eq "IDAT") {
    ++$IDAT_count;
    $IDAT_total += $length;
    }
 elsif ($type eq "IHDR") {
    my ($width,$height,$depth,$color,$compression,$filter,$interlace, $CRC)= unpack ("NNCCCCCN", $input);
    print ("Image Header: $width x $height, $depth bits/sample $colortypes{$color}");
    # for the other values, only tell me if they are abnormal or interesting.
    if ($interlace) {
       if ($interlace == 1)  { print ", interlaced" }
       else { print ", unknown interlace type!" }
       }
    if ($filter != 0) { print ", unknown filter type!" }
    print "\n";
    }
 elsif ($type eq "IEND") {
    #no need to say anything.
    }
 elsif ($type eq "gAMA") {
    my $gamma= unpack ("N", $input) / 100000.0 ;
    printf "Gamma: %2.2f (1/%2.2f)\n", $gamma, 1/$gamma;
    }
 elsif ($type eq "sBIT") {
    my @values= unpack ("C$length", $input);
    print "Bit Depth: ", join(",",@values), "\n";
    }
    
 else {
    print "Chunk $type, length $length\n";
    }
 return 1;
 }
 
############################

sub process_file ($)
 {
 $IDAT_total= 0;  $IDAT_count= 0;
 my $fname= shift;
 print "=> processing file $fname\n";
 unless (open FILE, "<$fname") {
    print "Cannot open file \"$fname\"\n";
    return;
    }
 binmode (FILE);
 validate_signature  or return;
 1 while (process_chunk);
 print ("$IDAT_count IDAT chunks totalling $IDAT_total bytes.\n\n");
 }

############################

sub main
 {
 while (my $arg= shift @ARGV) {
    process_file ($arg);
    }
 }

main;