PSI sics-cvs-psi-2008-10-02
This commit is contained in:
Douglas Clowes
3
test/DataNumber
Normal file
3
test/DataNumber
Normal file
@ -0,0 +1,3 @@
|
||||
131
|
||||
NEVER, EVER modify or delete this file
|
||||
You'll risk eternal damnation and a reincarnation as a cockroach!|n
|
||||
128
test/batchtest.tcl
Normal file
128
test/batchtest.tcl
Normal file
@ -0,0 +1,128 @@
|
||||
#------------------------------------------------------------------------------
|
||||
# This is a set of regression tests for the batch processing feauture
|
||||
# in SICS
|
||||
#
|
||||
# Mark Koennecke, October 2006
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
puts stdout "Testing batch processing"
|
||||
|
||||
test batch-1.0 {Test Batch File Execution} -body {
|
||||
config rights User User
|
||||
set result [eval exe job1.tcl]
|
||||
if {[string first TERMINATED $result] < 0} {
|
||||
error "Failed to process batch file"
|
||||
}
|
||||
if {[string first Job1 $result] < 0} {
|
||||
error "Output from batch file missing, received: $result"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test batch-1.1 {Test Batch File Interruption} -body {
|
||||
config rights User user
|
||||
exec ./interrupt.tcl &
|
||||
set result [eval exe job1.tcl]
|
||||
if {[string first TERMINATED $result] < 0} {
|
||||
error "Failed to process batch file"
|
||||
}
|
||||
if {[string first interrupted $result] < 0} {
|
||||
error "Interrupting did not work"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test batch-1.2 {Test Nested Batch File Execution} -body {
|
||||
config rights User user
|
||||
set result [eval exe job2.tcl]
|
||||
if {[string first TERMINATED $result] < 0} {
|
||||
error "Failed to process batch file"
|
||||
}
|
||||
if {[string first NestOne $result] < 0} {
|
||||
error "Output from batch file missing"
|
||||
}
|
||||
if {[string first NestTwo $result] < 0} {
|
||||
error "Output from batch file missing"
|
||||
}
|
||||
if {[string first NestThree $result] < 0} {
|
||||
error "Output from batch file missing"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test batch-1.3 {Test Nested Batch File Interruption} -body {
|
||||
config rights User user
|
||||
exec ./interrupt.tcl &
|
||||
set result [eval exe job2.tcl]
|
||||
if {[string first TERMINATED $result] < 0} {
|
||||
error "Failed to process batch file"
|
||||
}
|
||||
if {[string first NestOne $result] < 0} {
|
||||
error "Output from batch file missing"
|
||||
}
|
||||
if {[string first NestTwo $result] < 0} {
|
||||
error "Output from batch file missing"
|
||||
}
|
||||
if {[string first NestThree $result] < 0} {
|
||||
error "Output from batch file missing"
|
||||
}
|
||||
if {[string first interrupted $result] < 0} {
|
||||
error "Interrupting did not work"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test batch-1.4 {Test Path Parameters} -body {
|
||||
testPar "exe batchpath" tmp User
|
||||
testPar "exe syspath" tmp Mugger
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test batch-1.5 {Test Path Failure} -body {
|
||||
config rights Mugger Mugger
|
||||
exe batchpath tmp
|
||||
exe syspath tmp
|
||||
set result [exe job4.tcl]
|
||||
if {[string first "not found" $result] < 0} {
|
||||
error "Batch file found which should not"
|
||||
}
|
||||
exe batchpath ./
|
||||
exe syspath ./
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test batch-1.6 {Test Uploading} -body {
|
||||
config rights User User
|
||||
catch {exec rm hugo.job}
|
||||
testOK "exe upload"
|
||||
testOK "exe append clientput hugo"
|
||||
testOK "exe append wait 2"
|
||||
testOK "exe save hugo.job"
|
||||
testOK "exe upload"
|
||||
testOK "exe append clientput hugo"
|
||||
testOK "exe append wait 2"
|
||||
set stat [catch {testOK "exe save hugo.job" } msg ]
|
||||
if {$stat == 0} {
|
||||
error "Failed to trigger overwrite error"
|
||||
}
|
||||
testOK "exe forcesave hugo.job"
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test batch-1.7 {Test Notifications} -body {
|
||||
config rights User User
|
||||
testOK "exe interest"
|
||||
set result [eval exe job4.tcl]
|
||||
if {[string first BATCHSTART $result] < 0} {
|
||||
error "BATCHSTART missing"
|
||||
}
|
||||
if {[string first BATCHEND $result] < 0} {
|
||||
error "BATCHEND missing"
|
||||
}
|
||||
if {[string first job4.tcl.range $result] < 0} {
|
||||
error "Range entries missing"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
|
||||
271
test/countertest.tcl
Normal file
271
test/countertest.tcl
Normal file
@ -0,0 +1,271 @@
|
||||
#-------------------------------------------------------------
|
||||
# Testing of the counter module
|
||||
#
|
||||
# The regression counter has various errortypes which can be simulated:
|
||||
# 0 = none
|
||||
# 1 = failed start
|
||||
# 2 = status failure
|
||||
# 3 = pause fail
|
||||
# 4 = continue fail
|
||||
# 5 = failed read
|
||||
#
|
||||
# Another parameter is recover which causes the problem to go away
|
||||
# when 1
|
||||
#
|
||||
# TODO: What shall happen when pausing fails? Currently it continues
|
||||
# counting. This may be exactly what we need, but????
|
||||
#
|
||||
# This code needs the counter name two times: once as countername and
|
||||
# as errorname. The purpose is that this module may be used for testing
|
||||
# both the real and the multi counter.
|
||||
#
|
||||
# Mark Koennecke, September 2006
|
||||
#-------------------------------------------------------------
|
||||
#set countername aba
|
||||
#set errorname aba
|
||||
|
||||
puts stdout "Testing counter: $countername"
|
||||
|
||||
#---------------------------------------------------------------
|
||||
config rights Mugger Mugger
|
||||
$errorname setpar errortype 1 0
|
||||
|
||||
test counter-1.0 {Test Mode Setting} -body {
|
||||
config rights Spy Spy
|
||||
set res [eval $countername setmode monitor]
|
||||
if {[string first ERROR $res] < 0} {
|
||||
error "Managed to set parameter even if not allowed"
|
||||
}
|
||||
config rights User User
|
||||
set res [eval $countername setmode monitor]
|
||||
if {[string first ERROR $res] >= 0} {
|
||||
error "Setting parameter failed with $res"
|
||||
}
|
||||
set readback [SICSValue "$countername getmode"]
|
||||
compareValue [string tolower $readback] monitor
|
||||
config rights Spy Spy
|
||||
set res [eval $countername setmode timer]
|
||||
if {[string first ERROR $res] < 0} {
|
||||
error "Managed to set parameter even if not allowed"
|
||||
}
|
||||
config rights User User
|
||||
set res [eval $countername setmode timer]
|
||||
if {[string first ERROR $res] >= 0} {
|
||||
error "Setting parameter failed with $res"
|
||||
}
|
||||
set readback [SICSValue "$countername getmode"]
|
||||
compareValue [string tolower $readback] timer
|
||||
return "OK"
|
||||
} -result OK
|
||||
#-------------------------------------------------------------------
|
||||
test counter-1.1 {Test Preset Setting} -body {
|
||||
config rights Spy Spy
|
||||
set val 12
|
||||
set res [eval $countername setpreset $val]
|
||||
if {[string first ERROR $res] < 0} {
|
||||
error "Managed to set parameter even if not allowed"
|
||||
}
|
||||
config rights User User
|
||||
set res [eval $countername setpreset $val]
|
||||
if {[string first ERROR $res] >= 0} {
|
||||
error "Setting parameter failed with $res"
|
||||
}
|
||||
set readback [SICSValue "$countername getpreset"]
|
||||
compareValue $readback $val
|
||||
return "OK"
|
||||
} -result OK
|
||||
#---------------------------------------------------------------------
|
||||
test counter-1.3 {Test Normal Counting} -body {
|
||||
config rights Spy Spy
|
||||
set status [catch {testNBCounting "$countername countnb 10" 11} msg]
|
||||
if {$status == 0} {
|
||||
error "Counted in spite of lacking privilege"
|
||||
}
|
||||
config rights User User
|
||||
testNBCounting "$countername countnb 10" 11
|
||||
} -result OK
|
||||
#---------------------------------------------------------------------
|
||||
test counter-1.4 {Test Blocking Counting} -body {
|
||||
config rights Spy Spy
|
||||
set status [catch {testBlockCounting "$countername countnb 10" 11} msg]
|
||||
if {$status == 0} {
|
||||
error "Counted in spite of lacking privilege"
|
||||
}
|
||||
config rights User User
|
||||
testBlockCounting "$countername countnb 10" 11
|
||||
} -result OK
|
||||
#--------------------------------------------------------------------
|
||||
test counter-1.5 {Interrupted Counting} -body {
|
||||
testInterruptedCount "$countername countnb 100"
|
||||
} -result OK
|
||||
#--------------------------------------------------------------------
|
||||
config rights User User
|
||||
|
||||
test counter-1.51 {Pause Counting Test} -body {
|
||||
global socke
|
||||
$countername countnb 300
|
||||
exec sleep 1
|
||||
set ans [status]
|
||||
if {[string first Counting $ans] < 0} {
|
||||
error "Failed to start counting: $ans"
|
||||
}
|
||||
pause
|
||||
exec sleep 1
|
||||
set ans [status]
|
||||
if {[string first Paus $ans] < 0} {
|
||||
error "Failed to pause counting: $ans"
|
||||
}
|
||||
puts $socke continue
|
||||
flush $socke
|
||||
exec sleep 1
|
||||
set ans [status]
|
||||
if {[string first Count $ans] < 0} {
|
||||
error "Failed to continue counting: $ans"
|
||||
}
|
||||
puts $socke "INT1712 3"
|
||||
flush $socke
|
||||
set ans [status]
|
||||
return OK
|
||||
} -result OK
|
||||
#---------------------------------------------------------
|
||||
test counter-1.52 {Pause Interrupt Test} -body {
|
||||
global socke
|
||||
$countername countnb 300
|
||||
exec sleep 2
|
||||
set ans [status]
|
||||
if {[string first Counting $ans] < 0} {
|
||||
error "Failed to start counting: $ans"
|
||||
}
|
||||
pause
|
||||
exec sleep 1
|
||||
set ans [status]
|
||||
if {[string first Paus $ans] < 0} {
|
||||
error "Failed to pause counting: $ans"
|
||||
}
|
||||
puts $socke "INT1712 3"
|
||||
flush $socke
|
||||
set ans [status]
|
||||
if {[string first Eager $ans] < 0} {
|
||||
error "Failed to interrupt paused counting: $ans"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
#-------------------------------------------------------------------
|
||||
test counter-1.53 {Counter Value Read Test} -body {
|
||||
config rights User User
|
||||
$countername count 10
|
||||
set ans [SICSValue "$countername gettime"]
|
||||
compareValue $ans 10
|
||||
set ans [SICSValue "$countername getcounts"]
|
||||
compareValue $ans 5
|
||||
set ans [SICSValue "$countername getmonitor 1"]
|
||||
compareValue $ans 10
|
||||
set ans [SICSValue "$countername getmonitor 2"]
|
||||
compareValue $ans 25
|
||||
set ans [SICSValue "$countername getmonitor 3"]
|
||||
compareValue $ans 35
|
||||
set ans [SICSValue "$countername getmonitor 4"]
|
||||
compareValue $ans 45
|
||||
set ans [SICSValue "$countername getmonitor 5"]
|
||||
compareValue $ans 55
|
||||
set ans [SICSValue "$countername getmonitor 6"]
|
||||
compareValue $ans 65
|
||||
return OK
|
||||
} -result OK
|
||||
#--------------------------------------------------------------------
|
||||
config rights Mugger Mugger
|
||||
$errorname setpar errortype 1 1
|
||||
$errorname setpar recover 1 0
|
||||
|
||||
test counter-1.6 {Counting Start Failure} -body {
|
||||
set ans [$countername countnb 100]
|
||||
if { [string first "Counting aborted" $ans] < 0} {
|
||||
error "Failed to trigger count start failure: $ans"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
#---------------------------------------------------------------
|
||||
$errorname setpar errortype 1 1
|
||||
$errorname setpar recover 1 1
|
||||
|
||||
test counter-1.7 {Counting Start Failure with Recovery} -body {
|
||||
set ans [$countername countnb 10]
|
||||
if { [string first "WARNING" $ans] < 0} {
|
||||
error "Failed to trigger count start failure: $ans"
|
||||
}
|
||||
set ans [SICSValue status]
|
||||
if {[string first Counting $ans] < 0} {
|
||||
error "Did not recover from start failure"
|
||||
}
|
||||
exec sleep 12
|
||||
set ans [SICSValue status]
|
||||
if {[string first Eager $ans] < 0} {
|
||||
error "Did not stop counting after start failure"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
#----------------------------------------------------------------------
|
||||
$errorname setpar errortype 1 2
|
||||
$errorname setpar recover 1 0
|
||||
|
||||
test counter-1.8 {Counting Status Failure} -body {
|
||||
set ans [$countername countnb 100]
|
||||
set ans [status]
|
||||
if { [string first "Full Stop called" $ans] < 0} {
|
||||
error "Failed to trigger count start failure: $ans"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
#---------------------------------------------------------------
|
||||
$errorname setpar errortype 1 2
|
||||
$errorname setpar recover 1 1
|
||||
|
||||
test counter-1.9 {Counting Status Failure with Recovery} -body {
|
||||
set ans [$countername countnb 10]
|
||||
set ans [status]
|
||||
if { [string first "WARNING" $ans] < 0} {
|
||||
error "Failed to trigger count start failure: $ans"
|
||||
}
|
||||
if {[string first Counting $ans] < 0} {
|
||||
error "Did not recover from status failure"
|
||||
}
|
||||
exec sleep 12
|
||||
set ans [SICSValue status]
|
||||
if {[string first Eager $ans] < 0} {
|
||||
error "Did not stop counting after status failure"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
#-------------------------------------------------------------------
|
||||
$errorname setpar errortype 1 5
|
||||
$errorname setpar recover 1 0
|
||||
|
||||
test counter-1.10 {Counter Read Failure} -body {
|
||||
set ans [$countername count 2]
|
||||
if { [string first "Full Stop" $ans] < 0} {
|
||||
error "Failed to trigger count read failure: $ans"
|
||||
}
|
||||
set ans [SICSValue status]
|
||||
if {[string first Eager $ans] < 0} {
|
||||
error "Did not stop counting after read failure"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
#----------------------------------------------------------------
|
||||
$errorname setpar errortype 1 5
|
||||
$errorname setpar recover 1 1
|
||||
|
||||
test counter-1.10 {Counter Read Recover} -body {
|
||||
set ans [$countername count 2]
|
||||
if { [string first "WARN" $ans] < 0} {
|
||||
error "Failed to trigger count read failure: $ans"
|
||||
}
|
||||
set ans [SICSValue status]
|
||||
if {[string first Eager $ans] < 0} {
|
||||
error "Did not stop counting after read failure"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
|
||||
342
test/histtest.tcl
Normal file
342
test/histtest.tcl
Normal file
@ -0,0 +1,342 @@
|
||||
#---------------------------------------------------------------------------
|
||||
# This is for testing the histogram memory code
|
||||
# The errortypes are the same as in the counter module
|
||||
#
|
||||
# Mark Koennecke, October 2006
|
||||
#---------------------------------------------------------------------------
|
||||
puts stdout "Testing Histogram Memory"
|
||||
config rights Mugger Mugegr
|
||||
hm config errotype 0
|
||||
hm init
|
||||
|
||||
test hm-1.0 {Test Mode Setting} -body {
|
||||
config rights Spy Spy
|
||||
set res [eval hm countmode monitor]
|
||||
if {[string first ERROR $res] < 0} {
|
||||
error "Managed to set parameter even if not allowed"
|
||||
}
|
||||
config rights User User
|
||||
set res [eval hm countmode monitor]
|
||||
if {[string first ERROR $res] >= 0} {
|
||||
error "Setting parameter failed with $res"
|
||||
}
|
||||
set readback [SICSValue "hm countmode"]
|
||||
compareValue [string tolower $readback] monitor
|
||||
config rights Spy Spy
|
||||
set res [eval hm countmode timer]
|
||||
if {[string first ERROR $res] < 0} {
|
||||
error "Managed to set parameter even if not allowed"
|
||||
}
|
||||
config rights User User
|
||||
set res [eval hm countmode timer]
|
||||
if {[string first ERROR $res] >= 0} {
|
||||
error "Setting parameter failed with $res"
|
||||
}
|
||||
set readback [SICSValue "hm countmode"]
|
||||
compareValue [string tolower $readback] timer
|
||||
return OK
|
||||
} -result OK
|
||||
#-------------------------------------------------------------------
|
||||
test hm-1.1 {Test Preset Setting} -body {
|
||||
config rights Spy Spy
|
||||
set val 12
|
||||
set res [eval hm preset $val]
|
||||
if {[string first ERROR $res] < 0} {
|
||||
error "Managed to set parameter even if not allowed"
|
||||
}
|
||||
config rights User User
|
||||
set res [eval hm preset $val]
|
||||
if {[string first ERROR $res] >= 0} {
|
||||
error "Setting parameter failed with $res"
|
||||
}
|
||||
set readback [SICSValue "hm preset"]
|
||||
compareValue $readback $val
|
||||
return "OK"
|
||||
} -result OK
|
||||
#---------------------------------------------------------------------
|
||||
test hm-1.3 {Test Normal Counting} -body {
|
||||
config rights Spy Spy
|
||||
set status [catch {testNBCounting "hm count" 11} msg]
|
||||
if {$status == 0} {
|
||||
error "Counted in spite of lacking privilege"
|
||||
}
|
||||
config rights User User
|
||||
testOK "hm countmode timer"
|
||||
testOK "hm preset 5"
|
||||
testNBCounting "hm count" 11
|
||||
} -result OK
|
||||
#---------------------------------------------------------------------
|
||||
test hm-1.4 {Test Blocking Counting} -body {
|
||||
config rights Spy Spy
|
||||
set status [catch {testBlockCounting "hm countblock" 11} msg]
|
||||
if {$status == 0} {
|
||||
error "Counted in spite of lacking privilege"
|
||||
}
|
||||
config rights User User
|
||||
testBlockCounting "hm countblock" 11
|
||||
} -result OK
|
||||
#--------------------------------------------------------------------
|
||||
test hm-1.5 {Interrupted Counting} -body {
|
||||
hm preset 10
|
||||
testInterruptedCount "hm count"
|
||||
} -result OK
|
||||
#--------------------------------------------------------------------
|
||||
config rights User User
|
||||
|
||||
test hm-1.51 {Pause Counting Test} -body {
|
||||
global socke
|
||||
hm preset 300
|
||||
hm count
|
||||
exec sleep 1
|
||||
set ans [status]
|
||||
if {[string first Counting $ans] < 0} {
|
||||
error "Failed to start counting: $ans"
|
||||
}
|
||||
pause
|
||||
exec sleep 1
|
||||
set ans [status]
|
||||
if {[string first Paus $ans] < 0} {
|
||||
error "Failed to pause counting: $ans"
|
||||
}
|
||||
puts $socke continue
|
||||
flush $socke
|
||||
exec sleep 1
|
||||
set ans [status]
|
||||
if {[string first Count $ans] < 0} {
|
||||
error "Failed to continue counting: $ans"
|
||||
}
|
||||
puts $socke "INT1712 3"
|
||||
flush $socke
|
||||
set ans [status]
|
||||
return OK
|
||||
} -result OK
|
||||
#---------------------------------------------------------
|
||||
test hm-1.52 {Pause Interrupt Test} -body {
|
||||
global socke
|
||||
hm count 300
|
||||
exec sleep 2
|
||||
set ans [status]
|
||||
if {[string first Counting $ans] < 0} {
|
||||
error "Failed to start counting: $ans"
|
||||
}
|
||||
pause
|
||||
exec sleep 1
|
||||
set ans [status]
|
||||
if {[string first Paus $ans] < 0} {
|
||||
error "Failed to pause counting: $ans"
|
||||
}
|
||||
puts $socke "INT1712 3"
|
||||
flush $socke
|
||||
set ans [status]
|
||||
if {[string first Eager $ans] < 0} {
|
||||
error "Failed to interrupt paused counting: $ans"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
#--------------------------------------------------------------------
|
||||
config rights Mugger Mugger
|
||||
hm configure errortype 1
|
||||
hm configure recover 0
|
||||
hm init
|
||||
hm preset 10
|
||||
|
||||
test hm-1.6 {Counting Start Failure} -body {
|
||||
set ans [hm count]
|
||||
if { [string first "cannot start" $ans] < 0} {
|
||||
error "Failed to trigger count start failure: $ans"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
#-------------------------------------------------------------------------
|
||||
hm configure errortype 1
|
||||
hm configure recover 1
|
||||
hm init
|
||||
|
||||
test hm-1.7 {Counting Start Failure with Recovery} -body {
|
||||
set ans [hm count]
|
||||
if { [string first "WARNING" $ans] < 0} {
|
||||
error "Failed to trigger count start failure: $ans"
|
||||
}
|
||||
set ans [SICSValue status]
|
||||
if {[string first Counting $ans] < 0} {
|
||||
error "Did not recover from start failure"
|
||||
}
|
||||
exec sleep 15
|
||||
set ans [SICSValue status]
|
||||
if {[string first Eager $ans] < 0} {
|
||||
error "Did not stop counting after start failure"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
#----------------------------------------------------------------------
|
||||
hm configure errortype 2
|
||||
hm configure recover 0
|
||||
hm init
|
||||
|
||||
test hm-1.8 {Counting Status Failure} -body {
|
||||
set ans [hm count]
|
||||
set ans [status]
|
||||
if { [string first "Full Stop called" $ans] < 0} {
|
||||
error "Failed to trigger count start failure: $ans"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
#---------------------------------------------------------------
|
||||
hm configure errortype 2
|
||||
hm configure recover 1
|
||||
hm init
|
||||
|
||||
test hm-1.9 {Counting Status Failure with Recovery} -body {
|
||||
set ans [hm count 10]
|
||||
set ans [status]
|
||||
if { [string first "WARNING" $ans] < 0} {
|
||||
error "Failed to trigger count start failure: $ans"
|
||||
}
|
||||
if {[string first Counting $ans] < 0} {
|
||||
error "Did not recover from status failure"
|
||||
}
|
||||
exec sleep 12
|
||||
set ans [SICSValue status]
|
||||
if {[string first Eager $ans] < 0} {
|
||||
error "Did not stop counting after status failure"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
#----------------------------------------------------------------------
|
||||
hm configure errortype 0
|
||||
hm configure recover 0
|
||||
hm configure testval 3
|
||||
hm init
|
||||
hm preset 2
|
||||
hm countblock
|
||||
|
||||
test hm-1.10 {Test data} -body {
|
||||
set expected [SICSValue "hm configure dim0"]
|
||||
set data [hm get 0]
|
||||
if {[string first ERROR $data] >= 0} {
|
||||
error "Failed to read HM"
|
||||
}
|
||||
if {[string first Histogram $data] < 0} {
|
||||
error "Bad response from HM"
|
||||
}
|
||||
set l [split $data =]
|
||||
set data [lindex $l 1]
|
||||
set l [split $data]
|
||||
set count 0
|
||||
foreach e $l {
|
||||
if {![string is space $e]} {
|
||||
incr count
|
||||
if {$e != 3} {
|
||||
error "Bad value in HM, got $e, expected 3"
|
||||
}
|
||||
}
|
||||
}
|
||||
if {$count != $expected} {
|
||||
error "HM Datasize does not match, expected $expected, got $count"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
hm configure testval 7
|
||||
hm init
|
||||
hm countblock
|
||||
|
||||
test hm-1.11 {Test data second} -body {
|
||||
set expected [SICSValue "hm configure dim0"]
|
||||
set data [hm get 0]
|
||||
if {[string first ERROR $data] >= 0} {
|
||||
error "Failed to read HM"
|
||||
}
|
||||
if {[string first Histogram $data] < 0} {
|
||||
error "Bad response from HM"
|
||||
}
|
||||
set l [split $data =]
|
||||
set data [lindex $l 1]
|
||||
set l [split $data]
|
||||
set count 0
|
||||
foreach e $l {
|
||||
if {![string is space $e]} {
|
||||
incr count
|
||||
if {$e != 7} {
|
||||
error "Bad value in HM, got $e, expected 3"
|
||||
}
|
||||
}
|
||||
}
|
||||
if {$count != $expected} {
|
||||
error "HM Datasize does not match, expected $expected, got $count"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
#-------------------------- ---------------------------------------------
|
||||
test hm-1.13 {Test hm sum} -body {
|
||||
set test [SICSValue "hm sum 2 4"]
|
||||
if {$test != 14} {
|
||||
error "Summing HM failed, expected 14 got $test"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
#--------------------------------------------------------------------------
|
||||
test hm-1.14 {Test Setting Time Binning} -body {
|
||||
config rights Mugger Mugger
|
||||
testOK "tof genbin 50 20 70"
|
||||
testOK "tof configure testval 1"
|
||||
testOK "tof init"
|
||||
return OK
|
||||
} -result OK
|
||||
#-------------------------------------------------------------------------
|
||||
test hm-1.15 {Test Reading Time Binning} -body {
|
||||
set tst [SICSValue "tof notimebin"]
|
||||
if {$tst != 70} {
|
||||
error "NTOF bad, expected 70, got $tst"
|
||||
}
|
||||
set tdata [SICSValue "tof timebin"]
|
||||
set l [split $tdata]
|
||||
set count 0
|
||||
foreach v $l {
|
||||
if {![string is space $v]} {
|
||||
set tval [expr 50.0 + $count*20]
|
||||
if {abs($v - $tval) > 1} {
|
||||
error "Bad time value $v, expected $tval"
|
||||
}
|
||||
incr count
|
||||
}
|
||||
}
|
||||
if {$count < $tst} {
|
||||
error "Insufficient number of timebins: $count, expected $tst"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
#----------------------------------------------------------------------
|
||||
tof countmode timer
|
||||
tof preset 2
|
||||
tof countblock
|
||||
test hm-1.16 {Test Reading TOF Data} -body {
|
||||
set ntof [SICSValue "tof notimebin"]
|
||||
set dim [SICSValue "tof configure dim0"]
|
||||
set alldata [expr $ntof*$dim]
|
||||
set tdata [SICSValue "tof get 0"]
|
||||
set l [split $tdata]
|
||||
set count 0
|
||||
foreach v $l {
|
||||
if {![string is space $v]} {
|
||||
if {abs($v - 1) > .1} {
|
||||
error "Bad data value $v, expected $tval"
|
||||
}
|
||||
incr count
|
||||
}
|
||||
}
|
||||
if {$count < $alldata} {
|
||||
error "Datapoints missing, got $count, expected $alldata"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
#----------------------------------------------------------------------
|
||||
tof initval 1
|
||||
test hm-1.16 {Test TOF Sum} -body {
|
||||
set val [SICSValue "tof sum 2 3 0 20"]
|
||||
if {$val != 20 } {
|
||||
error " tof sum failed, expected 20 received $val"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
14
test/interrupt.tcl
Executable file
14
test/interrupt.tcl
Executable file
@ -0,0 +1,14 @@
|
||||
#!/usr/bin/tclsh
|
||||
#------------------------------------------------------------
|
||||
# This is a little script which issues an interrupt to SICS
|
||||
# after five seconds
|
||||
#
|
||||
# Mark Koennecke, October 2006
|
||||
#------------------------------------------------------------
|
||||
source sicstcldebug.tcl
|
||||
config rights Mugger Mugger
|
||||
exec sleep 5
|
||||
puts $socke "INT1712 3"
|
||||
exit 1
|
||||
|
||||
|
||||
5
test/job1.tcl
Normal file
5
test/job1.tcl
Normal file
@ -0,0 +1,5 @@
|
||||
#----------------------------------------------------------
|
||||
# One of the job files for testing batch file processing
|
||||
#----------------------------------------------------------
|
||||
clientput "Job1 batch file"
|
||||
wait 20
|
||||
6
test/job2.tcl
Normal file
6
test/job2.tcl
Normal file
@ -0,0 +1,6 @@
|
||||
#----------------------------------------------------------
|
||||
# One of the job files for testing batch file processing
|
||||
#----------------------------------------------------------
|
||||
clientput "NestOne"
|
||||
exe job3.tcl
|
||||
wait 3
|
||||
6
test/job3.tcl
Normal file
6
test/job3.tcl
Normal file
@ -0,0 +1,6 @@
|
||||
#----------------------------------------------------------
|
||||
# One of the job files for testing batch file processing
|
||||
#----------------------------------------------------------
|
||||
clientput "NestTwo"
|
||||
exe job4.tcl
|
||||
wait 3
|
||||
5
test/job4.tcl
Normal file
5
test/job4.tcl
Normal file
@ -0,0 +1,5 @@
|
||||
#----------------------------------------------------------
|
||||
# One of the job files for testing batch file processing
|
||||
#----------------------------------------------------------
|
||||
clientput "NestThree"
|
||||
wait 3
|
||||
303
test/mottest.tcl
Normal file
303
test/mottest.tcl
Normal file
@ -0,0 +1,303 @@
|
||||
#------------------------------------------------------------------------------
|
||||
# Regression tests fo a motor. It is assumed that the motors name is
|
||||
# brumm and that it has been initialized with the regress motor
|
||||
# driver. Moreover, this has to be loaded after tcltest.tcl, testutil.tcl
|
||||
# and sicstcldebug.tcl
|
||||
#
|
||||
# The regression motor has various errortypes which can be simulated:
|
||||
# 0 = none
|
||||
# 1 = failed start
|
||||
# 2 = position fault
|
||||
# 3 = hardware failure
|
||||
# 4 = off position, without explicit position fault
|
||||
# 5 = failed read
|
||||
# 6 = keep running (for testing interupting)
|
||||
# Moreover there is a recover flag which causes the motor to recover when it is
|
||||
# 1
|
||||
#
|
||||
# copyright: see file COPYRIGHT
|
||||
#
|
||||
# Mark Koennecke, July 2006
|
||||
#
|
||||
#------------------------------------------------------------------------------
|
||||
puts stdout "Testing motor code"
|
||||
|
||||
test motorpar-1.0 {Test sll} -body {
|
||||
testPar "brumm softlowerlim" -175 User } -result OK
|
||||
|
||||
test motorpar-1.1 {Test slu} -body {
|
||||
testPar "brumm softupperlim" 175 User } -result OK
|
||||
|
||||
test motorpar-1.2 {Test ss} -body {
|
||||
testPar "brumm softzero" 5 User } -result OK
|
||||
|
||||
test motorpar-1.3 {Test interrupt} -body {
|
||||
testPar "brumm interruptmode" 2 Mugger } -result OK
|
||||
|
||||
test motorpar-1.4 {Test accesscode} -body {
|
||||
testPar "brumm accesscode" 3 Mugger } -result OK
|
||||
|
||||
test motorpar-1.5 {Test precision} -body {
|
||||
testPar "brumm precision" .5 Mugger } -result OK
|
||||
|
||||
test motorpar-1.6 {Test fail} -body {
|
||||
testPar "brumm failafter" 5 Mugger } -result OK
|
||||
|
||||
test motorpar-1.7 {Test retry} -body {
|
||||
testPar "brumm maxretry" 5 Mugger } -result OK
|
||||
|
||||
test motorpar-1.8 {Test ignorefault} -body {
|
||||
testPar "brumm ignorefault" 1 Mugger } -result OK
|
||||
|
||||
test motorpar-1.9 {Test movecount} -body {
|
||||
testPar "brumm movecount" 12 Mugger } -result OK
|
||||
|
||||
test motorpar-1.10 {Test hardupper} -body {
|
||||
testROPar "brumm hardupperlim" 180 } -result OK
|
||||
|
||||
test motorpar-1.11 {Test hardlower} -body {
|
||||
testROPar "brumm hardlowerlim" -180 } -result OK
|
||||
|
||||
brumm recover 0
|
||||
brumm errortype 0
|
||||
test motor-1.0 {Test Normal Driving} -body {
|
||||
testDrive brumm 10 User } -result OK
|
||||
|
||||
brumm errortype 6
|
||||
test motor-1.1 {Test Interrupting} -body {
|
||||
testDriveInterrupt brumm 0 } -result OK
|
||||
|
||||
brumm errortype 1
|
||||
config rights User User
|
||||
|
||||
test motor-1.2 {Test Start Failure} -body {
|
||||
set ans [drive brumm 20.3]
|
||||
if { [string first "Failed to start motor" $ans] < 0} {
|
||||
error "Failed to trigger motor start failure: $ans"
|
||||
}
|
||||
set ans [status]
|
||||
if { [string first "Eager" $ans] < 0} {
|
||||
error "Motor did not return from start failure"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
brumm recover 1
|
||||
test motor-1.3 {Test Recover from start problem} -body {
|
||||
set ans [drive brumm 20.3]
|
||||
if { [string first "Failed to start motor" $ans] < 0} {
|
||||
error "Failed to trigger motor start failure"
|
||||
}
|
||||
set ans [status]
|
||||
if { [string first "Eager" $ans] < 0} {
|
||||
error "Motor did not return from start failure"
|
||||
}
|
||||
compareValue [SICSValue brumm] 20.3
|
||||
} -result OK
|
||||
|
||||
brumm recover 0
|
||||
brumm errortype 2
|
||||
|
||||
test motor-1.4 {Test Position Failure} -body {
|
||||
set ans [drive brumm -20.3]
|
||||
if { [string first "Position not reached" $ans] < 0} {
|
||||
error "Failed to trigger motor position fault: $ans"
|
||||
}
|
||||
set ans [status]
|
||||
if { [string first "Eager" $ans] < 0} {
|
||||
error "Motor did not return from position failure"
|
||||
}
|
||||
set ans [SICSValue brumm]
|
||||
if {abs($ans - -20.3) < .01} {
|
||||
error "Motor positioned OK inspite of position fault"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
brumm recover 1
|
||||
|
||||
test motor-1.6 {Test Position Failure Recover} -body {
|
||||
set ans [drive brumm 20.3]
|
||||
if { [string first "Position not reached" $ans] < 0} {
|
||||
error "Failed to trigger motor position fault: $ans"
|
||||
}
|
||||
if { [string first "restarting" $ans] < 0} {
|
||||
error "Restarting message not received"
|
||||
}
|
||||
set ans [status]
|
||||
if { [string first "Eager" $ans] < 0} {
|
||||
error "Motor did not return from position failure"
|
||||
}
|
||||
compareValue [SICSValue brumm] 20.3
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
brumm errortype 3
|
||||
brumm recover 0
|
||||
test motor-1.7 {Test Hardware Failure} -body {
|
||||
set ans [drive brumm 20.3]
|
||||
if { [string first "Hardware is mad" $ans] < 0} {
|
||||
error "Failed to trigger motor hardware fault: $ans"
|
||||
}
|
||||
set ans [status]
|
||||
if { [string first "Eager" $ans] < 0} {
|
||||
error "Motor did not return from position failure"
|
||||
}
|
||||
set ans [SICSValue brumm]
|
||||
if {abs($ans - 20.3) < .01} {
|
||||
error "Motor positioned OK inspite of hardware fault"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
brumm recover 1
|
||||
|
||||
test motor-1.8 {Test Hardware Failure Recover} -body {
|
||||
set ans [drive brumm 20.3]
|
||||
if { [string first "Hardware is mad" $ans] < 0} {
|
||||
error "Failed to trigger motor hardware fault: $ans"
|
||||
}
|
||||
if { [string first "restarting" $ans] < 0} {
|
||||
error "Restarting message not received"
|
||||
}
|
||||
set ans [status]
|
||||
if { [string first "Eager" $ans] < 0} {
|
||||
error "Motor did not return from hardware failure"
|
||||
}
|
||||
compareValue [SICSValue brumm] 20.3
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
brumm errortype 4
|
||||
|
||||
test motor-1.9 {Test Consistent Mispositioning} -body {
|
||||
set ans [drive brumm -20.3]
|
||||
if { [string first "off position" $ans] < 0} {
|
||||
error "Failed to trigger motor off position"
|
||||
}
|
||||
if { [string first "restarting" $ans] < 0} {
|
||||
error "Restarting message not received"
|
||||
}
|
||||
if { [string first "aborting" $ans] < 0} {
|
||||
error "Aborting message not received"
|
||||
}
|
||||
set ans [status]
|
||||
if { [string first "Eager" $ans] < 0} {
|
||||
error "Motor did not return after consistent position problem"
|
||||
}
|
||||
set ans [SICSValue brumm]
|
||||
if {abs($ans - -20.3) < .01} {
|
||||
error "Motor positioned OK inspite of mispositioning"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
brumm errortype 0
|
||||
drive brumm 27.
|
||||
|
||||
brumm errortype 5
|
||||
brumm recover 0
|
||||
|
||||
test motor-1.10 {Failed read} -body {
|
||||
set ans [brumm]
|
||||
if { [string first "Failed to read" $ans] < 0} {
|
||||
error "Failed to trigger motor failed read"
|
||||
}
|
||||
if { [string first "Error obtaining position" $ans] < 0} {
|
||||
error "Failed to abort reading"
|
||||
}
|
||||
if { [string first "cannot fix" $ans] < 0} {
|
||||
error "Missing cannot fix message"
|
||||
}
|
||||
set ans [status]
|
||||
if { [string first "Eager" $ans] < 0} {
|
||||
error "Motor did not return after failed read"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
brumm recover 1
|
||||
|
||||
test motor-1.11 {Failed read recover} -body {
|
||||
set ans [brumm]
|
||||
if { [string first "Failed to read" $ans] < 0} {
|
||||
error "Failed to trigger motor failed read"
|
||||
}
|
||||
if { [string first "brumm =" $ans] < 0} {
|
||||
error "Motor did not return value after fixing failed read"
|
||||
}
|
||||
set ans [status]
|
||||
if { [string first "Eager" $ans] < 0} {
|
||||
error "Motor did not return after failed read"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
brumm errortype 0
|
||||
drive brumm 27.
|
||||
brumm recover 0
|
||||
brumm errortype 3
|
||||
|
||||
test motor-1.12 {Motor Alarm} -body {
|
||||
drive brumm -27
|
||||
drive brumm -27
|
||||
drive brumm -27
|
||||
drive brumm -27
|
||||
set ans [drive brumm -27]
|
||||
if { [string first "MOTOR ALARM" $ans] < 0} {
|
||||
error "Motor did not stop with Alarm"
|
||||
}
|
||||
set ans [status]
|
||||
if { [string first "Eager" $ans] < 0} {
|
||||
error "Motor did not return after Alarm"
|
||||
}
|
||||
brumm errortype 0
|
||||
set ans [drive brumm -27]
|
||||
if { [string first "sucessfully" $ans] < 0} {
|
||||
error "Motor did not recover after Alarm"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
brumm errortype 0
|
||||
config rights Mugger Mugger
|
||||
|
||||
test motor-1.13 {Motor Sign} -body {
|
||||
brumm sign 1
|
||||
drive brumm 27.
|
||||
set old [SICSValue brumm]
|
||||
brumm sign -1
|
||||
set newVal [SICSValue brumm]
|
||||
set br [brumm sign]
|
||||
brumm sign 1
|
||||
return [compareValue [expr $old * -1] $newVal]
|
||||
} -result OK
|
||||
|
||||
brumm sign 1.
|
||||
|
||||
test motor-1.14 {Motor Recover} -body {
|
||||
brumm sign -1.
|
||||
brumm softzero 5
|
||||
set data [brumm list]
|
||||
backup hugo.bck
|
||||
recover hugo.bck
|
||||
set newData [brumm list]
|
||||
if {[string compare $data $newData] != 0} {
|
||||
backup hugo2.bck
|
||||
error "Recovery failed: look at diff between hugo.bck and hugo2.bck"
|
||||
}
|
||||
brumm sign 1
|
||||
brumm softzero 0
|
||||
set data [brumm list]
|
||||
backup hugo.bck
|
||||
recover hugo.bck
|
||||
set newData [brumm list]
|
||||
if {[string compare $data $newData] != 0} {
|
||||
backup hugo2.bck
|
||||
error "Recovery failed: look at diff between hugo.bck and hugo2.bck"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
config rights Spy Spy
|
||||
test motorpar-1.15 {Test sign setting} -body {
|
||||
testPar "brumm sign" -1 Mugger } -result OK
|
||||
117
test/nxscripttest.tcl
Normal file
117
test/nxscripttest.tcl
Normal file
@ -0,0 +1,117 @@
|
||||
#---------------------------------------------------------------------------
|
||||
# Regression tests for the SICS nxscript module.
|
||||
#
|
||||
# Mark Koennecke, November 2006
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
puts stdout "Testing NXScript"
|
||||
|
||||
test nxscript-1.0 {Test opening file} -body {
|
||||
config rights Spy Spy
|
||||
testCommand "nxscript createxml test.xml test.dic" ERROR
|
||||
config rights User User
|
||||
testOK "nxscript createxml test.xml test.dic"
|
||||
} -result OK
|
||||
|
||||
test nxscript-1.1 {Write text} -body {
|
||||
testNoError "nxscript puttext text Hugo ist eine Nassnase"
|
||||
} -result OK
|
||||
|
||||
test nxscript-1.2 {Write float} -body {
|
||||
testNoError "nxscript putfloat testfloat 27.8"
|
||||
} -result OK
|
||||
|
||||
test nxscript-1.3 {Write int} -body {
|
||||
testNoError "nxscript putint testint 177"
|
||||
} -result OK
|
||||
|
||||
drive a4 15
|
||||
a4 softzer0 1.
|
||||
|
||||
test nxscript-1.4 {Write motor} -body {
|
||||
testNoError "nxscript putmot testmot a4"
|
||||
} -result OK
|
||||
|
||||
aba count 10
|
||||
test nxscript-1.5 {Write counter} -body {
|
||||
testNoError "nxscript putcounter testcter aba"
|
||||
} -result OK
|
||||
|
||||
hm initval 55
|
||||
test nxscript-1.6 {Write HM} -body {
|
||||
testNoError "nxscript puthm testhm hm"
|
||||
} -result OK
|
||||
|
||||
config rights Mugger Mugger
|
||||
tof genbin 500 300 20
|
||||
tof init
|
||||
config rights User User
|
||||
|
||||
test nxscript-1.7 {Write time binning} -body {
|
||||
testNoError "nxscript puttimebinning testhmtb tof"
|
||||
} -result OK
|
||||
|
||||
|
||||
test nxscript-1.8 {Write array } -body {
|
||||
makearray
|
||||
set t [nxscript putarray testar ar 10]
|
||||
if {[string first ERROR $t] >= 0 || [string first WARNING $t] >= 0} {
|
||||
error "Failed to write array with: $t"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test nxscript-1.9 {Write int array } -body {
|
||||
makeintarray
|
||||
set t [nxscript putintarray testintar ar 10]
|
||||
if {[string first ERROR $t] >= 0 || [string first WARNING $t] >= 0} {
|
||||
error "Failed to write intarray with: $t"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test nxscript-1.10 {Write global } -body {
|
||||
testNoError "nxscript putglobal Instrument Washmaschine"
|
||||
} -result OK
|
||||
|
||||
test nxscript-1.11 {Write attribute } -body {
|
||||
testNoError "nxscript putattribute testhm signal 1"
|
||||
} -result OK
|
||||
|
||||
test nxscript-1.12 {Writing link } -body {
|
||||
testNoError "nxscript makelink testlink text"
|
||||
} -result OK
|
||||
|
||||
test nxscript-1.13 {Writing sicsdata } -body {
|
||||
hm initval 23
|
||||
data clear
|
||||
data copyhm 0 hm
|
||||
testNoError "nxscript putsicsdata testsd data"
|
||||
} -result OK
|
||||
|
||||
test nxscript-1.14 {Writing slabs } -body {
|
||||
data clear
|
||||
data putfloat 0 1.1
|
||||
testNoError "nxscript putslab testslab [list 0] [list 1] data"
|
||||
data putfloat 0 2.2
|
||||
testNoError "nxscript putslab testslab [list 1] [list 1] data"
|
||||
data putfloat 0 3.3
|
||||
testNoError "nxscript putslab testslab [list 2] [list 1] data"
|
||||
} -result OK
|
||||
|
||||
|
||||
test nxscript-1.20 {Close file} -body {
|
||||
testOK "nxscript close"
|
||||
} -result OK
|
||||
|
||||
test nxscript-1.21 {Testing file content } -body {
|
||||
set status [catch {exec diff --ignore-matching-lines=file_time test.xml testsoll.xml} msg]
|
||||
if {$status != 0} {
|
||||
error "Difference in NXSCRIP-XML file: $msg"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
|
||||
|
||||
|
||||
305
test/object.tcl
Normal file
305
test/object.tcl
Normal file
@ -0,0 +1,305 @@
|
||||
#
|
||||
# $Id$
|
||||
#
|
||||
# This software is copyright (C) 1995 by the Lawrence Berkeley Laboratory.
|
||||
#
|
||||
# Redistribution and use in source and binary forms, with or without
|
||||
# modification, are permitted provided that: (1) source code distributions
|
||||
# retain the above copyright notice and this paragraph in its entirety, (2)
|
||||
# distributions including binary code include the above copyright notice and
|
||||
# this paragraph in its entirety in the documentation or other materials
|
||||
# provided with the distribution, and (3) all advertising materials mentioning
|
||||
# features or use of this software display the following acknowledgement:
|
||||
# ``This product includes software developed by the University of California,
|
||||
# Lawrence Berkeley Laboratory and its contributors.'' Neither the name of
|
||||
# the University nor the names of its contributors may be used to endorse
|
||||
# or promote products derived from this software without specific prior
|
||||
# written permission.
|
||||
#
|
||||
# THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR IMPLIED
|
||||
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
|
||||
# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
|
||||
#
|
||||
|
||||
set object_priv(currentClass) {}
|
||||
set object_priv(objectCounter) 0
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
proc object_class {name spec} {
|
||||
global object_priv
|
||||
set object_priv(currentClass) $name
|
||||
lappend object_priv(objects) $name
|
||||
upvar #0 ${name}_priv class
|
||||
set class(__members) {}
|
||||
set class(__methods) {}
|
||||
set class(__params) {}
|
||||
set class(__class_vars) {}
|
||||
set class(__class_methods) {}
|
||||
uplevel $spec
|
||||
proc $name:config args "uplevel \[concat object_config \$args]"
|
||||
proc $name:configure args "uplevel \[concat object_config \$args]"
|
||||
proc $name:cget {self option} "uplevel \[list object_cget \$self \$option]"
|
||||
}
|
||||
#---------------------------------------------------------------------
|
||||
proc method {name args body} {
|
||||
global object_priv
|
||||
set className $object_priv(currentClass)
|
||||
upvar #0 ${className}_priv class
|
||||
if {[lsearch $class(__methods) $name] < 0} {
|
||||
lappend class(__methods) $name
|
||||
}
|
||||
set methodArgs self
|
||||
append methodArgs " " $args
|
||||
proc $className:$name $methodArgs "upvar #0 \$self slot ${className}_priv class_var\n$body"
|
||||
}
|
||||
#------------------------------------------------------------------
|
||||
proc object_method {name {defaultValue {}}} [info body method]
|
||||
#------------------------------------------------------------------
|
||||
proc member {name {defaultValue {}}} {
|
||||
global object_priv
|
||||
set className $object_priv(currentClass)
|
||||
upvar #0 ${className}_priv class
|
||||
lappend class(__members) [list $name $defaultValue]
|
||||
}
|
||||
#----------------------------------------------------------------------
|
||||
proc object_member {name {defaultValue {}}} [info body member]
|
||||
#---------------------------------------------------------------------
|
||||
proc param {name {defaultValue {}} {resourceClass {}} {configCode {}}} {
|
||||
global object_priv
|
||||
set className $object_priv(currentClass)
|
||||
upvar #0 ${className}_priv class
|
||||
if {$resourceClass == ""} {
|
||||
set resourceClass \
|
||||
[string toupper [string index $name 0]][string range $name 1 end]
|
||||
}
|
||||
if ![info exists class(__param_info/$name)] {
|
||||
lappend class(__params) $name
|
||||
}
|
||||
set class(__param_info/$name) [list $defaultValue $resourceClass]
|
||||
if {$configCode != {}} {
|
||||
proc $className:config:$name self $configCode
|
||||
}
|
||||
}
|
||||
#-------------------------------------------------------------------------
|
||||
proc object_param {name {defaultValue {}} {resourceClass {}} {configCode {}}} \
|
||||
[info body param]
|
||||
|
||||
#--------------------------------------------------------------------------
|
||||
proc object_class_var {name {initialValue ""}} {
|
||||
global object_priv
|
||||
set className $object_priv(currentClass)
|
||||
upvar #0 ${className}_priv class
|
||||
set class($name) $initialValue
|
||||
set class(__initial_value.$name) $initialValue
|
||||
lappend class(__class_vars) $name
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
proc object_class_method {name args body} {
|
||||
global object_priv
|
||||
set className $object_priv(currentClass)
|
||||
upvar #0 ${className}_priv class
|
||||
if {[lsearch $class(__class_methods) $name] < 0} {
|
||||
lappend class(__class_methods) $name
|
||||
}
|
||||
proc $className:$name $args "upvar #0 ${className}_priv class_var\n$body"
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
proc object_include {super_class_name} {
|
||||
global object_priv
|
||||
set className $object_priv(currentClass)
|
||||
upvar #0 ${className}_priv class
|
||||
upvar #0 ${super_class_name}_priv super_class
|
||||
foreach p $super_class(__params) {
|
||||
lappend class(__params) $p
|
||||
set class(__param_info/$p) $super_class(__param_info/$p)
|
||||
}
|
||||
set class(__members) [concat $super_class(__members) $class(__members)]
|
||||
set class(__class_vars) \
|
||||
[concat $super_class(__class_vars) $class(__class_vars)]
|
||||
foreach v $super_class(__class_vars) {
|
||||
set class($v) \
|
||||
[set class(__initial_value.$v) $super_class(__initial_value.$v)]
|
||||
}
|
||||
set class(__class_methods) \
|
||||
[concat $super_class(__class_methods) $class(__class_methods)]
|
||||
set class(__methods) \
|
||||
[concat $super_class(__methods) $class(__methods)]
|
||||
foreach m $super_class(__methods) {
|
||||
set proc $super_class_name:$m
|
||||
proc $className:$m [object_get_formals $proc] [info body $proc]
|
||||
}
|
||||
foreach m $super_class(__class_methods) {
|
||||
set proc $super_class_name:$m
|
||||
regexp "^\[^\n\]+\n(.*)" [info body $proc] dummy body
|
||||
proc $className:$m [object_get_formals $proc] \
|
||||
"upvar #0 ${className}_priv class_var\n$body"
|
||||
}
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
proc object_new {className {name {}}} {
|
||||
if {$name == {}} {
|
||||
global object_priv
|
||||
set name O_[incr object_priv(objectCounter)]
|
||||
}
|
||||
upvar #0 $name object
|
||||
upvar #0 ${className}_priv class
|
||||
set object(__class) $className
|
||||
foreach var $class(__params) {
|
||||
set info $class(__param_info/$var)
|
||||
set resourceClass [lindex $info 1]
|
||||
if ![catch {set val [option get $name $var $resourceClass]}] {
|
||||
if {$val == ""} {
|
||||
set val [lindex $info 0]
|
||||
}
|
||||
} else {
|
||||
set val [lindex $info 0]
|
||||
}
|
||||
set object($var) $val
|
||||
}
|
||||
foreach var $class(__members) {
|
||||
set object([lindex $var 0]) [lindex $var 1]
|
||||
}
|
||||
proc $name {method args} [format {
|
||||
upvar #0 %s object
|
||||
uplevel [concat $object(__class):$method %s $args]
|
||||
} $name $name]
|
||||
return $name
|
||||
}
|
||||
#---------------------------------------------------------------
|
||||
proc object_define_creator {windowType name spec} {
|
||||
object_class $name $spec
|
||||
if {[info procs $name:create] == {}} {
|
||||
error "widget \"$name\" must define a create method"
|
||||
}
|
||||
if {[info procs $name:reconfig] == {}} {
|
||||
error "widget \"$name\" must define a reconfig method"
|
||||
}
|
||||
proc $name {window args} [format {
|
||||
%s $window -class %s
|
||||
rename $window object_window_of$window
|
||||
upvar #0 $window object
|
||||
set object(__window) $window
|
||||
object_new %s $window
|
||||
proc %s:frame {self args} \
|
||||
"uplevel \[concat object_window_of$window \$args]"
|
||||
uplevel [concat $window config $args]
|
||||
$window create
|
||||
set object(__created) 1
|
||||
bind $window <Destroy> \
|
||||
"if !\[string compare %%W $window\] { object_delete $window }"
|
||||
$window reconfig
|
||||
return $window
|
||||
} $windowType \
|
||||
[string toupper [string index $name 0]][string range $name 1 end] \
|
||||
$name $name]
|
||||
}
|
||||
#------------------------------------------------------------------
|
||||
proc object_config {self args} {
|
||||
upvar #0 $self object
|
||||
set len [llength $args]
|
||||
if {$len == 0} {
|
||||
upvar #0 $object(__class)_priv class
|
||||
set result {}
|
||||
foreach param $class(__params) {
|
||||
set info $class(__param_info/$param)
|
||||
lappend result \
|
||||
[list -$param $param [lindex $info 1] [lindex $info 0] \
|
||||
$object($param)]
|
||||
}
|
||||
if [info exists object(__window)] {
|
||||
set result [concat $result [object_window_of$object(__window) config]]
|
||||
}
|
||||
return $result
|
||||
}
|
||||
if {$len == 1} {
|
||||
upvar #0 $object(__class)_priv class
|
||||
if {[string index $args 0] != "-"} {
|
||||
error "param '$args' didn't start with dash"
|
||||
}
|
||||
set param [string range $args 1 end]
|
||||
if {[set ndx [lsearch -exact $class(__params) $param]] == -1} {
|
||||
if [info exists object(__window)] {
|
||||
return [object_window_of$object(__window) config -$param]
|
||||
}
|
||||
error "no param '$args'"
|
||||
}
|
||||
set info $class(__param_info/$param)
|
||||
return [list -$param $param [lindex $info 1] [lindex $info 0] \
|
||||
$object($param)]
|
||||
}
|
||||
# accumulate commands and eval them later so that no changes will take
|
||||
# place if we find an error
|
||||
set cmds ""
|
||||
while {$args != ""} {
|
||||
set fieldId [lindex $args 0]
|
||||
if {[string index $fieldId 0] != "-"} {
|
||||
error "param '$fieldId' didn't start with dash"
|
||||
}
|
||||
set fieldId [string range $fieldId 1 end]
|
||||
if ![info exists object($fieldId)] {
|
||||
if {[info exists object(__window)]} {
|
||||
if [catch [list object_window_of$object(__window) config -$fieldId]] {
|
||||
error "tried to set param '$fieldId' which did not exist."
|
||||
} else {
|
||||
lappend cmds \
|
||||
[list object_window_of$object(__window) config -$fieldId [lindex $args 1]]
|
||||
set args [lrange $args 2 end]
|
||||
continue
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
if {[llength $args] == 1} {
|
||||
return $object($fieldId)
|
||||
} else {
|
||||
lappend cmds [list set object($fieldId) [lindex $args 1]]
|
||||
if {[info procs $object(__class):config:$fieldId] != {}} {
|
||||
lappend cmds [list $self config:$fieldId]
|
||||
}
|
||||
set args [lrange $args 2 end]
|
||||
}
|
||||
}
|
||||
foreach cmd $cmds {
|
||||
eval $cmd
|
||||
}
|
||||
if {[info exists object(__created)] && [info procs $object(__class):reconfig] != {}} {
|
||||
$self reconfig
|
||||
}
|
||||
}
|
||||
|
||||
proc object_cget {self var} {
|
||||
upvar #0 $self object
|
||||
return [lindex [object_config $self $var] 4]
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
proc object_delete self {
|
||||
upvar #0 $self object
|
||||
if {[info exists object(__class)] && [info commands $object(__class):destroy] != ""} {
|
||||
$object(__class):destroy $self
|
||||
}
|
||||
if [info exists object(__window)] {
|
||||
if [string length [info commands object_window_of$self]] {
|
||||
catch {rename $self {}}
|
||||
rename object_window_of$self $self
|
||||
}
|
||||
destroy $self
|
||||
}
|
||||
catch {unset object}
|
||||
}
|
||||
#--------------------------------------------------------------------------
|
||||
proc object_slotname slot {
|
||||
upvar self self
|
||||
return [set self]($slot)
|
||||
}
|
||||
#--------------------------------------------------------------------------
|
||||
proc object_get_formals {proc} {
|
||||
set formals {}
|
||||
foreach arg [info args $proc] {
|
||||
if [info default $proc $arg def] {
|
||||
lappend formals [list $arg $def]
|
||||
} else {
|
||||
lappend formals $arg
|
||||
}
|
||||
}
|
||||
return $formals
|
||||
}
|
||||
171
test/optitest.tcl
Normal file
171
test/optitest.tcl
Normal file
@ -0,0 +1,171 @@
|
||||
#--------------------------------------------------------------------
|
||||
# This file contaisn test for the peak optimization routines in SICS
|
||||
#
|
||||
# Mark Koennecke, October 2006
|
||||
#-------------------------------------------------------------------
|
||||
clientput "Testing optimization routines...."
|
||||
|
||||
config rights Mugger Mugger
|
||||
aba setpar errortype 1 0
|
||||
config rights User User
|
||||
|
||||
test opt-1.0 {Test Normal Optimizer} -body {
|
||||
testOK "opti clear"
|
||||
testOK "opti addvar a4 .3 20 .3"
|
||||
testOK "opti preset 2"
|
||||
testOK "opti countmode timer"
|
||||
drive a4 4.
|
||||
set result [eval opti run]
|
||||
if { [string first ERROR $result] > 0} {
|
||||
puts stdout $result
|
||||
error "Error occurred during optimization run"
|
||||
}
|
||||
if {[string first finished $result] < 0} {
|
||||
error "Optimization did not finish normally"
|
||||
}
|
||||
set val [SICSValue a4]
|
||||
if {abs($val - 5.3) > .1} {
|
||||
error "Optimisation did not arrive at desired position"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test opt-1.1 {Test Normal Optimizer Aborting} -body {
|
||||
testOK "opti clear"
|
||||
testOK "opti addvar a4 .3 20 .3"
|
||||
testOK "opti preset 2"
|
||||
testOK "opti countmode timer"
|
||||
drive a4 4.
|
||||
exec interrupt.tcl &
|
||||
set result [eval opti run]
|
||||
if {[string first "Scan aborted" $result] < 0} {
|
||||
error "Optimiser did not abort
|
||||
}
|
||||
set result [status]
|
||||
if { [string first Eager $result] < 0} {
|
||||
puts stdout $result
|
||||
error "Optimiser did not interrupt!"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test opt-1.2 {Test Climbing } -body {
|
||||
testOK "opti clear"
|
||||
testOK "opti addvar a4 .3 20 .5"
|
||||
testOK "opti preset 2"
|
||||
testOK "opti countmode timer"
|
||||
drive a4 4.
|
||||
set result [eval opti climb]
|
||||
if { [string first ERROR $result] > 0} {
|
||||
puts stdout $result
|
||||
error "Error occurred during optimization run"
|
||||
}
|
||||
if {[string first finished $result] < 0} {
|
||||
error "Optimization did not finish normally"
|
||||
}
|
||||
set val [SICSValue a4]
|
||||
if {abs($val - 5.3) > .5} {
|
||||
error "Optimisation did not arrive at desired position"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test opt-1.3 {Test Climbing } -body {
|
||||
testOK "opti clear"
|
||||
testOK "opti addvar a4 .3 20 .5"
|
||||
testOK "opti preset 2"
|
||||
testOK "opti countmode timer"
|
||||
drive a4 6.
|
||||
set result [eval opti climb]
|
||||
if { [string first ERROR $result] > 0} {
|
||||
puts stdout $result
|
||||
error "Error occurred during optimization run"
|
||||
}
|
||||
if {[string first finished $result] < 0} {
|
||||
error "Optimization did not finish normally"
|
||||
}
|
||||
set val [SICSValue a4]
|
||||
if {abs($val - 5.3) > .5} {
|
||||
error "Optimisation did not arrive at desired position"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test opt-1.4 {Test Climbing Interruption} -body {
|
||||
testOK "opti clear"
|
||||
testOK "opti addvar a4 .3 20 .5"
|
||||
testOK "opti preset 2"
|
||||
testOK "opti countmode timer"
|
||||
drive a4 4.
|
||||
exec interrupt.tcl &
|
||||
set result [eval opti climb]
|
||||
if {[string first "Scan was aborted" $result] < 0} {
|
||||
error "Optimiser did not abort"
|
||||
}
|
||||
set result [status]
|
||||
if { [string first Eager $result] < 0} {
|
||||
puts stdout $result
|
||||
error "Optimiser did not interrupt!"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
|
||||
test opt-1.5 {Test Maximizer} -body {
|
||||
drive a4 4.
|
||||
set result [eval max a4 .2 timer 2]
|
||||
if { [string first ERROR $result] > 0} {
|
||||
puts stdout $result
|
||||
error "Error occurred during maximization"
|
||||
}
|
||||
if {[string first Found $result] < 0} {
|
||||
error "Optimization did not finish normally"
|
||||
}
|
||||
set val [SICSValue a4]
|
||||
if {abs($val - 5.3) > .1} {
|
||||
error "Maximization did not arrive at desired position"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test opt-1.6 {Test Maximizer} -body {
|
||||
drive a4 6.
|
||||
set result [eval max a4 .2 timer 2]
|
||||
if { [string first ERROR $result] > 0} {
|
||||
puts stdout $result
|
||||
error "Error occurred during maximization"
|
||||
}
|
||||
if {[string first Found $result] < 0} {
|
||||
error "Optimization did not finish normally"
|
||||
}
|
||||
set val [SICSValue a4]
|
||||
if {abs($val - 5.3) > .1} {
|
||||
error "Maximization did not arrive at desired position"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test opt-1.6 {Test Maximizer Aborting} -body {
|
||||
drive a4 6.
|
||||
exec interrupt.tcl &
|
||||
set result [eval max a4 .2 timer 2]
|
||||
if { [string first "Full Stop" $result] < 0} {
|
||||
puts stdout $result
|
||||
error "Maximize did not interrupt!"
|
||||
}
|
||||
set result [status]
|
||||
if { [string first Eager $result] < 0} {
|
||||
puts stdout $result
|
||||
error "Maximize did not interrupt!"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test opt-1.7 {Test Maximizer Parameter} -body {
|
||||
testOK "max in360 1"
|
||||
testOK "max maxpts 50"
|
||||
testCommand "max in360" max.in360
|
||||
testCommand "max maxpts" max.maxpts
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
11390
test/samenv/tomato/07-20.log
Normal file
11390
test/samenv/tomato/07-20.log
Normal file
File diff suppressed because it is too large
Load Diff
486
test/scancommand.tcl
Normal file
486
test/scancommand.tcl
Normal file
@ -0,0 +1,486 @@
|
||||
#--------------------------------------------------------------------------
|
||||
# general scan command wrappers for TOPSI and the like.
|
||||
# New version using the object.tcl system from sntl instead of obTcl which
|
||||
# caused a lot of trouble with tcl8.0
|
||||
#
|
||||
# Requires the built in scan command xxxscan.
|
||||
#
|
||||
# Mark Koennecke, February 2000
|
||||
#--------------------------------------------------------------------------
|
||||
|
||||
source object.tcl
|
||||
set recoverfil recover.bin
|
||||
|
||||
#-------------------------- some utility functions -------------------------
|
||||
proc MC { t n } {
|
||||
set string $t
|
||||
for { set i 1 } { $i < $n } { incr i } {
|
||||
set string [format "%s%s" $string $t]
|
||||
}
|
||||
return $string
|
||||
}
|
||||
#--------------------------------------------------------------------------
|
||||
proc GetNum { text } {
|
||||
set list [split $text =]
|
||||
return [lindex $list 1]
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
|
||||
#************** Definition of scan class **********************************
|
||||
|
||||
object_class ScanCommand {
|
||||
member Mode Monitor
|
||||
member NP 1
|
||||
member counter counter
|
||||
member NoVar 0
|
||||
member Preset 10000
|
||||
member File default.dat
|
||||
member pinterest ""
|
||||
member Channel 0
|
||||
member Active 0
|
||||
member Recover 0
|
||||
member scanvars
|
||||
member scanstart
|
||||
member scanstep
|
||||
member pinterest
|
||||
|
||||
method var {name start step} {
|
||||
# check for activity
|
||||
if {$slot(Active)} {
|
||||
ClientPut "ERROR: cannot change parameters while scanning" error
|
||||
return
|
||||
}
|
||||
# check parameters
|
||||
set t [SICSType $name]
|
||||
if { [string compare $t DRIV] != 0 } {
|
||||
ClientPut [format "ERROR: %s is not drivable" $name] error
|
||||
return 0
|
||||
}
|
||||
set t [SICSType $start]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number!" $start] error
|
||||
return 0
|
||||
}
|
||||
set t [SICSType $step]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number!" $step] error
|
||||
return 0
|
||||
}
|
||||
# install the variable
|
||||
set i $slot(NoVar)
|
||||
incr slot(NoVar)
|
||||
lappend slot(scanvars) $name
|
||||
lappend slot(scanstart) $start
|
||||
lappend slot(scanstep) $step
|
||||
$self SendInterest pinterest ScanVarChange
|
||||
ClientPut OK
|
||||
}
|
||||
|
||||
method info {} {
|
||||
if { $slot(NoVar) < 1 } {
|
||||
return "0,1,NONE,0.,0.,default.dat"
|
||||
}
|
||||
append result $slot(NP) "," $slot(NoVar)
|
||||
for {set i 0} { $i < $slot(NoVar) } { incr i} {
|
||||
append result "," [lindex $slot(scanvars) $i]
|
||||
}
|
||||
append result "," [lindex $slot(scanstart) 0] "," \
|
||||
[lindex $slot(scanstep) 0]
|
||||
set r1 [xxxscan getfile]
|
||||
set l1 [split $r1 "="]
|
||||
append result "," [lindex $l1 1]
|
||||
return $result
|
||||
}
|
||||
|
||||
method getvars {} {
|
||||
set list ""
|
||||
lappend list $slot(scanvars)
|
||||
return [format "scan.Vars = %s -END-" $list]
|
||||
}
|
||||
|
||||
method xaxis {} {
|
||||
if { $slot(NoVar) <= 0} {
|
||||
#---- default Answer
|
||||
set t [format "%s.xaxis = %f %f" $self 0 1]
|
||||
} else {
|
||||
set t [format "%s.xaxis = %f %f" $self [lindex $slot(scanstart) 0] \
|
||||
[lindex $slot(scanstep) 0] ]
|
||||
}
|
||||
ClientPut $t
|
||||
}
|
||||
|
||||
method cinterest {} {
|
||||
xxxscan interest
|
||||
}
|
||||
|
||||
method uuinterest {} {
|
||||
xxxscan uuinterest
|
||||
}
|
||||
|
||||
method pinterest {} {
|
||||
set nam [GetNum [config MyName]]
|
||||
lappend $slot(pinterest) $nam
|
||||
}
|
||||
|
||||
method SendInterest { type text } {
|
||||
#------ check list first
|
||||
set l1 $slot($type)
|
||||
set l2 ""
|
||||
foreach e $l1 {
|
||||
set b [string trim $e]
|
||||
set g [string trim $b "{}"]
|
||||
set ret [SICSType $g]
|
||||
if { [string first COM $ret] >= 0 } {
|
||||
lappend l2 $e
|
||||
}
|
||||
}
|
||||
#-------- update scan data and write
|
||||
set slot($type) $l2
|
||||
foreach e $l2 {
|
||||
set b [string trim $e]
|
||||
$b put $text
|
||||
}
|
||||
}
|
||||
|
||||
method mode { {NewVal NULL} } {
|
||||
if { [string compare $NewVal NULL] == 0 } {
|
||||
set val [format "%s.Mode = %s" $self $slot(Mode)]
|
||||
ClientPut $val
|
||||
return $val
|
||||
} else {
|
||||
# check for activity
|
||||
if {$slot(Active)} {
|
||||
ClientPut "ERROR: cannot change parameters while scanning" error
|
||||
return
|
||||
}
|
||||
set tmp [string tolower $NewVal]
|
||||
set NewVal $tmp
|
||||
if { ([string compare $NewVal "timer"] == 0) || \
|
||||
([string compare $NewVal monitor] ==0) } {
|
||||
set slot(Mode) $NewVal
|
||||
ClientPut OK
|
||||
} else {
|
||||
ClientPut [format "ERROR: %s not recognized as ScanMode" $NewVal]
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
method np { { NewVal NULL } } {
|
||||
if { [string compare $NewVal NULL] == 0 } {
|
||||
set val [format "%s.NP = %d" $self $slot(NP)]
|
||||
ClientPut $val
|
||||
return $val
|
||||
} else {
|
||||
# check for activity
|
||||
if {$slot(Active)} {
|
||||
ClientPut "ERROR: cannot change parameters while scanning" error
|
||||
return
|
||||
}
|
||||
set t [SICSType $NewVal]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number" $NewVal] error
|
||||
return
|
||||
}
|
||||
set slot(NP) $NewVal
|
||||
ClientPut OK
|
||||
}
|
||||
}
|
||||
|
||||
method preset { {NewVal NULL} } {
|
||||
if { [string compare $NewVal NULL] == 0 } {
|
||||
set val [format "%s.Preset = %f" $self $slot(Preset)]
|
||||
ClientPut $val
|
||||
return $val
|
||||
} else {
|
||||
# check for activity
|
||||
if {$slot(Active)} {
|
||||
ClientPut "ERROR: cannot change parameters while scanning" error
|
||||
return
|
||||
}
|
||||
set t [SICSType $NewVal]
|
||||
if { [string compare $t NUM] != 0} {
|
||||
ClientPut [format "ERROR: %s is no number" $NewVal] error
|
||||
return
|
||||
}
|
||||
set slot(Preset) $NewVal
|
||||
ClientPut OK
|
||||
}
|
||||
}
|
||||
|
||||
method file {} {
|
||||
return [xxxscan file]
|
||||
}
|
||||
|
||||
method setchannel {num} {
|
||||
set ret [catch {xxxscan setchannel $num} msg]
|
||||
if { $ret == 0} {
|
||||
set slot(Channel) $num
|
||||
} else {
|
||||
return $msg
|
||||
}
|
||||
}
|
||||
|
||||
method list { } {
|
||||
ClientPut [format "%s.Preset = %f" $self $slot(Preset)]
|
||||
ClientPut [format "%s.Mode = %s" $self $slot(Mode)]
|
||||
ClientPut [format "%s.File = %s" $self $slot(File)]
|
||||
ClientPut [format "%s.NP = %d" $self $slot(NP)]
|
||||
ClientPut [format "%s.Channel = %d" $self $slot(Channel)]
|
||||
ClientPut "ScanVariables:"
|
||||
for { set i 0 } {$i < $slot(NoVar) } { incr i } {
|
||||
ClientPut [format " %s %f %f" [lindex $slot(scanvars) $i] \
|
||||
[lindex $slot(scanstart) $i] \
|
||||
[lindex $slot(scanstep) $i] ]
|
||||
}
|
||||
}
|
||||
|
||||
method clear {} {
|
||||
# check for activity
|
||||
if {$slot(Active)} {
|
||||
ClientPut "ERROR: cannot clear running scan" error
|
||||
return
|
||||
}
|
||||
|
||||
set slot(NP) 0
|
||||
set slot(NoVar) 0
|
||||
set slot(scanvars) ""
|
||||
set slot(scanstart) ""
|
||||
set slot(scanstep) ""
|
||||
$self SendInterest pinterest ScanVarChange
|
||||
xxxscan clear
|
||||
ClientPut OK
|
||||
}
|
||||
|
||||
method getcounts {} {
|
||||
return [xxxscan getcounts]
|
||||
}
|
||||
|
||||
method run { } {
|
||||
# start with error checking
|
||||
if { $slot(NP) < 1 } {
|
||||
ClientPut "ERROR: Insufficient Number of ScanPoints"
|
||||
return
|
||||
}
|
||||
if { $slot(NoVar) < 1 } {
|
||||
ClientPut "ERROR: No variables to scan given!"
|
||||
return
|
||||
}
|
||||
#------- check for activity
|
||||
if {$slot(Active)} {
|
||||
ClientPut "ERROR: Scan already in progress" error
|
||||
return
|
||||
}
|
||||
set slot(Active) 1
|
||||
xxxscan clear
|
||||
for {set i 0 } { $i < $slot(NoVar)} {incr i} {
|
||||
set ret [catch {xxxscan add [lindex $slot(scanvars) $i] \
|
||||
[lindex $slot(scanstart) $i] [lindex $slot(scanstep) $i]} msg]
|
||||
if {$ret != 0} {
|
||||
set slot(Active) 0
|
||||
error $msg
|
||||
}
|
||||
}
|
||||
set ret [catch \
|
||||
{xxxscan run $slot(NP) $slot(Mode) $slot(Preset)} msg]
|
||||
set slot(Active) 0
|
||||
if {$ret != 0 } {
|
||||
error $msg
|
||||
} else {
|
||||
return "Scan Finished"
|
||||
}
|
||||
}
|
||||
|
||||
method recover {} {
|
||||
set slot(Active) 1
|
||||
catch {xxxscan recover} msg
|
||||
set slot(Active) 0
|
||||
return "Scan Finished"
|
||||
}
|
||||
|
||||
method forceclear {} {
|
||||
set Active 0
|
||||
}
|
||||
}
|
||||
#---- end of ScanCommand definition
|
||||
|
||||
#********************** initialisation of module commands to SICS **********
|
||||
|
||||
set ret [catch {scan list} msg]
|
||||
if {$ret != 0} {
|
||||
object_new ScanCommand scan
|
||||
Publish scan Spy
|
||||
Publish scancounts Spy
|
||||
Publish textstatus Spy
|
||||
Publish cscan User
|
||||
Publish sscan User
|
||||
Publish sftime Spy
|
||||
Publish scaninfo Spy
|
||||
}
|
||||
|
||||
#*************************************************************************
|
||||
|
||||
#===================== Helper commands for status display work ============
|
||||
# a new user command which allows status clients to read the counts in a scan
|
||||
# This is just to circumvent the user protection on scan
|
||||
proc scancounts { } {
|
||||
set status [ catch {scan getcounts} result]
|
||||
if { $status == 0 } {
|
||||
return $result
|
||||
} else {
|
||||
return "scan.Counts= 0"
|
||||
}
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
# This is just another utilility function which helps in implementing the
|
||||
# status display client
|
||||
proc textstatus { } {
|
||||
set text [status]
|
||||
return [format "Status = %s" $text]
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
# Dumps time in a useful format
|
||||
proc sftime {} {
|
||||
return [format "sicstime = %s" [sicstime]]
|
||||
}
|
||||
#-------------------------------------------------------------------------
|
||||
# Utility function which gives scan parameters as an easily parsable
|
||||
# comma separated list for java status client
|
||||
proc scaninfo {} {
|
||||
set result [scan info]
|
||||
set r1 [sample]
|
||||
set l1 [split $r1 "="]
|
||||
append result "," [lindex $l1 1]
|
||||
append result "," [sicstime]
|
||||
set r1 [lastscancommand]
|
||||
set l1 [split $r1 "="]
|
||||
append result "," [lindex $l1 1]
|
||||
return [format "scaninfo = %s" $result]
|
||||
}
|
||||
|
||||
#===================== Syntactical sugar around scan ===================
|
||||
# center scan. A convenience scan for the one and only Daniel Clemens
|
||||
# at TOPSI. Scans around a given ceter point. Requires the scan command
|
||||
# for TOPSI to work.
|
||||
#
|
||||
# another convenience scan:
|
||||
# sscan var1 start end var1 start end .... np preset
|
||||
# scans var1, var2 from start to end with np steps and a preset of preset
|
||||
#
|
||||
# Mark Koennecke, August, 22, 1997
|
||||
#-----------------------------------------------------------------------------
|
||||
proc cscan { var center delta np preset } {
|
||||
#------ start with some argument checking
|
||||
set t [SICSType $var]
|
||||
if { [string compare $t DRIV] != 0 } {
|
||||
ClientPut [format "ERROR: %s is NOT drivable!" $var]
|
||||
return
|
||||
}
|
||||
set t [SICSType $center]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number!" $center]
|
||||
return
|
||||
}
|
||||
set t [SICSType $delta]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number!" $delta]
|
||||
return
|
||||
}
|
||||
set t [SICSType $np]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number!" $np]
|
||||
return
|
||||
}
|
||||
set t [SICSType $preset]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number!" $preset]
|
||||
return
|
||||
}
|
||||
#-------- store command in lastscancommand
|
||||
set txt [format "cscan %s %s %s %s %s" $var $center \
|
||||
$delta $np $preset]
|
||||
catch {lastscancommand $txt}
|
||||
#-------- set standard parameters
|
||||
scan clear
|
||||
scan preset $preset
|
||||
scan np [expr $np*2 + 1]
|
||||
#--------- calculate start
|
||||
set start [expr $center - $np * $delta]
|
||||
set ret [catch {scan var $var $start $delta} msg]
|
||||
if { $ret != 0} {
|
||||
ClientPut $msg
|
||||
return
|
||||
}
|
||||
#---------- start scan
|
||||
set ret [catch {scan run} msg]
|
||||
if {$ret != 0} {
|
||||
error $msg
|
||||
}
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
proc sscan args {
|
||||
scan clear
|
||||
#------- check arguments: the last two must be preset and np!
|
||||
set l [llength $args]
|
||||
if { $l < 5} {
|
||||
ClientPut "ERROR: Insufficient number of arguments to sscan"
|
||||
return
|
||||
}
|
||||
set preset [lindex $args [expr $l - 1]]
|
||||
set np [lindex $args [expr $l - 2]]
|
||||
set t [SICSType $preset]
|
||||
ClientPut $t
|
||||
ClientPut [string first $t "NUM"]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: expected number for preset, got %s" \
|
||||
$preset]
|
||||
return
|
||||
}
|
||||
set t [SICSType $np]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: expected number for np, got %s" \
|
||||
$np]
|
||||
return
|
||||
}
|
||||
scan preset $preset
|
||||
scan np $np
|
||||
#--------- do variables
|
||||
set nvar [expr ($l - 2) / 3]
|
||||
for { set i 0 } { $i < $nvar} { incr i } {
|
||||
set var [lindex $args [expr $i * 3]]
|
||||
set t [SICSType $var]
|
||||
if {[string compare $t DRIV] != 0} {
|
||||
ClientPut [format "ERROR: %s is not drivable" $var]
|
||||
return
|
||||
}
|
||||
set start [lindex $args [expr ($i * 3) + 1]]
|
||||
set t [SICSType $start]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: expected number for start, got %s" \
|
||||
$start]
|
||||
return
|
||||
}
|
||||
set end [lindex $args [expr ($i * 3) + 2]]
|
||||
set t [SICSType $end]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: expected number for end, got %s" \
|
||||
$end]
|
||||
return
|
||||
}
|
||||
#--------- do scan parameters
|
||||
set step [expr double($end - $start)/double($np)]
|
||||
set ret [catch {scan var $var $start $step} msg]
|
||||
if { $ret != 0} {
|
||||
ClientPut $msg
|
||||
return
|
||||
}
|
||||
}
|
||||
#------------- set lastcommand text
|
||||
set txt [format "sscan %s" [join $args]]
|
||||
catch {lastscancommand $txt}
|
||||
#------------- start scan
|
||||
set ret [catch {scan run} msg]
|
||||
if {$ret != 0} {
|
||||
error $msg
|
||||
}
|
||||
}
|
||||
177
test/scantest.tcl
Normal file
177
test/scantest.tcl
Normal file
@ -0,0 +1,177 @@
|
||||
#--------------------------------------------------------------------------
|
||||
# This file contains some regression tests for the SICS scan module.
|
||||
# This relies on the presence of a suitable configured multicounter in
|
||||
# the test initialization file. That multi counters script must have been
|
||||
# configured to generate an gaussian based on a a4 position. This gaussian
|
||||
# will then be used to check data and for testing peak based algorithms
|
||||
# such as optimization routines, peak and center etc.
|
||||
#
|
||||
# Mark Koennecke, October 2006
|
||||
#--------------------------------------------------------------------------
|
||||
|
||||
clientput "Testing scan routines.."
|
||||
|
||||
config rights Mugger Mugger
|
||||
aba setpar errortype 1 0
|
||||
config rights User User
|
||||
|
||||
proc testScanResults {} {
|
||||
set result [eval peak data]
|
||||
set l [split $result ,]
|
||||
if { abs([lindex $l 0] - 5.3) > .1} {
|
||||
error "Bad peak position"
|
||||
}
|
||||
if { abs([lindex $l 1] - 1.4) > .3} {
|
||||
error "Bad peak FWHM"
|
||||
}
|
||||
if { abs([lindex $l 2] - 288) > 7} {
|
||||
error "Bad peak Value"
|
||||
}
|
||||
}
|
||||
|
||||
test scan-1.0 {Test Normal Scan} -body {
|
||||
testOK "xxxscan clear"
|
||||
testOK "xxxscan add a4 2. .2"
|
||||
set result [eval xxxscan run 30 timer 2]
|
||||
if {[string first ERROR $result] >= 0} {
|
||||
set idx [string first ERROR $result]
|
||||
set errText [string range $result $idx end]
|
||||
error "ERROR occurred during scan: $errText"
|
||||
}
|
||||
testScanResults
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test scan-1.1 {Test cscan} -body {
|
||||
set result [eval cscan a4 5.3 .2 15 3]
|
||||
if {[string first ERROR $result] >= 0} {
|
||||
set idx [string first ERROR $result]
|
||||
set errText [string range $result $idx end]
|
||||
error "ERROR occurred during scan: $errText"
|
||||
}
|
||||
testScanResults
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test scan-1.2 {Test sscan} -body {
|
||||
set result [eval sscan a4 2 7 30 2]
|
||||
if {[string first ERROR $result] >= 0} {
|
||||
set idx [string first ERROR $result]
|
||||
set errText [string range $result $idx end]
|
||||
error "ERROR occurred during scan: $errText"
|
||||
}
|
||||
testScanResults
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test scan-1.3 {Test scan interest} -body {
|
||||
testOK "xxxscan interest"
|
||||
set result [eval xxxscan run 3 timer 2]
|
||||
if {[string first ERROR $result] >= 0} {
|
||||
set idx [string first ERROR $result]
|
||||
set errText [string range $result $idx end]
|
||||
error "ERROR occurred during scan: $errText"
|
||||
}
|
||||
if {[string first NewScan $result] < 0} {
|
||||
error " NewScan missing"
|
||||
}
|
||||
if {[string first scan.Counts $result] < 0} {
|
||||
error "count data missing"
|
||||
}
|
||||
if {[string first ScanEnd $result] < 0} {
|
||||
error "ScanEnd missing"
|
||||
}
|
||||
xxxscan uninterest
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test scan-1.3.1 {Test scan uuinterest} -body {
|
||||
testOK "xxxscan uuinterest"
|
||||
set result [eval xxxscan run 3 timer 2]
|
||||
if {[string first ERROR $result] >= 0} {
|
||||
set idx [string first ERROR $result]
|
||||
set errText [string range $result $idx end]
|
||||
error "ERROR occurred during scan: $errText"
|
||||
}
|
||||
if {[string first NewScan $result] < 0} {
|
||||
error " NewScan missing"
|
||||
}
|
||||
if {[string first ScanData $result] < 0} {
|
||||
error "count data missing"
|
||||
}
|
||||
if {[string first ScanEnd $result] < 0} {
|
||||
error "ScanEnd missing"
|
||||
}
|
||||
xxxscan uninterest
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test scan-1.3.2 {Test scan dyninterest} -body {
|
||||
testOK "xxxscan dyninterest"
|
||||
set result [eval xxxscan run 3 timer 2]
|
||||
if {[string first ERROR $result] >= 0} {
|
||||
set idx [string first ERROR $result]
|
||||
set errText [string range $result $idx end]
|
||||
error "ERROR occurred during scan: $errText"
|
||||
}
|
||||
if {[string first NewScan $result] < 0} {
|
||||
error " NewScan missing"
|
||||
}
|
||||
if {[string first xxxscan.scanpoint $result] < 0} {
|
||||
error "scan point data missing"
|
||||
}
|
||||
if {[string first ScanEnd $result] < 0} {
|
||||
error "ScanEnd missing"
|
||||
}
|
||||
xxxscan uninterest
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test scan-1.4 {Test scan log} -body {
|
||||
testOK "xxxscan log brumm"
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test scan-1.5 {Test scan getfile} -body {
|
||||
testCommand "xxxscan getfile" scan.File
|
||||
} -result OK
|
||||
|
||||
test scan-1.6 {Test scan getcounts} -body {
|
||||
testCommand "xxxscan getcounts" xxxscan.Counts
|
||||
} -result OK
|
||||
|
||||
test scan-1.7 {Test scan getmonitor } -body {
|
||||
testCommand "xxxscan getmonitor 1" xxxscan.mon01
|
||||
} -result OK
|
||||
|
||||
test scan-1.8 {Test scan gettimes } -body {
|
||||
testCommand "xxxscan gettimes" xxxscan.scantimes
|
||||
} -result OK
|
||||
|
||||
test scan-1.9 {Test scan np } -body {
|
||||
testCommand "xxxscan np" xxxscan.nP
|
||||
} -result OK
|
||||
|
||||
test scan-1.10 {Test scan getvardata } -body {
|
||||
testCommand "xxxscan getvardata 0" scan.a4
|
||||
} -result OK
|
||||
|
||||
test scan-1.11 {Test scan noscanvar } -body {
|
||||
testCommand "xxxscan noscanvar" xxxscan.noscanvar
|
||||
} -result OK
|
||||
|
||||
test scan-1.12 {Test scan getvarpar} -body {
|
||||
testCommand "xxxscan getvarpar 0" xxxscan.a4
|
||||
} -result OK
|
||||
|
||||
test scan-1.13 {Test scan aborting} -body {
|
||||
exec interrupt.tcl &
|
||||
set result [eval cscan a4 5.3 .2 15 3]
|
||||
if {[string first "Scan aborted" $result] < 0} {
|
||||
error "Scan did not interrupt!"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
|
||||
|
||||
23
test/sicsdatasoll.dat
Normal file
23
test/sicsdatasoll.dat
Normal file
@ -0,0 +1,23 @@
|
||||
0 32
|
||||
1 32
|
||||
2 32
|
||||
3 32
|
||||
4 32
|
||||
5 32
|
||||
6 32
|
||||
7 32
|
||||
8 32
|
||||
9 32
|
||||
10 32
|
||||
11 32
|
||||
12 32
|
||||
13 32
|
||||
14 32
|
||||
15 32
|
||||
16 32
|
||||
17 32
|
||||
18 32
|
||||
19 32
|
||||
20 32
|
||||
21 32
|
||||
22 32
|
||||
185
test/sicsstat.tcl
Normal file
185
test/sicsstat.tcl
Normal file
@ -0,0 +1,185 @@
|
||||
exe batchpath ./
|
||||
exe syspath ./
|
||||
|
||||
#--- BEGIN (commands producing errors on last restore)
|
||||
#--- END (commands producing errors on last restore)
|
||||
|
||||
lotte UNKNOWN
|
||||
lotte setAccess 2
|
||||
# Motor brumm
|
||||
brumm sign 1.000000
|
||||
brumm SoftZero 0.000000
|
||||
brumm SoftLowerLim -180.000000
|
||||
brumm SoftUpperLim 180.000000
|
||||
brumm Fixed -1.000000
|
||||
brumm InterruptMode 0.000000
|
||||
brumm precision 0.010000
|
||||
brumm ignorefault 0.000000
|
||||
brumm AccessCode 2.000000
|
||||
brumm failafter 3.000000
|
||||
brumm maxretry 3.000000
|
||||
brumm movecount 10.000000
|
||||
# Motor miau
|
||||
miau sign 1.000000
|
||||
miau SoftZero 0.000000
|
||||
miau SoftLowerLim -180.000000
|
||||
miau SoftUpperLim 180.000000
|
||||
miau Fixed -1.000000
|
||||
miau InterruptMode 0.000000
|
||||
miau precision 0.010000
|
||||
miau ignorefault 0.000000
|
||||
miau AccessCode 2.000000
|
||||
miau failafter 3.000000
|
||||
miau maxretry 3.000000
|
||||
miau movecount 10.000000
|
||||
# Counter aba
|
||||
aba SetPreset 1000.000000
|
||||
aba SetMode Timer
|
||||
# Counter hugo
|
||||
hugo SetPreset 1000.000000
|
||||
hugo SetMode Timer
|
||||
# Counter lieselotte
|
||||
lieselotte SetPreset 1000.000000
|
||||
lieselotte SetMode Timer
|
||||
# Counter multi
|
||||
multi SetPreset 0.000000
|
||||
multi SetMode Timer
|
||||
# Motor a1
|
||||
a1 sign 1.000000
|
||||
a1 SoftZero 0.000000
|
||||
a1 SoftLowerLim -2.000000
|
||||
a1 SoftUpperLim 180.000000
|
||||
a1 Fixed -1.000000
|
||||
a1 InterruptMode 0.000000
|
||||
a1 precision 0.010000
|
||||
a1 ignorefault 0.000000
|
||||
a1 AccessCode 2.000000
|
||||
a1 failafter 3.000000
|
||||
a1 maxretry 3.000000
|
||||
a1 movecount 10.000000
|
||||
# Motor a2
|
||||
a2 sign 1.000000
|
||||
a2 SoftZero 0.000000
|
||||
a2 SoftLowerLim 30.000000
|
||||
a2 SoftUpperLim 150.000000
|
||||
a2 Fixed -1.000000
|
||||
a2 InterruptMode 0.000000
|
||||
a2 precision 0.010000
|
||||
a2 ignorefault 0.000000
|
||||
a2 AccessCode 2.000000
|
||||
a2 failafter 3.000000
|
||||
a2 maxretry 3.000000
|
||||
a2 movecount 10.000000
|
||||
# Motor a3
|
||||
a3 sign 1.000000
|
||||
a3 SoftZero 0.000000
|
||||
a3 SoftLowerLim -360.000000
|
||||
a3 SoftUpperLim 360.000000
|
||||
a3 Fixed -1.000000
|
||||
a3 InterruptMode 0.000000
|
||||
a3 precision 0.010000
|
||||
a3 ignorefault 0.000000
|
||||
a3 AccessCode 2.000000
|
||||
a3 failafter 3.000000
|
||||
a3 maxretry 3.000000
|
||||
a3 movecount 10.000000
|
||||
# Motor a4
|
||||
a4 sign 1.000000
|
||||
a4 SoftZero 0.000000
|
||||
a4 SoftLowerLim -180.000000
|
||||
a4 SoftUpperLim 180.000000
|
||||
a4 Fixed -1.000000
|
||||
a4 InterruptMode 0.000000
|
||||
a4 precision 0.010000
|
||||
a4 ignorefault 0.000000
|
||||
a4 AccessCode 2.000000
|
||||
a4 failafter 3.000000
|
||||
a4 maxretry 3.000000
|
||||
a4 movecount 10.000000
|
||||
# Motor a5
|
||||
a5 sign 1.000000
|
||||
a5 SoftZero 0.000000
|
||||
a5 SoftLowerLim -180.000000
|
||||
a5 SoftUpperLim 180.000000
|
||||
a5 Fixed -1.000000
|
||||
a5 InterruptMode 0.000000
|
||||
a5 precision 0.010000
|
||||
a5 ignorefault 0.000000
|
||||
a5 AccessCode 2.000000
|
||||
a5 failafter 3.000000
|
||||
a5 maxretry 3.000000
|
||||
a5 movecount 10.000000
|
||||
# Motor a6
|
||||
a6 sign 1.000000
|
||||
a6 SoftZero 0.000000
|
||||
a6 SoftLowerLim -180.000000
|
||||
a6 SoftUpperLim 180.000000
|
||||
a6 Fixed -1.000000
|
||||
a6 InterruptMode 0.000000
|
||||
a6 precision 0.010000
|
||||
a6 ignorefault 0.000000
|
||||
a6 AccessCode 2.000000
|
||||
a6 failafter 3.000000
|
||||
a6 maxretry 3.000000
|
||||
a6 movecount 10.000000
|
||||
# Motor sgu
|
||||
sgu sign 1.000000
|
||||
sgu SoftZero 0.000000
|
||||
sgu SoftLowerLim -20.000000
|
||||
sgu SoftUpperLim 20.000000
|
||||
sgu Fixed -1.000000
|
||||
sgu InterruptMode 0.000000
|
||||
sgu precision 0.010000
|
||||
sgu ignorefault 0.000000
|
||||
sgu AccessCode 2.000000
|
||||
sgu failafter 3.000000
|
||||
sgu maxretry 3.000000
|
||||
sgu movecount 10.000000
|
||||
# Motor sgl
|
||||
sgl sign 1.000000
|
||||
sgl SoftZero 0.000000
|
||||
sgl SoftLowerLim -20.000000
|
||||
sgl SoftUpperLim 20.000000
|
||||
sgl Fixed -1.000000
|
||||
sgl InterruptMode 0.000000
|
||||
sgl precision 0.010000
|
||||
sgl ignorefault 0.000000
|
||||
sgl AccessCode 2.000000
|
||||
sgl failafter 3.000000
|
||||
sgl maxretry 3.000000
|
||||
sgl movecount 10.000000
|
||||
# Counter scancter
|
||||
scancter SetPreset 0.000000
|
||||
scancter SetMode Timer
|
||||
hm CountMode timer
|
||||
hm preset 10.000000
|
||||
tof CountMode timer
|
||||
tof preset 10.000000
|
||||
tof genbin 10.000000 12.000000 100
|
||||
tof init
|
||||
#---- tasUB module tasub
|
||||
tasub mono dd 3.350000
|
||||
tasub mono hb1 1.000000
|
||||
tasub mono hb2 1.000000
|
||||
tasub mono vb1 1.000000
|
||||
tasub mono vb2 1.000000
|
||||
tasub mono ss 1
|
||||
tasub ana dd 3.350000
|
||||
tasub ana hb1 1.000000
|
||||
tasub ana hb2 1.000000
|
||||
tasub ana vb1 1.000000
|
||||
tasub ana vb2 1.000000
|
||||
tasub ana ss 1
|
||||
tasub cell 1.000000 1.000000 1.000000 90.000000 90.000000 90.000000
|
||||
tasub clear
|
||||
tasub outofplane 1
|
||||
tasub const ki
|
||||
tasub ss 1
|
||||
tasub setub 1.000000 0.000000 0.000000 0.000000 1.000000 0.000000 0.000000 0.000000 1.000000
|
||||
tasub setnormal 0.000000 0.000000 0.000000
|
||||
tasub settarget 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000
|
||||
tasub r1 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00
|
||||
tasub r2 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00 0.00
|
||||
tasub update
|
||||
#----- MultiMotor sa
|
||||
sa recovernampos noeff a3 24 a4 48
|
||||
40
test/sicstcldebug.tcl
Normal file
40
test/sicstcldebug.tcl
Normal file
@ -0,0 +1,40 @@
|
||||
#------------------------------------------------------------------
|
||||
# This is a helper file in order to debug SICS Tcl scripts. The idea
|
||||
# is that a connection to a SICS interpreter at localhost:2911 is opened.
|
||||
# Then unknown is reimplemented to send unknown commands (which must be
|
||||
# SICS commands) to the SICS interpreter for evaluation. This is done
|
||||
# with transact in order to figure out when SICS finished processing.
|
||||
# Thus is should be possible to debug SICS Tcl scripts in a normal
|
||||
# standalone interpreter without the overhead of restarting SICS
|
||||
# all the time. It may even be possible to use one of the normal
|
||||
# Tcl debuggers then....
|
||||
#
|
||||
# Mark Koennecke, February 2006
|
||||
#------------------------------------------------------------------
|
||||
|
||||
set socke [socket localhost 2911]
|
||||
gets $socke
|
||||
puts $socke "Spy Spy"
|
||||
flush $socke
|
||||
gets $socke
|
||||
#------------------------------------------------------------------
|
||||
proc unknown args {
|
||||
global socke
|
||||
append com "transact " [join $args]
|
||||
puts $socke $com
|
||||
flush $socke
|
||||
set reply ""
|
||||
while {1} {
|
||||
set line [gets $socke]
|
||||
if {[string first TRANSACTIONFINISHED $line] >= 0} {
|
||||
return $reply
|
||||
} else {
|
||||
append reply $line "\n"
|
||||
}
|
||||
}
|
||||
}
|
||||
#------------------------------------------------------------------
|
||||
proc clientput args {
|
||||
puts stdout [join $args]
|
||||
}
|
||||
#------------------------------------------------------------------
|
||||
3354
test/tcltest.tcl
Normal file
3354
test/tcltest.tcl
Normal file
File diff suppressed because it is too large
Load Diff
32
test/test.dic
Normal file
32
test/test.dic
Normal file
@ -0,0 +1,32 @@
|
||||
##NXDICT-1.0
|
||||
#---------------------------------------------------------------------
|
||||
# Dictionary file for testing NXdict
|
||||
#
|
||||
# Mark Koennecke, November 2006
|
||||
#--------------------------------------------------------------------
|
||||
text=/entry1,NXentry/SDS testtext -type NX_CHAR
|
||||
testfloat=/entry1,NXentry/SDS testfloat
|
||||
testint=/entry1,NXentry/SDS testint -type NX_INT32
|
||||
testmot=/entry1,NXentry/SDS position
|
||||
testmot_null=/entry1,NXentry/SDS position_zeropoint
|
||||
testcter_preset=/entry1,NXentry/control,NXmonitor/SDS preset
|
||||
testcter_mode=/entry1,NXentry/control,NXmonitor/SDS mode -type NX_CHAR -dim {132}
|
||||
testcter_time=/entry1,NXentry/control,NXmonitor/SDS time
|
||||
testcter_00=/entry1,NXentry/control,NXmonitor/SDS counts0 -type NX_INT32
|
||||
testcter_01=/entry1,NXentry/control,NXmonitor/SDS counts1 -type NX_INT32
|
||||
testcter_02=/entry1,NXentry/control,NXmonitor/SDS counts2 -type NX_INT32
|
||||
testcter_03=/entry1,NXentry/control,NXmonitor/SDS counts3 -type NX_INT32
|
||||
testcter_04=/entry1,NXentry/control,NXmonitor/SDS counts4 -type NX_INT32
|
||||
testhm=/entry1,NXentry/detector,NXdata/SDS hmdata -type NX_INT32 -rank 1 \
|
||||
-dim {$(dim0)}
|
||||
testhmtb=/entry1,NXentry/detector,NXdata/SDS time_binning
|
||||
testar=/entry1,NXentry/detector,NXdata/SDS x_axis
|
||||
testintar=/entry1,NXentry/detector,NXdata/SDS y_axis -type NX_INT32
|
||||
testsd=/entry1,NXentry/detector,NXdata/SDS gurke -rank 1 \
|
||||
-type NX_INT32 -dim {$(dim0)}
|
||||
testslab=/entry,NXentry/SDS slappy -rank 1 -dim {-1}
|
||||
testlink=/entry1,NXentry/detector,NXdata/NXVGROUP
|
||||
|
||||
|
||||
|
||||
|
||||
7
test/test.hdd
Normal file
7
test/test.hdd
Normal file
@ -0,0 +1,7 @@
|
||||
*************************** Test Data File ********************************
|
||||
Original Filename = !!FILE!!
|
||||
File Creation Date = !!DATE!!
|
||||
****************************************************************************
|
||||
----------------------------------------------------------------------------
|
||||
!!SCANZERO!!
|
||||
**************************** DATA ******************************************
|
||||
10
test/testinc.tcl
Normal file
10
test/testinc.tcl
Normal file
@ -0,0 +1,10 @@
|
||||
#------------------------------------------------------------------------------
|
||||
# This is a prelude to source into tcl for testing regression tests.
|
||||
# copyright: see file COPYRIGHT
|
||||
#
|
||||
# Mark Koennecke, July 2006
|
||||
#------------------------------------------------------------------------------
|
||||
source tcltest.tcl
|
||||
namespace import tcltest::*
|
||||
source testutil.tcl
|
||||
source sicstcldebug.tcl
|
||||
513
test/testini.tcl
Normal file
513
test/testini.tcl
Normal file
@ -0,0 +1,513 @@
|
||||
# --------------------------------------------------------------------------
|
||||
# Initialization script for testing SICS
|
||||
#
|
||||
# Started: Dr. Mark Koennecke, July 2006
|
||||
#---------------------------------------------------------------------------
|
||||
# O P T I O N S
|
||||
|
||||
# --------------- Initialize Tcl internals --------------------------------
|
||||
|
||||
# first all the server options are set
|
||||
|
||||
ServerOption ReadTimeOut 10
|
||||
# timeout when checking for commands. In the main loop SICS checks for
|
||||
# pending commands on each connection with the above timeout, has
|
||||
# PERFORMANCE impact!
|
||||
|
||||
ServerOption AcceptTimeOut 10
|
||||
# timeout when checking for connection req.
|
||||
# Similar to above, but for connections
|
||||
|
||||
ServerOption ReadUserPasswdTimeout 500000
|
||||
# time to wiat for a user/passwd to be sent from a client. Increase this
|
||||
# if there is a problem connecting to a server due to network overload\
|
||||
|
||||
ServerOption ServerPort 2911
|
||||
# the port number the server is going to listen at. The client MUST know
|
||||
# this number in order to connect. It is in client.ini
|
||||
|
||||
ServerOption InterruptPort 2913
|
||||
# The UDP port where the server will wait for Interrupts from clients.
|
||||
# Obviously, clients wishing to interrupt need to know this number.
|
||||
|
||||
|
||||
#---------------------------------------------------------------------------
|
||||
# U S E R S
|
||||
|
||||
# than the SICS users are specified
|
||||
# Syntax: SicsUser name password userRightsCode
|
||||
SicsUser Mugger Mugger 1
|
||||
SicsUser User User 2
|
||||
#SicsUser Spy Spy 3
|
||||
SicsUser Spy 007 1
|
||||
|
||||
#----------------- SICS Variable
|
||||
VarMake lotte Text User
|
||||
|
||||
#----------------- Motors ---------------------------------------------------
|
||||
Motor brumm regress
|
||||
MakeDrive
|
||||
#----------------- Alias ----------------------------------------------------
|
||||
SicsAlias brumm miau
|
||||
#----------------- Counters -------------------------------------------------
|
||||
MakeCounter aba regress
|
||||
MakeCounter hugo SIM -1.
|
||||
MakeCounter lieselotte SIM -1.
|
||||
#------------------------------
|
||||
proc SICSValue {command} {
|
||||
set txt [eval $command]
|
||||
set l [split $txt =]
|
||||
return [string trim [lindex $l 1]]
|
||||
}
|
||||
#-----------------------------
|
||||
proc multitransfer {} {
|
||||
append res [SICSValue "aba gettime"] " "
|
||||
for {set i 0} {$i < 7} {incr i} {
|
||||
append res [SICSValue "aba getmonitor $i"] " "
|
||||
}
|
||||
return $res
|
||||
}
|
||||
#-----------------------------------
|
||||
MakeMultiCounter multi aba hugo lieselotte
|
||||
multi transferscript multitransfer
|
||||
|
||||
#------------- For Scanning ---------------------------------------------
|
||||
# This is with the tricky bit set: we use a multicounter and use the
|
||||
# scantransfer function to return values of a gaussian for a4 positions.
|
||||
# This gives nice scan data which can be used to test all sorts of things.
|
||||
#-------------------------------------------------------------------------
|
||||
MakeDataNumber SicsDataNumber ./DataNumber
|
||||
VarMake SicsDataPath Text Mugger
|
||||
SicsDataPath ./
|
||||
SicsDataPath lock
|
||||
VarMake SicsDataPrefix Text Mugger
|
||||
SicsDataPrefix regression
|
||||
SicsDataPrefix lock
|
||||
VarMake SicsDataPostFix Text Mugger
|
||||
SicsDataPostFix .dat
|
||||
SicsDataPostFix lock
|
||||
|
||||
Motor a1 SIM -2 180 -.1 10
|
||||
Motor a2 SIM 30 150 -.1 10
|
||||
Motor a3 SIM -360 360 -.1 10
|
||||
Motor a4 SIM -180 180 -.1 10
|
||||
Motor a5 SIM -180 180 -.1 10
|
||||
Motor a6 SIM -180 180 -.1 10
|
||||
Motor sgu SIM -20 20 -.1 10
|
||||
Motor sgl SIM -20 20 -.1 10
|
||||
MakeMultiCounter scanCter aba
|
||||
|
||||
proc scantransfer {} {
|
||||
set FWHM 1.5
|
||||
set pos 5.33
|
||||
set height 700
|
||||
set stddev [expr $FWHM/2.354]
|
||||
set ftmp [expr ([SICSValue a4] - $pos)/$stddev]
|
||||
set count [expr 10 + $height*0.4*exp(-.5*$ftmp*$ftmp)]
|
||||
set counti [expr int($count)]
|
||||
append res [SICSValue "lieselotte gettime"] " "
|
||||
append res $counti " "
|
||||
for {set i 1} {$i < 7} {incr i} {
|
||||
append res [SICSValue "lieselotte getmonitor $i"] " "
|
||||
}
|
||||
return $res
|
||||
}
|
||||
scancter transferscript scantransfer
|
||||
|
||||
MakeScanCommand xxxscan scancter test.hdd recover.bin
|
||||
MakePeakCenter xxxscan
|
||||
source scancommand.tcl
|
||||
MakeOptimise opti scancter
|
||||
MakeMaximize scancter
|
||||
|
||||
#-------------------------------------------------------------------------
|
||||
# Histogram Memory
|
||||
#------------------------------------------------------------------------
|
||||
MakeHM hm regress
|
||||
hm configure rank 1
|
||||
hm configure dim0 23
|
||||
hm configure testval 1
|
||||
hm configure errortype 0
|
||||
hm configure recover 1
|
||||
hm configure init 1
|
||||
hm init
|
||||
|
||||
MakeHM tof regress
|
||||
tof configure rank 1
|
||||
tof configure HistMode TOF
|
||||
tof configure dim0 23
|
||||
tof configure testval 1
|
||||
tof configure errortype 0
|
||||
tof configure recover 1
|
||||
tof genbin 10 12 100
|
||||
tof configure init 1
|
||||
tof init
|
||||
|
||||
#-------------------------------------------------------------------------
|
||||
# NXscript
|
||||
#-------------------------------------------------------------------------
|
||||
MakeNXScript
|
||||
#-------------------------------------------------------------------------
|
||||
proc makearray {} {
|
||||
global ar
|
||||
for { set i 10} {$i < 20} {incr i} {
|
||||
set ar([expr $i - 10]) [expr $i*1.0]
|
||||
}
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
proc makeintarray {} {
|
||||
global ar
|
||||
for { set i 10} {$i < 20} {incr i} {
|
||||
set ar([expr $i - 10]) $i
|
||||
}
|
||||
}
|
||||
Publish makearray User
|
||||
Publish makeintarray User
|
||||
Publish parray User
|
||||
|
||||
#------------------------------------------------------------------------
|
||||
# SicsData
|
||||
#------------------------------------------------------------------------
|
||||
sicsdatafactory new data
|
||||
sicsdatafactory new duta
|
||||
#-----------------------------------------------------------------------
|
||||
# tasub
|
||||
#-----------------------------------------------------------------------
|
||||
MakeTasUB tasub
|
||||
#-----------------------------------------------------------------------
|
||||
# MultiMotors
|
||||
#----------------------------------------------------------------------
|
||||
MakeMulti sa
|
||||
sa alias a3 om
|
||||
sa alias a4 stt
|
||||
sa pos noeff a3 24 a4 48
|
||||
sa endconfig
|
||||
|
||||
#-----------------------------------------------------------------------
|
||||
# Hipadaba
|
||||
#----------------------------------------------------------------------
|
||||
InstallHdb
|
||||
hmake /instrument spy none
|
||||
hmake /instrument/sample spy none
|
||||
hattach /instrument/sample a3 omega
|
||||
hattach /instrument/sample qh qh
|
||||
hmake /instrument/detector spy none
|
||||
hattach /instrument/detector hm data
|
||||
hattach /instrument lotte title
|
||||
|
||||
restore
|
||||
|
||||
#-------------------------------------------------
|
||||
proc farmFormat {par num} {
|
||||
hsetprop /sics/farm/$par lastError none
|
||||
return [format "$par %d" [string trim $num]]
|
||||
}
|
||||
#-----------------------------------------------
|
||||
proc farmRead {par } {
|
||||
hsetprop /sics/farm/$par lastError none
|
||||
hsetprop /sics/farm/$par replyCommand "farmReply $par"
|
||||
return $par
|
||||
}
|
||||
#-----------------------------------------------
|
||||
proc farmReply {par reply} {
|
||||
set action [string trim [hgetpropval /sics/farm/$par status]]
|
||||
hsetprop /sics/farm/$par status idle
|
||||
if {[string first OK $reply] >= 0} {
|
||||
if {[string first get $action] >= 0} {
|
||||
set idx [string first : $reply]
|
||||
if {$idx > 0} {
|
||||
set val [string trim [string range $reply [expr $idx +1] end]]
|
||||
hupdate /sics/farm/$par $val
|
||||
}
|
||||
} else {
|
||||
hget /sics/farm/$par
|
||||
}
|
||||
} else {
|
||||
if {[string first ERROR $reply] < 0} {
|
||||
set reply "ERROR: $reply"
|
||||
}
|
||||
clientPut $reply
|
||||
error $reply
|
||||
}
|
||||
}
|
||||
#=============================================
|
||||
proc schconset {val} {
|
||||
set com [farmFormat schnegge $val]
|
||||
hsetprop /sics/farm/schneggecon replyCommand schreply
|
||||
return $com
|
||||
}
|
||||
#----------------------------------------------
|
||||
proc schreply {reply} {
|
||||
clientput "schreply $reply"
|
||||
if {[string first OK $reply] >= 0} {
|
||||
hsetprop /sics/farm/schneggerunning readCommand schrunget
|
||||
hget /sics/farm/schneggerunning
|
||||
hsetprop /sics/farm/schneggerunning readCommand \
|
||||
"farmReply schneggerunning"
|
||||
} else {
|
||||
hsetprop /sics/farm/schneggecon status idle
|
||||
hsetprop /sics/farm/schneggecon lastError $reply
|
||||
clientput "ERROR: $reply on schnegge"
|
||||
}
|
||||
}
|
||||
#-----------------------------------------------
|
||||
proc schrun {reply} {
|
||||
clientput "schrun $reply"
|
||||
hsetprop /sics/farm/schneggerunning status idle
|
||||
if {[string first OK $reply] >= 0} {
|
||||
set idx [string first : $reply]
|
||||
if {$idx > 0} {
|
||||
set val [string trim [string range $reply [expr $idx +1] end]]
|
||||
hupdate /sics/farm/schneggerunning $val
|
||||
if {$val == 1} {
|
||||
clientput "schnegge creeping"
|
||||
hsetprop /sics/farm/schneggerunning readCommand schrunget
|
||||
hget /sics/farm/schneggerunning
|
||||
hsetprop /sics/farm/schneggerunning readCommand \
|
||||
"farmReply schneggerunning"
|
||||
} else {
|
||||
clientput "schnegge finished"
|
||||
hsetprop /sics/farm/schneggerunning readCommand \
|
||||
"farmRead schneggerunning"
|
||||
hsetprop /sics/farm/schneggecon status idle
|
||||
}
|
||||
}
|
||||
} else {
|
||||
clientput "schnegge has error: $reply"
|
||||
hsetprop /sics/farm/schneggerunning readCommand \
|
||||
"farmRead schneggerunning"
|
||||
hsetprop /sics/farm/schneggecon status idle
|
||||
hsetprop /sics/farm/schneggecon lastError $reply
|
||||
hsetprop /sics/farm/schneggerunning lastError $reply
|
||||
}
|
||||
}
|
||||
#----------------------------------------------
|
||||
proc schget {} {
|
||||
hsetprop /sics/farm/schneggecon lastError none
|
||||
hsetprop /sics/farm/schneggecon replyCommand "farmReply schneggecon"
|
||||
return schnegge
|
||||
}
|
||||
#----------------------------------------------
|
||||
proc schrunget {} {
|
||||
hsetprop /sics/farm/schneggerunning lastError none
|
||||
hsetprop /sics/farm/schneggerunning replyCommand schrun
|
||||
return schneggerunning
|
||||
}
|
||||
#-----------------------------------------------
|
||||
set farm 0
|
||||
if {$farm == 1} {
|
||||
# Generic Controller
|
||||
#-------------------------------------------------------------------
|
||||
MakeAsyncProtocol norma
|
||||
MakeAsyncQueue farmQueue norma localhost 9090
|
||||
MakeGenController farm
|
||||
genconfigure asynconnect farm farmQueue
|
||||
#------------------------------------------------
|
||||
genconfigure makepar farm hase int
|
||||
hsetprop /sics/farm/hase priv user
|
||||
hsetprop /sics/farm/hase writeCommand "farmFormat hase"
|
||||
hsetprop /sics/farm/hase readCommand "farmRead hase"
|
||||
hsetprop /sics/farm/hase replyCommand "farmReply hase"
|
||||
|
||||
genconfigure makepar farm schnegge int
|
||||
hsetprop /sics/farm/schnegge priv user
|
||||
hsetprop /sics/farm/schnegge writeCommand "farmFormat schnegge"
|
||||
hsetprop /sics/farm/schnegge readCommand "farmRead schnegge"
|
||||
hsetprop /sics/farm/schnegge replyCommand "farmReply schnegge"
|
||||
|
||||
genconfigure makepar farm schneggerunning int
|
||||
hsetprop /sics/farm/schneggerunning priv internal
|
||||
hsetprop /sics/farm/schneggerunning readCommand "farmRead schneggerunning"
|
||||
hsetprop /sics/farm/schneggerunning replyCommand "farmReply schneggerunning"
|
||||
|
||||
genconfigure makepar farm schneggecon int
|
||||
hsetprop /sics/farm/schneggecon priv user
|
||||
hsetprop /sics/farm/schneggecon writeCommand schconset
|
||||
hsetprop /sics/farm/schneggecon readCommand schget
|
||||
hsetprop /sics/farm/schneggecon replyCommand schreply
|
||||
}
|
||||
|
||||
set farm 0
|
||||
|
||||
if {$farm == 1} {
|
||||
#-------------- Test new async protocol controller
|
||||
makesctcontroller farmser std localhost:7070
|
||||
MakeSICSObj farm TestObj
|
||||
#---------------------------
|
||||
proc farmparcom {par} {
|
||||
sct send $par
|
||||
return parread
|
||||
}
|
||||
#------------------------
|
||||
proc farmparread {} {
|
||||
set rply [sct result]
|
||||
if {[string first ERR $rply] >= 0} {
|
||||
sct geterror $rply
|
||||
return idle
|
||||
}
|
||||
set data [string range $rply 3 end]
|
||||
set node [sct]
|
||||
sct update $data
|
||||
return idle
|
||||
}
|
||||
#--------------------------
|
||||
proc farmcheck {} {
|
||||
set val [sct target]
|
||||
if {$val < -100 || $val > 100} {
|
||||
error "Value out of range"
|
||||
}
|
||||
return OK
|
||||
}
|
||||
#---------------------------
|
||||
proc farmset {par} {
|
||||
set val [sct target]
|
||||
sct send "$par $val"
|
||||
return setreply
|
||||
}
|
||||
#-------------------------
|
||||
proc farmsetreply {} {
|
||||
set rply [sct result]
|
||||
if {[string first ERR $rply] >= 0} {
|
||||
sct print $rply
|
||||
}
|
||||
return idle
|
||||
}
|
||||
#--------------------------
|
||||
hfactory /sics/farm/hase plain spy int
|
||||
hsetprop /sics/farm/hase read farmparcom hase
|
||||
hsetprop /sics/farm/hase parread farmparread
|
||||
|
||||
hsetprop /sics/farm/hase check farmcheck
|
||||
hsetprop /sics/farm/hase write farmset hase
|
||||
hsetprop /sics/farm/hase setreply farmsetreply
|
||||
|
||||
farmser poll /sics/farm/hase
|
||||
farmser write /sics/farm/hase
|
||||
|
||||
hfactory /sics/farm/hugo plain spy int
|
||||
hsetprop /sics/farm/hugo read farmparcom hugo
|
||||
hsetprop /sics/farm/hugo parread farmparread
|
||||
|
||||
hsetprop /sics/farm/hugo check farmcheck
|
||||
hsetprop /sics/farm/hugo write farmset hugo
|
||||
hsetprop /sics/farm/hugo setreply farmsetreply
|
||||
|
||||
farmser poll /sics/farm/hugo
|
||||
farmser write /sics/farm/hugo
|
||||
|
||||
hfactory /sics/farm/schnegge plain spy float
|
||||
hsetprop /sics/farm/schnegge read farmparcom schnegge
|
||||
hsetprop /sics/farm/schnegge parread farmparread
|
||||
|
||||
hsetprop /sics/farm/schnegge check farmcheck
|
||||
hsetprop /sics/farm/schnegge write farmset schnegge
|
||||
hsetprop /sics/farm/schnegge setreply farmsetreply
|
||||
|
||||
farmser poll /sics/farm/schnegge
|
||||
farmser write /sics/farm/schnegge
|
||||
|
||||
hfactory /sics/farm/schneggerunning plain spy int
|
||||
hsetprop /sics/farm/schneggerunning read farmparcom schneggerunning
|
||||
hsetprop /sics/farm/schneggerunning parread farmparread
|
||||
farmser poll /sics/farm/schneggerunning
|
||||
|
||||
hfactory /sics/farm/stone plain spy int
|
||||
hsetprop /sics/farm/stone read farmparcom stone
|
||||
hsetprop /sics/farm/stone parread farmparread
|
||||
#farmser poll /sics/farm/stone
|
||||
|
||||
farmser debug -1
|
||||
|
||||
#----------------- drivable scriptcontext adapter
|
||||
proc schneggechecklimits {} {
|
||||
return [farmcheck]
|
||||
}
|
||||
#-----------------------------
|
||||
proc schneggestatus {} {
|
||||
farmser queue /sics/farm/schneggerunning progress read
|
||||
set status [sct writestatus]
|
||||
switch $status {
|
||||
commandsent {
|
||||
set runtime [SICSValue "hgetprop /sics/farm/schneggerunning read_time"]
|
||||
set starttime [sct write_time]
|
||||
if {$runtime > $starttime} {
|
||||
sct writestatus evalcheck
|
||||
}
|
||||
return busy
|
||||
}
|
||||
evalcheck {
|
||||
set tst [hval /sics/farm/schneggerunning]
|
||||
if {$tst == 1} {
|
||||
return busy
|
||||
} else {
|
||||
return idle
|
||||
}
|
||||
}
|
||||
default {
|
||||
error "schneggestatus called in bad state $status"
|
||||
}
|
||||
}
|
||||
}
|
||||
#---------------------------------------------
|
||||
hsetprop /sics/farm/schnegge checklimits schneggechecklimits
|
||||
hsetprop /sics/farm/schnegge checkstatus schneggestatus
|
||||
#makesctdrive schnecke /sics/farm/schnegge farmser
|
||||
makesctdriveobj schnecke /sics/farm/schnegge DriveAdapter farmser
|
||||
|
||||
}
|
||||
|
||||
#---------- test http
|
||||
set httptest 1
|
||||
|
||||
if {$httptest == 1} {
|
||||
makesctcontroller amorhmsct sinqhttp amorhm data 180 spy 007
|
||||
#makesctcontroller amorhmsct sinqhttp localhost:8080 data 60 spy 007
|
||||
MakeSICSObj amorhm HttpTest
|
||||
amorhmsct debug -1
|
||||
#------------------
|
||||
proc statget {} {
|
||||
sct send "admin/textstatus.egi"
|
||||
return statrepl
|
||||
}
|
||||
#-----------------
|
||||
proc statreply {} {
|
||||
sct update [sct result]
|
||||
sct utime readtime
|
||||
return idle
|
||||
}
|
||||
#-----------------
|
||||
proc readcollapse {} {
|
||||
sct send "admin/processhmdata.egi?bank=0&command=sum:2:0:400"
|
||||
return colread
|
||||
}
|
||||
#-----------------
|
||||
proc colreply {} {
|
||||
sct utime readtime
|
||||
set data [sct result]
|
||||
return idle
|
||||
}
|
||||
#-------------------------
|
||||
hfactory /sics/amorhm/status plain spy text
|
||||
hsetprop /sics/amorhm/status read statget
|
||||
hsetprop /sics/amorhm/status statrepl statreply
|
||||
amorhmsct poll /sics/amorhm/status 10
|
||||
|
||||
hattach /sics/amorhm data intvarar collapse
|
||||
hsetprop /sics/amorhm/collapse read readcollapse
|
||||
hsetprop /sics/amorhm/collapse colread colreply
|
||||
amorhmsct poll /sics/amorhm/collapse 20
|
||||
|
||||
}
|
||||
|
||||
#source sansdruck.tcl
|
||||
|
||||
|
||||
#MakeRS232Controller sadu pc4639 4168
|
||||
#MakeRS232Controller sadu localhost 4168
|
||||
#sadu replyterminator 0x04
|
||||
#sadu sendterminator 0x04
|
||||
#sadu timeout 1000
|
||||
|
||||
#source ../sim/mars/julcho.tcl
|
||||
|
||||
|
||||
21
test/testmisc.tcl
Normal file
21
test/testmisc.tcl
Normal file
@ -0,0 +1,21 @@
|
||||
#--------------------------------------------------------------------
|
||||
# This is for testing odd bits and pieces
|
||||
#
|
||||
# Mark Koennecke, October 2006
|
||||
#--------------------------------------------------------------------
|
||||
|
||||
puts stdout "Testing variables and aliases"
|
||||
|
||||
test misc-1.0 {Test Variables} -body {
|
||||
testPar lotte Uuuuuurgs User
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test misc-1.1 {Test Alias} -body {
|
||||
config rights User User
|
||||
miau errortype 0
|
||||
testDrive miau 10 User
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
|
||||
80
test/testmumo.tcl
Normal file
80
test/testmumo.tcl
Normal file
@ -0,0 +1,80 @@
|
||||
#-----------------------------------------------------------------------
|
||||
# Some tests for SANS style MultiMotors. A MultiMotor with the name sa
|
||||
# must have been initialized in the test initializaton file.
|
||||
#
|
||||
# Mark Koennecke, November 2006
|
||||
#----------------------------------------------------------------------
|
||||
puts stdout "Testing SANS MultiMotor Module..."
|
||||
|
||||
proc testMumoPosition {omPos sttPos} {
|
||||
set txt [sa]
|
||||
set luf [split $txt "\n"]
|
||||
set l1 [lindex $luf 0]
|
||||
if {[string first "Status listing" $l1] < 0} {
|
||||
error "Bad first line on MultiMotor: $l1"
|
||||
}
|
||||
set l2 [lindex $luf 1]
|
||||
set li2 [split $l2 =]
|
||||
if {abs([lindex $li2 1] - $omPos) > .1} {
|
||||
error "Bad omega position: $li2, expected $omPos"
|
||||
}
|
||||
set l2 [lindex $luf 2]
|
||||
set li2 [split $l2 =]
|
||||
if {abs([lindex $li2 1] - $sttPos) > .1} {
|
||||
error "Bad stt position: $li2, expected $sttPos"
|
||||
}
|
||||
return OK
|
||||
}
|
||||
#---------------------------------------------------------------------
|
||||
test mumo-1.0 {Test Reading} -body {
|
||||
config rights Mugger Mugger
|
||||
drive a3 0 a4 0
|
||||
return [testMumoPosition .0 .0]
|
||||
} -result OK
|
||||
#----------------------------------------------------------------------
|
||||
test mumo-1.1 {Test Named Position} -body {
|
||||
sa noeff
|
||||
return [testMumoPosition 24. 48.]
|
||||
} -result OK
|
||||
#---------------------------------------------------------------------
|
||||
test mumo-1.2 {Test Back} -body {
|
||||
sa back
|
||||
return [testMumoPosition 0. 0.]
|
||||
} -result OK
|
||||
#----------------------------------------------------------------------
|
||||
test mumo-1.3 {Test defpos} -body {
|
||||
sa defpos fart om 10 stt 43
|
||||
sa fart
|
||||
return [testMumoPosition 10. 43.]
|
||||
} -result OK
|
||||
#-----------------------------------------------------------------------
|
||||
test mumo-1.4 {Test individual driving} -body {
|
||||
sa noeff
|
||||
sa om 27
|
||||
return [testMumoPosition 27 48.]
|
||||
} -result OK
|
||||
#-----------------------------------------------------------------------
|
||||
test mumo-1.5 {Test pos definiton} -body {
|
||||
sa pos gurke
|
||||
sa back
|
||||
sa gurke
|
||||
return [testMumoPosition 27 48.]
|
||||
} -result OK
|
||||
#----------------------------------------------------------------------
|
||||
test mumo-1.6 {Test dropping named position} -body {
|
||||
sa drop fart
|
||||
set txt [sa fart]
|
||||
if {[string first ERROR $txt] < 0} {
|
||||
error "Did not trigger error when trying to drive a dropped position"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
#----------------------------------------------------------------------
|
||||
test mumo-1.6 {Test Permission} -body {
|
||||
config rights Spy Spy
|
||||
set txt [sa neoff]
|
||||
if {[string first ERROR $txt] < 0} {
|
||||
error "Did not trigger error whithout permission"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
60
test/testsics
Executable file
60
test/testsics
Executable file
@ -0,0 +1,60 @@
|
||||
#!/usr/bin/tclsh
|
||||
#------------------------------------------------------------------------------
|
||||
# This is a regression test for SICS. Before this can be used a SICServer must
|
||||
# have been started with: SICServer testini.tcl. This file uses the
|
||||
# tcltest package which comes with SICS for tests.
|
||||
#
|
||||
# copyright: see file COPYRIGHT
|
||||
#
|
||||
# Started: Mark Koennecke, July 2006
|
||||
#------------------------------------------------------------------------------
|
||||
# as of now we have tcl8.3 which has an outdated version of tcltest. We use
|
||||
# a better version in a local file. Once tcl8.4 has made it into the distro
|
||||
# I use, use the line below. We need tcltest 2.+
|
||||
# package require tcltest
|
||||
source tcltest.tcl
|
||||
namespace import tcltest::*
|
||||
source testutil.tcl
|
||||
source sicstcldebug.tcl
|
||||
|
||||
#--------------- Test Miscellaneous stuff
|
||||
source testmisc.tcl
|
||||
|
||||
#-------------- Test for motors
|
||||
source mottest.tcl
|
||||
|
||||
#-------------- Test Counter
|
||||
set countername aba
|
||||
set errorname aba
|
||||
source countertest.tcl
|
||||
|
||||
#-------------- Test Multi Counter
|
||||
set countername multi
|
||||
source countertest.tcl
|
||||
|
||||
#-------------- Test batch processing
|
||||
source batchtest.tcl
|
||||
|
||||
#-------------- Test scans
|
||||
source scantest.tcl
|
||||
|
||||
#------------ Test peak optimization
|
||||
source optitest.tcl
|
||||
|
||||
#----------- test histogram memory
|
||||
source histtest.tcl
|
||||
|
||||
#----------- test sics data
|
||||
source testsicsdata.tcl
|
||||
|
||||
|
||||
#----------- test nxscript
|
||||
source nxscripttest.tcl
|
||||
|
||||
#------------ test SANS MultiMotor
|
||||
source testmumo.tcl
|
||||
|
||||
#------------ print test summary
|
||||
cleanupTests
|
||||
exit 1
|
||||
|
||||
218
test/testsicsdata.tcl
Normal file
218
test/testsicsdata.tcl
Normal file
@ -0,0 +1,218 @@
|
||||
#-------------------------------------------------------------------------
|
||||
# This is a regression test for the SICS data module
|
||||
#
|
||||
# Mark Koennecke, November 2006
|
||||
#-------------------------------------------------------------------------
|
||||
puts stdout "Testing SicsData"
|
||||
data clear
|
||||
|
||||
test sicsdata-1.0 {Test writing int} -body {
|
||||
config rights User User
|
||||
for {set i 0} {$i < 5} { incr i} {
|
||||
testOK "data putint $i $i"
|
||||
}
|
||||
for {set i 0} {$i < 5} { incr i} {
|
||||
set val [SICSValue "data get $i"]
|
||||
if {$val != $i} {
|
||||
error "SicsData returned a bad value: expected $i received $val"
|
||||
}
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test sicsdata-1.1 {Test writing float} -body {
|
||||
for {set i 0} {$i < 5} { incr i} {
|
||||
set v [expr $i * 1.0]
|
||||
testOK "data putfloat $i $v"
|
||||
}
|
||||
for {set i 0} {$i < 5} { incr i} {
|
||||
set val [SICSValue "data get $i"]
|
||||
if {abs($val - $i) > .000001} {
|
||||
error "SicsData returned a bad value: expected $i received $val"
|
||||
}
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test sicsdata-1.2 {Test used} -body {
|
||||
set val [SICSValue "data used"]
|
||||
if {$val != 5} {
|
||||
error "Expected data used to be 5, not $val"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test sicsdata-1.3 {Test clear} -body {
|
||||
testOK "data clear"
|
||||
set val [SICSValue "data used"]
|
||||
if {$val != 0} {
|
||||
error "Expected data used to be 0, not $val"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
xxxscan clear
|
||||
xxxscan add a4 2. .2
|
||||
xxxscan run 30 timer 2
|
||||
|
||||
test sicsdata-1.4 {Testing scancounts} -body {
|
||||
testOK "data copyscancounts 0 xxxscan"
|
||||
set val [SICSValue "data used"]
|
||||
if {$val != 30} {
|
||||
error "Expected data used to be 30, not $val"
|
||||
}
|
||||
set val [SICSValue "data get 0"]
|
||||
if {$val != 10} {
|
||||
error "Expected data 0 to be 10, not $val"
|
||||
}
|
||||
set val [SICSValue "data get 10"]
|
||||
if {$val != 41} {
|
||||
error "Expected data 10 to be 41, not $val"
|
||||
}
|
||||
set val [SICSValue "data get 20"]
|
||||
if {$val != 171} {
|
||||
error "Expected data 10 to be 171, not $val"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test sicsdata-1.5 {Testing scanmonitor} -body {
|
||||
testOK "data clear"
|
||||
testOK "data copyscanmon 0 xxxscan 2"
|
||||
set val [SICSValue "data used"]
|
||||
if {$val != 30} {
|
||||
error "Expected data used to be 30, not $val"
|
||||
}
|
||||
set val [SICSValue "data get 0"]
|
||||
if {$val != 0} {
|
||||
error "Expected data 0 to be 0, not $val"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test sicsdata-1.6 {Testing scanvar} -body {
|
||||
testOK "data copyscanvar 0 xxxscan 0"
|
||||
set val [SICSValue "data used"]
|
||||
if {$val != 30} {
|
||||
error "Expected data used to be 30, not $val"
|
||||
}
|
||||
set val [SICSValue "data get 0"]
|
||||
if {abs($val - 2.0) > .001} {
|
||||
error "Expected data 0 to be 2.0, not $val"
|
||||
}
|
||||
set val [SICSValue "data get 20"]
|
||||
if {abs($val - 6.0) > .001} {
|
||||
error "Expected data 20 to be 6.0, not $val"
|
||||
}
|
||||
set val [SICSValue "data get 29"]
|
||||
if {abs($val - 7.8) > .001} {
|
||||
error "Expected data 29 to be 7.8, not $val"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
config rights Mugger Mugger
|
||||
tof genbin 20 10 50
|
||||
tof init
|
||||
|
||||
test sicsdata-1.7 {Testing timebin} -body {
|
||||
testOK "data clear"
|
||||
testOK "data copytimebin 0 tof"
|
||||
set val [SICSValue "data used"]
|
||||
if {$val != 50} {
|
||||
error "Expected data used to be 50, not $val"
|
||||
}
|
||||
set val [SICSValue "data get 0"]
|
||||
if {abs($val - 20.0) > .001} {
|
||||
error "Expected data 0 to be 20.0, not $val"
|
||||
}
|
||||
set val [SICSValue "data get 49"]
|
||||
if {abs($val - 510.0) > .001} {
|
||||
error "Expected data 49 to be 510.0, not $val"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
hm initval 32
|
||||
|
||||
test sicsdata-1.8 {Testing hm} -body {
|
||||
testOK "data clear"
|
||||
testOK "data copyhm 0 hm"
|
||||
set val [SICSValue "data used"]
|
||||
if {$val != 23} {
|
||||
error "Expected data used to be 23, not $val"
|
||||
}
|
||||
set val [SICSValue "data get 0"]
|
||||
if {abs($val - 32.0) > .001} {
|
||||
error "Expected data 0 to be 32.0, not $val"
|
||||
}
|
||||
set val [SICSValue "data get 22"]
|
||||
if {abs($val - 32.0) > .001} {
|
||||
error "Expected data 22 to be 32.0, not $val"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test sicsdata-1.8 {Testing UU write} -body {
|
||||
set text [data writeuu hugo]
|
||||
if {[string first "begin 622" $text] < 0} {
|
||||
error "Bad reply on uuwrite: $text"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test sicsdata-1.9 {Testing file dump} -body {
|
||||
data clear
|
||||
data copyhm 0 hm
|
||||
testOK "data dump test.dat"
|
||||
set status [catch {exec diff test.dat sicsdatasoll.dat} msg]
|
||||
if {$status != 0} {
|
||||
error "Difference in dump file: $msg"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test sicsdata-1.10 {Copying sicsdata} -body {
|
||||
duta clear
|
||||
data clear
|
||||
data copyhm 0 hm
|
||||
testNoError "duta copydata 0 data 0 23"
|
||||
set val [SICSValue "duta used"]
|
||||
if {$val != 23} {
|
||||
error "Expected data used to be 23, not $val"
|
||||
}
|
||||
for {set i 0} {$i < 23} {incr i} {
|
||||
set val [SICSValue "duta get $"]
|
||||
if {abs($val - 32.0) > .001} {
|
||||
error "Expected data $i to be 32.0, not $val"
|
||||
}
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test sicsdata-1.11 {Division} -body {
|
||||
|
||||
config rights Mugger Mugger
|
||||
duta clear
|
||||
data clear
|
||||
hm initval 32
|
||||
data copyhm 0 hm
|
||||
hm initval 16
|
||||
duta copyhm 0 hm
|
||||
testNoError "data divideby duta"
|
||||
set val [SICSValue "data used"]
|
||||
if {$val != 23} {
|
||||
error "Expected data used to be 23, not $val"
|
||||
}
|
||||
for {set i 0} {$i < 23} {incr i} {
|
||||
set val [SICSValue "data get $"]
|
||||
if {abs($val - 2.0) > .001} {
|
||||
error "Expected data $i to be 2.0, not $val"
|
||||
}
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
|
||||
|
||||
|
||||
84
test/testsoll.xml
Normal file
84
test/testsoll.xml
Normal file
@ -0,0 +1,84 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<NXroot NeXus_version="3.0.0" XML_version="mxml" file_name="test.xml"
|
||||
file_time="2007-02-21 10:51:15+0100" Instrument="Washmaschine">
|
||||
<NXentry name="entry1">
|
||||
<testtext target="/entry1/testtext">Hugo ist eine Nassnase</testtext>
|
||||
<testfloat NAPItype="NX_FLOAT32">
|
||||
27.8000
|
||||
</testfloat>
|
||||
<testint NAPItype="NX_INT32">
|
||||
177
|
||||
</testint>
|
||||
<position NAPItype="NX_FLOAT32">
|
||||
15.0000
|
||||
</position>
|
||||
<position_zeropoint NAPItype="NX_FLOAT32">
|
||||
0.0000
|
||||
</position_zeropoint>
|
||||
<NXmonitor name="control">
|
||||
<preset NAPItype="NX_FLOAT32">
|
||||
10.0000
|
||||
</preset>
|
||||
<mode>timer</mode>
|
||||
<time NAPItype="NX_FLOAT32">
|
||||
10.0000
|
||||
</time>
|
||||
<counts0 NAPItype="NX_INT32">
|
||||
5
|
||||
</counts0>
|
||||
<counts1 NAPItype="NX_INT32">
|
||||
10
|
||||
</counts1>
|
||||
<counts2 NAPItype="NX_INT32">
|
||||
25
|
||||
</counts2>
|
||||
<counts3 NAPItype="NX_INT32">
|
||||
35
|
||||
</counts3>
|
||||
<counts4 NAPItype="NX_INT32">
|
||||
45
|
||||
</counts4>
|
||||
</NXmonitor>
|
||||
<NXdata name="detector">
|
||||
<hmdata NAPItype="NX_INT32[23]" signal="1">
|
||||
55 55 55 55
|
||||
55 55 55 55
|
||||
55 55 55 55
|
||||
55 55 55 55
|
||||
55 55 55 55
|
||||
55 55 55
|
||||
</hmdata>
|
||||
<time_binning NAPItype="NX_FLOAT32[20]">
|
||||
500.0000 800.0000 1100.0000 1400.0000
|
||||
1700.0000 2000.0000 2300.0000 2600.0000
|
||||
2900.0000 3200.0000 3500.0000 3800.0000
|
||||
4100.0000 4400.0000 4700.0000 5000.0000
|
||||
5300.0000 5600.0000 5900.0000 6200.0000
|
||||
</time_binning>
|
||||
<x_axis NAPItype="NX_FLOAT32[10]">
|
||||
10.0000 11.0000 12.0000 13.0000
|
||||
14.0000 15.0000 16.0000 17.0000
|
||||
18.0000 19.0000
|
||||
</x_axis>
|
||||
<y_axis NAPItype="NX_INT32[10]">
|
||||
10 11 12 13
|
||||
14 15 16 17
|
||||
18 19
|
||||
</y_axis>
|
||||
<NAPIlink target="/entry1/testtext" />
|
||||
<gurke NAPItype="NX_INT32[23]">
|
||||
23 23 23 23
|
||||
23 23 23 23
|
||||
23 23 23 23
|
||||
23 23 23 23
|
||||
23 23 23 23
|
||||
23 23 23
|
||||
</gurke>
|
||||
</NXdata>
|
||||
</NXentry>
|
||||
<NXentry name="entry">
|
||||
<slappy NAPItype="NX_FLOAT32[3]">
|
||||
1.1000 2.2000 3.3000
|
||||
</slappy>
|
||||
</NXentry>
|
||||
</NXroot>
|
||||
265
test/testtasub.tcl
Normal file
265
test/testtasub.tcl
Normal file
@ -0,0 +1,265 @@
|
||||
#----------------------------------------------------------------------
|
||||
# This is a set of regression tests for the tasub module.
|
||||
# This module does the UB matrix algorithm as described by Mark Lumsden
|
||||
# triple axis spectrometers.
|
||||
#
|
||||
# Mark Koennecke, November 2006
|
||||
#----------------------------------------------------------------------
|
||||
puts stdout "Testing Tasub"
|
||||
#----------------------------------------------------------------------
|
||||
# testTasubCalculation tests the tasub calculation. The input is a list
|
||||
# containg the cell constants and two lists denoting reflections.
|
||||
# For each reflection the list must hold:
|
||||
# 0 1 2 3 4 5 6 7 8 9 10 11 12
|
||||
# qh qk ql ei ef a1 a2 a3 a4 sgu sgl a5 a6
|
||||
# testTasubCalculation then inputs the cell and the reflections into
|
||||
# tasub and calculates a UB from that. Then it tries to drive to the
|
||||
# QE positions given for the reflections and checks if the angles are right
|
||||
# It also checks QE positions in order to check if they have been properly
|
||||
# updated.
|
||||
# This then can be used with various inputs to check various configurations
|
||||
# of the instrument.
|
||||
#----------------------------------------------------------------------
|
||||
proc testTasubCalculation {cell ref1 ref2} {
|
||||
if {[llength $cell] < 6} {
|
||||
error "Not enough cell parameters"
|
||||
}
|
||||
if {[llength $ref1] < 13} {
|
||||
error "Not enough parameters for reflection 1"
|
||||
}
|
||||
if {[llength $ref2] < 13} {
|
||||
error "Not enough parameters for reflection 2"
|
||||
}
|
||||
checkSettingCell $cell
|
||||
checkMakeUB $ref1 $ref2
|
||||
checkDrivingReflection $ref1
|
||||
checkDrivingReflection $ref2
|
||||
}
|
||||
#-------------------------------------------------------------------
|
||||
proc checkSettingCell {cell} {
|
||||
config rights Mugger Mugger
|
||||
append cmd "tasub cell " [join $cell]
|
||||
testOK $cmd
|
||||
set readback [string trim [SICSValue "tasub cell"]]
|
||||
set l [split $readback]
|
||||
for {set i 0} {$i < [llength $cell]} {incr i} {
|
||||
set ori [lindex $cell $i]
|
||||
set val [lindex $l $i]
|
||||
if {abs($ori - $val) > .01} {
|
||||
error "Bad cell readback, in $cell, back $readback"
|
||||
}
|
||||
}
|
||||
}
|
||||
#---------------------------------------------------------------------
|
||||
proc checkMakeUB {ref1 ref2} {
|
||||
checkOK "tasub clear"
|
||||
set cmd [format "tasub addref %f %f %f %f %f %f %f %f %f" \
|
||||
[lindex $ref1 0] [lindex $ref1 1] [lindex $ref1 2] \
|
||||
[lindex $ref1 7] [lindex $ref1 8] [lindex $ref1 9] \
|
||||
[lindex $ref1 10] \
|
||||
[lindex $ref1 3] [lindex $ref1 4]]
|
||||
eval $cmd
|
||||
set cmd [format "tasub addref %f %f %f %f %f %f %f %f %f" \
|
||||
[lindex $ref2 0] [lindex $ref2 1] [lindex $ref2 2] \
|
||||
[lindex $ref2 7] [lindex $ref2 8] [lindex $ref2 9] \
|
||||
[lindex $ref2 10] \
|
||||
[lindex $ref2 3] [lindex $ref2 4]]
|
||||
eval $cmd
|
||||
set test [tasub makeub 1 2]
|
||||
if {[string first ERROR $test] > 0} {
|
||||
error "Problem calculating UB: $test"
|
||||
}
|
||||
}
|
||||
#--------------------------------------------------------------------
|
||||
proc checkDrivingReflection {ref} {
|
||||
set cmd [format "drive qh %f qk %f ql %f ei %f ef %f" \
|
||||
[lindex $ref 0] [lindex $ref 1] [lindex $ref 2] \
|
||||
[lindex $ref 3] [lindex $ref 4]]
|
||||
set test [eval $cmd]
|
||||
puts $cmd
|
||||
if {[string first ERROR $test] >= 0} {
|
||||
error "Failed to drive reflection: $test"
|
||||
}
|
||||
set a1 [SICSValue a1]
|
||||
set a1soll [lindex $ref 5]
|
||||
if {abs($a1soll - $a1) >.01} {
|
||||
error "Bad a1 position, should $a1soll, is $a1"
|
||||
}
|
||||
set a1 [SICSValue a1]
|
||||
set a1soll [lindex $ref 5]
|
||||
if {abs($a1soll - $a1) >.01} {
|
||||
error "Bad a1 position, should $a1soll, is $a1"
|
||||
}
|
||||
set a2 [SICSValue a2]
|
||||
set a2soll [lindex $ref 6]
|
||||
if {abs($a2soll - $a2) >.01} {
|
||||
error "Bad a2 position, should $a2soll, is $a2"
|
||||
}
|
||||
set a3 [SICSValue a3]
|
||||
set a3soll [lindex $ref 7]
|
||||
if {abs($a3soll - $a3) >.01} {
|
||||
error "Bad a3 position, should $a3soll, is $a3"
|
||||
}
|
||||
set a4 [SICSValue a4]
|
||||
set a4soll [lindex $ref 8]
|
||||
if {abs($a4soll - $a4) >.01} {
|
||||
error "Bad a4 position, should $a4soll, is $a4"
|
||||
}
|
||||
set sgu [SICSValue sgu]
|
||||
set sgusoll [lindex $ref 9]
|
||||
if {abs($sgusoll - $sgu) >.01} {
|
||||
error "Bad sgu position, should $sgusoll, is $sgu"
|
||||
}
|
||||
set sgl [SICSValue sgl]
|
||||
set sglsoll [lindex $ref 10]
|
||||
if {abs($sglsoll - $sgl) >.01} {
|
||||
error "Bad sgl position, should $sglsoll, is $sgl"
|
||||
}
|
||||
set a5 [SICSValue a5]
|
||||
set a5soll [lindex $ref 11]
|
||||
if {abs($a5soll - $a5) >.01} {
|
||||
error "Bad a5 position, should $a5soll, is $a5"
|
||||
}
|
||||
set a6 [SICSValue a6]
|
||||
set a6soll [lindex $ref 12]
|
||||
if {abs($a6soll - $a6) >.01} {
|
||||
error "Bad a6 position, should $a6soll, is $a6"
|
||||
}
|
||||
|
||||
set qh [SICSValue qh]
|
||||
set qhsoll [lindex $ref 0]
|
||||
if {abs($qhsoll - $qh) >.01} {
|
||||
error "Bad qh position, should $qhsoll, is $qh"
|
||||
}
|
||||
set qk [SICSValue qk]
|
||||
set qksoll [lindex $ref 1]
|
||||
if {abs($qksoll - $qk) >.01} {
|
||||
error "Bad qk position, should $qksoll, is $qk"
|
||||
}
|
||||
set ql [SICSValue ql]
|
||||
set qlsoll [lindex $ref 2]
|
||||
if {abs($qlsoll - $ql) >.01} {
|
||||
error "Bad ql position, should $qlsoll, is $ql"
|
||||
}
|
||||
|
||||
set ei [SICSValue ei]
|
||||
set eisoll [lindex $ref 3]
|
||||
if {abs($eisoll - $ei) >.01} {
|
||||
error "Bad ei position, should $eisoll, is $ei"
|
||||
}
|
||||
set ef [SICSValue ef]
|
||||
set efsoll [lindex $ref 4]
|
||||
if {abs($efsoll - $ef) >.01} {
|
||||
error "Bad ef position, should $efsoll, is $ef"
|
||||
}
|
||||
}
|
||||
#===================== tests =========================================
|
||||
test tasub-1.0 {Test setting dd} -body {
|
||||
testPar "tasub mono dd" 3.35461 Mugger
|
||||
testPar "tasub ana dd" 3.35461 Mugger
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test tasub-1.1 {Test setting ss} -body {
|
||||
testPar "tasub mono ss" 1 Mugger
|
||||
testPar "tasub ana ss" 1 Mugger
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test tasub-1.2 {Test setting sample configuration} -body {
|
||||
testPar "tasub const" kf Mugger
|
||||
testPar "tasub ss" -1 Mugger
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test tasub-1.3 {Test clearing tasub} -body {
|
||||
testOK "tasub clear"
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test tasub-1.4 {Test setting cell} -body {
|
||||
checkSettingCell [list 7. 7. 7. 90. 90. 90.]
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
tasub mono dd 3.35461
|
||||
tasub ana dd 3.35461
|
||||
tasub mono ss 1
|
||||
tasub ana ss 1
|
||||
tasub const kf
|
||||
tasub ss -1
|
||||
|
||||
test tasub-1.5 {Basic calculation test} -body {
|
||||
set ref1 [list 1 0 0 5 5 37.075 74.150 168.27 -23.46 0 0 37.075 74.15]
|
||||
set ref2 [list 0 0 1 5 5 37.075 74.150 84.78 -10.44 0 0 37.075 74.15]
|
||||
set cell [list 9.95 9.95 22.24 90 90 90]
|
||||
testTasubCalculation $cell $ref1 $ref2
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
|
||||
test tasub-1.6 {Test driving ei} -body {
|
||||
drive ei 5.0
|
||||
set eit [SICSValue ei]
|
||||
set a1 [SICSValue a1]
|
||||
set a2 [SICSValue a2]
|
||||
if {abs(5 - $eit) > .001} {
|
||||
error "Readback of ei failed"
|
||||
}
|
||||
if {abs(37.07 - $a1) > .01} {
|
||||
error "Bad a1 value, is $a1, should 37.07"
|
||||
}
|
||||
if {abs(74.15 - $a2) > .01} {
|
||||
error "Bad a2 value, is $a2, should 74.15"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test tasub-1.7 {Test driving ef} -body {
|
||||
drive ef 5.
|
||||
set eit [SICSValue ef]
|
||||
set a1 [SICSValue a5]
|
||||
set a2 [SICSValue a6]
|
||||
if {abs(5. - $eit) > .001} {
|
||||
error "Readback of ei failed"
|
||||
}
|
||||
if {abs(37.07 - $a1) > .01} {
|
||||
error "Bad a5 value, is $a1, should 37.07"
|
||||
}
|
||||
if {abs(74.15 - $a2) > .01} {
|
||||
error "Bad a6 value, is $a2, should 74.15"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test tasub-1.8 {Test reading en} -body {
|
||||
drive ei 5. ef 3.7
|
||||
set en [SICSValue en]
|
||||
if {abs($en - 1.3) > .01} {
|
||||
error "Bad en value: should: 1.3, is $en"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test tasub-1.9 {Test driving ef, different scattering sense} -body {
|
||||
tasub ana ss -1
|
||||
drive ef 5.0
|
||||
set eit [SICSValue ef]
|
||||
set a1 [SICSValue a5]
|
||||
set a2 [SICSValue a6]
|
||||
if {abs(5 - $eit) > .001} {
|
||||
error "Readback of ef failed"
|
||||
}
|
||||
if {abs(-37.07 - $a1) > .01} {
|
||||
error "Bad a5 value, is $a1, should -37.07"
|
||||
}
|
||||
if {abs(-74.15 - $a2) > .01} {
|
||||
error "Bad a6 value, is $a2, should -74.15"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
165
test/testutil.tcl
Normal file
165
test/testutil.tcl
Normal file
@ -0,0 +1,165 @@
|
||||
#------------------------------------------------------------------------------
|
||||
# utility routines for testing SICS
|
||||
#
|
||||
# copyright: see file COPYRIGHT
|
||||
#
|
||||
# Mark Koennecke, July 2006
|
||||
#------------------------------------------------------------------------------
|
||||
proc SICSValue {command} {
|
||||
set txt [eval $command]
|
||||
set l [split $txt =]
|
||||
return [string trim [lindex $l 1]]
|
||||
}
|
||||
#-----------------------------------------------------------------------------
|
||||
proc compareValue {is should} {
|
||||
if {[string is double $is] == 1} {
|
||||
if {abs($should - $is) > .01} {
|
||||
error "Bad compare is: $is, should $should"
|
||||
}
|
||||
} else {
|
||||
if {[string compare $is $should] != 0} {
|
||||
error "Bad compare is: $is, should $should"
|
||||
}
|
||||
}
|
||||
return OK
|
||||
}
|
||||
#------------------------------------------------------------------------------
|
||||
proc testPar {name testval priv } {
|
||||
config rights Spy Spy
|
||||
set value [SICSValue $name]
|
||||
set res [eval $name $testval]
|
||||
if {[string first ERROR $res] < 0} {
|
||||
error "Managed to set parameter even if not allowed"
|
||||
}
|
||||
config rights $priv $priv
|
||||
set res [eval $name $testval]
|
||||
if {[string first ERROR $res] >= 0} {
|
||||
error "Setting parameter failed with $res"
|
||||
}
|
||||
set readback [SICSValue $name]
|
||||
compareValue $readback $testval
|
||||
eval $name $value
|
||||
return "OK"
|
||||
}
|
||||
#-------------------------------------------------------------------------------
|
||||
proc testROPar {name val} {
|
||||
config rights Mugger Mugger
|
||||
set value [SICSValue $name]
|
||||
compareValue $value $val
|
||||
catch {$name [expr $val + 1]} msg
|
||||
set value [SICSValue $name]
|
||||
compareValue $value $val
|
||||
config rights Spy Spy
|
||||
return OK
|
||||
}
|
||||
#------------------------------------------------------------------------------
|
||||
proc testDrive {name value priv} {
|
||||
config rights Spy Spy
|
||||
set ans [eval drive $name $value]
|
||||
if {[string first ERROR $ans] < 0} {
|
||||
error "Protection on drivable does not work"
|
||||
}
|
||||
config rights $priv $priv
|
||||
set ans [eval drive $name $value]
|
||||
if { [string first sucessfully $ans] < 0} {
|
||||
error "Driving $name failed: $ans"
|
||||
}
|
||||
set readback [SICSValue $name]
|
||||
compareValue $readback $value
|
||||
config rights Spy Spy
|
||||
return OK
|
||||
}
|
||||
#------------------------------------------------------------------------------
|
||||
proc testDriveInterrupt {name value} {
|
||||
global socke
|
||||
config rights Mugger Mugger
|
||||
run $name $value
|
||||
puts $socke "INT1712 3"
|
||||
flush $socke
|
||||
set ans [eval status]
|
||||
config rights Spy Spy
|
||||
if {[string first Interrupt $ans] < 0} {
|
||||
puts stdout $ans
|
||||
error "Failed to abort driving"
|
||||
}
|
||||
if { [string first Eager $ans] < 0} {
|
||||
error "Failed to finish driving"
|
||||
}
|
||||
return OK
|
||||
}
|
||||
#---------------------------------------------------------------------
|
||||
proc testNBCounting {startCommand waitTime} {
|
||||
set res [$startCommand]
|
||||
if {[string first ERROR $res] >= 0} {
|
||||
error "Starting count failed with $res"
|
||||
}
|
||||
exec sleep 1
|
||||
set res [SICSValue status]
|
||||
if {[string first "Count" $res] < 0} {
|
||||
error "Status does not say counting"
|
||||
}
|
||||
exec sleep $waitTime
|
||||
set res [SICSValue status]
|
||||
if {[string first "Eager" $res] < 0} {
|
||||
error "Counting did not stop"
|
||||
}
|
||||
return "OK"
|
||||
}
|
||||
#----------------------------------------------------------------
|
||||
proc testBlockCounting {startCommand waitTime} {
|
||||
set res [$startCommand]
|
||||
if {[string first ERROR $res] >= 0} {
|
||||
error "Starting count failed with $res"
|
||||
}
|
||||
exec sleep $waitTime
|
||||
set res [SICSValue status]
|
||||
if {[string first "Eager" $res] < 0} {
|
||||
error "Counting did not stop"
|
||||
}
|
||||
return "OK"
|
||||
}
|
||||
#---------------------------------------------------------------
|
||||
proc testInterruptedCount {startCommand} {
|
||||
global socke
|
||||
set res [$startCommand]
|
||||
if {[string first ERROR $res] >= 0} {
|
||||
error "Starting count failed with $res"
|
||||
}
|
||||
puts $socke "INT1712 3"
|
||||
flush $socke
|
||||
exec sleep 10
|
||||
set ans [eval status]
|
||||
config rights Spy Spy
|
||||
if {[string first Interrupt $ans] < 0} {
|
||||
puts stdout $ans
|
||||
error "Failed to abort counting"
|
||||
}
|
||||
if { [string first Eager $ans] < 0} {
|
||||
error "Failed to finish counting"
|
||||
}
|
||||
return OK
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
proc testOK {command} {
|
||||
set test [eval $command]
|
||||
if {[string first OK $test] < 0} {
|
||||
error [format "Expected OK, got %s" $test]
|
||||
}
|
||||
return OK
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
proc testNoError {command} {
|
||||
set test [eval $command]
|
||||
if {[string first ERROR $test] >= 0} {
|
||||
error [format "Located Error: %s" $test]
|
||||
}
|
||||
return OK
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
proc testCommand {command response} {
|
||||
set result [eval $command]
|
||||
if {[string first $response $result] < 0} {
|
||||
error "Expected $response, received $result"
|
||||
}
|
||||
return OK
|
||||
}
|
||||
Reference in New Issue
Block a user