Merged new hdb and nexus code.
r2099 | ffr | 2007-07-22 15:23:41 +1000 (Sun, 22 Jul 2007) | 2 lines
This commit is contained in:
Ferdi Franceschini
committed by
Douglas Clowes
Douglas Clowes
parent
4e407d0a73
commit
8770acc191
139
site_ansto/instrument/util/command.tcl
Normal file
139
site_ansto/instrument/util/command.tcl
Normal file
@@ -0,0 +1,139 @@
|
||||
set cmd_prop_list {kind command data false control true klass command nxsave false}
|
||||
set cmd_par_prop_list {kind hobj data false control true nxsave false klass command}
|
||||
|
||||
#Useful for selecting arguments passed to a mapped function
|
||||
|
||||
# type = one of hipadaba types
|
||||
# range restricts type values, maps to the argtype hlist property
|
||||
# command {type:range p1 type:range p2} { ... }
|
||||
proc command {acmdName arglist body} {
|
||||
global cmd_prop_list cmd_par_prop_list
|
||||
set NS [uplevel namespace current]
|
||||
set cmdName ${NS}::$acmdName
|
||||
variable ${cmdName}_param_list
|
||||
variable ${cmdName}_feedback_list
|
||||
if {[info exists ${cmdName}_param_list]} {
|
||||
unset ${cmdName}_param_list
|
||||
}
|
||||
if {[info exists ${cmdName}_feedback_list]} {
|
||||
unset ${cmdName}_feedback_list
|
||||
}
|
||||
# puts "cmdName: $cmdName"
|
||||
foreach {type_spec var} $arglist {
|
||||
lappend params $var
|
||||
foreach {type domain} [split $type_spec :] {}
|
||||
lappend ${cmdName}_param_list $var ${cmdName}_par_$var
|
||||
set sicsvar [lindex [set ${cmdName}_param_list] end]
|
||||
# Make var with priv=user so we can use sicslist on it
|
||||
VarMake $sicsvar $type user
|
||||
# Set privilege internal to stop hdb builder adding it to hdb tree
|
||||
sicslist setatt $sicsvar privilege internal
|
||||
#FIXME Can argtype be replace with 'domain' then we setatt domain $domain
|
||||
if {$domain == ""} {
|
||||
sicslist setatt $sicsvar argtype $type
|
||||
} else {
|
||||
if {$type == "text"} {
|
||||
if {[string first , $domain] == -1} {
|
||||
sicslist setatt $sicsvar argtype $domain
|
||||
} else {
|
||||
sicslist setatt $sicsvar argtype $type
|
||||
sicslist setatt $sicsvar values $domain
|
||||
}
|
||||
} else {
|
||||
sicslist setatt $sicsvar argtype $type
|
||||
foreach {min max} [split $domain ,] {}
|
||||
sicslist setatt $sicsvar min $min
|
||||
sicslist setatt $sicsvar max $max
|
||||
}
|
||||
}
|
||||
sicslist setatt $sicsvar long_name $var
|
||||
foreach {att val} $cmd_par_prop_list {
|
||||
sicslist setatt $sicsvar $att $val
|
||||
}
|
||||
}
|
||||
set options {
|
||||
set __cmdinfo [info level 0]
|
||||
set __cmd [lindex $__cmdinfo 0]
|
||||
variable ${__cmd}_param_list
|
||||
switch -- [lindex $args 0] {
|
||||
-map {
|
||||
switch [lindex $args 1] {
|
||||
"param" {
|
||||
foreach {__var __param} [set ${__cmd}_param_list] {
|
||||
eval [lindex $args 2] [lrange $args 3 end] $__param $__var
|
||||
}
|
||||
return
|
||||
}
|
||||
"feedback" {
|
||||
if {[info exists ${__cmd}_feedback_list] != 1} {
|
||||
return
|
||||
}
|
||||
foreach {__var __fbvar} [set ${__cmd}_feedback_list] {
|
||||
eval [lindex $args 2] [lrange $args 3 end] $__fbvar $__var
|
||||
}
|
||||
return
|
||||
}
|
||||
}
|
||||
}
|
||||
-list {
|
||||
switch [lindex $args 1] {
|
||||
"param" {
|
||||
return [set ${__cmd}_param_list]
|
||||
}
|
||||
"feedback" {
|
||||
return [set ${__cmd}_feedback_list]
|
||||
}
|
||||
}
|
||||
}
|
||||
-set {
|
||||
if {[lindex $args 1] == "feedback"} {
|
||||
set __vname [lindex $args 2]
|
||||
set __ptype fb
|
||||
if {[llength $args] > 3} {
|
||||
set __val [lindex $args 3]
|
||||
}
|
||||
} else {
|
||||
set __vname [lindex $args 1]
|
||||
set __ptype par
|
||||
if {[llength $args] > 2} {
|
||||
set __val [lindex $args 2]
|
||||
}
|
||||
}
|
||||
if {[llength [sicslist ${__cmd}_${__ptype}_${__vname}]] == 0} {
|
||||
error_msg "${__cmd}_${__ptype}_${__vname} doesnt exist"
|
||||
return
|
||||
}
|
||||
if {[info exists __val]} {
|
||||
${__cmd}_${__ptype}_${__vname} $__val
|
||||
return
|
||||
} else {
|
||||
return [SplitReply [${__cmd}_${__ptype}_${__vname}]]
|
||||
}
|
||||
}
|
||||
-addfb {
|
||||
foreach {__type __var} [lrange $args 1 end] {
|
||||
set __sicsvar ${__cmd}_fb_${__var}
|
||||
VarMake $__sicsvar $__type user
|
||||
sicslist setatt $__sicsvar privilege internal
|
||||
sicslist setatt $__sicsvar control true
|
||||
sicslist setatt $__sicsvar data false
|
||||
sicslist setatt $__sicsvar nxsave false
|
||||
sicslist setatt $__sicsvar klass @none
|
||||
lappend ${__cmd}_feedback_list $__var $__sicsvar
|
||||
}
|
||||
return
|
||||
}
|
||||
}
|
||||
}
|
||||
# The foreach loop initialises the parameters for the command body
|
||||
# The 'if' statement makes sure that the SICS 'parameter' variables are only
|
||||
# updated if they change.
|
||||
proc $cmdName {args} [subst -nocommands {$options foreach n {$params} v \$args {set \$n \$v; if {\$v != [SplitReply [${cmdName}_par_\$n]]} {debug_msg "set ${cmdName}_par_\$n \$v"; ${cmdName}_par_\$n \$v}}; $body }]
|
||||
publish $cmdName user
|
||||
sicslist setatt $cmdName long_name $acmdName
|
||||
sicslist setatt $cmdName privilege user
|
||||
sicslist setatt $cmdName group [string map {:: ""} $NS]
|
||||
foreach {att val} $cmd_prop_list {
|
||||
sicslist setatt $cmdName $att $val
|
||||
}
|
||||
}
|
||||
107
site_ansto/instrument/util/extra_utility.tcl
Normal file
107
site_ansto/instrument/util/extra_utility.tcl
Normal file
@@ -0,0 +1,107 @@
|
||||
# Many of these functions are also useful in test and debug code
|
||||
# running on an external Tcl interpreter.
|
||||
|
||||
# LIST FUNCTIONS
|
||||
proc head {args} {lindex [join $args] 0}
|
||||
proc tail {args} {join [lrange [join $args] 1 end]}
|
||||
|
||||
# SET FUNCTIONS
|
||||
|
||||
# Set membership
|
||||
proc setmem {el A} {
|
||||
expr {[lsearch $A $el] >= 0}
|
||||
}
|
||||
|
||||
# Set difference: A\B, members of A that are not in B
|
||||
proc setdiff {A B} {
|
||||
foreach el $A {
|
||||
if {[lsearch -exact $B $el] == -1} {
|
||||
lappend missing $el;
|
||||
}
|
||||
}
|
||||
if {[info exists missing]} {
|
||||
return $missing;
|
||||
}
|
||||
}
|
||||
|
||||
proc _intersection {lista listb} {
|
||||
set result {}
|
||||
foreach elem [join $listb] {
|
||||
if { [lsearch -exact $lista $elem] != -1 } {
|
||||
lappend result $elem
|
||||
}
|
||||
}
|
||||
return $result
|
||||
}
|
||||
|
||||
proc intersection {lista args} {
|
||||
if {[llength $args] == 0} {return $lista}
|
||||
if {[llength $args] == 1} {return [_intersection $lista $args]}
|
||||
return [intersection [_intersection $lista [head $args]] [tail $args]];
|
||||
}
|
||||
|
||||
|
||||
# TYPE CHECKING
|
||||
# This is an enhanced set membership function.
|
||||
# It can check that an element is a member of a list or
|
||||
# of a named type
|
||||
proc isoneof {element setb} {
|
||||
global simpleType;
|
||||
set result 0;
|
||||
|
||||
foreach elb $setb {
|
||||
switch $elb {
|
||||
alpha {set result [string is alpha $element]}
|
||||
text {set result [string is wordchar $element]}
|
||||
print {set result [string is print $element]}
|
||||
float {set result [string is double $element]}
|
||||
int {set result [string is integer $element]}
|
||||
default {set result [expr {$element == $elb}]}
|
||||
}
|
||||
if {$result == 1} {return 1}
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
# Returns 'sicslist' output in lower case, this may be useful in macros.
|
||||
# This function is used a lot in the hdbbuilder
|
||||
proc tolower_sicslist {args} {
|
||||
set result [eval sicslist $args]
|
||||
return [string tolower $result];
|
||||
}
|
||||
|
||||
# You can use debug_msg in place of 'puts' for debug info in Tcl macros.
|
||||
# debug on, turns on debugging
|
||||
# debug off, turns off debugging
|
||||
proc debug_mode {mode} {
|
||||
switch $mode {
|
||||
on {
|
||||
proc debug_msg {args} {
|
||||
set cmdinfo [info level -1]
|
||||
set cmd [lindex $cmdinfo 0]
|
||||
set arglist [lrange $cmdinfo 1 end]
|
||||
clientput "DEBUG:$args> [namespace origin $cmd] $arglist"
|
||||
}
|
||||
}
|
||||
off {
|
||||
proc debug_msg {args} {};
|
||||
}
|
||||
}
|
||||
}
|
||||
proc debug_msg {args} {};
|
||||
publish debug_mode mugger
|
||||
sicslist setatt debug_mode privilege internal
|
||||
|
||||
proc todo_msg {args} {
|
||||
set cmdinfo [info level -1]
|
||||
set cmd [lindex $cmdinfo 0]
|
||||
set arglist [lrange $cmdinfo 1 end]
|
||||
clientput "TODO:$args> [namespace origin $cmd] $arglist"
|
||||
}
|
||||
|
||||
proc error_msg {args} {
|
||||
set cmdinfo [info level -1]
|
||||
set cmd [lindex $cmdinfo 0]
|
||||
set arglist [lrange $cmdinfo 1 end]
|
||||
clientput "ERROR: [namespace origin $cmd] $arglist: $args" error
|
||||
}
|
||||
@@ -1,10 +1,18 @@
|
||||
# Some useful functions for SICS configuration.
|
||||
|
||||
# $Revision: 1.3 $
|
||||
# $Date: 2007-04-20 01:53:31 $
|
||||
# $Revision: 1.4 $
|
||||
# $Date: 2007-07-22 05:23:41 $
|
||||
# Author: Ferdi Franceschini (ffr@ansto.gov.au)
|
||||
# Last revision by $Author: ffr $
|
||||
|
||||
source util/extra_utility.tcl
|
||||
source util/command.tcl
|
||||
|
||||
# Returns attribute name and value
|
||||
proc getatt {sicsobj att} {
|
||||
lindex [split [tolower_sicslist $sicsobj $att] =] 1
|
||||
}
|
||||
|
||||
# Utility fucntion for setting the home and upper and lower
|
||||
# limits for a motor
|
||||
proc setHomeandRange {args} {
|
||||
@@ -47,8 +55,6 @@ proc setpos {motor pos} {
|
||||
set newZero [expr $currPos - $pos + $oldZero]
|
||||
uplevel #0 "$motor softzero $newZero"
|
||||
}
|
||||
publish setpos user
|
||||
publish SplitReply user
|
||||
|
||||
proc getinfo {object} {
|
||||
set wc [format "%s_*" $object];
|
||||
@@ -59,4 +65,152 @@ proc getinfo {object} {
|
||||
}
|
||||
}
|
||||
}
|
||||
publish getinfo spy
|
||||
|
||||
|
||||
# Convenience function for setting klass group and name attributes
|
||||
# on sics object metadata
|
||||
proc set_sicsobj_atts {sobj aklass agroup aname acontrol adata} {
|
||||
sicslist setatt $sobj klass $aklass;
|
||||
if {$agroup != "@none"} {
|
||||
sicslist setatt $sobj group $agroup;
|
||||
}
|
||||
sicslist setatt $sobj long_name $aname;
|
||||
sicslist setatt $sobj control $acontrol;
|
||||
sicslist setatt $sobj data $adata;
|
||||
}
|
||||
|
||||
## TODO put all the utility macros in the utility namespace
|
||||
namespace eval utility {
|
||||
namespace export instname;
|
||||
variable instrument_name;
|
||||
set instrument_name "";
|
||||
|
||||
# Convenience command for getting unadorned instrument name
|
||||
proc instname {} {
|
||||
variable instrument_name;
|
||||
set instrument_name [SplitReply [instrument]];
|
||||
proc ::utility::instname {} {
|
||||
variable instrument_name;
|
||||
return $instrument_name;
|
||||
}
|
||||
return $instrument_name;
|
||||
}
|
||||
|
||||
# Initialise the attributes of sobj
|
||||
# to make it ready for adding to the hdb tree.
|
||||
proc mkData {sobj name aklass args} {
|
||||
sicslist setatt $sobj long_name $name
|
||||
sicslist setatt $sobj nxalias $sobj
|
||||
sicslist setatt $sobj klass $aklass
|
||||
switch [getatt $sobj type] {
|
||||
"sicsvariable" {
|
||||
sicslist setatt $sobj kind hobj
|
||||
sicslist setatt $sobj data true
|
||||
sicslist setatt $sobj control true
|
||||
sicslist setatt $sobj nxsave true
|
||||
sicslist setatt $sobj privilege internal
|
||||
sicslist setatt $sobj mutable false
|
||||
}
|
||||
default {
|
||||
error "ERROR [info level -1] -> [info level 0]"
|
||||
}
|
||||
}
|
||||
array set attval $args
|
||||
foreach att {kind data control nxsave privilege nxalias mutable} {
|
||||
if {[info exists attval($att)]} {
|
||||
sicslist setatt $sobj $att $attval($att)
|
||||
}
|
||||
}
|
||||
}
|
||||
# Sets the privilege attribute when making a SICS variable
|
||||
# access = spy, user, manager, internal, readonly
|
||||
proc mkVar {name type access {along_name x} {anxsave x} {aklass x} {acontrol x} {adata x}} {
|
||||
array set sicsAccess {spy spy user user manager mugger internal internal readonly internal}
|
||||
VarMake $name $type $sicsAccess($access);
|
||||
sicslist setatt $name privilege $access;
|
||||
sicslist setatt $name kind hobj;
|
||||
sicslist setatt $name mutable false
|
||||
if {$access != "internal"} {
|
||||
sicslist setatt $name data $adata
|
||||
sicslist setatt $name control $acontrol
|
||||
sicslist setatt $name nxsave $anxsave
|
||||
sicslist setatt $name klass $aklass
|
||||
sicslist setatt $name long_name $along_name
|
||||
}
|
||||
}
|
||||
|
||||
proc about {option args} {
|
||||
return [info $option $args];
|
||||
}
|
||||
}
|
||||
|
||||
namespace import ::utility::*;
|
||||
Publish getinfo spy
|
||||
Publish setpos user
|
||||
Publish SplitReply user
|
||||
Publish instname user
|
||||
|
||||
proc debug {args} {
|
||||
clientput $args
|
||||
}
|
||||
proc echo {args} {
|
||||
clientput $args
|
||||
}
|
||||
|
||||
proc ::utility::set_sobj_attributes {} {
|
||||
sicslist setatt getinfo privilege internal
|
||||
sicslist setatt setpos privilege internal
|
||||
sicslist setatt SplitReply privilege internal
|
||||
sicslist setatt instname privilege internal
|
||||
}
|
||||
|
||||
proc ::utility::set_histomem_attributes {} {
|
||||
foreach hm [sicslist type histmem] {
|
||||
sicslist setatt $hm nxalias $hm
|
||||
sicslist setatt $hm mutable true
|
||||
}
|
||||
}
|
||||
proc ::utility::set_motor_attributes {} {
|
||||
# Bug: SICS-57 on Jira
|
||||
# The first entry in [sicslist type motor] is 'motor' when
|
||||
# we run the sicslist command on initialisation. This is because
|
||||
# The 'Motor' command has type motor, so we skip it with lrange.
|
||||
foreach m [lrange [sicslist type motor] 1 end] {
|
||||
sicslist setatt $m kind hobj
|
||||
sicslist setatt $m data true
|
||||
sicslist setatt $m control true
|
||||
sicslist setatt $m nxsave true
|
||||
sicslist setatt $m mutable true
|
||||
sicslist setatt $m units [SplitReply [$m units]]
|
||||
sicslist setatt $m long_name [SplitReply [$m long_name]]
|
||||
set mpart [split [SplitReply [$m part] ] .]
|
||||
sicslist setatt $m klass [lindex $mpart 0]
|
||||
if {[llength $mpart] == 2} {
|
||||
sicslist setatt $m group [lindex $mpart 1]
|
||||
}
|
||||
sicslist setatt $m nxalias $m
|
||||
switch [expr int([SplitReply [$m accesscode]])] {
|
||||
0 {sicslist setatt $m privilege internal}
|
||||
1 {sicslist setatt $m privilege manager}
|
||||
2 {sicslist setatt $m privilege user}
|
||||
3 {sicslist setatt $m privilege spy}
|
||||
}
|
||||
}
|
||||
foreach m [sicslist type configurablevirtualmotor] {
|
||||
sicslist setatt $m kind hobj
|
||||
sicslist setatt $m data true
|
||||
sicslist setatt $m control true
|
||||
sicslist setatt $m nxsave true
|
||||
sicslist setatt $m privilege user
|
||||
sicslist setatt $m nxalias $m
|
||||
sicslist setatt $m mutable true
|
||||
}
|
||||
}
|
||||
|
||||
# Retuns plain value of hdb node property
|
||||
proc ::utility::hgetplainprop {hpath prop} {
|
||||
return [string trim [lindex [split [hgetprop $hpath $prop] =] 1] ]
|
||||
}
|
||||
proc ::utility::hlistplainprop {hpath} {
|
||||
return [string trim [join [split [hlistprop $hpath] =] ]]
|
||||
}
|
||||
|
||||
Reference in New Issue
Block a user