361 lines
13 KiB
Tcl
361 lines
13 KiB
Tcl
# This is a template driver for a device from vendor
|
|
#
|
|
# Author: Douglas Clowes
|
|
# Date: September 2011
|
|
#
|
|
|
|
set vendor "aerotech"
|
|
set device "soloist"
|
|
|
|
namespace eval ::scobj::[set vendor]_[set device] {
|
|
# All of this takes place in a namespace based on the vendor and device
|
|
# Debug prints and vendor/device save
|
|
puts "Namespace: [namespace current]"
|
|
puts "Vendor:[set vendor]"
|
|
puts "Device:[set device]"
|
|
set [namespace current]::vendor [set ::vendor]
|
|
set [namespace current]::device [set ::device]
|
|
set [namespace current]::ven_dev "[set ::vendor]_[set ::device]"
|
|
puts "[namespace current]::vendor [set [namespace current]::vendor]"
|
|
puts "[namespace current]::device [set [namespace current]::device]"
|
|
puts "[namespace current]::ven_dev [set [namespace current]::ven_dev]"
|
|
|
|
proc debug_log {debug_level arg_string} {
|
|
# write a timestamped string message to a log file for debugging
|
|
set catch_status [ catch {
|
|
set debug_threshold 0
|
|
if {$debug_level >= $debug_threshold} {
|
|
set fd [open "[set [namespace current]::log_file]" "a" 0777]
|
|
set catch_status [ catch {
|
|
set line "[clock format [clock seconds] -format "%T"] $arg_string"
|
|
puts $fd "$line"
|
|
} catch_message ]
|
|
close $fd
|
|
}
|
|
} catch_message ]
|
|
}
|
|
|
|
proc basename {node} {
|
|
set point [string last "/" $node]
|
|
if { $point < 0 } {
|
|
return $node
|
|
} else {
|
|
incr point
|
|
return "[string range $node $point end]"
|
|
}
|
|
}
|
|
proc pathname {node} {
|
|
set point [string last "/" $node]
|
|
if { $point < 0 } {
|
|
return ""
|
|
} else {
|
|
incr point -1
|
|
return "[string range $node 0 $point]"
|
|
}
|
|
return "[join [lrange [split $node '/'] 0 end-1] '/']"
|
|
}
|
|
|
|
proc ns {} {
|
|
return "[namespace current]"
|
|
}
|
|
|
|
proc setValue {tc_root nextState cmd} {
|
|
# send a command to set a value
|
|
debug_log 1 "setValue tc_root=$tc_root sct=[sct] $cmd [sct target]"
|
|
if { [hpropexists [sct] geterror] } {
|
|
hdelprop [sct] geterror
|
|
}
|
|
set par [sct target]
|
|
sct send "$cmd $par"
|
|
return $nextState
|
|
}
|
|
|
|
proc chkWrite {tc_root} {
|
|
# process the response to the write
|
|
# - not all devices will respond to writes
|
|
set data [sct result]
|
|
debug_log 1 "chkWrite tc_root=$tc_root sct=[sct] resp=$data"
|
|
if {[string equal -nocase -length 7 $data "ASCERR:"]} {
|
|
# the protocol driver has reported an error
|
|
sct geterror "$data"
|
|
} elseif {[string equal -nocase -length 1 $data "?"]} {
|
|
# the device has reported an error
|
|
sct geterror "Error: $data"
|
|
} else {
|
|
# the write was successful, record the data
|
|
set data [sct target]
|
|
if {$data != [sct oldval]} {
|
|
sct oldval $data
|
|
sct update $data
|
|
sct utime readtime
|
|
debug_log 1 "chkWrite new data for $tc_root [sct] result=$data"
|
|
}
|
|
}
|
|
return idle
|
|
}
|
|
|
|
proc nulWrite {tc_root} {
|
|
set data "[sct result]"
|
|
debug_log 1 "nulWrite tc_root=$tc_root sct=[sct] resp=$data"
|
|
return idle
|
|
}
|
|
|
|
proc getValue {tc_root nextState cmd} {
|
|
# send a command to request a value
|
|
debug_log 1 "getValue tc_root=$tc_root sct=[sct] $cmd"
|
|
if { [hpropexists [sct] geterror] } {
|
|
hdelprop [sct] geterror
|
|
}
|
|
sct send "$cmd"
|
|
return $nextState
|
|
}
|
|
|
|
proc rdValue {tc_root} {
|
|
# process the received response to the read request
|
|
debug_log 1 "rdValue tc_root=$tc_root sct=[sct] result=[sct result]"
|
|
set data [sct result]
|
|
if {[string equal -nocase -length 7 $data "ASCERR:"]} {
|
|
# the protocol driver has reported an error
|
|
sct geterror "$data"
|
|
} elseif {[string equal -nocase -length 1 $data "!"]} {
|
|
# the device has reported an error
|
|
sct geterror "Error: $data"
|
|
} elseif {[string equal -nocase -length 1 $data "%"]} {
|
|
set val "[string range $data 1 end]"
|
|
if { [string equal -nocase "[basename [sct]]" axisstatus] } {
|
|
set txt ""
|
|
set zzz [list 0 1 2 3 4 5 6 7 8 9 10 11 12 14 18 19 22 23 24 25 26 27 28 29 30 31]
|
|
set xxx [list ena hom inp mov acc dec pca ccl brk cwi msc cac cen hmg afa cfd hlm llm hml mrk hia hib hic see cee est]
|
|
for { set i 0 } {$i < [llength $zzz]} { incr i } {
|
|
if { [string length $txt] > 0 } { set txt ":$txt" }
|
|
if { ($val & (1 << int([lindex $zzz $i]))) == 0 } {
|
|
set txt "[string tolower [lindex $xxx $i]]$txt"
|
|
} else {
|
|
set txt "[string toupper [lindex $xxx $i]]$txt"
|
|
}
|
|
}
|
|
set val [format "0x%08X" $val]
|
|
}
|
|
if {$val != [sct oldval]} {
|
|
debug_log 1 "[sct] new:$val, old:[sct oldval]"
|
|
sct oldval $val
|
|
sct update $val
|
|
sct utime readtime
|
|
debug_log 1 "[pathname [sct]] new:$txt, old:[hval [pathname [sct]]]"
|
|
hset "[pathname [sct]]/axistext" "$txt"
|
|
}
|
|
} else {
|
|
set fields [split "$data"]
|
|
set rate [lindex $fields end]
|
|
debug_log 1 "Rate new:$rate, old:[sct oldval]"
|
|
if {$rate != [sct oldval]} {
|
|
sct oldval $rate
|
|
sct update $rate
|
|
sct utime readtime
|
|
}
|
|
}
|
|
return idle
|
|
}
|
|
|
|
##
|
|
# @brief createNode() creates a node for the given nodename with the properties given
|
|
#
|
|
# @param scobj_hpath string variable holding the path to the object's base node in sics (/sample/tc1)
|
|
# @param sct_controller name of the scriptcontext object (typically sct_xxx_yyy)
|
|
# @param cmdGroup subdirectory (below /sample/tc*/) in which the node is to be created
|
|
# @param varName name of the actual node typically representing one device command
|
|
# @param readable set to 1 if the node represents a query command, 0 if it is not
|
|
# @param writable set to 1 if the node represents a request for a change in settings sent to the device
|
|
# @param drivable if set to 1 it prepares the node to provide a drivable interface
|
|
# @param dataType data type of the node, must be one of none, int, float, text
|
|
# @param permission defines what user group may read/write to this node (is one of spy, user, manager)
|
|
# @param rdCmd actual device query command to be sent to the device
|
|
# @param rdFunc nextState Function to be called after the getValue function, typically rdValue()
|
|
# @param wrCmd actual device write command to be sent to the device
|
|
# @param wrFunc Function to be called to send the wrCmd to the device, typically setValue()
|
|
# @param allowedValues allowed values for the node data - does not permit other
|
|
# @param klass Nexus class name (?)
|
|
# @return OK
|
|
proc createNode {scobj_hpath sct_controller\
|
|
cmdGroup varName\
|
|
readable writable drivable\
|
|
dataType permission\
|
|
rdCmd rdFunc\
|
|
wrCmd wrFunc\
|
|
allowedValues klass} {
|
|
|
|
set catch_status [ catch {
|
|
set ns "[namespace current]"
|
|
set nodeName "$scobj_hpath/$cmdGroup/$varName"
|
|
if {1 > [string length $cmdGroup]} {
|
|
set nodeName "$scobj_hpath/$varName"
|
|
}
|
|
debug_log 1 "Creating node $nodeName"
|
|
hfactory $nodeName plain $permission $dataType
|
|
if {$readable > 0} {
|
|
# the node is readable so set it up to be polled using the rdFunc
|
|
# rdFunc is getValueFunc.rdValueFunc with both explicit functions
|
|
# or rdValueFunc where "getValue" is the implied getValueFunc
|
|
set parts [split "$rdFunc" "."]
|
|
if { [llength $parts] == 2 } {
|
|
set func_name [lindex $parts 0]
|
|
set next_state [lindex $parts 1]
|
|
} else {
|
|
set func_name "getValue"
|
|
set next_state [lindex $parts 0]
|
|
}
|
|
hsetprop $nodeName read ${ns}::$func_name $scobj_hpath $next_state $rdCmd
|
|
hsetprop $nodeName $next_state ${ns}::$next_state $scobj_hpath
|
|
# set the poll rate as a period in seconds
|
|
# TODO allow directly settable value in seconds
|
|
set poll_period 30
|
|
if { $readable >= 0 && $readable <= 9 } {
|
|
set poll_period [lindex [list 0 1 2 3 4 5 10 15 20 30] $readable]
|
|
}
|
|
debug_log 1 "Registering node $nodeName for poll at $poll_period seconds"
|
|
$sct_controller poll $nodeName $poll_period
|
|
}
|
|
if {$writable == 1} {
|
|
# the node is writable so set it up to invoke a callback when written
|
|
# rdFunc is putValueFunc.chkWriteFunc with both explicit functions
|
|
# or putValueFunc where "noResponse" is the implied chkWriteFunc
|
|
set parts [split "$wrFunc" "."]
|
|
if { [llength $parts] == 2 } {
|
|
set func_name [lindex $parts 0]
|
|
set next_state [lindex $parts 1]
|
|
} else {
|
|
set func_name [lindex $parts 0]
|
|
set next_state "noResponse"
|
|
}
|
|
hsetprop $nodeName write ${ns}::$func_name $scobj_hpath $next_state $wrCmd
|
|
hsetprop $nodeName $next_state ${ns}::$next_state $scobj_hpath
|
|
hsetprop $nodeName writestatus UNKNOWN
|
|
debug_log 1 "Registering node $nodeName for write callback"
|
|
$sct_controller write $nodeName
|
|
}
|
|
# Initialise the previous value to test against
|
|
switch -exact $dataType {
|
|
"none" { }
|
|
"int" { hsetprop $nodeName oldval -1 }
|
|
"float" { hsetprop $nodeName oldval -1.0 }
|
|
default { hsetprop $nodeName oldval UNKNOWN }
|
|
}
|
|
# Set the allowed values property
|
|
if {1 < [string length $allowedValues]} {
|
|
hsetprop $nodeName values $allowedValues
|
|
}
|
|
# Drive adapter interface
|
|
# TODO make it a separate function and pass in all this stuff
|
|
if {$drivable == 1} {
|
|
hsetprop $nodeName check ${ns}::check $scobj_hpath
|
|
hsetprop $nodeName driving 0
|
|
hsetprop $nodeName checklimits ${ns}::check $scobj_hpath
|
|
hsetprop $nodeName checkstatus ${ns}::drivestatus $scobj_hpath
|
|
hsetprop $nodeName halt ${ns}::halt $scobj_hpath
|
|
} else {
|
|
hsetprop $nodeName driving 0
|
|
}
|
|
} catch_message ]
|
|
if {$catch_status != 0} {
|
|
debug_log 5 "error in [ns]::createNode $catch_message"
|
|
return -code error "in [ns]::createNode $catch_message"
|
|
}
|
|
return OK
|
|
}
|
|
|
|
proc mk_sct_driver {sct_controller klass name tol} {
|
|
set [ns]::log_file "/tmp/[set [ns]::ven_dev]_${name}.log"
|
|
debug_log 1 "mk_sct_driver $sct_controller $klass $name $tol"
|
|
set catch_status [ catch {
|
|
|
|
MakeSICSObj $name SCT_OBJECT
|
|
sicslist setatt $name klass $klass
|
|
sicslist setatt $name long_name $name
|
|
|
|
set scobj_hpath /sics/$name
|
|
|
|
set deviceCommand {\
|
|
{} axisstatus 1 0 0 text user {AXISSTATUS()} {rdValue} {} {} {}\
|
|
{} axistext 0 0 0 text user {} {} {} {} {}\
|
|
{} position 1 0 0 float user {PFBK()} {rdValue} {} {} {}\
|
|
{} velocity 1 0 0 float user {VFBK()} {rdValue} {} {} {}\
|
|
}
|
|
|
|
foreach {cmdGroup varName\
|
|
readable writable drivable\
|
|
dataType permission\
|
|
rdCmd rdFunc\
|
|
wrCmd wrFunc\
|
|
allowedValues} $deviceCommand {
|
|
createNode $scobj_hpath $sct_controller\
|
|
$cmdGroup $varName\
|
|
$readable $writable $drivable\
|
|
$dataType $permission\
|
|
$rdCmd $rdFunc\
|
|
$wrCmd $wrFunc\
|
|
$allowedValues $klass
|
|
}
|
|
|
|
} catch_message ]
|
|
if {$catch_status != 0} {
|
|
debug_log 5 "error in [ns]::mk_sct_driver $catch_message"
|
|
return -code error "in [ns]::mk_sct_driver $catch_message"
|
|
}
|
|
}
|
|
|
|
proc add_[set vendor]_[set device] {name IP port {_tol 5.0}} {
|
|
###puts "Namespace: [ns]"
|
|
###puts "::vendor $::vendor"
|
|
###puts "::device $::device"
|
|
###puts "[ns]::vendor [set [ns]::vendor]"
|
|
###puts "[ns]::device [set [ns]::device]"
|
|
###puts "[ns]::ven_dev [set [ns]::ven_dev]"
|
|
set [ns]::log_file "/tmp/[set [ns]::ven_dev]_[set name].log"
|
|
set fd [open "[set [namespace current]::log_file]" "w" 0777]
|
|
close $fd
|
|
debug_log 1 "add_[set [ns]::vendor]_[set [ns]::device] ${name} ${IP} ${port} ${_tol}"
|
|
if {[SplitReply [environment_simulation]]=="false"} {
|
|
debug_log 1 "makesctcontroller sct_${name} std ${IP}:${port}"
|
|
makesctcontroller sct_${name} std ${IP}:${port} "\n" 30.0
|
|
}
|
|
debug_log 1 "mk_sct_driver sct_${name} environment ${name} ${_tol}"
|
|
mk_sct_driver sct_${name} environment ${name} ${_tol}
|
|
}
|
|
|
|
|
|
namespace export add_[set vendor]_[set device]
|
|
}
|
|
|
|
namespace import ::scobj::[set vendor]_[set device]::*
|
|
|
|
#
|
|
# below this point is debugging only
|
|
#
|
|
if { "[lindex [split [info nameofexecutable] "/"] end]" == "tclsh"} {
|
|
set catch_status [ catch {
|
|
puts "TCLSH"
|
|
proc environment_simulation {} { return "" }
|
|
proc SplitReply {str} { return "" }
|
|
proc makesctcontroller {args} { }
|
|
proc MakeSICSObj {args} { }
|
|
proc sicslist {args} { }
|
|
proc hfactory {args} { }
|
|
proc hsetprop {args} { }
|
|
proc sct {args} {
|
|
puts $args
|
|
}
|
|
|
|
proc sct_bm1 {args} { }
|
|
add_ansto_bm "bm1" 127.0.0.1 4001 2.0
|
|
|
|
proc sct_bm2 {args} { }
|
|
add_ansto_bm "bm2" 127.0.0.1 4002 2.0
|
|
|
|
} catch_message ]
|
|
if {$catch_status != 0} {
|
|
puts "error in main $catch_message"
|
|
return -code error "in main $catch_message"
|
|
}
|
|
}
|
|
|