From 25c45a983dbf137083243008b68e58af85b7e2e3 Mon Sep 17 00:00:00 2001
From: ian <ian>
Date: Sat, 7 Jun 2008 23:08:45 +0000
Subject: [PATCH] gui wip coming along nicely

---
 hostside/gui        | 187 +++++++++++++++++++++++++++++++++++++++++---
 hostside/gui-config |   1 +
 2 files changed, 176 insertions(+), 12 deletions(-)

diff --git a/hostside/gui b/hostside/gui
index 4dbe01a..6ab84e6 100755
--- a/hostside/gui
+++ b/hostside/gui
@@ -4,6 +4,8 @@
 
 set tk_strictMotif 1
 
+tk_setPalette background black foreground white
+
 source lib.tcl
 
 proc pagew {page} { return ".picture-$page" }
@@ -285,12 +287,14 @@ proc layout-data {} {
 
 # 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 }
@@ -305,16 +309,16 @@ proc speedw-new {w ctrlr} {
     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
@@ -339,9 +343,9 @@ proc speedw-uninhibit {w} {
     $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} {
@@ -453,6 +457,161 @@ register-event &train_*_signalling-problem {train problem} \
     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} {
@@ -515,14 +674,12 @@ append event_dispatch_body {
 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 {} {
@@ -532,6 +689,9 @@ 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 {
@@ -540,7 +700,10 @@ proc main {} {
     }
     unset cpage
     widgets-movpos
-    engage
+    widgets-input-bindings
+    engage-server
+    engage-input-bindings
+    start_commandloop
 }
 
 main
diff --git a/hostside/gui-config b/hostside/gui-config
index c7a4bc3..9b86f11 100644
--- a/hostside/gui-config
+++ b/hostside/gui-config
@@ -7,3 +7,4 @@ set movpos_bindings(bot) {
 	J		I	O
 	M		K	L
 }
+bind-input 0003 045e 0084 0390 wheelmouse "wheel mouse"
-- 
2.30.2