294 lines
9.5 KiB
Tcl
294 lines
9.5 KiB
Tcl
#--------------------------------------------------------------------------
|
|
# This is a set of utilities for testing SICServers on instruments
|
|
#
|
|
# Mark Koennecke, November 2006, March 2007
|
|
#-------------------------------------------------------------------------
|
|
proc testInventory {inventory} {
|
|
set txt [sicscommand list]
|
|
set objList [split $txt ,]
|
|
set missing 0
|
|
foreach obj $inventory {
|
|
if {[lsearch $objList $obj] < 0} {
|
|
incr missing
|
|
puts stdout "MISSING: $obj"
|
|
}
|
|
}
|
|
return $missing
|
|
}
|
|
#-----------------------------------------------------------------------
|
|
proc SICSValue {command} {
|
|
set txt [eval $command]
|
|
set l [split $txt =]
|
|
return [string trim [lindex $l 1]]
|
|
}
|
|
#-----------------------------------------------------------------------
|
|
proc max {one two} {
|
|
if {$one > $two} {
|
|
return $one
|
|
} else {
|
|
return $two
|
|
}
|
|
}
|
|
#------------------------------------------------------------------------
|
|
# Test Motors. All are read: if they are not in the notList we will
|
|
# try driving them by 1 %. Drivecommand can either be drive of dr,
|
|
# depending on instrument
|
|
#-----------------------------------------------------------------------
|
|
proc testMotors {drivecommand motorList notList} {
|
|
set failed 0
|
|
foreach mot $motorList {
|
|
if {[lsearch $notList $mot] < 0 } {
|
|
puts stdout "Testing $mot"
|
|
set rawVal [eval $mot]
|
|
if {[string first ERROR $rawVal] >= 0} {
|
|
puts stdout "MOTOR: failed to read $mot, error $rawVal"
|
|
incr failed
|
|
continue
|
|
}
|
|
set val [string trim [lindex [split $rawVal =] 1]]
|
|
#----------- test drive three times tolerance
|
|
set prec [SICSValue "$mot precision"]
|
|
set status [catch {set move [expr $prec * 3.]} msg]
|
|
#------- this fixes virtual motors which will not have a precision
|
|
if {$status != 0} {
|
|
set move 0.3
|
|
}
|
|
set newval [expr $val + $move]
|
|
set status [catch {eval $drivecommand $mot $newval} msg]
|
|
if {[string first ERROR $msg] >= 0 } {
|
|
#------------ if we went into a limit, we try the other direction
|
|
if {[string first limit $msg] > 0} {
|
|
set newval [expr $val - $move]
|
|
set status [catch {eval $drivecommand $mot $newval} msg]
|
|
}
|
|
}
|
|
if {[string first ERROR $msg] >= 0} {
|
|
puts stdout "MOTOR: failed to drive $mot with $msg"
|
|
incr failed
|
|
continue
|
|
}
|
|
#---------- drive back
|
|
set status [catch {eval $drivecommand $mot $val} msg]
|
|
if {[string first ERROR $msg] >= 0 } {
|
|
puts stdout "MOTOR: failed to drive $mot back with $msg"
|
|
incr failed
|
|
}
|
|
}
|
|
}
|
|
return $failed
|
|
}
|
|
#------------------------------------------------------------------------
|
|
proc testSaveAndRestore {dir} {
|
|
backup $dir/insttest.tcl
|
|
recover $dir/insttest.tcl
|
|
backup $dir/instdiff.tcl
|
|
set f1 [exe print $dir/insttest.tcl]
|
|
set f2 [exe print $dir/instdiff.tcl]
|
|
set out [open b1.tcl w]
|
|
puts $out $f1
|
|
close $out
|
|
set out [open b2.tcl w]
|
|
puts $out $f2
|
|
close $out
|
|
set status [catch {exec diff b1.tcl b2.tcl} msg]
|
|
if {$status != 0} {
|
|
puts stdout \
|
|
"BACKUP/RESTORE: Serious problem: differences in restored parameters"
|
|
puts stdout "BACKUP/RESTORE: look at diff between b1.tcl and b2.tcl"
|
|
} else {
|
|
file delete b1.tcl
|
|
file delete b2.tcl
|
|
}
|
|
}
|
|
#------------------------------------------------------------------------
|
|
proc testCommand args {
|
|
set command [join $args]
|
|
set status [catch {eval $command} txt]
|
|
if {$status != 0} {
|
|
puts stdout "COMMAND: Command $command returned with error $txt"
|
|
return 0
|
|
}
|
|
if {[string first ERROR $txt] >= 0} {
|
|
puts stdout "COMMAND: problem while executing command $command"
|
|
puts stdout "COMMAND: output is $txt"
|
|
return 0
|
|
}
|
|
if {[string first WARNING $txt] >= 0} {
|
|
puts stdout "COMMAND: warning while executing command $command"
|
|
puts stdout "COMMAND: output is: $txt"
|
|
}
|
|
return 1
|
|
}
|
|
#------------------------------------------------------------------------
|
|
proc testCommandList {commandList} {
|
|
set count 0
|
|
foreach command $commandList {
|
|
puts stdout "Testing $command"
|
|
if {![testCommand $command]} {
|
|
incr count
|
|
}
|
|
}
|
|
return $count
|
|
}
|
|
#------------------------------------------------------------------------
|
|
proc testCommandInterrupt {command instrument user password} {
|
|
catch {exec ./interrupt.tcl $instrument $user $password &} msg
|
|
set txt1 [sicscommand $command]
|
|
set t1 [string match -nocase "*stop*" $txt1]
|
|
set txt2 [status]
|
|
set t2 [string match -nocase "*eager*" $txt2]
|
|
if {$t1 != 1 || $t2 != 1} {
|
|
puts stdout "INTERRUPT: Interrupting $command failed!"
|
|
puts stdout "INTERRUPT: message is $txt1"
|
|
puts stdout "INTERRUPT: status = $txt2"
|
|
puts stdout "Tests after this may fail!"
|
|
error "No interrupt"
|
|
}
|
|
}
|
|
#------------------------------------------------------------------------
|
|
proc testInterruptList {comList instrument user password} {
|
|
set int 0
|
|
foreach com $comList {
|
|
set status \
|
|
[catch {testCommandInterrupt $com $instrument $user $password} msg]
|
|
if {$status != 0} {
|
|
incr int
|
|
}
|
|
}
|
|
return $int
|
|
}
|
|
#-----------------------------------------------------------------------
|
|
proc testVarValue {command value {precision NA}} {
|
|
set txt [eval $command]
|
|
if {[string first ERROR $txt] >= 0} {
|
|
error "Failed to read variable $command"
|
|
}
|
|
if {[string first = $txt] > 0} {
|
|
set l [split $txt =]
|
|
set val [string trim [lindex $l 1]]
|
|
} else {
|
|
set val $txt
|
|
}
|
|
if {[string first NA $precision] >= 0} {
|
|
if {[string first $value $val] < 0} {
|
|
error "Value $value not found in response $txt"
|
|
}
|
|
} else {
|
|
if {abs($value-$val) > $precision} {
|
|
error "Bad value $val, expected $value"
|
|
}
|
|
}
|
|
return OK
|
|
}
|
|
#------------------------------------------------------------------------
|
|
proc testVarList {varList} {
|
|
puts stdout "Testing variable values"
|
|
set count 0
|
|
foreach var $varList {
|
|
if {[llength $var] > 2} {
|
|
set status [catch {testVarValue [lindex $var 0] \
|
|
[lindex $var 1] [lindex $var 2]} msg]
|
|
} else {
|
|
set status [catch {testVarValue [lindex $var 0] \
|
|
[lindex $var 1]} msg]
|
|
}
|
|
if {$status != 0} {
|
|
set cmd [lindex $var 0]
|
|
puts stdout "$msg @ $cmd"
|
|
incr count
|
|
} else {
|
|
}
|
|
}
|
|
return $count
|
|
}
|
|
#-------------------------------------------------------------------------
|
|
proc runStandardTests {parArray} {
|
|
upvar $parArray parameters
|
|
if { [info exists parameters(inventory)] } {
|
|
puts stdout "Testing Inventory.."
|
|
lappend counters [testInventory $parameters(inventory)]
|
|
} else {
|
|
lappend counters 0
|
|
}
|
|
|
|
if { [info exists parameters(driveCommand)] && \
|
|
[info exists parameters(motorList)] && \
|
|
[info exists parameters(notList)] } {
|
|
puts stdout "Testing motors... "
|
|
lappend counters [testMotors $parameters(driveCommand) \
|
|
$parameters(motorList) $parameters(notList)]
|
|
} else {
|
|
lappend counters 0
|
|
}
|
|
|
|
if { [info exists parameters(commandList)] } {
|
|
puts stdout "Testing a list of commands"
|
|
lappend counters [testCommandList $parameters(commandList)]
|
|
} else {
|
|
lappend counters 0
|
|
}
|
|
|
|
if { [info exists parameters(dir)] } {
|
|
puts stdout "Testing backup/recover.."
|
|
catch {testSaveAndRestore $parameters(dir)} msg
|
|
}
|
|
|
|
if { [info exists parameters(interruptList)] && \
|
|
[info exists parameters(instrument)] && \
|
|
[info exists parameters(user)] && \
|
|
[info exists parameters(password)] } {
|
|
puts stdout "Testing interrupting commands... "
|
|
lappend counters [testInterruptList $parameters(interruptList) \
|
|
$parameters(instrument) \
|
|
$parameters(user) $parameters(password)]
|
|
} else {
|
|
lappend counters 0
|
|
}
|
|
|
|
if {[info exists parameters(varList)]} {
|
|
lappend counters [testVarList $parameters(varList)]
|
|
} else {
|
|
lappend counters 0
|
|
}
|
|
}
|
|
#-------------------------------------------------------------------------
|
|
proc printStandardSummary {counters} {
|
|
puts stdout [format "%d objects missing" [lindex $counters 0]]
|
|
puts stdout [format "%d motors failed to drive" [lindex $counters 1]]
|
|
puts stdout [format "%d commands failed" [lindex $counters 2]]
|
|
puts stdout [format "%d commands interrupts failed" [lindex $counters 3]]
|
|
puts stdout [format "%d variable values bad" [lindex $counters 4]]
|
|
}
|
|
#-----------------------------------------------------------------------
|
|
proc SICSValue {command} {
|
|
set txt [eval $command]
|
|
set l [split $txt =]
|
|
return [string trim [lindex $l 1]]
|
|
}
|
|
#----------------------------------------------------------------------
|
|
proc standardPrelude {inst {count co}} {
|
|
global __threshold __batchpath
|
|
set __threshold [SICSValue "counter getthreshold 1"]
|
|
set __batchpath [SICSValue "exe batchpath"]
|
|
if {[string compare $inst local] == 0} {
|
|
catch {sicscommand "exe batchpath /$env(HOME)/tmp"} msg
|
|
} else {
|
|
catch {sicscommand "exe batchpath /home/$inst/tmp"} msg
|
|
}
|
|
catch {sicscommand "scan mode timer"} msg
|
|
catch {sicscommand "counter setmode timer"} msg
|
|
catch {sicscommand "counter setthreshold 1 0"} msg
|
|
catch {sicscommand "exe upload"} msg
|
|
catch {sicscommand "exe append counter setthreshold 1 0"} msg
|
|
catch {sicscommand "exe append $count timer 120"} msg
|
|
catch {sicscommand "exe forcesave insttestbatch.tcl"} msg
|
|
}
|
|
#----------------------------------------------------------------------
|
|
proc standardRestore {} {
|
|
global __threshold __batchpath
|
|
catch {sicscommand "exe batchpath $__batchpath"} msg
|
|
catch {sicscommand "scan mode monitor"} msg
|
|
catch {sicscommand "counter setmode monitor"} msg
|
|
catch {sicscommand "counter setthreshold 1 $__threshold"} msg
|
|
}
|