- Implemented regresion tests for batch processing, scans,
histmem and peak optimization
This commit is contained in:
koennecke
3
test/DataNumber
Normal file
3
test/DataNumber
Normal file
@ -0,0 +1,3 @@
|
||||
41
|
||||
NEVER, EVER modify or delete this file
|
||||
You'll risk eternal damnation and a reincarnation as a cockroach!|n
|
||||
128
test/batchtest.tcl
Normal file
128
test/batchtest.tcl
Normal file
@ -0,0 +1,128 @@
|
||||
#------------------------------------------------------------------------------
|
||||
# This is a set of regression tests for the batch processing feauture
|
||||
# in SICS
|
||||
#
|
||||
# Mark Koennecke, October 2006
|
||||
#------------------------------------------------------------------------------
|
||||
|
||||
puts stdout "Testing batch processing"
|
||||
|
||||
test batch-1.0 {Test Batch File Execution} -body {
|
||||
config rights User User
|
||||
set result [eval exe job1.tcl]
|
||||
if {[string first TERMINATED $result] < 0} {
|
||||
error "Failed to process batch file"
|
||||
}
|
||||
if {[string first Job1 $result] < 0} {
|
||||
error "Output from batch file missing, received: $result"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test batch-1.1 {Test Batch File Interruption} -body {
|
||||
config rights User user
|
||||
exec ./interrupt.tcl &
|
||||
set result [eval exe job1.tcl]
|
||||
if {[string first TERMINATED $result] < 0} {
|
||||
error "Failed to process batch file"
|
||||
}
|
||||
if {[string first interrupted $result] < 0} {
|
||||
error "Interrupting did not work"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test batch-1.2 {Test Nested Batch File Execution} -body {
|
||||
config rights User user
|
||||
set result [eval exe job2.tcl]
|
||||
if {[string first TERMINATED $result] < 0} {
|
||||
error "Failed to process batch file"
|
||||
}
|
||||
if {[string first NestOne $result] < 0} {
|
||||
error "Output from batch file missing"
|
||||
}
|
||||
if {[string first NestTwo $result] < 0} {
|
||||
error "Output from batch file missing"
|
||||
}
|
||||
if {[string first NestThree $result] < 0} {
|
||||
error "Output from batch file missing"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test batch-1.3 {Test Nested Batch File Interruption} -body {
|
||||
config rights User user
|
||||
exec ./interrupt.tcl &
|
||||
set result [eval exe job2.tcl]
|
||||
if {[string first TERMINATED $result] < 0} {
|
||||
error "Failed to process batch file"
|
||||
}
|
||||
if {[string first NestOne $result] < 0} {
|
||||
error "Output from batch file missing"
|
||||
}
|
||||
if {[string first NestTwo $result] < 0} {
|
||||
error "Output from batch file missing"
|
||||
}
|
||||
if {[string first NestThree $result] < 0} {
|
||||
error "Output from batch file missing"
|
||||
}
|
||||
if {[string first interrupted $result] < 0} {
|
||||
error "Interrupting did not work"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test batch-1.4 {Test Path Parameters} -body {
|
||||
testPar "exe batchpath" tmp User
|
||||
testPar "exe syspath" tmp Mugger
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test batch-1.5 {Test Path Failure} -body {
|
||||
config rights Mugger Mugger
|
||||
exe batchpath tmp
|
||||
exe syspath tmp
|
||||
set result [exe job4.tcl]
|
||||
if {[string first "not found" $result] < 0} {
|
||||
error "Batch file found which should not"
|
||||
}
|
||||
exe batchpath ./
|
||||
exe syspath ./
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test batch-1.6 {Test Uploading} -body {
|
||||
config rights User User
|
||||
catch {exec rm hugo.job}
|
||||
testOK "exe upload"
|
||||
testOK "exe append clientput hugo"
|
||||
testOK "exe append wait 2"
|
||||
testOK "exe save hugo.job"
|
||||
testOK "exe upload"
|
||||
testOK "exe append clientput hugo"
|
||||
testOK "exe append wait 2"
|
||||
set stat [catch {testOK "exe save hugo.job" } msg ]
|
||||
if {$stat == 0} {
|
||||
error "Failed to trigger overwrite error"
|
||||
}
|
||||
testOK "exe forcesave hugo.job"
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test batch-1.7 {Test Notifications} -body {
|
||||
config rights User User
|
||||
testOK "exe interest"
|
||||
set result [eval exe job4.tcl]
|
||||
if {[string first BATCHSTART $result] < 0} {
|
||||
error "BATCHSTART missing"
|
||||
}
|
||||
if {[string first BATCHEND $result] < 0} {
|
||||
error "BATCHEND missing"
|
||||
}
|
||||
if {[string first job4.tcl.range $result] < 0} {
|
||||
error "Range entries missing"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
|
||||
@ -15,7 +15,7 @@
|
||||
# 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: onxe as countername and
|
||||
# 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.
|
||||
#
|
||||
|
||||
332
test/histtest.tcl
Normal file
332
test/histtest.tcl
Normal file
@ -0,0 +1,332 @@
|
||||
#---------------------------------------------------------------------------
|
||||
# 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.14 {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.14 {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
|
||||
14
test/interrupt.tcl
Executable file
14
test/interrupt.tcl
Executable file
@ -0,0 +1,14 @@
|
||||
#!/usr/bin/tclsh
|
||||
#------------------------------------------------------------
|
||||
# This is a little script which issues an interrupt to SICS
|
||||
# after five seconds
|
||||
#
|
||||
# Mark Koennecke, October 2006
|
||||
#------------------------------------------------------------
|
||||
source sicstcldebug.tcl
|
||||
config rights Mugger Mugger
|
||||
exec sleep 5
|
||||
puts $socke "INT1712 3"
|
||||
exit 1
|
||||
|
||||
|
||||
5
test/job1.tcl
Normal file
5
test/job1.tcl
Normal file
@ -0,0 +1,5 @@
|
||||
#----------------------------------------------------------
|
||||
# One of the job files for testing batch file processing
|
||||
#----------------------------------------------------------
|
||||
clientput "Job1 batch file"
|
||||
wait 20
|
||||
6
test/job2.tcl
Normal file
6
test/job2.tcl
Normal file
@ -0,0 +1,6 @@
|
||||
#----------------------------------------------------------
|
||||
# One of the job files for testing batch file processing
|
||||
#----------------------------------------------------------
|
||||
clientput "NestOne"
|
||||
exe job3.tcl
|
||||
wait 3
|
||||
6
test/job3.tcl
Normal file
6
test/job3.tcl
Normal file
@ -0,0 +1,6 @@
|
||||
#----------------------------------------------------------
|
||||
# One of the job files for testing batch file processing
|
||||
#----------------------------------------------------------
|
||||
clientput "NestTwo"
|
||||
exe job4.tcl
|
||||
wait 3
|
||||
5
test/job4.tcl
Normal file
5
test/job4.tcl
Normal file
@ -0,0 +1,5 @@
|
||||
#----------------------------------------------------------
|
||||
# One of the job files for testing batch file processing
|
||||
#----------------------------------------------------------
|
||||
clientput "NestThree"
|
||||
wait 3
|
||||
305
test/object.tcl
Normal file
305
test/object.tcl
Normal file
@ -0,0 +1,305 @@
|
||||
#
|
||||
# $Id: object.tcl,v 1.1 2006/10/20 14:57:27 koennecke 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
171
test/optitest.tcl
Normal file
@ -0,0 +1,171 @@
|
||||
#--------------------------------------------------------------------
|
||||
# This file contaisn test for the peak optimization routines in SICS
|
||||
#
|
||||
# Mark Koennecke, October 2006
|
||||
#-------------------------------------------------------------------
|
||||
clientput "Testing optimization routines...."
|
||||
|
||||
config rights Mugger Mugger
|
||||
aba setpar errortype 1 0
|
||||
config rights User User
|
||||
|
||||
test opt-1.0 {Test Normal Optimizer} -body {
|
||||
testOK "opti clear"
|
||||
testOK "opti addvar a4 .3 20 .3"
|
||||
testOK "opti preset 2"
|
||||
testOK "opti countmode timer"
|
||||
drive a4 4.
|
||||
set result [eval opti run]
|
||||
if { [string first ERROR $result] > 0} {
|
||||
puts stdout $result
|
||||
error "Error occurred during optimization run"
|
||||
}
|
||||
if {[string first finished $result] < 0} {
|
||||
error "Optimization did not finish normally"
|
||||
}
|
||||
set val [SICSValue a4]
|
||||
if {abs($val - 5.3) > .1} {
|
||||
error "Optimisation did not arrive at desired position"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test opt-1.1 {Test Normal Optimizer Aborting} -body {
|
||||
testOK "opti clear"
|
||||
testOK "opti addvar a4 .3 20 .3"
|
||||
testOK "opti preset 2"
|
||||
testOK "opti countmode timer"
|
||||
drive a4 4.
|
||||
exec interrupt.tcl &
|
||||
set result [eval opti run]
|
||||
if {[string first "Scan aborted" $result] < 0} {
|
||||
error "Optimiser did not abort
|
||||
}
|
||||
set result [status]
|
||||
if { [string first Eager $result] < 0} {
|
||||
puts stdout $result
|
||||
error "Optimiser did not interrupt!"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test opt-1.2 {Test Climbing } -body {
|
||||
testOK "opti clear"
|
||||
testOK "opti addvar a4 .3 20 .5"
|
||||
testOK "opti preset 2"
|
||||
testOK "opti countmode timer"
|
||||
drive a4 4.
|
||||
set result [eval opti climb]
|
||||
if { [string first ERROR $result] > 0} {
|
||||
puts stdout $result
|
||||
error "Error occurred during optimization run"
|
||||
}
|
||||
if {[string first finished $result] < 0} {
|
||||
error "Optimization did not finish normally"
|
||||
}
|
||||
set val [SICSValue a4]
|
||||
if {abs($val - 5.3) > .5} {
|
||||
error "Optimisation did not arrive at desired position"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test opt-1.3 {Test Climbing } -body {
|
||||
testOK "opti clear"
|
||||
testOK "opti addvar a4 .3 20 .5"
|
||||
testOK "opti preset 2"
|
||||
testOK "opti countmode timer"
|
||||
drive a4 6.
|
||||
set result [eval opti climb]
|
||||
if { [string first ERROR $result] > 0} {
|
||||
puts stdout $result
|
||||
error "Error occurred during optimization run"
|
||||
}
|
||||
if {[string first finished $result] < 0} {
|
||||
error "Optimization did not finish normally"
|
||||
}
|
||||
set val [SICSValue a4]
|
||||
if {abs($val - 5.3) > .5} {
|
||||
error "Optimisation did not arrive at desired position"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test opt-1.4 {Test Climbing Interruption} -body {
|
||||
testOK "opti clear"
|
||||
testOK "opti addvar a4 .3 20 .5"
|
||||
testOK "opti preset 2"
|
||||
testOK "opti countmode timer"
|
||||
drive a4 4.
|
||||
exec interrupt.tcl &
|
||||
set result [eval opti climb]
|
||||
if {[string first "Scan was aborted" $result] < 0} {
|
||||
error "Optimiser did not abort"
|
||||
}
|
||||
set result [status]
|
||||
if { [string first Eager $result] < 0} {
|
||||
puts stdout $result
|
||||
error "Optimiser did not interrupt!"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
|
||||
test opt-1.5 {Test Maximizer} -body {
|
||||
drive a4 4.
|
||||
set result [eval max a4 .2 timer 2]
|
||||
if { [string first ERROR $result] > 0} {
|
||||
puts stdout $result
|
||||
error "Error occurred during maximization"
|
||||
}
|
||||
if {[string first Found $result] < 0} {
|
||||
error "Optimization did not finish normally"
|
||||
}
|
||||
set val [SICSValue a4]
|
||||
if {abs($val - 5.3) > .1} {
|
||||
error "Maximization did not arrive at desired position"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test opt-1.6 {Test Maximizer} -body {
|
||||
drive a4 6.
|
||||
set result [eval max a4 .2 timer 2]
|
||||
if { [string first ERROR $result] > 0} {
|
||||
puts stdout $result
|
||||
error "Error occurred during maximization"
|
||||
}
|
||||
if {[string first Found $result] < 0} {
|
||||
error "Optimization did not finish normally"
|
||||
}
|
||||
set val [SICSValue a4]
|
||||
if {abs($val - 5.3) > .1} {
|
||||
error "Maximization did not arrive at desired position"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test opt-1.6 {Test Maximizer Aborting} -body {
|
||||
drive a4 6.
|
||||
exec interrupt.tcl &
|
||||
set result [eval max a4 .2 timer 2]
|
||||
if { [string first "Full Stop" $result] < 0} {
|
||||
puts stdout $result
|
||||
error "Maximize did not interrupt!"
|
||||
}
|
||||
set result [status]
|
||||
if { [string first Eager $result] < 0} {
|
||||
puts stdout $result
|
||||
error "Maximize did not interrupt!"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test opt-1.7 {Test Maximizer Parameter} -body {
|
||||
testOK "max in360 1"
|
||||
testOK "max maxpts 50"
|
||||
testCommand "max in360" max.in360
|
||||
testCommand "max maxpts" max.maxpts
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
486
test/scancommand.tcl
Normal file
486
test/scancommand.tcl
Normal file
@ -0,0 +1,486 @@
|
||||
#--------------------------------------------------------------------------
|
||||
# general scan command wrappers for TOPSI and the like.
|
||||
# New version using the object.tcl system from sntl instead of obTcl which
|
||||
# caused a lot of trouble with tcl8.0
|
||||
#
|
||||
# Requires the built in scan command xxxscan.
|
||||
#
|
||||
# Mark Koennecke, February 2000
|
||||
#--------------------------------------------------------------------------
|
||||
|
||||
source object.tcl
|
||||
set recoverfil recover.bin
|
||||
|
||||
#-------------------------- some utility functions -------------------------
|
||||
proc MC { t n } {
|
||||
set string $t
|
||||
for { set i 1 } { $i < $n } { incr i } {
|
||||
set string [format "%s%s" $string $t]
|
||||
}
|
||||
return $string
|
||||
}
|
||||
#--------------------------------------------------------------------------
|
||||
proc GetNum { text } {
|
||||
set list [split $text =]
|
||||
return [lindex $list 1]
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
|
||||
|
||||
#************** Definition of scan class **********************************
|
||||
|
||||
object_class ScanCommand {
|
||||
member Mode Monitor
|
||||
member NP 1
|
||||
member counter counter
|
||||
member NoVar 0
|
||||
member Preset 10000
|
||||
member File default.dat
|
||||
member pinterest ""
|
||||
member Channel 0
|
||||
member Active 0
|
||||
member Recover 0
|
||||
member scanvars
|
||||
member scanstart
|
||||
member scanstep
|
||||
member pinterest
|
||||
|
||||
method var {name start step} {
|
||||
# check for activity
|
||||
if {$slot(Active)} {
|
||||
ClientPut "ERROR: cannot change parameters while scanning" error
|
||||
return
|
||||
}
|
||||
# check parameters
|
||||
set t [SICSType $name]
|
||||
if { [string compare $t DRIV] != 0 } {
|
||||
ClientPut [format "ERROR: %s is not drivable" $name] error
|
||||
return 0
|
||||
}
|
||||
set t [SICSType $start]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number!" $start] error
|
||||
return 0
|
||||
}
|
||||
set t [SICSType $step]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number!" $step] error
|
||||
return 0
|
||||
}
|
||||
# install the variable
|
||||
set i $slot(NoVar)
|
||||
incr slot(NoVar)
|
||||
lappend slot(scanvars) $name
|
||||
lappend slot(scanstart) $start
|
||||
lappend slot(scanstep) $step
|
||||
$self SendInterest pinterest ScanVarChange
|
||||
ClientPut OK
|
||||
}
|
||||
|
||||
method info {} {
|
||||
if { $slot(NoVar) < 1 } {
|
||||
return "0,1,NONE,0.,0.,default.dat"
|
||||
}
|
||||
append result $slot(NP) "," $slot(NoVar)
|
||||
for {set i 0} { $i < $slot(NoVar) } { incr i} {
|
||||
append result "," [lindex $slot(scanvars) $i]
|
||||
}
|
||||
append result "," [lindex $slot(scanstart) 0] "," \
|
||||
[lindex $slot(scanstep) 0]
|
||||
set r1 [xxxscan getfile]
|
||||
set l1 [split $r1 "="]
|
||||
append result "," [lindex $l1 1]
|
||||
return $result
|
||||
}
|
||||
|
||||
method getvars {} {
|
||||
set list ""
|
||||
lappend list $slot(scanvars)
|
||||
return [format "scan.Vars = %s -END-" $list]
|
||||
}
|
||||
|
||||
method xaxis {} {
|
||||
if { $slot(NoVar) <= 0} {
|
||||
#---- default Answer
|
||||
set t [format "%s.xaxis = %f %f" $self 0 1]
|
||||
} else {
|
||||
set t [format "%s.xaxis = %f %f" $self [lindex $slot(scanstart) 0] \
|
||||
[lindex $slot(scanstep) 0] ]
|
||||
}
|
||||
ClientPut $t
|
||||
}
|
||||
|
||||
method cinterest {} {
|
||||
xxxscan interest
|
||||
}
|
||||
|
||||
method uuinterest {} {
|
||||
xxxscan uuinterest
|
||||
}
|
||||
|
||||
method pinterest {} {
|
||||
set nam [GetNum [config MyName]]
|
||||
lappend $slot(pinterest) $nam
|
||||
}
|
||||
|
||||
method SendInterest { type text } {
|
||||
#------ check list first
|
||||
set l1 $slot($type)
|
||||
set l2 ""
|
||||
foreach e $l1 {
|
||||
set b [string trim $e]
|
||||
set g [string trim $b "{}"]
|
||||
set ret [SICSType $g]
|
||||
if { [string first COM $ret] >= 0 } {
|
||||
lappend l2 $e
|
||||
}
|
||||
}
|
||||
#-------- update scan data and write
|
||||
set slot($type) $l2
|
||||
foreach e $l2 {
|
||||
set b [string trim $e]
|
||||
$b put $text
|
||||
}
|
||||
}
|
||||
|
||||
method mode { {NewVal NULL} } {
|
||||
if { [string compare $NewVal NULL] == 0 } {
|
||||
set val [format "%s.Mode = %s" $self $slot(Mode)]
|
||||
ClientPut $val
|
||||
return $val
|
||||
} else {
|
||||
# check for activity
|
||||
if {$slot(Active)} {
|
||||
ClientPut "ERROR: cannot change parameters while scanning" error
|
||||
return
|
||||
}
|
||||
set tmp [string tolower $NewVal]
|
||||
set NewVal $tmp
|
||||
if { ([string compare $NewVal "timer"] == 0) || \
|
||||
([string compare $NewVal monitor] ==0) } {
|
||||
set slot(Mode) $NewVal
|
||||
ClientPut OK
|
||||
} else {
|
||||
ClientPut [format "ERROR: %s not recognized as ScanMode" $NewVal]
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
method np { { NewVal NULL } } {
|
||||
if { [string compare $NewVal NULL] == 0 } {
|
||||
set val [format "%s.NP = %d" $self $slot(NP)]
|
||||
ClientPut $val
|
||||
return $val
|
||||
} else {
|
||||
# check for activity
|
||||
if {$slot(Active)} {
|
||||
ClientPut "ERROR: cannot change parameters while scanning" error
|
||||
return
|
||||
}
|
||||
set t [SICSType $NewVal]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number" $NewVal] error
|
||||
return
|
||||
}
|
||||
set slot(NP) $NewVal
|
||||
ClientPut OK
|
||||
}
|
||||
}
|
||||
|
||||
method preset { {NewVal NULL} } {
|
||||
if { [string compare $NewVal NULL] == 0 } {
|
||||
set val [format "%s.Preset = %f" $self $slot(Preset)]
|
||||
ClientPut $val
|
||||
return $val
|
||||
} else {
|
||||
# check for activity
|
||||
if {$slot(Active)} {
|
||||
ClientPut "ERROR: cannot change parameters while scanning" error
|
||||
return
|
||||
}
|
||||
set t [SICSType $NewVal]
|
||||
if { [string compare $t NUM] != 0} {
|
||||
ClientPut [format "ERROR: %s is no number" $NewVal] error
|
||||
return
|
||||
}
|
||||
set slot(Preset) $NewVal
|
||||
ClientPut OK
|
||||
}
|
||||
}
|
||||
|
||||
method file {} {
|
||||
return [xxxscan file]
|
||||
}
|
||||
|
||||
method setchannel {num} {
|
||||
set ret [catch {xxxscan setchannel $num} msg]
|
||||
if { $ret == 0} {
|
||||
set slot(Channel) $num
|
||||
} else {
|
||||
return $msg
|
||||
}
|
||||
}
|
||||
|
||||
method list { } {
|
||||
ClientPut [format "%s.Preset = %f" $self $slot(Preset)]
|
||||
ClientPut [format "%s.Mode = %s" $self $slot(Mode)]
|
||||
ClientPut [format "%s.File = %s" $self $slot(File)]
|
||||
ClientPut [format "%s.NP = %d" $self $slot(NP)]
|
||||
ClientPut [format "%s.Channel = %d" $self $slot(Channel)]
|
||||
ClientPut "ScanVariables:"
|
||||
for { set i 0 } {$i < $slot(NoVar) } { incr i } {
|
||||
ClientPut [format " %s %f %f" [lindex $slot(scanvars) $i] \
|
||||
[lindex $slot(scanstart) $i] \
|
||||
[lindex $slot(scanstep) $i] ]
|
||||
}
|
||||
}
|
||||
|
||||
method clear {} {
|
||||
# check for activity
|
||||
if {$slot(Active)} {
|
||||
ClientPut "ERROR: cannot clear running scan" error
|
||||
return
|
||||
}
|
||||
|
||||
set slot(NP) 0
|
||||
set slot(NoVar) 0
|
||||
set slot(scanvars) ""
|
||||
set slot(scanstart) ""
|
||||
set slot(scanstep) ""
|
||||
$self SendInterest pinterest ScanVarChange
|
||||
xxxscan clear
|
||||
ClientPut OK
|
||||
}
|
||||
|
||||
method getcounts {} {
|
||||
return [xxxscan getcounts]
|
||||
}
|
||||
|
||||
method run { } {
|
||||
# start with error checking
|
||||
if { $slot(NP) < 1 } {
|
||||
ClientPut "ERROR: Insufficient Number of ScanPoints"
|
||||
return
|
||||
}
|
||||
if { $slot(NoVar) < 1 } {
|
||||
ClientPut "ERROR: No variables to scan given!"
|
||||
return
|
||||
}
|
||||
#------- check for activity
|
||||
if {$slot(Active)} {
|
||||
ClientPut "ERROR: Scan already in progress" error
|
||||
return
|
||||
}
|
||||
set slot(Active) 1
|
||||
xxxscan clear
|
||||
for {set i 0 } { $i < $slot(NoVar)} {incr i} {
|
||||
set ret [catch {xxxscan add [lindex $slot(scanvars) $i] \
|
||||
[lindex $slot(scanstart) $i] [lindex $slot(scanstep) $i]} msg]
|
||||
if {$ret != 0} {
|
||||
set slot(Active) 0
|
||||
error $msg
|
||||
}
|
||||
}
|
||||
set ret [catch \
|
||||
{xxxscan run $slot(NP) $slot(Mode) $slot(Preset)} msg]
|
||||
set slot(Active) 0
|
||||
if {$ret != 0 } {
|
||||
error $msg
|
||||
} else {
|
||||
return "Scan Finished"
|
||||
}
|
||||
}
|
||||
|
||||
method recover {} {
|
||||
set slot(Active) 1
|
||||
catch {xxxscan recover} msg
|
||||
set slot(Active) 0
|
||||
return "Scan Finished"
|
||||
}
|
||||
|
||||
method forceclear {} {
|
||||
set Active 0
|
||||
}
|
||||
}
|
||||
#---- end of ScanCommand definition
|
||||
|
||||
#********************** initialisation of module commands to SICS **********
|
||||
|
||||
set ret [catch {scan list} msg]
|
||||
if {$ret != 0} {
|
||||
object_new ScanCommand scan
|
||||
Publish scan Spy
|
||||
Publish scancounts Spy
|
||||
Publish textstatus Spy
|
||||
Publish cscan User
|
||||
Publish sscan User
|
||||
Publish sftime Spy
|
||||
Publish scaninfo Spy
|
||||
}
|
||||
|
||||
#*************************************************************************
|
||||
|
||||
#===================== Helper commands for status display work ============
|
||||
# a new user command which allows status clients to read the counts in a scan
|
||||
# This is just to circumvent the user protection on scan
|
||||
proc scancounts { } {
|
||||
set status [ catch {scan getcounts} result]
|
||||
if { $status == 0 } {
|
||||
return $result
|
||||
} else {
|
||||
return "scan.Counts= 0"
|
||||
}
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
# This is just another utilility function which helps in implementing the
|
||||
# status display client
|
||||
proc textstatus { } {
|
||||
set text [status]
|
||||
return [format "Status = %s" $text]
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
# Dumps time in a useful format
|
||||
proc sftime {} {
|
||||
return [format "sicstime = %s" [sicstime]]
|
||||
}
|
||||
#-------------------------------------------------------------------------
|
||||
# Utility function which gives scan parameters as an easily parsable
|
||||
# comma separated list for java status client
|
||||
proc scaninfo {} {
|
||||
set result [scan info]
|
||||
set r1 [sample]
|
||||
set l1 [split $r1 "="]
|
||||
append result "," [lindex $l1 1]
|
||||
append result "," [sicstime]
|
||||
set r1 [lastscancommand]
|
||||
set l1 [split $r1 "="]
|
||||
append result "," [lindex $l1 1]
|
||||
return [format "scaninfo = %s" $result]
|
||||
}
|
||||
|
||||
#===================== Syntactical sugar around scan ===================
|
||||
# center scan. A convenience scan for the one and only Daniel Clemens
|
||||
# at TOPSI. Scans around a given ceter point. Requires the scan command
|
||||
# for TOPSI to work.
|
||||
#
|
||||
# another convenience scan:
|
||||
# sscan var1 start end var1 start end .... np preset
|
||||
# scans var1, var2 from start to end with np steps and a preset of preset
|
||||
#
|
||||
# Mark Koennecke, August, 22, 1997
|
||||
#-----------------------------------------------------------------------------
|
||||
proc cscan { var center delta np preset } {
|
||||
#------ start with some argument checking
|
||||
set t [SICSType $var]
|
||||
if { [string compare $t DRIV] != 0 } {
|
||||
ClientPut [format "ERROR: %s is NOT drivable!" $var]
|
||||
return
|
||||
}
|
||||
set t [SICSType $center]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number!" $center]
|
||||
return
|
||||
}
|
||||
set t [SICSType $delta]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number!" $delta]
|
||||
return
|
||||
}
|
||||
set t [SICSType $np]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number!" $np]
|
||||
return
|
||||
}
|
||||
set t [SICSType $preset]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: %s is no number!" $preset]
|
||||
return
|
||||
}
|
||||
#-------- store command in lastscancommand
|
||||
set txt [format "cscan %s %s %s %s %s" $var $center \
|
||||
$delta $np $preset]
|
||||
catch {lastscancommand $txt}
|
||||
#-------- set standard parameters
|
||||
scan clear
|
||||
scan preset $preset
|
||||
scan np [expr $np*2 + 1]
|
||||
#--------- calculate start
|
||||
set start [expr $center - $np * $delta]
|
||||
set ret [catch {scan var $var $start $delta} msg]
|
||||
if { $ret != 0} {
|
||||
ClientPut $msg
|
||||
return
|
||||
}
|
||||
#---------- start scan
|
||||
set ret [catch {scan run} msg]
|
||||
if {$ret != 0} {
|
||||
error $msg
|
||||
}
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
proc sscan args {
|
||||
scan clear
|
||||
#------- check arguments: the last two must be preset and np!
|
||||
set l [llength $args]
|
||||
if { $l < 5} {
|
||||
ClientPut "ERROR: Insufficient number of arguments to sscan"
|
||||
return
|
||||
}
|
||||
set preset [lindex $args [expr $l - 1]]
|
||||
set np [lindex $args [expr $l - 2]]
|
||||
set t [SICSType $preset]
|
||||
ClientPut $t
|
||||
ClientPut [string first $t "NUM"]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: expected number for preset, got %s" \
|
||||
$preset]
|
||||
return
|
||||
}
|
||||
set t [SICSType $np]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: expected number for np, got %s" \
|
||||
$np]
|
||||
return
|
||||
}
|
||||
scan preset $preset
|
||||
scan np $np
|
||||
#--------- do variables
|
||||
set nvar [expr ($l - 2) / 3]
|
||||
for { set i 0 } { $i < $nvar} { incr i } {
|
||||
set var [lindex $args [expr $i * 3]]
|
||||
set t [SICSType $var]
|
||||
if {[string compare $t DRIV] != 0} {
|
||||
ClientPut [format "ERROR: %s is not drivable" $var]
|
||||
return
|
||||
}
|
||||
set start [lindex $args [expr ($i * 3) + 1]]
|
||||
set t [SICSType $start]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: expected number for start, got %s" \
|
||||
$start]
|
||||
return
|
||||
}
|
||||
set end [lindex $args [expr ($i * 3) + 2]]
|
||||
set t [SICSType $end]
|
||||
if { [string compare $t NUM] != 0 } {
|
||||
ClientPut [format "ERROR: expected number for end, got %s" \
|
||||
$end]
|
||||
return
|
||||
}
|
||||
#--------- do scan parameters
|
||||
set step [expr double($end - $start)/double($np)]
|
||||
set ret [catch {scan var $var $start $step} msg]
|
||||
if { $ret != 0} {
|
||||
ClientPut $msg
|
||||
return
|
||||
}
|
||||
}
|
||||
#------------- set lastcommand text
|
||||
set txt [format "sscan %s" [join $args]]
|
||||
catch {lastscancommand $txt}
|
||||
#------------- start scan
|
||||
set ret [catch {scan run} msg]
|
||||
if {$ret != 0} {
|
||||
error $msg
|
||||
}
|
||||
}
|
||||
177
test/scantest.tcl
Normal file
177
test/scantest.tcl
Normal file
@ -0,0 +1,177 @@
|
||||
#--------------------------------------------------------------------------
|
||||
# This file contains some regression tests for the SICS scan module.
|
||||
# This relies on the presence of a suitable configured multicounter in
|
||||
# the test initialization file. That multi counters script must have been
|
||||
# configured to generate an gaussian based on a a4 position. This gaussian
|
||||
# will then be used to check data and for testing peak based algorithms
|
||||
# such as optimization routines, peak and center etc.
|
||||
#
|
||||
# Mark Koennecke, October 2006
|
||||
#--------------------------------------------------------------------------
|
||||
|
||||
clientput "Testing scan routines.."
|
||||
|
||||
config rights Mugger Mugger
|
||||
aba setpar errortype 1 0
|
||||
config rights User User
|
||||
|
||||
proc testScanResults {} {
|
||||
set result [eval peak data]
|
||||
set l [split $result ,]
|
||||
if { abs([lindex $l 0] - 5.3) > .1} {
|
||||
error "Bad peak position"
|
||||
}
|
||||
if { abs([lindex $l 1] - 1.4) > .3} {
|
||||
error "Bad peak FWHM"
|
||||
}
|
||||
if { abs([lindex $l 2] - 288) > 7} {
|
||||
error "Bad peak Value"
|
||||
}
|
||||
}
|
||||
|
||||
test scan-1.0 {Test Normal Scan} -body {
|
||||
testOK "xxxscan clear"
|
||||
testOK "xxxscan add a4 2. .2"
|
||||
set result [eval xxxscan run 30 timer 2]
|
||||
if {[string first ERROR $result] >= 0} {
|
||||
set idx [string first ERROR $result]
|
||||
set errText [string range $result $idx end]
|
||||
error "ERROR occurred during scan: $errText"
|
||||
}
|
||||
testScanResults
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test scan-1.1 {Test cscan} -body {
|
||||
set result [eval cscan a4 5.3 .2 15 3]
|
||||
if {[string first ERROR $result] >= 0} {
|
||||
set idx [string first ERROR $result]
|
||||
set errText [string range $result $idx end]
|
||||
error "ERROR occurred during scan: $errText"
|
||||
}
|
||||
testScanResults
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test scan-1.2 {Test sscan} -body {
|
||||
set result [eval sscan a4 2 7 30 2]
|
||||
if {[string first ERROR $result] >= 0} {
|
||||
set idx [string first ERROR $result]
|
||||
set errText [string range $result $idx end]
|
||||
error "ERROR occurred during scan: $errText"
|
||||
}
|
||||
testScanResults
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test scan-1.3 {Test scan interest} -body {
|
||||
testOK "xxxscan interest"
|
||||
set result [eval xxxscan run 3 timer 2]
|
||||
if {[string first ERROR $result] >= 0} {
|
||||
set idx [string first ERROR $result]
|
||||
set errText [string range $result $idx end]
|
||||
error "ERROR occurred during scan: $errText"
|
||||
}
|
||||
if {[string first NewScan $result] < 0} {
|
||||
error " NewScan missing"
|
||||
}
|
||||
if {[string first scan.Counts $result] < 0} {
|
||||
error "count data missing"
|
||||
}
|
||||
if {[string first ScanEnd $result] < 0} {
|
||||
error "ScanEnd missing"
|
||||
}
|
||||
xxxscan uninterest
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test scan-1.3.1 {Test scan uuinterest} -body {
|
||||
testOK "xxxscan uuinterest"
|
||||
set result [eval xxxscan run 3 timer 2]
|
||||
if {[string first ERROR $result] >= 0} {
|
||||
set idx [string first ERROR $result]
|
||||
set errText [string range $result $idx end]
|
||||
error "ERROR occurred during scan: $errText"
|
||||
}
|
||||
if {[string first NewScan $result] < 0} {
|
||||
error " NewScan missing"
|
||||
}
|
||||
if {[string first ScanData $result] < 0} {
|
||||
error "count data missing"
|
||||
}
|
||||
if {[string first ScanEnd $result] < 0} {
|
||||
error "ScanEnd missing"
|
||||
}
|
||||
xxxscan uninterest
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test scan-1.3.2 {Test scan dyninterest} -body {
|
||||
testOK "xxxscan dyninterest"
|
||||
set result [eval xxxscan run 3 timer 2]
|
||||
if {[string first ERROR $result] >= 0} {
|
||||
set idx [string first ERROR $result]
|
||||
set errText [string range $result $idx end]
|
||||
error "ERROR occurred during scan: $errText"
|
||||
}
|
||||
if {[string first NewScan $result] < 0} {
|
||||
error " NewScan missing"
|
||||
}
|
||||
if {[string first xxxscan.scanpoint $result] < 0} {
|
||||
error "scan point data missing"
|
||||
}
|
||||
if {[string first ScanEnd $result] < 0} {
|
||||
error "ScanEnd missing"
|
||||
}
|
||||
xxxscan uninterest
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test scan-1.4 {Test scan log} -body {
|
||||
testOK "xxxscan log brumm"
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test scan-1.5 {Test scan getfile} -body {
|
||||
testCommand "xxxscan getfile" scan.File
|
||||
} -result OK
|
||||
|
||||
test scan-1.6 {Test scan getcounts} -body {
|
||||
testCommand "xxxscan getcounts" xxxscan.Counts
|
||||
} -result OK
|
||||
|
||||
test scan-1.7 {Test scan getmonitor } -body {
|
||||
testCommand "xxxscan getmonitor 1" xxxscan.mon01
|
||||
} -result OK
|
||||
|
||||
test scan-1.8 {Test scan gettimes } -body {
|
||||
testCommand "xxxscan gettimes" xxxscan.scantimes
|
||||
} -result OK
|
||||
|
||||
test scan-1.9 {Test scan np } -body {
|
||||
testCommand "xxxscan np" xxxscan.nP
|
||||
} -result OK
|
||||
|
||||
test scan-1.10 {Test scan getvardata } -body {
|
||||
testCommand "xxxscan getvardata 0" scan.a4
|
||||
} -result OK
|
||||
|
||||
test scan-1.11 {Test scan noscanvar } -body {
|
||||
testCommand "xxxscan noscanvar" xxxscan.noscanvar
|
||||
} -result OK
|
||||
|
||||
test scan-1.12 {Test scan getvarpar} -body {
|
||||
testCommand "xxxscan getvarpar 0" xxxscan.a4
|
||||
} -result OK
|
||||
|
||||
test scan-1.13 {Test scan aborting} -body {
|
||||
exec interrupt.tcl &
|
||||
set result [eval cscan a4 5.3 .2 15 3]
|
||||
if {[string first "Scan aborted" $result] < 0} {
|
||||
error "Scan did not interrupt!"
|
||||
}
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
|
||||
|
||||
@ -1,5 +1,7 @@
|
||||
exe batchpath ./
|
||||
exe syspath ./
|
||||
lotte UNKNOWN
|
||||
lotte setAccess 2
|
||||
# Motor brumm
|
||||
brumm sign 1.000000
|
||||
brumm SoftZero 0.000000
|
||||
@ -11,8 +13,19 @@ brumm precision 0.100000
|
||||
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.100000
|
||||
miau ignorefault 0.000000
|
||||
miau AccessCode 2.000000
|
||||
miau movecount 10.000000
|
||||
# Counter aba
|
||||
aba SetPreset 10.000000
|
||||
aba SetPreset 2.000000
|
||||
aba SetMode Timer
|
||||
# Counter hugo
|
||||
hugo SetPreset 10.000000
|
||||
@ -23,3 +36,25 @@ lieselotte SetMode Timer
|
||||
# Counter multi
|
||||
multi SetPreset 10.000000
|
||||
multi SetMode Timer
|
||||
# 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
|
||||
# Counter scancter
|
||||
scancter SetPreset 2.000000
|
||||
scancter SetMode Timer
|
||||
hm CountMode timer
|
||||
hm preset 2.000000
|
||||
hm genbin 10.000000 20.000000 70
|
||||
hm init
|
||||
tof CountMode timer
|
||||
tof preset 2.000000
|
||||
tof genbin 50.000000 20.000000 70
|
||||
tof init
|
||||
|
||||
7
test/test.hdd
Normal file
7
test/test.hdd
Normal file
@ -0,0 +1,7 @@
|
||||
*************************** Test Data File ********************************
|
||||
Original Filename = !!FILE!!
|
||||
File Creation Date = !!DATE!!
|
||||
****************************************************************************
|
||||
----------------------------------------------------------------------------
|
||||
!!SCANZERO!!
|
||||
**************************** DATA ******************************************
|
||||
@ -41,10 +41,14 @@ 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.
|
||||
@ -66,3 +70,69 @@ proc multitransfer {} {
|
||||
#-----------------------------------
|
||||
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 a4 SIM -180 180 -.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
|
||||
|
||||
|
||||
21
test/testmisc.tcl
Normal file
21
test/testmisc.tcl
Normal file
@ -0,0 +1,21 @@
|
||||
#--------------------------------------------------------------------
|
||||
# This is for testing odd bits and pieces
|
||||
#
|
||||
# Mark Koennecke, October 2006
|
||||
#--------------------------------------------------------------------
|
||||
|
||||
puts stdout "Testing variables and aliases"
|
||||
|
||||
test misc-1.0 {Test Variables} -body {
|
||||
testPar lotte Uuuuuurgs User
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
test misc-1.1 {Test Alias} -body {
|
||||
config rights User User
|
||||
miau errortype 0
|
||||
testDrive miau 10 User
|
||||
return OK
|
||||
} -result OK
|
||||
|
||||
|
||||
@ -17,6 +17,9 @@ namespace import tcltest::*
|
||||
source testutil.tcl
|
||||
source sicstcldebug.tcl
|
||||
|
||||
#--------------- Test Miscellaneous stuff
|
||||
source testmisc.tcl
|
||||
|
||||
#-------------- Test for motors
|
||||
#source mottest.tcl
|
||||
|
||||
@ -27,7 +30,19 @@ set errorname aba
|
||||
|
||||
#-------------- Test Multi Counter
|
||||
set countername multi
|
||||
source countertest.tcl
|
||||
#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
|
||||
|
||||
#------------ print test summary
|
||||
cleanupTests
|
||||
|
||||
@ -138,4 +138,19 @@ proc testInterruptedCount {startCommand} {
|
||||
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]
|
||||
}
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
proc testCommand {command response} {
|
||||
set result [eval $command]
|
||||
if {[string first $response $result] < 0} {
|
||||
error "Expected $response, received $result"
|
||||
}
|
||||
return OK
|
||||
}
|
||||
|
||||
Reference in New Issue
Block a user