From 79b0f40e5073d4d5eda11662de24ef44bb8b1dc3 Mon Sep 17 00:00:00 2001 From: koennecke Date: Fri, 20 Oct 2006 14:57:27 +0000 Subject: [PATCH] - Implemented regresion tests for batch processing, scans, histmem and peak optimization --- test/DataNumber | 3 + test/batchtest.tcl | 128 ++++++++++++ test/countertest.tcl | 2 +- test/histtest.tcl | 332 +++++++++++++++++++++++++++++ test/interrupt.tcl | 14 ++ test/job1.tcl | 5 + test/job2.tcl | 6 + test/job3.tcl | 6 + test/job4.tcl | 5 + test/object.tcl | 305 +++++++++++++++++++++++++++ test/optitest.tcl | 171 +++++++++++++++ test/scancommand.tcl | 486 +++++++++++++++++++++++++++++++++++++++++++ test/scantest.tcl | 177 ++++++++++++++++ test/sicsstat.tcl | 37 +++- test/test.hdd | 7 + test/testini.tcl | 72 ++++++- test/testmisc.tcl | 21 ++ test/testsics | 17 +- test/testutil.tcl | 17 +- 19 files changed, 1806 insertions(+), 5 deletions(-) create mode 100644 test/DataNumber create mode 100644 test/batchtest.tcl create mode 100644 test/histtest.tcl create mode 100755 test/interrupt.tcl create mode 100644 test/job1.tcl create mode 100644 test/job2.tcl create mode 100644 test/job3.tcl create mode 100644 test/job4.tcl create mode 100644 test/object.tcl create mode 100644 test/optitest.tcl create mode 100644 test/scancommand.tcl create mode 100644 test/scantest.tcl create mode 100644 test/test.hdd create mode 100644 test/testmisc.tcl diff --git a/test/DataNumber b/test/DataNumber new file mode 100644 index 00000000..533c5153 --- /dev/null +++ b/test/DataNumber @@ -0,0 +1,3 @@ + 41 +NEVER, EVER modify or delete this file +You'll risk eternal damnation and a reincarnation as a cockroach!|n \ No newline at end of file diff --git a/test/batchtest.tcl b/test/batchtest.tcl new file mode 100644 index 00000000..a78dca36 --- /dev/null +++ b/test/batchtest.tcl @@ -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 + + diff --git a/test/countertest.tcl b/test/countertest.tcl index 291e0433..4b814687 100644 --- a/test/countertest.tcl +++ b/test/countertest.tcl @@ -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. # diff --git a/test/histtest.tcl b/test/histtest.tcl new file mode 100644 index 00000000..94dc6900 --- /dev/null +++ b/test/histtest.tcl @@ -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 diff --git a/test/interrupt.tcl b/test/interrupt.tcl new file mode 100755 index 00000000..0389cbff --- /dev/null +++ b/test/interrupt.tcl @@ -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 + + \ No newline at end of file diff --git a/test/job1.tcl b/test/job1.tcl new file mode 100644 index 00000000..b0a882ec --- /dev/null +++ b/test/job1.tcl @@ -0,0 +1,5 @@ +#---------------------------------------------------------- +# One of the job files for testing batch file processing +#---------------------------------------------------------- +clientput "Job1 batch file" +wait 20 diff --git a/test/job2.tcl b/test/job2.tcl new file mode 100644 index 00000000..6dae8a59 --- /dev/null +++ b/test/job2.tcl @@ -0,0 +1,6 @@ +#---------------------------------------------------------- +# One of the job files for testing batch file processing +#---------------------------------------------------------- +clientput "NestOne" +exe job3.tcl +wait 3 diff --git a/test/job3.tcl b/test/job3.tcl new file mode 100644 index 00000000..155bdc1a --- /dev/null +++ b/test/job3.tcl @@ -0,0 +1,6 @@ +#---------------------------------------------------------- +# One of the job files for testing batch file processing +#---------------------------------------------------------- +clientput "NestTwo" +exe job4.tcl +wait 3 diff --git a/test/job4.tcl b/test/job4.tcl new file mode 100644 index 00000000..8d562ec6 --- /dev/null +++ b/test/job4.tcl @@ -0,0 +1,5 @@ +#---------------------------------------------------------- +# One of the job files for testing batch file processing +#---------------------------------------------------------- +clientput "NestThree" +wait 3 diff --git a/test/object.tcl b/test/object.tcl new file mode 100644 index 00000000..22460fd2 --- /dev/null +++ b/test/object.tcl @@ -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 \ + "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 +} diff --git a/test/optitest.tcl b/test/optitest.tcl new file mode 100644 index 00000000..824f311e --- /dev/null +++ b/test/optitest.tcl @@ -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 + diff --git a/test/scancommand.tcl b/test/scancommand.tcl new file mode 100644 index 00000000..04e5ee02 --- /dev/null +++ b/test/scancommand.tcl @@ -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 + } +} diff --git a/test/scantest.tcl b/test/scantest.tcl new file mode 100644 index 00000000..2b085b24 --- /dev/null +++ b/test/scantest.tcl @@ -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 + + + diff --git a/test/sicsstat.tcl b/test/sicsstat.tcl index 41306db0..7206b843 100644 --- a/test/sicsstat.tcl +++ b/test/sicsstat.tcl @@ -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 diff --git a/test/test.hdd b/test/test.hdd new file mode 100644 index 00000000..2e05e49c --- /dev/null +++ b/test/test.hdd @@ -0,0 +1,7 @@ +*************************** Test Data File ******************************** +Original Filename = !!FILE!! +File Creation Date = !!DATE!! +**************************************************************************** +---------------------------------------------------------------------------- +!!SCANZERO!! +**************************** DATA ****************************************** diff --git a/test/testini.tcl b/test/testini.tcl index 76b42b81..bf9c4ca5 100644 --- a/test/testini.tcl +++ b/test/testini.tcl @@ -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 + diff --git a/test/testmisc.tcl b/test/testmisc.tcl new file mode 100644 index 00000000..7122b49a --- /dev/null +++ b/test/testmisc.tcl @@ -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 + + diff --git a/test/testsics b/test/testsics index c54151aa..1d775ade 100755 --- a/test/testsics +++ b/test/testsics @@ -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 diff --git a/test/testutil.tcl b/test/testutil.tcl index a5c6c5f9..413354bd 100644 --- a/test/testutil.tcl +++ b/test/testutil.tcl @@ -138,4 +138,19 @@ proc testInterruptedCount {startCommand} { error "Failed to finish counting" } return OK -} \ No newline at end of file +} +#------------------------------------------------------------------------ +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 +}