435 lines
14 KiB
Tcl
435 lines
14 KiB
Tcl
## \file hipadaba_configuration_common.tcl
|
|
# \brief Commands for building the hdb tree from sics object properties and an instrument dictionary.
|
|
#
|
|
# hobj policy: data=false control=parent nxsave=false klass=parent
|
|
# subtree/group_path policy: data=parent control=parent nxsave=parent klass=parent
|
|
# type=macro & klass=command -> kind=command
|
|
# type=macro & klass!=command -> kind=script
|
|
|
|
source $cfPath(hipadaba)/instdict_specification.tcl
|
|
source $cfPath(hipadaba)/common_instrument_dictionary.tcl
|
|
|
|
InstallHdb
|
|
|
|
# TODO only use add_node to add hpaths and nodes,
|
|
# eg add_node / path beam_monitor_scan prop_list {data true ...}
|
|
|
|
# eventid=source/type, type={parameter feedback graphics} eg hdb_bmonscan/feedback
|
|
proc update_node {name eventid access} {
|
|
global nodeindex
|
|
upvar $name signal
|
|
hset $nodeindex($eventid) $signal($eventid)
|
|
}
|
|
|
|
proc add_hpath {basePath path {priv spy} {dtype none} {dlen ""}} {
|
|
|
|
|
|
set parent $basePath
|
|
array set prop_arr [::utility::hlistplainprop $basePath]
|
|
foreach child [split $path /] {
|
|
if {[lsearch [hlist $parent] $child] == -1} {
|
|
hmake $parent/$child $priv $dtype $dlen
|
|
if {$basePath != "/"} {
|
|
hsetprop $parent/$child data $prop_arr(data)
|
|
hsetprop $parent/$child control $prop_arr(control)
|
|
hsetprop $parent/$child nxsave $prop_arr(nxsave)
|
|
hsetprop $parent/$child klass @none
|
|
hsetprop $parent/$child type $prop_arr(type)
|
|
}
|
|
}
|
|
if {$parent == "/"} {
|
|
set parent /$child
|
|
} else {
|
|
set parent $parent/$child
|
|
}
|
|
}
|
|
return $parent
|
|
}
|
|
|
|
proc add_cmd_par {hpath sobj name} {
|
|
hattach $hpath $sobj $name
|
|
#array set property [attlist $sobj]
|
|
# hsetprop $hpath/$name argtype $property(argtype)
|
|
foreach {prop pval} [attlist $sobj] {
|
|
hsetprop $hpath/$name $prop $pval
|
|
}
|
|
hsetprop $hpath/$name data false
|
|
# if {[info exists property(values)]} {
|
|
# hsetprop $hpath/$name values $property(values)
|
|
# }
|
|
# if {[info exists property(min)]} {
|
|
# hsetprop $hpath/$name min $property(min)
|
|
# }
|
|
# if {[info exists property(max)]} {
|
|
# hsetprop $hpath/$name max $property(max)
|
|
# }
|
|
}
|
|
|
|
proc add_feedback {hpath sobj name} {
|
|
hattach $hpath $sobj $name
|
|
foreach {prop pval} [attlist $sobj] {
|
|
hsetprop $hpath/$name $prop $pval
|
|
}
|
|
hsetprop $hpath/$name privilege READ_ONLY
|
|
}
|
|
|
|
# args is an optional set of properties as name/value pairs.
|
|
# need node kind
|
|
proc add_node {basePath args} {
|
|
global nodeindex
|
|
array unset arg_array
|
|
array set arg_array $args;
|
|
|
|
if {[info exists arg_array(path)] && [info exists arg_array(prop_list)]} {
|
|
add_hpath $basePath $arg_array(path)
|
|
if {$basePath == "/"} {
|
|
set node_path /$arg_array(path)
|
|
} else {
|
|
set node_path $basePath/$arg_array(path)
|
|
}
|
|
# if {[info exists arg_array(prop_list)]} {
|
|
foreach {prop pval} $arg_array(prop_list) {
|
|
hsetprop $node_path $prop $pval
|
|
}
|
|
# }
|
|
return $node_path
|
|
}
|
|
|
|
if {![info exists arg_array(dlen)]} {
|
|
set arg_array(dlen) ""
|
|
}
|
|
set gp_path [file dirname $arg_array(node)]
|
|
set node_name [file tail $arg_array(node)]
|
|
if {$gp_path != "."} {
|
|
add_hpath $basePath $gp_path
|
|
set basePath $basePath/$gp_path
|
|
hsetprop $basePath type part
|
|
}
|
|
if {[lsearch [hlist $basePath] $node_name] == -1} {
|
|
#TODO allow hdb nodes of type drivable countable environment
|
|
switch $arg_array(kind) {
|
|
command {
|
|
# A command is a macro, node=macro name
|
|
set command $node_name
|
|
set cmd_path [add_command $basePath $command]
|
|
set node_path $cmd_path
|
|
# The extra arguments for add_node are supplied by the command parameters
|
|
# and command feedback procedures.
|
|
if {[string length [info procs ${command}_parameters]] > 0} {
|
|
${command}_parameters add_node $cmd_path
|
|
} else {
|
|
$command -map param add_cmd_par $cmd_path
|
|
}
|
|
if {[string length [info procs ${command}_feedback]] > 0} {
|
|
add_hpath $cmd_path feedback
|
|
hsetprop $cmd_path/feedback type part
|
|
${command}_feedback add_node $cmd_path/feedback
|
|
} else {
|
|
add_hpath $cmd_path feedback
|
|
hsetprop $cmd_path/feedback type part
|
|
$command -map feedback add_feedback $cmd_path/feedback
|
|
}
|
|
}
|
|
event {
|
|
# An event is a data array, node= a node path
|
|
add_hpath $basePath $node_name $arg_array(priv) $arg_array(dtype) $arg_array(dlen)
|
|
set node_path $basePath/$node_name
|
|
set nodeindex($arg_array(eventid),$arg_array(node)) $node_path
|
|
}
|
|
hobj {
|
|
hattach $basePath $node_name $arg_array(long_name)
|
|
set node_path $basePath/$arg_array(long_name)
|
|
hsetprop $node_path data [getatt $node_name data]
|
|
hsetprop $node_path control [getatt $node_name control]
|
|
hsetprop $node_path nxsave [getatt $node_name nxsave]
|
|
hsetprop $node_path klass [getatt $node_name klass]
|
|
foreach child [hlist $node_path] {
|
|
hsetprop $node_path/$child data false
|
|
hsetprop $node_path/$child control [getatt $node_name control]
|
|
hsetprop $node_path/$child nxsave false
|
|
hsetprop $node_path/$child klass [getatt $node_name klass]
|
|
}
|
|
}
|
|
ilist {
|
|
set node_path $basePath
|
|
set ilist_proc $node_name
|
|
$ilist_proc add_node $node_path
|
|
}
|
|
script {
|
|
# A r/w pair of scripts, node = a node path
|
|
set node_path $basePath/$node_name
|
|
hmakescript $node_path $arg_array(rscript) $arg_array(wscript) $arg_array(dtype) $arg_array(dlen)
|
|
}
|
|
}
|
|
if {[info exists arg_array(prop_list)]} {
|
|
foreach {prop pval} $arg_array(prop_list) {
|
|
hsetprop $node_path $prop $pval
|
|
}
|
|
}
|
|
return $node_path
|
|
}
|
|
}
|
|
|
|
# Add command
|
|
proc add_command {basePath command} {
|
|
array unset cmd_atts
|
|
array set cmd_atts [attlist $command]
|
|
if 0 {
|
|
if {[info exists cmd_atts(group)]} {
|
|
add_hpath $basePath $cmd_atts(group)
|
|
set basePath $basePath/$cmd_atts(group)
|
|
hsetprop $basePath type part
|
|
}
|
|
}
|
|
hcommand $basePath/$cmd_atts(long_name) $command
|
|
set cmd_ns [namespace qualifiers $command]
|
|
if {[llength [trace info variable ::${cmd_ns}::event]] == 0} {
|
|
trace add variable ::${cmd_ns}::event write update_node
|
|
}
|
|
set cmd_path $basePath/$cmd_atts(long_name)
|
|
hsetprop $cmd_path privilege $cmd_atts(privilege)
|
|
hsetprop $cmd_path type $cmd_atts(kind)
|
|
hsetprop $cmd_path data $cmd_atts(data)
|
|
hsetprop $cmd_path control $cmd_atts(control)
|
|
hsetprop $cmd_path klass $cmd_atts(klass)
|
|
hsetprop $cmd_path nxsave $cmd_atts(nxsave)
|
|
return $cmd_path
|
|
}
|
|
|
|
# attlist <sicsobj>
|
|
# return a list of name value pairs for the sicsobj attributes
|
|
proc attlist {sicsobj} {
|
|
foreach att [tolower_sicslist $sicsobj] {
|
|
lappend atts [split [string range $att 0 end-1] =]
|
|
}
|
|
return [join $atts]
|
|
}
|
|
|
|
# List sics objects with the given sics type, klass and group
|
|
proc sobjlist {atype aklass} {
|
|
global sobj_sicstype_list
|
|
|
|
switch $atype {
|
|
command,macro {
|
|
return [intersection [tolower_sicslist type macro] [tolower_sicslist klass $aklass] [tolower_sicslist kind command]]
|
|
}
|
|
script,macro {
|
|
return [intersection [tolower_sicslist type macro] [tolower_sicslist klass $aklass] [tolower_sicslist kind script]]
|
|
}
|
|
"@any" {
|
|
foreach st $sobj_sicstype_list {
|
|
lappend sobjects [tolower_sicslist type $st]
|
|
}
|
|
return [intersection [join $sobjects] [tolower_sicslist klass $aklass]]
|
|
}
|
|
default {
|
|
return [intersection [tolower_sicslist type $atype] [tolower_sicslist klass $aklass]]
|
|
}
|
|
}
|
|
}
|
|
|
|
proc getsobjatt {sicsobj attribute} {
|
|
string trim [lindex [join [split [tolower_sicslist $sicsobj $attribute] =]] 1]
|
|
}
|
|
|
|
|
|
# Add the given sics object (sobj) of sobjtype to the
|
|
# given hipadaba path hpath.
|
|
# hpath must exist.
|
|
proc sobjadd {hpath sobj args} {
|
|
array unset sobjatt
|
|
array set sobjatt [attlist $sobj]
|
|
switch $sobjatt(type) {
|
|
motor - configurablevirtualmotor {
|
|
if {[info exists sobjatt(group)]} {
|
|
set hpath [add_hpath $hpath $sobjatt(group)]
|
|
hsetprop $hpath type part
|
|
}
|
|
if {[lsearch [hlist $hpath] $sobjatt(long_name)] == -1} {
|
|
# hattach $hpath $sobj $sobjatt(long_name)
|
|
# hsetprop $hpath/$sobjatt(long_name) units $sobjatt(units)
|
|
# hsetprop $hpath/$sobjatt(long_name) long_name $sobjatt(long_name)
|
|
set node_path [add_node $hpath node $sobj long_name $sobjatt(long_name) kind $sobjatt(kind)]
|
|
hsetprop $node_path savecmd $sobjatt(savecmd)
|
|
hsetprop $node_path sdsinfo $sobjatt(sdsinfo)
|
|
hsetprop $node_path nxalias $sobjatt(nxalias)
|
|
hsetprop $node_path mutable $sobjatt(mutable)
|
|
} else {
|
|
clientput "ERROR: $hpath/$sobjatt(long_name) for $sobj exists" error
|
|
}
|
|
}
|
|
macro {
|
|
if {[info exists sobjatt(group)]} {
|
|
set hpath [add_hpath $hpath $sobjatt(group)]
|
|
hsetprop $hpath type part
|
|
}
|
|
if {[lsearch [hlist $hpath] $sobjatt(long_name)] != -1} {
|
|
clientput "ERROR: $hpath/$sobjatt(long_name) for $sobj exists" error
|
|
} else {
|
|
add_node $hpath kind $sobjatt(kind) node $sobj dtype $sobjatt(type) priv $sobjatt(privilege)
|
|
}
|
|
}
|
|
sicsvariable {
|
|
if {[info exists sobjatt(group)]} {
|
|
set hpath [add_hpath $hpath $sobjatt(group)]
|
|
hsetprop $hpath type part
|
|
}
|
|
if {[lsearch [hlist $hpath] $sobjatt(long_name)] == -1} {
|
|
set node_path [add_node $hpath node $sobj long_name $sobjatt(long_name) kind $sobjatt(kind)]
|
|
hsetprop $node_path sicsdev $sobj
|
|
hsetprop $node_path nxalias $sobj
|
|
hsetprop $node_path savecmd $sobjatt(savecmd)
|
|
hsetprop $node_path sdsinfo $sobjatt(sdsinfo)
|
|
hsetprop $node_path mutable $sobjatt(mutable)
|
|
hsetprop $node_path privilege $sobjatt(privilege)
|
|
} else {
|
|
clientput "ERROR: $hpath/$sobjatt(long_name) for $sobj exists" error
|
|
}
|
|
}
|
|
node {
|
|
}
|
|
singlecounter {
|
|
# TODO
|
|
todo_msg "$sobjatt(type) case, add $sobj to $hpath"
|
|
}
|
|
histmem {
|
|
# TODO
|
|
todo_msg "$sobjatt(type) case, add $sobj to $hpath"
|
|
if {[info exists sobjatt(group)]} {
|
|
set hpath [add_hpath $hpath $sobjatt(group)]
|
|
hsetprop $hpath type part
|
|
}
|
|
if {[lsearch [hlist $hpath] $sobjatt(long_name)] == -1} {
|
|
set node_path [add_node $hpath node $sobj long_name $sobjatt(long_name) kind $sobjatt(kind)]
|
|
hsetprop $node_path savecmd $sobjatt(savecmd)
|
|
hsetprop $node_path sdsinfo $sobjatt(sdsinfo)
|
|
hsetprop $node_path nxalias $sobjatt(nxalias)
|
|
hsetprop $node_path mutable $sobjatt(mutable)
|
|
hsetprop $node_path sicsdev $sobj
|
|
} else {
|
|
clientput "ERROR: $hpath/$sobjatt(long_name) for $sobj exists" error
|
|
}
|
|
}
|
|
nxscript {
|
|
# TODO
|
|
todo_msg "$sobjatt(type) case, add $sobj to $hpath"
|
|
}
|
|
sicsdata {
|
|
# TODO
|
|
todo_msg "$sobjatt(type) case, add $sobj to $hpath"
|
|
}
|
|
scanobject {
|
|
# TODO
|
|
todo_msg "$sobjatt(type) case, add $sobj to $hpath"
|
|
}
|
|
}
|
|
}
|
|
|
|
# sobjtypeadd <hpath> <sobjtype>
|
|
# Traverses list of sics objects of given type and attaches the matching sics objects to the given hpath
|
|
# Hipadaba node properties are constructed from the sobj attribute list.
|
|
proc sobjtypeadd {hpath sobjtype given_klass} {
|
|
foreach {sobj} [sobjlist $sobjtype $given_klass] {
|
|
sobjadd $hpath $sobj
|
|
}
|
|
}
|
|
|
|
|
|
## \brief Remove empty instrument dictionary nodes
|
|
#
|
|
# \param instdict name of the instrument dictionary structure
|
|
#
|
|
# Nodes which have no child nodes and no associated sics objects for the
|
|
# current instrument are removed.
|
|
proc prune {instdict} {
|
|
upvar $instdict dict
|
|
array set dictarr $dict
|
|
set candidates [array names dictarr]
|
|
# While there are candidates for removal remove the childless ones
|
|
# which have an empty sobj list
|
|
while {[expr [llength $candidates]] > 0} {
|
|
set new_candidates ""
|
|
foreach name $candidates {
|
|
array unset dictval
|
|
array set dictval $dictarr($name)
|
|
if {[lsearch $dictval(property) nxvgroup] != -1} {
|
|
# Link targets are not candidates for pruning
|
|
continue
|
|
}
|
|
set sobjects ""
|
|
if {[info exists dictval(sobj)]} {
|
|
foreach {t k} $dictval(sobj) {
|
|
lappend sobjects [sobjlist $t $k]
|
|
}
|
|
}
|
|
if { [llength [join $sobjects]] == 0 } {
|
|
if {[llength [array get dictarr $name/*]] == 0} {
|
|
array unset dictarr $name
|
|
} else {
|
|
if {[lsearch $candidates $name/*] != -1} {
|
|
lappend new_candidates $name
|
|
}
|
|
}
|
|
}
|
|
}
|
|
set candidates $new_candidates
|
|
}
|
|
set dict [array get dictarr]
|
|
return
|
|
}
|
|
#
|
|
#TODO add data control nxsave nxtyp properties
|
|
##\brief Traverse the instrument dictionary and construct the hipadaba database.
|
|
#
|
|
# \param instDict name of the instrument dictionary structure
|
|
#
|
|
# This command prunes the dictionary before building it.
|
|
# \see prune
|
|
proc buildHDB {instDict} {
|
|
upvar #0 $instDict dictionary
|
|
prune dictionary
|
|
foreach {n v} $dictionary {
|
|
array unset varr
|
|
array set varr $v
|
|
array unset property_array
|
|
array set property_array $varr(property)
|
|
add_node / path $n prop_list $varr(property)
|
|
if {[info exists varr(sobj)]} {
|
|
foreach {sicstype sobj_klass} $varr(sobj) {
|
|
sobjtypeadd /$n $sicstype $sobj_klass
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
namespace eval ::hdb {
|
|
proc set_save {hpath mode {top true}} {
|
|
if {$hpath != "/"} {
|
|
set hnode $hpath
|
|
} else {
|
|
foreach hp [hlist /] {
|
|
::hdb::set_save /$hp $mode
|
|
}
|
|
return
|
|
}
|
|
if {[::utility::hgetplainprop $hnode data] == "false"} {
|
|
return
|
|
}
|
|
foreach hp [hlist $hnode] {
|
|
set_save $hnode/$hp $mode false
|
|
}
|
|
if {$top == "true"} {
|
|
hsetprop $hnode nxsave $mode
|
|
if {$mode == "true"} {
|
|
set hp ""
|
|
foreach ps [lrange [split [string trim $hnode /] /] 0 end-1] {
|
|
set hp $hp/$ps
|
|
hsetprop $hp nxsave true
|
|
}
|
|
}
|
|
} else {
|
|
hsetprop $hnode nxsave $mode
|
|
}
|
|
}
|
|
}
|