set tk_strictMotif 1
+tk_setPalette background black foreground white
+
source lib.tcl
proc pagew {page} { return ".picture-$page" }
# Interfaces for concrete controllers:
# speedw-new $w $ctrlr {stepmap}
-# speedw-setstate $w enabled|disabled controller appears/disappears
+# speedw-setstate $w disabled|normal controller appears/disappears
# speedw-userinput-abs $w $step
# speedw-userinput-rel $w $stepmap
# where
# eval {stepmap} [list $oldstep] => $newstep
+set speedws {}
+
proc speedws-forall {command args} {
global speedws
foreach w $speedws { eval [list $command $w] $args }
set s(inhibit) 0
set s(commanding) 0
- frame $w -relief groove
+ frame $w -relief groove -border 1
label $w.ctrlr -state disabled -text $s(ctrlr)
set s(optionmenu) [tk_optionMenu $w.train speed/${w}(train) {}]
- $w.train configure -textvariable {} -width 100
- label $w.speed -state disabled -width 40 \
+ $w.train configure -textvariable {} -width 15
+ label $w.speed -state disabled -width 4 \
-font -*-courier-bold-r-*-*-20-*-*-*-*-*-*-* \
-background black -foreground white
pack $w.ctrlr $w.train $w.speed -side left
- speedw-notrains $w
+ speedw-notrains $w "(starting)"
}
proc speedw-notrains {w whystr} {
$w.train configure -state disabled
$w.speed configure -foreground white
}
-proc speedw-setstate {w enadis} {
- $w.ctrlr configure -state $enadis
- $w.speed configure -state $enadis -
+proc speedw-setstate {w disnorm} {
+ $w.ctrlr configure -state $disnorm
+ $w.speed configure -state $disnorm
}
proc speedw-train-selected {w t} {
speedws-train-problem $train
}
+#---------- input device evdev binding ----------
+
+proc bind-input {bus vendor product version concrete ctrlr} {
+ global input_bindings
+ set key $bus:$vendor:$product:$version
+ lappend input_bindings [list $key $concrete $ctrlr]
+}
+
+proc widgets-input-bindings {} {
+ global input_bindings
+ frame .inputs
+ foreach binding $input_bindings {
+ manyset $binding key concrete ctrlr
+ upvar #0 concreteix($concrete) cix
+ if {![info exists cix]} { set cix 0 }
+ incr cix
+ set w .inputs.$concrete$cix
+ speedw-new $w $ctrlr
+ pack $w -side left -padx 10
+ upvar #0 input/$key in
+puts stderr $key
+ set in(w) $w
+ set in(laststart) 0
+ set in(concrete) $concrete
+ }
+ pack .inputs -side bottom -fill x
+}
+
+# input/$bus:$vendor:$product:$version becomes `in' via upvar
+# $in(w) the speedw
+# $in(chan) channel open onto evdev-manip; unset if none
+# $in(laststart) last start time, [clock seconds]
+# at every event we set this the current time
+# but we insist on adding at least 5s
+# and if that would make it > current time +15s
+# we don't start
+
+proc scan-input-bindings {} {
+ global errorInfo errorCode
+ global input_bindings inputretryadd inputretrymax scaninputinterval
+ if {[catch {
+ set f [open /proc/bus/input/devices]
+ } emsg]} {
+ if {[string match {POSIX ENOENT *} $errorCode]} return
+ error $emsg $errorInfo $errorCode
+ }
+ while 1 {
+ set r [gets $f l]
+ if {$r <= 0} {
+ if {[info exists v(key)] &&
+ [info exists v(sysfs)] &&
+ [info exists v(event)]} {
+ lappend target($v(key)) [list $v(event) $v(sysfs)]
+ }
+ catch { unset v }
+ }
+ if {$r < 0} {
+ break
+ }
+ append l "\n"
+ if {[regexp \
+ {^I: Bus=(\w+) Vendor=(\w+) Product=(\w+) Version=(\w+)\s} \
+ $l dummy bus vendor product version]} {
+ set v(key) $bus:$vendor:$product:$version
+ } elseif {[regexp {^S: Sysfs=(\S+)\s} $l dummy sysfs]} {
+ set v(sysfs) $sysfs
+ } elseif {[regexp {^H: Handlers=(?:.*\s)?(event\d+)\s} $l dummy ev]} {
+ set v(event) $ev
+ } else {
+ # ignored
+ }
+ }
+ close $f
+ foreach key [array names target] {
+ if {[llength $target($key)] > 1} { unset target($key); continue }
+ upvar #0 input/$key in
+ if {![info exists in(w)]} continue
+ if {[info exists in(chan)]} continue
+ set now [clock seconds]
+ set newlast [expr {$in(laststart) + $inputretryadd}]
+ if {$newlast > $now + $inputretrymax} continue
+ if {$newlast < $now} { set newlast $now }
+ set in(laststart) $newlast
+ manyset [lindex $target($key) 0] ev sysfs
+ set cmdl [list ./evdev-manip --grab --stdin-monitor \
+ --expect-sysfs /sys$sysfs/$ev/dev \
+ /dev/input/$ev]
+ catch-for-input-binding $key {
+ debug "i-b $key running $cmdl"
+ set in(chan) [open |$cmdl r]
+ fconfigure $in(chan) -blocking 0 -buffering line
+ fileevent $in(chan) readable [list catch-for-input-binding $key \
+ [list readable input-binding $in(chan) $key]]
+ }
+ }
+ foreach binding $input_bindings {
+ manyset $binding key concrete ctrlr
+ upvar #0 input/$key in
+ if {![info exists in(w)]} continue
+ if {[info exists target($key)]} continue
+ speedw-setstate $in(w) disabled
+ }
+ after $scaninputinterval scan-input-bindings
+}
+
+proc input-binding-eof {chan key} {
+ upvar #0 input/$key in
+ fconfigure $in(chan) -blocking 1
+ close $in(chan)
+ error "evdev-manip exited" {} {CHILDSTATUS ? 0}
+}
+
+proc input-binding-inputline {chan l key} {
+ upvar #0 input/$key in
+ switch -glob -- $l {
+ {device *} {
+ debug "i-b $key start << $l"
+ speedw-setstate $in(w) normal
+ }
+ {event *} {
+ manyset [split $l] dummy dummy kind code value
+ set proc ib-$in(concrete)-$kind/$code
+ if {[catch { info args $proc }]} return
+ $proc $value
+ }
+ {report-from *} { }
+ {synch *} { }
+ * {
+ debug "i-b $key ignored << $l"
+ }
+ }
+}
+
+proc catch-for-input-binding {key body} {
+ upvar #0 input/$key in
+ global errorInfo errorCode
+ set r [catch { uplevel 1 $body } rv]
+ if {$r!=1} { return -code $r $rv }
+ switch -glob $errorCode {
+ {CHILDSTATUS *} { set m "exited with status [lindex $errorCode 2]" }
+ {CHILDKILLED *} { set m "killed by signal [lindex $errorCode 3]" }
+ {POSIX *} { set m "communication error: [lindex $errorCode 1]" }
+ * { error $rv $errorInfo $errorCode }
+ }
+ debug "i-b $key died $m"
+ catch { close $in(chan) }
+ catch { unset in(chan) }
+
+ speedw-setstate $in(w) disabled
+}
+
+proc engage-input-bindings {} {
+ scan-input-bindings
+}
+
#---------- plan background (gui-plan subprocess) ----------
proc gui-pipe-readable {args} {
proc train-event-inputline {sconn l} $event_dispatch_body
proc register-event {args} { error "too late!" }
-proc engage {} {
+proc engage-server {} {
global server port sconn
set sconn [socket $server $port]
fconfig-trainproto $sconn
fileevent $sconn readable {readable train-event $sconn}
-
- start_commandloop
}
proc main {} {
setting posdeviation 10 {\d+}
setting movfeatcommand {movfeat++} {(?:!movfeat|movfeat\+?\+?)}
setting problemdisplayms 1000 {\d+}
+ setting inputretryadd 5 {\d+}
+ setting inputretrymax 15 {\d+}
+ setting scaninputinterval 500 {\d+}
uplevel #0 source gui-config
parse-argv {}
foreach cpage $pages {
}
unset cpage
widgets-movpos
- engage
+ widgets-input-bindings
+ engage-server
+ engage-input-bindings
+ start_commandloop
}
main
~ijackson / trains.git / commitdiff