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

PSI sics-cvs-psi_pre-ansto

Browse Source
This commit is contained in:
koennecke
2003-06-13 00:00:00 +00:00
committed by Douglas Clowes
parent 2e3ddfb6c6
commit 3ffd0d8af4
1099 changed files with 318432 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

8
tcl/bgerror.tcl Executable file
View File

@@ -0,0 +1,8 @@
proc bgerror err {
global errorInfo
set info $errorInfo
puts stdout $err
puts stdout "------------------------- StackTrace ---------------------"
puts $info
}

151
tcl/client.tcl Executable file
View File

@@ -0,0 +1,151 @@
#!/data/koenneck/bin/tclsh
#----------------------------------------------------------------------------
# A command line client for SICS, written in plain Tcl.
# Just sends and reads commands from the SICServer
#
# Mark Koennecke, September 1996
#----------------------------------------------------------------------------
#---------- Data section
set sdata(test,host) lnsa06.psi.ch
set sdata(test,port) 2910
set sdata(dmc,host) lnsa05.psi.ch
set sdata(dmc,port) 3006
set sdata(topsi,host) lnsa03.psi.ch
set sdata(topsi,port) 9708
set sdata(sans,host) lnsa07.psi.ch
set sdata(sans,port) 2915
set sdata(user) Spy
set sdata(passwd) 007
set mysocket stdout
#--------------------------------------------------------------------------
proc bgerror err {
global errorInfo
set info $errorInfo
puts stdout $err
puts stdout "------------------------- StackTrace ---------------------"
puts $info
}
#--------------------------------- procedures section -----------------------
# Setting up the connection to the Server
proc StartConnection {host port} {
global mysocket
global sdata
# start main connection
set mysocket [socket $host $port]
puts $mysocket [format "%s %s" $sdata(user) $sdata(passwd)]
set ret [catch {flush $mysocket} msg]
if { $ret != 0} {
error "Server NOT running!"
}
fconfigure $mysocket -blocking 0
fconfigure $mysocket -buffering none
fileevent $mysocket readable GetData
after 5000
}
#----------------------------------------------------------------------------
proc GetData { } {
global mysocket
global b
if { [eof $mysocket] } {
puts stdout "Connection to server lost"
close $mysocket
set b 1
return
}
set buf [read $mysocket]
set buf [string trim $buf]
set list [split $buf \n]
foreach teil $list {
set teil [string trimright $teil]
puts stdout $teil
}
puts -nonewline stdout "SICS> "
flush stdout
}
#---------------------------------------------------------------------------
proc SendCommand { text} {
global mysocket
global b
if { [eof $mysocket] } {
puts stdout "Connection to server lost"
set b 1
}
puts $mysocket $text
flush $mysocket
}
#----------------------------------------------------------------------------
proc readProgA {pid} {
global readProgADone;
global b
global mysocket
# read outputs of schemdb
set tmpbuf [gets $pid];
if {[string first quit $tmpbuf] > -1 } {
close $mysocket
puts stdout "Closing connection to SICS server on your request..."
puts stdout "Bye, bye, have a nice day!"
set b 1
} elseif { [string first stop $tmpbuf] > -1} {
SendCommand "INT1712 3"
} else {
SendCommand $tmpbuf
}
set readProgADone [eof $pid];
if {$readProgADone} {
puts "closing...";
catch [close $pid] aa;
if {$aa != ""} {
puts "HERE1: Error on closing";
exit 1;
}
}
}
#-------------------------- 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 PrintHeader { } {
global instrument
puts stdout [format "%s Welcome to SICS! %s" [MC " " 30] [MC " " 30]]
puts stdout [format "%s You are connected to: %s" [MC " " 29] [MC " " 29]]
puts stdout [format "%s %s %s" [MC " " 35] $instrument [MC " " 35]]
puts stdout "SICS> "
flush stdout
}
#-------------------------------- "MAIN" -----------------------------------
if {$argc < 1} {
puts stdout "Usage: client instrumentname"
exit 0
}
#----------------- StartConnection
set instrument [lindex $argv 0]
set ret [catch {StartConnection $sdata($instrument,host) \
$sdata($instrument,port)} msg ]
if {$ret != 0} {
puts stdout $msg
exit 1
}
#----------------- print header
PrintHeader
# set the "read" event
fileevent stdin readable {readProgA stdin};
#---loop till exit
set b 0
vwait b
exit 0

54
tcl/count.tcl Normal file
View File

@@ -0,0 +1,54 @@
#--------------------------------------------------------------------------
# A count command for DMC
# All arguments are optional. The current values will be used if not
# specified
# Dr. Mark Koennecke, Juli 1997
#--------------------------------------------------------------------------
proc SplitReply { text } {
set l [split $text =]
return [lindex $l 1]
}
#--------------------------------------------------------------------------
proc count { {mode NULL } { preset NULL } } {
starttime [sicstime]
catch {temperature log clear} msg
#----- deal with mode
set mode2 [string toupper $mode]
set mode3 [string trim $mode2]
set mc [string index $mode2 0]
if { [string compare $mc T] == 0 } {
banana CountMode Timer
} elseif { [string compare $mc M] == 0 } {
banana CountMode Monitor
}
#------ deal with preset
if { [string compare $preset NULL] != 0 } {
banana preset $preset
}
#------ prepare a count message
set a [banana preset]
set aa [SplitReply $a]
set b [banana CountMode]
set bb [SplitReply $b]
ClientPut [format " Starting counting in %s mode with a preset of %s" \
$bb $aa]
#------- count
banana InitVal 0
wait 1
banana count
set ret [catch {Success} msg]
#------- StoreData
StoreData
if { $ret != 0 } {
error [format "Counting ended with error"]
}
}
#---------------- Repeat -----------------------------------------------
proc repeat { num {mode NULL} {preset NULL} } {
for { set i 0 } { $i < $num } { incr i } {
set ret [catch {count $mode $preset} msg]
if {$ret != 0} {
error "Counting ended with error"
}
}
}

52
tcl/fit.tcl Normal file
View File

@@ -0,0 +1,52 @@
#-----------------------------------------------------------------------------
# This is an implementation for a fit command for SICS. It uses a separate
# fit program retrieved from the vast spaces of the net for this purpose.
# The scheme is as follows: Data is written to a file, the fit program is
# executed and the data retrieved at need.
#
# Mark Koennecke, October 1997
#----------------------------------------------------------------------------
#----- Initialise this to match your setup
set fithome /data/koenneck/src/sics/fit
set scancom xxxscan
set IIcentervar ""
proc fit__run { } {
global fithome
global scancom
global IIcentervar
#---------------
set cp [$scancom getcounts]
set cp2 [split $cp =]
set Counts [lindex $cp2 1]
set fp [$scancom getvardata 0]
set fp2 [split $fp = ]
set fitpar [lindex $fp2 1]
#----- set center variable
set bg [lindex $fp2 1]
set bg2 [split $bg .]
set IIcentervar [lindex $bg2 1]
unset cp
unset cp2
unset fp
unset fp2
unset bg
unset bg2
#---- write fit input file
set fd [open $fithome/sicsin.dat w]
set length [llength $Counts]
for {set i 0 } { $i < $length } { incr i} {
puts $fd [format " %f %d" [lindex $fitpar $i] \
[lindex $Counts $i] ]
}
close $fd
}
proc fit args {
set l [llength $args]
if { $l < 1} {
fit__run
}
}

228
tcl/ldAout.tcl Normal file
View File

@@ -0,0 +1,228 @@
# ldAout.tcl --
#
# This "tclldAout" procedure in this script acts as a replacement
# for the "ld" command when linking an object file that will be
# loaded dynamically into Tcl or Tk using pseudo-static linking.
#
# Parameters:
# The arguments to the script are the command line options for
# an "ld" command.
#
# Results:
# The "ld" command is parsed, and the "-o" option determines the
# module name. ".a" and ".o" options are accumulated.
# The input archives and object files are examined with the "nm"
# command to determine whether the modules initialization
# entry and safe initialization entry are present. A trivial
# C function that locates the entries is composed, compiled, and
# its .o file placed before all others in the command; then
# "ld" is executed to bind the objects together.
#
# SCCS: @(#) ldAout.tcl 1.11 96/09/17 09:02:20
#
# Copyright (c) 1995, by General Electric Company. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# This work was supported in part by the ARPA Manufacturing Automation
# and Design Engineering (MADE) Initiative through ARPA contract
# F33615-94-C-4400.
proc tclLdAout {{cc {}} {shlib_suffix {}} {shlib_cflags none}} {
global env
global argv
if {$cc==""} {
set cc $env(CC)
}
# if only two parameters are supplied there is assumed that the
# only shlib_suffix is missing. This parameter is anyway available
# as "info sharedlibextension" too, so there is no need to transfer
# 3 parameters to the function tclLdAout. For compatibility, this
# function now accepts both 2 and 3 parameters.
if {$shlib_suffix==""} {
set shlib_suffix $env(SHLIB_SUFFIX)
set shlib_cflags $env(SHLIB_CFLAGS)
} else {
if {$shlib_cflags=="none"} {
set shlib_cflags $shlib_suffix
set shlib_suffix [info sharedlibextension]
}
}
# seenDotO is nonzero if a .o or .a file has been seen
set seenDotO 0
# minusO is nonzero if the last command line argument was "-o".
set minusO 0
# head has command line arguments up to but not including the first
# .o or .a file. tail has the rest of the arguments.
set head {}
set tail {}
# nmCommand is the "nm" command that lists global symbols from the
# object files.
set nmCommand {|nm -g}
# entryProtos is the table of _Init and _SafeInit prototypes found in the
# module.
set entryProtos {}
# entryPoints is the table of _Init and _SafeInit entries found in the
# module.
set entryPoints {}
# libraries is the list of -L and -l flags to the linker.
set libraries {}
set libdirs {}
# Process command line arguments
foreach a $argv {
if {!$minusO && [regexp {\.[ao]$} $a]} {
set seenDotO 1
lappend nmCommand $a
}
if {$minusO} {
set outputFile $a
set minusO 0
} elseif {![string compare $a -o]} {
set minusO 1
}
if [regexp {^-[lL]} $a] {
lappend libraries $a
if [regexp {^-L} $a] {
lappend libdirs [string range $a 2 end]
}
} elseif {$seenDotO} {
lappend tail $a
} else {
lappend head $a
}
}
lappend libdirs /lib /usr/lib
# MIPS -- If there are corresponding G0 libraries, replace the
# ordinary ones with the G0 ones.
set libs {}
foreach lib $libraries {
if [regexp {^-l} $lib] {
set lname [string range $lib 2 end]
foreach dir $libdirs {
if [file exists [file join $dir lib${lname}_G0.a]] {
set lname ${lname}_G0
break
}
}
lappend libs -l$lname
} else {
lappend libs $lib
}
}
set libraries $libs
# Extract the module name from the "-o" option
if {![info exists outputFile]} {
error "-o option must be supplied to link a Tcl load module"
}
set m [file tail $outputFile]
set l [expr [string length $m] - [string length $shlib_suffix]]
if [string compare [string range $m $l end] $shlib_suffix] {
error "Output file does not appear to have a $shlib_suffix suffix"
}
set modName [string tolower [string range $m 0 [expr $l-1]]]
if [regexp {^lib} $modName] {
set modName [string range $modName 3 end]
}
if [regexp {[0-9\.]*(_g0)?$} $modName match] {
set modName [string range $modName 0 [expr [string length $modName]-[string length $match]-1]]
}
set modName "[string toupper [string index $modName 0]][string range $modName 1 end]"
# Catalog initialization entry points found in the module
set f [open $nmCommand r]
while {[gets $f l] >= 0} {
if [regexp {T[ ]*_?([A-Z][a-z0-9_]*_(Safe)?Init(__FP10Tcl_Interp)?)$} $l trash symbol] {
if {![regexp {_?([A-Z][a-z0-9_]*_(Safe)?Init)} $symbol trash s]} {
set s $symbol
}
append entryProtos {extern int } $symbol { (); } \n
append entryPoints { } \{ { "} $s {", } $symbol { } \} , \n
}
}
close $f
if {$entryPoints==""} {
error "No entry point found in objects"
}
# Compose a C function that resolves the initialization entry points and
# embeds the required libraries in the object code.
set C {#include <string.h>}
append C \n
append C {char TclLoadLibraries_} $modName { [] =} \n
append C { "@LIBS: } $libraries {";} \n
append C $entryProtos
append C {static struct } \{ \n
append C { char * name;} \n
append C { int (*value)();} \n
append C \} {dictionary [] = } \{ \n
append C $entryPoints
append C { 0, 0 } \n \} \; \n
append C {typedef struct Tcl_Interp Tcl_Interp;} \n
append C {typedef int Tcl_PackageInitProc (Tcl_Interp *);} \n
append C {Tcl_PackageInitProc *} \n
append C TclLoadDictionary_ $modName { (symbol)} \n
append C { char * symbol;} \n
append C {{
int i;
for (i = 0; dictionary [i] . name != 0; ++i) {
if (!strcmp (symbol, dictionary [i] . name)) {
return dictionary [i].value;
}
}
return 0;
}} \n
# Write the C module and compile it
set cFile tcl$modName.c
set f [open $cFile w]
puts -nonewline $f $C
close $f
set ccCommand "$cc -c $shlib_cflags $cFile"
puts stderr $ccCommand
eval exec $ccCommand
# Now compose and execute the ld command that packages the module
set ldCommand ld
foreach item $head {
lappend ldCommand $item
}
lappend ldCommand tcl$modName.o
foreach item $tail {
lappend ldCommand $item
}
puts stderr $ldCommand
eval exec $ldCommand
# Clean up working files
exec /bin/rm $cFile [file rootname $cFile].o
}

84
tcl/log.tcl Normal file
View File

@@ -0,0 +1,84 @@
#-----------------------------------------------------------------------------
# This file implements a LogBook facility for SICS.
# Usage:
# LogBook - lists the current status
# LogBook filename - sets the logbook file name
# LogBook on - starts logging, creates new file
# LogBook off - closes log file
#
# Mark Koennecke, June 1997, initially developed for SANS
# works using one procedure and an array for data. All internal procedures
# start with cli
#----------------------------------------------------------------------------
set cliArray(file) default.log
set cliArray(status) off
set cliArray(number) 0
#---------------------------------------------------------------------------
proc cliList { } {
global cliArray
# ClientPut [format " LogBook file: %s\n" $cliArray(file)]
# ClientPut [format " Logging: %s " $cliArray(status)] ]
append res [format " LogBook file: %s\n" $cliArray(file)] \
[format " Logging: %s " $cliArray(status)]
return $res
}
#-------------------------------------------------------------------------
proc cliLogOn { } {
global cliArray
set cmd [list config File $cliArray(file)]
set ret [catch {eval $cmd} msg]
if { $ret != 0 } {
error $msg
} else {
set l [ split $msg = ]
set cliArray(number) [lindex $l 1]
set cliArray(status) on
}
}
#--------------------------------------------------------------------------
proc cliLogOff { } {
global cliArray
set cmd [list config close $cliArray(number)]
set ret [catch {eval $cmd} msg]
if { $ret != 0 } {
error $msg
} else {
set cliArray(status) off
}
}
#-------------------------------------------------------------------------
proc logbook args {
global cliArray
#---- first case: a listing
if { [llength $args] == 0} {
return [cliList]
}
#---- there must be an argument
set argument [lindex $args 0]
#---- on/ off
if {[string compare "on" $argument] == 0} {
set ret [catch {cliLogOn} msg]
if { $ret != 0 } {
error $msg
} else {
ClientPut OK
}
} elseif {[string compare "off" $argument] == 0} {
set ret [catch {cliLogOff} msg]
if { $ret != 0 } {
error $msg
} else {
ClientPut OK
}
} elseif {[string compare "file" $argument] >= 0} {
if {[llength $args] < 1} {
error "ERROR: nor filename specified for LogBook"
}
set cliArray(file) [lindex $args 1]
} elseif {[string compare "no" $argument] == 0} {
ClientPut $cliArray(number)
} else {
error [format "ERROR: unknown argument %s to LogBook" $argument]
}
}

29
tcl/parray.tcl Normal file
View File

@@ -0,0 +1,29 @@
# parray:
# Print the contents of a global array on stdout.
#
# SCCS: @(#) parray.tcl 1.9 96/02/16 08:56:44
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
proc parray {a {pattern *}} {
upvar 1 $a array
if ![array exists array] {
error "\"$a\" isn't an array"
}
set maxl 0
foreach name [lsort [array names array $pattern]] {
if {[string length $name] > $maxl} {
set maxl [string length $name]
}
}
set maxl [expr {$maxl + [string length $a] + 2}]
foreach name [lsort [array names array $pattern]] {
set nameString [format %s(%s) $a $name]
puts stdout [format "%-*s = %s" $maxl $nameString $array($name)]
}
}

79
tcl/reflist.tcl Normal file
View File

@@ -0,0 +1,79 @@
#---------------------------------------------------------------------------
# The first step when doing a four circle experiment is to search
# reflections manually. When some have been found a UB-matrix calculation
# can be tried. In between it is necessary to keep a list of peak positons
# found and to write them to file. This is exactly what this is for.
#
# Mark Koennecke, October 1998
#---------------------------------------------------------------------------
#----- where data files shall go by default
set prefix ./
#--------------------------------------------------------------------------
proc iiGetNum { text } {
set list [split $text =]
return [lindex $list 1]
}
#------------ clear everything
proc iiinit {} {
global iiref
set iiref(np) 0
set iiref(OM) ""
set iiref(TH) ""
set iiref(CH) ""
set iiref(PH) ""
set iiref(title) ""
}
#------- run this once when loading in order to empty space
iiinit
#------------------- store
proc iistore {} {
global iiref
incr iiref(np)
lappend iiref(OM) [iiGetNum [OM]]
lappend iiref(TH) [iiGetNum [TH]]
lappend iiref(CH) [iiGetNum [CH]]
lappend iiref(PH) [iiGetNum [PH]]
lappend iiref(title) [iiGetNum [title]]
}
#------------- write to file
proc iiwrite {fil} {
global iiref
global prefix
set fd [open $prefix/$fil w]
for {set i 0} {$i < $iiref(np)} { incr i } {
set om [lindex $iiref(OM) $i]
set th [lindex $iiref(TH) $i]
set ch [lindex $iiref(CH) $i]
set ph [lindex $iiref(PH) $i]
set tt [lindex $iiref(title) $i]
puts $fd [format "%8.2f %8.2f %8.2f %8.2f %d %s" $th $om $ch $ph $i $tt]
}
close $fd
}
#------------------- the actual control implementation function
proc rliste args {
if {[llength $args] < 1} {
error "ERROR: keyword expected to rliste"
}
switch [lindex $args 0] {
"clear" {
iiinit
return
}
"store" {
iistore
}
"write" {
if { [llength $args] < 2 } {
error "ERROR: expected filename after write"
}
iiwrite [lindex $args 1]
}
default {
error "ERROR: keyword [lindex $args 0] not recognized"
}
}
}

74
tcl/scan.tcl Normal file
View File

@@ -0,0 +1,74 @@
#----------------------------------------------------------------------------
# A simple scan command for DMC. This allows scanning a motor against the
# monitors. This is useful for adjusting DMC. No fancy file writing is done.
# This code relies on (and checks for) the LogBook being active.
#
# Mark Koennecke, Juli 1997
#---------------------------------------------------------------------------
#----- internal: check LogBook is on.
proc scan:CheckLog { } {
set text [LogBook]
if { [string match Log*:*on $text] } {
return 1
} else {
return 0
}
}
#------ internal: get Monitor value
proc scan:monitor { num } {
set reply [counter GetMonitor $num]
set l [split $reply =]
return [lindex $l 1]
}
#------ actual scan command
proc scan { motor start step n {mode NULL } { preset NULL } } {
#----- check for existence of LogBook
# set ret [scan:CheckLog]
# if { $ret != 1 } {
# ClientPut "ERROR: logging must be active for scan"
# ClientPut $ret
# return
# }
#----- is motor reallly countable ?
set ret [SICSType $motor]
if { [string compare $ret "DRIV"] != 0 } {
ClientPut [format "ERROR: %s not drivable" $motor]
return
}
#----- deal with mode
set mode2 [string toupper $mode]
set mode3 [string trim $mode2]
set mc [string index $mode2 0]
if { [string compare $mc T] == 0 } {
banana CountMode Timer
} elseif { [string compare $mc M] == 0 } {
banana CountMode Monitor
}
#------ deal with preset
if { [string compare $preset NULL] != 0 } {
banana preset $preset
}
#------- write output header
ClientPut [format "%10.10s Monitor0 Monitor1" $motor]
#------ the scan loop
for { set i 0} { $i < $n } { incr i } {
#--------- drive
set pos [expr $start + $i * $step]
set ret [catch "drive $motor $pos" msg]
if { $ret != 0 } {
ClientPut "ERROR: driving motor"
ClientPut $msg
}
#---------- count
banana count
Success
#---------- create output
set m0 [scan:monitor 0]
set m1 [scan:monitor 1]
ClientPut [format "%10.2f %11.11d %11.11d" $pos $m0 $m1]
}
ClientPut "Scan finished !"
}

542
tcl/scancom.tcl Normal file
View File

@@ -0,0 +1,542 @@
#--------------------------------------------------------------------------
# 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
#--------------------------------------------------------------------------
#---------- adapt to the local settings
set home /data/koenneck/src
source $home/sics/object.tcl
set datapath $home/tmp
set recoverfil $home/tmp/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
}
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 slot(Active) 1
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 slot(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
VarMake lastscancommand Text User
Publish scancounts Spy
Publish textstatus Spy
Publish cscan User
Publish sscan User
Publish sftime Spy
Publish scaninfo Spy
Publish wwwsics 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 inf [string first = $r1]
if {$inf > 0} {
incr inf
set sa [string range $r1 $inf end]
} else {
set sa Unknown
}
regsub -all , $sa " " sam
append result "," $sam
append result "," [sicstime]
set r1 [lastscancommand]
set l1 [split $r1 "="]
append result "," [lindex $l1 1]
return [format "scaninfo = %s" $result]
}
#----------------------------------------------------------------------
# wwwsics is a procedure which formats the most important status
# information for the WWW-status.
proc wwwsics {} {
#----- get all the data we need
set user [GetNum [user]]
set sample [GetNum [sample]]
set tit [GetNum [title]]
set ret [catch {lambda} msg]
if {$ret != 0 } {
set lam Undetermined
} else {
set lam [GetNum $msg]
}
set lscan [GetNum [lastscancommand]]
set svar [GetNum [scan getvars]]
set ind [string last -END- $svar]
if { $ind > 2 } {
set svar [string range $svar 0 $ind]
} else {
set svar " "
}
set res [scan info]
set l [split $res ,]
set fil [lindex $l 5]
set run [GetNum [sicsdatanumber]]
set stat [GetNum [status]]
#------- html format the reply
append result "<table BORDER=2>"
append result <tr> <th>Run Number</th> <td> $run </td> </tr>
append result <tr> <th>Title</th> <td> $tit </td> </tr>
append result <tr> <th>User</th> <td> $user </td> </tr>
append result <tr> <th>Sample </th> <td> $sample </td> </tr>
append result <tr> <th>wavelength</th> <td> $lam</td> </tr>
append result <tr> <th>Status</th> <td> $stat</td> </tr>
append result <tr> <th>Scan Variables</th> <td> $svar</td> </tr>
append result <tr> <th>File </th> <td> $fil</td> </tr>
append result <tr> <th>Last Scan Command</th> <td> $lscan</td> </tr>
append result </table>
return $result
}
#===================== Syntactical sugar around scan ===================
# center scan. A convenience scan for the one and only Daniel Clemens
# at TOPSI. Scans around a given center 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
}
}

23
tcl/stdin.tcl Normal file
View File

@@ -0,0 +1,23 @@
proc readProgA {pid} {
global readProgADone;
# read outputs of schemdb
set tmpbuf [gets $pid];
puts "received $tmpbuf\n";
set readProgADone [eof $pid];
if {$readProgADone} {
puts "closing...";
catch [close $pid] aa;
if {$aa != ""} {
puts "HERE1: Error on closing";
exit 1;
}
}
}
# set the "read" event
fileevent stdin readable {readProgA stdin};

62
tcl/susca.tcl Normal file
View File

@@ -0,0 +1,62 @@
#----------------------------------------------------------------------------
# suchscan : a very fast scan. A motor is set to run, the counter is started
# and the counter read as fast as possible. Current motor position and
# counts are printed. For quick and dirty location of peaks.
#
# Mark Koennecke, October 1998
#---------------------------------------------------------------------------
proc scGetNum { text } {
set list [split $text =]
return [lindex $list 1]
}
# set the counter name
set ctr counter
#----------- check if var still driving
proc runtest {var } {
set t [listexe]
if {[string first $var $t] >= 0} {
return 1
} else {
return 0
}
}
#-------------------------- the actual susca
proc susca args {
global ctr
if {[llength $args] < 4} {
ClientPut "USAGE: susca var start length time"
error "ERROR: Insufficient number of arguments to susca"
}
#------ drive to start position
set var [lindex $args 0]
set start [lindex $args 1]
set end [lindex $args 2]
set ctime [lindex $args 3]
set ret [catch {drive $var $start} msg]
if {$ret != 0 } {
error "ERROR: $msg"
}
set last 0
#------- start counter
$ctr setmode timer
$ctr countnb $ctime
#-------- start motor
set ret [catch {run $var $end} msg]
if {$ret != 0 } {
error "ERROR: $msg"
}
#------ scan loop
while {[runtest $var] == 1} {
set ct [scGetNum [$ctr getcounts]]
set ncts [expr abs($ct - $last)]
set last $ct
set vp [scGetNum [$var]]
ClientPut [format "%8.2f %12.2f" $vp $ncts]
}
ClientPut "OK"
}

12
tcl/tail.tcl Normal file
View File

@@ -0,0 +1,12 @@
#--------------------------------------------------------------------------
# Implementation of the SICS tail command. This uses the unix sicstail
# command which is defined for the instrument user.
#
# Mark Koennecke, June 1999
#-------------------------------------------------------------------------
proc tail { {n 20} } {
set txt [exec sicstail $n]
ClientPut $txt
return
}

772
tcl/topsiold.tcl Normal file
View File

@@ -0,0 +1,772 @@
#----------------------------------------------------------------------------
# Scan command implementation for TOPSI
# Test version, Mark Koennecke, February 1997
#----------------------------------------------------------------------------
set home /data/koenneck/src/sics/tcl
set datapath /data/koenneck/src/sics/tmp
set recoverfil /data/koenneck/src/sics/recover.dat
bpOn
source $home/utils.tcl
source $home/base.tcl
source $home/inherit.tcl
source $home/obtcl.tcl
#-------------------------- 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]
}
#-------------------------- String list for writing ------------------------
class DataSet
DataSet method init { } {
instvar N
instvar Data
next
set Data(0) " Bla"
set N 0
}
DataSet method add { text } {
instvar N
instvar Data
set Data($N) $text
incr N
}
DataSet method ins { text i } {
instvar Data
instvar N
if { $i >= $N } {
set N [expr $i + 1]
} else {
unset Data($i)
}
set Data($i) $text
}
DataSet method put { file } {
instvar Data
instvar N
for { set i 0 } { $i < $N } { incr i } {
puts $file $Data($i)
}
}
DataSet method clear { } {
instvar Data
instvar N
unset Data
set Data(0) "Bla"
set N 0
}
DataSet method GetN { } {
instvar N
return $N
}
#---------------------------------------------------------------------------
# scan class initialization
class ScanCommand
ScanCommand method init { counter } {
instvar ScanData
instvar [DataSet new Data]
instvar Active
instvar Recover
next
set ScanData(Mode) Timer
set ScanData(NP) 1
set ScanData(counter) $counter
set ScanData(NoVar) 0
set ScanData(Preset) 10.
set ScanData(File) Default.dat
set ScanData(Counts) " "
set ScanData(cinterest) " "
set ScanData(pinterest) " "
set Active 0
set Recover 0
}
#-------------add scan variables---------------------------------------------
ScanCommand method var { name start step } {
instvar ScanData
instvar ScanVar
instvar Active
# check for activity
if {$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 $ScanData(NoVar)
set ScanData(NoVar) [incr ScanData(NoVar)]
set ScanVar($i,Var) $name
set ScanVar($i,Start) $start
set ScanVar($i,Step) $step
set ScanVar($i,Value) " "
$self SendInterest pinterest ScanVarChange
ClientPut OK
}
#---------------------- getvars ------------------------------------------
ScanCommand method getvars {} {
instvar ScanData
instvar ScanVar
set list ""
for {set i 0} { $i < $ScanData(NoVar) } { incr i} {
lappend list $ScanVar($i,Var)
}
return [format "scan.Vars = %s -END-" $list]
}
#------------------------------------------------------------------------
ScanCommand method xaxis {} {
instvar ScanData
instvar ScanVar
if { $ScanData(NoVar) <= 0} {
#---- default Answer
set t [format "%s.xaxis = %f %f" $self 0 1]
} else {
set t [format "%s.xaxis = %f %f" $self $ScanVar(0,Start) \
$ScanVar(0,Step)]
}
ClientPut $t
}
#--------------------- modvar --------------------------------------------
ScanCommand method modvar {name start step } {
instvar ScanData
instvar ScanVar
for {set i 0} { $i < $ScanData(NoVar) } { incr i} {
if { [string compare $name $ScanVar($i,Var)] == 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
}
#-------- do it
set ScanVar($i,Start) $start
set ScanVar($i,Step) $step
return OK
}
}
error [format "Scan Variable %s NOT found" $name]
}
#----------------- interests ----------------------------------------------
ScanCommand method cinterest {} {
instvar ScanData
set nam [GetNum [config MyName]]
lappend ScanData(cinterest) $nam
}
#--------------------------------------------------------------------------
ScanCommand method pinterest {} {
instvar ScanData
set nam [GetNum [config MyName]]
lappend ScanData(pinterest) $nam
}
#-------------------------------------------------------------------------
ScanCommand method SendInterest { type text } {
instvar ScanData
#------ check list first
set l1 $ScanData($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 ScanData($type) $l2
foreach e $l2 {
set b [string trim $e]
$b put $text
}
}
#---------------- Change Mode ----------------------------------------------
ScanCommand method Mode { {NewVal NULL } } {
instvar ScanData
instvar Active
if { [string compare $NewVal NULL] == 0 } {
set val [format "%.Mode = %s" $self $ScanData(Mode)]
ClientPut $val
return $val
} else {
# check for activity
if {$Active} {
ClientPut "ERROR: cannot change parameters while scanning" error
return
}
if { ([string compare $NewVal "Timer"] == 0) || \
([string compare $NewVal Monitor] ==0) } {
set ScanData(Mode) $NewVal
ClientPut OK
} else {
ClientPut [format "ERROR: %s not recognized as ScanMode" $NewVal]
}
}
}
#----------------------------- NP -------------------------------------------
ScanCommand method NP { { NewVal NULL } } {
instvar ScanData
instvar Active
if { [string compare $NewVal NULL] == 0 } {
set val [format "%s.NP = %d" $self $ScanData(NP)]
ClientPut $val
return $val
} else {
# check for activity
if {$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 ScanData(NP) $NewVal
ClientPut OK
}
}
#------------------------------ Preset ------------------------------------
ScanCommand method Preset { {NewVal NULL} } {
instvar ScanData
instvar Active
if { [string compare $NewVal NULL] == 0 } {
set val [format "%s.Preset = %f" $self $ScanData(Preset)]
ClientPut $val
return $val
} else {
# check for activity
if {$Active} {
ClientPut "ERROR: cannot change parameters while scanning" error
return
}
set ScanData(Preset) $NewVal
set t [SICSType $NewVal]
if { [string compare $t NUM] != 0} {
ClientPut [format "ERROR: %s is no number" $NewVal] error
return
}
ClientPut OK
}
}
#------------------------------ File ------------------------------------
ScanCommand method File { {NewVal NULL} } {
instvar ScanData
if { [string compare $NewVal NULL] == 0 } {
set val [format "%s.File = %s" $self $ScanData(File)]
ClientPut $val
return $val
} else {
set ScanData(File) $NewVal
ClientPut OK
}
}
#--------------------------- Count ---------------------------------------
# These and the commands below are for use in recovery only
ScanCommand method RecoCount { val } {
instvar Recover
instvar ScanData
if { ! $Recover } {
ClientPut \
"ERROR: This command may only be used in Recovery Operations" \
error
return
}
set ScanData(Counts) $val
}
#--------------------------- monitor -------------------------------------
ScanCommand method RecoMonitor { val } {
instvar Recover
instvar ScanData
if { ! $Recover } {
ClientPut \
"ERROR: This command may only be used in Recovery Operations" \
error
return
}
set ScanData(Monitor) $val
}
#--------------------------- var -------------------------------------
ScanCommand method RecoVar { var val } {
instvar Recover
instvar ScanData
instvar ScanVar
if { ! $Recover } {
ClientPut \
"ERROR: This command may only be used in Recovery Operations" \
error
return
}
set ScanVar($var,Value) $val
}
#--------------------------- WriteRecover --------------------------------
ScanCommand method WriteRecover { } {
instvar ScanData
instvar ScanVar
global recoverfil
set fd [open $recoverfil w]
puts $fd [format "%s Preset %s " $self $ScanData(Preset)]
puts $fd [format "%s Mode %s " $self $ScanData(Mode)]
puts $fd [format "%s NP %s " $self $ScanData(NP)]
puts $fd [format "%s File %s " $self $ScanData(File)]
for { set i 0 } { $i < $ScanData(NoVar) } { incr i } {
puts $fd [format "%s var %s %s %s" $self $ScanVar($i,Var) \
$ScanVar($i,Start) $ScanVar($i,Step)]
puts $fd [format "%s RecoVar %d %s" $self $i [list $ScanVar($i,Value)]]
}
puts $fd [format "%s RecoCount %s" $self [list $ScanData(Counts)]]
puts $fd [format "%s RecoMonitor %s" $self [list $ScanData(Monitor)]]
close $fd
}
#-------------------------- list ------------------------------------------
ScanCommand method list { } {
instvar ScanData
instvar ScanVar
ClientPut [format "%s.Preset = %f" $self $ScanData(Preset)]
ClientPut [format "%s.Mode = %s" $self $ScanData(Mode)]
ClientPut [format "%s.File = %s" $self $ScanData(File)]
ClientPut [format "%s.NP = %d" $self $ScanData(NP)]
ClientPut "ScanVariables:"
for { set i 0 } {$i < $ScanData(NoVar) } { incr i } {
ClientPut [format " %s %f %f" $ScanVar($i,Var) $ScanVar($i,Start) \
$ScanVar($i,Step)]
}
}
#--------------------------------- clear ---------------------------------
ScanCommand method clear { } {
instvar ScanData
instvar ScanVar
instvar Data
instvar Active
# check for activity
if {$Active} {
ClientPut "ERROR: cannot clear running scan" error
return
}
set ScanData(NP) 0
set ScanData(NoVar) 0
set ScanData(Counts) " "
set ScanData(Monitor) " "
Data clear
$self SendInterest pinterest ScanVarChange
ClientPut OK
}
#--------------------------- Store Initial data -----------------------------
ScanCommand method SaveHeader { } {
instvar Data
instvar ScanData
instvar ScanVar
Data clear
# administrative header
Data add [format "%s TOPSI Data File %s" [MC * 30] \
[MC * 30]]
Data add [Title]
Data add [User]
Data add [format "File created: %s" [sicstime]]
Data add [MC * 75]
Data add [format " %s Setting %s " [MC * 30] [MC * 30]]
# settings of instrument variables
Data add [format "%s Monochromator %s" [MC - 30] [MC - 30]]
Data add [lambda]
Data add [MTL position]
Data add [MTU position]
Data add [MGU position]
# diaphragm should go here
# sample info
Data add [format "%s Sample %s" [MC - 30] [MC - 30]]
Data add [STL position]
Data add [STU position]
Data add [SGL position]
Data add [SGU position]
Data add [MC * 75]
# counter info
Data add [format "CountMode = %s" $ScanData(Mode)]
Data add [format "Count Preset = %s" $ScanData(Preset)]
Data add [MC * 75]
Data add [format "%s DATA %s" [MC * 30] [MC * 30]]
set val "Variables scanned: "
for { set i 0 } { $i < $ScanData(NoVar) } { incr i} {
append val " " $ScanVar($i,Var)
}
Data add "$val"
append t [LeftAlign NP 5]
append t [LeftAlign Counts 12]
for { set i 0 } { $i < $ScanData(NoVar) } { incr i} {
append t [LeftAlign $ScanVar($i,Var) 10]
}
Data add $t
set ScanData(Ptr) [Data GetN]
}
#-----------------------------------------------------------------------------
ScanCommand method ConfigureDevices { } {
instvar ScanData
$ScanData(counter) SetMode $ScanData(Mode)
$ScanData(counter) SetPreset $ScanData(Preset)
}
#----------------------------------------------------------------------------
ScanCommand method StoreScanPoint { } {
instvar ScanData
instvar Data
instvar ScanVar
lappend ScanData(Counts) [GetNum [$ScanData(counter) GetCounts]]
lappend ScanData(Monitor) [GetNum [$ScanData(counter) GetMonitor 1]]
#------------ get Scan Var Values
for { set i 0 } { $i < $ScanData(NoVar) } { incr i } {
lappend ScanVar($i,Value) [GetNum [$ScanVar($i,Var) position]]
}
set iFile $ScanData(Ptr)
#------------ write it
set length [llength $ScanData(Counts)]
for { set i 0 } { $i < $length} { incr i} {
set t " "
append t [LeftAlign $i 5]
append t [LeftAlign [lindex $ScanData(Counts) $i ] 12]
for { set ii 0 } { $ii < $ScanData(NoVar) } { incr ii} {
append t [LeftAlign [lindex $ScanVar($ii,Value) $i] 10]
}
Data ins $t $iFile
incr iFile
}
set fd [open $ScanData(File) w]
Data put $fd
close $fd
}
#--------------------------------------------------------------------------
ScanCommand method GetCounts { } {
instvar ScanData
#------- get data available
set length [llength $ScanData(Counts)]
for { set i 0 } { $i < $length } { incr i} {
lappend result [lindex $ScanData(Counts) $i]
}
#------ put zero in those which are not yet measured
if { $length < $ScanData(NP) } {
for { set i $length } { $i < $ScanData(NP) } { incr i } {
lappend result 0
}
}
return "scan.Counts= $result"
}
#---------------------------------------------------------------------------
ScanCommand method EndScan { } {
instvar Data
instvar ScanData
instvar ScanVar
Data add [format "%s End of Data %s" [MC * 30] [MC * 30]]
set fd [open $ScanData(File) w]
Data put $fd
close $fd
}
#-------------------------------------------------------------------------
ScanCommand method EvalInt { } {
set int [GetInt]
ClientPut [format "Interrupt %s detected" $int]
switch -exact $int {
continue {
return OK
}
abortop {
SetInt continue
return SKIP
}
abortscan {
SetInt continue
return ABORT
}
default {
return ABORT
}
}
}
#--------------------------------------------------------------------------
ScanCommand method DriveTo { iNP } {
instvar ScanData
instvar ScanVar
set command "drive "
for { set i 0 } { $i < $ScanData(NoVar) } { incr i } {
set ScanVar($i,NewVal) [expr $ScanVar($i,Start) + $iNP * \
$ScanVar($i,Step)]
# append ScanVar($i,Value) " " $ScanVar($i,NewVal)
append command " " $ScanVar($i,Var) " " $ScanVar($i,NewVal)
}
set ret [catch {eval $command } msg ]
if { $ret != 0 } {
ClientPut $msg error
return [$self EvalInt]
}
return OK
}
#------------------------------------------------------------------------
ScanCommand method CheckScanBounds { } {
instvar ScanData
instvar ScanVar
for { set i 0} { $i < $ScanData(NP) } { incr i } {
for { set ii 0 } { $ii < $ScanData(NoVar) } { incr ii } {
set NewVal [expr $ScanVar($ii,Start) + $i*$ScanVar($ii,Step)]
set iRet [catch {SICSBounds $ScanVar($ii,Var) $NewVal} msg]
if { $iRet != 0 } {
ClientPut $msg error
return 0
}
}
}
return 1
}
#-------------------------------------------------------------------------
ScanCommand method Count { } {
instvar ScanData
set command $ScanData(counter)
append command " Count "
append command $ScanData(Preset)
set ret [catch {eval $command } msg ]
if { $ret != 0 } {
ClientPut $msg error
return [$self EvalInt]
}
return OK
}
#-------------------------------------------------------------------------
proc LeftAlign { text iField } {
set item $text
append item [MC " " $iField]
return [string range $item 0 $iField]
}
#-------------------------------------------------------------------------
ScanCommand method ScanStatusHeader { } {
instvar ScanData
instvar ScanVar
append t [LeftAlign NP 5]
append t [LeftAlign Counts 12]
for { set i 0 } { $i < $ScanData(NoVar) } { incr i} {
append t [LeftAlign $ScanVar($i,Var) 10]
}
ClientPut $t status
}
#------------------------------------------------------------------------
ScanCommand method ProgressReport { i } {
instvar ScanData
instvar ScanVar
$self ScanStatusHeader
append t [LeftAlign $i 5]
append t [LeftAlign [lindex $ScanData(Counts) $i ] 12]
for { set i 0 } { $i < $ScanData(NoVar) } { incr i} {
append t [LeftAlign $ScanVar($i,NewVal) 10]
}
ClientPut $t status
}
#-------------------------------------------------------------------------
ScanCommand method MakeFile { } {
global datapath
instvar ScanData
SicsDataNumber incr
set num1 [SicsDataNumber]
set num [GetNum $num1]
set fil [ format "%s/topsi%4.4d%2.2d.dat" $datapath $num 97]
set ScanData(File) $fil
}
#--------------------------------------------------------------------------
ScanCommand method run { } {
instvar ScanData
instvar Data
instvar ScanVar
instvar Active
# start with error checking
if { $ScanData(NP) < 1 } {
ClientPut "ERROR: Insufficient Number of ScanPoints"
return
}
if { $ScanData(NoVar) < 1 } {
ClientPut "ERROR: No variables to scan given!"
return
}
#------- check for activity
if {$Active} {
ClientPut "ERROR: Scan already in progress" error
return
}
#------- check Bounds
if { [$self CheckScanBounds] != 1 } {
return
}
# clean data space from relicts of previous scans
Data clear
set ScanData(Counts) " "
set ScanData(Monitor) " "
for {set i 0} { $i < $ScanData(NoVar) } { incr i } {
set ScanVar($i,Value) " "
}
# configure and save data header
$self ConfigureDevices
$self MakeFile
$self SaveHeader
ClientPut [format "Writing %s" $ScanData(File)]
# the actual scan loop
SetStatus Scanning
$self SendInterest cinterest NewScan
set Active 1
for { set i 0 } { $i < $ScanData(NP) } { incr i } {
#---- driving
set ret [$self DriveTo $i]
switch -exact $ret {
OK { }
SKIP { continue }
ABORT { ClientPut "\nERROR: Scan Aborted at drive"
SetStatus Eager
set Active 0
error "Abort"
}
}
#---- counting
set ret [$self Count]
switch -exact $ret {
OK { }
SKIP { continue }
ABORT { ClientPut "\nERROR: Scan Aborted at counting"
SetStatus Eager
set Active 0
error "Abort"
}
}
#--- save data
$self StoreScanPoint
$self WriteRecover
#--- invoke interests
$self SendInterest cinterest [$self GetCounts]
#--- Status Report
$self ProgressReport $i
}
#---- final processing
$self EndScan
ClientPut "OK"
SetStatus Eager
set Active 0
}
#--------------------------------------------------------------------------
ScanCommand method Recover { } {
instvar ScanData
instvar Data
instvar ScanVar
instvar Active
instvar Recover
global recoverfil
# ---- read Recover Information
set Recover 1
$self clear
source $recoverfil
# configure and save data header
$self ConfigureDevices
$self SaveHeader
# Write scan start info
$self ScanStatusHeader
# --- figure out where we are
set Recover 0
set pos [llength $ScanData(Counts)]
# ----------------------the actual scan loop
set OldStat [status]
SetStatus Scanning
set Active 1
for { set i $pos } { $i < $ScanData(NP) } { incr i } {
#---- driving
set ret [$self DriveTo $i]
switch -exact $ret {
OK { }
SKIP { continue }
ABORT { ClientPut "\nERROR: Scan Aborted"
SetStatus $OldStat
set Active 0
return
}
}
#---- counting
set ret [$self Count]
switch -exact $ret {
OK { }
SKIP { continue }
ABORT { ClientPut "\nERROR: Scan Aborted"
SetStatus $OldStat
set Active 0
return
}
}
#--- save data
$self StoreScanPoint
$self WriteRecover
#--- Status Report
$self ProgressReport $i
}
#---- final processing
$self EndScan
ClientPut "OK"
SetStatus $OldStat
set Active 0
}
#---------------------------------------------------------------------------
# finally initialise the scan command
ScanCommand new scan counter
#---------------------------------------------------------------------------
# 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]]
}

43
tcl/wwwpulver.tcl Normal file
View File

@@ -0,0 +1,43 @@
#------------------------------------------------------------------------
# This implements the wwwsics command which generates a listing of
# important experiment parameters in html format for the SICS WWW Status
# application. This version is for the powder diffractometers DMC and
# HRPT.
#
# Mark Koennecke, March 2000
#------------------------------------------------------------------------
proc wwwsics {} {
#----- get all the data we need
set user [GetNum [user]]
set sample [GetNum [sample]]
set tit [GetNum [title]]
set ret [catch {lambda} msg]
if {$ret != 0 } {
set lam Undetermined
} else {
set lam [GetNum $msg]
}
set ret [catch {temperature} msg]
if {$ret != 0 } {
set tem Undetermined
} else {
set tem [GetNum $msg]
}
set run [GetNum [sicsdatanumber]]
catch {incr run} msg
set stat [GetNum [status]]
#------- html format the reply
append result "<table BORDER=2>"
append result <tr> <th>Run Number</th> <td> $run </td> </tr>
append result <tr> <th>Title</th> <td> $tit </td> </tr>
append result <tr> <th>User</th> <td> $user </td> </tr>
append result <tr> <th>Sample </th> <td> $sample </td> </tr>
append result <tr> <th>wavelength</th> <td> $lam</td> </tr>
append result <tr> <th>Sample Temperature</th> <td> $tem</td> </tr>
append result <tr> <th>Status</th> <td> $stat</td> </tr>
append result </table>
return $result
}
#------------ install command
catch {Publish wwwsics Spy} msg