#--------------------------------------------------------------------------- # 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 - [ ] 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 :\[:\]" clientput " (port is usually 3000 + channel number)" clientput " cfgenv remove " clientput " cfgenv remove " # 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 :\[:\]" } 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 " clientput " obj_dependency set 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 " clientput " obj_dependency kill " 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 " } 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) \[\] \[\]" } } } 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 " } 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 " } 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 " } 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\] " } 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 ":3000+" 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"