3224422d60
Squashed commit of the following: commit 736f0f3da501ee39fb89735a1142fe6ff2b2c4dd Author: Douglas Clowes <dcl@ansto.gov.au> Date: Wed Jul 2 12:21:32 2014 +1000 Use hlistprop $path tclnames in hipadaba_configuration_common.tcl commit 428cac5ac8fe37f6998d3114c71ca01fc9446644 Author: Douglas Clowes <dcl@ansto.gov.au> Date: Wed Jul 2 12:11:47 2014 +1000 Use hlistprop $path tclnames in nxscripts_common_1.tcl commit 123cc63924e92a9453bfd1297a4ee6398b31bd1d Author: Douglas Clowes <dcl@ansto.gov.au> Date: Wed Jul 2 10:56:34 2014 +1000 Use hlistprop $path tclnames in gumxml.tcl commit e23f8befd36a2066ceaa32ce3d37d53bc462f870 Author: Douglas Clowes <dcl@ansto.gov.au> Date: Wed Jul 2 10:55:48 2014 +1000 Use hlistprop $path tclnames in testing commit a3587be0a8cc9a9452a75cb0e19572558d35a08a Author: Douglas Clowes <dcl@ansto.gov.au> Date: Wed Jul 2 10:55:01 2014 +1000 Implement hlistprop $path tclnames
980 lines
33 KiB
Tcl
980 lines
33 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
|
|
|
|
namespace eval ::hdb {
|
|
namespace export buildHDB attlist
|
|
|
|
set sobjadd_state(depends) false
|
|
|
|
set NXlog_template {
|
|
NXlog {
|
|
$name {
|
|
$paramarr(time)
|
|
$paramarr(value)
|
|
$paramarr(raw_value)
|
|
$paramarr(description)
|
|
$paramarr(average_value)
|
|
$paramarr(average_value_error)
|
|
$paramarr(minimum_value)
|
|
$paramarr(maximum_value)
|
|
$paramarr(duration)
|
|
}
|
|
}
|
|
}
|
|
|
|
set NXnote_template {
|
|
NXnote {
|
|
$name {
|
|
$paramarr(author)
|
|
$paramarr(date)
|
|
$paramarr(type)
|
|
$paramarr(file_name)
|
|
$paramarr(description)
|
|
$paramarr(data)
|
|
}
|
|
}
|
|
}
|
|
|
|
set NXbeam_template {
|
|
$name {
|
|
$paramarr(distance)
|
|
$paramarr(incident_energy)
|
|
$paramarr(final_energy)
|
|
$paramarr(energy_transfer)
|
|
$paramarr(incident_wavelength)
|
|
$paramarr(incident_wavelength_spread)
|
|
$paramarr(incident_beam_divergence)
|
|
$paramarr(final_wavelength)
|
|
$paramarr(incident_polarization)
|
|
$paramarr(final_polarization)
|
|
$paramarr(final_wavelength_spread)
|
|
$paramarr(final_beam_divergence)
|
|
$paramarr(flux)
|
|
}
|
|
}
|
|
|
|
# NOTE: paramarr(offset) was added for Quokka's DetPosYOffsetmm parameter
|
|
set NXgeometry_template {
|
|
NXgeometry {
|
|
geometry {
|
|
sobjlist {$paramarr(geomdescription)}
|
|
NXshape {
|
|
shape {
|
|
sobjlist {$paramarr(shape) $paramarr(size)}
|
|
}
|
|
}
|
|
NXtranslation {
|
|
position {
|
|
sobjlist {$paramarr(position) $paramarr(offset) $paramarr(coordinate_scheme)}
|
|
NXgeometry {
|
|
geometry {
|
|
link {
|
|
target {$paramarr(refpos)}
|
|
nxalias {$paramarr(position)}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
NXorientation {
|
|
orientation {
|
|
sobjlist {$paramarr(orientation)}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
set NXaperture_template [subst -novariables {
|
|
NXaperture {
|
|
$name {
|
|
sobjlist {$paramarr(material) $paramarr(description)}
|
|
[ set NXgeometry_template ]
|
|
}
|
|
}
|
|
} ]
|
|
|
|
set NXvelocity_selector_template [subst -novariables {
|
|
NXvelocity_selector {
|
|
$name {
|
|
sobjlist {
|
|
$paramarr(type)
|
|
$paramarr(rotation_speed)
|
|
$paramarr(radius)
|
|
$paramarr(spwidth)
|
|
$paramarr(length)
|
|
$paramarr(num)
|
|
$paramarr(twist)
|
|
$paramarr(table)
|
|
$paramarr(height)
|
|
$paramarr(width)
|
|
$paramarr(wavelength)
|
|
$paramarr(wavelength_spread)
|
|
}
|
|
[ set NXgeometry_template ]
|
|
}
|
|
}
|
|
} ]
|
|
}
|
|
|
|
proc ::hdb::MakeLog {name klass paramlist} {
|
|
variable NXlog_template
|
|
array set paramarr $paramlist
|
|
set newtable [list]
|
|
prune_NX newtable $NXlog_template
|
|
::hdb::subtree_macro $name $klass $newtable
|
|
}
|
|
proc ::hdb::MakeNote {name klass paramlist} {
|
|
variable NXnote_template
|
|
array set paramarr $paramlist
|
|
set newtable [list]
|
|
prune_NX newtable $NXnote_template
|
|
::hdb::subtree_macro $name $klass $newtable
|
|
}
|
|
proc ::hdb::MakeBeam {name klass paramlist} {
|
|
variable NXbeam_template
|
|
array set paramarr $paramlist
|
|
set newtable [list]
|
|
prune_NX newtable $NXbeam_template
|
|
::hdb::subtree_macro $name $klass $newtable
|
|
}
|
|
|
|
proc ::hdb:MakeEnvironment {name klass paramlist} {
|
|
variable NXenvironment_template
|
|
array set paramarr $paramlist
|
|
set newtable [list]
|
|
prune_NX newtable $NXenvironment_template
|
|
::hdb::subtree_macro $name $klass $newtable
|
|
}
|
|
|
|
proc ::hdb::MakeGeometry {name klass paramlist} {
|
|
variable NXgeometry_template
|
|
array set paramarr $paramlist
|
|
set newtable [list]
|
|
prune_NX newtable $NXgeometry_template
|
|
::hdb::subtree_macro $name $klass $newtable
|
|
}
|
|
|
|
##
|
|
# @brief Generates an hdb subtree macro from a named list of SICS objects.
|
|
#
|
|
# NOTE: Currently the only SICS objects supported are 'sicsvariable' and 'macro'.
|
|
# @param name, This is the name of the aperture.
|
|
# @paramlist, A name value list of aperture parameters. All parameters are optional.
|
|
proc ::hdb::MakeAperture {name paramlist} {
|
|
array set paramarr $paramlist
|
|
variable NXaperture_template
|
|
set newtable [list]
|
|
prune_NX newtable $NXaperture_template
|
|
::hdb::subtree_macro $name instrument $newtable
|
|
}
|
|
|
|
proc ::hdb::MakeVelocity_Selector {name paramlist} {
|
|
variable NXvelocity_selector_template
|
|
array set paramarr $paramlist
|
|
set newtable [list]
|
|
prune_NX newtable $NXvelocity_selector_template
|
|
::hdb::subtree_macro $name instrument $newtable
|
|
}
|
|
|
|
##
|
|
# @brief This simplifies a NeXus-class template by removing unnecessary branches.
|
|
# A NeXus-class template is a keyed-list which has Tcl variables for some of the nodes,
|
|
# if the Tcl variables aren't defined for some branch then that branch is removed.
|
|
# All other variables are expanded in place, also all 'sobjlists' are split up into type
|
|
# specific lists. This is intended as a helper function for commands which generate
|
|
# NeXus-class keyed lists from a simple set of optional parameters.
|
|
#
|
|
# @param NXklist, This is a keyed list representation of the NeXus class which will be augmented
|
|
# with the pruned nx_template. Note this can just be an empty list.
|
|
# @param nx_template, The NeXus-class template which will be pruned.
|
|
# @param path, (optional, default="") Parent path in recursive calls.
|
|
# @param node, (optional, default="") Current node in recursive calls.
|
|
# @param level, (optional,default=1) The location of the template parameters in the callstack.
|
|
proc prune_NX {NXklist nx_template {path ""} {node ""} {level 1}} {
|
|
upvar $NXklist newtable
|
|
if {$path == ""} {
|
|
set currpath $node
|
|
} else {
|
|
set currpath $path/$node
|
|
}
|
|
foreach {n v} $nx_template {
|
|
switch $n {
|
|
"sobjlist" {
|
|
set has_sobj 0
|
|
foreach var $v {
|
|
if {[string index $var 0] == "$"} {
|
|
set vn [string range $var 1 end]
|
|
upvar $level $vn lvar
|
|
if [info exists lvar] {
|
|
foreach sobj $lvar {
|
|
lappend [getatt $sobj type]_list $sobj
|
|
}
|
|
set has_sobj 1
|
|
}
|
|
} else {
|
|
foreach sobj $var {
|
|
lappend [getatt $sobj type]_list $sobj
|
|
}
|
|
set has_sobj 1
|
|
}
|
|
}
|
|
if {$has_sobj} {
|
|
if [info exists sicsvariable_list] {
|
|
::utility::tabset newtable $currpath/sicsvariable [subst {{$sicsvariable_list}}]
|
|
}
|
|
if [info exists macro_list] {
|
|
::utility::tabset newtable $currpath/macro [subst {{$macro_list}}]
|
|
}
|
|
} else {
|
|
}
|
|
}
|
|
"link" {
|
|
set linktarget ""
|
|
array set linkinfo $v
|
|
if {[string index $linkinfo(target) 0] == "$"} {
|
|
set vn [string range $linkinfo(target) 1 end]
|
|
upvar $level $vn lvar
|
|
if [info exists lvar] {
|
|
set linktarget $lvar
|
|
}
|
|
} else {
|
|
set linktarget $linkinfo(target)
|
|
}
|
|
if {[string index $linkinfo(nxalias) 0] == "$"} {
|
|
set vn [string range $linkinfo(nxalias) 1 end]
|
|
upvar $level $vn avar
|
|
if [info exists avar] {
|
|
set linkname $avar
|
|
}
|
|
} else {
|
|
set linkname $linkinfo(nxalias)
|
|
}
|
|
if {$linktarget != ""} {
|
|
::utility::tabset newtable $currpath/link/target [subst {{$linktarget}}]
|
|
::utility::tabset newtable $currpath/link/nxalias [subst {{$linkname}}]
|
|
}
|
|
}
|
|
default {
|
|
if {[string range $n 0 1] == "NX"} {
|
|
set node $n
|
|
} elseif {[string index $n 0] == "$"} {
|
|
set vn [string range $n 1 end]
|
|
upvar $level $vn lvar
|
|
if [info exists lvar] {
|
|
set node $lvar
|
|
} else {
|
|
}
|
|
} else {
|
|
set node $n
|
|
}
|
|
prune_NX newtable $v $currpath $node [expr $level+1]
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
##
|
|
# @brief Make an aperture
|
|
#
|
|
# @param args optional name and description variables
|
|
#proc MakeAperture {apname nxgeometry args} {
|
|
# set nxaperture [::hdb::NXaperture $apname $nxgeometry $args]
|
|
# ::hdb::subtree_macro $apname instrument $nxaperture
|
|
#}
|
|
|
|
##
|
|
# @brief Generate a subtree macro procedure
|
|
#
|
|
# @param Name of the subtree macro
|
|
# @klass Category which the macro belongs to (usually a NeXus class)
|
|
# @klist A keyed list which describes the subtree.
|
|
proc ::hdb::subtree_macro {name klass klist} {
|
|
set st_macroname ${name}_subtree_macro
|
|
proc ::hdb::$st_macroname {} "return [list $klist]"
|
|
::hdb::set_subtree_props ::hdb::$st_macroname $klass
|
|
}
|
|
|
|
##
|
|
# @brief Publish an hdb_subtree macro and initialise it's property list
|
|
#
|
|
# @param st_name The name of the hdb_subtree macro
|
|
# @param klass Where should the subtree be placed in the hdb heirarchy
|
|
# @param control (optional, default=true) Add it to the control interface?
|
|
# @param privilege (optional, default=user) Modification privilege.
|
|
proc ::hdb::set_subtree_props {st_name klass {control "true"} {privilege "user"} } {
|
|
publish $st_name mugger
|
|
sicslist setatt $st_name klass $klass
|
|
sicslist setatt $st_name control $control
|
|
sicslist setatt $st_name privilege $privilege
|
|
sicslist setatt $st_name kind "hdb_subtree"
|
|
sicslist setatt $st_name long_name "@none"
|
|
sicslist setatt $st_name data "true"
|
|
sicslist setatt $st_name nxsave "true"
|
|
}
|
|
|
|
# @brief Add a subtree to a given hipadaba path.
|
|
#
|
|
# @param hpath, Basepath for subtree
|
|
# @param object, SICS object name
|
|
# @param subtree, A nested Tcl list which represents the subtree
|
|
# @param type, the SICS object type if we are adding SICS object node. Optional, default = @none.
|
|
# @param makenode, type of node to make. Optional, default = @none.
|
|
proc ::hdb::add_subtree {hpath subtree {object @none} {type @none} {makenode @none}} {
|
|
set ::errorInfo ""
|
|
set SICStypes {sicsvariable macro}
|
|
if [catch {
|
|
switch $makenode {
|
|
"@none" {
|
|
foreach {n v} $subtree {
|
|
if {[lsearch -exact $::nexus_classes $n] >= 0} {
|
|
add_subtree $hpath $v $object $n NXclass
|
|
} elseif {[lsearch -exact $SICStypes $n] >= 0} {
|
|
add_subtree $hpath $v $object $n sicsobject
|
|
} elseif {$n=="link"} {
|
|
add_subtree $hpath $v $object $n link
|
|
} else {
|
|
error "ERROR:Unknown type, '$n'"
|
|
}
|
|
}
|
|
}
|
|
"NXclass" {
|
|
foreach {item val} $subtree {
|
|
add_hpath $hpath $item
|
|
hsetprop $hpath/$item klass $type
|
|
add_subtree $hpath/$item $val $object
|
|
}
|
|
}
|
|
"sicsobject" {
|
|
foreach item $subtree {
|
|
if {$item==$object} {
|
|
error "ERROR: Infinite recursion, cannot add $item as a node to it's own hdb subtree"
|
|
}
|
|
set objtype [getatt $item type]
|
|
if {$type != $objtype} {
|
|
error "ERROR: Specified type of '$type' doesn't match actual type, '$objtype', for $item"
|
|
}
|
|
sobjadd $hpath $item
|
|
}
|
|
}
|
|
"link" {
|
|
set target [::utility::tabget subtree target]
|
|
set nxalias [::utility::tabget subtree nxalias]
|
|
foreach l $nxalias t $target {
|
|
set refname [normalgetatt $t long_name]
|
|
::hdb::add_hpath $hpath $refname
|
|
hsetprop $hpath/$refname data "true"
|
|
hsetprop $hpath/$refname nxsave "false"
|
|
hsetprop $hpath/$refname control "false"
|
|
|
|
hsetprop $hpath/$refname link $t
|
|
hsetprop $hpath/$refname nxalias ${l}_link
|
|
hsetprop $hpath/$refname type nxvgroup
|
|
hsetprop $hpath/$refname klass @none
|
|
}
|
|
}
|
|
default {
|
|
error "ERROR: Unknown node type, $makenode"
|
|
}
|
|
}
|
|
} message ] {
|
|
if {$::errorCode=="NONE"} {return $hpath}
|
|
return -code error $message
|
|
}
|
|
}
|
|
##
|
|
# @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 catch_status [ catch {
|
|
set parent $basePath
|
|
foreach {key} [hlistprop $basePath tclnames] {
|
|
array set prop_arr [list $key "[hgetpropval $basePath $key]"]
|
|
}
|
|
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
|
|
} message ]
|
|
handle_exception $catch_status $message
|
|
}
|
|
|
|
##
|
|
# @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} [::utility::normalattlist $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
|
|
variable sobjadd_state
|
|
|
|
array unset arg_array
|
|
set catch_status [ catch {
|
|
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 [::utility::normalattlist $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 {
|
|
set hobj_long_name [normalgetatt $node_name long_name]
|
|
hattach $basePath $node_name $hobj_long_name
|
|
set node_path $basePath/$hobj_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 mutable [getatt $node_name mutable]
|
|
hsetprop $node_path klass [getatt $node_name klass]
|
|
if [info exists attribute(hdbchain)] {
|
|
foreach pmot [split $attribute(hdbchain) ,] {
|
|
hchain $node_path [lindex [split [getatt $pmot hdb_path] ,] 0]
|
|
}
|
|
}
|
|
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 - getset {
|
|
# A r/w pair of scripts, node = a node path
|
|
set node_path $basePath/[normalgetatt $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 [getatt $node_name data]
|
|
hsetprop $node_path control [getatt $node_name control]
|
|
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 [normalgetatt $node_name units]
|
|
}
|
|
if {[info exists arg_array(prop_list)]} {
|
|
foreach {prop pval} $arg_array(prop_list) {
|
|
hsetprop $node_path $prop $pval
|
|
}
|
|
}
|
|
if {[info exists attribute(depends)]} {
|
|
foreach dep [split [normalgetatt $node_name depends] , ] {
|
|
set sobjadd_state(depends) true
|
|
::hdb::sobjadd $node_path $dep
|
|
set sobjadd_state(depends) false
|
|
}
|
|
}
|
|
if { $sobjadd_state(depends) == false && [info exists attribute(hdb_path)] } {
|
|
sicslist setatt $node_name hdb_path $attribute(hdb_path),$node_path
|
|
} else {
|
|
sicslist setatt $node_name hdb_path $node_path
|
|
}
|
|
return $node_path
|
|
}
|
|
} message ]
|
|
handle_exception $catch_status $message
|
|
}
|
|
|
|
##
|
|
# @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
|
|
}
|
|
}
|
|
set hcom_long_name [normalgetatt $command long_name]
|
|
hcommand $basePath/$hcom_long_name $command
|
|
set cmd_path $basePath/$hcom_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)
|
|
hsetprop $cmd_path sicsdev $cmd_atts(id)
|
|
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} {
|
|
if [ catch {
|
|
foreach att [tolower_sicslist $sicsobj] {
|
|
lappend atts [split [string range $att 0 end-1] =]
|
|
}
|
|
return [join $atts]
|
|
} message ] {
|
|
if {$::errorCode=="NONE"} {return $message}
|
|
return -code error $message
|
|
}
|
|
}
|
|
|
|
|
|
##
|
|
# @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
|
|
set catch_status [ catch {
|
|
array set sobjatt [attlist $sobj]
|
|
if {[sicslist exists $sobj id] == false} {
|
|
sicslist setatt $sobj id $sobj
|
|
}
|
|
switch $sobjatt(type) {
|
|
motor - configurablevirtualmotor - tasmot {
|
|
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 [normalgetatt $sobj 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)] >= 0} {
|
|
clientput "ERROR: $hpath/$sobjatt(long_name) for $sobj exists" error
|
|
} elseif {$sobjatt(kind) == "hdb_subtree"} {
|
|
add_subtree $hpath [$sobj]
|
|
} else {
|
|
set node_path [add_node $hpath kind $sobjatt(kind) node $sobj priv $sobjatt(privilege) ]
|
|
if [info exists sobjatt(mutable)] {
|
|
if {[catch {hsetprop $node_path mutable $sobjatt(mutable)} err]} {clientput $err error}
|
|
}
|
|
}
|
|
}
|
|
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 [normalgetatt $sobj 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 [normalgetatt $sobj 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
|
|
}
|
|
}
|
|
chopperadapter {
|
|
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 [normalgetatt $sobj 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
|
|
}
|
|
}
|
|
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"
|
|
}
|
|
# TODO Can this be replaced with a sct_* glob?
|
|
sct_object {
|
|
set node_name [normalgetatt $sobj long_name]
|
|
set node_path $hpath/$node_name
|
|
hfactory $node_path link $sobj
|
|
hsetprop $node_path type $sobjatt(type)
|
|
sicslist setatt $sobj hdb_path $node_path
|
|
}
|
|
environment_controller {
|
|
todo_msg "$sobjatt(type) case, add $sobj to $hpath"
|
|
}
|
|
default {
|
|
error "ERROR: Unknown sics object type $sobjatt(type)"
|
|
}
|
|
}
|
|
} message ]
|
|
handle_exception $catch_status $message
|
|
}
|
|
proc ::hdb::write_poll {pollnode val} {
|
|
hsetprop $pollnode poll_interval $val
|
|
sicspoll intervall $pollnode $val
|
|
}
|
|
proc ::hdb::read_poll {pollnode} {
|
|
return [getatt $pollnode]
|
|
}
|
|
|
|
##
|
|
# @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} {
|
|
set catch_status [ catch {
|
|
foreach {sobj} [sobjlist $sobjtype $given_klass] {
|
|
array unset sobjatt
|
|
array set sobjatt [attlist $sobj]
|
|
if {[info exists sobjatt(privilege)] && $sobjatt(privilege) != "internal"} {
|
|
sobjadd $hpath $sobj
|
|
}
|
|
}
|
|
} message ]
|
|
handle_exception $catch_status $message
|
|
}
|
|
|
|
|
|
##
|
|
# @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
|
|
foreach {n v} $dict {
|
|
lappend candidates $n
|
|
}
|
|
# 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] >= 0} {
|
|
# 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
|
|
set tempdict ""
|
|
foreach {n v} $dict {
|
|
if {$n != $name} {
|
|
lappend tempdict $n
|
|
lappend tempdict $v
|
|
}
|
|
}
|
|
set dict $tempdict
|
|
} else {
|
|
if {[lsearch $candidates $name/*] >= 0} {
|
|
lappend new_candidates $name
|
|
}
|
|
}
|
|
}
|
|
}
|
|
set candidates $new_candidates
|
|
}
|
|
return
|
|
}
|
|
|
|
proc ::hdb::alias {parent linkpath NXtarget name } {
|
|
set catch_status [ catch {
|
|
if {$NXtarget != "data_set"} {
|
|
return -code error "Unhandled target alias $NXtarget"
|
|
}
|
|
hfactory $parent/$name alias $linkpath
|
|
} message ]
|
|
handle_exception $catch_status $message
|
|
}
|
|
|
|
##
|
|
# @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
|
|
set catch_status [ catch {
|
|
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
|
|
}
|
|
}
|
|
}
|
|
foreach node [hmatchprop / permlink *] {
|
|
set plink [hgetpropval $node permlink]
|
|
if {[llength $plink] > 1} {
|
|
set target [lindex $plink 0]
|
|
if {$target == "data_set" && [hgetpropval $node control]} {
|
|
::hdb::alias "/control" $node {*}$plink
|
|
}
|
|
}
|
|
}
|
|
} message ]
|
|
handle_exception $catch_status $message
|
|
}
|
|
|
|
##
|
|
# @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 [ catch {
|
|
if {$hpath != "/"} {
|
|
set hnode $hpath
|
|
if {[hpropexists $hnode data] && [hgetpropval $hnode data] != "false"} {
|
|
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
|
|
}
|
|
}
|
|
} else {
|
|
foreach hp [hlist /] {
|
|
::hdb::set_save /$hp $mode
|
|
}
|
|
}
|
|
} message ] {
|
|
return -code error "([info level 0]) $message"
|
|
}
|
|
}
|
|
|
|
namespace import ::hdb::*
|