#!/usr/bin/wishx
+load chiark_tcl_hbytes-1.so
+
#---------- general utilities ----------
set tk_strictMotif 1
[list --grab] [ib-wheelmouse-redactions]]]
}
+#----- gamepad
+
+proc ib-create/gamepad {devid wunique desc} {
+ ib-speedw-new $devid $wunique $desc
+}
+
#----- ebuyer wireless keyboard
proc ib-create/ebwikeb {devid wunique} {
speedw-setstate $w normal
}
+#----- Joytech "Neo S" USB PC gamepad
+
+proc hidraw-descriptors/gamepad-neo-s {} {
+ return xx
+}
+
+#proc hidraw-readable/gamepad-neo-s {chan hidraw devid} {
+# upvar #0 hidraw/$hidraw raw
+# # In my tests with tcl8.3 and tcl8.5, "read chan numbytes"
+# # on a nonblocking binary channel does only one read(2)
+# # provided that read(2) returns less than requested
+# while 1 {
+# set msg [hbytes raw2h [read $chan 256]]
+# if {![hbytes
+# switch -glob [bhtes $msg {
+# 4a* { set want 8 }
+# {} { set want 64 }
+# * { error "unknown report number $raw(buf)" }
+# }
+# if {$want > $sofar} {
+# set got [read $chan [expr {$want - $sofar}]]
+#
+# }
+#
+# set sofar [hbytes length $raw(buf)]
+# if {!$sofar} {
+# set got [read $chan 64]
+# } else {
+#
+# }
+
+
#---------- input device evdev binding ----------
proc ib-evcmd-construct {devid target xargs} {
/dev/input/$ev]]
}
-proc bind-input {bus vendor product version concrete args} {
+proc bind-input-core {devid devkind devinfo concrete concargs} {
global input_bindings
- set devid $bus:$vendor:$product:$version
- lappend input_bindings [list $devid $concrete $args]
+ lappend input_bindings [list $devkind $devid $devinfo $concrete $concargs]
+}
+
+proc bind-input {bus vendor product version concrete args} {
+ bind-input-core evdev:$bus:$vendor:$product:$version \
+ evdev [list $bus $vendor $product $version] \
+ $concrete $args
}
proc bind-input-static {event sysfs concrete args} {
- global input_bindings input_statics
- set devid [get-unique static]
- lappend input_statics [list $devid $event $sysfs]
- lappend input_bindings [list $devid $concrete $args]
+ bind-input-core [get-unique static] \
+ static [list $event $sysfs] \
+ $concrete $args
+}
+
+proc bind-input-raw {devtype concrete args} {
+ bind-input-core hidraw:[get-unique $devtype] \
+ hidraw [list $devtype] \
+ $concrete $args
}
proc widgets-input-bindings {} {
global input_bindings
foreach binding $input_bindings {
- manyset $binding devid concrete xa
+ manyset $binding devkind devid devinfo concrete concargs
set cid [get-unique $concrete]
upvar #0 input/$devid in
set in(laststart) 0
set in(concrete) $concrete
- eval [list ib-create/$concrete $devid $cid] $xa
+ eval [list ib-create/$concrete $devid $cid] $concargs
}
pack .inputs -side top -fill x
}
-# input/$bus:$vendor:$product:$version becomes `in' via upvar
-# $in(chan) channel open onto evdev-manip; unset if none
+# input/$devid becomes `in' via upvar:
+# $in(chan) channel open onto evdev-manip;
+# unset if none, or hidraw, or something
# $in(laststart) last start time, [clock seconds]
# at every event we set this the current time
# but we insist on adding at least 5s
# we don't start
# $in(speedw) optional, may be set by ib-create
+# hidraw/hidrawN becomes `hr' via upvar:
+# $raw(devid) $devid (see above)
+# $raw(chan) channel open onto /dev/hidrawN
+
+proc input-concrete-start-try {devid concrete} {
+ global inputretryadd inputretrymax
+ upvar #0 input/$devid in
+ set now [clock seconds]
+ set newlast [expr {$in(laststart) + $inputretryadd}]
+ if {$newlast > $now + $inputretrymax} { return 0 }
+ if {$newlast < $now} { set newlast $now }
+ set in(laststart) $newlast
+}
+
+proc input-bindings-list {devkind} {
+ global input_bindings
+ set o {}
+ foreach b $input_bindings {
+ manyset $b dk
+ if {[string compare $dk $devkind]} continue
+ lappend o $b
+ }
+ return $o
+}
+
proc scan-input-bindings {} {
- global errorInfo errorCode unmatched_notified
- global input_bindings inputretryadd inputretrymax scaninputinterval
- global input_statics
+ global errorInfo errorCode unmatched_notified old_hidraws
+ global input_bindings scaninputinterval
+ global input_rawbindings
+
+ after $scaninputinterval scan-input-bindings
+
+ # scan /proc/bus/input/devices for appropriate evdevs
+ # results go in $target($devid)
if {[catch {
set f [open /proc/bus/input/devices]
} emsg]} {
}
}
close $f
- foreach static $input_statics {
- manyset $static devid event sysfs
+
+ # add as-if-scanned entries for static bindings to target
+ # also check to see if we want hidraw
+ foreach binding $input_bindings {
+ manyset $binding devkind devid devinfo concrete concargs
+ switch -exact $devkind static { } default continue
lappend target($devid) [list $event $sysfs]
}
+
+ # scan /dev/hidraw*
+ foreach binding [input-bindings-list hidraw] {
+ manyset $binding devkind devid devinfo concrete concargs
+ switch -exact $devkind hidraw { } default continue
+ manyset $devinfo devtype
+ set rawmap([hidraw-descriptors/$devtype]) \
+ [list $devid $devtype $concrete]
+ }
+ if {[array exists rawmap]} {
+ set new_hidraws [lsort [glob -nocomplain -directory /dev hidraw*]]
+ foreach hidraw $new_hidraws {
+ upvar #0 hidraw/$hidraw raw
+ if {[info exists raw(chan)]} {
+ set found($raw(devid)) 1
+ continue
+ }
+ if {[lsearch -exact $old_hidraws $hidraw] >= 0} continue
+ if {[catch {
+ set chan [open $hidraw r+]
+ set descriptors [exec ./hidraw-ioctl -d <@ $chan]
+ if {![info exists rawmap($descriptors)]} {
+ set m [exec ./hidraw-ioctl -i <@ $chan]
+ error "unknown descriptors (unmatched device) $hidraw $m >$descriptors<"
+ }
+ } emsg]} {
+ upvar #0 hidraw_notified($hidraw) notified
+ if {![info exists notified] ||
+ [string compare $notified $emsg]} {
+ debug "ir $hidraw $emsg"
+ set notified $emsg
+ }
+ catch { close $chan }
+ catch { unset chan }
+ continue
+ }
+ manyset $rawmap($descriptors) devid devtype concrete
+ set found($devid) 1
+ if {![input-concrete-start-try $devid $concrete]} {
+ catch { close $chan }
+ continue
+ }
+ set raw(devid) $devid
+ set raw(chan) $chan
+ fconfigure $chan -buffering none -blocking no \
+ -encoding binary -eofchar {} -translation binary
+ fileevent $chan readable \
+ [list hidraw-readable/$devtype $chan $hidraw $devid]
+ input-binding-present $devid 1 "hidraw $hidraw"
+ }
+ set old_hidraws $new_hidraws
+ }
+
+ # try to start the input binding for all the unstarted found targets
foreach devid [array names target] {
upvar #0 input/$devid in
if {![info exists in(concrete)]} {
}
continue
}
+ set found($devid) 1
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 }
+ if {![input-concrete-start-try $devid $concrete]} continue
+
set cmdl [ib-evcmd/$in(concrete) $devid $target($devid)]
if {![llength $cmdl]} {
unset target($devid)
continue
}
lappend cmdl 2>@ stderr
- set in(laststart) $newlast
catch-for-input-binding $devid {
debug "ib $devid running $cmdl"
set in(chan) [open |$cmdl r+]
[list readable input-binding $in(chan) $devid]]
}
}
+
+ # anything not found, not present
foreach binding $input_bindings {
- manyset $binding devid concrete ctrlr
+ manyset $binding devkind devid devinfo concrete concargs
+ switch -exact $devkind evdev - raw { } default continue
upvar #0 input/$devid in
if {![info exists in(concrete)]} continue
- if {[info exists target($devid)]} continue
- input-binding-notpresent $devid absent
+ if {[info exists found($devid)]} continue
+ input-binding-present $devid 0 absent
}
- after $scaninputinterval scan-input-bindings
}
-proc input-binding-notpresent {devid why} {
+proc input-binding-present {devid yes why} {
upvar #0 input/$devid in
if {[info exists in(speedw)]} {
- speedw-setstate $in(speedw) disabled
+ speedw-setstate $in(speedw) [lindex {disabled normal} $yes]
}
- if {![catch { info args ib-absent/$in(concret) }]} {
- ib-absent/$in(concrete) $devid $why
+ set call "ib-[lindex {absent present} $yes]/$in(concrete)"
+ if {![catch { info args $call }]} {
+ $call $devid $why
}
}
switch -glob -- $lr {
{opened *} {
debug "ib $devid start << $l"
- if {[info exists in(speedw)]} {
- speedw-setstate $in(speedw) normal
- }
+ input-binding-present 1 $devid "evdev open"
}
{[-0-9]*} {
manyset [split $lr] value kindl kindr codel coder
catch { close $in(chan) }
catch { unset in(chan) }
- input-binding-notpresent $devid "died $m"
+ input-binding-present $devid 0 "died $m"
}
proc engage-input-bindings {} {
}
proc main {} {
- global pages cpage configfile input_bindings input_statics
+ global pages cpage configfile input_bindings old_hidraws
setting server railway {[[0-9a-z:].*}
setting geometry {} {[-+]\d+[-+]\d+}
setting posdeviation 5 {\d+}
frame .inputs
if {![info exists input_bindings]} { set input_bindings {} }
- if {![info exists input_statics]} { set input_statics {} }
+ set old_hidraws {}
uplevel #0 source gui-layout.config
uplevel #0 source $configfile
~ijackson / trains.git / commitdiff