ttyacm-multiplex

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