3a3b6764ee
One typo and forgetting to clear a temporary variable meant that the list of candidates for removal never shrank while pruning reflectometer/config/motors/sct_batmotor.tcl The beam attenuator is on axis D not A. Also provide statemon feedback, "busy" or "idle" sans/config/velsel/velsel.tcl Update velocity selector parameters for NVS 43 SICS-374 sans/config/velsel/sct_velsel.tcl Set velocity selector identifier script_context_util.tcl Don't override the "klass' attribute, just make sure that it matches the hdb klass property if it's defined. event.h and statemon.c Added statemon BUSY and IDLE events for the scbat because it when it oscillates it's busy doing something. r2875 | ffr | 2010-01-22 20:41:36 +1100 (Fri, 22 Jan 2010) | 18 lines
961 lines
32 KiB
Tcl
961 lines
32 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
|
|
|
|
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
|
|
array set prop_arr [hlistprop $basePath tcllist]
|
|
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 {
|
|
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
|
|
}
|
|
|
|
##
|
|
# @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
|
|
}
|
|
}
|
|
}
|
|
} 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::*
|