2917 lines
70 KiB
Tcl
2917 lines
70 KiB
Tcl
#---------------------------------------------------------------------------
|
|
# sea configuration scripts
|
|
#---------------------------------------------------------------------------
|
|
|
|
if {[sicsdescriptor hvali] eq "notfound"} {
|
|
# replacement for hvali for use with old sics version
|
|
definealias hvali hval
|
|
}
|
|
|
|
global vars
|
|
set vars ""
|
|
|
|
proc publishLazy {command {level User}} {
|
|
set desc [sicsdescriptor $command]
|
|
if {$desc eq "notfound"} {
|
|
Publish $command $level
|
|
} elseif {$desc eq "Macro"} {
|
|
# clientput $command already published
|
|
} else {
|
|
clientput publish will not overwrite $command of type $desc
|
|
}
|
|
}
|
|
|
|
publishLazy publishLazy
|
|
|
|
proc result {cmd args} {
|
|
set res [eval $cmd $args]
|
|
set list [split $res =]
|
|
if {[llength $list] > 1} {
|
|
return [string trim [lindex $list 1]]
|
|
} else {
|
|
return [string trim $res]
|
|
}
|
|
}
|
|
|
|
proc get_num {var args} {
|
|
# used for matlab interface
|
|
if {[string match /* $var]} {
|
|
set cmd "hval $var"
|
|
} elseif {[llength $var] == 1} {
|
|
if {[string match *.* $var]} {
|
|
set second [lassign [split $var .] var]
|
|
} else {
|
|
set second [list ]
|
|
}
|
|
set cmd "result $var [join $second /]"
|
|
switch [sicstype $var] {
|
|
COM - DRIV {
|
|
}
|
|
default {
|
|
set cmd "hval /$var/[join $second /]"
|
|
}
|
|
}
|
|
} else {
|
|
set cmd $var
|
|
}
|
|
if {[catch {set res [eval "$cmd $args"]} msg]} {
|
|
return $msg
|
|
}
|
|
return $res
|
|
}
|
|
|
|
publishLazy get_num spy
|
|
|
|
proc set_num {args} {
|
|
# used for matlab interface
|
|
set value [lindex $args end]
|
|
set var [lrange $args 0 end-1]
|
|
if {[string match /* $var]} {
|
|
set cmd "hset $var $value"
|
|
} elseif {[llength $var] == 1} {
|
|
if {[string match *.* $var]} {
|
|
set second [lassign [split $var .] var]
|
|
} else {
|
|
set second [list ]
|
|
}
|
|
set cmd "$var [join $second /] $value"
|
|
switch [sicstype $var] {
|
|
COM {
|
|
}
|
|
DRIV {
|
|
if {[llength $second] == 0} {
|
|
set cmd "run $var $value"
|
|
}
|
|
}
|
|
default {
|
|
set cmd "hset /$var/[join $second /] $value"
|
|
}
|
|
}
|
|
} else {
|
|
set cmd "$var $value"
|
|
}
|
|
if {![catch {eval $cmd} msg]} {
|
|
return 1
|
|
}
|
|
return $msg
|
|
}
|
|
|
|
publishLazy set_num
|
|
|
|
proc is_busy {{variable "ANY"}} {
|
|
if {$variable eq "ANY"} {
|
|
return [expr {[listexe] ne "Machine Idle"}]
|
|
}
|
|
foreach var [listexe] {
|
|
if {$variable eq $var} {
|
|
return 1
|
|
}
|
|
}
|
|
return 0
|
|
}
|
|
|
|
publishLazy is_busy spy
|
|
|
|
proc wait_for {{variable "ANY"}} {
|
|
while {[is_busy $variable]} {
|
|
wait 0.1
|
|
incr cnt
|
|
if {$cnt > 20} {
|
|
clientput "."
|
|
set cnt 0
|
|
}
|
|
}
|
|
return 1
|
|
}
|
|
|
|
publishLazy wait_for spy
|
|
|
|
proc do_as_manager code {
|
|
if {[result config myrights] == 2} { # user rights -> change to manager
|
|
config rights seamanager seager
|
|
if {[catch {uplevel 1 $code} msg]} {
|
|
clientput "ERROR: in $code:\nERROR: $msg"
|
|
}
|
|
config rights seauser seaser
|
|
} else {
|
|
if {[catch {uplevel 1 $code} msg]} {
|
|
clientput "ERROR: in $code:\nERROR: $msg"
|
|
}
|
|
}
|
|
}
|
|
|
|
proc scanargs {arglist array args} {
|
|
# scans arguments arglist and puts them into the array "array"
|
|
# or into separate variables, when array is "var"
|
|
# the number of elements in args returned, and stored in array(-cnt)
|
|
# formal arguments are given as -<name> [ <default value> ]
|
|
|
|
if {$array ne "var"} {
|
|
upvar $array arg
|
|
}
|
|
|
|
# read formal arguments
|
|
set name ""
|
|
set idx 0
|
|
foreach a $args {
|
|
if {[string match {-[A-Za-z]*} $a]} {
|
|
if {$name ne ""} {
|
|
set values($name) ""
|
|
set done($name) -1
|
|
set names($idx) $name
|
|
incr idx
|
|
}
|
|
set name $a
|
|
} elseif {$name ne ""} {
|
|
set values($name) $a
|
|
set done($name) 0
|
|
set names($idx) $name
|
|
incr idx
|
|
set name ""
|
|
}
|
|
}
|
|
if {$name ne ""} {
|
|
set values($name) ""
|
|
set done($name) -1
|
|
set names($idx) $name
|
|
incr idx
|
|
}
|
|
set nargs $idx
|
|
# clientput $arglist
|
|
# clientput [array get values]
|
|
# clientput [array get names]
|
|
|
|
# read actual arguments
|
|
if {$nargs > 0} {
|
|
set phase 0
|
|
} else {
|
|
set phase 2
|
|
}
|
|
set idx 0
|
|
set argocnt 0
|
|
set argsout [list]
|
|
set name ""
|
|
foreach a $arglist {
|
|
if {$phase > 1} {
|
|
lappend argsout $a
|
|
incr argocnt
|
|
} elseif {[string match {-[A-Za-z]*} $a]} {
|
|
if {$phase == 0} {
|
|
set phase 1
|
|
}
|
|
if {$name ne ""} {
|
|
error "missing value for $name"
|
|
}
|
|
if {![info exists values($a)]} {
|
|
set phase 2
|
|
lappend argsout $a
|
|
incr argocnt
|
|
} else {
|
|
if {$done($a) == 1} {
|
|
error "double argument: $a"
|
|
}
|
|
set name $a
|
|
}
|
|
} else {
|
|
if {$name eq ""} {
|
|
if {$phase == 0 && $idx == $nargs - 1 && $names($idx) eq "-args"} {
|
|
set phase 1
|
|
}
|
|
if {$phase == 1} {
|
|
set phase 2
|
|
lappend argsout $a
|
|
incr argocnt
|
|
} else {
|
|
set name $names($idx)
|
|
incr idx
|
|
if {$idx >= $nargs} {
|
|
set phase 2
|
|
}
|
|
}
|
|
}
|
|
set values($name) $a
|
|
set done($name) 1
|
|
set name ""
|
|
}
|
|
}
|
|
if {$name ne ""} {
|
|
error "missing value for $name"
|
|
}
|
|
if {$nargs > 0 && $names([expr $nargs - 1]) eq "-args"} {
|
|
if {$done(-args) == 1} {
|
|
if {[llength $argsout] > 0} {
|
|
error "$args\nERROR: superfluous args: $argsout"
|
|
}
|
|
} else {
|
|
set values(-args) $argsout
|
|
set done(-args) 1
|
|
}
|
|
} elseif {[llength $argsout] > 0} {
|
|
error "$args\nERROR: superfluous args (no -args argument at end): $argsout"
|
|
}
|
|
for {set idx 0} {$idx < $nargs} {incr idx} {
|
|
set name $names($idx)
|
|
if {$done($name) < 0} {
|
|
error "$args\nERROR: missing $name argument: $arglist"
|
|
}
|
|
if {$array eq "var"} {
|
|
upvar [string range $name 1 end] x
|
|
# clientput "upvar [string range $name 1 end] $values($name)"
|
|
set x $values($name)
|
|
} else {
|
|
# clientput "array $array ([string range $name 1 end]) $values($name)"
|
|
set arg([string range $name 1 end]) $values($name)
|
|
}
|
|
}
|
|
set arg(-cnt) $argocnt
|
|
return $argocnt
|
|
}
|
|
|
|
proc cfgenv {{obj ""} args} {
|
|
if {$obj eq "" || $obj eq "list"} {
|
|
set objs [split [result cfg_env items]]
|
|
foreach obj $objs {
|
|
set val [result cfg_env $obj]
|
|
if {[desc_env exists $obj]} {
|
|
set des [result desc_env $obj]
|
|
} else {
|
|
set des ""
|
|
}
|
|
if {$val ne "undefined"} {
|
|
if {[string length $obj] < 8} {
|
|
clientput [format "%2s%-8s %-20s (%s)" " " $obj $val $des]
|
|
} else {
|
|
clientput [format "%10s %-20s (%s)" $obj $val $des]
|
|
}
|
|
}
|
|
}
|
|
clientput " "
|
|
clientput "Usage:"
|
|
clientput " cfgenv <object> <terminalserver>:<port>\[:<driver>\]"
|
|
clientput " (port is usually 3000 + channel number)"
|
|
clientput " cfgenv remove <terminalserver>"
|
|
clientput " cfgenv remove <object>"
|
|
# cfg_env list
|
|
return ""
|
|
} elseif {[llength $args] == 0} {
|
|
set obj [silent $obj result alias_hostport $obj]
|
|
if {[cfg_env exists $obj]} {
|
|
return "cfgenv $obj = [result cfg_env $obj]"
|
|
} else {
|
|
return "cfgenv $obj = "
|
|
}
|
|
} elseif {$obj eq "remove"} {
|
|
foreach obj [result cfg_env items] {
|
|
set val [result cfg_env $obj]
|
|
set host [lindex [split $val :] 0]
|
|
set host [lindex [split $host .] 0]
|
|
if {[string match "*.$host.*" ".[join $args .]."] \
|
|
|| [string match "* $obj *" " $args "]} {
|
|
clientput "remove $obj $val"
|
|
cfg_env deleteitem $obj
|
|
}
|
|
}
|
|
} else {
|
|
set ca [concat $args]
|
|
set aobj [silent $obj result alias_hostport $obj]
|
|
if {$ca eq "="} {
|
|
cfg_env deleteitem $aobj
|
|
} else {
|
|
if {[lindex $args 0] eq "="} {
|
|
set ca [lrange $args 1 end]
|
|
}
|
|
set old [silent unknown result cfg_env $aobj]
|
|
cfg_env makeitem $aobj $ca
|
|
if {[sicsdescriptor $obj] ne "notfound"} {
|
|
driverKind $obj hostport
|
|
if {$ca ne $old || $ca ne $hostport} {
|
|
$obj reconnect $ca
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
proc driverKind {obj {connectaddress 0} {drivername 0}} {
|
|
if {$connectaddress ne 0} {
|
|
upvar $connectaddress term
|
|
}
|
|
if {$drivername ne 0} {
|
|
upvar $drivername driver
|
|
}
|
|
if {[sicsdescriptor $obj] eq "dummyremote"} {
|
|
set term [result silent "" sics [hgetpropval $obj remobj] hostport]
|
|
set driver " "
|
|
return dummyremote
|
|
}
|
|
set cre [split [silent 0 result $obj creationCmd]]
|
|
if {[llength $cre] == 4} {
|
|
set term [lindex $cre 3]
|
|
set driver [lindex $cre 2]
|
|
return ease
|
|
}
|
|
set cre [split [silent 0 hgetpropval /sics/$obj creationCmd]]
|
|
if {[lindex $cre 0] eq "stdConfig::make"} {
|
|
set term [lindex $cre 3]
|
|
set driver [lindex $cre 1]
|
|
return stdsct
|
|
} elseif {[llength $cre] == 3} {
|
|
set term [lindex $cre 2]
|
|
set driver [lindex [split [lindex $cre 0] _] 0]
|
|
return oldsct
|
|
}
|
|
set cre [split [silent 0 hgetpropval /sics/$obj _makecmd]]
|
|
if {[lindex $cre 0] eq "makesctcontroller"} {
|
|
set term [$obj hostport]
|
|
# set term [lindex $cre 3]
|
|
set driver [lindex $cre 2]
|
|
return sctcontroller
|
|
}
|
|
set term " "
|
|
set driver " "
|
|
return unknown
|
|
}
|
|
|
|
proc driverName {{obj 0}} {
|
|
global makenv_object inside_samenv
|
|
if {$obj eq "0" && $inside_samenv} {
|
|
set obj $makenv_object
|
|
}
|
|
set drivername unknown
|
|
driverKind $obj 0 drivername
|
|
return $drivername
|
|
}
|
|
|
|
publishLazy driverName
|
|
|
|
proc showDeviceConfig { } {
|
|
clientput " "
|
|
clientput "Object Driver Connected to Description"
|
|
clientput \
|
|
"-------------------------------------------------------------------------------"
|
|
set list [split [obj_list items]]
|
|
set bad 0
|
|
foreach obj $list {
|
|
set kind [driverKind $obj term driver]
|
|
set stat [silent "" result $obj status]
|
|
set des [result obj_list $obj]
|
|
if {[result config myrights] < 3} { # not when in spy mode
|
|
switch -- $kind {
|
|
sctcontroller - stdsct {
|
|
desc_env makeitem $obj $des
|
|
}
|
|
oldsct {
|
|
# cfg_env makeitem $obj $term
|
|
desc_env makeitem $obj $des
|
|
}
|
|
ease {
|
|
# cfg_env makeitem $obj $term
|
|
desc_env makeitem $obj $des
|
|
}
|
|
}
|
|
}
|
|
set col123 [format "%-6s %-6s %-19s" $obj $driver $term]
|
|
clientput [format "%-33s %s" [string trim $col123] "$des"]
|
|
if { [string length $stat] > 0 } {
|
|
clientput " $stat"
|
|
if {[lindex [split $stat " "] 0] eq "connecting"} {
|
|
if {$bad == 0} {
|
|
set bad 1
|
|
}
|
|
} else {
|
|
set bad 2
|
|
}
|
|
}
|
|
}
|
|
if {$bad == 2} {
|
|
clientput " "
|
|
clientput "Please check the cabling to the proper ports and terminalservers"
|
|
clientput "If the configuration has to be changed, use"
|
|
clientput " "
|
|
clientput " cfgenv"
|
|
clientput " "
|
|
clientput "and enter again"
|
|
clientput " "
|
|
clientput " samenv [result device name]"
|
|
}
|
|
if {$bad == 1} {
|
|
clientput " "
|
|
clientput "Please check if the connection was successful with:"
|
|
clientput " "
|
|
clientput " samenv"
|
|
}
|
|
}
|
|
|
|
proc showUnconfigured { } {
|
|
global device_name unconfigured_list
|
|
set list $unconfigured_list
|
|
if {[llength $list] > 1} {
|
|
clientput "ERROR: connections for [join $list ,] are not configured"
|
|
} else {
|
|
clientput "ERROR: connection for [join $list] is not configured"
|
|
}
|
|
clientput " "
|
|
clientput "Configure connections:"
|
|
clientput " "
|
|
foreach obj $list {
|
|
clientput " cfgenv $obj <terminalserver>:<port>\[:<driver>\]"
|
|
}
|
|
clientput " (port is usually 3000 + channel number)"
|
|
clientput " "
|
|
clientput "and enter"
|
|
clientput " "
|
|
clientput " samenv $device_name"
|
|
clientput " "
|
|
error "again."
|
|
}
|
|
|
|
set inside_samenv 0
|
|
|
|
proc makenv args {
|
|
global objects_created objects_replaced objects_already
|
|
global inside_samenv unconfigured_list makenv_object
|
|
|
|
if {$inside_samenv == 0} {
|
|
clientput "ERROR: .config/.addon/.stick files must not be called directly"
|
|
SetInt abortbatch
|
|
return
|
|
}
|
|
|
|
set argc [scanargs $args var -objname -driver -controller 0 -port 0 -visibility user -args]
|
|
|
|
set makenv_object $objname
|
|
if {$controller eq "0"} {
|
|
set dobj _$objname
|
|
} else {
|
|
set dobj $controller
|
|
}
|
|
if {[string match like-* $driver]} {
|
|
set hostport [silent 0 result cfg_env $dobj]
|
|
set hpl [split $hostport ":"]
|
|
if {[llength $hpl] > 2} {
|
|
set driver [lindex $hpl 2]
|
|
} else {
|
|
if {[lindex $hpl 1] == 7777} {
|
|
set driver 336_lsc
|
|
} else {
|
|
set driver [string range $driver 5 end]
|
|
}
|
|
}
|
|
}
|
|
set ret [source_sct_driver $driver]
|
|
if {$ret == 2} return
|
|
if {$ret} {
|
|
set kind stdsct
|
|
} elseif {[llength [info procs ${driver}_Make]] == 1} {
|
|
set dobj $objname
|
|
set kind oldsct
|
|
} else {
|
|
set kind ease
|
|
set dobj $objname
|
|
set des [driverlist $driver]
|
|
if {$des eq "notfound"} {
|
|
error "unknown driver: $driver"
|
|
}
|
|
desc_env makeitem $objname $des
|
|
}
|
|
if {$port ne "0"} {
|
|
set arg $port
|
|
} elseif {[cfg_env exists $dobj] && ([result cfg_env $dobj] ne "")} {
|
|
set arg [result cfg_env $dobj]
|
|
} else {
|
|
cfg_env makeitem $dobj
|
|
if {$kind eq "ease"} {
|
|
cfg_env $dobj ""
|
|
lappend unconfigured_list $dobj
|
|
clientput "$dobj not configured"
|
|
return
|
|
}
|
|
cfg_env $dobj undefined
|
|
}
|
|
switch $kind {
|
|
stdsct {
|
|
set cmd [list stdConfig::make $driver $objname $controller -port $port]
|
|
if {[llength $args] > 0} {
|
|
foreach a $args {
|
|
lappend cmd $a
|
|
}
|
|
}
|
|
# clientput "STDSCT: $cmd"
|
|
set oldcmd [silent none hgetpropval /sics/$objname creationCmd]
|
|
if {[string equal -nocase $cmd $oldcmd]} {
|
|
append objects_already "$objname "
|
|
if {! [obj_list exists $objname]} {
|
|
obj_list makeitem $objname unknown
|
|
}
|
|
} elseif {[catch {eval $cmd} msg]} {
|
|
clientput "ERROR: in $cmd:"
|
|
clientput "ERROR: $msg"
|
|
} else {
|
|
Layout /$objname
|
|
device_layout /$objname [silent 0 hgetpropval /$objname layoutpos]
|
|
if {$oldcmd eq "none"} {
|
|
append objects_created "$objname "
|
|
} else {
|
|
append objects_replaced "$objname "
|
|
}
|
|
}
|
|
if {$visibility ne "user"} {
|
|
hsetprop /sics/$objname groupMode $visibility
|
|
}
|
|
}
|
|
oldsct {
|
|
set cmd "${driver}_Make $objname $arg"
|
|
set oldcmd [silent none hgetpropval /sics/$objname creationCmd]
|
|
if {[string equal -nocase $cmd $oldcmd]} {
|
|
append objects_already "$objname "
|
|
if {! [obj_list exists $objname]} {
|
|
obj_list makeitem $objname unknown
|
|
}
|
|
} elseif {[catch {set des [eval $cmd]} msg]} {
|
|
clientput "ERROR: in $cmd:"
|
|
clientput "ERROR: $msg"
|
|
} else {
|
|
if {$oldcmd eq "none"} {
|
|
append objects_created "$objname "
|
|
} else {
|
|
append objects_replaced "$objname "
|
|
}
|
|
obj_list makeitem $objname $des
|
|
}
|
|
Layout /$objname
|
|
device_layout /$objname [silent 0 hgetpropval /$objname layoutpos]
|
|
}
|
|
ease {
|
|
set cmd "makeobject $objname $driver $arg"
|
|
# clientput "EASE $cmd"
|
|
set oldcmd [silent none result $objname creationcmd]
|
|
if {[string equal -nocase $cmd $oldcmd]} {
|
|
append objects_already "$objname "
|
|
if {! [obj_list exists $objname]} {
|
|
obj_list makeitem $objname unknown
|
|
}
|
|
} elseif {[catch {eval $cmd} msg]} {
|
|
clientput "ERROR: in $cmd:"
|
|
clientput "ERROR: $msg"
|
|
} else {
|
|
if {$oldcmd eq "none"} {
|
|
append objects_created "$objname "
|
|
} else {
|
|
append objects_replaced "$objname "
|
|
}
|
|
obj_list makeitem $objname $des
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
proc stick_sensors {sensor1 sensor2} {
|
|
set stick_name [result default stick]
|
|
catch {
|
|
set sn "${stickname}_[hgetpropval /tt/ts/curve shortname]"
|
|
hsetprop /tt/ts/curve sensorname $sn
|
|
}
|
|
catch {
|
|
tt ts/curve $sensor1
|
|
}
|
|
if {$sensor1 eq "undefined"} {
|
|
GraphItem shown tt.ts 0
|
|
GraphItem shown tt.setsamp.power 0
|
|
GraphItem shown tt.setsamp.reg 0
|
|
} else {
|
|
GraphAdd tt.ts K T_sample blue
|
|
}
|
|
catch {
|
|
tt
|
|
defineTemperature tt
|
|
}
|
|
source config/stick.list
|
|
if {[string match "code*" $sensor2]} {
|
|
set code [lindex [split $sensor2=0 =] 1]
|
|
set table_code [silent 0 set stick_cfgtable($stick_name)]
|
|
if {$table_code != $code} {
|
|
clientput "ERROR: code $code in $stick_name.stick does not match value from config/sticklist: $table_code"
|
|
}
|
|
set sensor2 code
|
|
} else {
|
|
catch {
|
|
set sn "${stickname}_[hgetpropval /tt/ts_2/curve shortname]"
|
|
hsetprop /tt/ts/curve sensorname $sn
|
|
}
|
|
}
|
|
catch {
|
|
tt ts_2/curve $sensor2
|
|
}
|
|
GraphItem label tt.ts_2 T_sample2
|
|
GraphItem units tt.ts_2 K
|
|
GraphItem color tt.ts_2 cyan
|
|
if {$sensor2 eq "code" || $sensor2 eq "undefined"} {
|
|
GraphItem shown tt.ts_2 0
|
|
} else {
|
|
GraphItem shown tt.ts_2 1
|
|
}
|
|
}
|
|
|
|
proc fix_stick_sensors {} {
|
|
# fix stick sensors
|
|
foreach path {/tt/ts/curve /tt/ts_2/curve} {
|
|
set curv [sctval $path ""]
|
|
if {$curv ne ""} {
|
|
hset $path $curv
|
|
}
|
|
}
|
|
}
|
|
|
|
proc ts_sensor {sensor} {
|
|
catch {
|
|
catch {
|
|
set sn "[result device stick_name]_[hgetpropval /tt/ts/curve shortname]"
|
|
hsetprop /tt/ts/curve sensorname $sn
|
|
}
|
|
tt ts/curve $sensor
|
|
if {$sensor eq "undefined"} {
|
|
GraphItem shown tt.ts 0
|
|
} else {
|
|
GraphAdd tt.ts K T_sample blue
|
|
}
|
|
defineTemperature tt
|
|
}
|
|
}
|
|
|
|
proc ts_sensor2 {sensor {rescode 0}} {
|
|
# rescode is not used
|
|
catch {
|
|
catch {
|
|
set sn "[result device stick_name]_[hgetpropval /tt/ts_2/curve shortname]"
|
|
hsetprop /tt/ts/curve sensorname $sn
|
|
}
|
|
tt ts_2/curve $sensor
|
|
GraphItem label tt.ts_2 T_sample2
|
|
GraphItem units tt.ts_2 K
|
|
GraphItem color tt.ts_2 cyan
|
|
if {$sensor eq "code" || $sensor eq "undefined"} {
|
|
GraphItem shown tt.ts_2 0
|
|
} else {
|
|
GraphItem shown tt.ts_2 1
|
|
}
|
|
}
|
|
}
|
|
|
|
proc stick {name} {
|
|
set ::selected_stick $name
|
|
}
|
|
|
|
proc import {device} {
|
|
|
|
set file ${device}.config
|
|
if {![file exists $file]} {
|
|
set file ${device}.config.inc
|
|
if {![file exists $file]} {
|
|
return "$file not found"
|
|
}
|
|
}
|
|
set deviceDesc [result deviceDesc]
|
|
clientput "read $file"
|
|
source $file
|
|
deviceDesc = $deviceDesc
|
|
}
|
|
|
|
proc prettyList { name desc } {
|
|
clientput [format "%-10s %s" $name $desc]
|
|
}
|
|
|
|
proc findDesc {filename name} {
|
|
set desc 0
|
|
if {[catch {set fil [open $filename]}] == 0} {
|
|
while {[gets $fil line] >= 0} {
|
|
set s [split $line =]
|
|
if {[string trim [lindex $s 0]] eq $name} {
|
|
set desc [string trim [lindex $s 1]]
|
|
break
|
|
}
|
|
}
|
|
close $fil
|
|
}
|
|
return $desc
|
|
}
|
|
|
|
proc obj_dependency {command {mama ""} {kid ""}} {
|
|
switch $command {
|
|
set {
|
|
if {$mama eq ""} {
|
|
clientput "Usage: obj_dependency set <mama> <kid>"
|
|
clientput " obj_dependency set <mama> LOCK"
|
|
error "illegal syntax"
|
|
}
|
|
if {$kid eq ""} {
|
|
return
|
|
}
|
|
set d [silent "" result obj_dependencies $mama]
|
|
foreach k $kid {
|
|
set d [lsearch -all -inline -not -exact $d $k]
|
|
lappend d $k
|
|
}
|
|
obj_dependencies makeitem $mama $d
|
|
}
|
|
kill {
|
|
if {$mama eq ""} {
|
|
clientput "Usage: obj_dependency kill <mama> <kid>"
|
|
clientput " obj_dependency kill <mama>"
|
|
error "illegal syntax"
|
|
}
|
|
if {$kid eq ""} {
|
|
# remove all items for mama
|
|
catch {obj_dependencies deleteitem $mama}
|
|
} else {
|
|
set d [silent "" result obj_dependencies $mama]
|
|
# remove item $kid
|
|
set d [lsearch -all -inline -not -exact $d $kid]
|
|
obj_dependencies makeitem $mama $d
|
|
}
|
|
}
|
|
check {
|
|
if {$kid ne ""} {
|
|
error "Usage: obj_dependency check <mama>"
|
|
}
|
|
foreach kid [silent "" result obj_dependencies $mama] {
|
|
if {$kid eq "LOCK"} {
|
|
return 0
|
|
}
|
|
if {[sicsdescriptor $kid] ne "notfound"} {
|
|
return 0
|
|
}
|
|
}
|
|
return 1
|
|
}
|
|
list {
|
|
if {$mama ne ""} {
|
|
error "Usage: obj_dependency list"
|
|
}
|
|
foreach obj [obj_dependencies items] {
|
|
clientput "$obj: [result obj_dependencies $obj]"
|
|
}
|
|
return
|
|
}
|
|
default {
|
|
error "Usage: obj_dependency (set | kill | check | list) \[<mama>\] \[<kid>\]"
|
|
}
|
|
}
|
|
}
|
|
|
|
proc remove_these_objects {list} {
|
|
set cnt 1
|
|
set newlist [list]
|
|
# make while loop as long as at least one object is removed
|
|
while {$cnt > 0} {
|
|
set cnt 0
|
|
foreach obj $list {
|
|
if {[obj_dependency check $obj]} {
|
|
if {[sicsdescriptor $obj] ne "notfound"} {
|
|
catch { removeobject $obj } msg
|
|
clientput $msg
|
|
if {[regexp addon_(.*) $obj -> addonname]} {
|
|
# remove addon from addon_list
|
|
catch {addon_list deleteitem $addonname} msg
|
|
if {$msg ne ""} {
|
|
clientput $msg
|
|
}
|
|
}
|
|
if {[sicsdescriptor $obj] eq "notfound"} {
|
|
catch {obj_list deleteitem $obj}
|
|
catch {obj_dependencies deleteitem $obj}
|
|
incr cnt
|
|
} else {
|
|
clientput "could not delete $obj"
|
|
}
|
|
} else {
|
|
catch {obj_list deleteitem $obj}
|
|
catch {obj_dependencies deleteitem $obj}
|
|
}
|
|
} else {
|
|
lappend newlist $obj
|
|
}
|
|
}
|
|
set list $newlist
|
|
}
|
|
}
|
|
|
|
proc sort_layout {} {
|
|
set layoutlist [list]
|
|
set cnt 500
|
|
foreach item [device_layout items] {
|
|
set val [result device_layout $item]
|
|
# make value positive and with a fixed number of digits
|
|
set key 5000000000
|
|
if {[string is integer -strict $val]} {
|
|
incr key $val
|
|
} else {
|
|
set val 0
|
|
}
|
|
incr cnt
|
|
lappend layoutlist "$key $cnt $item $val"
|
|
#clientput "$key $cnt $item $val"
|
|
device_layout deleteitem $item
|
|
}
|
|
foreach item [lsort $layoutlist] {
|
|
device_layout makeitem [lindex $item 2] [lindex $item 3]
|
|
}
|
|
}
|
|
|
|
proc stopall {} {
|
|
catch {
|
|
set running [listexe]
|
|
if {$running ne "Machine Idle"} {
|
|
clientput "stop $running"
|
|
catch {stopexe run}
|
|
for {set j 0} {$j < 2} {incr j} {
|
|
set start [DoubleTime]
|
|
set sleep 0.01
|
|
for {set i 0} {[DoubleTime] < $start + 5} {incr i} {
|
|
catch {wait 0.01}
|
|
set sleep [expr $sleep * 1.1]
|
|
set running [listexe]
|
|
if {$running eq "Machine Idle"} break;
|
|
}
|
|
if {$running eq "Machine Idle"} break;
|
|
# force stop of script context objects
|
|
foreach obj $running {
|
|
if {[catch {hsetprop /$obj status idle} msg]} {
|
|
clientput $msg
|
|
}
|
|
}
|
|
}
|
|
set tim [expr [DoubleTime] - $start]
|
|
if {$tim > 0.1} {
|
|
clientput "time for stop [format %.2f $tim] ($i x)"
|
|
}
|
|
if {$running eq "Machine Idle"} {
|
|
clientput "stopped"
|
|
} else {
|
|
clientput "RESET SERVER"
|
|
resetserver
|
|
wait 1
|
|
}
|
|
}
|
|
} msg
|
|
set running [listexe]
|
|
if {$running ne "Machine Idle"} {
|
|
clientput $msg
|
|
clientput "could not stop $running"
|
|
}
|
|
}
|
|
|
|
proc samenv args {
|
|
global inside_samenv unconfigured_list vars logbase
|
|
global objects_created objects_replaced objects_already device_name
|
|
global selected_stick selected_addons
|
|
global change_device_to_none
|
|
|
|
set inside_samenv 0
|
|
set verbose 1
|
|
foreach a $args {
|
|
switch -glob -- $a {
|
|
-q* {
|
|
set verbose 0
|
|
}
|
|
default {
|
|
lappend arg $a
|
|
}
|
|
}
|
|
}
|
|
if {[info exists arg]} {
|
|
set name [lindex $arg 0]
|
|
} else {
|
|
set name ""
|
|
}
|
|
set dev [result device name]
|
|
set stk [result device stick_name]
|
|
if {$stk ne "" && $stk ne $dev} {
|
|
append dev /$stk
|
|
}
|
|
foreach a [result addon_list items] {
|
|
if {$a ne $stk} {
|
|
append dev /$a
|
|
}
|
|
}
|
|
|
|
switch $name {
|
|
name {
|
|
return $dev
|
|
}
|
|
list {
|
|
set list [lsort [glob *.config]]
|
|
if {[llength $arg] == 1} {
|
|
set func prettyList
|
|
} else {
|
|
set func [lindex $arg 1]
|
|
}
|
|
foreach item $list {
|
|
$func [file rootname $item] [findDesc $item deviceDesc]
|
|
}
|
|
return ""
|
|
}
|
|
reload {
|
|
set name $dev
|
|
}
|
|
"" {
|
|
if {$verbose && $dev ne "none"} {
|
|
clientput "$dev: [result deviceDesc]"
|
|
showDeviceConfig
|
|
clientput " "
|
|
return "samenv = $dev"
|
|
}
|
|
return "samenv = $dev ([result deviceDesc])"
|
|
}
|
|
}
|
|
|
|
set change_device_to_none 0
|
|
|
|
set nl [split $name /]
|
|
if {[llength $nl] == 1} {
|
|
set selected_stick ""
|
|
set selected_addons [list]
|
|
} else {
|
|
set name [lindex $nl 0]
|
|
set selected_stick [lindex $nl 1]
|
|
if {[file exists ${selected_stick}.stick]} {
|
|
set selected_addons [lrange $nl 2 end]
|
|
} else {
|
|
set selected_stick ""
|
|
set selected_addons [lrange $nl 1 end]
|
|
}
|
|
}
|
|
|
|
set permanent_addons [list]
|
|
foreach addon [addon_list items] {
|
|
if {[result addon_list $addon] eq "permanent"} {
|
|
lappend permanent_addons $addon
|
|
} else {
|
|
}
|
|
}
|
|
|
|
set file ${name}.config
|
|
if { [file exists $file] == 0 } {
|
|
return "$file not found"
|
|
}
|
|
|
|
device stick_menu ""
|
|
if {$name eq "none" && [result device stick_name] ne ""} {
|
|
addon delete [result device stick_name]
|
|
}
|
|
device stick_name ""
|
|
device stick_label ""
|
|
device name none
|
|
device name_label NONE
|
|
device makeitem stickrot_hostport unconnected
|
|
|
|
stopall
|
|
|
|
if {[default name] eq $name} {
|
|
# save defaults
|
|
clientput "--- save defaults ---\n[default list]\n---"
|
|
} else {
|
|
default clear
|
|
}
|
|
|
|
foreach seaclient [silent {} seaclient_list items] {
|
|
obj_list makeitem $seaclient
|
|
seaclient_list deleteitem $seaclient
|
|
}
|
|
|
|
set objects_to_kill [obj_list items]
|
|
|
|
if { [llength $objects_to_kill] != 0 } {
|
|
clientput " "
|
|
clientput --- remove $dev ---
|
|
}
|
|
# catch {removeobject samenv_vars}
|
|
|
|
remove_these_objects $objects_to_kill
|
|
foreach item [split [device_layout items]] {
|
|
device_layout deleteitem $item
|
|
}
|
|
|
|
GraphKill samenv
|
|
GraphOrder
|
|
# clear ignoreMsg flags:
|
|
ignoreMsg 0
|
|
|
|
reload
|
|
|
|
if {$name eq "none" &&
|
|
[llength $selected_addons] == 0 && [llength $permanent_addons] == 0} {
|
|
device makeitem rack_used 0
|
|
do_as_manager {
|
|
set inside_samenv 1
|
|
source none.config
|
|
sort_layout
|
|
request_items $name
|
|
|
|
catch {array unset ::config_failed}
|
|
device stickrot_hostport unconnected
|
|
set inside_samenv 0
|
|
}
|
|
set device_name none
|
|
device makeitem confirmed ""
|
|
restore killerr
|
|
save_samenv none
|
|
return "samenv = none"
|
|
}
|
|
clientput " "
|
|
clientput --- install $name ---
|
|
|
|
set vars ""
|
|
|
|
set objects_created ""
|
|
set objects_replaced ""
|
|
set objects_already ""
|
|
set ::device_name $name
|
|
set ::stick_name $name
|
|
ccu4_device 0
|
|
|
|
if {[info exists unconfigured_list]} {
|
|
unset unconfigured_list
|
|
}
|
|
set inside_samenv 1
|
|
|
|
do_as_manager {
|
|
catch {array unset ::config_failed}
|
|
if {[catch {source $file} msg]} {
|
|
clientput "ERROR: in $file\nERROR: $msg"
|
|
set ::config_failed("_device") "error in $file: $msg"
|
|
}
|
|
request_items $name
|
|
}
|
|
device changetime [DoubleTime]
|
|
set inside_samenv 0
|
|
if {[info exists unconfigured_list]} {
|
|
showUnconfigured
|
|
}
|
|
default name $name
|
|
|
|
if {$selected_stick eq ""} {
|
|
set selected_stick [silent "" default stick]
|
|
if {$selected_stick ne ""} {
|
|
clientput "set stick to $selected_stick"
|
|
}
|
|
}
|
|
if {$selected_stick eq ""} {
|
|
if {[silent none hvali /tt/ts/curve] eq "undefined"} {
|
|
set selected_stick $name
|
|
if {[silent "" result device stick_menu] eq ""} {
|
|
device stick_menu $name
|
|
}
|
|
} else {
|
|
lassign [silent "" result device stick_menu] first
|
|
if {$first eq $name} {
|
|
if {[file exists $name.stick]} {
|
|
set selected_stick $name
|
|
}
|
|
} elseif {$first ne ""} {
|
|
set selected_stick none
|
|
}
|
|
}
|
|
}
|
|
# if {$selected_stick ne ""} {
|
|
# set inside_samenv 1
|
|
# clientput "selected_stick $selected_stick"
|
|
# set ::stick_name $selected_stick
|
|
# do_as_manager {
|
|
# source ${selected_stick}.stick
|
|
# }
|
|
# unset ::stick_name
|
|
# set inside_samenv 0
|
|
# device stick_name $selected_stick
|
|
# default stick $selected_stick
|
|
# }
|
|
|
|
# make sure that endinit flag is set
|
|
obj_list endinit
|
|
|
|
sort_layout
|
|
|
|
set ccudesc [sicsdescriptor cc]
|
|
if {$ccudesc eq "ccu4"} {
|
|
device makeitem rack_used 1
|
|
# should be given explicitely as arg to makeCCU4
|
|
# ccu4_device default
|
|
} else {
|
|
device makeitem rack_used 0
|
|
if {$ccudesc eq "notfound"} {
|
|
set rack [silent other result device rack]
|
|
catch {
|
|
set autorack [get_rack $rack]
|
|
if {$autorack ne $rack} {
|
|
set racks [get_rack]
|
|
if {[llength $racks] == 1} {
|
|
set rack $racks
|
|
} else {
|
|
# this is an error message
|
|
clientput "RACKS: $racks"
|
|
}
|
|
}
|
|
}
|
|
if {$rack ne "no" && $rack ne "" && $rack ne "other"} {
|
|
do_as_manager {
|
|
set inside_samenv 1
|
|
makenv cc ccu4
|
|
set inside_samenv 0
|
|
ccu4_show_device $device_name
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
# makeobject samenv_vars array
|
|
GraphLoad $vars samenv
|
|
|
|
default stick $selected_stick
|
|
|
|
default load
|
|
|
|
device name $name
|
|
device name_label [string toupper $name]
|
|
if {$name ne [silent 0 hval /device/confirmed]} {
|
|
device makeitem confirmed ""
|
|
}
|
|
|
|
obj_list savefile ""
|
|
if { [string length $objects_created] != 0 } {
|
|
clientput "create: $objects_created"
|
|
}
|
|
if { [string length $objects_replaced] != 0 } {
|
|
clientput "replace: $objects_replaced"
|
|
}
|
|
if { [string length $objects_already] != 0 } {
|
|
clientput "already there: $objects_already"
|
|
}
|
|
if {$verbose} showDeviceConfig
|
|
|
|
if {$selected_stick ne ""} {
|
|
addon stick $selected_stick
|
|
}
|
|
foreach a $selected_addons {
|
|
addon $a
|
|
}
|
|
foreach a $permanent_addons {
|
|
addon permanent $a
|
|
}
|
|
|
|
if {[sicsdescriptor sics] eq "RemServer"} {
|
|
# update_remob
|
|
sics nowait sea nowait update_remob
|
|
}
|
|
save_samenv
|
|
return "samenv = $name"
|
|
}
|
|
|
|
proc addon args {
|
|
global inside_samenv unconfigured_list vars permanent_addon
|
|
global selected_addons
|
|
global objects_created objects_replaced objects_already
|
|
|
|
switch [lindex $args 0] {
|
|
permanent {
|
|
set permanent_addon 1
|
|
if {$inside_samenv} {
|
|
if {[llength $args] > 1} {
|
|
error "ERROR: usage inside an addon: addon permanent"
|
|
}
|
|
return
|
|
}
|
|
if {[llength $args] != 2} {
|
|
error "ERROR: usage: addon permanent <addon>"
|
|
}
|
|
set name [lindex $args 1]
|
|
set state [silent notfound result addon_list $name]
|
|
if {$state ne "notfound"} {
|
|
if {$state ne "permanent"} {
|
|
foreach o [result obj_dependencies addon_$name] {
|
|
obj_dependency set $o addonlock_$name
|
|
}
|
|
makeobject addonlock_$name string
|
|
obj_list makeitem addonlock_$name
|
|
addon_$name makeitem addonlock_$name
|
|
addon_list $name permanent
|
|
clientput "addon $name set to permanent"
|
|
} else {
|
|
clientput "addon $name is already permanent"
|
|
}
|
|
return
|
|
}
|
|
set file ${name}.addon
|
|
}
|
|
delete {
|
|
if {$inside_samenv} {
|
|
error "ERROR: addon delete inhibited inside config scripts"
|
|
}
|
|
if {[llength $args] != 2} {
|
|
error "ERROR: usage: addon delete <addon>"
|
|
}
|
|
stopall
|
|
set name [lindex $args 1]
|
|
catch {
|
|
set olist [silent 0 addon_$name items]
|
|
clientput "(addon delete: remove $olist)"
|
|
if {$olist ne "0"} {
|
|
remove_these_objects "$olist addon_$name"
|
|
}
|
|
catch {addon_list deleteitem $name}
|
|
GraphKill $name
|
|
obj_dependency kill addon_$name
|
|
return ""
|
|
} msg
|
|
if {$msg ne ""} {
|
|
clientput $msg
|
|
}
|
|
device changetime [DoubleTime]
|
|
save_samenv
|
|
return
|
|
}
|
|
stick {
|
|
if {[llength $args] == 1} {
|
|
return [result device stick_name]
|
|
}
|
|
if {$inside_samenv} {
|
|
error "ERROR: addon stick inhibited inside config scripts"
|
|
}
|
|
if {[llength $args] != 2} {
|
|
error "ERROR: usage: addon stick <stick>"
|
|
}
|
|
set name [lindex $args 1]
|
|
set ::stick_name $name
|
|
if {$name eq "cancel"} {
|
|
return [result device stick_name]
|
|
}
|
|
if {[result device stick_name] ne ""} {
|
|
clientput "(addon delete [result device stick_name])"
|
|
addon delete [result device stick_name]
|
|
}
|
|
device stick_name $name
|
|
device stick_label [string toupper $name]
|
|
default stick $name
|
|
set file ${name}.stick
|
|
set permanent_addon 0
|
|
}
|
|
list {
|
|
return [string map "{[result device stick_name]} {}" [addon_list items]]
|
|
}
|
|
default {
|
|
if {[llength $args] != 1} {
|
|
error "ERROR: usage: addon \[permanent | delete\] <addon>"
|
|
}
|
|
set name [lindex $args 0]
|
|
if {$inside_samenv} {
|
|
lappend selected_addons $name
|
|
}
|
|
set permanent_addon 0
|
|
if {[addon_list exists $name]} {
|
|
addon delete $name
|
|
catch {unset ::config_failed($name)}
|
|
}
|
|
set file ${name}.addon
|
|
}
|
|
}
|
|
if { [file exists $file] == 0 } {
|
|
return "$file not found"
|
|
}
|
|
if {[info exists unconfigured_list]} {
|
|
unset unconfigured_list
|
|
}
|
|
set vars ""
|
|
set objects_created ""
|
|
set objects_replaced ""
|
|
set objects_already ""
|
|
set old_inside $inside_samenv
|
|
set inside_samenv 1
|
|
if {[catch {
|
|
if {[result config myrights] == 2} {
|
|
config rights seamanager seager
|
|
source $file
|
|
config rights seauser seaser
|
|
} else {
|
|
source $file
|
|
}
|
|
} msg]} {
|
|
clientput "ERROR: in $file\nERROR: $msg"
|
|
set ::config_failed($name) "error in $file: $msg"
|
|
} else {
|
|
catch {unset ::config_failed($name)}
|
|
}
|
|
device changetime [DoubleTime]
|
|
set inside_samenv $old_inside
|
|
if {[info exists unconfigured_list]} {
|
|
showUnconfigured
|
|
}
|
|
obj_list endinit
|
|
|
|
sort_layout
|
|
|
|
makeobject addon_$name array
|
|
obj_list makeitem addon_$name ADDON
|
|
|
|
if {$permanent_addon} {
|
|
addon_list makeitem $name permanent
|
|
} else {
|
|
addon_list makeitem $name volatile
|
|
}
|
|
GraphLoad $vars $name
|
|
if { [string length $objects_created] != 0 } {
|
|
clientput "create: $objects_created"
|
|
}
|
|
if { [string length $objects_replaced] != 0 } {
|
|
clientput "replace: $objects_replaced"
|
|
}
|
|
if { [string length $objects_already] != 0 } {
|
|
clientput "already there: $objects_already"
|
|
}
|
|
set objlist [string trim "$objects_created $objects_replaced $objects_already"]
|
|
set dep ""
|
|
foreach o $objlist {
|
|
foreach d [silent "" result obj_dependencies $o] {
|
|
addon_$name makeitem $d
|
|
}
|
|
addon_$name makeitem $o
|
|
append dep " $o [silent "" result obj_dependencies $o]"
|
|
}
|
|
obj_dependency set addon_$name $dep
|
|
if {$permanent_addon} {
|
|
foreach o $dep {
|
|
obj_dependency set $o addonlock_$name
|
|
}
|
|
makeobject addonlock_$name string
|
|
addon_$name makeitem addonlock_$name
|
|
obj_list makeitem addonlock_$name
|
|
}
|
|
if {[sicsdescriptor sics] eq "RemServer"} {
|
|
# update_remob
|
|
sics nowait sea nowait update_remob
|
|
}
|
|
save_samenv
|
|
return OK
|
|
}
|
|
|
|
proc ConfigState {} {
|
|
if {[array exists ::config_failed]} {
|
|
foreach {name msg} [array get ::config_failed] {
|
|
Style warning
|
|
Label "$msg"
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
proc defineTemperature {obj} {
|
|
if {[silent "" result findalias temperature] ne $obj} {
|
|
do_as_manager {
|
|
definealias temperature $obj
|
|
}
|
|
clientput "definealias temperature $obj"
|
|
}
|
|
}
|
|
|
|
publishLazy samenv Spy
|
|
publishLazy addon Spy
|
|
publishLazy cfgenv Spy
|
|
publishLazy defineTemperature User
|
|
|
|
catch { unset autoFlowPar }
|
|
catch { unset tempStat }
|
|
catch { unset powStat }
|
|
catch { unset flowStat }
|
|
|
|
proc appendVars args {
|
|
global vars inside_samenv
|
|
if {$inside_samenv} {
|
|
if {[string length $vars] == 0} {
|
|
append vars $args
|
|
} else {
|
|
append vars " " $args
|
|
}
|
|
return 1
|
|
} else {
|
|
return 0
|
|
}
|
|
}
|
|
|
|
set now [clock seconds]
|
|
|
|
proc e args {
|
|
clientput [eval [join $args]]
|
|
}
|
|
|
|
publishLazy e
|
|
|
|
proc ctrlTable args {
|
|
if {[llength $args] < 2} {
|
|
error "ERROR: need at least 2 args"
|
|
}
|
|
set obj [lindex $args 0]
|
|
if {$obj eq "fixed"} {
|
|
set obj [lindex $args 1]
|
|
if {[llength $args] < 3} {
|
|
error "ERROR: fixed what ?"
|
|
}
|
|
set par [lindex $args 2]
|
|
set res 0
|
|
if {[sicsdescriptor fixed_$obj] eq "array"} {
|
|
if {[string match -nocase "* $par *" " [fixed_$obj items] "]} {
|
|
set res [result fixed_$obj $par]
|
|
}
|
|
}
|
|
if {[llength $args] > 3} {
|
|
if {[lindex $args 3] == 1} {
|
|
if {[sicsdescriptor fixed_$obj] ne "array"} {
|
|
makeobject fixed_$obj array
|
|
}
|
|
set res 1
|
|
} else {
|
|
set res 0
|
|
}
|
|
fixed_$obj makeitem $par $res
|
|
}
|
|
return "fixed_$obj $par = $res"
|
|
}
|
|
set par [lindex $args 1]
|
|
if {[string match -nocase "* $par *" " [table_$obj items] "]} {
|
|
if {[llength $args] < 3} {
|
|
set res ""
|
|
catch {set res [result table_$obj $par]}
|
|
return "table_obj $par = $res"
|
|
} elseif {[llength $args] >= 3} {
|
|
set val [join [split [join [lrange $args 2 end]] ?]]
|
|
set tbl [split [lindex $args 2] :]
|
|
if {[llength $tbl] == 1} {
|
|
return [table_$obj $par "? $val"]
|
|
}
|
|
set dirty 0
|
|
set last 0
|
|
set item1 [split [lindex $tbl 0]]
|
|
if {[llength $item1] > 1} {
|
|
set dirty 1
|
|
}
|
|
set xi [lindex [split [lindex $tbl 0]] end]
|
|
set tbl [lrange $tbl 1 end]
|
|
foreach item $tbl {
|
|
set it [split $item]
|
|
switch [llength $it] {
|
|
1 {
|
|
set last 1
|
|
}
|
|
2 {
|
|
if {$last} {
|
|
set dirty 1
|
|
}
|
|
}
|
|
default {
|
|
set dirty 1
|
|
}
|
|
}
|
|
set yi [lindex $it 0]
|
|
append new "$xi:$yi "
|
|
set xi [lindex $it end]
|
|
}
|
|
if {$last != 1 || $dirty} {
|
|
set val "? $val"
|
|
}
|
|
return [table_$obj $par $val]
|
|
}
|
|
}
|
|
error "ERROR: ctrlTable syntax error"
|
|
}
|
|
|
|
publishLazy ctrlTable Spy
|
|
|
|
set lastset 0
|
|
|
|
proc intpol { obj par x {old none}} {
|
|
# obsolete ? MZ May 2016
|
|
set tbl [split [result table_$obj $par] :]
|
|
if {[llength $tbl] == 1} {
|
|
$obj $par [lindex [split $tbl] 0]
|
|
return
|
|
}
|
|
set x0 0
|
|
set x1 1e30
|
|
set y0 0
|
|
set y1 0
|
|
set xi [lindex [split [lindex $tbl 0]] end]
|
|
set tbl [lrange $tbl 1 end]
|
|
foreach item $tbl {
|
|
set it [split $item]
|
|
set yi [lindex $it 0]
|
|
if {$xi <= $x} {
|
|
if {$xi > $x0} {
|
|
set x0 $xi
|
|
set y0 $yi
|
|
}
|
|
} else {
|
|
if {$xi < $x1} {
|
|
set x1 $xi
|
|
set y1 $yi
|
|
}
|
|
}
|
|
set xi [lindex $it end]
|
|
}
|
|
if {$y0 <= 0 || $y1 <= 0} {
|
|
# linear in x and y
|
|
set q [expr $x1 - $x0]
|
|
if {$q > 0} {
|
|
set y [expr $y0 + ($x - $x0) / $q * ($y1 - $y0)]
|
|
} else {
|
|
set y $y0
|
|
}
|
|
} else {
|
|
# logarithmic in x and y
|
|
set q [expr log($x1*1.0/$x0)]
|
|
if {$q > 0} {
|
|
set y [expr $y0*exp(log($x*1.0/$x0)/$q*log($y1*1.0/$y0))]
|
|
} else {
|
|
set y $y0
|
|
}
|
|
}
|
|
if {$y != $old} {
|
|
$obj $par $y
|
|
}
|
|
}
|
|
|
|
proc putIntoLimits { name min max } {
|
|
# if min > max min is ignored
|
|
upvar $name v
|
|
if {$v > $max} {
|
|
set v $max
|
|
} elseif {$v < $min} {
|
|
set v $min
|
|
}
|
|
}
|
|
|
|
proc pidControl { name dif prop inte min max} {
|
|
upvar $name out
|
|
upvar #0 pid_dif_$name d
|
|
global deltaTime
|
|
|
|
if { [info exists d] == 0} {
|
|
set d 0
|
|
}
|
|
set out [expr $out + $prop * (($dif - $d) + $dif * $deltaTime / $inte)]
|
|
#clientput "$name $dif $n(d) $out"
|
|
set d $dif
|
|
putIntoLimits out $min $max
|
|
return $dif
|
|
}
|
|
|
|
proc minMax {name idx value {value2 none} } {
|
|
upvar $name n
|
|
if {"$value2" eq "none"} {
|
|
set value2 $value
|
|
}
|
|
if {$value2 > $n(max$idx)} {
|
|
set n(max$idx) $value2
|
|
} elseif {$value < $n(min$idx)} {
|
|
set n(min$idx) $value
|
|
}
|
|
}
|
|
|
|
proc statInp { name period value } {
|
|
upvar $name n
|
|
global now
|
|
|
|
if {$value eq "undefined"} {
|
|
set n(spread) 1
|
|
return
|
|
}
|
|
if { [info exists n(idx)] == 0} {
|
|
set n(idx) 0
|
|
set n(last) $now
|
|
set n(spread) 1
|
|
set n(min0) $value
|
|
set n(min1) $value
|
|
set n(min2) $value
|
|
set n(min3) $value
|
|
set n(max0) $value
|
|
set n(max1) $value
|
|
set n(max2) $value
|
|
set n(max3) $value
|
|
}
|
|
set idx $n(idx)
|
|
if {$now > $n(last) + ($period - 3)/ 4} {
|
|
incr idx
|
|
if {$idx >= 4} {
|
|
set idx 0
|
|
}
|
|
set n(idx) $idx
|
|
set n(max$idx) $value
|
|
set n(min$idx) $value
|
|
set n(last) $now
|
|
} else {
|
|
minMax n $idx $value
|
|
}
|
|
|
|
set n(maxn) $n(max0)
|
|
set n(minn) $n(min0)
|
|
minMax n n $n(min1) $n(max1)
|
|
minMax n n $n(min2) $n(max2)
|
|
minMax n n $n(min2) $n(max3)
|
|
|
|
set n(spread) [expr $n(maxn) - $n(minn)]
|
|
if {$n(maxn) > -$n(minn)} {
|
|
set n(absmax) $n(maxn)
|
|
} else {
|
|
set n(absmax) [expr -$n(minn)]
|
|
}
|
|
|
|
return $n(spread)
|
|
}
|
|
|
|
proc ChnState {} {
|
|
global change_device_to_none unplugged_device
|
|
|
|
if {[silent 0 set change_device_to_none] > 0 } {
|
|
Style warning
|
|
Label "[string toupper $unplugged_device] unplugged -> change to NONE in [expr $change_device_to_none - [clock seconds]] sec"
|
|
NoNewline
|
|
Style warning
|
|
RadioGroup do_not_change_to_none
|
|
RadioButton 0 "do not do it"
|
|
Style warning
|
|
NoNewline
|
|
RadioButton 1 "do it now"
|
|
}
|
|
}
|
|
|
|
proc do_not_change_to_none {{value 2}} {
|
|
global change_device_to_none unplugged_device
|
|
|
|
if {$value == 0} {
|
|
set change_device_to_none 0
|
|
} elseif {$value == 1} {
|
|
set change_device_to_none [clock seconds]
|
|
}
|
|
if {$change_device_to_none == 0} {
|
|
return 0
|
|
}
|
|
if {[clock seconds] >= $change_device_to_none} {
|
|
return 1
|
|
}
|
|
return 2
|
|
}
|
|
|
|
publishLazy do_not_change_to_none
|
|
|
|
proc startAutodeviceCron {} {
|
|
if {[sicscron count autodeviceCron] == 0} {
|
|
sicscron 1 autodeviceCron
|
|
}
|
|
}
|
|
|
|
proc autodevice_cnt {value} {
|
|
set old [silent -1 sct oldvalue]
|
|
if {abs($value - $old) <= abs($value + $old) * 0.01} {
|
|
set update_cnt [sct update_cnt]
|
|
if {$update_cnt < 9} {
|
|
incr update_cnt
|
|
sct update_cnt $update_cnt
|
|
}
|
|
} else {
|
|
sct update_cnt 0
|
|
sct oldvalue $value
|
|
}
|
|
}
|
|
|
|
proc autodeviceCron {} {
|
|
global change_device_to_none unplugged_device
|
|
|
|
logconfig flush
|
|
rack_check_connection
|
|
# act is either: "", "plugged", "renew", "rebuild" or "selected on touch display"
|
|
set act [silent "" result device action]
|
|
set now [clock seconds]
|
|
if {$act eq "renew"} {
|
|
if {[result device ccu4_device] ne "0"} {
|
|
clientput "CCU4 has restarted - configure"
|
|
ccu4_device renew
|
|
}
|
|
device action ""
|
|
} elseif {$act eq "rebuild"} {
|
|
# rebuild SECoP objects after description change
|
|
device action ""
|
|
set objdict [dict create]
|
|
foreach obj [obj_list items] {
|
|
if {[silent 0 hgetpropval /sics/$obj rebuild_addon]} {
|
|
dict set objdict $obj 1
|
|
}
|
|
}
|
|
set rebuildict [dict create]
|
|
foreach addon [addon_list items] {
|
|
foreach aobj [addon_$addon items] {
|
|
if {[dict exists $objdict $aobj]} {
|
|
dict set rebuildict $addon 1
|
|
dict unset objdict $aobj
|
|
}
|
|
}
|
|
}
|
|
if {[llength $objdict]} {
|
|
set device [result device name]
|
|
} else {
|
|
set device ""
|
|
}
|
|
set addons [list]
|
|
set stick [list]
|
|
set stick_name [result device stick_name]
|
|
foreach {addon yes} $rebuildict {
|
|
if {$addon eq $stick_name} {
|
|
lappend stick $addon
|
|
} else {
|
|
lappend addons $addon
|
|
}
|
|
}
|
|
clientput "CONFIG $device/$stick/$addons"
|
|
if {$device eq ""} {
|
|
if {[llength %stick]} {
|
|
addon stick $stick
|
|
}
|
|
foreach addon $addons {
|
|
addon $addon
|
|
}
|
|
} else {
|
|
samenv -q $device/$stick/[join $addons /]
|
|
}
|
|
} elseif {$act ne ""} { # "plugged" or "selected ontouch display"
|
|
set new [silent 0 result device newdevice]
|
|
set change_device_to_none 0
|
|
if {$new eq "none"} {
|
|
if {$act eq "plugged"} {
|
|
set unplugged_device [result device name]
|
|
if {$unplugged_device ne "none"} {
|
|
clientput "unplugged $unplugged_device"
|
|
device makeitem confirmed ""
|
|
set change_device_to_none [expr $now + 60]
|
|
}
|
|
} else {
|
|
clientput "none $act"
|
|
device makeitem confirmed none
|
|
samenv -q none
|
|
}
|
|
} elseif {$act eq "plugged" && $new eq [result device name]} {
|
|
clientput "$new plugged, no change"
|
|
device makeitem confirmed $new
|
|
device makeitem was_unplugged 0
|
|
} else {
|
|
# new has changed and is not none
|
|
if {[result device name] ne "none" && $act eq "plugged" && [silent 0 result device was_unplugged] == 0} {
|
|
clientlog "unplugged time too short [result device name] -> $new"
|
|
# this was a quick hack
|
|
# device makeitem confirmed none
|
|
# catch {samenv -q none} msg
|
|
# clientput $msg
|
|
# return
|
|
} else {
|
|
device makeitem confirmed $new
|
|
clientput "LOAD $new $act"
|
|
catch {samenv -q $new} msg
|
|
clientput $msg
|
|
device makeitem was_unplugged 0
|
|
}
|
|
}
|
|
device action ""
|
|
} else { # act == ""
|
|
set c2n [silent 0 set change_device_to_none]
|
|
if {$c2n != 0 && $now > $c2n} {
|
|
set change_device_to_none 0
|
|
device makeitem confirmed none
|
|
samenv -q none
|
|
}
|
|
if {![device exists force_status_save]} {
|
|
device makeitem force_status_save 0
|
|
} else {
|
|
device force_status_save 0
|
|
}
|
|
}
|
|
set curveD [silent 0 hvali /tt/ts_2/curve]
|
|
if {$curveD eq "0" || $curveD eq "undefined"} {
|
|
if {[string match "stick *" [silent 0 hvali /tt/status]]} {
|
|
hupdate /tt/status ""
|
|
}
|
|
} else {
|
|
source config/stick.list
|
|
set devstk [silent none result device stick_name]
|
|
if {$devstk ne "none"} {
|
|
set rawpath /tt/ts_2/raw
|
|
set r [silent -1 hvali $rawpath]
|
|
set upd [silent -1 hgetpropval $rawpath update_cnt]
|
|
if {$upd == -1} {
|
|
hsetprop $rawpath update_cnt 0
|
|
hsetprop $rawpath last_res_no 0
|
|
_tt updatescript $rawpath autodevice_cnt
|
|
}
|
|
if {$r < -1} {
|
|
set res_no [expr round(log10(-$r) * 12)]
|
|
set last_res_no [hgetpropval $rawpath last_res_no]
|
|
if {$res_no != $last_res_no} {
|
|
hsetprop $rawpath update_cnt 0
|
|
hsetprop $rawpath last_res_no $res_no
|
|
if {[string match "stick *" [silent 0 hvali /tt/status]]} {
|
|
hupdate /tt/status ""
|
|
}
|
|
return
|
|
}
|
|
if {$upd < 3} {
|
|
return
|
|
}
|
|
set found_stick 0
|
|
set bad_sticks [list]
|
|
foreach {stk code} [array get stick_cfgtable] {
|
|
if {$res_no == round(log10($code) * 12)} {
|
|
if {$devstk eq $stk} {
|
|
set found_stick 1
|
|
} else {
|
|
lappend bad_sticks $stk
|
|
}
|
|
}
|
|
}
|
|
if {$found_stick == 0 && [llength $bad_sticks] > 0} {
|
|
# hupdate /tt/status "stick seems not to be $devstk (may be $bad_sticks?)"
|
|
} elseif {[string match "stick *" [hvali /tt/status]]} {
|
|
hupdate /tt/status ""
|
|
}
|
|
} elseif {$r >= 0 && $upd >= 3} { # no code on stick seen
|
|
if {[info exists stick_cfgtable($devstk)]} {
|
|
if {$r == 0} {
|
|
hupdate /tt/status "stick not inserted? use stick 'none'"
|
|
} else {
|
|
hupdate /tt/status "stick with no coding inserted?"
|
|
}
|
|
} elseif {[string match "stick *" [hvali /tt/status]]} {
|
|
hupdate /tt/status ""
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
proc debug args {
|
|
config listen 1
|
|
set verbose 2
|
|
set debug 0
|
|
set info "switch debugging mode on for:"
|
|
if {$args eq "all"} {
|
|
set objects [obj_list items]
|
|
} elseif {$args eq "off"} {
|
|
set objects [obj_list items]
|
|
set debug -1
|
|
set verbose 0
|
|
set info "switch debugging mode off for:"
|
|
} else {
|
|
set objects $args
|
|
}
|
|
foreach obj $objects {
|
|
switch [driverKind $obj term] {
|
|
stdsct - oldsct {
|
|
if {[result $term debug] != $debug} {
|
|
$term debug $debug
|
|
append info " $term/$obj"
|
|
}
|
|
}
|
|
sctcontroller {
|
|
if {[result $obj debug] != $debug} {
|
|
$obj debug $debug
|
|
append info " $obj"
|
|
}
|
|
}
|
|
ease {
|
|
if {[result $obj verbose] != $verbose} {
|
|
$obj verbose $verbose
|
|
append info " $obj"
|
|
}
|
|
}
|
|
}
|
|
}
|
|
clientput $info
|
|
}
|
|
|
|
publishLazy debug
|
|
|
|
proc loggerCheck {node} {
|
|
set logger_name [silent "" hgetprop $node logger_name]
|
|
scan [hinfo $node] {%[a-z],%d,} type children
|
|
if {$logger_name ne ""} {
|
|
if {$type in [list int float]} {
|
|
return -1
|
|
}
|
|
if {[silent "" hgetpropval $node cvtfunc] ne ""} {
|
|
return -1
|
|
}
|
|
if {[silent "" hgetpropval $node enum] ne ""} {
|
|
return -1
|
|
}
|
|
}
|
|
if {$children > 0} {
|
|
return [hdbScan $node/ loggerCheck]
|
|
}
|
|
return 1
|
|
}
|
|
|
|
proc loggerGroup {path} {
|
|
hdbScan $path loggerShow
|
|
}
|
|
|
|
proc loggerShow {node} {
|
|
GraphInput $node
|
|
if {[hdbScan $node/ loggerCheck] < 0} {
|
|
set title [silent "down $node" hgetpropval $node group]
|
|
Group logger $title $node/
|
|
}
|
|
return 0
|
|
}
|
|
|
|
proc grsGroup {path} {
|
|
loggerShow $path
|
|
}
|
|
|
|
proc groGroup {obj} {
|
|
foreach item [$obj loggeditems] {
|
|
GraphInput $item
|
|
}
|
|
}
|
|
|
|
set tt_loggedlist {tt.tm tt.ts tt.set tt.tr tt.te tt.tk tt.he tt.p tt.aux \
|
|
tt.prop tt.int tt.deriv tt.set2 tt.power2 \
|
|
tt.tShift tt.shiftUp tt.shiftLow tt.state \
|
|
tt.ScanChan tt.t0 tt.t1 tt.t2 tt.t3 tt.t4}
|
|
|
|
foreach item $tt_loggedlist {
|
|
set tt_loggeditems($item) 1
|
|
}
|
|
|
|
proc connectionsGroup {} {
|
|
global unconfigured_list
|
|
if {[info exists unconfigured_list]} {
|
|
set list $unconfigured_list
|
|
} else {
|
|
set list [list]
|
|
}
|
|
foreach obj [split [obj_list items]] {
|
|
lappend list $obj
|
|
}
|
|
foreach obj $list {
|
|
if {[cfg_env exists $obj]} {
|
|
set cfg 0
|
|
switch [sicsdescriptor $obj] {
|
|
notfound {
|
|
set cfg 1
|
|
}
|
|
array {}
|
|
SctController {
|
|
set mc [silent {0 0 0 0} hgetpropval /sics/$obj _makecmd]
|
|
if {[lindex $mc 3] eq "without_connection"} {
|
|
# this is a protocol without connection
|
|
set cfg 0
|
|
} else {
|
|
set cfg 2
|
|
}
|
|
}
|
|
default {
|
|
if {[silent 0 $obj creationCmd] eq "0"} {
|
|
# sct object: do not display hostport, is on controller
|
|
set cfg 0
|
|
} else {
|
|
# ease object
|
|
set cfg 3
|
|
}
|
|
}
|
|
}
|
|
if {$cfg > 0} {
|
|
Newline
|
|
Label "[silent $obj result obj_list $obj]:"
|
|
Newline
|
|
Tip "<terminal server>:3000+<channel number>"
|
|
Tip "i.e. pstsXXX:300Y"
|
|
Input "host:port for $obj" "cfgenv $obj" 16
|
|
if {$cfg == 3} {
|
|
NoNewline
|
|
Label [silent "" result $obj status]
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
proc configGroup {} {
|
|
global unconfigured_list
|
|
Group connections "connections"
|
|
foreach obj [split [obj_list items]] {
|
|
set opath [silent 0 hgetpropval /sics/$obj objectPath]
|
|
if {$opath ne "0"} {
|
|
Group grs "graphics for [silent $obj hgetpropval $opath group]" $opath
|
|
} else {
|
|
set desc [sicsdescriptor $obj]
|
|
switch $desc {
|
|
Macro - SctController {
|
|
}
|
|
default {
|
|
Group gro "graphics for [silent $obj result obj_list $obj]" $obj
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
proc showStatus {obj {respectIgnore 0}} {
|
|
set canNotConnect 0
|
|
switch [sicsdescriptor $obj] {
|
|
notfound {
|
|
Newline
|
|
Style warning
|
|
set nam [silent 0 result desc_env $obj]
|
|
if {$nam eq "0"} {
|
|
set nam $obj
|
|
} else {
|
|
set nam "$obj ($nam)"
|
|
}
|
|
Tip "check setting of serial connections"
|
|
Label "$nam: connection port unconfigured"
|
|
}
|
|
Macro {}
|
|
default {
|
|
set s [silent "" result $obj status]
|
|
if {$s eq "no response" && [silent 0 hgetpropval /sics/$obj ignore_no_response]} {
|
|
set s ""
|
|
}
|
|
if {$respectIgnore} {
|
|
if {[ignoreMsg $obj]} {
|
|
set s ""
|
|
}
|
|
}
|
|
if {$s ne ""} {
|
|
Newline
|
|
Style warning
|
|
set nam [result obj_list $obj]
|
|
if {[cfg_env exists $obj]} {
|
|
Tip "$nam: check cabling and setting of serial connections"
|
|
} else {
|
|
Tip $nam
|
|
}
|
|
Label "$obj: $s"
|
|
# if {[string match "*no*response*" $s] || [string match "disconnected*" $s] || [string match "offline*" $s]}
|
|
if {[string match "*no*response*" $s] || [string match "disconnected*" $s]} {
|
|
NoNewline
|
|
Style warning
|
|
CheckBox "reconnect" "reconnect_object $obj/0"
|
|
} else {
|
|
set canNotConnect 1
|
|
}
|
|
if {$respectIgnore} {
|
|
NoNewline
|
|
Style warning
|
|
CheckBox "ignore" "ignoreMsg $obj"
|
|
} elseif {[ignoreMsg $obj]} {
|
|
Style warning
|
|
CheckBox "ignore error message in header" "ignoreMsg $obj"
|
|
}
|
|
Newline
|
|
}
|
|
}
|
|
}
|
|
return $canNotConnect
|
|
}
|
|
|
|
proc ignoreMsg {obj {ignore read}} {
|
|
if {$obj eq 0} {
|
|
# clear ignore messages
|
|
foreach obj [ignore_msg items] {
|
|
ignore_msg makeitem $obj ""
|
|
}
|
|
return
|
|
}
|
|
set status [silent "" result $obj status]
|
|
if {$ignore eq "read"} {
|
|
# check ignore flag
|
|
set imsg [silent "" result ignore_msg $obj]
|
|
if {$imsg eq $status || $imsg eq "always"} {
|
|
return 1
|
|
}
|
|
return 0
|
|
}
|
|
if {$ignore == 0} {
|
|
ignore_msg makeitem $obj ""
|
|
} elseif {$ignore eq "always"} {
|
|
ignore_msg makeitem $obj "always"
|
|
} else {
|
|
ignore_msg makeitem $obj $status
|
|
}
|
|
}
|
|
|
|
publishLazy ignoreMsg
|
|
|
|
proc ObjState {} {
|
|
global unconfigured_list
|
|
if {[info exists unconfigured_list]} {
|
|
set list $unconfigured_list
|
|
} else {
|
|
set list [list]
|
|
}
|
|
foreach obj [split [obj_list items]] {
|
|
lappend list $obj
|
|
}
|
|
set canNotConnect 0
|
|
set showRackList 0
|
|
set rack [silent no result device rack]
|
|
foreach obj $list {
|
|
if {$obj eq "_cc"} {
|
|
set canNotConnect [showStatus _cc 1]
|
|
if {$canNotConnect || $rack eq "no"} {
|
|
set showRackList 1
|
|
}
|
|
} else {
|
|
showStatus $obj 1
|
|
}
|
|
}
|
|
if {[result device name] eq "none"} {
|
|
set showRackList 1
|
|
} elseif {$canNotConnect} {
|
|
Style warning
|
|
if {[silent no result device rack] eq "other"} {
|
|
Label "can not connect to CCU"
|
|
Newline
|
|
Style hotwarning
|
|
Label "please check the network connection to the device server"
|
|
Style hotwarning
|
|
Label "or configure the connection to ccu4 or select rack"
|
|
} else {
|
|
if {[silent no result device rack] eq "no"} {
|
|
Label "no rack selected"
|
|
} else {
|
|
Label "probably wrong rack selected"
|
|
}
|
|
Style hotwarning
|
|
Label "please select rack (rack number as labelled on the top of the rack)"
|
|
}
|
|
}
|
|
if {$showRackList} {
|
|
Group rack "choose rack"
|
|
}
|
|
}
|
|
|
|
proc Item {name desc} {
|
|
Tip $desc
|
|
RadioButton $name
|
|
}
|
|
|
|
proc listSelectDir {fil show} {
|
|
global shown_groups
|
|
global done_codes
|
|
|
|
clientput -a
|
|
while {[gets $fil line] >= 0} {
|
|
set s [split [string trim $line]]
|
|
if {[lindex $s 0] eq "END"} {
|
|
return
|
|
}
|
|
if {[llength $s] >= 2 && ([lindex $s 0] eq "GROUP")} {
|
|
set desc [lrange $s 1 end]
|
|
set grp [lindex $s 1]
|
|
if {$show} {
|
|
clientput "-T$desc"
|
|
clientput "-GS_$grp"
|
|
if {[info exists shown_groups(S_$grp)]} {
|
|
RadioGroup "samenv -q" [result device name]
|
|
listSelectDir $fil 1
|
|
clientput "-E1"
|
|
} else {
|
|
listSelectDir $fil 0
|
|
clientput "-E0"
|
|
}
|
|
} else {
|
|
listSelectDir $fil 0
|
|
}
|
|
} else {
|
|
foreach dev [lsort [glob -nocomplain $s.config]] {
|
|
if {[file exists $dev]} {
|
|
set code [file rootname $dev]
|
|
if {$show && ! [info exists done_codes($code)]} {
|
|
if {$code eq "none"} {
|
|
RadioButton reload "reload [samenv name]"
|
|
}
|
|
RadioButton $code "$code ([findDesc $dev deviceDesc])"
|
|
Newline
|
|
}
|
|
set done_codes($code) 1
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
proc webDeviceGroup {} {
|
|
global shown_groups
|
|
global done_codes
|
|
|
|
array unset done_codes
|
|
if {[catch {set fil [open config/device.list]}]} {
|
|
return [list]
|
|
}
|
|
clientput "-Tnone"
|
|
set idx 0
|
|
RadioGroup "samenv -q$idx" [result device name]
|
|
RadioButton reload "reload [samenv name]"
|
|
set failure [catch {
|
|
# clientput -a
|
|
while {[gets $fil line] >= 0} {
|
|
set s [split [string trim $line]]
|
|
if {[lindex $s 0] eq "END"} {
|
|
continue
|
|
}
|
|
if {[llength $s] >= 2 && ([lindex $s 0] eq "GROUP")} {
|
|
# group desc
|
|
set grp [lindex $s 1]
|
|
set desc [lrange $s 1 end]
|
|
clientput "-T$desc"
|
|
incr idx
|
|
RadioGroup "samenv -q$idx" [result device name]
|
|
} else {
|
|
foreach dev [lsort [glob -nocomplain $s.config]] {
|
|
if {[file exists $dev]} {
|
|
set code [file rootname $dev]
|
|
if {! [info exists done_codes($code)]} {
|
|
RadioButton $code "$code ([findDesc $dev deviceDesc])"
|
|
Newline
|
|
}
|
|
set done_codes($code) 1
|
|
}
|
|
}
|
|
}
|
|
}
|
|
} msg]
|
|
close $fil
|
|
if {$failure} {
|
|
error $msg
|
|
}
|
|
}
|
|
|
|
proc selectList {} {
|
|
global done_codes
|
|
global shown_groups
|
|
|
|
array unset done_codes
|
|
if {[result device frappy_u_config]} {
|
|
CheckBox "device controlled by NICOS/Frappy" "device frappy_u_config"
|
|
Newline
|
|
Style warning
|
|
Label "the frappy main server is killed when the device is changed"
|
|
Newline
|
|
Style warning
|
|
Label "or on deactivation of above check box"
|
|
Newline
|
|
}
|
|
if {[catch {set fil [open config/device.list]}] == 0} {
|
|
RadioGroup "samenv -q" [result device name]
|
|
listSelectDir $fil 1
|
|
close $fil
|
|
}
|
|
}
|
|
|
|
proc -deviceGroup {} {
|
|
NarrowColumn
|
|
# OkButton 1 "Change Device"
|
|
# SwitchButton 1 "Cancel"
|
|
# Newline
|
|
|
|
# samenv list Item
|
|
|
|
selectList
|
|
# Newline
|
|
# OkButton 2 "Change Device"
|
|
# SwitchButton 2 "Cancel"
|
|
# Newline
|
|
}
|
|
|
|
proc Layout {func args} {
|
|
device_layout makeitem $func "[join $args]"
|
|
}
|
|
|
|
proc otherSticksGroup {} {
|
|
global stick_menu
|
|
RadioGroup "addon stick"
|
|
set list [lsort [glob *.stick]]
|
|
foreach stickFile $list {
|
|
scan $stickFile "%\[^.]" stick
|
|
if {![info exists stick_menu($stick)] && $stick ne "none"} {
|
|
RadioButton $stick "$stick ([findDesc $stickFile stickDesc])"
|
|
Newline
|
|
}
|
|
}
|
|
}
|
|
|
|
proc -sticksGroup {} {
|
|
global stick_menu
|
|
if {[result device frappy_u_stick]} {
|
|
CheckBox "stick is controlled by NICOS/Frappy" "device frappy_u_stick"
|
|
Newline
|
|
Style warning
|
|
Label "the frappy stick server is killed when the stick is changed"
|
|
Newline
|
|
Style warning
|
|
Label "or on deactivation of above check box"
|
|
Newline
|
|
}
|
|
RadioGroup "addon stick"
|
|
# close group after clicking on radio button:
|
|
clientput -a
|
|
if {[result device stick_menu] eq "all"} {
|
|
set stick all
|
|
} else {
|
|
array unset stick_menu
|
|
foreach stick [split [result device stick_menu]] {
|
|
if {$stick eq "noother"} {
|
|
break
|
|
}
|
|
RadioButton $stick "$stick ([findDesc ${stick}.stick stickDesc])"
|
|
Newline
|
|
set stick_menu($stick) 1
|
|
}
|
|
}
|
|
if {$stick ne "noother"} {
|
|
Group otherSticks "other sticks"
|
|
RadioButton none
|
|
Newline
|
|
RadioButton cancel
|
|
}
|
|
}
|
|
|
|
#proc -sticksGroup {} {
|
|
# sticksGroup
|
|
#}
|
|
|
|
proc addonDesc args {
|
|
# save addon name at a meaningful place
|
|
}
|
|
|
|
proc select_addon {addon {value none}} {
|
|
set old [addon_list exists $addon]
|
|
if {$old} {
|
|
if {[result addon_list $addon] eq "permanent"} {
|
|
set old 2
|
|
}
|
|
}
|
|
if {$value eq "none" || $old == $value} {
|
|
return $old
|
|
}
|
|
if {$value == 2} {
|
|
addon permanent $addon
|
|
} elseif {$value} {
|
|
addon $addon
|
|
} else {
|
|
addon delete $addon
|
|
}
|
|
}
|
|
|
|
publishLazy select_addon
|
|
|
|
proc -addonGroup {} {
|
|
if {[result device frappy_u_addon]} {
|
|
CheckBox "addons are controlled by NICOS/Frappy" "device frappy_u_addon"
|
|
Newline
|
|
Style warning
|
|
Label "the frappy addons server is killed when an addon is removed"
|
|
Newline
|
|
Style warning
|
|
Label "or on deactivation of above check box"
|
|
Newline
|
|
}
|
|
set list [lsort [glob *.addon]]
|
|
foreach addonFile $list {
|
|
scan $addonFile "%\[^.]" addon
|
|
CheckBox "$addon ([findDesc $addonFile addonDesc])" "select_addon $addon"
|
|
NoNewline
|
|
switch [select_addon $addon] {
|
|
1 {
|
|
RadioGroup "select_addon $addon"
|
|
RadioButton 2 "make permanent"
|
|
}
|
|
2 {
|
|
Label permanent
|
|
}
|
|
}
|
|
Newline
|
|
}
|
|
#RadioButton cancel
|
|
}
|
|
|
|
proc webSelectGroup {} {
|
|
# group name starting with '-': group is hidden until activated with button
|
|
set u_device [hval /device/name_label]
|
|
set u_stick ""
|
|
if {[result device stick_menu] ne ""} {
|
|
set u_stick [hval /device/stick_label]
|
|
}
|
|
clientput "-Tselect device"
|
|
Group webDevice "select device ($u_device)"
|
|
if {$u_stick ne ""} {
|
|
Group -sticks "select stick ($u_stick)"
|
|
}
|
|
set u_adds [addon list]
|
|
if {[llength $u_adds] == 0} {
|
|
set u_adds ""
|
|
} else {
|
|
set u_adds " ($u_adds)"
|
|
}
|
|
Group -addon "select addon$u_adds"
|
|
}
|
|
|
|
proc mainGroup {{forweb ""}} {
|
|
global tt device_name test_betrieb shown_groups
|
|
|
|
# clientput "FORWEB $forweb"
|
|
GraphicsId [result vars]
|
|
Tip "[result deviceDesc]"
|
|
Style header
|
|
if {[info exists test_betrieb]} {
|
|
Label Test-Betrieb
|
|
Newline
|
|
Label Markus ist am Testen
|
|
# hdbLayout
|
|
Newline
|
|
Style header
|
|
}
|
|
Label [string toupper [result instrument]]
|
|
NoNewline
|
|
|
|
set u_device [silent [string toupper [hval /device/name]] hval /device/name_label]
|
|
set lab "Device: $u_device"
|
|
SelectButton -device $lab
|
|
NoNewline
|
|
set u_stick ""
|
|
if {[result device stick_menu] ne ""} {
|
|
set u_stick [silent [string toupper [hval /device/stick_name]] hval /device/stick_label]
|
|
SelectButton "-sticks" "Stick: $u_stick"
|
|
NoNewline
|
|
}
|
|
set u_adds [addon list]
|
|
set adds [addon list]
|
|
if {[llength $adds] == 0} {
|
|
set adds Add
|
|
set u_adds ""
|
|
} else {
|
|
set adds "Add:$adds"
|
|
set u_adds " ($u_adds)"
|
|
}
|
|
SelectButton "-addon" $adds
|
|
|
|
if {$forweb == ""} {
|
|
# for classic SEA client:
|
|
# group name starting with '-': group is hidden until activated with button
|
|
Group -device "select device ($u_device)"
|
|
if {$u_stick ne ""} {
|
|
Group -sticks "select stick ($u_stick)"
|
|
}
|
|
Group -addon "select addon$u_adds"
|
|
} else {
|
|
# for seaweb:
|
|
Group webSelect "select device/stick/addon"
|
|
}
|
|
|
|
Newline
|
|
catch {ConfigState}
|
|
catch {TsState}
|
|
catch {ChnState}
|
|
ObjState
|
|
Newline
|
|
foreach p [device_layout items] {
|
|
if {[string index $p 0] eq "/"} {
|
|
hdbLayout $p
|
|
} else {
|
|
if {[catch {eval ${p}Layout [result device_layout $p]} msg]} {
|
|
Style Warning
|
|
Label $msg
|
|
}
|
|
}
|
|
}
|
|
if {![device_layout exists visibility]
|
|
|| [info exists shown_groups(expertMode)] } {
|
|
Group config "configuration"
|
|
}
|
|
}
|
|
|
|
proc make_array {name args} {
|
|
global $name
|
|
foreach n $args {
|
|
set ${name}($n) ""
|
|
}
|
|
}
|
|
|
|
proc find_interval {table rev section x} {
|
|
# find the interval containing x in a table
|
|
#
|
|
# arguments:
|
|
# table a 1D list x(0) y(0) x(1) y(1) .... x(n) y(n).
|
|
# The table does not need to be ordered.
|
|
# A list with an odd length triggers an error.
|
|
# rev 1 for inverting the table (exchange x and y)
|
|
# section the name of a variable to store the section as a list: x(a) y(a) x(b) y(b)
|
|
# x the value to be found
|
|
#
|
|
# an empty table is replaced by 0 0
|
|
# the result allows to distinguish differnt cases:
|
|
# 0: (normal case) a section was found with was found xa <= x <= xb, section = x(a) y(a) x(b) y(b)
|
|
# -1: the table contained one single pair, x < x(0), section = x(0) y(0) x(0) y(0)
|
|
# 1: the table contained one single pair, x >= x(0), section = x(0) y(0) x(0) y(0)
|
|
# -2: x is lower than the lowest value in the table, section = x(0) y(0) x(1) y(1)
|
|
# 2: x is higher than the highest value in the table, section = x(n-1) y(n-1) x(n) y(n)
|
|
|
|
upvar $section s
|
|
|
|
if {[llength $table] % 2 != 0} {
|
|
error "find_interval: table length must be even"
|
|
}
|
|
if {$rev} {
|
|
set var {yi xi}
|
|
} else {
|
|
set var {xi yi}
|
|
}
|
|
set n [expr [llength $table]/2]
|
|
if {$n == 0} {
|
|
set n 2
|
|
set table [list 0 0]
|
|
}
|
|
set a_empty 1
|
|
set b_empty 1
|
|
# find next higher and next lower x and their y value, result in xa xb ya yb
|
|
foreach $var $table {
|
|
if {$xi <= $x} {
|
|
if {$a_empty || $xi > $xa} {
|
|
set xa $xi
|
|
set ya $yi
|
|
set a_empty 0
|
|
}
|
|
} else {
|
|
if {$b_empty || $xi < $xb} {
|
|
set xb $xi
|
|
set yb $yi
|
|
set b_empty 0
|
|
}
|
|
}
|
|
}
|
|
if {$a_empty} {
|
|
# no lower xi found, look for second lowest xi
|
|
foreach $var $table {
|
|
if {$xi > $xb && ($a_empty || $xi < $xa)} {
|
|
set xa $xi
|
|
set ya $yi
|
|
set a_empty 0
|
|
}
|
|
}
|
|
if {$a_empty} {
|
|
set s [list $xb $yb $xb $yb]
|
|
return -1
|
|
}
|
|
set s [list $xb $yb $xa $ya]
|
|
return -2
|
|
} elseif {$b_empty} {
|
|
# no higher x found, look for second highest x
|
|
foreach $var $table {
|
|
if {$xi < $xa && ($b_empty || $xi > $xb)} {
|
|
set xb $xi
|
|
set yb $yi
|
|
set b_empty 0
|
|
}
|
|
}
|
|
if {$b_empty} {
|
|
set s [list $xa $ya $xa $ya]
|
|
return 1
|
|
}
|
|
if {$x == $xa} {
|
|
set s [list $xb $yb $xb $yb]
|
|
return 1
|
|
}
|
|
set s [list $xb $yb $xa $ya]
|
|
return 2
|
|
}
|
|
set s [list $xa $ya $xb $yb]
|
|
return 0
|
|
}
|
|
|
|
proc interpolate {table rev x args} {
|
|
set res [find_interval $table $rev intval $x]
|
|
set logx 0
|
|
set logy 0
|
|
set slope [list]
|
|
foreach a $args {
|
|
switch -- $a {
|
|
logx {
|
|
set logx 1
|
|
}
|
|
logy {
|
|
set logy 1
|
|
}
|
|
extrapolate {
|
|
if {abs($res) == 2} {
|
|
# treat outside cases like inside cases
|
|
set res 0
|
|
}
|
|
}
|
|
default {
|
|
lappend slope $a
|
|
}
|
|
}
|
|
}
|
|
set x0 [expr [lindex $intval 0]]
|
|
set y0 [expr [lindex $intval 1]]
|
|
set x1 [expr [lindex $intval 2]]
|
|
set y1 [expr [lindex $intval 3]]
|
|
if {$logx} {
|
|
if [catch {set x0 [expr log($x0)]}] {
|
|
set x0 -88
|
|
}
|
|
if [catch {set x1 [expr log($x1)]}] {
|
|
set x1 -88
|
|
}
|
|
if [catch {set x [expr log($x)]}] {
|
|
set x -88
|
|
}
|
|
}
|
|
if {$logy} {
|
|
if [catch {set y0 [expr log($y0)]}] {
|
|
set y0 -88
|
|
}
|
|
if [catch {set y1 [expr log($y1)]}] {
|
|
set y1 -88
|
|
}
|
|
}
|
|
|
|
if {$res != 0} {
|
|
# outside cases
|
|
if {[llength $slope] == 0} {
|
|
set slope 1
|
|
}
|
|
if {$res < 0} {
|
|
set slope [lindex $slope 0]
|
|
} else {
|
|
set slope [lindex $slope end]
|
|
set x0 $x1
|
|
set y0 $y1
|
|
}
|
|
} else {
|
|
set slope [expr ($y1 - $y0) / double($x1 - $x0)]
|
|
}
|
|
set y [expr $y0 + $slope * ($x - $x0)]
|
|
if {$logy} {
|
|
if {$y > 88} {
|
|
set y 88
|
|
}
|
|
set y [expr exp($y)]
|
|
}
|
|
return $y
|
|
}
|
|
|
|
proc parseValueUnit {str unitvar} {
|
|
upvar $unitvar unit
|
|
set value 0
|
|
set unit ""
|
|
if {[scan $str "%f%s" value unit] != 2} {
|
|
return $value
|
|
}
|
|
set idx [string first [string index $unit 0] afpnum0kMGT]
|
|
if {$idx < 0} {
|
|
#no prefix
|
|
return [expr double($value)]
|
|
}
|
|
set unit [string range $unit 1 end]
|
|
return [expr $value * pow(10.0,$idx * 3 - 18)]
|
|
}
|
|
|
|
proc formatWithUnit {value {mindig 1}} {
|
|
set dig [expr $mindig - 1]
|
|
if {$dig < 0} {set dig 0}
|
|
set me [split [format "%.${dig}e" $value] e]
|
|
scan $me "%s %d" mant exp
|
|
if {$exp < -18 || $exp > 14} {
|
|
return [join $me e]
|
|
}
|
|
if {$exp % 3 > 0} {
|
|
if {$exp % 3 == 2} {
|
|
incr exp -2
|
|
incr dig -2
|
|
} else {
|
|
incr exp -1
|
|
incr dig -1
|
|
}
|
|
if {$dig < 0} {set dig 0}
|
|
set mant [format %.${dig}f [expr $value / pow(10,$exp)]]
|
|
}
|
|
if {$exp == 0} {
|
|
return $mant
|
|
}
|
|
return "$mant[string index afpnum0kMGT [expr ($exp+18)/3]]"
|
|
}
|
|
|
|
proc default {{cmd list} args} {
|
|
if {$cmd eq "clear"} {
|
|
removeobject default_list
|
|
}
|
|
if {[sicsdescriptor default_list] eq "notfound"} {
|
|
makeobject default_list array
|
|
default_list makeitem "device.name"
|
|
default_list makeitem "device.stick_name"
|
|
}
|
|
switch -- $cmd {
|
|
clear {
|
|
foreach item [default_list items] {
|
|
if {![string match device.* $item]} {
|
|
default_list deleteitem $item
|
|
}
|
|
}
|
|
return ""
|
|
}
|
|
list {
|
|
# list and save
|
|
set res ""
|
|
foreach item [default_list items] {
|
|
set cmd [split $item .]
|
|
set val [silent "NoValue" result $cmd]
|
|
if {$val ne "NoValue"} {
|
|
append res "$cmd $val\n"
|
|
default_list $item $val
|
|
}
|
|
}
|
|
return $res
|
|
}
|
|
name {
|
|
if {"$args" ne ""} {
|
|
default_list makeitem device.name "$args"
|
|
}
|
|
return [result default_list device.name]
|
|
}
|
|
stick {
|
|
if {"$args" ne ""} {
|
|
default_list makeitem device.stick_name "$args"
|
|
}
|
|
return [result default_list device.stick_name]
|
|
}
|
|
load {
|
|
clientput "--- load defaults ---"
|
|
foreach item [default_list items] {
|
|
set cmd [split $item .]
|
|
set val [result default_list $item]
|
|
clientput "$cmd $val"
|
|
if {$val ne "NoValue"} {
|
|
catch { eval "$cmd $val" }
|
|
}
|
|
}
|
|
clientput "---"
|
|
}
|
|
default {
|
|
set item [join [concat $cmd $args] .]
|
|
if {![default_list exists $item]} {
|
|
default_list makeitem $item
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
publishLazy default
|
|
|
|
proc source_sct_driver {driver} {
|
|
global startupList
|
|
|
|
foreach type [list $driver [lindex [split $driver _] end]] {
|
|
set script drivers/${type}.tcl
|
|
if {[file exists $script]} {
|
|
set modtime [file mtime $script]
|
|
if {![info exists startupList($script)]} {
|
|
set startupList($script) 0
|
|
}
|
|
if {$startupList($script) ne $modtime} {
|
|
if {[catch {source drivers/${type}.tcl} msg]} {
|
|
clientput "ERROR: in ${type}.tcl:"
|
|
clientput $msg
|
|
return 2
|
|
}
|
|
clientput "loaded $script"
|
|
set startupList($script) $modtime
|
|
}
|
|
return 1
|
|
}
|
|
}
|
|
return 0
|
|
}
|
|
|
|
proc read_file {file} {
|
|
set contents ""
|
|
set fd ""
|
|
# catch {
|
|
set fd [open $file r]
|
|
# catch {
|
|
set contents [read $fd]
|
|
# }
|
|
close $fd
|
|
# }
|
|
return $contents
|
|
}
|
|
|
|
proc noTecs {} {
|
|
defineTemperature tt
|
|
}
|
|
|
|
proc reload {} {
|
|
global startupList
|
|
# add here scripts which may be needed to reload (sourced in drivers)
|
|
set stdlist {
|
|
seacom.tcl stdsct.tcl
|
|
drivers/magfield.tcl drivers/trun.tcl drivers/lsc.tcl
|
|
}
|
|
catch {
|
|
lappend stdlist drivers/secop_[silent x set ::secop_version].tcl
|
|
}
|
|
if {[result instrument] eq "seaman"} {
|
|
append stdlist " seamancom.tcl"
|
|
}
|
|
set i [result instrument]
|
|
set filelist [concat $stdlist [glob startup/*.tcl]]
|
|
do_as_manager {
|
|
foreach script [concat $filelist [array names startupList]] {
|
|
if {![info exists startupList($script)]} {
|
|
set startupList($script) 0
|
|
}
|
|
# if file does no more exist, take old mtime in order not to trigger reload
|
|
set modtime [silent $startupList($script) file mtime $script]
|
|
if {$startupList($script) ne $modtime} {
|
|
if {[catch { uplevel #0 "source $script" } msg]} {
|
|
clientput "ERROR: in $script"
|
|
clientput $msg
|
|
} else {
|
|
clientput "loaded $script"
|
|
set startupList($script) $modtime
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
publishLazy reload
|
|
|
|
proc plugin {plugin args} {
|
|
# mechanism to call external programs in a safe way
|
|
# simple programs using stdout as output may just added to the first
|
|
# switch branch
|
|
if {![file exists [pwd]/plugin/$plugin]} {
|
|
error "unknown plugin: $plugin"
|
|
}
|
|
set cmd [linsert $args 0 exec [pwd]/plugin/safeplugin $plugin]
|
|
return [eval $cmd]
|
|
}
|
|
|
|
publishLazy plugin
|
|
|
|
proc _tcl args {
|
|
eval $args
|
|
}
|
|
|
|
publishLazy _tcl
|
|
|
|
global startupList
|
|
set startupList(seacom.tcl) [file mtime seacom.tcl]
|
|
|
|
reload
|
|
|
|
clientput "seacom.tcl completed"
|