312 lines
7.5 KiB
Tcl
312 lines
7.5 KiB
Tcl
# 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
|
|
seaman / rack_list makeitem [rack] [result instrument]
|
|
}
|
|
|
|
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
|