- Implemented regresion tests for batch processing, scans,

histmem and peak optimization

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

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
+
+

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. 
 #

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

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
+
+ 

test/job1.tcl

@@ -0,0 +1,5 @@
+#----------------------------------------------------------
+# One of the job files for testing batch file processing
+#----------------------------------------------------------
+clientput "Job1 batch file"
+wait 20

test/job2.tcl

@@ -0,0 +1,6 @@
+#----------------------------------------------------------
+# One of the job files for testing batch file processing
+#----------------------------------------------------------
+clientput "NestOne"
+exe job3.tcl
+wait 3

test/job3.tcl

@@ -0,0 +1,6 @@
+#----------------------------------------------------------
+# One of the job files for testing batch file processing
+#----------------------------------------------------------
+clientput "NestTwo"
+exe job4.tcl
+wait 3

test/job4.tcl

@@ -0,0 +1,5 @@
+#----------------------------------------------------------
+# One of the job files for testing batch file processing
+#----------------------------------------------------------
+clientput "NestThree"
+wait 3

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 <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
+}

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
+

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
+         }
+}

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
+
+
+

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

test/test.hdd

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

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
+

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
+
+

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

test/testutil.tcl

@@ -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
+}