Updated 2012-08-28 00:51:51 by LkpPo

The code below is not mine, but it's a little hexadecimal editor. I don't remember who wrote it!!! I get the surprise to find my name here, I've not created this page, but if it exists...

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