move folder tasmad
r3086 | jgn | 2011-03-29 15:32:07 +1100 (Tue, 29 Mar 2011) | 1 line
This commit is contained in:
Jing Chen
committed by
Douglas Clowes
Douglas Clowes
parent
e92dce3948
commit
66e3096b24
944
site_ansto/instrument/tas/config/tasmad/sicscommon/hdbutil.tcl
Normal file
944
site_ansto/instrument/tas/config/tasmad/sicscommon/hdbutil.tcl
Normal file
@@ -0,0 +1,944 @@
|
||||
#-----------------------------------------------------------------------
|
||||
# This is a collection of utility procedures to help with Hipadaba and
|
||||
# Gumtree Swiss Edition. This file is supposed to be sourced by any
|
||||
# instrument using Hipadaba.
|
||||
#
|
||||
# Copyright: see file COPYRIGHT
|
||||
#
|
||||
# Collected from various files: Mark Koennecke, March 2008
|
||||
#
|
||||
# Requirements:
|
||||
# * the internal scan command xxxscan
|
||||
# * scan data to live /graphics/scan_data
|
||||
#
|
||||
# Many updates, till November 2008, Mark Koennecke
|
||||
#----------------------------------------------------------------------
|
||||
if { [info exists hdbinit] == 0 } {
|
||||
set hdbinit 1
|
||||
MakeStateMon
|
||||
Publish getgumtreexml Spy
|
||||
if {[string first tmp $home] < 0} {
|
||||
set tmppath $home/tmp
|
||||
} else {
|
||||
set tmppath $home
|
||||
}
|
||||
Publish mgbatch Spy
|
||||
Publish loadmgbatch Spy
|
||||
Publish hsearchprop Spy
|
||||
Publish hdbscan User
|
||||
Publish hdbprepare User
|
||||
Publish hdbcollect User
|
||||
Publish listbatchfiles Spy
|
||||
Publish makemumopos User
|
||||
Publish dropmumo User
|
||||
Publish hdbbatchpath User
|
||||
Publish cscan User
|
||||
Publish sscan User
|
||||
Publish scan Spy
|
||||
Publish hmake Mugger
|
||||
Publish hmakescript Mugger
|
||||
Publish hlink Mugger
|
||||
Publish hcommand Mugger
|
||||
Publish hdbstorenexus User
|
||||
Publish scaninfo Spy
|
||||
}
|
||||
#===================================================================
|
||||
# Configuration commands provided:
|
||||
# hdbReadOnly
|
||||
# makesampleenv path
|
||||
# makestdscan path
|
||||
# makestdscangraphics path
|
||||
# makestdbatch
|
||||
# makeQuickPar name path
|
||||
# makeslit path left right upper lower
|
||||
# configures a slit. Missing motors can be indicated with NONE
|
||||
# makestdadmin
|
||||
# makecount path
|
||||
# makerepeat path
|
||||
# makekillfile path
|
||||
# makesuccess path
|
||||
# makestdgui
|
||||
# makewait path
|
||||
# makeevproxy rootpath hdbname devicename
|
||||
# makemumo rootpath mumoname
|
||||
# makeexe
|
||||
# confnxhdb path alias pass
|
||||
# makestddrive path
|
||||
#===================== hfactory adapters ==========================
|
||||
proc hmake {path priv type {len 1}} {
|
||||
hfactory $path plain $priv $type $len
|
||||
}
|
||||
#--------------------------------------------------------------------
|
||||
proc hmakescript {path readscript writescript type {len 1}} {
|
||||
hfactory $path script $readscript $writescript $type $len
|
||||
}
|
||||
#-------------------------------------------------------------------
|
||||
proc hlink {path obj {treename NONE} } {
|
||||
if {[string equal $treename NONE]} {
|
||||
set treename $ob
|
||||
}
|
||||
append realpath $path / $treename
|
||||
hfactory $realpath link $obj
|
||||
}
|
||||
#-------------------------------------------------------------------
|
||||
proc hcommand {path script} {
|
||||
hfactory $path command $script
|
||||
}
|
||||
#================ make XML tree =====================================
|
||||
proc getdataType {path} {
|
||||
return [lindex [split [hinfo $path] ,] 0]
|
||||
}
|
||||
#---------------------------------------------------------------------
|
||||
proc makeInitValue {path type prefix} {
|
||||
append result ""
|
||||
if {[string compare $type none] != 0 && [string compare $type func] != 0} {
|
||||
set test [catch {hgetprop $path transfer} msg]
|
||||
set tst [catch {hval $path} val]
|
||||
if {$test != 0 && $tst == 0} {
|
||||
append result "$prefix <initValue>\n"
|
||||
append result "$prefix $val\n"
|
||||
append result "$prefix </initValue>\n"
|
||||
}
|
||||
}
|
||||
return $result
|
||||
}
|
||||
#----------------------------------------------------------------------
|
||||
proc make_nodes {path result indent} {
|
||||
set nodename [file tail $path];
|
||||
set type [getdataType $path]
|
||||
set prefix [string repeat " " $indent]
|
||||
set newIndent [expr $indent + 2]
|
||||
#array set prop_list [ string trim [join [split [hlistprop $path] =]] ]
|
||||
set prop_list(control) true
|
||||
set we_have_control [info exists prop_list(control)]
|
||||
if {$we_have_control == 0 || $we_have_control && $prop_list(control) == "true"} {
|
||||
append result "$prefix<component id=\"$nodename\" dataType=\"$type\">\n"
|
||||
foreach p [property_elements $path $newIndent] {
|
||||
append result $p
|
||||
}
|
||||
foreach x [hlist $path] {
|
||||
set result [make_nodes [string map {// /} "$path/$x"] $result $newIndent]
|
||||
}
|
||||
# append result [makeInitValue $path $type $prefix]
|
||||
append result "$prefix</component>\n"
|
||||
}
|
||||
return $result
|
||||
}
|
||||
#-------------------------------------------------------------------
|
||||
proc property_elements_old {path indent} {
|
||||
set prefix [string repeat " " $indent]
|
||||
foreach {key value} [string map {= " "} [hlistprop $path]] {
|
||||
if {[string compare -nocase $key "control"] == 0} {continue}
|
||||
lappend proplist "$prefix<property id=\"$key\">\n"
|
||||
# foreach v [split $value ,] {
|
||||
# lappend proplist "$prefix$prefix<value>$v</value>\n"
|
||||
# }
|
||||
lappend proplist "$prefix$prefix<value>$value</value>\n"
|
||||
lappend proplist "$prefix</property>\n"
|
||||
}
|
||||
if [info exists proplist] {return $proplist}
|
||||
}
|
||||
#-----------------------------------------------------------------------
|
||||
proc property_elements {path indent} {
|
||||
set prefix [string repeat " " $indent]
|
||||
set data [hlistprop $path]
|
||||
set propList [split $data \n]
|
||||
foreach prop $propList {
|
||||
set pl [split $prop =]
|
||||
set key [string trim [lindex $pl 0]]
|
||||
set value [string trim [lindex $pl 1]]
|
||||
if {[string length $key] < 1} {
|
||||
continue
|
||||
}
|
||||
lappend proplist "$prefix<property id=\"$key\">\n"
|
||||
lappend proplist "$prefix$prefix<value>$value</value>\n"
|
||||
lappend proplist "$prefix</property>\n"
|
||||
}
|
||||
if [info exists proplist] {return $proplist}
|
||||
}
|
||||
#--------------------------------------------------------------------------
|
||||
proc getgumtreexml {path} {
|
||||
append result "<?xml version = \"1.0\" encoding = \"UTF-8\"?>\n"
|
||||
append result "<hipadaba:SICS xmlns:hipadaba=\"http://www.psi.ch/sics/hipadaba\" >\n"
|
||||
|
||||
if {[string compare $path "/" ] == 0} {
|
||||
foreach n [hlist $path] {
|
||||
set result [make_nodes /$n $result 2]
|
||||
}
|
||||
} else {
|
||||
foreach n [hlist $path] {
|
||||
set result [make_nodes $path/$n $result 2]
|
||||
}
|
||||
}
|
||||
|
||||
append result "</hipadaba:SICS>\n"
|
||||
}
|
||||
#==================== Gumtree batch =========================================
|
||||
proc searchPathForDrivable {name} {
|
||||
set path [string trim [hmatchprop / sicsdev $name]]
|
||||
if {[string compare $path NONE] != 0} {
|
||||
return $path
|
||||
}
|
||||
set txt [findalias $name]
|
||||
if {[string compare $txt NONE] == 0} {
|
||||
return NONE
|
||||
}
|
||||
set l1 [split $txt =]
|
||||
set l [split [lindex $l1 1] ,]
|
||||
foreach alias $l {
|
||||
set alias [string trim $alias]
|
||||
set path [string trim [hmatchprop / sicsdev $alias]]
|
||||
if {[string compare $path NONE] != 0} {
|
||||
return $path
|
||||
}
|
||||
}
|
||||
return NONE
|
||||
}
|
||||
#----------------------------------------------------------------
|
||||
proc searchForCommand {name} {
|
||||
return [string trim [hmatchprop / sicscommand $name]]
|
||||
}
|
||||
#----------------------------------------------------------------
|
||||
proc treatsscan {scanpath command out} {
|
||||
set l [split $command]
|
||||
set len [llength $l]
|
||||
set noVar [expr ($len-2)/3]
|
||||
set np [lindex $l [expr $len -2]]
|
||||
set preset [lindex $l [expr $len -1]]
|
||||
for {set i 0} {$i < $noVar} {incr i} {
|
||||
set start [expr $i * 3]
|
||||
set scanVar [lindex $l [expr 1 + $start]]
|
||||
set scanStart [lindex $l [expr 2 + $start]]
|
||||
set scanEnd [lindex $l [expr 3 + $start]]
|
||||
set scanStep [expr ($scanEnd*1. - $scanStart*1.)/$np*1.]
|
||||
append hdbVar $scanVar ,
|
||||
append hdbStart $scanStart ,
|
||||
append hdbStep $scanStep ,
|
||||
}
|
||||
set hdbVar [string trim $hdbVar ,]
|
||||
set hdbStart [string trim $hdbStart ,]
|
||||
set hdbStep [string trim $hdbStep ,]
|
||||
puts $out "\#NODE: $scanpath"
|
||||
puts $out "clientput BatchPos = 1"
|
||||
puts $out "hdbscan $hdbVar $hdbStart $hdbStep $np monitor $preset"
|
||||
}
|
||||
#----------------------------------------------------------------
|
||||
proc treatcscan {scanpath command out} {
|
||||
set l [split $command]
|
||||
set scanVar [lindex $l 1]
|
||||
set scanCenter [lindex $l 2]
|
||||
set scanStep [lindex $l 3]
|
||||
set np [lindex $l 4]
|
||||
set preset [lindex $l 5]
|
||||
set hdbStart [expr $scanCenter - ($np*1.0)/2. * $scanStep*1.0]
|
||||
puts $out "\#NODE: $scanpath"
|
||||
puts $out "clientput BatchPos = 1"
|
||||
puts $out "hdbscan $scanVar $hdbStart $scanStep $np monitor $preset"
|
||||
}
|
||||
#----------------------------------------------------------------
|
||||
proc translateCommand {command out} {
|
||||
set drivelist [list drive dr run]
|
||||
set textList [list for while source if]
|
||||
# clientput "Translating: $command"
|
||||
set command [string trim $command]
|
||||
if {[string length $command] < 2} {
|
||||
return
|
||||
}
|
||||
set l [split $command]
|
||||
set obj [string trim [lindex $l 0]]
|
||||
#------- check for drive commands
|
||||
set idx [lsearch $drivelist $obj]
|
||||
if {$idx >= 0} {
|
||||
set dev [lindex $l 1]
|
||||
set path [searchPathForDrivable $dev]
|
||||
if {[string compare $path NONE] != 0} {
|
||||
set realTxt [hgetprop $path sicsdev]
|
||||
set realL [split $realTxt =]
|
||||
set realDev [lindex $realL 1]
|
||||
set mapList [list $dev $realDev]
|
||||
set newCom [string map $mapList $command]
|
||||
puts $out "\#NODE: $path"
|
||||
puts $out "clientput BatchPos = 1"
|
||||
puts $out $newCom
|
||||
return
|
||||
}
|
||||
}
|
||||
#------ check for well known broken commands
|
||||
set idx [lsearch $textList $obj]
|
||||
if {$idx >= 0} {
|
||||
puts $out "\#NODE: /batch/commandtext"
|
||||
puts $out "clientput BatchPos = 1"
|
||||
set buffer [string map {\n @nl@} $command]
|
||||
puts $out "hset /batch/commandtext $buffer"
|
||||
return
|
||||
}
|
||||
#--------- check for simple commands
|
||||
set path [searchForCommand $command]
|
||||
if {[string compare $path NONE] != 0} {
|
||||
puts $out "\#NODE: $path"
|
||||
puts $out "clientput BatchPos = 1"
|
||||
puts $out $command
|
||||
return
|
||||
}
|
||||
set scancom [searchForCommand hdbscan]
|
||||
#---------- deal with scans
|
||||
if {[string first sscan $obj] >= 0} {
|
||||
if {[catch {treatsscan $scancom $command $out}] == 0} {
|
||||
return
|
||||
}
|
||||
}
|
||||
if {[string first cscan $obj] >= 0} {
|
||||
if {[catch {treatsscan $scancom $command $out}] == 0} {
|
||||
return
|
||||
}
|
||||
}
|
||||
#--------- give up: output as a text node
|
||||
puts $out "\#NODE: /batch/commandtext"
|
||||
puts $out "clientput BatchPos = 1"
|
||||
set buffer [string map {\n @nl@} $command]
|
||||
puts $out "hset /batch/commandtext $buffer"
|
||||
}
|
||||
#----------------------------------------------------------------
|
||||
proc mgbatch {filename} {
|
||||
global tmppath
|
||||
set f [open $filename r]
|
||||
gets $f line
|
||||
close $f
|
||||
if {[string first MOUNTAINBATCH $line] > 0} {
|
||||
#--------- This is a mountaingum batch file which does not need
|
||||
# to be massaged
|
||||
return $filename
|
||||
}
|
||||
set f [open $filename r]
|
||||
set realfilename [file tail $filename]
|
||||
set out [open $tmppath/$realfilename w]
|
||||
puts $out \#MOUNTAINBATCH
|
||||
while {[gets $f line] >= 0} {
|
||||
append buffer $line
|
||||
if {[info complete $buffer] == 1} {
|
||||
translateCommand $buffer $out
|
||||
unset buffer
|
||||
} else {
|
||||
append buffer \n
|
||||
}
|
||||
}
|
||||
close $out
|
||||
return $tmppath/$realfilename
|
||||
}
|
||||
#----------------------------------------------------------------
|
||||
proc loadmgbatch {filename} {
|
||||
set txt [exe fullpath $filename]
|
||||
set l [split $txt =]
|
||||
set realf [lindex $l 1]
|
||||
set realf [mgbatch $realf]
|
||||
return [exe print $realf]
|
||||
}
|
||||
#============== hdbscan =========================================
|
||||
proc hdbscan {scanvars scanstart scanincr np mode preset} {
|
||||
global stdscangraph hdbscanactive
|
||||
xxxscan clear
|
||||
xxxscan configure script
|
||||
xxxscan function prepare hdbprepare
|
||||
xxxscan function collect hdbcollect
|
||||
set varlist [split $scanvars ,]
|
||||
set startlist [split $scanstart ,]
|
||||
set incrlist [split $scanincr ,]
|
||||
catch {hset $stdscangraph/scan_variable/name [lindex $varlist 0]}
|
||||
set count 0
|
||||
foreach var $varlist {
|
||||
if {[string first / $var] >= 0} {
|
||||
set var [string trim [SplitReply [hgetprop $var sicsdev]]]
|
||||
}
|
||||
xxxscan add $var [lindex $startlist $count] [lindex $incrlist $count]
|
||||
incr count
|
||||
}
|
||||
set hdbscanactive 1
|
||||
set status [catch {xxxscan run $np $mode $preset} msg]
|
||||
set hdbscanactive 0
|
||||
if {$status == 0} {
|
||||
return $msg
|
||||
} else {
|
||||
error $msg
|
||||
}
|
||||
}
|
||||
#------------------------------------------------------------------------------
|
||||
proc hdbprepare {obj userdata } {
|
||||
global stdscangraph
|
||||
stdscan prepare $obj userdata
|
||||
catch {hupdate $stdscangraph/dim}
|
||||
}
|
||||
#------------------------------------------------------------------------------
|
||||
proc hdbcollect {obj userobj np} {
|
||||
global stdscangraph
|
||||
stdscan collect $obj $userobj $np
|
||||
catch {hupdate $stdscangraph/scan_variable}
|
||||
catch {hupdate $stdscangraph/counts}
|
||||
}
|
||||
#-----------------------------------------------------------------------------
|
||||
proc gethdbscanvardata {no} {
|
||||
set np [string trim [SplitReply [xxxscan np]]]
|
||||
if {$np == 0} {
|
||||
return ".0 .0 .0"
|
||||
}
|
||||
set status [catch {SplitReply [xxxscan getvardata $no]} txt]
|
||||
if {$status == 0} {
|
||||
return [join $txt]
|
||||
} else {
|
||||
return ".0 .0 .0"
|
||||
}
|
||||
}
|
||||
#----------------------------------------------------------------------------
|
||||
proc gethdbscancounts {} {
|
||||
set np [string trim [SplitReply [xxxscan np]]]
|
||||
if {$np == 0} {
|
||||
return "0 0 0"
|
||||
}
|
||||
set status [catch {SplitReply [xxxscan getcounts]} txt]
|
||||
if {$status == 0} {
|
||||
return [join $txt]
|
||||
} else {
|
||||
return "0 0 0"
|
||||
}
|
||||
}
|
||||
#================= helper to get the list of batch files =================
|
||||
proc listbatchfiles {} {
|
||||
set ext [list *.tcl *.job *.run]
|
||||
set txt [SplitReply [exe batchpath]]
|
||||
set dirlist [split $txt :]
|
||||
set txt [SplitReply [exe syspath]]
|
||||
set dirlist [concat $dirlist [split $txt :]]
|
||||
# clientput $dirlist
|
||||
set result [list ""]
|
||||
foreach dir $dirlist {
|
||||
foreach e $ext {
|
||||
set status [catch {glob [string trim $dir]/$e} filetxt]
|
||||
if {$status == 0} {
|
||||
set filelist [split $filetxt]
|
||||
foreach f $filelist {
|
||||
# clientput "Working at $f"
|
||||
set nam [file tail $f]
|
||||
if { [lsearch $result $nam] < 0} {
|
||||
# clientput "Adding $nam"
|
||||
lappend result $nam
|
||||
}
|
||||
}
|
||||
} else {
|
||||
# clientput "ERROR: $filetxt"
|
||||
}
|
||||
}
|
||||
}
|
||||
foreach bf $result {
|
||||
append resulttxt $bf ,
|
||||
}
|
||||
return [string trim $resulttxt ,]
|
||||
}
|
||||
#-------------------------------------------------------------------------
|
||||
proc hsearchprop {root prop val} {
|
||||
set children [hlist $root]
|
||||
set childlist [split $children \n]
|
||||
if {[llength $childlist] <= 0} {
|
||||
error "No children"
|
||||
}
|
||||
foreach child $childlist {
|
||||
if {[string length $child] < 1} {
|
||||
continue
|
||||
}
|
||||
catch {hgetprop $root/$child $prop} msg
|
||||
if { [string first ERROR $msg] < 0} {
|
||||
set value [string trim [SplitReply $msg]]
|
||||
if { [string equal -nocase $value $val] == 1} {
|
||||
return $root/$child
|
||||
}
|
||||
}
|
||||
set status [catch {hsearchprop $root/$child $prop $val} node]
|
||||
if {$status == 0} {
|
||||
return $node
|
||||
}
|
||||
}
|
||||
error "Not found"
|
||||
}
|
||||
#============ various utility routines =====================================
|
||||
proc hdbReadOnly args {
|
||||
error "Parameter is READ ONLY"
|
||||
}
|
||||
#---------------------------------------------------------------------------
|
||||
proc makesampleenv {path} {
|
||||
hfactory $path plain spy none
|
||||
hsetprop $path type graphdata
|
||||
hsetprop $path viewer mountaingumui.TimeSeries
|
||||
hfactory $path/vars plain user text
|
||||
hset $path/vars tomato
|
||||
hfactory $path/rank plain user int
|
||||
hset $path/rank 1
|
||||
hfactory $path/dim plain user intar 1
|
||||
hset $path/dim 300
|
||||
hfactory $path/getdata plain user text
|
||||
hsetprop $path/getdata type logcommand
|
||||
hfactory $path/getdata/2010ttime plain spy text
|
||||
hfactory $path/getdata/2010ime plain spy text
|
||||
}
|
||||
#--------------------------------------------------
|
||||
proc makestdscan {path} {
|
||||
hfactory $path command hdbscan
|
||||
hsetprop $path type command
|
||||
hsetprop $path viewer mountaingumui.ScanEditor
|
||||
hsetprop $path priv user
|
||||
hfactory $path/scan_variables plain user text
|
||||
hsetprop $path/scan_variables argtype drivable
|
||||
hfactory $path/scan_start plain user text
|
||||
hfactory $path/scan_increments plain user text
|
||||
hfactory $path/NP plain user int
|
||||
hfactory $path/mode plain user text
|
||||
hsetprop $path/mode values "monitor,timer"
|
||||
hfactory $path/preset plain user float
|
||||
}
|
||||
#---------------------------------------------------
|
||||
proc makestdscangraphics {path} {
|
||||
global stdscangraph
|
||||
|
||||
set stdscangraph $path
|
||||
|
||||
hfactory $path plain spy none
|
||||
hsetprop $path type graphdata
|
||||
hsetprop $path viewer default
|
||||
hattach $path title title
|
||||
hfactory $path/rank plain mugger int
|
||||
hset $path/rank 1
|
||||
hsetprop $path/rank priv internal
|
||||
hfactory $path/dim script "xxxscan np" hdbReadOnly intar 1
|
||||
hsetprop $path/dim priv internal
|
||||
hfactory $path/scan_variable script "gethdbscanvardata 0" hdbReadOnly floatvarar 1
|
||||
hsetprop $path/scan_variable type axis
|
||||
hsetprop $path/scan_variable dim 0
|
||||
hsetprop $path/scan_variable transfer zip
|
||||
hsetprop $path/scan_variable priv internal
|
||||
hfactory $path/scan_variable/name plain user text
|
||||
hfactory $path/counts script "gethdbscancounts" hdbReadOnly intvarar 1
|
||||
hsetprop $path/counts type data
|
||||
hsetprop $path/counts transfer zip
|
||||
hsetprop $path/counts priv internal
|
||||
}
|
||||
#----------------------------------------------------
|
||||
proc makeQuickPar {name path} {
|
||||
hfactory /quickview/$name plain mugger text
|
||||
hset /quickview/$name $path
|
||||
}
|
||||
#---------------------------------------------------
|
||||
proc makestdbatch {} {
|
||||
hfactory /batch plain spy none
|
||||
hfactory /batch/bufferlist script listbatchfiles hdbReadOnly text
|
||||
sicspoll add /batch/bufferlist hdb 30
|
||||
hfactory /batch/commandtext plain spy text
|
||||
hsetprop /batch/commandtext viewer mountaingumui.TextEdit
|
||||
hsetprop /batch/commandtext commandtext true
|
||||
hfactory /batch/currentline plain user int
|
||||
}
|
||||
#-----------------------------------------------------
|
||||
proc makeslit {path left right upper bottom} {
|
||||
hfactory $path plain spy none
|
||||
hsetprop $path type part
|
||||
if {![string equal $left NONE]} {
|
||||
hattach $path $left left
|
||||
}
|
||||
if {![string equal $right NONE]} {
|
||||
hattach $path $right right
|
||||
}
|
||||
if {![string equal $upper NONE]} {
|
||||
hattach $path $upper upper
|
||||
}
|
||||
if {![string equal $bottom NONE]} {
|
||||
hattach $path $bottom bottom
|
||||
}
|
||||
}
|
||||
#---------------------------------------------------------
|
||||
proc makestdadmin {} {
|
||||
hfactory /instrument/experiment plain spy none
|
||||
hattach /instrument/experiment title title
|
||||
hattach /instrument/experiment user user
|
||||
set status [catch {hattach /instrument/experiment/user adress address} msg]
|
||||
if {$status != 0} {
|
||||
set status [catch {hattach /instrument/experiment/user address address} msg]
|
||||
}
|
||||
hattach /instrument/experiment/user phone phone
|
||||
hattach /instrument/experiment/user email email
|
||||
hfactory /instrument/experiment/datafilenumber script sicsdatanumber \
|
||||
hdbReadOnly int
|
||||
hsetprop /instrument/experiment/datafilenumber priv internal
|
||||
hfactory /instrument/experiment/batchpath script "exe batchpath" \
|
||||
hdbbatchpath text
|
||||
hsetprop /instrument/experiment/batchpath priv user
|
||||
sicspoll add /instrument/experiment/batchpath hdb 60
|
||||
sicspoll add /instrument/experiment/datafilenumber hdb 60
|
||||
}
|
||||
#----------------------------------------------------------
|
||||
proc makecount {path} {
|
||||
hfactory $path command count
|
||||
hsetprop $path type command
|
||||
hsetprop $path priv user
|
||||
hfactory $path/mode plain user text
|
||||
hsetprop $path/mode values "monitor,timer"
|
||||
hfactory $path/preset plain user float
|
||||
hset $path/preset 60000
|
||||
hset $path/mode monitor
|
||||
}
|
||||
#----------------------------------------------------------
|
||||
proc makerepeat {path} {
|
||||
hfactory $path command repeat
|
||||
hsetprop $path type command
|
||||
hsetprop $path priv user
|
||||
hfactory $path/num plain user int
|
||||
hfactory $path/mode plain user text
|
||||
hsetprop $path/mode values "monitor,timer"
|
||||
hfactory $path/preset plain user float
|
||||
hset $path/preset 60000
|
||||
hset $path/mode monitor
|
||||
}
|
||||
#----------------------------------------------------------
|
||||
proc makekillfile {path} {
|
||||
hcommand $path killfile
|
||||
hsetprop $path type command
|
||||
hsetprop $path priv manager
|
||||
}
|
||||
#----------------------------------------------------------
|
||||
proc makesuccess {path} {
|
||||
hcommand $path success
|
||||
hsetprop $path type command
|
||||
hsetprop $path priv user
|
||||
}
|
||||
#-----------------------------------------------------------
|
||||
proc makestdgui {} {
|
||||
hfactory /gui plain spy none
|
||||
hfactory /gui/status plain internal text
|
||||
status hdbinterest /gui/status
|
||||
}
|
||||
#------------------------------------------------------------
|
||||
proc makewait {path} {
|
||||
hfactory $path command wait
|
||||
hsetprop $path type command
|
||||
hsetprop $path priv user
|
||||
hfactory $path/time plain user int
|
||||
}
|
||||
#------------------------------------------------------------
|
||||
proc makeevproxy {rootpath hdbname devicename} {
|
||||
MakeProxy p${devicename} $devicename float
|
||||
p${devicename} map upperlimit upperlimit float user
|
||||
p${devicename} map lowerlimit lowerlimit float user
|
||||
hlink $rootpath p${devicename} $hdbname
|
||||
hsetprop $rootpath/$hdbname sicsdev $devicename
|
||||
hsetprop $rootpath/$hdbname type drivable
|
||||
sicspoll add $rootpath/$hdbname hdb 30
|
||||
}
|
||||
#================== multi motor stuff =======================
|
||||
proc getNamposList {mumo} {
|
||||
set txt [$mumo list]
|
||||
set l [split $txt "\n"]
|
||||
set lala [llength $l]
|
||||
for {set i 1} {$i < [llength $l]} {incr i} {
|
||||
set pos [lindex $l $i]
|
||||
if {[string length $pos] > 1} {
|
||||
append result [lindex $l $i] ","
|
||||
}
|
||||
}
|
||||
if { ![info exists result] } {
|
||||
# clientput "nampos = $txt"
|
||||
append result UNKNOWN
|
||||
}
|
||||
return [string trimright $result ","]
|
||||
}
|
||||
#------------------------------------------------------------
|
||||
proc getNamPos {mumo} {
|
||||
set txt [$mumo find]
|
||||
set l [split $txt =]
|
||||
return [string trim [lindex $l 1]]
|
||||
}
|
||||
#-----------------------------------------------------------
|
||||
proc updateNamePosValues {rootpath} {
|
||||
hupdate $rootpath/namedposition/values
|
||||
hupdate $rootpath/dropnamedposition/name/values
|
||||
}
|
||||
#------------------------------------------------------------
|
||||
proc makemumopos {mumo rootpath name} {
|
||||
$mumo pos $name
|
||||
updateNamePosValues $rootpath
|
||||
}
|
||||
#-----------------------------------------------------------
|
||||
proc dropmumo {mumo rootpath name} {
|
||||
$mumo drop $name
|
||||
updateNamePosValues $rootpath
|
||||
}
|
||||
#------------------------------------------------------------
|
||||
proc getDropList {mumo} {
|
||||
set txt [getNamposList $mumo]
|
||||
append txt ",all"
|
||||
return $txt
|
||||
}
|
||||
#-------------------------------------------------------------
|
||||
proc makemumo {rootpath mumoname} {
|
||||
hfactory $rootpath/namedposition script "getNamPos $mumoname" \
|
||||
$mumoname text
|
||||
hsetprop $rootpath/namedposition priv user
|
||||
hfactory $rootpath/namedposition/values script \
|
||||
"getNamposList $mumoname" hdbReadOnly text
|
||||
hsetprop $rootpath/namedposition/values visible false
|
||||
hupdate $rootpath/namedposition/values
|
||||
hfactory $rootpath/assignname2current command \
|
||||
"makemumopos $mumoname $rootpath"
|
||||
hsetprop $rootpath/assignname2current priv user
|
||||
hsetprop $rootpath/assignname2current type command
|
||||
hfactory $rootpath/assignname2current/name plain user text
|
||||
hset $rootpath/assignname2current/name "Undefined"
|
||||
hfactory $rootpath/dropnamedposition command \
|
||||
"dropmumo $mumoname $rootpath"
|
||||
hsetprop $rootpath/dropnamedposition priv user
|
||||
hsetprop $rootpath/dropnamedposition type command
|
||||
hfactory $rootpath/dropnamedposition/name plain user text
|
||||
hfactory $rootpath/dropnamedposition/name/values script \
|
||||
"getDropList $mumoname" hdbReadOnly text
|
||||
hsetprop $rootpath/dropnamedposition/name/values visible false
|
||||
hupdate $rootpath/dropnamedposition/name/values
|
||||
}
|
||||
#-----------------------------------------------------------------
|
||||
proc hdbbatchpath {pathstring} {
|
||||
exe batchpath $pathstring
|
||||
catch {batchroot $pathstring}
|
||||
catch {hupdate /instrument/commands/batch/execute/file/values}
|
||||
catch {hupdate /instrument/commands/batch/batchpath}
|
||||
catch {hupdate /instrument/experiment/batchpath}
|
||||
catch {hupdate /batch/bufferlist}
|
||||
}
|
||||
#------------------------------------------------------------------
|
||||
proc makeexe {} {
|
||||
set path /instrument/commands/batch
|
||||
hfactory $path plain spy none
|
||||
hfactory $path/batchpath script "exe batchpath" hdbbatchpath text
|
||||
hsetprop $path/batchpath priv user
|
||||
hfactory $path/execute command exe
|
||||
hsetprop $path/execute type command
|
||||
hsetprop $path/execute priv user
|
||||
hfactory $path/execute/file plain user text
|
||||
hfactory $path/execute/file/values script listbatchfiles hdbReadOnly text
|
||||
sicspoll add $path/execute/file/values hdb 60
|
||||
}
|
||||
#------------------------------------------------------------------
|
||||
proc confnxhdb {path alias pass} {
|
||||
hsetprop $path nxalias $alias
|
||||
hsetprop $path nxpass $pass
|
||||
}
|
||||
#----------------------------------------------------------------------
|
||||
proc hdbstorenexus args {
|
||||
if {[llength $args] < 2} {
|
||||
error "hdbstorenexus called with insufficient number of arguments"
|
||||
}
|
||||
set path [lindex $args 0]
|
||||
set pass [lindex $args 1]
|
||||
set childlist [split [hlist $path] \n]
|
||||
foreach child $childlist {
|
||||
if {[string length $child] < 1} {
|
||||
continue
|
||||
}
|
||||
set status [catch {hgetpropval $path/$child nxpass} passval]
|
||||
if {$status == 0} {
|
||||
set status [catch {hgetpropval $path/$child nxslab} slabval]
|
||||
# ------- slabbed writing
|
||||
if {$status == 0 && [string first $pass $passval] >= 0} {
|
||||
set slabsizes [eval $slabval [lrange $args 2 end]]
|
||||
nxscript puthdbslab $path/$child [lindex $slabsizes 0] [lindex $slabsizes 1]
|
||||
}
|
||||
#--------- normal writing
|
||||
if {[string first $pass $passval] >= 0} {
|
||||
nxscript puthdb $path/$child
|
||||
}
|
||||
}
|
||||
eval hdbstorenexus $path/$child $pass [lrange $args 2 end]
|
||||
}
|
||||
}
|
||||
#===================== Syntactical sugar around hdbscan ===================
|
||||
# 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 1997
|
||||
#
|
||||
# Reworked for hdbscan, Mark Koennecke, November 2008
|
||||
#-----------------------------------------------------------------------------
|
||||
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
|
||||
}
|
||||
set mode [string trim [SplitReply [scan mode]]]
|
||||
#-------- store command in lastscancommand
|
||||
set txt [format "cscan %s %s %s %s %s" $var $center \
|
||||
$delta $np $preset]
|
||||
catch {lastscancommand $txt}
|
||||
#--------- calculate start and do scan
|
||||
set start [expr $center - $np * $delta]
|
||||
set ret [catch {hdbscan $var $start $delta [expr ($np * 2) + 1] $mode $preset} msg]
|
||||
if { $ret != 0} {
|
||||
error $msg
|
||||
} else {
|
||||
return $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
|
||||
}
|
||||
#--------- 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
|
||||
append scanvars $var ","
|
||||
append scanstarts $start ","
|
||||
set step [expr double($end - $start)/double($np-1)]
|
||||
append scansteps $step ","
|
||||
}
|
||||
#------------- set lastcommand text
|
||||
set txt [format "sscan %s" [join $args]]
|
||||
catch {lastscancommand $txt}
|
||||
#------------- start scan
|
||||
set scanvars [string trim $scanvars ,]
|
||||
set scanstarts [string trim $scanstarts ,]
|
||||
set scansteps [string trim $scansteps ,]
|
||||
set mode [string trim [SplitReply [scan mode]]]
|
||||
set ret [catch {hdbscan $scanvars $scanstarts $scansteps $np $mode $preset} msg]
|
||||
if {$ret != 0} {
|
||||
error $msg
|
||||
} else {
|
||||
return $msg
|
||||
}
|
||||
}
|
||||
#------------------------------------------------------------------------------
|
||||
proc splitScanVar {txt} {
|
||||
set l1 [split $txt =]
|
||||
set var [lindex $l1 0]
|
||||
set vl [split $var .]
|
||||
lappend result [lindex $vl 1]
|
||||
lappend result [string trim [lindex $l1 1]]
|
||||
lappend result [string trim [lindex $l1 2]]
|
||||
}
|
||||
#-----------------------------------------------------------------------------
|
||||
proc scaninfo {} {
|
||||
set novar [string trim [SplitReply [xxxscan noscanvar]]]
|
||||
if {$novar == 0} {
|
||||
return "0,1,NONE,0.,0.,default.dat"
|
||||
}
|
||||
append result "scaninfo = "
|
||||
append result [string trim [SplitReply [xxxscan np]]] "," $novar
|
||||
for {set i 0} {$i < $novar} {incr i} {
|
||||
set vl [splitScanVar [xxxscan getvarpar $i]]
|
||||
append result ", " [lindex $vl 0]
|
||||
}
|
||||
set vl [splitScanVar [xxxscan getvarpar 0]]
|
||||
append result "," [lindex $vl 1]
|
||||
append result "," [lindex $vl 2]
|
||||
append result "," [SplitReply [xxxscan getfile]]
|
||||
append result "," [SplitReply [sample]]
|
||||
append result "," [sicstime]
|
||||
append result "," [SplitReply [lastscancommand]]
|
||||
return $result
|
||||
}
|
||||
#-------------------------------------------------------------
|
||||
proc scan args {
|
||||
if {[llength $args] < 1} {
|
||||
error "Need keyword for scan"
|
||||
}
|
||||
set key [string trim [lindex $args 0]]
|
||||
switch $key {
|
||||
uuinterest { return [xxxscan uuinterest] }
|
||||
pinterest {}
|
||||
getcounts { set cts [SplitReply [xxxscan getcounts]]
|
||||
return "scan.Counts = $cts"
|
||||
}
|
||||
mode {
|
||||
if {[llength $args] > 1} {
|
||||
return [counter mode [lindex $args 1]]
|
||||
} else {
|
||||
return [counter mode]
|
||||
}
|
||||
}
|
||||
clear {
|
||||
return [xxxscan clear]
|
||||
}
|
||||
default {
|
||||
error "scan does not support keyword $key"
|
||||
}
|
||||
}
|
||||
}
|
||||
#-------------------------------------------------------------
|
||||
proc makestddrive {path} {
|
||||
hfactory $path command drive
|
||||
hsetprop $path type command
|
||||
hsetprop $path viewer mountaingumui.DriveEditor
|
||||
hsetprop $path priv user
|
||||
hfactory $path/motor plain user text
|
||||
hsetprop $path/motor argtype drivable
|
||||
hfactory $path/value plain user float
|
||||
}
|
||||
Reference in New Issue
Block a user