8e6d4e4da6
Check all kinds of hdb nodes for units. nxscripts_common_1.tcl Make units optional when saving data. Catch histogram memory savecmd errors. r2188 | ffr | 2007-10-23 12:32:41 +1000 (Tue, 23 Oct 2007) | 7 lines
501 lines
18 KiB
Tcl
501 lines
18 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
|
|
# kind=script must have access property (read_only, read_write) and dtype and dlen
|
|
|
|
source $cfPath(hipadaba)/instdict_specification.tcl
|
|
source $cfPath(hipadaba)/common_instrument_dictionary.tcl
|
|
|
|
InstallHdb
|
|
|
|
namespace eval ::hdb {
|
|
namespace export buildHDB attlist
|
|
}
|
|
|
|
##
|
|
# @brief Add an hdb path to the hdb tree at the given basePath
|
|
#
|
|
# @param basePath This is the parent for the new hdb path
|
|
# @param path Add this path to the basePath
|
|
# @param priv This is the access privilege for the new hdb path
|
|
# @param dtype The new hdb node will have this type
|
|
# @param dlen Array length if the hdb node represents array data
|
|
proc ::hdb::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
|
|
}
|
|
|
|
##
|
|
# @brief Attach a command parameter node to the given hdb "command path"
|
|
#
|
|
# @param hpath hdb "command path", this will be the parent for the parameter node
|
|
# @param sobj name of SICS variable which corresponds to a command parameter
|
|
# @param name The hdb node name that the variable will be added under
|
|
# @see command
|
|
proc ::hdb::add_cmd_par {hpath sobj name} {
|
|
hattach $hpath $sobj $name
|
|
foreach {prop pval} [attlist $sobj] {
|
|
hsetprop $hpath/$name $prop $pval
|
|
}
|
|
hsetprop $hpath/$name data false
|
|
}
|
|
|
|
##
|
|
# @brief Attach a feedback node to the given hdb "command path"
|
|
#
|
|
# @param hpath hdb "command path", this will be the parent for the feedback node
|
|
# @param sobj name of the SICS variable which corresponds to a command feedback value
|
|
# @param name The hdb node name that the variable will be added under
|
|
# @see command
|
|
proc ::hdb::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
|
|
}
|
|
|
|
##
|
|
# @brief Adds a hdb path to the given base path with the given properties
|
|
#
|
|
# @param args a list of name value pairs which provide the node properties\n
|
|
#\targs can just be "path a/b/c prop_list {kind xxx long_name junk ..}"\n
|
|
#\tor "node nnn kind kkk long_name junk prop_list {propA aaa propB bbb ...}"
|
|
proc ::hdb::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
|
|
array set attribute [attlist $node_name]
|
|
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 ::hdb::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 ::hdb::add_feedback $cmd_path/feedback
|
|
}
|
|
}
|
|
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]
|
|
}
|
|
}
|
|
script {
|
|
# A r/w pair of scripts, node = a node path
|
|
set node_path $basePath/[getatt $node_name long_name]
|
|
set data_type [getatt $node_name dtype]
|
|
set data_length [getatt $node_name dlen]
|
|
if {[getatt $node_name access] == "read_only"} {
|
|
hmakescript $node_path $node_name hdbReadOnly $data_type $data_length
|
|
} else {
|
|
hmakescript $node_path $node_name $node_name $data_type $data_length
|
|
}
|
|
hsetprop $node_path sicsdev $node_name
|
|
hsetprop $node_path nxalias $node_name
|
|
hsetprop $node_path data true
|
|
hsetprop $node_path control false
|
|
hsetprop $node_path klass [getatt $node_name klass]
|
|
hsetprop $node_path sdsinfo [getatt $node_name sdsinfo]
|
|
hsetprop $node_path savecmd [getatt $node_name savecmd]
|
|
#hmakescript $node_path $arg_array(rscript) $arg_array(wscript) $arg_array(dtype) $arg_array(dlen)
|
|
}
|
|
}
|
|
if {[info exists attribute(units)]} {
|
|
hsetprop $node_path units $attribute(units)
|
|
}
|
|
if {[info exists arg_array(prop_list)]} {
|
|
foreach {prop pval} $arg_array(prop_list) {
|
|
hsetprop $node_path $prop $pval
|
|
}
|
|
}
|
|
sicslist setatt $node_name hdb_path $node_path
|
|
return $node_path
|
|
}
|
|
}
|
|
|
|
##
|
|
# @brief Add a "command" node to basePath for the gumtree control interface.
|
|
# @param basePath parent for new command node
|
|
# @param command name of the command procedure
|
|
proc ::hdb::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_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
|
|
}
|
|
|
|
##
|
|
# @brief Retrieve the list of attributes for the given sics object
|
|
#
|
|
# @param sicsobj SICS object name
|
|
# @return a list of name value pairs for the sicsobj attributes
|
|
proc ::hdb::attlist {sicsobj} {
|
|
foreach att [tolower_sicslist $sicsobj] {
|
|
lappend atts [split [string range $att 0 end-1] =]
|
|
}
|
|
return [join $atts]
|
|
}
|
|
|
|
|
|
##
|
|
# @brief List sics objects with the given sics type, klass and group
|
|
#
|
|
# @param atype one of the types given in instdict_specification.tcl
|
|
# @param aklass one of the klasses given in instdict_specification.tcl
|
|
# @return A Tcl list of SICS objects.
|
|
proc ::hdb::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]]
|
|
}
|
|
}
|
|
}
|
|
|
|
##
|
|
# @brief Get the named attribute from the given SICS object
|
|
#
|
|
# @param sicsobj a SICS object name
|
|
# @param attribute name of the attribute to be fetched
|
|
# @return the plain attribute value
|
|
proc ::hdb::getsobjatt {sicsobj attribute} {
|
|
string trim [lindex [join [split [tolower_sicslist $sicsobj $attribute] =]] 1]
|
|
}
|
|
|
|
##
|
|
# @brief Add the given sics object of sobjtype to the given hipadaba path (hpath must exist)
|
|
#
|
|
# @param hpath parent for new hdb node
|
|
# @param sobj SICS object name
|
|
# @param args Hmmm this doesn't get used, do we need it?
|
|
proc ::hdb::sobjadd {hpath sobj args} {
|
|
# TODO Check if args parameter needs to be here, it might be there in case the function is called
|
|
# with more than two arguments.
|
|
array unset sobjatt
|
|
array set sobjatt [attlist $sobj]
|
|
sicslist setatt $sobj id $sobj
|
|
switch $sobjatt(type) {
|
|
motor - configurablevirtualmotor {
|
|
if {[info exists sobjatt(group)]} {
|
|
set hpath [add_hpath $hpath $sobjatt(group)]
|
|
if {[catch {hsetprop $hpath type part} err]} {clientput $err error}
|
|
}
|
|
if {[lsearch [hlist $hpath] $sobjatt(long_name)] == -1} {
|
|
set node_path [add_node $hpath node $sobj long_name $sobjatt(long_name) kind $sobjatt(kind)]
|
|
if {[catch {hsetprop $node_path savecmd $sobjatt(savecmd)} err]} {clientput $err error}
|
|
if {[catch {hsetprop $node_path sdsinfo $sobjatt(sdsinfo)} err]} {clientput $err error}
|
|
if {[catch {hsetprop $node_path nxalias $sobjatt(nxalias)} err]} {clientput $err error}
|
|
if {[catch {hsetprop $node_path mutable $sobjatt(mutable)} err]} {clientput $err error}
|
|
} else {
|
|
clientput "ERROR: $hpath/$sobjatt(long_name) for $sobj exists" error
|
|
}
|
|
}
|
|
macro {
|
|
# access attribute = ro,rw
|
|
if {[info exists sobjatt(group)]} {
|
|
set hpath [add_hpath $hpath $sobjatt(group)]
|
|
if {[catch {hsetprop $hpath type part} err]} {clientput $err error}
|
|
}
|
|
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 priv $sobjatt(privilege)
|
|
}
|
|
}
|
|
sicsvariable {
|
|
if {[info exists sobjatt(group)]} {
|
|
set hpath [add_hpath $hpath $sobjatt(group)]
|
|
if {[catch {hsetprop $hpath type part} err]} {clientput $err error}
|
|
}
|
|
if {[lsearch [hlist $hpath] $sobjatt(long_name)] == -1} {
|
|
set node_path [add_node $hpath node $sobj long_name $sobjatt(long_name) kind $sobjatt(kind)]
|
|
if {[catch {hsetprop $node_path sicsdev $sobj} err]} {clientput $err error}
|
|
if {[catch {hsetprop $node_path nxalias $sobj} err]} {clientput $err error}
|
|
if {[catch {hsetprop $node_path savecmd $sobjatt(savecmd)} err]} {clientput $err error}
|
|
if {[catch {hsetprop $node_path sdsinfo $sobjatt(sdsinfo)} err]} {clientput $err error}
|
|
if {[catch {hsetprop $node_path mutable $sobjatt(mutable)} err]} {clientput $err error}
|
|
if {[catch {hsetprop $node_path privilege $sobjatt(privilege)} err]} {clientput $err error}
|
|
} else {
|
|
clientput "ERROR: $hpath/$sobjatt(long_name) for $sobj exists" error
|
|
}
|
|
}
|
|
node {
|
|
}
|
|
singlecounter {
|
|
# TODO
|
|
todo_msg "$sobjatt(type) case, add $sobj to $hpath"
|
|
}
|
|
histmem {
|
|
if {[info exists sobjatt(group)]} {
|
|
set hpath [add_hpath $hpath $sobjatt(group)]
|
|
if {[catch {hsetprop $hpath type part} err]} {clientput $err error}
|
|
}
|
|
if {[lsearch [hlist $hpath] $sobjatt(long_name)] == -1} {
|
|
set node_path [add_node $hpath node $sobj long_name $sobjatt(long_name) kind $sobjatt(kind)]
|
|
if {[catch {hsetprop $node_path savecmd $sobjatt(savecmd)} err]} {clientput $err error}
|
|
if {[catch {hsetprop $node_path sdsinfo $sobjatt(sdsinfo)} err]} {clientput $err error}
|
|
if {[catch {hsetprop $node_path nxalias $sobjatt(nxalias)} err]} {clientput $err error}
|
|
if {[catch {hsetprop $node_path mutable $sobjatt(mutable)} err]} {clientput $err error}
|
|
if {[catch {hsetprop $node_path sicsdev $sobj} err]} {clientput $err error}
|
|
} 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"
|
|
}
|
|
environment_controller {
|
|
if {[info exists sobjatt(group)]} {
|
|
set hpath [add_hpath $hpath $sobjatt(group)]
|
|
if {[catch {hsetprop $hpath type part} err]} {clientput $err error}
|
|
}
|
|
if {[lsearch [hlist $hpath] $sobjatt(long_name)] == -1} {
|
|
set node_path [add_node $hpath node $sobj long_name $sobjatt(long_name) kind $sobjatt(kind)]
|
|
if {[catch { hsetprop $node_path savecmd $sobjatt(savecmd)} err]} {clientput $err error}
|
|
if {[catch { hsetprop $node_path sdsinfo $sobjatt(sdsinfo)} err]} {clientput $err error}
|
|
if {[catch { hsetprop $node_path nxalias $sobjatt(nxalias)} err]} {clientput $err error}
|
|
if {[catch { hsetprop $node_path mutable $sobjatt(mutable)} err]} {clientput $err error}
|
|
hmakescript $node_path/target "$sobj target" hdbReadOnly float
|
|
hsetprop $node_path/target data false
|
|
hsetprop $node_path/target control true
|
|
} else {
|
|
clientput "ERROR: $hpath/$sobjatt(long_name) for $sobj exists" error
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
##
|
|
# @brief Attaches the SICS objects of the given type and klass to the given hdb path
|
|
#
|
|
# The hipadaba node properties are constructed from the SICS object attribute list.
|
|
#
|
|
# @param hpath parent for the new SICS object nodes
|
|
# @param sobjtype One of the types in instdict_specification.tcl
|
|
# @param given_klass A klass in instdict_specification.tcl
|
|
# @see sobjadd
|
|
proc ::hdb::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 ::hdb::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
|
|
}
|
|
|
|
##
|
|
# @brief Traverse the instrument dictionary and construct the hipadaba database.
|
|
#
|
|
# This command prunes the dictionary before building it.
|
|
#
|
|
# @param instDict name of the instrument dictionary structure
|
|
#
|
|
# @see prune
|
|
proc ::hdb::buildHDB {instDict} {
|
|
#TODO add data control nxsave nxtyp properties
|
|
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
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
##
|
|
# @brief Set the save state for the given subtree
|
|
#
|
|
# @param hpath The save state of the nodes below this path will be set
|
|
# @param mode true or false
|
|
# @param top This is just here to make the recursion work from the top level, You don't need
|
|
# to set this
|
|
proc ::hdb::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
|
|
}
|
|
}
|
|
|
|
namespace import ::hdb::*
|