Merged new hdb and nexus code.
r2099 | ffr | 2007-07-22 15:23:41 +1000 (Sun, 22 Jul 2007) | 2 lines
This commit is contained in:
Ferdi Franceschini
committed by
Douglas Clowes
Douglas Clowes
parent
4e407d0a73
commit
8770acc191
@@ -0,0 +1,434 @@
|
||||
## \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
|
||||
}
|
||||
}
|
||||
}
|
||||
Reference in New Issue
Block a user