chiark / gitweb /
cgi-fcgi-perl: wip, doc comment
[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
37 # Copyright 2005 Ian Jackson <ian@chiark.greenend.org.uk>
38 #
39 # This script and its documentation (if any) are free software; you
40 # can redistribute it and/or modify them under the terms of the GNU
41 # General Public License as published by the Free Software Foundation;
42 # either version 3, or (at your option) any later version.
43
44 # chiark-named-conf and its manpage are distributed in the hope that
45 # it will be useful, but WITHOUT ANY WARRANTY; without even the
46 # implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
47 # PURPOSE.  See the GNU General Public License for more details.
48
49 # You should have received a copy of the GNU General Public License along
50 # with this program; if not, consult the Free Software Foundation's
51 # website at www.fsf.org, or the GNU Project website at www.gnu.org.
52
53
54 if {[llength $argv] != 1} { error "need serial port arg" }
55
56 set port [lindex $argv 0]
57
58 set count 0
59 set lit 0 ;# 1 means literal (ASCII) entry mode
60 set echo 1
61
62 proc p {s} {
63     puts -nonewline $s
64 }
65
66 proc tput {args} {
67     global tput
68     if {[catch { set s $tput($args) }]} {
69         set s [eval exec tput $args]
70         set tput($args) $s
71     }
72     p $s
73 }
74
75 proc csr_pos {lit bytenum} {
76     set x [expr {
77         (!$lit ? (3*$bytenum) : 53+$bytenum)
78         + ($bytenum>>2) - (2-$lit)*($bytenum==16)
79         + 5
80     }]
81     tput hpa $x
82 }
83
84 proc csr_this {} { global lit x; csr_pos $lit $x }
85 proc csr_other {} { global lit x; csr_pos [expr {!$lit}] $x }
86 proc csrs_erase {} { csr_this; p " "; csr_other; p " " }
87 proc csr_this_show {} {
88     global h1
89     csr_this; if {[info exists h1]} { p $h1; p "\b" }
90 }
91 proc csrs_show {} {
92     csr_other; p _
93     csr_this_show
94 }
95
96 proc echop {} {
97     global echo
98     return [expr {$echo ? "|" : "'"}]
99 }
100
101 proc newline {} {
102     global x echo count
103     if {[info exists x]} { csrs_erase; p "\r\n" }
104     set x 0
105     p [format "%3x%s%*s|%*s|" $count [echop] 52 "" 21 ""]
106     csrs_show
107 }
108
109 proc p_ch_spaces {} {
110     global x lit
111     if {$x==15} return
112     if {$lit} { p " " }
113     if {($x & 3) != 3} return
114     p " "
115 }
116
117 proc p_rmso {smso} {
118     if {[string length $smso]} { tput sgr0 }
119 }
120
121 proc ch {d smso} {
122     global lit x count
123     if {$x == 16} newline
124     if {[string length $smso]} { tput $smso }
125     set h [format %02x [expr {$d & 0xff}]]
126     set c [format %c [expr {($d > 33 && $d < 127 && $d != 95) ? $d : 46}]]
127     if {$lit} {
128         p $c; csr_other; p $h
129         p_ch_spaces
130         p_rmso $smso
131         p _
132     } else {
133         p $h; csr_other; p $c
134         p_ch_spaces
135         p_rmso $smso
136         p _
137     }
138     incr x
139     set count [expr {($count+1) & 0xfff}]
140     csr_this_show
141 }
142
143 proc onreadp {} {
144     global p
145     while 1 {
146         set c [read $p 1]
147         binary scan $c c* d
148         if {![llength $d]} {
149             if {[eof $p]} { error "eof on device" }
150             return
151         }
152         ch $d {}
153     }
154 }
155
156 proc transmit {d} {
157     global p echo
158     puts -nonewline $p [format %c $d]
159     if {$echo} { ch $d bold }
160 }
161
162 proc k_echo {} {
163     global echo
164     set echo [expr {!$echo}]
165     tput hpa 3
166     p [echop]
167     csr_this
168 }
169
170 proc k_newline {} {
171     global count x
172     if {$x} {
173         newline
174     } else {
175         set count 0
176         p "\r"
177         p [format %3x $count]
178         csr_this
179     }
180 }
181
182 proc k_switch {} {
183     global lit h1
184     csrs_erase
185     catch { unset h1 }
186     set lit [expr {!$lit}]
187     csrs_show
188 }
189
190 proc k_stop {} {
191     restore
192     exit 0
193 }
194
195 proc k_suspend {} {
196     restore
197     exec kill -TSTP [info pid]
198     setup
199 }
200
201 proc k_noparthex {} {
202     global h1
203     csrs_erase
204     catch { unset h1 }
205     csrs_show
206 }
207
208 proc k_hexdigit {c} {
209     global h1 echo
210     if {![info exists h1]} { set h1 $c; p $c; p "\b"; return }
211     set d [expr 0x${h1}${c}]
212     unset h1
213     transmit $d
214     if {!$echo} { p " \b" }
215 }
216
217 proc onreadk {} {
218     global lit
219     while 1 {
220         set c [read stdin 1]
221         binary scan $c c* d
222         if {![llength $d]} {
223             if {[eof stdin]} { error "eof on stdin" }
224             return
225         }
226         switch -exact $d {
227             9 { k_switch; continue }
228             3 - 4 { k_stop; continue }
229             26 { k_suspend; continue }
230         }
231         if {$lit} { transmit $d; continue }
232         switch -exact $d {
233             13 { k_newline; continue }
234             32 { transmit 0; continue }
235             39 { k_echo; continue }
236             127 { k_noparthex; continue }
237         }
238         if {$d >= 48 && $d <= 57} { k_hexdigit $c; continue }
239         set kl [expr {$d | 32}]
240         if {$d >= 97 && $d <= 102} { k_hexdigit $c; continue }
241         p "\a"
242     }
243 }
244
245 proc try {script} {
246     if {[catch { uplevel 1 $script } emsg]} {
247         catch { puts stderr "(warning: $emsg)" }
248     }
249 }
250
251 proc tryv {variable script} {
252     upvar #0 $variable var
253     if {![info exists var]} return
254     uplevel 1 "
255         global $variable
256         $script
257     "
258     unset var
259 }
260
261 proc restore {} {
262     tryv x { puts "\r\n" }
263     try { fconfigure stdin -blocking true }
264     try { fconfigure stdout -blocking true }
265     tryv term_stty { exec stty $term_stty }
266     tryv p { close $p }
267 }
268
269 proc setup {} {
270     global term_stty port p
271
272     set term_stty [exec stty -g]
273
274     set p [open $port {RDWR NONBLOCK} 0]
275     
276     exec stty          min 1 time 0 -istrip -ocrnl -onlcr -onocr -opost \
277                        -ctlecho -echo -echoe -echok -echonl -iexten -isig \
278                        -icanon -icrnl
279     exec stty -F $port min 1 time 0 -istrip -ocrnl -onlcr -onocr -opost \
280                        -ctlecho -echo -echoe -echok -echonl -iexten -isig \
281                        -icanon -icrnl \
282             9600 clocal cread -crtscts -hup -parenb cs8 -cstopb \
283             -ixoff bs0 cr0 ff0 nl0 -ofill -olcuc
284
285     fconfigure $p -blocking false -buffering none -encoding binary \
286             -translation binary
287
288     fconfigure stdin -blocking false -buffering none -translation binary
289     fconfigure stdout -blocking false -buffering none -translation binary
290
291     newline
292
293     fileevent stdin readable onreadk
294     fileevent $p readable onreadp
295 }
296
297 proc bgerror {m} {
298     try {
299         restore
300         global errorInfo errorCode
301         puts stderr "$m\n$errorCode\n$errorInfo"
302     }
303     exit 127
304 }
305
306 if {[catch setup emsg]} {
307     restore
308     error $emsg $errorInfo $errorCode
309 }
310
311 vwait quit