e36e9f1146
Reduce log noise by setting iout = eInternal for macros. servlog.c Fixed timestamp in logfiles to get hours. hmm_configuration_common_1.tcl Added ML's mods to wombat config: ie BAT and FAT TABLE attributes and elements for multi-period acquisition and histo-streaming. Fixed "failed lsearch" bug. It's more robust to test for a non-successful lsearch instead of a failed lsearch. nxscripts_common_1.tcl SICS-297 Fixed Saving data series in a scratch file overwrites earlier entries. instdict_specification.tcl Added "scobj" kind and "sct_indexed_motor" sics object type for script context controllers and and objects. hipadaba_configuration_common.tcl Added sct_indexed_motor sics obj type to ::hdb::sobjadd and scobj kind to ::hdb::add_node sct_positmotor_common.tcl Update the index SICS variable when updating the current index value to make sure that the position is saved in the data file. You must now provide the hdb node_name when creating the sct posit motor. mk_sct_positmotor now sets the "param" and "long_name" attributes on the posit motor object util/utility.tcl Added ::utility::set_sct_indexed_motor_attributes to set SICS object attributes required for generating hdb info for an SCT_POSIT_MOTOR nxscript.c Merge the ansto mod to putslab (rev1.7) which adds support for saving unbuffered data from the histmem. sicshipadaba.c This incorporates the patch made to CommandSetCallback in rev1.10 so it can just be copied as is (ie no merge required). WARNING: There are changes to ListHdbNode to handle record separators which may affect us. Disabled sending hdb command start and stop messages because they break gumtree sicshdbfactory.c Disabled sending hdb command start and stop messages because they break gumtree hipadaba_configuration_common.tcl R2.4DEV The sct_posit_motor case of ::hdb::sobjadd is only needed to call add_node with kind=scobj. nxscripts_common_1.tcl R2.4DEV Added ::nexus::scobj::sdsinfo _gen_nxdict now skips nodes with data_type == "none" new util/script_context_util.tcl R2.4DEV Adds ::scobj::hinitprops command to initialise the hdb properties for script context object nodes. sct_positmotor_common.tcl R2.4DEV Use ::scobj::hinitprops utility command to initialise hdb properties on script context object parameter nodes. dynstring.c DynStringReplace should memcopy '\0', otherwise it can get the wrong length for iTextLen. Added DynStringReplaceWithLen to allow initialising a dynstring with char arrays which contain null chars and other non-ascii chars. Useful for read and write buffers in script context. ascon.c AsconRead return NULL for noResponse and AsconFailed otherwise the "result" node gets set with a spurious empty value. scriptcontext.c SctActionHandler only set the "result" node if there really is a reply. sicsobj.c Update from M.K. site_ansto.c Added galil and ordela hvps protocol handlers for scriptcontext. motor_dmc2280.c Allow home parameter to be outside of limits (for KOWARI) hardsup/makefile Added ordela HVPS protocol handler hardsup/sct_orhvpsprot.c New ordela HVPS protocol handler. Retries on NAKs and re-orders pot channels (ie toggles lower two bits). hardsup/sct_velselprot.c Start velocity selector protocol handler. hardsup/sct_galilprot.c Completed galil protocol handler. hipadaba_configuration_common.tcl Add new style SICS objects to hdb tree. instdict_specification.tcl Added scobj to kind list and sct_motor to sics object list. (and some housekeeping) hmm_configuration_common_1.tcl Added ratemaps to simulation. Fixe BAT_TABLE and added PERIOD_INDICES as per Mark Lesha's mods for multi-period acquisition. ratemaps now return float. sct_postimotor_common.tcl Now setting properties on the posit motor object so that it can be automatically added to the hdb tree. hrpd/config/motors/motor_configuration.tcl Fixed simulated msd motor so that it's handle properly in the hdb layer. sans/config/hmm/detector_ordela.tcl Updated the ordela calibration script to use the new sct_orhvpsprop.c script context controller. quokka_configuration.tcl Deleted lines which set the hdb properties for script context posit motors. This is now handled automatically as for other SICS objects. utility.tcl setpos now replaces the motor setpos subcommand. Added functions to set script context object attributes and sct_posit motor attributes. Created hparPath and hsibPath convenience commands for new-style SICS objects. script_context_util.tcl NEW! Adds hinitprops function to initialise the hdb properties for a script context object r2758 | ffr | 2008-12-12 17:53:53 +1100 (Fri, 12 Dec 2008) | 113 lines
954 lines
32 KiB
Tcl
954 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
|
|
# puts "[info level 0]\nCallstack depth = [info level]\nRecursion depth = [expr $level-1]"
|
|
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 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} [::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
|
|
if [ 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]
|
|
}
|
|
}
|
|
scobj {
|
|
set node_path ${basePath}/$node_name
|
|
hfactory $node_path link $node_name
|
|
}
|
|
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 ] {
|
|
if {$::errorCode=="NONE"} {return $message}
|
|
return -code error $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)
|
|
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
|
|
if [ catch {
|
|
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 [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_posit_motor {
|
|
set sobjName [normalgetatt $sobj long_name]
|
|
add_node $hpath node $sobjName long_name $sobjName kind scobj
|
|
}
|
|
environment_controller {
|
|
todo_msg "$sobjatt(type) case, add $sobj to $hpath"
|
|
}
|
|
default {
|
|
error "ERROR: Unknown sics object type $sobjatt(type)"
|
|
}
|
|
}
|
|
} message ] {
|
|
if {$::errorCode=="NONE"} {return $message}
|
|
return -code error $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} {
|
|
if [ 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 ] {
|
|
if {$::errorCode=="NONE"} {return $message}
|
|
return -code error $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
|
|
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] >= 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
|
|
} else {
|
|
if {[lsearch $candidates $name/*] >= 0} {
|
|
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
|
|
if [ 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 ] {
|
|
if {$::errorCode=="NONE"} {return $message}
|
|
return -code error $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 {$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::*
|