linse/sics
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

PSI update

Browse Source 
r1464 | ffr | 2007-02-12 12:20:21 +1100 (Mon, 12 Feb 2007) | 2 lines
This commit is contained in:
Ferdi Franceschini
2007-02-12 12:20:21 +11:00
committed by Douglas Clowes
parent 634f2023b1
commit 3168325921
157 changed files with 29053 additions and 910 deletions
Download Patch File Download Diff File Expand all files Collapse all files

3
test/DataNumber Normal file
View File

@ -0,0 +1,3 @@
75
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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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

106
test/nxscripttest.tcl Normal file
View File

@ -0,0 +1,106 @@
#---------------------------------------------------------------------------
# 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.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
View File

@ -0,0 +1,305 @@
#
# $Id: object.tcl,v 1.2 2007-02-12 01:15:03 ffr Exp $
#
# 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
View 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

486
test/scancommand.tcl Normal file
View 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
View 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
View 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

163
test/sicsstat.tcl Normal file
View File

@ -0,0 +1,163 @@
exe batchpath ./
exe syspath ./
lotte Wuergehals was here
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 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 movecount 10.000000
# Counter aba
aba SetPreset 10.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 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 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 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 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 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 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 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 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 500.000000 300.000000 20
tof init
#---- tasUB module tasub
tasub mono dd 3.354610
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.354610
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 9.950000 9.950000 22.240000 90.000000 90.000000 90.000000
tasub clear
tasub addref 1.00 0.00 0.00 168.27 -23.46 0.00 0.00 5.00 5.00
tasub addref 0.00 0.00 1.00 84.78 -10.44 0.00 0.00 5.00 5.00
tasub outofplane 1
tasub const kf
tasub ss -1
tasub setub -0.100503 -0.000000 -0.000000 0.000000 -0.000000 -0.044964 0.000000 -0.100503 -0.000000
tasub setnormal 0.000000 0.000000 1.000000
tasub settarget 1.200000 0.000000 1.000000 0.000000 1.553424 1.553424
tasub r1 1.00 0.00 0.00 168.27 -23.46 0.00 0.00 5.00 5.00
tasub r2 0.00 0.00 1.00 84.78 -10.44 0.00 0.00 5.00 5.00
tasub update
#----- MultiMotor sa
sa recovernampos noeff a3 24 a4 48

40
test/sicstcldebug.tcl Normal file
View 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
View File

File diff suppressed because it is too large Load Diff

31
test/test.dic Normal file
View File

@ -0,0 +1,31 @@
##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
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)}
testlink=/entry1,NXentry/detector,NXdata/NXVGROUP

7
test/test.hdd Normal file
View File

@ -0,0 +1,7 @@
*************************** Test Data File ********************************
Original Filename = !!FILE!!
File Creation Date = !!DATE!!
****************************************************************************
----------------------------------------------------------------------------
!!SCANZERO!!
**************************** DATA ******************************************

10
test/testinc.tcl Normal file
View 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

196
test/testini.tcl Normal file
View File

@ -0,0 +1,196 @@
# --------------------------------------------------------------------------
# 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

21
test/testmisc.tcl Normal file
View 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
View 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
View 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
View 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

79
test/testsoll.xml Normal file
View File

@ -0,0 +1,79 @@
<?xml version="1.0" encoding="UTF-8"?>
<NXroot NeXus_version="3.0.0" XML_version="mxml" file_name="test.xml"
file_time="2006-11-08 14:30:21+0100" Instrument="Washmaschine" signal="1">
<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]">
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>
</NXroot>

265
test/testtasub.tcl Normal file
View 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
View 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
}