[Keith Vetter] 2005-09-22: For the same project which led to [WAV Dump], I also 
had to delve into the file format of [BMP] files. It can be run either as a 
wish script or tclsh script. It displays the image header information, the 
palette (if there is one) and the first row of the image (which is actually the 
bottom row since the image is stored inverted). 

----
======
 ##+##########################################################################
 #
 # bmpDump.tsh -- Dumps out metadata about .BMP files
 # by Keith Vetter, September 2005
 #
 #############################################################################

 set S(rows) 1                                   ;# Count of image rows to show

 proc DoBMP {iname} {
    set ::S(ch) [open $iname r]
    fconfigure $::S(ch) -translation binary
    FileHeader $iname                           ;# Read file header
    ImageHeader                                 ;# Read image header
    DumpImageHeader $iname                      ;# Dump image header info
    ReadPixels                                  ;# Dump pixel info
    Show ""
 }
 proc ReadInt {{size 32}} {                      ;# Reads raw integer from file
    array set BSCAN {32 i 16 s 8 c}
    set data [read $::S(ch) [expr {$size / 8}]]
    binary scan $data $BSCAN($size) val
    return $val
 }
 proc ReadRGBX {} {
    set data [read $::S(ch) 4]
    binary scan $data cccc b g r x
    return [format "%02X%02X%02X" [expr {$r & 0xFF}] [expr {$g & 0xFF}] [expr {$b & 0xFF}]]
 }
 proc FileHeader {fname} {
    set data [read $::S(ch) 2]
    if {$data ne "BM"} { ERROR "Bad file header: signature" }
    set len [ReadInt]
    set len2 [file size $fname]
    if {$len != $len2} { ERROR "Bad file header: file length"}
    set len [ReadInt]
    if {$len != 0} { ERROR "Bad file header: reserved fields"}
    set ::S(offBits) [ReadInt]
 }
 proc ImageHeader {} {
    global I
    array unset I

    set size [ReadInt]
    if {$size == 12} { ERROR "Cannot handle OS/2 bmp files" }

    set I(Width) [ReadInt]
    set I(Height) [ReadInt]
    set I(Planes) [ReadInt 16]
    set I(BitCount) [ReadInt 16]
    set I(Compression) [ReadInt]
    set I(SizeImage) [ReadInt]
    set I(xPelsPerMeter) [ReadInt]
    set I(yPelsPerMeter) [ReadInt]
    set I(ClrUsed) [ReadInt]
    set I(ClrImportant) [ReadInt]

    if {$I(Compression)} { ERROR "Cannot handle compressed images"}
    if {$I(BitCount) <= 8} ReadPalette
 }
 proc ReadPalette {} {
    set cnt [expr {int(pow(2,$::I(BitCount)))}]
    for {set i 0} {$i < $cnt} {incr i} {
        set ii [format "%d" $i]
        set ::I(palette,$ii) [ReadRGBX]
    }
 }
 proc DumpImageHeader {iname} {
    array set ZIP {0 none 1 rle8 2 rle4 3 bitfields}

    Show [file tail $iname]
    Show [string repeat "=" [string length [file tail $iname]]]
    Show [format "  %-17s: %d" "Width" $::I(Width)]
    Show [format "  %-17s: %d" "Height" $::I(Height)]
    Show [format "  %-17s: %d" "Planes" $::I(Planes)]
    Show [format "  %-17s: %d" "Bits/pixel" $::I(BitCount)]
    Show [format "  %-17s: %s" "Compression" $ZIP($::I(Compression))]
    Show [format "  %-17s: %d" "Image Size" $::I(SizeImage)]
    Show [format "  %-17s: %dx%d" "Pixels/meter" $::I(xPelsPerMeter) $::I(yPelsPerMeter)]
    Show [format "  %-17s: %d" "Colors Used" $::I(ClrUsed)]
    Show [format "  %-17s: %d %s" "Essential Colors" $::I(ClrImportant) \
              [expr {$::I(ClrImportant) > 0 ? "" : "(all)"}]]
    Show [format "  %-17s: %s" "Palette" [DumpPalette]]
    Show [format "  %-17s: %s" "Image" ""]
 }
 proc DumpPalette {} {
    if {$::I(BitCount) > 8} { return "none"}

    if {$::I(BitCount) == 1} {
        return [format "0: %s  1: %s" $::I(palette,0) $::I(palette,1)]
    }

    set result "\n"
    set cnt [expr {int(pow(2,$::I(BitCount)))}]
    set cols 6
    for {set i 0} {$i < $cnt} {incr i} {
        append result [format "  %3d: %s" $i $::I(palette,$i)]
        if {($i % $cols) == $cols-1} { append result "\n"}
    }
    return $result
 }

 proc ReadPixels {} {
    seek $::S(ch) $::S(offBits)
    set func "ReadPixels$::I(BitCount)"
    if {[info commands $func] eq {}} {
        ERROR "Cannot read pixels for bitCount $::I(BitCount)" 0
        return
    }
    $func
 }
 proc ReadPixels1 {} {
    set bytes [expr {($::I(Width)+7)/8}]
    set bpr [expr {(((($::I(Width)+7)/8)+3)/4)*4}]
    for {set row 0} {$row < $::I(Height)} {incr row} {
        if {$row >= $::S(rows)} break
        set data [read $::S(ch) $bpr]
        binary scan $data c$bytes pixels
        set tmp {}
        foreach pixel $pixels {
            for {set shift 7} {$shift >= 0} {incr shift -1} {
                lappend tmp [expr {($pixel >> $shift) & 0x01}]
            }
        }
        set pixels [lrange $tmp 0 [expr {$::I(Width)-1}]]
        ShowRow $row $pixels
    }
 }
 proc ReadPixels4 {} {
    set bytes [expr {($::I(Width)+1)/2}]
    set bpr [expr {(((($::I(Width)+1)/2)+3)/4)*4}]
    for {set row 0} {$row < $::I(Height)} {incr row} {
        if {$row >= $::S(rows)} break
        set data [read $::S(ch) $bpr]
        binary scan $data c$bytes pixels
        set tmp {}
        foreach pixel $pixels {
            lappend tmp [expr {($pixel >> 4) & 0x0F}]
            lappend tmp [expr {$pixel & 0x0F}]
        }
        set pixels [lrange $tmp 0 [expr {$::I(Width)-1}]]
        ShowRow $row $pixels
    }
 }

 proc ReadPixels8 {} {
    set bpr [expr {(($::I(Width)+3)/4)*4}]
    for {set row 0} {$row < $::I(Height)} {incr row} {
        if {$row >= $::S(rows)} break
        set data [read $::S(ch) $bpr]
        binary scan $data c$::I(Width) pixels
        ShowRow $row $pixels
    }
 }
 proc ShowRow {row pixels} {
    ShowNNL [format "   Row %2d: " [expr {$::I(Height)-$row-1}]]
    set w [expr {$::I(BitCount) == 8 ? 3 : 2}]
    foreach pixel $pixels {
        ShowNNL [format " %${w}d" [expr {$pixel & 0xFF}]]
    }
    Show ""
 }
 proc ReadPixels24 {} {
    set bpr [expr {4 * (($::I(Width) * 3 + 3) / 4)}]
    for {set row 0} {$row < $::I(Height)} {incr row} {
        if {$row >= $::S(rows)} break
        set data [read $::S(ch) $bpr]
        DisplayRow $row $data
    }
 }
 proc DisplayRow {row data} {
    ShowNNL "  Row [expr {$::I(Height)-$row-1}]:"

    binary scan $data c* bgr
    set bgr [lrange $bgr 0 [expr {([llength $bgr] / 3)*3-1}]] ; list
    set last {}
    set cnt 0
    foreach {b g r} $bgr {
        set pixel [list $r $g $b]
        if {$pixel eq $last} {
            if {$cnt == 0} {ShowNNL "*"}
            incr cnt
        } else {
            set rgb [format "%02X%02X%02X" [expr {$r & 0xFF}] [expr {$g & 0xFF}] [expr {$b & 0xFF}]]
            ShowNNL " $rgb"
            set last $pixel
            set cnt 0
        }
    }
    Show ""
 }
 proc Show {line} { ShowNNL "$line\n" }
 proc ShowNNL {line} {
    if {[info exists ::tk_version] && [winfo exists .t]} {
        .t insert end $line
        .t see end
    } else {
        puts -nonewline $line
    }
 }
 proc ERROR {emsg {die 1}} {
    if {[info exists ::tk_version]} {
        tk_messageBox -icon error -message $emsg
    } else {
        puts stderr $emsg
    }
    if {$die} exit
 }
 ################################################################
 ################################################################

 if {[info exists ::tk_version]} {
    wm title . "BMP Dump"
    bind all <Key-F2> [list console show]
    pack [text .t -wrap word] -fill both -expand 1
 }

 if {$argv eq {}} {
    catch {wm withdraw .}
    ERROR "usage: bmpdmp <bmp files>"
 }
 foreach arg $argv {
    regsub -all {\\} $arg {/} arg
    set files [glob -nocomplain $arg]
    if {$files eq {}} { set files $arg }
    foreach iname $files {
        DoBMP $iname
    }
 }
======

<<categories>> File | Image Processing