PSI sics-cvs-psi-2008-10-02
This commit is contained in:
Douglas Clowes
274
tcl/analyzedevexeclog
Executable file
274
tcl/analyzedevexeclog
Executable file
@@ -0,0 +1,274 @@
|
||||
#!/usr/bin/tclsh
|
||||
#-----------------------------------------------------------------------------
|
||||
# This program analyses a devexec log as written by SICS. It should produce
|
||||
# a list of devices together with the time each device was active
|
||||
# in seconds.
|
||||
#
|
||||
# Mark Koennecke, January 2007
|
||||
#----------------------------------------------------------------------------
|
||||
# Some utility routines for processing an entry in the devexeclog. A line
|
||||
# has the form:
|
||||
# DEVEXEC:OP:DEVICE:SECONDS:NANOSECONDS
|
||||
# This is split into a list and accessor function are provided for various
|
||||
# items
|
||||
#---------------------------------------------------------------------------
|
||||
proc parseLogLine {line} {
|
||||
set l [split $line :]
|
||||
set tst [lindex $l 0]
|
||||
if {[string compare $tst DEVEXEC] != 0} {
|
||||
error "Bad log line: $line"
|
||||
}
|
||||
return [lrange $l 1 end]
|
||||
}
|
||||
#--------------------------------------------------------------------------
|
||||
proc getLogOp {logList} {
|
||||
return [lindex $logList 0]
|
||||
}
|
||||
#--------------------------------------------------------------------------
|
||||
proc getLogDevice {logList} {
|
||||
return [lindex $logList 1]
|
||||
}
|
||||
#--------------------------------------------------------------------------
|
||||
proc getLogSeconds {logList} {
|
||||
return [lindex $logList 2]
|
||||
}
|
||||
#--------------------------------------------------------------------------
|
||||
proc getLogNanos {logList} {
|
||||
return [lindex $logList 3]
|
||||
}
|
||||
#-------------------------------------------------------------------------
|
||||
proc getStamp {logList} {
|
||||
return [lrange $logList 2 end]
|
||||
}
|
||||
#==========================================================================
|
||||
proc calcTimeDiff {sec1 nano1 sec2 nano2} {
|
||||
set secSum 0
|
||||
set nanoSum 0
|
||||
if {$sec2 > $sec1} {
|
||||
set nanoSum [expr 1000000 - $nano1]
|
||||
set secSum [expr $sec2 - $sec1 + 1]
|
||||
set nanoSum [expr $nanoSum + $nano2]
|
||||
} elseif {$sec2 == $sec1} {
|
||||
set secSum 0
|
||||
set nanoSum [expr $nano2 - $nano1]
|
||||
} else {
|
||||
error "Bad time order: sec2 should be bigger then sec1"
|
||||
}
|
||||
return [list $secSum $nanoSum]
|
||||
}
|
||||
#=========================================================================
|
||||
# There are two arrays:
|
||||
# One is called devices and holds the device name and the total number
|
||||
# of seconds this device has run. There are special devices:
|
||||
# - nobeam for couting NOBEAM time. This has later to be subtracted from
|
||||
# counting times.
|
||||
# - unallocated time which can not be clearly given to some device
|
||||
# This might happen if the SICServer restarts whilst something is
|
||||
# running.
|
||||
#
|
||||
# The other one is running and holds all the devices which are currently
|
||||
# being run. For each such device a list will be held with seconds
|
||||
# and nanos. At each Start and stop, time differences to the previous
|
||||
# event will be calculated and added to the devices running. If more then
|
||||
# one device is running at a given time, the time will be distributed
|
||||
# equally to all devices.
|
||||
#
|
||||
# There is also a counter for devices which are currently running.
|
||||
#
|
||||
# This section now provides helper functions for dealing with these
|
||||
# arrays
|
||||
#========================================================================
|
||||
set devRun 0
|
||||
set devices(nobeam) 0
|
||||
set devices(unaccounted) 0
|
||||
set sicsRestart 0
|
||||
#------------------------------------------------------------------------
|
||||
proc addToDevice {dev sec nano} {
|
||||
upvar #0 devices devices
|
||||
set totalSec [expr double($sec) + double($nano)/1000000.0]
|
||||
if {[info exists devices($dev)] } {
|
||||
set devices($dev) [expr $devices($dev) + $totalSec]
|
||||
} else {
|
||||
set devices($dev) $totalSec
|
||||
}
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
proc addToRunning {dev sec nano} {
|
||||
upvar #0 running running devRun devRun
|
||||
if {[info exists running($dev)] } {
|
||||
set l $running($dev)
|
||||
set newSec [expr double([lindex $l 0]) + double($sec)]
|
||||
set newNano [expr double([lindex $l 1]) + double($nano)]
|
||||
set running($dev) [list $newSec $newNano]
|
||||
} else {
|
||||
set running($dev) [list $sec $nano]
|
||||
incr devRun
|
||||
}
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
proc stopRunning {dev} {
|
||||
upvar #0 running running devRun devRun devices devices
|
||||
set l $running($dev)
|
||||
addToDevice $dev [lindex $l 0] [lindex $l 1]
|
||||
incr devRun -1
|
||||
unset running($dev)
|
||||
}
|
||||
#-----------------------------------------------------------------------
|
||||
proc isDevRunning {dev} {
|
||||
upvar #0 running running
|
||||
return [info exists running($dev)]
|
||||
}
|
||||
#------------------------------------------------------------------------
|
||||
proc cancelAll {} {
|
||||
upvar #0 running running devRun devRun devices devices
|
||||
upvar #0 sicsRestart sicsRestart
|
||||
if {$devRun > 0} {
|
||||
incr sicsRestart
|
||||
}
|
||||
set runlist [array names running]
|
||||
foreach dev $runlist {
|
||||
puts stdout "Live restart on device $dev"
|
||||
set l $running($dev)
|
||||
addToDevice unaccounted [lindex $l 0] [lindex $l 1]
|
||||
unset running($dev)
|
||||
}
|
||||
set devRun 0
|
||||
}
|
||||
#---------------------------------------------------------------------
|
||||
proc addRunDiff {dev stamp lastStamp} {
|
||||
upvar #0 running running devRun devRun
|
||||
|
||||
set diff [calcTimeDiff [lindex $lastStamp 0] \
|
||||
[lindex $lastStamp 1] \
|
||||
[lindex $stamp 0]\
|
||||
[lindex $stamp 1]]
|
||||
if {![info exists running($dev)] } {
|
||||
addToRunning $dev 0 0
|
||||
}
|
||||
set disSec [expr double([lindex $diff 0])/double($devRun)]
|
||||
set disNano [expr double([lindex $diff 1])/double($devRun)]
|
||||
set devlist [array names running]
|
||||
foreach d $devlist {
|
||||
addToRunning $d $disSec $disNano
|
||||
}
|
||||
}
|
||||
#---------------------------------------------------------------------
|
||||
proc clearAll {} {
|
||||
upvar #0 devRun devRun __lastStamp lastStamp __nobeamStamp nobeamStamp
|
||||
upvar #0 devices devices running running sicsRestart sicsRestart
|
||||
set devRun 0
|
||||
catch {unset lastStamp}
|
||||
catch {unset nobeamStamp}
|
||||
set l [array names devices]
|
||||
foreach d $l {
|
||||
unset devices($d)
|
||||
}
|
||||
set l [array names running]
|
||||
foreach d $l {
|
||||
unset running($d)
|
||||
}
|
||||
set devices(nobeam) 0
|
||||
set devices(unaccounted) 0
|
||||
set sicsRestart 0
|
||||
}
|
||||
#=======================================================================
|
||||
# This section contains the code with the main interpretation and
|
||||
# analysis
|
||||
#=======================================================================
|
||||
proc analyzeLine {line after} {
|
||||
upvar #0 devRun devRun __lastStamp lastStamp __nobeamStamp nobeamStamp
|
||||
set log [parseLogLine $line]
|
||||
set afterSec [clock scan $after]
|
||||
set op [getLogOp $log]
|
||||
set t [getLogSeconds $log]
|
||||
if {$t < $afterSec} {
|
||||
return
|
||||
}
|
||||
switch $op {
|
||||
START {
|
||||
set dev [getLogDevice $log]
|
||||
if {[string compare $dev SICS] == 0} {
|
||||
cancelAll
|
||||
return
|
||||
}
|
||||
if {$devRun > 0} {
|
||||
set stamp [getStamp $log]
|
||||
addRunDiff $dev $stamp $lastStamp
|
||||
set lastStamp $stamp
|
||||
} else {
|
||||
if {![isDevRunning $dev] } {
|
||||
addToRunning $dev 0 0
|
||||
set lastStamp [getStamp $log]
|
||||
}
|
||||
}
|
||||
}
|
||||
STOP {
|
||||
if {![info exists lastStamp]} {
|
||||
return
|
||||
}
|
||||
set dev [getLogDevice $log]
|
||||
if {[string compare $dev SICS] == 0} {
|
||||
cancelAll
|
||||
return
|
||||
}
|
||||
set stamp [getStamp $log]
|
||||
addRunDiff $dev $stamp $lastStamp
|
||||
if {[isDevRunning $dev] } {
|
||||
stopRunning $dev
|
||||
}
|
||||
if {$devRun == 0} {
|
||||
unset lastStamp
|
||||
}
|
||||
}
|
||||
NOBEAM {
|
||||
set nobeamStamp [getStamp $log]
|
||||
}
|
||||
CONTINUE {
|
||||
set stamp [getStamp $log]
|
||||
set diff [calcTimeDiff [lindex $nobeamStamp 0] \
|
||||
[lindex $nobeamStamp 1] \
|
||||
[lindex $stamp 0]\
|
||||
[lindex $stamp 1]]
|
||||
addToDevice nobeam [lindex $diff 0] [lindex $diff 1]
|
||||
unset nobeamStamp
|
||||
}
|
||||
}
|
||||
}
|
||||
#==========================================================================
|
||||
proc printResult {} {
|
||||
upvar #0 devices devices sicsRestart sicsRestart
|
||||
set l [array names devices]
|
||||
puts stdout "DEVICE SECONDS"
|
||||
foreach dev $l {
|
||||
puts stdout [format "%-20s %12.2f" $dev $devices($dev)]
|
||||
}
|
||||
puts stdout [format "%-20s %12.2f" "Live Restarts" $sicsRestart]
|
||||
}
|
||||
#=========================================================================
|
||||
proc analyzeFile {filename after} {
|
||||
set f [open $filename r]
|
||||
while {[gets $f line] >= 0} {
|
||||
set status [catch {analyzeLine $line $after} msg]
|
||||
if {$status != 0} {
|
||||
puts stdout "ERROR: error $msg processing $line"
|
||||
}
|
||||
}
|
||||
close $f
|
||||
}
|
||||
#=============== MAIN Program ===========================================
|
||||
proc main {} {
|
||||
global argv
|
||||
if {[llength $argv] < 2} {
|
||||
puts stdout "Usage:\n\tanalysedevexeclog filename after"
|
||||
puts stdout "\t with after being a date in format MM/DD/YYYY"
|
||||
exit 1
|
||||
}
|
||||
|
||||
analyzeFile [lindex $argv 0] [lindex $argv 1]
|
||||
|
||||
printResult
|
||||
}
|
||||
|
||||
main
|
||||
exit 0
|
||||
|
||||
80
tcl/gumxml.tcl
Normal file
80
tcl/gumxml.tcl
Normal file
@@ -0,0 +1,80 @@
|
||||
proc getdataType {path} {
|
||||
return [lindex [split [hinfo $path] ,] 0]
|
||||
}
|
||||
|
||||
|
||||
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 "$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 {
|
||||
# set result [make_nodes $path $result 2]
|
||||
foreach n [hlist $path] {
|
||||
set result [make_nodes $path/$n $result 2]
|
||||
}
|
||||
}
|
||||
|
||||
append result "</hipadaba:SICS>\n"
|
||||
}
|
||||
|
||||
if {[info exists guminit] == 0} {
|
||||
set guminit 1
|
||||
Publish getgumtreexml Spy
|
||||
}
|
||||
690
tcl/hdbutil.tcl
Normal file
690
tcl/hdbutil.tcl
Normal file
@@ -0,0 +1,690 @@
|
||||
#-----------------------------------------------------------------------
|
||||
# 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
|
||||
#----------------------------------------------------------------------
|
||||
if { [info exists hdbinit] == 0 } {
|
||||
set hdbinit 1
|
||||
InstallHdb
|
||||
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 hmake Mugger
|
||||
# Publish hmakescript Mugger
|
||||
# Publish hlink Mugger
|
||||
# Publish hcommand Mugger
|
||||
}
|
||||
#===================================================================
|
||||
# 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
|
||||
#===================== 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 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 "$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 {
|
||||
# set result [make_nodes $path $result 2]
|
||||
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 ,]
|
||||
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
|
||||
hupdate $stdscangraph/dim
|
||||
}
|
||||
#------------------------------------------------------------------------------
|
||||
proc hdbcollect {obj userobj np} {
|
||||
global stdscangraph
|
||||
stdscan collect $obj $userobj $np
|
||||
hupdate $stdscangraph/scan_variable
|
||||
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 {} {
|
||||
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/starttime plain spy text
|
||||
hfactory $path/getdata/endtime 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
|
||||
hattach /instrument/experiment/user adress address
|
||||
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" \
|
||||
"exe batchpath" text
|
||||
hsetprop /instrument/experiment/batchpath priv user
|
||||
}
|
||||
#----------------------------------------------------------
|
||||
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
|
||||
hupdate /instrument/commands/batch/execute/file/values
|
||||
}
|
||||
#------------------------------------------------------------------
|
||||
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
|
||||
}
|
||||
177
tcl/makemodrivskel
Executable file
177
tcl/makemodrivskel
Executable file
@@ -0,0 +1,177 @@
|
||||
#!/usr/bin/tclsh
|
||||
#------------------------------------------------------------------------------
|
||||
# Make the skeleton for a motor driver
|
||||
#
|
||||
# copyright: see file COPYRIGHT
|
||||
#
|
||||
# Mark Koennecke, July 2006
|
||||
#------------------------------------------------------------------------------
|
||||
if { [llength $argv] < 1} {
|
||||
puts stdout "Usage:\n\tmakemodrivskel prefix"
|
||||
exit 1
|
||||
}
|
||||
|
||||
set prefix [lindex $argv 0]
|
||||
#-----------------------------------------------------------------------------
|
||||
proc stdCast {} {
|
||||
global prefix
|
||||
puts stdout " ${prefix}MotorDriver *self = NULL;"
|
||||
puts stdout " "
|
||||
puts stdout " self = (${prefix}MotorDriver *)data;"
|
||||
}
|
||||
|
||||
#----------------- output datastructure
|
||||
puts stdout "#include <stdlib.h>"
|
||||
puts stdout "#include <sics.h>"
|
||||
puts stdout "#include <modriv.h>"
|
||||
puts stdout "typedef struct __${prefix}MoDriv{"
|
||||
puts stdout " /* general motor driver interface "
|
||||
puts stdout " fields. REQUIRED!"
|
||||
puts stdout " */"
|
||||
puts stdout " float fUpper; /* upper limit */"
|
||||
puts stdout " float fLower; /* lower limit */"
|
||||
puts stdout " char *name;"
|
||||
puts stdout " int (*GetPosition)(void *self, float *fPos);"
|
||||
puts stdout " int (*RunTo)(void *self,float fNewVal);"
|
||||
puts stdout " int (*GetStatus)(void *self);"
|
||||
puts stdout " void (*GetError)(void *self, int *iCode, char *buffer, int iBufLen);"
|
||||
puts stdout " int (*TryAndFixIt)(void *self, int iError,float fNew);"
|
||||
puts stdout " int (*Halt)(void *self);"
|
||||
puts stdout " int (*GetDriverPar)(void *self, char *name, "
|
||||
puts stdout " float *value);"
|
||||
puts stdout " int (*SetDriverPar)(void *self,SConnection *pCon,"
|
||||
puts stdout " char *name, float newValue);"
|
||||
puts stdout " void (*ListDriverPar)(void *self, char *motorName,"
|
||||
puts stdout " SConnection *pCon);"
|
||||
puts stdout " void (*KillPrivate)(void *self);"
|
||||
puts stdout " /* your drivers private fields follow below */"
|
||||
puts stdout " } ${prefix}MotorDriver;"
|
||||
puts stdout " "
|
||||
|
||||
|
||||
puts stdout "/*================================================================"
|
||||
puts stdout " GetPos returns OKOK on success, HWFault on failure "
|
||||
puts stdout "------------------------------------------------------------------*/"
|
||||
puts stdout "static int ${prefix}GetPos(void *data, float *fPos){"
|
||||
stdCast
|
||||
puts stdout " return OKOK;"
|
||||
puts stdout "}"
|
||||
|
||||
puts stdout "/*----------------------------------------------------------------"
|
||||
puts stdout " RunTo starts the motor running. Returns OKOK on success, HWfault"
|
||||
puts stdout " on Errors"
|
||||
puts stdout "------------------------------------------------------------------*/"
|
||||
puts stdout "static int ${prefix}RunTo(void *data, float newValue){"
|
||||
stdCast
|
||||
puts stdout " return OKOK;"
|
||||
puts stdout "}"
|
||||
|
||||
puts stdout "/*-----------------------------------------------------------------"
|
||||
puts stdout " CheckStatus queries the sattus of a running motor. Possible return"
|
||||
puts stdout " values can be:"
|
||||
puts stdout " HWBusy : motor still running"
|
||||
puts stdout " HWFault : motor error detected"
|
||||
puts stdout " HWPosFault : motor finished, but position not reached"
|
||||
puts stdout " HWIdle : motor finished OK"
|
||||
puts stdout " HWWarn : motor issued warning"
|
||||
puts stdout "--------------------------------------------------------------------*/"
|
||||
puts stdout "static int ${prefix}CheckStatus(void *data){"
|
||||
stdCast
|
||||
puts stdout " return HWIdle;"
|
||||
puts stdout "}"
|
||||
|
||||
puts stdout "/*------------------------------------------------------------------"
|
||||
puts stdout " GetError gets more information about error which occurred"
|
||||
puts stdout " *iCode is an integer error code to be used in TryFixIt as indicator"
|
||||
puts stdout " buffer is a buffer for a text description of the problem"
|
||||
puts stdout " iBufLen is the length of buffer"
|
||||
puts stdout "--------------------------------------------------------------------*/"
|
||||
puts stdout "static void ${prefix}GetError(void *data, int *iCode, char *buffer,"
|
||||
puts stdout " int iBufLen){"
|
||||
stdCast
|
||||
puts stdout "}"
|
||||
|
||||
puts stdout "/*------------------------------------------------------------------"
|
||||
puts stdout " TryAndFixIt tries everything which is possible in software to fix "
|
||||
puts stdout " a problem. iError is the error code from GetError, newValue is "
|
||||
puts stdout " the target value for the motor"
|
||||
puts stdout " Possible retrun values are:"
|
||||
puts stdout " MOTOK : everything fixed"
|
||||
puts stdout " MOTREDO : try again "
|
||||
puts stdout " MOTFAIL : cannot fix this"
|
||||
puts stdout "--------------------------------------------------------------------*/"
|
||||
puts stdout "static int ${prefix}FixIt(void *data, int iError, float newValue){"
|
||||
stdCast
|
||||
puts stdout " return MOTFAIL;"
|
||||
puts stdout "}"
|
||||
|
||||
puts stdout "/*-------------------------------------------------------------------"
|
||||
puts stdout " Halt tries to stop the motor. Halt errors are ignored"
|
||||
puts stdout "---------------------------------------------------------------------*/"
|
||||
puts stdout "static int ${prefix}Halt(void *data){"
|
||||
stdCast
|
||||
puts stdout " return 1;"
|
||||
puts stdout "}"
|
||||
|
||||
puts stdout "/*--------------------------------------------------------------------"
|
||||
puts stdout " GetDriverPar retrieves the value of a driver parameter."
|
||||
puts stdout " Name is the name of the parameter, fValue the value when found."
|
||||
puts stdout " Returns 0 on success, 0 else"
|
||||
puts stdout "-----------------------------------------------------------------------*/"
|
||||
puts stdout "static int ${prefix}GetDriverPar(void *data, char *name, float *value){"
|
||||
stdCast
|
||||
puts stdout " return 0;"
|
||||
puts stdout "}"
|
||||
|
||||
puts stdout "/*----------------------------------------------------------------------"
|
||||
puts stdout " SetDriverPar sets a driver parameter. Returns 0 on failure, 1 on "
|
||||
puts stdout " success. Name is the parameter name, pCon the connection to report"
|
||||
puts stdout " errors too, value the new value"
|
||||
puts stdout "------------------------------------------------------------------------*/"
|
||||
puts stdout "static int ${prefix}SetDriverPar(void *data, SConnection *pCon,"
|
||||
puts stdout " char *name, float value){"
|
||||
stdCast
|
||||
puts stdout " return 0;"
|
||||
puts stdout "}"
|
||||
|
||||
puts stdout "/*-----------------------------------------------------------------------"
|
||||
puts stdout " ListDriverPar lists the names and values of driver parameters to "
|
||||
puts stdout " pCon. Motorname is the name of the motor ro prefix to the listing."
|
||||
puts stdout "-------------------------------------------------------------------------*/"
|
||||
puts stdout "static void ${prefix}ListDriverPar(void *data, char *motorname, "
|
||||
puts stdout " SConnection *pCon){"
|
||||
stdCast
|
||||
puts stdout "}"
|
||||
|
||||
puts stdout "/*-----------------------------------------------------------------------"
|
||||
puts stdout " KillPrivate has the task to delete possibly dynamically allocated "
|
||||
puts stdout " memory in the private part of the driver structure"
|
||||
puts stdout "------------------------------------------------------------------------*/"
|
||||
puts stdout "static void ${prefix}KillPrivate(void *data){"
|
||||
stdCast
|
||||
puts stdout "}"
|
||||
|
||||
puts stdout "/*=======================================================================*/"
|
||||
puts stdout "MotorDriver *${prefix}MakeMotorDriver(void) {"
|
||||
puts stdout " ${prefix}MotorDriver *pNew = NULL;"
|
||||
puts stdout ""
|
||||
puts stdout " pNew = malloc(sizeof(${prefix}MotorDriver));"
|
||||
puts stdout " if(pNew == NULL){"
|
||||
puts stdout " return NULL;"
|
||||
puts stdout " }"
|
||||
puts stdout " memset(pNew,0,sizeof(${prefix}MotorDriver));"
|
||||
puts stdout " "
|
||||
puts stdout " pNew->GetPosition = ${prefix}GetPos;"
|
||||
puts stdout " pNew->RunTo = ${prefix}RunTo;"
|
||||
puts stdout " pNew->Halt = ${prefix}Halt;"
|
||||
puts stdout " pNew->GetStatus = ${prefix}CheckStatus;"
|
||||
puts stdout " pNew->GetError = ${prefix}GetError;"
|
||||
puts stdout " pNew->TryAndFixIt = ${prefix}FixIt;"
|
||||
puts stdout " pNew->GetDriverPar = ${prefix}GetDriverPar;"
|
||||
puts stdout " pNew->SetDriverPar = ${prefix}SetDriverPar;"
|
||||
puts stdout " pNew->ListDriverPar = ${prefix}ListDriverPar;"
|
||||
puts stdout " pNew->KillPrivate = ${prefix}KillPrivate;"
|
||||
puts stdout " "
|
||||
puts stdout " return (MotorDriver *)pNew;"
|
||||
puts stdout "}"
|
||||
puts stdout ""
|
||||
51
tcl/ritaframe
Executable file
51
tcl/ritaframe
Executable file
@@ -0,0 +1,51 @@
|
||||
#!/usr/bin/tclsh
|
||||
#--------------------------------------------------------------------------
|
||||
# script for extracting a frame of rita data from a file and to dump
|
||||
# the frame into an ASCII file
|
||||
#
|
||||
# Mark Koennecke, November 2006
|
||||
#-------------------------------------------------------------------------
|
||||
set loadnx "/afs/psi.ch/project/sinq/sl-linux/lib/"
|
||||
load [file join $loadnx nxinter.so]
|
||||
|
||||
if {$argc < 2} {
|
||||
puts stdout "Usage:\n\tritaframe filename number"
|
||||
exit 1
|
||||
}
|
||||
set num [lindex $argv 1]
|
||||
|
||||
set f [nx_open [lindex $argv 0] $NXACC_READ]
|
||||
nx_openpath $f /entry1/data/counts
|
||||
set info [nx_getinfo $f]
|
||||
set dim1 [expr int([get_nxds_value $info 2])]
|
||||
set dim2 [expr int([get_nxds_value $info 3])]
|
||||
set nFrames [expr int([get_nxds_value $info 4])]
|
||||
if {$num < 0 || $num > $nFrames-1} {
|
||||
nx_close $f
|
||||
puts stdout "Requested frame out of range"
|
||||
exit1
|
||||
}
|
||||
set start [create_nxds 1 $NX_INT32 3]
|
||||
set end [create_nxds 1 $NX_INT32 3]
|
||||
put_nxds_value $start 0 0
|
||||
put_nxds_value $start 0 1
|
||||
put_nxds_value $start $num 2
|
||||
|
||||
put_nxds_value $end $dim1 0
|
||||
put_nxds_value $end $dim2 1
|
||||
put_nxds_value $end 1 2
|
||||
|
||||
set data [nx_getslab $f $start $end]
|
||||
for {set y 0} {$y < $dim2} {incr y} {
|
||||
for {set x 0} {$x < $dim1} {incr x} {
|
||||
set val [expr int([get_nxds_value $data $x $y])]
|
||||
puts -nonewline stdout [format " %8d" $val]
|
||||
}
|
||||
puts stdout ""
|
||||
}
|
||||
drop_nxds $start
|
||||
drop_nxds $end
|
||||
drop_nxds $data
|
||||
|
||||
nx_close $f
|
||||
exit 0
|
||||
@@ -7,20 +7,50 @@
|
||||
# Thus is should be possible to debug SICS Tcl scripts in a normal
|
||||
# standalone interpreter without the overhead of restarting SICS
|
||||
# all the time. It may even be possible to use one of the normal
|
||||
# Tcl debugfgers then....
|
||||
# Tcl debuggers then....
|
||||
#
|
||||
# Mark Koennecke, February 2006
|
||||
#
|
||||
# Revamped for use in testing SICS instruments.
|
||||
# Mark Koennecke, November 2006
|
||||
#------------------------------------------------------------------
|
||||
|
||||
set socke [socket localhost 2911]
|
||||
gets $socke
|
||||
puts $socke "Spy 007"
|
||||
flush $socke
|
||||
gets $socke
|
||||
set host(amor) amor.psi.ch
|
||||
set host(dmc) dmc.psi.ch
|
||||
set host(focus) focus.psi.ch
|
||||
set host(hrpt) hrpt.psi.ch
|
||||
set host(mars) mars.psi.ch
|
||||
set host(morpheus) morpheus.psi.ch
|
||||
set host(narziss) narziss.psi.ch
|
||||
set host(poldi) poldi.psi.ch
|
||||
set host(rita2) rita2.psi.ch
|
||||
set host(sans) sans.psi.ch
|
||||
set host(sansli) sans2.psi.ch
|
||||
set host(tasp) tasp.psi.ch
|
||||
set host(trics) trics.psi.ch
|
||||
set host(local) localhost
|
||||
|
||||
#-------------------------------------------------------------------
|
||||
# initialize the socket before debugging. If local == 1, then a
|
||||
# connection to localhost is built
|
||||
#------------------------------------------------------------------
|
||||
proc unknown args {
|
||||
global socke
|
||||
append com "transact " [join $args]
|
||||
proc initSicsDebug {instrument} {
|
||||
global socke host
|
||||
catch {close $socke}
|
||||
set status [catch {set compi $host($instrument)} msg]
|
||||
if {$status != 0} {
|
||||
error "Host for $instrument not found"
|
||||
}
|
||||
set socke [socket $compi 2911]
|
||||
gets $socke
|
||||
puts $socke "Spy 007"
|
||||
flush $socke
|
||||
gets $socke
|
||||
}
|
||||
#----------------------------------------------------------------
|
||||
proc sicscommand args {
|
||||
global socke
|
||||
append com "transact " [join $args]
|
||||
puts stdout "Sending: $com"
|
||||
puts $socke $com
|
||||
flush $socke
|
||||
set reply ""
|
||||
@@ -29,11 +59,16 @@ proc unknown args {
|
||||
if {[string first TRANSACTIONFINISHED $line] >= 0} {
|
||||
return $reply
|
||||
} else {
|
||||
append reply $line
|
||||
append reply $line "\n"
|
||||
}
|
||||
}
|
||||
}
|
||||
#------------------------------------------------------------------
|
||||
proc unknown args {
|
||||
return [sicscommand $args]
|
||||
}
|
||||
#------------------------------------------------------------------
|
||||
proc clientput args {
|
||||
puts stdout [join $args]
|
||||
}
|
||||
#------------------------------------------------------------------
|
||||
|
||||
73
tcl/tjxp
Executable file
73
tcl/tjxp
Executable file
@@ -0,0 +1,73 @@
|
||||
#!/usr/bin/tclsh
|
||||
#----------------------------------------------------------------------
|
||||
# This is a Tcl template processor in the style of JSP tags. Unmarked
|
||||
# text is left alone. But there is special markup:
|
||||
# <% script %> execute Tcl script and output result
|
||||
# <%=var%> print The Tcl variable var
|
||||
# <%! script%> execute the script and print nothing
|
||||
#
|
||||
# copyright: GPL
|
||||
#
|
||||
# Mark Koennecke, November 2006
|
||||
#----------------------------------------------------------------------
|
||||
proc loadTemplate {input} {
|
||||
return [read $input]
|
||||
}
|
||||
#---------------------------------------------------------------------
|
||||
proc processScript {script} {
|
||||
set startChar [string index $script 0]
|
||||
if {[string equal $startChar =] == 1 } {
|
||||
set varName [string trim [string range $script 1 end]]
|
||||
set cmd [format "return \$%s" $varName]
|
||||
return [uplevel #0 $cmd]
|
||||
} elseif {[string equal $startChar !] == 1} {
|
||||
set script [string range $script 1 end]
|
||||
uplevel #0 $script
|
||||
} else {
|
||||
return [uplevel #0 $script]
|
||||
}
|
||||
return ""
|
||||
}
|
||||
#----------------------------------------------------------------------
|
||||
# process The template: read template from input,
|
||||
# write to output channel
|
||||
#----------------------------------------------------------------------
|
||||
proc processTemplate {input output} {
|
||||
set template [loadTemplate $input]
|
||||
set current 0
|
||||
set start [string first "<%" $template]
|
||||
set end [string first "%>" $template $start]
|
||||
while {$start >= 0} {
|
||||
if {$end < 0} {
|
||||
error "Found start tag but no end in $template"
|
||||
}
|
||||
puts -nonewline $output [string range $template $current \
|
||||
[expr $start -1]]
|
||||
set script [string range $template [expr $start +2] \
|
||||
[expr $end -1]]
|
||||
set txt [processScript $script]
|
||||
if {[string length $txt] >= 1} {
|
||||
puts -nonewline $output $txt
|
||||
}
|
||||
set template [string range $template [expr $end +2] end]
|
||||
set start [string first "<%" $template]
|
||||
set end [string first "%>" $template $start]
|
||||
|
||||
}
|
||||
puts -nonewline $output $template
|
||||
}
|
||||
#================ MAIN ================================================
|
||||
if {$argc < 2} {
|
||||
puts stdout "Usage:\n\ttjxp infile outfile"
|
||||
puts stdout "\t Outfile can be - for stdout"
|
||||
exit 1
|
||||
}
|
||||
set in [open [lindex $argv 0] r]
|
||||
set outfile [lindex $argv 1]
|
||||
if {[string equal [string trim $outfile] -] == 1} {
|
||||
set out stdout
|
||||
} else {
|
||||
set out [open $outfile w]
|
||||
}
|
||||
processTemplate $in $out
|
||||
exit 0
|
||||
38
tcl/tjxphelp
Normal file
38
tcl/tjxphelp
Normal file
@@ -0,0 +1,38 @@
|
||||
|
||||
|
||||
Tcl Template Processing System.
|
||||
|
||||
This is a test file and help text for my Tcl template processing
|
||||
system. It was inspired by JSP and JXP. But is in my favourite
|
||||
scripting language Tcl. Basically it allows to mix Tcl scripts with
|
||||
text. The text can contain special marks which are then executed as
|
||||
Tcl scripts in a variety of ways. Three tags are supported:
|
||||
|
||||
<%! set var waschmaschine %>
|
||||
|
||||
This tag executes the Tcl script but prints nothing, except may
|
||||
be error messages. Please note that this can be used to source
|
||||
more Tcl files which contains procedures you need for doing your
|
||||
work.
|
||||
|
||||
<%=var %> prints the value of the Tcl variable var. When processed,
|
||||
this should print waschmaschine.
|
||||
|
||||
<% set a [list 1 2 3]
|
||||
join $a
|
||||
%>
|
||||
executes the Tcl code within and prints the result. This should be
|
||||
1 2 3.
|
||||
|
||||
All Tcl code is executed at global level. There is nothing more to
|
||||
this. All this was done in 75 lines of Tcl, including comments! You
|
||||
should be able to process this file through tjxp to see what you get.
|
||||
Txjp is brough to you by:
|
||||
|
||||
Mark Koennecke, Mark.Koennecke@psi.ch
|
||||
|
||||
txjp is copyrighted under the GNU Public Licence 2.0, which you can
|
||||
find elsewhere.
|
||||
|
||||
Enjoy!
|
||||
|
||||
Reference in New Issue
Block a user