D. McC: George Peter Staplin (GPS) wrote it, except I just changed the initial "pound-bang" line so it no longer reads "#!/bin/wish8.3".
#!/usr/bin/env wish
package require Tk
proc bind:copyClass {class newClass} {
foreach binding [bind $class] {
bind $newClass $binding [bind $class $binding]
}
}
proc bind:removeAllBut {class bindList} {
foreach binding $bindList {
array set tmprab "<${binding}> 0"
}
foreach binding [bind $class] {
if {[info exists tmprab($binding)]} {
continue
}
bind $class $binding {}
}
array unset tmprab
}
proc widget:hex:updateYview {win args} {
set pos [lindex $args 0]
$win.hex yview moveto $pos
widget:hex:resizeColumns $win
widget:hex:updateASCII $win
widget:hex:updateOffset $win
puts "scroll set args: $args"
eval $win.scroll set $args
}
proc widget:hex:event:Button-1 {win x y} {
set pos [$win.hex index @$x,$y]
$win.hex mark set insert $pos
$win.hex mark set anchor insert
focus $win.hex
$win.hex tag remove sel 0.0 end
$win.ascii tag remove sel 0.0 end
set cur [$win.hex index insert]
set splitIndex [split $cur .]
set line [lindex $splitIndex 0]
set curChar [lindex $splitIndex 1]
#puts stderr $curChar
if {[expr {$curChar & 1}]} {
set curChar [expr {$curChar - 1}]
}
if {$curChar > 0} {
set curChar [expr {$curChar / 2}]
}
set hexLine [$win.hex index @0,0]
#puts "cur $cur"
set offset [expr {int($line - $hexLine + 1.0)}]
set cur "$offset.$curChar"
set end [$win.ascii index "$cur + 1 chars"]
$win.ascii tag add sel $cur $end
}
proc widget:hex:ascii:event:Button-1 {win x y} {
set pos [$win.ascii index @$x,$y]
$win.ascii mark set insert $pos
$win.ascii mark set anchor insert
focus $win.ascii
$win.hex tag remove sel 0.0 end
$win.ascii tag remove sel 0.0 end
set cur [$win.hex index insert]
}
proc widget:hex:updateASCII {win} {
set start [$win.hex index @0,0]
set end [$win.hex index @0,[winfo height $win.hex]]
set end [expr {double($end + 1.0)}]
#puts "$start $end"
set data [split [$win.hex get $start $end] \n]
$win.ascii delete 1.0 end
foreach line $data {
set lineLength [expr {[string length $line] / 2}]
set line [binary format H* $line]
for {set i 0} {$i < $lineLength} {incr i} {
binary scan $line @${i}a1 ascii
if {[string is alnum $ascii]} {
$win.ascii insert end $ascii
} else {
$win.ascii insert end .
}
}
$win.ascii insert end \n
}
}
proc widget:hex:updateOffset {win} {
set viewFirst [$win.hex index @0,0]
set viewLast [$win.hex index @0,[winfo height $win.hex]]
set viewFirstLine [lindex [split $viewFirst .] 0]
set viewLastLine [lindex [split $viewLast .] 0]
incr viewFirstLine -1
$win.offset delete 1.0 end
for {set i $viewFirstLine} {$i < $viewLastLine} {incr i} {
set offset [expr {$i * 16}]
$win.offset insert end $offset\n
}
$win.offset config -width [string length $offset]
}
proc widget:hex:resizeColumns {win} {
set start [$win.hex index @0,0]
set end [$win.hex index @0,[winfo height $win.hex]]
set viewStartLine [lindex [split $start .] 0]
set viewEndLine [lindex [split $end .] 0]
#puts "viewStartLine $viewStartLine"
#puts "viewEndLine $viewEndLine"
for {set i $viewStartLine} {$i <= $viewEndLine} {incr i} {
set lineend [$win.hex index "$i.0 lineend"]
set charEnd [lindex [split $lineend .] 1]
if {$charEnd < 32} {
$win.hex delete $lineend
} elseif {$charEnd > 32} {
#delete the \n
$win.hex delete "$i.$charEnd"
$win.hex insert "$i.32" \n
}
}
}
proc widget:hex:event:backSpace {win} {
set cur [$win.hex index insert]
if {[regexp {[0-9]+\.0} $cur]} {
return
}
if {[string compare [$win.hex tag nextrange sel 1.0 end] ""]} {
$win.hex delete sel.first sel.last
} elseif {[$win.hex compare insert != 1.0]} {
$win.hex delete insert-1c
$win.hex see insert
}
after idle [list widget:hex:resizeColumns $win]
after idle [list widget:hex:updateASCII $win]
after idle [list widget:hex:updateOffset $win]
}
proc widget:hex:event:delete {win} {
if {[catch {$win.hex delete sel.first sel.last}]} {
$win.hex delete insert
}
after idle [list widget:hex:resizeColumns $win]
after idle [list widget:hex:updateASCII $win]
after idle [list widget:hex:updateOffset $win]
}
proc widget:hex:event:insert {win char} {
if {![regexp {[0-9a-f]} $char]} {
return
}
$win.hex insert insert $char
$win.hex see insert
widget:hex:resizeColumns $win
after idle [list widget:hex:updateASCII $win]
after idle [list widget:hex:updateOffset $win]
}
proc widget:hex:instanceCmd {win cmd args} {
#puts "instanceCmd $win $cmd $args"
if {$cmd == "insert"} {
if {[llength $args] != 1} {
return -code error "insert called with more than one argument: $args"
}
set data [lindex $args 0]
binary scan $data H* hex
set newHex ""
set charCount 0
set hexLen [string length $hex]
for {set i 0} {$i < $hexLen} {incr i} {
incr charCount
append newHex [string index $hex $i]
if {$charCount == 32} {
append newHex \n
set charCount 0
}
}
$win.hex insert end $newHex
widget:hex:updateASCII $win
widget:hex:updateOffset $win
} elseif {$cmd == "clear"} {
if {[llength $args] != 0} {
return -code error "clear was called with arguments and doesn't accept any arguments: $args"
}
$win.offset delete 1.0 end
$win.hex delete 1.0 end
$win.ascii delete 1.0 end
} elseif {$cmd == "get"} {
if {[llength $args] != 0} {
return -code error "get was called with arguments and doesn't accept any arguments: $args"
}
set data [$win.hex get 1.0 end-1c]
set data [string map {"\n" ""} $data]
set data [binary format H* $data]
return $data
} elseif {[string match "conf*" $cmd]} {
if {[expr {[llength $args] & 1}] != 0} {
return -code error "Invalid number of arguments given to $win\
(uneven number): $args"
}
array set cmdArgs $args
foreach flag {foreground background} short {fg bg} {
if {[info exists cmdArgs(-$flag)]} {
$win.offset config -$short $cmdArgs(-$flag)
$win.hex config -$short $cmdArgs(-$flag)
$win.ascii config -$short $cmdArgs(-$flag)
unset cmdArgs(-$flag)
}
if {[info exists cmdArgs(-$short)]} {
$win.offset config -$short $cmdArgs(-$short)
$win.hex config -$short $cmdArgs(-$short)
$win.ascii config -$short $cmdArgs(-$short)
unset cmdArgs(-$short)
}
}
if {[info exists cmdArgs(-insertbackground)]} {
$win.hex config -insertbackground $cmdArgs(-insertbackground)
$win.ascii config -insertbackground $cmdArgs(-insertbackground)
unset cmdArgs(-insertbackground)
}
if {[array size cmdArgs] > 0} {
return -code error "1 or more arguments were not understood: [array get cmdArgs]"
}
} elseif {$cmd == "cget"} {
set flag [lindex $args 0]
switch -- $flag {
-bg -
-background {
return [$win.hex cget -bg]
}
-fg -
-foreground {
return [$win.hex cget -fg]
}
-insertbackground {
return [$win.hex cget -insertbackground]
}
default {
return -code error "unknown flag given to cget: $flag"
}
}
}
}
proc widget:hex {win args} {
if {[expr {[llength $args] & 1}] != 0} {
return -code error "Invalid number of arguments given to widget:hex\
(uneven number after window): $args"
}
array set cmdArgs $args
text .__temp
set bg [.__temp cget -bg]
set fg [.__temp cget -fg]
set insertbackground [.__temp cget -insertbackground]
puts $insertbackground
destroy .__temp
foreach flag {foreground background} short {fg bg} {
if {[info exists cmdArgs(-$flag)]} {
set $short [set cmdArgs(-$flag)]
unset cmdArgs(-$flag)
}
if {[info exists cmdArgs(-$short)]} {
set $short [set cmdArgs(-$short)]
unset cmdArgs(-$short)
}
}
if {[info exists cmdArgs(-insertbackground)]} {
set insertbackground $cmdArgs(-insertbackground)
}
if {[array size cmdArgs] > 0} {
return -code error "1 or more arguments were not understood: [array get cmdArgs]"
}
bind:copyClass Text HexEdit$win
bind:removeAllBut HexEdit$win [list Key-Left Key-Right \
Key-Up Key-Down Key-Next Key-Prior B1-Motion Button-2 B2-Motion]
bind HexEdit$win <Button-1> [list widget:hex:event:Button-1 $win %x %y]
bind HexEdit$win <Delete> [list widget:hex:event:delete $win]
bind HexEdit$win <Key> [list widget:hex:event:insert $win %A]
bind HexEdit$win <BackSpace> [list widget:hex:event:backSpace $win]
bind HexEditASCII$win <Button-1> [list widget:hex:ascii:event:Button-1 $win %x %y]
bind HexEditASCII$win <B1-Motion> [bind Text <B1-Motion>]
frame $win
pack [scrollbar $win.scroll -command [list $win.hex yview]] -side left -fill y
pack [text $win.offset -width 2 -height 6 -wrap none -fg $fg -bg $bg] -side left -fill y
bindtags $win.offset all
pack [text $win.hex -width 33 -height 6 -wrap none \
-yscrollcommand [list widget:hex:updateYview $win] -fg $fg -bg $bg \
-insertbackground $insertbackground] -side left -fill y
pack [text $win.ascii -width 17 -height 6 -wrap none -fg $fg -bg $bg \
-insertbackground $insertbackground] -side left -fill y
bindtags $win.hex [list HexEdit$win all]
bindtags $win.ascii [list HexEditASCII$win all]
bind $win <Configure> {widget:hex:updateYview %W [%W.hex yview]}
#The instance command
rename $win _junk$win
interp alias {} $win {} widget:hex:instanceCmd $win
bind $win <Configure> "
widget:hex:resizeColumns $win
widget:hex:updateASCII $win
widget:hex:updateOffset $win
"
return $win
}
proc file:open
{win inFile} {
$win clear
set fi [open $inFile r]
fconfigure $fi -translation binary -encoding binary
set data [read $fi]
close $fi
$win insert $data
}
proc file:save {win} {
set f [tk_getSaveFile]
if {"" == $f} {
return
}
set data [$win get]
set fo [open $f w]
fconfigure $fo -translation binary -encoding binary
puts -nonewline $fo $data
close $fo
}
proc file:choose {win} {
set f [tk_getOpenFile]
if {"" == $f} {
return
}
file:open $win $f
}
proc main {argc argv} {
#source bind.tcl
#source cscrollbar.tcl
pack [widget:hex .h] -fill both -side top -anchor w -expand 1
.h config -bg black -fg cyan -insertbackground yellow
pack [frame .f] -side bottom -fill x
pack [button .f.b -text Save -command [list file:save .h]] -side left
pack [button .f.load -text Load -command [list file:choose .h]] -side left
}
main $argc $argv