initial commit
This commit is contained in:
l_samenv
310
tcl/startup/sea_man.tcl
Normal file
310
tcl/startup/sea_man.tcl
Normal file
@ -0,0 +1,310 @@
|
||||
# bookkeeping of moving items
|
||||
|
||||
proc TsState {} {
|
||||
global ts_status disconnect_time
|
||||
set tslist [list]
|
||||
# if {[info exists ts_status]} {
|
||||
# Newline
|
||||
# Style warning
|
||||
# Label $ts_status
|
||||
# NoNewline
|
||||
# Style warning
|
||||
# CheckBox redo check_connections
|
||||
# }
|
||||
|
||||
if {[info exists disconnect_time(0)] && [DoubleTime] > $disconnect_time(0) + 4} {
|
||||
connection_details 1
|
||||
}
|
||||
foreach ts [silent "" ts_busy items] {
|
||||
set ins [result ts_busy $ts]
|
||||
set ilist($ins) 1
|
||||
set hlist([lindex [split $ts ":"] 0]) 1
|
||||
lappend tslist $ts $ins
|
||||
if {[connection_details]} {
|
||||
Newline
|
||||
Style hotwarning
|
||||
set INS [string toupper $ins]
|
||||
if {[info exists disconnect_time($ts)]} {
|
||||
if {[DoubleTime] < $disconnect_time($ts) + 4} {
|
||||
Label "trying to disconnect $ts from $INS"
|
||||
} else {
|
||||
CheckBox "unbook (only if you are sure $INS is not using $ts)" "forced_disconnect $ts"
|
||||
}
|
||||
} else {
|
||||
Tip "$ts is still connected to $INS"
|
||||
CheckBox "disconnect $ts from $INS" "remote_disconnect $ts $ins/0"
|
||||
}
|
||||
}
|
||||
}
|
||||
if {[llength $tslist] == 0} {
|
||||
if {[array exists disconnect_time]} {
|
||||
array unset disconnect_time
|
||||
connection_details 0
|
||||
}
|
||||
return
|
||||
}
|
||||
set insts [array names ilist]
|
||||
if {[connection_details]} {
|
||||
Newline
|
||||
Style hotwarning
|
||||
CheckBox "show details" "connection_details"
|
||||
} elseif {[llength $insts] eq 1} {
|
||||
set rdev [string toupper [result device_on $insts]]
|
||||
set INS [string toupper $insts]
|
||||
Newline
|
||||
Style hotwarning
|
||||
if {[info exists disconnect_time(0)]} {
|
||||
Label "trying to disconnect $rdev from $INS"
|
||||
} else {
|
||||
Tip "$rdev is still connected to $INS"
|
||||
CheckBox "disconnect $rdev from $INS" "remote_device_none $insts/0"
|
||||
}
|
||||
NoNewline
|
||||
Style hotwarning
|
||||
CheckBox "show details" "connection_details"
|
||||
} else {
|
||||
if {[llength $tslist] > 2} {
|
||||
set ts [join [array names hlist] ,]
|
||||
if {[llength [array names hlist]] > 1} {
|
||||
append ts " are"
|
||||
} else {
|
||||
append ts " is"
|
||||
}
|
||||
} else {
|
||||
set ts "[lindex $tslist 0] is"
|
||||
}
|
||||
Newline
|
||||
Style hotwarning
|
||||
Tip "$ts already connected to [string toupper [join $insts ,]]"
|
||||
CheckBox "disconnect $ts from [string toupper [join $insts ,]]" "remote_disconnect $tslist/0"
|
||||
if {[llength $tslist] > 2} {
|
||||
NoNewline
|
||||
Style hotwarning
|
||||
CheckBox "show details" "connection_details"
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
set connection_details 0
|
||||
|
||||
proc connection_details {{on query}} {
|
||||
global connection_details
|
||||
if {$on ne "query"} {
|
||||
set connection_details $on
|
||||
}
|
||||
return $connection_details
|
||||
}
|
||||
|
||||
proc disconnect_from {caller args} {
|
||||
foreach arg $args {
|
||||
set todo($arg) 1
|
||||
}
|
||||
set answer ""
|
||||
set confirm [list]
|
||||
foreach obj [obj_list items] {
|
||||
set type [driverKind $obj hostport]
|
||||
if {[info exists todo($hostport)]} {
|
||||
$obj disconnect
|
||||
append answer "disconnect $obj from $hostport\n"
|
||||
unset todo($hostport)
|
||||
lappend confirm $hostport
|
||||
}
|
||||
}
|
||||
foreach hp [array names todo] {
|
||||
append answer "no object found connected to $hp\n"
|
||||
lappend confirm $hp
|
||||
}
|
||||
if {[llength $confirm] != 0} {
|
||||
if {$caller ne "0"} {
|
||||
seaman / "book_confirm $caller $confirm"
|
||||
}
|
||||
}
|
||||
if {$answer eq ""} {
|
||||
append answer "nothing to disconnect"
|
||||
}
|
||||
clientput $answer
|
||||
return
|
||||
}
|
||||
|
||||
proc save_samenv {{dev ""}} {
|
||||
if {[sicsdescriptor seaman] eq "notfound"} {
|
||||
return
|
||||
}
|
||||
if {$dev eq ""} {
|
||||
set dev [samenv name]
|
||||
}
|
||||
seaman / "samenv_list makeitem [result instrument] $dev"
|
||||
}
|
||||
|
||||
publishLazy save_samenv
|
||||
|
||||
proc web_port {port} {
|
||||
device makeitem webport $port
|
||||
save_samenv
|
||||
}
|
||||
|
||||
proc is_mobile_port {hostport} {
|
||||
# returns 0 when hostport is local to the instrument or a special value
|
||||
lassign [split $hostport :] host port
|
||||
if {$port eq "" || $host eq "samenv" || $host eq "localhost" || [string match "sample-ts*" $host]} {
|
||||
return 0
|
||||
}
|
||||
return 1
|
||||
}
|
||||
|
||||
proc request_items {device} {
|
||||
global serverport ts_status
|
||||
|
||||
if {[sicsdescriptor seaman] eq "notfound"} {
|
||||
return
|
||||
}
|
||||
foreach d [ts_busy items] {
|
||||
ts_busy deleteitem $d
|
||||
}
|
||||
set items {}
|
||||
foreach obj [obj_list items] {
|
||||
set hostport 0
|
||||
driverKind $obj hostport
|
||||
if {[is_mobile_port $hostport]} {
|
||||
lappend items $hostport
|
||||
}
|
||||
}
|
||||
seaman / "book_request [result instrument] [info hostname]:$serverport $device $items"
|
||||
set ts_status "Checking serial connections ..."
|
||||
}
|
||||
|
||||
proc check_connections {{value -1}} {
|
||||
global ts_status
|
||||
if {$value == 1} {
|
||||
request_items [result device name]
|
||||
} elseif {[info exists ts_status]} {
|
||||
clientput $ts_status
|
||||
} else {
|
||||
clientput ok
|
||||
}
|
||||
}
|
||||
|
||||
proc reconnect_object {obj {value 0}} {
|
||||
global serverport ts_status
|
||||
|
||||
switch [driverKind $obj hostport] {
|
||||
stdsct {
|
||||
set obj $hostport
|
||||
driverKind $obj hostport
|
||||
}
|
||||
sctcontroller - ease {
|
||||
}
|
||||
default {
|
||||
error "unknown object for reconnect"
|
||||
}
|
||||
}
|
||||
if {[is_mobile_port $hostport]} {
|
||||
seaman / "book_request [result instrument] [info hostname]:$serverport PARTIAL $hostport"
|
||||
set ts_status "Checking serial connection ..."
|
||||
}
|
||||
}
|
||||
|
||||
proc reconnect_or_set_busy args {
|
||||
global ts_status
|
||||
catch {unset ts_status}
|
||||
foreach a $args {
|
||||
if {[llength $a] > 1} {
|
||||
set item [lindex $a 0]
|
||||
set instr [lindex $a 1]
|
||||
if {[llength $a] > 2} {
|
||||
device_on makeitem $instr [lindex $a 2]
|
||||
}
|
||||
if {$instr eq "[result instrument]"} {
|
||||
if {[ts_busy exists $item]} {
|
||||
ts_busy deleteitem $item
|
||||
}
|
||||
set todo($item) 1
|
||||
} else {
|
||||
ts_busy makeitem $item $instr
|
||||
}
|
||||
} else {
|
||||
set item $a
|
||||
if {[ts_busy exists $item]} {
|
||||
ts_busy deleteitem $item
|
||||
}
|
||||
}
|
||||
}
|
||||
set answer ""
|
||||
foreach obj [obj_list items] {
|
||||
set type [driverKind $obj item]
|
||||
if {[info exists todo($item)]} {
|
||||
append answer "reconnect $obj to $item\n"
|
||||
$obj reconnect
|
||||
}
|
||||
}
|
||||
clientput $answer
|
||||
return
|
||||
}
|
||||
|
||||
proc remote_disconnect {args} {
|
||||
global disconnect_time
|
||||
if {[string length [lindex $args end]] == 1} {
|
||||
set args [lrange $args 0 end-1]
|
||||
}
|
||||
foreach {item instr} $args {
|
||||
set disconnect_time($item) [DoubleTime]
|
||||
}
|
||||
seaman / "book_this [result instrument] $args"
|
||||
}
|
||||
|
||||
proc forced_disconnect {item {value 0}} {
|
||||
global disconnect_time
|
||||
if {$value} {
|
||||
catch {unset disconnect_time($item)}
|
||||
seaman / "book_confirm [result instrument] $item"
|
||||
} else {
|
||||
return 0
|
||||
}
|
||||
}
|
||||
|
||||
proc remote_device_none {instrument {value 0}} {
|
||||
global disconnect_time
|
||||
seaman / "device_none_on $instrument"
|
||||
set disconnect_time(0) [DoubleTime]
|
||||
}
|
||||
|
||||
#proc make_rem_controller {name hostport} {
|
||||
#
|
||||
# set typ [sicsdescriptor sics]
|
||||
# if {$typ eq "notfound"} {
|
||||
# remob server sics localhost.localdomain 8647
|
||||
# }
|
||||
# if {[sicsdescriptor sics] eq "RemServer"} {
|
||||
# remob obj $name sics
|
||||
# sics $name reconnect $hostport
|
||||
# }
|
||||
# obj_list makeitem $name "$name rem_controller"
|
||||
#}
|
||||
|
||||
proc seaman_set_rack args {
|
||||
global rack_list
|
||||
global rack_list_old
|
||||
set rack [lindex $args 0]
|
||||
if {$rack eq "start"} {
|
||||
array unset rack_list_old
|
||||
array set rack_list_old [array get rack_list]
|
||||
} elseif {$rack eq "end"} {
|
||||
foreach old [array names rack_list_old] {
|
||||
unset rack_list($old)
|
||||
}
|
||||
} else {
|
||||
set rack_list($rack) [lrange $args 1 end]
|
||||
unset -nocomplain rack_list_old($rack)
|
||||
}
|
||||
}
|
||||
|
||||
publish disconnect_from User
|
||||
publish request_items User
|
||||
publish reconnect_or_set_busy User
|
||||
publish remote_disconnect User
|
||||
publish forced_disconnect Spy
|
||||
publish reconnect_object User
|
||||
publish connection_details Spy
|
||||
publish remote_device_none User
|
||||
publish check_connections User
|
||||
publish seaman_set_rack User
|
||||
Reference in New Issue
Block a user