+#!/usr/bin/tclsh8.4
+# -*- tcl -*-
+
+proc debug {m} { puts "DEBUG $m" }
+
+proc log {m} { puts "LOG $m" }
+
+proc experror {m} {
+ error $m {} EXPECTED
+}
+
+proc find-devices {} {
+ global errorCode errorInfo devices
+ set base /sys/class/tty
+ foreach candidate [glob -nocomplain -directory $base -tails ttyACM*] {
+ debug "candidate $candidate"
+ if {[catch { file link $base/$candidate/device } ltarget]} {
+ debug " readlink failed [lrange $errorCode 0 1]"
+ switch -glob $errorCode {
+ {POSIX EINVAL *} continue
+ {POSIX ENOENT *} continue
+ default { error "$ltarget \[$errorCode] $errorInfo $errorCode" }
+ }
+ }
+ if {![regexp {^(.*)\.(\d+)$} $ltarget dummy dbase interf]} {
+ debug " readlink bad target $ltarget"
+ continue
+ }
+ debug " approved $dbase $interf $candidate"
+ lappend devs($dbase) [list $interf $candidate]
+ }
+ set howmany [array size devs]
+ if {!$howmany} {
+ experror "no appropriate device(s) found"
+ }
+ if {$howmany > 1} {
+ experror "several appropriate device(s) found [array names $devs]"
+ }
+ set devices {}
+ foreach dev [lsort -index 0 -integer $devs([lindex [array names devs] 0])] {
+ lappend devices [lindex $dev 1]
+ }
+}
+
+proc reopen-our-device {} {
+ global devices dchan
+ find-devices
+ set dchan [open /dev/[lindex $devices 1] r+]
+ fconfigure $dchan -blocking no -buffering line -translation {crlf cr}
+ read $dchan; # flush input
+ puts $dchan ATE0
+ flush $dchan
+ after 250
+ set result [read $dchan]
+ if {![regexp -line {^OK$} $result]} { experror "got [logquote $result]" }
+ fileevent $dchan readable dchan-readable
+}
+
+proc devfailure {emsg} {
+ global errorCode errorInfo dchan
+ switch -glob $errorCode {
+ {POSIX *} - EXPECTED {
+ log "device failure: $emsg"
+ }
+ default {
+ log "unexpected device failure: $emsg"
+ foreach l [split $errorInfo "\n"] {
+ log " $l"
+ }
+ }
+ }
+ if {[info exists dchan]} {
+ catch { close $dchan }
+ catch { unset dchan }
+ }
+}
+
+proc try-open-our-device {} {
+ global devices
+ if {[catch {
+ reopen-our-device
+ } emsg]} {
+ devfailure $emsg
+ return
+ }
+ sendout-async *TTYATMUX "*TTYATMUXDEVS [join $devices ,]"
+ sendout-async *TTYATMUX "*TTYATMUXOPEN"
+}
+
+proc dchan-readable {args} {
+ global dchan
+ while 1 {
+ if {[catch {
+ gets $dchan l
+ } r]} {
+ devfailure $r
+ return
+ }
+ if {$r<0} {
+ if {![eof $dchan]} return
+ set errorCode EXPECTED
+ devfailure "eof"
+ return
+ }
+ dchan-line $l
+ }
+}
+
+proc async-notif-or-resp-varies {async_values asid l} {
+ set ll [llength [split $l ,]]
+ if {$ll == $async_values} {
+ async-notif $asid $l
+ } elseif {$ll == $async_values+1} {
+ sync-reply $l
+ } else {
+ bad-data $l "async-notif-or-resp-varies $ll"
+ }
+}
+
+proc async-notif-or-resp-fixed {asid l} {
+ global current_command_asid
+ if {![string compare $asid $current_command_asid]} {
+ sync-reply $l
+ } else {
+ async-notif $asid $l
+ }
+}
+
+proc async-notif-creg {asid l} {
+ set ll [llength [split $l ,]]
+ switch -exact $ll {
+ 4 { sync-reply $l }
+ 3 {
+ async-notif {+CREG} 2 2 $l
+ async-notif {+CREG} 1 1 [lindex [split $l ,] 0]
+ }
+ 2 { sync-reply $l }
+ 1 {
+ async-notif {+CREG} 1 2 $l
+ }
+ default {
+ bad-data $l "async-notif-creg $ll"
+ }
+ }
+}
+
+proc async-control-max0 {c l allows} {
+ async-control-core $c $l $allows {
+ set wanted 0
+ } {
+ set tw 0
+ manyset $ca($c) tw
+ if {$tw} { set wanted 1 }
+ } {
+ set send $wanted
+ foreach allow $allows { lappend $send [lindex $allow 0] }
+ sync-subcommand $c "$cmd=[join $send ,]" async-updated-ok $c
+ }
+}
+
+proc async-control-cmer {c l allows} {
+ async-control-core $c $l $allows {
+ set send 0,0,0,0
+ } {
+ set mode 0; set ind 0
+ manyset $ca($c) mode keyp disp ind bfr
+ if {$mode==3 && $ind} { set send 3,0,0,1 }
+ } {
+ sync-subcommand $c "$cmd=$send" async-updated-ok $c
+ }
+}
+
+proc async-updated-ok
+
+proc async-control-core {c l allows ubody_init ubody_perclient ubody_finish} {
+ global clients
+ uplevel 1 cmd cmd
+ if {[regexp {^(AT[^=?])\?$} dummy cmd]} {
+ sync-subcommand $c $cmd async-massage-result-subs $c $cmd
+ } elseif {[regexp {^(AT[^=?])=\?$} dummy cmd]} {
+ sync-subcommand $c $cmd async-massage-result-support $c $cmd $allows
+ } elseif {[regexp {^(AT[^=?])=([0-9,]+)$} dummy cmd values]} {
+ set values [split $values ,]
+ if {[llength $values] > [llength $allows]} {
+ bad-command "too many values"
+ return
+ }
+ while {[llength $values] < [llength $allows]} {
+ lappend values 0
+ }
+ foreach val $values allow $allows {
+ if {[lsearch -exact $allow $val]<0} {
+ bad-command "$val not in allowed $allow ($allows)"
+ return
+ }
+ }
+ uplevel 1 [list upvar #0 client_async/$cmd ca]
+ upvar #0 client_async/$cmd ca
+ set ca($c) $values
+ uplevel 1 $ubody_init
+ upvar 1 c uc
+ foreach uc [array names clients] {
+ uplevel 1 $ubody_perclient
+ }
+ uplevel 1 $ubody_finish
+ } else {
+ bad-command "unknown async control syntax"
+ }
+}
+
+proc set-client-echo {c yn} {
+ global client_echo
+ set client_echo($c) 0
+ client-command-complete $c OK
+}
+
+proc process-client-command {c nl} {
+ switch -regexp $l {
+ {^AT\+CREG\b} { async-control-max0 $c $l {{0 1 2}} }
+ {^AT\+CGREG\b} { async-control-max0 $c $l {{0 1 2}} }
+ {^AT\*ERINFO\b} { async-control-max0 $c $l {{0 1}} }
+ {^AT\+CGEREP\b} { async-control-max0 $c $l {{0 1 2} 0} }
+ {^AT\+CMER\b} { async-control-cmer $c $l {{0 3} 0 0 {0 1} 0} }
+ {^ATE0$} { set-client-echo $c 0 }
+ {^ATE1$} { set-client-echo $c 1 }
+
+
+proc dchan-line {l} {
+ global cclient
+ switch -regexp $l {
+ {\+CREG:} { async-notif-creg +CREG $l }
+ {\+CGREG:} { async-notif-creg +CGREG $l }
+ {\*ERINFO:} { async-notif-or-resp-fixed *ERINFO $l }
+ {\+CGEV:} { async-notif +CGEREP $l }
+
+ {\+CIEV:} { async-notif +CIEV $l }
+ }
+
+ if {[info exists cclient
+
+proc sendout-async
+proc logquote
+
+
+try-open-our-device
~ian / chiark-tcl-applet.git / commitdiff