b3138f1197
- Added sinfo to SICS - Added driver for TCP/IP Astrium velocity selector - Added driver for TCP/IP Astrium chopper controller SKIPPED: psi/amor2t.c psi/amorstat.c psi/dornier2.c psi/ecb.c psi/el734hp.c psi/fowrite.c psi/libpsi.a psi/make_gen psi/nextrics.c psi/pardef.c psi/pimotor.c psi/pipiezo.c psi/polterwrite.c psi/psi.c psi/scontroller.c psi/serial.c psi/tasinit.c psi/tasscan.c psi/tcpdocho.c psi/tcpdornier.c psi/tricssupport.c psi/velodornier.c
388 lines
11 KiB
Tcl
388 lines
11 KiB
Tcl
# requires stooop package from tcllib
|
|
# loaded from sycamore.tcl
|
|
|
|
proc arga argStr {
|
|
set args [ split $argStr ]
|
|
set argc [llength $args]
|
|
# syc::debug "arga.argc = %s" $argc
|
|
set objName ""
|
|
set key ""
|
|
set name ""
|
|
set val ""
|
|
set bObj [expr $argc > 0]
|
|
set bKey [expr $argc > 1]
|
|
set bName [expr $argc > 2]
|
|
set bVal [expr $argc > 3]
|
|
if $bObj {
|
|
set objName [string tolower [lindex $args 0]]
|
|
#syc::debug "arga.objName = %s" $objName
|
|
}
|
|
if $bKey {
|
|
set key [string tolower [lindex $args 1]]
|
|
#syc::debug "arga.key = %s" $key
|
|
}
|
|
if $bName {
|
|
set name [string tolower [lindex $args 2]]
|
|
}
|
|
if $bVal {
|
|
set val [string tolower [lindex $args 3]]
|
|
}
|
|
# ? cannot get 'array set' to work in the form:
|
|
# array set argv {
|
|
# argc $argc
|
|
# objName $objName
|
|
# ... etcetera
|
|
# }
|
|
set argv(argc) $argc
|
|
set argv(bObj) $bObj
|
|
set argv(bKey) $bKey
|
|
set argv(bName) $bName
|
|
set argv(bVal) $bVal
|
|
set argv(objName) $objName
|
|
set argv(key) $key
|
|
set argv(name) $name
|
|
set argv(val) $val
|
|
# would like to return associative array
|
|
# for now, settle for list
|
|
# syc::debug "arga.argv = { %s }" [array get argv]
|
|
return [array get argv]
|
|
}
|
|
|
|
# -----------------------------------------------------------------------------
|
|
class sinfo { ;# base class definition
|
|
proc sinfo {this} { ;# base class constructor
|
|
# non-static data member initialisation
|
|
set ($this,objectID) $this
|
|
}
|
|
|
|
proc ~sinfo {this} {} ;# base class destructor
|
|
|
|
proc id {this} {
|
|
return [format "sin.objectID = \{ %s \}" $($this,objectID)]
|
|
}
|
|
|
|
# static data member variables
|
|
# set File default.dat
|
|
set delimiter ", "
|
|
set debug 0
|
|
set init 0
|
|
set name "sinfo"
|
|
set usage {sinfo init|diag|config|server|device|command [parameter]}
|
|
set version 0.6
|
|
|
|
class server {
|
|
proc server {this name} {
|
|
set ($this,name) $name
|
|
|
|
proc name {this} {
|
|
return [format "server.name = \{ %s \}" $($this,name)]
|
|
}
|
|
}
|
|
proc ~server {this} {}
|
|
}
|
|
|
|
class sinfot {
|
|
proc sinfot {this} {}
|
|
proc ~sinfot {this} {}
|
|
}
|
|
|
|
proc helpMsgStr args {
|
|
return [formatMsg $sinfo::name "usage" $sinfo::usage]
|
|
}
|
|
|
|
proc debug args {
|
|
if {$sinfo::debug < 1} {
|
|
return
|
|
}
|
|
set l [llength $args]
|
|
set dMsg "Script code event"
|
|
set dVal " "
|
|
if {$l > 0} {
|
|
set dMsg [lindex $args 0]
|
|
if {$l > 1} {
|
|
set dVal [lindex $args 1]
|
|
}
|
|
}
|
|
sinWrite [format "sinfo::debug: %s" [format $dMsg $dVal]] "value"
|
|
}
|
|
|
|
proc diag args {
|
|
set flag [lindex $args 0]
|
|
set msg [format "diag=%s" $flag]
|
|
switch $flag {
|
|
"on" {
|
|
set sinfo::debug 1
|
|
}
|
|
"off" {
|
|
set sinfo::debug 0
|
|
}
|
|
default {
|
|
if {1 == $sinfo::debug} {
|
|
set msg "diag=on"
|
|
} else {
|
|
set msg "diag=off"
|
|
}
|
|
}
|
|
}
|
|
return [format "sinfo.diag = \{ %s \}" $msg]
|
|
}
|
|
|
|
proc formatMsg {objName parName msg} {
|
|
# return [format "%s.%s = \{ %s \}" $objName $parName $msg]
|
|
# set msgStr [format "%s.%s = %s " $objName $parName $msg]
|
|
#sinWrite "DEBUG formatMsg: msg = $msg" "value"
|
|
return "$objName.$parName=$msg"
|
|
}
|
|
|
|
proc writeObjPar {objName parName} {
|
|
return [format "%s.%s = \{ %s \}" \
|
|
$objName $parName [set ::$objName::$parName]]
|
|
}
|
|
|
|
proc writeError {objName msg} {
|
|
# return [format "%s.error = \{ %s \}" $objName $msg]
|
|
set msg [format "%s.error = \{ %s \}" $objName $msg]
|
|
sinWrite $msg "error"
|
|
return $msg
|
|
}
|
|
|
|
proc writeNspPar {objName parName} {
|
|
set result ::
|
|
append result $objName :: $parName
|
|
# return [format "%s.%s = \{ %s \}" $objName $parName [set $result]]
|
|
sinWrite [format "%s" [set $result]] "value"
|
|
}
|
|
|
|
proc writeList {objName parName parList} {
|
|
# return [format "%s.%s = %s " $objName $parName \
|
|
# [join $parList $sinfo::delimiter]]
|
|
set msg [format "%s" [join $parList $sinfo::delimiter]]
|
|
sinWrite $msg "value"
|
|
#return $msg
|
|
}
|
|
|
|
proc writeNamespaceChildren {obj key nsp} {
|
|
set chList {}
|
|
set nameList {}
|
|
set chList [namespace children $nsp]
|
|
set l [llength $chList]
|
|
for {set i 0} {$i < $l} {incr i} {
|
|
lappend nameList [namespace tail [lindex $chList $i]]
|
|
}
|
|
writeList $obj $key $nameList
|
|
}
|
|
|
|
proc writeNamespaceList {obj key nsp} {
|
|
set nameList {}
|
|
foreach v [info vars ${nsp}::*] {
|
|
lappend nameList [namespace tail $v]
|
|
}
|
|
writeList $obj $key $nameList
|
|
}
|
|
}
|
|
|
|
proc sinfo::server args {
|
|
array set argv [arga $args]
|
|
debug "sinfo::server, server.argv = { %s }" [array get argv]
|
|
set parSet {}
|
|
set parNames {}
|
|
if {$argv(bKey)} {
|
|
set key $argv(key)
|
|
debug "sinfo::server, key = $key"
|
|
switch $key {
|
|
"connection" -
|
|
"experiment" -
|
|
"help" -
|
|
"key" -
|
|
"list"
|
|
{
|
|
debug "sinfo::server, in switch $key, sinfox list server $key"
|
|
set nameList [sinfox list server $key]
|
|
sinfo::writeList "server" $key $nameList
|
|
}
|
|
"command" -
|
|
"device" -
|
|
"devicetype" -
|
|
"group" -
|
|
"interface"
|
|
{
|
|
if {$argv(bName)} {
|
|
set name $argv(name)
|
|
debug "sinfo::server, using name $name"
|
|
#sinWrite [format "DEBUG: if bname, key = %s, name = %s" $key $name] "value"
|
|
set nameList [sinfox list server $key $name]
|
|
sinfo::writeList "server" $name $nameList
|
|
#todo: improve response for unknown name
|
|
# eg server.error={device=foo}
|
|
} else {
|
|
set nameList [sinfox list server $key]
|
|
debug "sinfo::server, key=$key, nameList = $nameList"
|
|
sinfo::writeList "server" $key $nameList
|
|
}
|
|
}
|
|
|
|
"gtdevice"
|
|
{
|
|
if {$argv(bName)} {
|
|
set name $argv(name)
|
|
if [info exists ::server::gtDeviceList::$name] {
|
|
sinfo::writeNspPar server::gtDeviceList $name
|
|
} else {
|
|
set msg [format "key=%s.%s" "server" $key]
|
|
return [sinfo::writeList "server" error $msg]
|
|
}
|
|
} else {
|
|
writeList "server" $key [gumtree::gtDeviceList]
|
|
# sinfo::writeNamespaceList "server" $key \
|
|
# [ ::server::gtDeviceList
|
|
}
|
|
}
|
|
|
|
default {
|
|
puts default
|
|
if [info exists ::server::$key] {
|
|
sinfo::writeNspPar server $key
|
|
} else {
|
|
set msg [format "key=%s.%s" "server" $key]
|
|
return [sinfo::writeList "server" error $msg]
|
|
}
|
|
}
|
|
}
|
|
} else {
|
|
# writeNamespaceList $objName
|
|
set nameList [sinfox list server list]
|
|
writeList "server" "list" $nameList
|
|
}
|
|
}
|
|
|
|
proc sinfo::checkType {objName} {
|
|
if { [string compare -nocase $objName server] == 0 } then {
|
|
set return "server"
|
|
} elseif { [string compare -nocase $objName sequencer] == 0 } then {
|
|
set return "sequencer"
|
|
} else {
|
|
switch [SICSType $objName] {
|
|
COUNT -
|
|
DRIV { return "device" }
|
|
COM { return "command" }
|
|
TEXT { return "object" }
|
|
default { return "unknown" }
|
|
}
|
|
}
|
|
}
|
|
|
|
proc sinfo::list args {
|
|
array set argv [arga $args]
|
|
debug "sinfo.argv = { %s }" [array get argv]
|
|
set argc [llength $args]
|
|
set objName $argv(objName)
|
|
set key $argv(key)
|
|
set name $argv(name)
|
|
sinfo::debug "sinfo.numargs = %s" $argc
|
|
if {$argc < 1} {
|
|
sinWrite [sinfo::helpMsgStr] "value"
|
|
return
|
|
}
|
|
sinfo::debug "object = %s" $argv(objName)
|
|
if $argv(bKey) {
|
|
sinfo::debug "key = %s" $argv(key)
|
|
}
|
|
if $argv(bName) {
|
|
sinfo::debug "name = %s" $argv(name)
|
|
}
|
|
|
|
set parList {}
|
|
set numPars 0
|
|
|
|
set objType [checkType $objName]
|
|
sinfo::debug "sinfo.objectType = %s" $objType
|
|
|
|
switch $objType {
|
|
device
|
|
{
|
|
set nameList [sinfox list $objName $key $name]
|
|
writeList $objName $key $nameList
|
|
}
|
|
command
|
|
{
|
|
debug "sinfo.message = { %s is command objectType}" $objName
|
|
}
|
|
server
|
|
{
|
|
set cmd [format "sinfo::server %s %s %s %s" \
|
|
$objName $key $argv(name) $argv(val)]
|
|
return [eval $cmd]
|
|
}
|
|
sequencer
|
|
{
|
|
debug "sinfo.message = { %s is sequencer objectType}" $objName
|
|
if {$argv(bKey)} {
|
|
set key $argv(key)
|
|
switch $key {
|
|
"command"
|
|
{
|
|
if $bName {
|
|
set target [format "::sequencer::%s" $name]
|
|
sinfo::writeNamespaceList $objName $name $target
|
|
} else {
|
|
sinfo::writeNamespaceChildren $objName \
|
|
$key ::sequencer
|
|
}
|
|
}
|
|
default
|
|
{
|
|
}
|
|
}
|
|
} else {
|
|
sinfo::writeNamespaceList "sequencer" "list" "::sequencer"
|
|
}
|
|
}
|
|
object
|
|
{
|
|
# todo: test for interface name
|
|
switch $objName {
|
|
default {
|
|
writeError "sinfo" \
|
|
[format "'%s' is invalid object" $objName]
|
|
}
|
|
}
|
|
}
|
|
unknown -
|
|
default {
|
|
writeError "sinfo" [format "'%s' has invalid object type" $objName]
|
|
}
|
|
}
|
|
}
|
|
|
|
# -----------------------------------------------------------------------------
|
|
# wrapper procs for sinfo class
|
|
|
|
proc sinfo args {
|
|
set l [llength $args]
|
|
if {$l < 1} {
|
|
sinWrite [sinfo::helpMsgStr] "value"
|
|
return
|
|
}
|
|
set arglist [ split $args ]
|
|
set objName [lindex $arglist 0]
|
|
set cmd [format "sinfo::%s $args" $objName]
|
|
#sinWrite "DEBUG: $cmd" "value"
|
|
# set cmd $args
|
|
#set cmd "sinfo::list $args"
|
|
#FIXME the command should provide the output code for sinWrite
|
|
#sinWrite [eval $cmd] "value"
|
|
eval $cmd
|
|
}
|
|
|
|
proc sin args {
|
|
set argc [llength $args]
|
|
if {$argc < 1} {
|
|
set msg \
|
|
"sin.usage = \
|
|
{ sin \[server|sequencer|device|command\] \[parameter\] }"
|
|
sinWrite $msg "value"
|
|
} else {
|
|
sinWrite [sinfo::list $args] "value"
|
|
}
|
|
}
|