472 lines
16 KiB
Tcl
Executable File
472 lines
16 KiB
Tcl
Executable File
#!/usr/bin/tclsh
|
|
|
|
# ca* by Dirk Zimoch
|
|
# $Source: /cvs/G/EPICS/App/scripts/ca,v $
|
|
# $Date: 2017/02/23 08:19:10 $
|
|
|
|
regsub -all {\$} {ca* by Dirk Zimoch
|
|
$Source: /cvs/G/EPICS/App/scripts/ca,v $
|
|
$Revision: 1.36 $
|
|
$Date: 2017/02/23 08:19:10 $} {} version
|
|
|
|
package require Tclx
|
|
package require Epics
|
|
|
|
# possible flags and what they are for
|
|
set possFlags(-date) " add record time stamp date"
|
|
set possFlags(-d) " same as -date"
|
|
set possFlags(-localdate) " add host date"
|
|
set possFlags(-time) " add record time stamp time"
|
|
set possFlags(-timestamp) " add floating point time stamp"
|
|
set possFlags(-tfmt) "<format> add user formatted time stamp"
|
|
set possFlags(-ltfmt) "<format> add user formatted host time"
|
|
set possFlags(-t) " same as -time"
|
|
set possFlags(-localtime) " add host time"
|
|
set possFlags(-noname) " don't add channel name"
|
|
set possFlags(-nounit) " don't add units"
|
|
set possFlags(-stat) " always add severity and status"
|
|
set possFlags(-nostat) " never add severity and status"
|
|
set possFlags(-hex) " show integer values as hex"
|
|
set possFlags(-int) " show numeric values instead of strings"
|
|
set possFlags(-prec) "<digits> override the PREC field"
|
|
set possFlags(-plain) " don't do any formatting"
|
|
set possFlags(-timeout) "<sec> timeout cawait after <sec> seconds"
|
|
set possFlags(-num) " show enums as numeric values"
|
|
set possFlags(-n) "<num> exit after <num> updates (for camon)"
|
|
set possFlags(-version) " print version and exit"
|
|
set possFlags(-help) " print this help text and exit"
|
|
set possFlags(-period) "<sec> execute periodically (in particular caget)"
|
|
set possFlags(-sep) " <string> print separator (with -period)"
|
|
|
|
proc printHelp {} {
|
|
global possFlags
|
|
puts {usage: caget [flags] <channel> [<channel> ...]}
|
|
puts { cagets [flags] <channel> [<channel> ...]}
|
|
puts { caput [flags] <channel> <value> [<channel> <value> ...]}
|
|
puts { caputq [flags] <channel> <value> [<channel> <value> ...]}
|
|
puts { cainfo [flags] <channel> [<channel> ...]}
|
|
puts { camon [flags] <channel> [<channel> ...]}
|
|
puts { cado [flags] <channel> [<channel> ...]}
|
|
puts { cawait [flags] <channel> '<condition>' [<channel> '<condition>'...]}
|
|
puts {caget reads and formats values from channels (arrays too)}
|
|
puts {cagets writes 1 to .PROC and reads after processing has finished}
|
|
puts {caput writes, waits until processing finishes and reads back}
|
|
puts {caputq writes but does not wait for processing}
|
|
puts {cainfo reads additional information}
|
|
puts {camon starts monitors (terminate with CTRL-C, or use -n <num>)}
|
|
puts {cado writes 1 but does not wait for processing}
|
|
puts {cawait waits until any condition ('>4.3', '!3...5', etc) matches}
|
|
puts {accepted flags:}
|
|
foreach {f} [lsort [array names possFlags]] {
|
|
puts "$f $possFlags($f)"
|
|
}
|
|
}
|
|
proc check_n {i} {
|
|
#is i an integer?
|
|
#incr n to compensate for connect that is counted , too
|
|
global n
|
|
set n $i
|
|
if {[catch {incr n}]} {puts stderr "-n flag expects an integer"; set n 1}
|
|
}
|
|
proc check_flag {f} {
|
|
global flags possFlags
|
|
if {[clength [array names possFlags -exact $f]] > 0} {
|
|
lappend flags $f
|
|
} else {puts stderr "not valid flag: $f"}
|
|
}
|
|
|
|
if {![regexp {gets|get|putq|put|info|mon|do|wait} [file tail $argv0] command]} {
|
|
if [regexp {gets|get|putq|put|info|mon|do|wait} [lindex $argv 0] command] {
|
|
set argv [lrange $argv 1 end]
|
|
} else {
|
|
printHelp
|
|
exit 1
|
|
}
|
|
}
|
|
|
|
set flags {}
|
|
set n 0
|
|
while {[string match "-*" [set flag [lindex $argv 0]]]} {
|
|
switch -regexp -- $flag {
|
|
{^-(\?)|(h(elp)?)$} { printHelp; exit}
|
|
{^-(v(er(sion)?)?)$} { puts $version; exit }
|
|
{^-timeout} { set timeout [lindex $argv 1]
|
|
set argv [lrange $argv 2 end] }
|
|
{^-prec} { set prec [lindex $argv 1]
|
|
set argv [lrange $argv 2 end] }
|
|
{^-n$} { check_n [lindex $argv 1];
|
|
set argv [lrange $argv 2 end] }
|
|
{^-period$} { set period [lindex $argv 1];
|
|
set argv [lrange $argv 2 end] }
|
|
{^-sep$} { set sep [lindex $argv 1];
|
|
set argv [lrange $argv 2 end] }
|
|
{^-tfmt$} { lappend flags $flag;
|
|
set tfmt [lindex $argv 1];
|
|
set argv [lrange $argv 2 end] }
|
|
{^-ltfmt$} { lappend flags $flag;
|
|
set ltfmt [lindex $argv 1];
|
|
set argv [lrange $argv 2 end] }
|
|
default { check_flag $flag
|
|
set argv [lrange $argv 1 end] }
|
|
}
|
|
}
|
|
if {[llength $argv] == 0} { printHelp; exit 1 }
|
|
|
|
proc bgerror {msg} {
|
|
global errorInfo
|
|
puts stderr $errorInfo
|
|
}
|
|
|
|
proc formatval {channel {value {}} {sevr {}} {stat {}} {time {}}} {
|
|
global info flags prec tfmt ltfmt
|
|
set EGU ""
|
|
foreach {attr val} $info($channel) {
|
|
set $attr $val
|
|
}
|
|
if {[lsearch $flags -plain] != -1} {
|
|
set formatted $VAL
|
|
set status ""
|
|
set channel ""
|
|
set EGU ""
|
|
} else {
|
|
if {[info exists PREC] && [info exists prec]} {
|
|
set PREC $prec
|
|
}
|
|
if {$value == {}} {
|
|
set value $VAL
|
|
}
|
|
if {$time == {}} {
|
|
set time $TIME
|
|
}
|
|
if {$sevr == {}} {
|
|
set sevr $SEVR
|
|
}
|
|
if {$stat == {}} {
|
|
set stat $STAT
|
|
}
|
|
if {$TYPE == "DBF_STRING" && [string length $value] == 39} {
|
|
# long string: try to re-read as array of char
|
|
set field [file extension $channel]
|
|
if {$field != "" && $field != ".VAL"} {
|
|
catch {
|
|
set value [pvget $channel$]
|
|
set TYPE "DBF_CHAR"
|
|
set SIZE [llength $value]
|
|
}
|
|
}
|
|
}
|
|
catch {
|
|
set null 0
|
|
if {$TYPE == "DBF_CHAR" && $SIZE > 1 \
|
|
&& [lsearch $flags "-num"] == -1 \
|
|
&& [lsearch $flags "-int"] == -1 \
|
|
&& [lsearch $flags "-hex"] == -1} {
|
|
foreach char $value {
|
|
if {$null && $char != 0} {
|
|
error "Not printable"
|
|
}
|
|
if {($char & 0x7f) >= 0x20 || $char == 0x0a || $char == 0x0d && $char != 0x7f} {
|
|
append s [format "%c" $char]
|
|
} elseif {$char == 0} {
|
|
set null 1
|
|
} else {
|
|
error "Not prinable"
|
|
}
|
|
}
|
|
set SIZE 1
|
|
set TYPE DBF_STRING
|
|
set value $s
|
|
}
|
|
}
|
|
if {$SIZE == 1} {
|
|
set value [list $value]
|
|
}
|
|
foreach val $value {
|
|
if [info exists PREC] {
|
|
if [catch { # new Tcl fails on NaN. Suck.
|
|
if {$PREC < 0} {
|
|
set val [format "%.[expr -$PREC]e" $val]
|
|
} else {
|
|
set val [format "%.${PREC}f" $val]
|
|
}
|
|
}] {
|
|
set val "NaN"
|
|
}
|
|
}
|
|
if {$TYPE == "DBF_ENUM" && \
|
|
([lsearch $flags "-int"] != -1 || [lsearch $flags "-num"] != -1 || [lsearch $flags "-hex"] != -1)} {
|
|
set v [lsearch $ENUM $val]
|
|
if {$v != -1} {set val $v}
|
|
set TYPE "DBF_INT"
|
|
}
|
|
if {$TYPE == "DBF_STRING" || $TYPE == "DBF_ENUM"} {
|
|
set val \"[string map {"\n" "\\n" "\r" "\\r" "\"" "\\\"" "\\" "\\\\"} $val]\"
|
|
} else {
|
|
if {[lsearch $flags -hex] != -1} {
|
|
catch {
|
|
set val [format "0x%x" [expr int($val)]]
|
|
}
|
|
}
|
|
}
|
|
lappend formatted $val
|
|
}
|
|
if {$SIZE > 1} {
|
|
set formatted \{[join $formatted]\}
|
|
} else {
|
|
set formatted [lindex $formatted 0]
|
|
}
|
|
if {[lsearch $flags -stat] != -1 || $sevr != "NO_ALARM"} {
|
|
set status " (SEVR:$sevr STAT:$stat)"
|
|
} else {
|
|
set status ""
|
|
}
|
|
}
|
|
if {[scan $time "%d/%d/%d %d:%d:%f" m d y H M S] != 6} {
|
|
set m 0
|
|
set d 0
|
|
set y 0
|
|
set H 0
|
|
set M 0
|
|
set S 0
|
|
}
|
|
set time ""
|
|
set microseconds [clock microseconds]
|
|
set seconds [expr $microseconds/1000000]
|
|
foreach flag $flags {
|
|
switch -- $flag {
|
|
"-d" -
|
|
"-date" {append time [format " %02d.%02d.%02d" $d $m $y]}
|
|
"-localdate" {append time [clock format $seconds -format " %d.%m.%y"]}
|
|
"-t" -
|
|
"-time" {append time [format " %02d:%02d:%09.6f" $H $M $S]}
|
|
"-localtime" {append time [clock format $seconds -format " %H:%M:%S."] [string range $microseconds end-5 end]}
|
|
"-timestamp" {append time [format " %s" [expr [clock scan "$m/$d/$y $H:$M"]+$S]]}
|
|
"-tfmt" {append time [clock format [clock scan "$m/$d/$y $H:$M:[expr int($S)]"] -format [regsub -all "%N" " $tfmt" [format "%09d" [expr int(($S-int($S))*1e9)]]]]}
|
|
"-ltfmt" {append time [clock format $seconds -format [regsub -all "%N" " $ltfmt" [string range $microseconds end-5 end]000]]}
|
|
"-noname" {set channel ""}
|
|
"-nounit" {set EGU ""}
|
|
"-nostat" {set status ""}
|
|
}
|
|
}
|
|
return [concat $time $channel $formatted $EGU $status]
|
|
}
|
|
|
|
proc parsecond {cond} {
|
|
set cond [string trim $cond]
|
|
if {[string index $cond 0] == "!"} {
|
|
#puts -nonewline stderr "not "
|
|
return "!([parsecond [string range $cond 1 end]])"
|
|
}
|
|
if [regexp {^(.*)\.\.\.(.*)} $cond match v1 v2] {
|
|
#puts stderr "in range $v1 ... $v2"
|
|
return "\$value >= \"$v1\" && \$value <= \"$v2\""
|
|
}
|
|
if [regexp {^(<=|>=|<|>|==)(.*)} $cond match op val] {
|
|
#puts stderr "$op $val"
|
|
return "\$value $op \"$val\""
|
|
}
|
|
if {[string index $cond 0] == "="} {
|
|
#puts stderr "== [string range $cond 1 end]"
|
|
return "\$value == \"[string range $cond 1 end]\""
|
|
}
|
|
#puts stderr "== $cond"
|
|
return "\$value == \"$cond\""
|
|
}
|
|
|
|
proc monitor {channel condition io value stat sevr time} {
|
|
global info oldval n flags
|
|
if {$io != "OK"} {
|
|
unset info($channel)
|
|
unset oldval($channel)
|
|
puts stderr "$channel CONNECTION LOST"
|
|
return
|
|
}
|
|
if {![info exists info($channel)]} {
|
|
set info($channel) [pvinfo $channel]
|
|
}
|
|
foreach {attr val} $info($channel) {
|
|
set $attr $val
|
|
}
|
|
set newval [formatval $channel $value $stat $sevr $time]
|
|
if {$condition == {}} {
|
|
if {[info exists oldval($channel)] && $oldval($channel) == $newval} return
|
|
set oldval($channel) $newval
|
|
puts $newval
|
|
if {$n > 0 && [incr n -1] < 1} { exit }
|
|
return
|
|
}
|
|
if {$TYPE == "DBF_ENUM" && [lsearch $flags -num] >= 0} {
|
|
set v [lsearch $ENUM $value]
|
|
if {$v != -1} {set value $v}
|
|
}
|
|
|
|
if [expr $condition] {
|
|
puts $newval
|
|
exit
|
|
}
|
|
}
|
|
|
|
set faults 0
|
|
|
|
while 1 {
|
|
switch $command {
|
|
"do" {
|
|
foreach channel $argv {
|
|
if [catch {pvputq $channel 1} msg] {
|
|
puts stderr $msg
|
|
incr faults
|
|
}
|
|
}
|
|
exit $faults
|
|
}
|
|
"gets" {
|
|
set channels $argv
|
|
foreach channel $argv {
|
|
regexp {^[^\.]*} $channel base
|
|
if [catch {pvput $base.PROC 1} msg] {
|
|
puts stderr $msg
|
|
incr faults
|
|
}
|
|
}
|
|
}
|
|
"putq" -
|
|
"put" {
|
|
set channels {}
|
|
foreach {channel setvalue} $argv {
|
|
if [catch {set info($channel) [pvinfo $channel]} msg] {
|
|
puts stderr $msg
|
|
incr faults
|
|
continue
|
|
}
|
|
foreach {attr value} $info($channel) {
|
|
set $attr $value
|
|
}
|
|
if {$TYPE == "DBF_CHAR" && $SIZE > 1 && \
|
|
[lsearch $flags "-int"] == -1 && \
|
|
[lsearch $flags "-hex"] == -1} {
|
|
set a {}
|
|
for {set i 0} {$i < $SIZE} {incr i} {
|
|
if {[scan [string index $setvalue $i] "%c" c] == -1} {
|
|
set c 0
|
|
}
|
|
lappend a $c
|
|
}
|
|
set setvalue $a
|
|
}
|
|
if [catch {
|
|
if {$command == "putq"} {
|
|
pvputq $channel $setvalue
|
|
} else {
|
|
pvput $channel $setvalue
|
|
pvget $channel
|
|
lappend channels $channel
|
|
}
|
|
} msg] {
|
|
puts stderr $msg
|
|
incr faults
|
|
}
|
|
}
|
|
if {$command == "putq"} { exit $faults }
|
|
}
|
|
"mon" {
|
|
foreach channel $argv {
|
|
if [catch {set info($channel) [pvinfo $channel]} msg] {
|
|
puts stderr $msg
|
|
incr faults
|
|
}
|
|
if [catch {pvmon $channel "monitor $channel {}"} msg] {
|
|
puts stderr $msg
|
|
}
|
|
}
|
|
catch {vwait forever}
|
|
exit
|
|
}
|
|
"wait" {
|
|
foreach {channel condition} $argv {
|
|
if [catch {set info($channel) [pvinfo $channel]} msg] {
|
|
puts stderr $msg
|
|
incr faults
|
|
}
|
|
if [catch {pvmon $channel "monitor $channel [list [parsecond $condition]]"} msg] {
|
|
puts stderr $msg
|
|
}
|
|
}
|
|
if [info exists timeout] {
|
|
after [expr int($timeout*1000)] {
|
|
puts stderr "cawait timed out"
|
|
exit 1
|
|
}
|
|
}
|
|
catch {vwait forever}
|
|
exit
|
|
}
|
|
default {
|
|
set channels $argv
|
|
}
|
|
}
|
|
|
|
|
|
foreach channel $channels {
|
|
if [catch {
|
|
if {[info exists info($channel)]} {
|
|
pvget $channel
|
|
}
|
|
set info($channel) [pvinfo $channel]
|
|
} msg] {
|
|
puts stderr $msg
|
|
incr faults
|
|
}
|
|
switch $command {
|
|
"put" -
|
|
"gets" -
|
|
"get" {
|
|
if [info exists info($channel)] {
|
|
puts [formatval $channel]
|
|
}
|
|
}
|
|
"info" {
|
|
if [info exists info($channel)] {
|
|
puts "$channel:"
|
|
regexp {^[^\.]*} $channel base
|
|
set HHSV ""
|
|
set HSV ""
|
|
set LSV ""
|
|
set LLSV ""
|
|
foreach {field value} $info($channel) {
|
|
set extra ""
|
|
switch $field {
|
|
HIHI {catch {
|
|
set HHSV "\t([pvget $base.HHSV])"
|
|
set HSV "\t([pvget $base.HSV])"
|
|
set LSV "\t([pvget $base.LSV])"
|
|
set LLSV "\t([pvget $base.LLSV])"
|
|
set extra $HHSV
|
|
}
|
|
}
|
|
HIGH {set extra $HSV}
|
|
LOW {set extra $LSV}
|
|
LOLO {set extra $LLSV}
|
|
}
|
|
puts "$field\t[list $value]$extra"
|
|
}
|
|
}
|
|
catch {
|
|
set rtyp [pvget $base.RTYP]
|
|
puts "RTYP\t$rtyp"
|
|
}
|
|
catch {
|
|
set desc [pvget $base.DESC]
|
|
puts "DESC\t\"$desc\""
|
|
}
|
|
}
|
|
}
|
|
}
|
|
if {![info exists period]} { break }
|
|
if {$n > 0 && [incr n -1] <= 1} { break }
|
|
if {[info exists sep]} {puts $sep}
|
|
after [expr int($period*1000)]
|
|
}
|
|
|
|
exit $faults
|
|
|