chiark / gitweb /
fix option processing
[chiark-tcl-applet.git] / ttyacm-multiplex
1 #!/usr/bin/tclsh8.4
2 # -*- tcl -*-
3
4 set expected_devs 3
5
6 proc debug {m} { puts "DEBUG $m" }
7
8 proc log {m} { puts "LOG $m" }
9
10 proc experror {m} {
11     error $m {} EXPECTED
12 }
13
14 proc find-devices {} {
15     global errorCode errorInfo devices expected_devs
16     set base /sys/class/tty
17     foreach candidate [glob -nocomplain -directory $base -tails ttyACM*] {
18         debug "candidate $candidate"
19         if {[catch { file link $base/$candidate/device } ltarget]} {
20             debug " readlink failed [lrange $errorCode 0 1]"
21             switch -glob $errorCode {
22                 {POSIX EINVAL *} continue
23                 {POSIX ENOENT *} continue
24                 default { error "$ltarget \[$errorCode] $errorInfo $errorCode" }
25             }
26         }
27         if {![regexp {^(.*)\.(\d+)$} $ltarget dummy dbase interf]} {
28             debug " readlink bad target $ltarget"
29             continue
30         }
31         debug " approved $dbase $interf $candidate"
32         lappend devs($dbase) [list $interf $candidate]
33     }
34     set howmany [array size devs]
35     if {!$howmany} {
36         experror "no appropriate device(s) found"
37     }
38     if {$howmany > 1} {
39         experror "several appropriate device(s) found [array names $devs]"
40     }
41     set devices {}
42     foreach dev [lsort -index 0 -integer $devs([lindex [array names devs] 0])] {
43         lappend devices [lindex $dev 1]
44     }
45     if {[llength $devices] != $expected_devs} {
46         experror "wrong # devices ($devices), expected $expected"
47     }
48 }
49
50 proc create-dev-nodes {} {
51     global devices expected_devs
52     set ourdevs /dev/atmux
53     set ttyat ttyAT
54     for {set i 0} {$i < $expected_devs-1} {incr i} {
55         set new $ttyAT$i
56         file link -symbolic ../$device $ourdevs/.new.$new
57         file rename -force $ourdevs/.new.$new $ourdevs/$new
58         set wanted($new) 1
59     }
60     foreach candidate [glob -nocomplain -directory $ourdevs -tails ttyAT*] {
61         if {![info exists wanted($candidate)]} {
62             file remove $ourdevs/$candidate
63         }
64     }
65 }
66
67 proc reopen-our-device {} {
68     global devices dchan
69     set dchan [open /dev/[lindex $devices 1] r+]
70     fconfigure $dchan -blocking no -buffering line -translation {crlf cr}
71     read $dchan; # flush input
72     puts $dchan ATE0
73     flush $dchan
74     after 250
75     set result [read $dchan]
76     if {![regexp -line {^OK$} $result]} { experror "got [logquote $result]" }
77     fileevent $dchan readable chan-readable $dchan dchan "modem device"
78 }
79
80 proc devices {} {
81     find-devices
82     create-dev-nodes
83     reopen-our-device
84 }
85
86 proc dchan-failure {dummy} {
87     global dchan
88     if {[info exists dchan]} {
89         catch { close $dchan }
90         catch { unset dchan }
91     }
92 }
93
94 proc try-open-our-device {} {
95     global devices
96     if {[catch {
97         reopen-our-device
98     } emsg]} {
99         devfailure $emsg
100         return
101     }
102     sendout-async *TTYATMUX "*TTYATMUXDEVS [join $devices ,]"
103     sendout-async *TTYATMUX "*TTYATMUXOPEN"
104 }
105
106 proc trap-log {what body var} {
107     global errorCode errorInfo
108     upvar 1 $var result
109     set rc [catch {
110         uplevel 1 $body
111     } result]
112     switch -exact $rc {
113         1 {
114             switch -glob $errorCode {
115                 {POSIX *} - EXPECTED { log "$what: $result" }
116                 default {
117                     log "unexpected: $what: $result"
118                     foreach l [split $errorInfo "\n"] { log "  $l" }
119                 }
120             }
121             return 1
122         }
123         0 {
124             return 0
125         }
126         default {
127             return -code $rc -errorinfo $errorInfo \
128                 -errorcode $errorCode $result
129         }
130     }
131 }
132
133 proc chan-readable {chan how what args} {
134     while 1 {
135         if {[trap-log "$what failure" {
136             gets $chan l
137         } r]} {
138             $how-failure $chan
139             return
140         }
141         if {$r<0} {
142             if {![eof $chan]} return
143             log "device eof"
144             $how-failure $chan
145             return
146         }
147         trap-log "error processing $what data" {
148             $how-line $l
149         } dummy
150     }
151 }
152
153 proc async-notif fixme this has wrong arguments
154
155 proc async-notif-or-resp-fixed {asid l} {
156     global current_command_asid
157     if {![string compare $asid $current_command_asid]} {
158         sync-reply $l
159     } else {
160         async-notif $asid $l
161     }
162 }
163
164 proc async-notif-creg {asid l} {
165     set ll [llength [split $l ,]]
166     switch -exact $ll {
167         4 { sync-reply $l }
168         3 { 
169             async-notif {+CREG} 2 2 $l
170             async-notif {+CREG} 1 1 [lindex [split $l ,] 0]
171         }
172         2 { sync-reply $l }
173         1 { 
174             async-notif {+CREG} 1 2 $l
175         }
176         default {
177             bad-data $l "async-notif-creg $ll"
178         }
179     }
180 }
181
182 proc async-control-max0 {c l allows} {
183     async-control-core $c $l $allows {
184         set wanted 0
185     } {
186         set tw 0
187         manyset $ca($c) tw
188         if {$tw} { set wanted 1 }
189     } {
190         set send $wanted
191         foreach allow $allows { lappend $send [lindex $allow 0] }
192         sync-subcommand $c "$cmd=[join $send ,]" async-updated-ok $c
193     }
194 }
195
196 proc async-control-cmer {c l allows} {
197     async-control-core $c $l $allows {
198         set send 0,0,0,0
199     } {
200         set mode 0; set ind 0
201         manyset $ca($c) mode keyp disp ind bfr
202         if {$mode==3 && $ind} { set send 3,0,0,1 }
203     } {
204         sync-subcommand $c "$cmd=$send" async-updated-ok $c
205     }
206 }
207
208 proc async-updated-ok
209
210 proc async-control-core {c l allows ubody_init ubody_perclient ubody_finish} {
211     global clients
212     uplevel 1 cmd cmd
213     if {[regexp {^(AT[^=?])\?$} $l dummy cmd]} {
214         sync-subcommand $c $l async-massage-result-subs $c $cmd
215     } elseif {[regexp {^(AT[^=?])=\?$} $l dummy cmd]} {
216         sync-subcommand $c $l async-massage-result-support $c $cmd $allows
217     } elseif {[regexp {^(AT[^=?])=([0-9,]+)$} $l dummy cmd values]} {
218         set values [split $values ,]
219         if {[llength $values] > [llength $allows]} {
220             bad-command "too many values"
221             return
222         }
223         while {[llength $values] < [llength $allows]} {
224             lappend values 0
225         }
226         foreach val $values allow $allows {
227             if {[lsearch -exact $allow $val]<0} {
228                 bad-command "$val not in allowed $allow ($allows)"
229                 return
230             }
231         }
232         uplevel 1 [list upvar #0 client_async/$cmd ca]
233         upvar #0 client_async/$cmd ca
234         set ca($c) $values
235         uplevel 1 $ubody_init
236         upvar 1 c uc
237         foreach uc [array names clients] {
238             uplevel 1 $ubody_perclient
239         }
240         uplevel 1 $ubody_finish
241     } else {
242         bad-command "unknown async control syntax"
243     }
244 }
245
246 proc set-client-echo {c yn} {
247     global client_echo
248     set client_echo($c) 0
249     client-command-complete $c OK
250 }
251
252 proc simple-command {c l} {
253     sync-subcommand $c $l simple-command-complete
254 }
255
256 proc client-command-complete
257
258 proc process-client-command {c nl} {
259     switch -regexp $l {
260         {^AT\+CREG\b} { async-control-max0 $c $l {{0 1 2}} }
261         {^AT\+CGREG\b} { async-control-max0 $c $l {{0 1 2}} }
262         {^AT\*ERINFO\b} { async-control-max0 $c $l {{0 1}} }
263         {^AT\+CGEREP\b} { async-control-max0 $c $l {{0 1 2} 0} }
264         {^AT\+CMER\b} { async-control-cmer $c $l {{0 3} 0 0 {0 1} 0} }
265         {^ATE0$} { set-client-echo $c 0 }
266         {^ATE1$} { set-client-echo $c 1 }
267         {^AT\+CFUN\b} { simple-command $c $l }
268         default { bad-command "unknown command" }
269     }
270 }
271
272 proc dchan-line {l} {
273     global cclient
274     switch -regexp $l {
275         {\+CREG:}   { async-notif-creg             +CREG     $l }
276         {\+CGREG:}  { async-notif-creg             +CGREG    $l }
277         {\*ERINFO:} { async-notif-or-resp-fixed    *ERINFO   $l }
278         {\+CGEV:}   { async-notif                  +CGEREP   $l }
279         {\+CIEV:}   { async-notif                  +CMER     $l }
280         default     { syync-reply $l }
281     }
282 }
283
284 proc cchan-line {c l} {
285     lappend queue [list $c $l]
286     check-busy
287 }
288
289 proc sync-subcommand {c l args} {
290     global busy dchan
291     if {[info exists busy]} { error "already busy $busy; want $c $l $args" }
292     if {[trap-log "write device" { puts $dchan $l } dummy]} {
293         
294
295 proc sync-reply {l} {
296     global busy
297     if {![info exists busy]} {
298         bad-data $l "unexpected sync reply"
299         return
300     }
301     eval $
302
303 proc check-busy {} {
304     global busy queue
305     while {![info exists busy] && [llength $queue]} {
306         manyset [lindex $queue 0] c l
307         set queue [lrange $queue 1 end]
308         if {[trap-log "process for $c [logquote $l]"] {
309             process-client-command $c $l
310         } dummy]} {
311             client-command-complete $c ERROR
312         }
313     }
314 }
315
316 proc client-command-complete {c l} {
317     if {[trap-log "write to $c" { puts $c $l } dummy]} {
318         client-failure $c
319     }
320 }
321
322 proc cchan-readable {
323
324 proc sendout-async
325 proc logquote
326
327
328 try-open-our-device