888 lines
19 KiB
Tcl
888 lines
19 KiB
Tcl
# config commands
|
|
|
|
namespace eval stdConfig {
|
|
}
|
|
|
|
namespace eval stdSct {
|
|
}
|
|
|
|
proc stdConfig::make args {
|
|
scanargs $args arg -driver -name -ctrl 0 -base / -port 0 -permanent 0 -args
|
|
|
|
variable driver $arg(driver)
|
|
variable name $arg(name)
|
|
variable base $arg(base)
|
|
variable hostport $arg(port)
|
|
variable makeargs $arg(args)
|
|
variable permanent $arg(permanent)
|
|
# permanent=0: object to be registered in obj_list
|
|
# therefore removed with samenv none
|
|
# permanent=1: object created in init file
|
|
# no need to register make command in status file
|
|
# permanent=2: object created on demand, persistent, removed only explicitly
|
|
|
|
if {[string equal 0 $arg(ctrl)]} {
|
|
variable ctrl _$name
|
|
} else {
|
|
variable ctrl $arg(ctrl)
|
|
}
|
|
if {[llength [info procs ${driver}]] == 0} {
|
|
# this is not needed when make is called from makenv, but on startup, when
|
|
# executing a creationCommand
|
|
source_sct_driver $driver
|
|
}
|
|
set cmd [linsert $makeargs 0 $driver]
|
|
# clientput "MCMD: $cmd"
|
|
if {[catch {set des [eval $cmd]} msg]} {
|
|
clientput "ERROR: calling stdConfig::$cmd:"
|
|
clientput $msg
|
|
return
|
|
}
|
|
if {$permanent == 0} {
|
|
desc_env makeitem $name $des
|
|
obj_list makeitem $name $des
|
|
obj_dependencies makeitem $name $ctrl
|
|
}
|
|
put_secop_info $base$name
|
|
}
|
|
|
|
proc stdConfig::controllerDesc {desc} {
|
|
variable ctrl
|
|
variable permanent
|
|
if {$permanent == 0} {
|
|
obj_list makeitem $ctrl $desc
|
|
desc_env makeitem $ctrl $desc
|
|
}
|
|
}
|
|
|
|
proc stdConfig::controller {{prot std} args} {
|
|
variable driver
|
|
variable ctrl
|
|
variable node
|
|
variable resolution 5
|
|
variable fastperiod 5
|
|
variable slowperiod 10
|
|
variable hostport
|
|
variable permanent
|
|
|
|
if {[lindex $args 0] eq "without_connection" || $prot eq "syncedprot"} {
|
|
set hostport without_connection
|
|
}
|
|
set node /sics/$ctrl
|
|
if {$hostport eq "0"} {
|
|
set hostport [silent 0 result cfg_env $ctrl]
|
|
if {$hostport eq "without_connection" || $hostport eq "0"} {
|
|
set hostport unconnected:0
|
|
}
|
|
}
|
|
if {[string index $hostport 0] eq "@"} {
|
|
if {[sicsdescriptor alias_hostport] eq "notfound"} {
|
|
makeobject alias_hostport array
|
|
}
|
|
alias_hostport makeitem $ctrl $hostport
|
|
set hostport [silent 0 result cfg_env $hostport]
|
|
if {[string equal 0 $hostport]} {
|
|
set hostport unconnected:0
|
|
}
|
|
} else {
|
|
catch {alias_hostport deleteitem $ctrl}
|
|
}
|
|
if {"$hostport" eq "undefined"} {
|
|
set hostport $ctrl
|
|
}
|
|
set makecmd [concat makesctcontroller $ctrl $prot $hostport $args]
|
|
# clientput "MSCT: $makecmd"
|
|
if {[string equal SctController [sicsdescriptor $ctrl]]} {
|
|
set _makecmd [hgetpropval $node _makecmd]
|
|
hsetprop $node _makecmd $makecmd
|
|
set makecmd [hgetpropval $node _makecmd]
|
|
if {! [string equal $makecmd $_makecmd]} {
|
|
hsetprop $node _makecmd $_makecmd
|
|
error "shared controllers do not match\n(a) $_makecmd\n(b) $makecmd"
|
|
}
|
|
return 0
|
|
}
|
|
eval $makecmd
|
|
|
|
prop _makecmd $makecmd
|
|
prop idn ""
|
|
prop tasksPath $node/tasks
|
|
prop state idle
|
|
prop read stdSct::read
|
|
prop update stdSct::update
|
|
prop write stdSct::write
|
|
prop complete stdSct::completeUpdate
|
|
prop commerror stdSct::errorScript
|
|
set reconnect_script "$ctrl queue /sics/$ctrl/tasks start stdSct::prestart"
|
|
prop reconnect_script $reconnect_script
|
|
logsetup /sics/$ctrl 1
|
|
|
|
set node /sics/$ctrl/tasks
|
|
hfactory $node plain user none
|
|
prop sync stdSct::sync
|
|
prop start stdSct::start
|
|
prop complete stdSct::completeStart
|
|
eval $reconnect_script
|
|
|
|
if {$permanent == 0} {
|
|
obj_list makeitem $ctrl "$driver controller"
|
|
desc_env makeitem $ctrl "$driver controller"
|
|
}
|
|
set node /sics/$ctrl
|
|
return 1
|
|
}
|
|
|
|
proc stdSct::prestart {} {
|
|
catch {
|
|
set hp [[sct controller] hostport]
|
|
set ip [[sct controller] ip]
|
|
hupdate /sics/[sct controller] "$hp ($ip)"
|
|
}
|
|
return start
|
|
}
|
|
|
|
proc stdConfig::pollperiod {fast {slow 0} {res 0}} {
|
|
if {$fast > 0} {
|
|
variable fastperiod $fast
|
|
}
|
|
if {$slow > 0} {
|
|
variable slowperiod $slow
|
|
}
|
|
if {$res > 0} {
|
|
variable resolution $res
|
|
} elseif {$fast > 0} {
|
|
variable resolution $fast
|
|
}
|
|
}
|
|
|
|
proc stdConfig::wr {{period 0} {prio slow} {action read}} {
|
|
variable slowperiod
|
|
variable node
|
|
variable ctrl
|
|
|
|
if {$period == 0} {
|
|
set period $slowperiod
|
|
}
|
|
$ctrl write $node
|
|
poll $period $prio $action
|
|
prop geterror "not read yet"
|
|
prop __save update
|
|
}
|
|
|
|
proc stdConfig::rd {{period 0} {prio read} {action read}} {
|
|
variable fastperiod
|
|
if {$period == 0} {
|
|
set period $fastperiod
|
|
}
|
|
poll $period $prio $action
|
|
}
|
|
|
|
proc stdConfig::upd {} {
|
|
variable ctrl
|
|
variable node
|
|
$ctrl connect $node
|
|
}
|
|
|
|
proc stdConfig::out {} {
|
|
variable ctrl
|
|
variable node
|
|
$ctrl write $node
|
|
prop __save update
|
|
}
|
|
|
|
proc stdConfig::par {value} {
|
|
variable node
|
|
hupdate $node $value
|
|
prop __save update
|
|
}
|
|
|
|
proc stdConfig::treatProps {kind props} {
|
|
variable level
|
|
foreach line [split $props "\n"] {
|
|
append prop $line
|
|
if {[info complete $prop]} {
|
|
prop [uplevel #$level subst [lindex $prop 0]] \
|
|
[uplevel #$level subst [lrange $prop 1 end]
|
|
} else {
|
|
append prop "\n"
|
|
}
|
|
}
|
|
foreach prop $props {
|
|
switch -- $prop
|
|
}
|
|
switch -- $kind {
|
|
wr {}
|
|
rd {}
|
|
upd {}
|
|
out {}
|
|
par {}
|
|
}
|
|
}
|
|
|
|
proc stdConfig::treatArgs {arguments} {
|
|
variable priv undef
|
|
variable type float
|
|
variable nolog
|
|
variable secop_module
|
|
variable cfgcmd [list]
|
|
|
|
if {[llength $arguments] == 3} {
|
|
# check for new syntax (not yet used?)
|
|
switch -- [lindex $arguments 0] {
|
|
none - int - float - text - drive -
|
|
intar - floatar - intvarar - floatvarar -
|
|
object - func {
|
|
set type [lindex $arguments 0]
|
|
treatProps [lindex $arguments 1] [lindex $arguments 2]
|
|
}
|
|
}
|
|
}
|
|
set opt cfg
|
|
set defpriv internal
|
|
set nolog 0
|
|
set secop_module ""
|
|
foreach a $arguments {
|
|
switch -glob -- $a {
|
|
-internal - -spy - -user - -mugger {
|
|
set priv [string range $a 1 end]
|
|
}
|
|
-none - -int - -float - -text -
|
|
-intar - -floatar - -intvarar - -floatvarar -
|
|
-object - -func - -drive {
|
|
set type [string range $a 1 end]
|
|
}
|
|
-nolog {
|
|
set nolog 1
|
|
}
|
|
-secop=* {
|
|
# clientput "SECOP $a"
|
|
set secop_module [string range $a 7 end]
|
|
# clientput "SECOP $secop_module"
|
|
}
|
|
default {
|
|
switch -- $a {
|
|
wr - out - par {
|
|
set defpriv user
|
|
}
|
|
}
|
|
lappend cfgcmd $a
|
|
}
|
|
}
|
|
}
|
|
if {[string equal undef $priv]} {
|
|
set priv $defpriv
|
|
}
|
|
}
|
|
|
|
proc stdConfig::obj {class args} {
|
|
variable name
|
|
variable base
|
|
variable hostport
|
|
variable makeargs
|
|
variable resolution
|
|
variable ctrl
|
|
variable driver
|
|
variable cfgcmd
|
|
variable priv
|
|
variable type
|
|
variable permanent
|
|
|
|
treatArgs $args
|
|
variable objpath $base$name
|
|
variable path $objpath
|
|
variable node $path
|
|
|
|
if {! [info exists ctrl]} {
|
|
error "ctrl must be called before obj"
|
|
}
|
|
|
|
# Layout hdb
|
|
|
|
# set path /$name
|
|
|
|
if {[string equal drive $type]} {
|
|
hfactory $path plain $priv float
|
|
dynsctdriveobj $name $path $class $ctrl
|
|
hsetprop $path sicscommand "run $name"
|
|
} else {
|
|
dynsicsobj $name $class $priv $type
|
|
hfactory $path link $name
|
|
}
|
|
eval $cfgcmd
|
|
|
|
set node $path
|
|
prop objectPath $objpath
|
|
if {$permanent != 1} {
|
|
prop creationCmd "stdConfig::make $driver $name $ctrl $base -port $hostport $makeargs"
|
|
}
|
|
|
|
set node $path/send
|
|
hfactory $node plain user text
|
|
$ctrl write $node
|
|
prop write stdSct::startSend
|
|
prop complete stdSct::completeSend
|
|
prop visible false
|
|
|
|
set node $path/status
|
|
hfactory $node plain internal text
|
|
prop visible false
|
|
hupdate $node ""
|
|
logsetup $path/status 1
|
|
|
|
if {[string equal drive $type]} {
|
|
set node $path/is_running
|
|
hfactory $node plain user int
|
|
prop visible false
|
|
prop check stdSct::setRunning
|
|
prop write stdSct::complete
|
|
$ctrl write $node
|
|
hupdate $node 0
|
|
logsetup $path/is_running 1
|
|
|
|
hsetprop $path updatestatus stdSct::updatestatus_
|
|
}
|
|
|
|
set node $path
|
|
switch $type {
|
|
none - func - object {
|
|
}
|
|
default {
|
|
hsetprop $node secop_module $name
|
|
logsetup $node $resolution
|
|
}
|
|
}
|
|
|
|
if {$permanent == 0} {
|
|
obj_list makeitem $name $class
|
|
desc_env makeitem $name $class
|
|
}
|
|
return 1
|
|
}
|
|
|
|
proc stdConfig::node {name args} {
|
|
variable objpath
|
|
variable path
|
|
variable ctrl
|
|
variable resolution
|
|
variable cfgcmd
|
|
variable priv
|
|
variable type
|
|
variable nolog
|
|
variable secop_module
|
|
|
|
treatArgs $args
|
|
variable node $path/$name
|
|
if {[lindex $cfgcmd 0] eq "alias"} {
|
|
if {[llength $cfgcmd] != 2 || $args ne $cfgcmd} {
|
|
error "Usage: node <node> alias <originalpath>"
|
|
}
|
|
hfactory $node alias [lindex $cfgcmd 1]
|
|
} else {
|
|
hfactory $node plain $priv $type
|
|
if {!$nolog} {
|
|
switch $type {
|
|
float - int {
|
|
hsetprop $node secop_module $secop_module
|
|
logsetup $node $resolution
|
|
}
|
|
text {
|
|
hsetprop $node secop_module $secop_module
|
|
logsetup $node $resolution
|
|
hupdate $node ""
|
|
}
|
|
}
|
|
}
|
|
eval $cfgcmd
|
|
}
|
|
prop objectPath $objpath
|
|
}
|
|
|
|
proc stdConfig::poll {args} {
|
|
variable ctrl
|
|
variable node
|
|
|
|
eval [concat $ctrl poll $node $args]
|
|
}
|
|
|
|
proc stdConfig::default {value} {
|
|
variable node
|
|
if {[silent "" hgetpropval $node enum] ne ""} {
|
|
enum_update $node $value
|
|
} else {
|
|
hupdate $node $value
|
|
}
|
|
hdelprop $node geterror
|
|
}
|
|
|
|
proc stdConfig::kids {{title 0} code} {
|
|
variable path
|
|
variable node
|
|
variable name
|
|
|
|
if {![string equal hidden $title]} {
|
|
if {[string equal 0 $title]} {
|
|
set title $name
|
|
}
|
|
prop group $title
|
|
prop newline 1
|
|
}
|
|
# if {[silent "" hgetpropval $node __save] eq ""} {
|
|
# prop __save kids
|
|
# }
|
|
set oldpath $path
|
|
set path $node
|
|
if {[catch {uplevel 1 $code} msg]} {
|
|
clientput $msg
|
|
}
|
|
set path $oldpath
|
|
}
|
|
|
|
proc stdConfig::prop {prop args} {
|
|
variable node
|
|
eval [concat hsetprop $node $prop $args]
|
|
if {$prop eq "enum"} {
|
|
eval [concat hsetprop $node enum_ $args]
|
|
}
|
|
}
|
|
|
|
#action scripts
|
|
|
|
proc stdSct::sync {} {
|
|
set cmd [silent 0 sct synccmd]
|
|
if {[string equal 0 $cmd]} {
|
|
return start
|
|
}
|
|
sct send $cmd
|
|
sct synccnt 10
|
|
return stdSct::syncComplete
|
|
}
|
|
|
|
proc stdSct::syncComplete {} {
|
|
set sr [silent "" sct syncreply]
|
|
if {$sr ne "" && $sr ne [sct result]} {
|
|
sct send "@@NOSEND@@"
|
|
}
|
|
return start
|
|
}
|
|
|
|
proc stdSct::start {} {
|
|
set cmd [silent 0 sct startcmd]
|
|
if {[string equal 0 $cmd]} {
|
|
return unpoll
|
|
}
|
|
sct send $cmd
|
|
return complete
|
|
}
|
|
|
|
proc stdSct::completeStart {} {
|
|
set idn [eval [silent "sct result" sct convert_idn]]
|
|
if {[string equal [sct idn] $idn]} {
|
|
clientput "[sct sicsdev] resynchronized after comm. error"
|
|
return unpoll
|
|
} elseif {[string length [sct idn]] == 0} {
|
|
sct idn $idn
|
|
clientput "connected [sct sicsdev]. idn: [sct idn]"
|
|
} else {
|
|
clientput "[sct sicsdev]: bad answer to startcmd: [sct result]"
|
|
sct idn ""
|
|
return sync
|
|
}
|
|
return unpoll
|
|
}
|
|
|
|
proc stdSct::startSend {} {
|
|
sct send [sct target]
|
|
return complete
|
|
}
|
|
|
|
proc stdSct::completeSend {} {
|
|
sct print "response = [sct result]"
|
|
sct update "[sct target]"
|
|
return idle
|
|
}
|
|
|
|
proc stdSct::errorScript {} {
|
|
set s [split [sct result] :]
|
|
if {[string match *ERR* [lindex $s 0]]} {
|
|
set s [lreplace $s 0 0]
|
|
}
|
|
set s [join $s :]
|
|
[sct controllerName] poll [sct tasksPath] 1 start sync
|
|
error "$s"
|
|
}
|
|
|
|
proc stdSct::read {} {
|
|
sct send [format [sct readcmd] [silent 0 sct addr]]
|
|
return update
|
|
}
|
|
|
|
proc stdSct::scanf {fmt args} {
|
|
set scan [linsert $args 0 scan [sct result] "${fmt}%n"]
|
|
lappend scan _cnt_
|
|
set res [uplevel 1 "eval {$scan}"]
|
|
if {$res != [llength $args] + 1} {
|
|
error "in command:[sct send]\nbad response: [sct result]\nafter arg $res\nfmt=$fmt"
|
|
}
|
|
}
|
|
|
|
proc stdSct::scanresult {} {
|
|
set readfmt [silent 0 sct readfmt]
|
|
if {$readfmt eq "0"} {
|
|
return [sct result]
|
|
}
|
|
stdSct::scanf [sct readfmt] result
|
|
return $result
|
|
}
|
|
|
|
proc stdSct::update {} {
|
|
sct update [stdSct::scanresult]
|
|
return idle
|
|
}
|
|
|
|
proc stdSct::write {} {
|
|
sct send [format [sct writecmd] [sct target] [silent 0 sct addr]]
|
|
return complete
|
|
}
|
|
|
|
proc stdSct::complete args {
|
|
return idle
|
|
}
|
|
|
|
proc stdSct::completeUpdate args {
|
|
catch {
|
|
sct update [sct requested]
|
|
}
|
|
return idle
|
|
}
|
|
|
|
proc stdSct::setRunning args {
|
|
if {[sct target]} {
|
|
error "can not set running - use run command instead"
|
|
}
|
|
[sct controller] queue [sct parent] halt halt
|
|
}
|
|
|
|
# wait for specified time and block controller before starting script
|
|
proc stdSct::after {delay script} {
|
|
sct _after_count 10
|
|
[sct controller] poll [sct] [expr $delay * 0.1] start "stdSct::afterpoll $script"
|
|
return idle
|
|
}
|
|
|
|
proc stdSct::afterpoll {script} {
|
|
set cnt [sct _after_count]
|
|
incr cnt -1
|
|
if {$cnt < 0} {
|
|
[sct controller] queue [sct] start $script
|
|
return unpoll
|
|
}
|
|
sct _after_count $cnt
|
|
return idle
|
|
}
|
|
|
|
proc stdSct::updatestatus_ {} {
|
|
set is_running [hval [sct]/is_running]
|
|
set run_status "[sct status] [sct writestatus]"
|
|
if {$run_status ne [silent 0 sct prev_run_status]} {
|
|
hupdate [sct]/is_running [expr {[sct writestatus] eq "start" || [sct status] eq "run"}]
|
|
sct prev_run_status $run_status
|
|
}
|
|
}
|
|
|
|
proc wait_node {path {tmo 30}} {
|
|
set start [clock seconds]
|
|
while {[string length [silent "" hgetpropval $path requested]] != 0} {
|
|
if {[clock seconds] > $start + $tmo} {
|
|
return 1
|
|
}
|
|
wait 0.2
|
|
}
|
|
return 0
|
|
}
|
|
|
|
# return the value of a node, or if a write operation is pending, its requested target
|
|
proc sctval {node {default_value 0}} {
|
|
set val [silent $default_value hvali $node]
|
|
return [silent $val hgetpropval $node requested]
|
|
}
|
|
|
|
proc silentval {defval node} {
|
|
set value [hvali $node]
|
|
catch {
|
|
hgetpropval $node geterror
|
|
set value $defval
|
|
}
|
|
return $value
|
|
}
|
|
|
|
# update error and make logger value invalid
|
|
proc updateerror {path error {overwrite 0}} {
|
|
set e [silent 0 hgetpropval $path geterror]
|
|
set val 0
|
|
catch {set val [hvali $path]}
|
|
if {$e eq "0" || $overwrite} {
|
|
hsetprop $path geterror $error
|
|
}
|
|
logsetup $path clear
|
|
hupdate $path $val
|
|
}
|
|
|
|
# update and clear error
|
|
proc updateval {path val} {
|
|
hdelprop $path geterror
|
|
hupdate $path $val
|
|
}
|
|
|
|
# update and clear error, clear log when val = undefvalue
|
|
proc updateval_u {path val undefvalue} {
|
|
if {$val != $undefvalue} {
|
|
hupdate $path $val
|
|
} else {
|
|
if {[hvali $path] != $undefvalue} {
|
|
hupdate $path $undefvalue
|
|
}
|
|
logsetup $path clear
|
|
}
|
|
hdelprop $path geterror
|
|
}
|
|
|
|
# update and set error when val = undefvalue
|
|
proc updateval_e {path val undefvalue error} {
|
|
if {$val != $undefvalue} {
|
|
hupdate $path $val
|
|
hdelprop $path geterror
|
|
} else {
|
|
if {[silent 0 hvali $path] != $undefvalue} {
|
|
hupdate $path $undefvalue
|
|
}
|
|
logsetup $path clear
|
|
hsetprop $path geterror $error
|
|
}
|
|
}
|
|
|
|
proc synceddo {code {timeout 10}} {
|
|
set id [synced begin]
|
|
catch {
|
|
uplevel 1 $code
|
|
}
|
|
synced end $id
|
|
synced wait $id $timeout
|
|
}
|
|
|
|
proc sctsync {code} {
|
|
set id [synced begin]
|
|
uplevel 1 $code
|
|
synced end $id
|
|
sct send $id
|
|
}
|
|
|
|
proc internalset {path value} {
|
|
hsetprop $path internalset 1
|
|
if {[catch {hset $path $value} msg]} {
|
|
hsetprop $path internalset 0
|
|
error $msg
|
|
}
|
|
hsetprop $path internalset 0
|
|
}
|
|
|
|
proc enum_decode {path {input ""} {number_var ""} {name_var ""}} {
|
|
if {$number_var ne ""} {
|
|
upvar $number_var num
|
|
}
|
|
if {$name_var ne ""} {
|
|
upvar $name_var nam
|
|
}
|
|
|
|
if {$input eq ""} {
|
|
set input [hvali $path]
|
|
}
|
|
set idx 0
|
|
set enum [split [hgetpropval $path enum] ,]
|
|
if {$enum eq "1"} {
|
|
set enum [list 0 1]
|
|
}
|
|
foreach e $enum {
|
|
lassign [split $e =] name number
|
|
if {$number eq ""} {
|
|
set number $idx
|
|
} else {
|
|
set idx $number
|
|
}
|
|
incr idx
|
|
set match -1
|
|
foreach el $input {
|
|
set tst [expr {$el eq $name || $el eq $number}]
|
|
if {$match < 0} {
|
|
set match $tst
|
|
} elseif {$match != $tst} {
|
|
error "ERROR: $path: $input ambiguous"
|
|
}
|
|
}
|
|
if {$match > 0} {
|
|
set num $number
|
|
set nam $name
|
|
return
|
|
}
|
|
}
|
|
if {$number_var ne ""} {
|
|
set num $input
|
|
}
|
|
if {$name_var ne ""} {
|
|
set nam $input
|
|
clientput "WARNING: enum_decode: ($path) name in '$input' not found"
|
|
}
|
|
}
|
|
|
|
proc named_enum {{textvar ""}} {
|
|
if {$textvar ne ""} {
|
|
enum_decode [sct] [sct target] num nam
|
|
upvar $textvar tv
|
|
set tv $nam
|
|
} else {
|
|
enum_decode [sct] [sct target] num
|
|
}
|
|
sct target $num
|
|
sct requested $num
|
|
return $num
|
|
}
|
|
|
|
proc enum_val {path} {
|
|
# for compatibility
|
|
return [hvali $path]
|
|
}
|
|
|
|
proc enum_txt {path} {
|
|
set v [hvali $path]
|
|
enum_decode $path $v num nam
|
|
return $nam
|
|
}
|
|
|
|
proc enum_txt_req {path} {
|
|
set v [hvali $path]
|
|
catch {
|
|
set v [sct requested]
|
|
}
|
|
enum_decode $path $v num nam
|
|
return $nam
|
|
}
|
|
|
|
proc enum_update {args} {
|
|
# one argument: value (on this node)
|
|
# two arguments: path value
|
|
if {[llength $args] > 2} {
|
|
error {ERROR: Usage: enum_update [path] value}
|
|
}
|
|
if {[llength $args] == 2} {
|
|
set path [lindex $args 0]
|
|
set input [lindex $args 1]
|
|
} else {
|
|
set path ""
|
|
set input $args
|
|
}
|
|
if {$path eq ""} {
|
|
set ownpath 1
|
|
set path [sct]
|
|
} else {
|
|
set ownpath 0
|
|
}
|
|
if {$input eq ""} {
|
|
set input [hvali $path]
|
|
}
|
|
enum_decode $path $input num
|
|
if {$ownpath} {
|
|
sct update $num
|
|
} else {
|
|
hupdate $path $num
|
|
}
|
|
return
|
|
}
|
|
|
|
proc get_values {path args} {
|
|
foreach name $args {
|
|
set varname [regsub "/" $name "_"]
|
|
upvar $varname $varname
|
|
set $varname [expr double([hvali $path/$name])]
|
|
}
|
|
}
|
|
|
|
proc update_values {path args} {
|
|
foreach name $args {
|
|
set varname [regsub "/" $name "_"]
|
|
upvar $varname $varname
|
|
updateval $path/$name [set $varname]
|
|
}
|
|
}
|
|
|
|
# when value on <path> is updated, its gets updated also on the callers node
|
|
# older links to callers node are removed
|
|
|
|
proc link2me {src} {
|
|
catch {
|
|
if {[silent 0 sct link2me] ne $src} {
|
|
[sct controller] updatescript $src "link2me_update [sct]"
|
|
sct link2me $src
|
|
sct update [hvali $src]
|
|
} elseif {[hvali [sct]] ne [hvali $src]} {
|
|
clientlog "link2me [sct]=[hvali [sct]] but $src=[hvali $src]"
|
|
}
|
|
}
|
|
}
|
|
|
|
proc link2me_update {dest value} {
|
|
if {[silent "" hgetpropval $dest link2me] ne [sct]} {
|
|
[sct controller] killupdatescript [sct] "link2me_update $dest"
|
|
clientlog "link removed: [sct] -> $dest"
|
|
} else {
|
|
updateval $dest $value
|
|
}
|
|
}
|
|
|
|
proc on_update_call {src script {valueproperty value}} {
|
|
if {[catch {
|
|
[sct controller] updatescript $src "on_update_queue [sct] $script $valueproperty"
|
|
if {[silent 1 sct on_update_call_cnt] == 0} {
|
|
sct on_update_call_cnt 99
|
|
}
|
|
} msg]} {
|
|
clientput $msg
|
|
}
|
|
}
|
|
|
|
proc on_update_queue {dest script valueproperty value} {
|
|
# when on_update_call_cnt is present on <dest> node:
|
|
# it is counted down on every call and the script is killed when at 0
|
|
# in order to keep the script alive, on_update_call_cnt should be set
|
|
# to a low value in the script itself
|
|
set cnt [silent none hgetpropval $dest on_update_call_cnt]
|
|
if {$cnt ne "none"} {
|
|
if {$cnt <= 0} {
|
|
[sct controller] killupdatescript $dest "on_update_queue $dest $script $valueproperty"
|
|
return
|
|
}
|
|
hsetprop $dest on_update_call_cnt [expr $cnt - 1]
|
|
}
|
|
hsetprop $dest $valueproperty $value
|
|
[sct controller] queue $dest write $script
|
|
}
|
|
|
|
proc node_cmd args {
|
|
switch [llength $args] {
|
|
0 {
|
|
error "Usage: node_cmd <node> [<name> [<value>]]"
|
|
}
|
|
1 {
|
|
lassign $args node
|
|
return [hval $node]
|
|
}
|
|
2 {
|
|
lassign $args node name
|
|
return [hval $node/$name]
|
|
}
|
|
default {
|
|
set val [lassign $args node name]
|
|
hset $node/$name $val
|
|
return $val
|
|
}
|
|
}
|
|
}
|