set verbose 2

proc PngDump {fname} {
    global IHDR
    
    unset -nocomplain ::IDAT
    unset -nocomplain ::PALETTE
    unset -nocomplain ::APALETTE
    
    ShowLine 1 $fname
    ShowLine 1 "[string repeat = [string length $fname]]"
    set fh [open $fname r]
    try {
        fconfigure $fh -encoding binary -translation binary -eofchar {}
        if {[read $fh 8] != "\x89PNG\r\n\x1a\n"} {
            ERROR "$fname is not a png file"
            return
        }
        while {[set r [read $fh 8]] != ""} {
            binary scan $r Ia4 len type
            set data [read $fh $len]
            set crc [read $fh 4]

            set handler "Do[string toupper $type]"
            if {[info procs $handler] ne ""} {
                $handler $data
            } else {
                ERROR "unknown chunk type: $type"
            }
        }
    } finally {
        close $fh
    }
    ShowLine 1 ""
    if {$::verbose == 0} {
        set msg "$fname:  $IHDR(width)x$IHDR(height) "
        append msg "$IHDR(color)/$IHDR(depth)/$IHDR(interlace)"
        ShowLine 0 $msg
    }
    
}
proc ERROR {msg} {
    puts stderr $msg
}
proc ShowLine {lvl msg} {
    if {$lvl > $::verbose} return
    puts $msg
}
proc ShowData {lvl args} {
    if {$lvl > $::verbose} return
    foreach {key value} $args {
        set msg [format "  %-12s %s" "${key}:" $value]
        puts $msg
    }
}
proc Adorn {value labels} {
    set lbl "-"
    if {$value < [llength $labels]} {
        set lbl [lindex $labels $value]
    }
    if {$lbl eq "-"} { return $value }
    return "$value -- $lbl"
}
################################################################
proc DoIHDR {data} {
    global IHDR
    set ctypes_ {grayscale - RGB indexed "grayscale with alpha" - RGBA}
    binary scan $data IIccccc IHDR(width) IHDR(height) IHDR(depth) IHDR(color) \
        IHDR(compression) IHDR(filter) IHDR(interlace)

    if {$IHDR(color) == 0 || $IHDR(color) == 3} {
        set bits [expr {$IHDR(width) * $IHDR(depth)}]
        set IHDR(bytes,row) [expr {int(ceil($bits / 8.0))}]
        set IHDR(bpp) [expr {$IHDR(depth) > 8 ? 2 : 1}]
    } elseif {$IHDR(color) == 2} {
        set IHDR(bytes,row) [expr {$IHDR(width) * 3 * $IHDR(depth) / 8}]
        set IHDR(bpp) [expr {3 * $IHDR(depth) / 8}]
    } elseif {$IHDR(color) == 4} {
        set IHDR(bytes,row) [expr {$IHDR(width) * $IHDR(depth) / 8}]
        set IHDR(bpp) [expr {2 * $IHDR(depth) / 8}]
    } elseif {$IHDR(color) == 6} {
        set IHDR(bytes,row) [expr {$IHDR(width) * 4 * $IHDR(depth) / 8}]
        set IHDR(bpp) [expr {4 * $IHDR(depth) / 8}]
    }

    ShowLine 1 "IHDR : Image header"
    ShowData 1 size        "$IHDR(width)x$IHDR(height)"
    ShowData 1 "color type"  [Adorn $IHDR(color) $ctypes_]
    ShowData 1 depth       $IHDR(depth)
    ShowData 2 compression $IHDR(compression)
    ShowData 2 filter      $IHDR(filter)
    ShowData 1 interlace   [Adorn $IHDR(interlace) {none Adam7}]
}

proc DoPLTE {data} {
    global PALETTE
    
    ShowLine 1 "PLTE : Palette"
    set cnt [expr {-1 + [string length $data] / 3}]
    for {set i 0} {$i <= $cnt} {incr i} {
        set rgb [string range $data [expr {$i * 3}] [expr {$i * 3 + 2}]]
        binary scan $rgb cucucu r g b
        set PALETTE($i) [expr {($r << 16) | ($g << 8) | $b}]
        if {$i < 5} {
            ShowData 2 "palette\[$i]" [format "#%06X" $PALETTE($i)]
        }
    }
    if {$cnt >= 5} {
        ShowLine 2 "  ..."
        ShowData 2 "palette\[$cnt]" [format "#%06X" $PALETTE($cnt)]
    }
}

proc DoIDAT {data} {
    global IDAT

    # Just accumulate info for summary info in IEND
    incr IDAT(cnt)
    incr IDAT(len) [string length $data]
    append IDAT(data) $data
}

proc DoIEND {data} {
    # Combine multiple IDAT and display info here
    binary scan $::IDAT(data) cucu CMF FLG
    
    set CM [expr {$CMF & 0xF}]
    set methods_ {- - - - - - - - deflate}
    set CINFO [expr {$CMF >> 4}]
    set window [expr {2**($CINFO+8)}]

    set FCHECK [expr {$FLG & 0x1F}]
    set FDICT [expr {($FLG & 0x20) >> 5}]
    set FLEVEL [expr {$FLG >> 6 }]
    set flevels_ {fastest fast default maximum}
    
    ShowLine 1 "IDAT : Image data"
    ShowData 2 segments  $::IDAT(cnt) size  $::IDAT(len)
    ShowData 2 method [Adorn $CM $methods_]
    ShowData 2 window $window
    ShowData 2 level "[Adorn $FLEVEL $flevels_] compression"

    ShowLine 1 "IEND : Image trailer"
}

proc DoTRNS {data} {
    global IHDR APALETTE

    ShowLine 1 "tRNS : Transparency"
    if {$IHDR(color) == 3} {  ;# Indexed color png
        set cnt [expr {-1 + [string length $data]}]
        for {set i 0} {$i <= $cnt} {incr i} {
            binary scan [string index $data $i] cu alpha
            set APALETTE($i) $alpha
            if {$i > 4} continue
            if {$alpha == 0} {
                set alpha "$alpha -- transparent"
            } elseif {$alpha == 255} {
                set alpha "$alpha -- opaque"
            }
            ShowData 2 "alpha palette\[$i\]" $alpha
        }
        if {$cnt >= 4} {
            ShowLine 2 "  ..."
            set alpha $APALETTE($cnt)
            if {$alpha == 0} {
                set alpha "$alpha -- transparent"
            } elseif {$alpha == 255} {
                set alpha "$alpha -- opaque"
            }
            ShowData 2 "alpha palette\[$cnt\]" $alpha
        }
    } elseif {$IHDR(color) == 0} {  ;# Grayscale png
        binary scan $data S alpha
        ShowData 2 "gray alpha" $alpha
    } elseif {$IHDR(color) == 2} {  ;# Truecolor png
        binary scan $data SSS red green blue
        ShowData 2 "red alpha" $red "green alpha" $green "blue alpha" $blue
    } else {
        ShowData 2 ? ?
    }
}

proc DoGAMA {data} {
    binary scan $data I gamma
    set gamma [expr {$gamma / 100000.}]
    ShowLine 1 "gAMA : Image gamma"
    ShowData 2 gamma $gamma
}

proc DoCHRM {data} {
    ShowLine 1 "cHRM : Primary chromaticities"
    set lbls {"white x" "white y" "red x" "red y" "green x" "green y"
        "blue x" "blue y"}
    for {set i 0} {$i < 8} {incr i} {
        set chrm [string range $data [expr {$i*4}] [expr {$i*4 + 3}]]
        binary scan $chrm I val
        ShowData 2 [lindex $lbls $i] $val
    }
}

proc DoSRGB {data} {
    binary scan $data c render
    set intents_ {Perceptual "Relative colorimetric"
        Saturation "Absolute colorimetric"}
    ShowData 2 render [Adorn $render $intents_]
}

proc DoICCP {data} {
    set name [lindex [split $data \x00] 0]
    ShowLine 1 "iCCP : Embedded ICC profile"
    ShowData 2 name $name
}

proc DoTEXT {data} {
    ShowLine 1 "tEXt : Textual data"
    lassign [split $data \x00] key value
    ShowData 2 key $key value $value
}

proc DoZTXT {data} {
    set ::data $data
    ShowLine 1 "zTXt : Compressed textual data"
    lassign [split $data \x00] key
    set keylen [expr {[string length $key] + 1}]
    binary scan [string index $data $keylen] cu method
    set value [string range $data $keylen+1 end]
    set compressed [string range $value 2 end-4]
    set uncompressed [zlib inflate $compressed]
    
    ShowData 2 method [Adorn $method {deflate}] key $key text $uncompressed
}

proc DoITXT {data} {
    ShowLine 1 "iTXt : International textual data"
    lassign [split $data \x00] key
    set keylen [expr {[string length $key] + 1}]
    binary scan [string range $data $keylen $keylen+2] cc compress method
    if {$compress == 1} {
        ShowData 2 $key ...
        ShowData 2 compress $compress method [Adorn $method {deflate}] text ...
    } else {
        set rest [string range $data $keylen+2 end]
        lassign [split $rest \x00] language key2 value
        ShowData 2 key $key language $language key2 $key2 text $value
    }
}

proc DoBKGD {data} {
    ShowLine 1 "bKGD : Background color"
    set len [string length $data]
    if {$len == 1} {
        binary scan $data cu idx
        ShowData 2 "palette idx"  $idx
    } elseif {$len == 2} {
        binary scan $data cucu gray alpha
        ShowData 2 gray $gray alpha $alpha
    } elseif {$len == 6} {
        binary scan $data SSS red green blue
        ShowData 2 red $red green $green blue $blue
    } else {
        ShowData 2 ? ?
    }
}

proc DoPHYS {data} {
    binary scan $data IIc x y units
    ShowLine 1 "pHYs : Physical pixel dimensions"
    ShowData 2 x-axis      $x
    ShowData 2 y-axis      $y
    ShowData 2 units       [Adorn $units {"unknown" "meters"}]
}

proc DoSBIT {data} {
    ShowLine 1 "sBIT : Significant bits"
    set len [string length $data]
    if {$len == 1} {
        binary scan $data c gray
        ShowData 2 gray $gray
    } elseif {$len == 2} {
        binary scan $data cc gray alpha
        ShowData 2 gray $gray alpha $alpha
    } elseif {$len == 3} {
        binary scan $data ccc red green blue
        ShowData 2 red $red green $green blue $blue
    } elseif {$len == 4} {
        binary scan $data cccc red green blue alpha
        ShowData 2 red $red green $green blue $blue alpha $alpha
    } else {
        ShowData 2 ? ?
    }
}

proc DoSPLT {data} {
    ShowLine 1 "sPLT : Suggested palette"
    set name [lindex [split $data \x00] 0]
    ShowData 2 "palette name" $name
}

proc DoSPAL {data} {
    # see ftp://ftp.simplesystems.org/pub/libpng/png-group/documents/history/png-proposed-sPLT-19961107.html
    lassign [split $data \x00] name signature
    ShowLine 1 "spAL : Suggested palette beta sPLT"
    ShowData 2 "palette name" $name signature $signature
}

proc DoHIST {data} {
    set cnt [expr {[string length $data] / 2}]
    set min [expr {min(5,$cnt)}]
    ShowLine 1 "hIST : Palette histogram"
    ShowData 2 entries $cnt
    for {set i 0} {$i < $min} {incr i} {
        binary scan [string range $data [expr {2 * $i}] end] S value
        ShowData 2 "hist\[$i]" $value
    }
    if {$min < $cnt} { ShowLine 2 "  ..." }
}

proc DoTIME {data} {
    binary scan $data Sccccc year month day hour minute second
    ShowLine 1 "tIME : Image last-modification time"
    ShowData 2 time "$year/$month/$day  $hour:$minute:$second"
}
################################################################

if {$argc == 0} {
    ERROR "usage: pngDump ?-v? ?-q? image1.png ?image2.png ...?"
    return
}

foreach fname $argv {
    if {$fname eq "-v"} { incr verbose ; continue }
    if {$fname eq "-q"} { incr verbose -1 ; continue }
    if {$fname eq "-qq"} { incr verbose -2 ; continue }
    PngDump $fname
}

if {! $tcl_interactive} exit
return