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