chiark / gitweb /
actually build summer
[chiark-utils.git] / 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