scripts/hexterm

   1 #!/usr/bin/tclsh8.4
   2 set comment {
   3 #
   4 Use of the screen:
   5 0         1         2         3         4         5         6         7
   6 xxx| hh hh hh hh  hh hh hh hh  hh hh hh hh  hh hh hh hh_| abcd e_.. .... ...._|
   7 }
   8 # Display:
   9 #       | is a vertical delimiter
  10 #       hh are hex digits of output:
  11 #               00-ff   actual hex data (bold for stuff we entered)
  12 #               0-f     under cursor: one digit entered, need the next
  13 #       abcde_.... are ASCII output:
  14 #               .       things we can't print including SPC and _
  15 #       in both, we may see
  16 #                       space we haven't yet filled
  17 #               _       cursor when in other tab
  18 #       xxx     number of bytes read/written so far
  19 # Keystrokes:
  20 #       TAB     switch between hex and literal mode
  21 #       ^C, ^D  quit
  22 #       ^Z      suspend
  23 # Keystrokes in hex mode only:
  24 #       RET     move to a new line; if already at start of line,
  25 #                set count to 0
  26 #       DEL     clear any entered hex digit
  27 #       SPC     send 00
  28 # nyi:
  29 #       G-Z     record last bytes we transmitted and store in memory
  30 #                if we were halfway through a hex byte, first digit
  31 #                is length of string to record
  32 #       g-z     play back memory
  33
  34 if {[llength $argv] != 1} { error "need serial port arg" }
  35
  36 set port [lindex $argv 0]
  37
  38 set count 0
  39 set lit 0 ;# 1 means literal (ASCII) entry mode
  40
  41 proc p {s} {
  42     puts -nonewline $s
  43 }
  44
  45 proc tput {args} {
  46     global tput
  47     if {[catch { set s $tput($args) }]} {
  48         set s [eval exec tput $args]
  49         set tput($args) $s
  50     }
  51     p $s
  52 }
  53
  54 proc csr_pos {lit bytenum} {
  55     set x [expr {
  56         (!$lit ? (3*$bytenum) : 53+$bytenum)
  57         + ($bytenum>>2) - (2-$lit)*($bytenum==16)
  58         + 5
  59     }]
  60     tput hpa $x
  61 }
  62
  63 proc csr_this {} { global lit x; csr_pos $lit $x }
  64 proc csr_other {} { global lit x; csr_pos [expr {!$lit}] $x }
  65 proc csrs_erase {} { csr_this; p " "; csr_other; p " " }
  66 proc csr_this_show {} {
  67     global h1
  68     csr_this; if {[info exists h1]} { p $h1; p "\b" }
  69 }
  70 proc csrs_show {} {
  71     csr_other; p _
  72     csr_this_show
  73 }
  74
  75 proc newline {} {
  76     global x count
  77     if {[info exists x]} { csrs_erase; p "\r\n" }
  78     set x 0
  79     p [format "%3x|%*s|%*s|" $count 52 "" 21 ""]
  80     csrs_show
  81 }
  82
  83 proc p_ch_spaces {} {
  84     global x lit
  85     if {$x==15} return
  86     if {$lit} { p " " }
  87     if {($x & 3) != 3} return
  88     p " "
  89 }
  90
  91 proc p_rmso {smso} {
  92     if {[string length $smso]} { tput sgr0 }
  93 }
  94
  95 proc ch {d smso} {
  96     global lit x count
  97     if {$x == 16} newline
  98     if {[string length $smso]} { tput $smso }
  99     set h [format %02x [expr {$d & 0xff}]]
 100     set c [format %c [expr {($d > 33 && $d < 127 && $d != 95) ? $d : 46}]]
 101     if {$lit} {
 102         p $c; csr_other; p $h
 103         p_ch_spaces
 104         p_rmso $smso
 105         p _
 106     } else {
 107         p $h; csr_other; p $c
 108         p_ch_spaces
 109         p_rmso $smso
 110         p _
 111     }
 112     incr x
 113     set count [expr {($count+1) & 0xfff}]
 114     csr_this_show
 115 }
 116
 117 proc onreadp {} {
 118     global p
 119     while 1 {
 120         set c [read $p 1]
 121         binary scan $c c* d
 122         if {![llength $d]} {
 123             if {[eof $p]} { error "eof on device" }
 124             return
 125         }
 126         ch $d {}
 127     }
 128 }
 129
 130 proc transmit {d} {
 131     global p
 132     puts -nonewline $p [format %c $d]
 133     ch $d bold
 134 }
 135
 136 proc k_newline {} {
 137     global count x
 138     if {$x} {
 139         newline
 140     } else {
 141         set count 0
 142         p "\r"
 143         p [format %3x $count]
 144         csr_this
 145     }
 146 }
 147
 148 proc k_switch {} {
 149     global lit h1
 150     csrs_erase
 151     catch { unset h1 }
 152     set lit [expr {!$lit}]
 153     csrs_show
 154 }
 155
 156 proc k_stop {} {
 157     restore
 158     exit 0
 159 }
 160
 161 proc k_suspend {} {
 162     restore
 163     exec kill -TSTP [info pid]
 164     setup
 165 }
 166
 167 proc k_noparthex {} {
 168     global h1
 169     csrs_erase
 170     catch { unset h1 }
 171     csrs_show
 172 }
 173
 174 proc k_hexdigit {c} {
 175     global h1
 176     if {![info exists h1]} { set h1 $c; p $c; p "\b"; return }
 177     set d [expr 0x${h1}${c}]
 178     unset h1
 179     transmit $d
 180 }
 181
 182 proc onreadk {} {
 183     global lit
 184     while 1 {
 185         set c [read stdin 1]
 186         binary scan $c c* d
 187         if {![llength $d]} {
 188             if {[eof stdin]} { error "eof on stdin" }
 189             return
 190         }
 191         switch -exact $d {
 192             9 { k_switch; continue }
 193             3 - 4 { k_stop; continue }
 194             26 { k_suspend; continue }
 195         }
 196         if {$lit} { transmit $d; continue }
 197         switch -exact $d {
 198             13 { k_newline; continue }
 199             127 { k_noparthex; continue }
 200             32 { transmit 0; continue }
 201         }
 202         if {$d >= 48 && $d <= 57} { k_hexdigit $c; continue }
 203         set kl [expr {$d | 32}]
 204         if {$d >= 97 && $d <= 102} { k_hexdigit $c; continue }
 205         p "\a"
 206     }
 207 }
 208
 209 proc try {script} {
 210     if {[catch { uplevel 1 $script } emsg]} {
 211         catch { puts stderr "(warning: $emsg)" }
 212     }
 213 }
 214
 215 proc tryv {variable script} {
 216     upvar #0 $variable var
 217     if {![info exists var]} return
 218     uplevel 1 "
 219         global $variable
 220         $script
 221     "
 222     unset var
 223 }
 224
 225 proc restore {} {
 226     tryv x { puts "\r\n" }
 227     try { fconfigure stdin -blocking true }
 228     try { fconfigure stdout -blocking true }
 229     tryv term_stty { exec stty $term_stty }
 230     tryv p { close $p }
 231 }
 232
 233 proc setup {} {
 234     global term_stty port p
 235
 236     set term_stty [exec stty -g]
 237
 238     set p [open $port {RDWR NONBLOCK} 0]
 239
 240     exec stty          min 1 time 0 -istrip -ocrnl -onlcr -onocr -opost \
 241                        -ctlecho -echo -echoe -echok -echonl -iexten -isig \
 242                        -icanon -icrnl
 243     exec stty -F $port min 1 time 0 -istrip -ocrnl -onlcr -onocr -opost \
 244                        -ctlecho -echo -echoe -echok -echonl -iexten -isig \
 245                        -icanon -icrnl \
 246             9600 clocal cread -crtscts -hup -parenb cs8 -cstopb \
 247             -ixoff bs0 cr0 ff0 nl0 -ofill -olcuc
 248
 249     fconfigure $p -blocking false -buffering none -encoding binary \
 250             -translation binary
 251
 252     fconfigure stdin -blocking false -buffering none -translation binary
 253     fconfigure stdout -blocking false -buffering none -translation binary
 254
 255     newline
 256
 257     fileevent stdin readable onreadk
 258     fileevent $p readable onreadp
 259 }
 260
 261 proc bgerror {m} {
 262     try {
 263         restore
 264         global errorInfo errorCode
 265         puts stderr "$m\n$errorCode\n$errorInfo"
 266     }
 267     exit 127
 268 }
 269
 270 if {[catch setup emsg]} {
 271     restore
 272     error $emsg $errorInfo $errorCode
 273 }
 274
 275 vwait quit