396 lines
13 KiB
Tcl
Executable File
396 lines
13 KiB
Tcl
Executable File
#!/usr/bin/tclsh
|
|
|
|
# ca* by Dirk Zimoch
|
|
# $Source: /cvs/G/EPICS/App/scripts/ca,v $
|
|
# $Date: 2013/07/11 09:49:48 $
|
|
|
|
regsub -all {\$} {ca* by Dirk Zimoch
|
|
$Source: /cvs/G/EPICS/App/scripts/ca,v $
|
|
$Revision: 1.25 $
|
|
$Date: 2013/07/11 09:49:48 $} {} version
|
|
|
|
proc printHelp {} {
|
|
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:}
|
|
puts {-date add record execution date}
|
|
puts {-localdate add host date}
|
|
puts {-time add record execution time}
|
|
puts {-localtime add host time}
|
|
puts {-noname don't add channel name}
|
|
puts {-nounit don't add units}
|
|
puts {-stat always add severity and status}
|
|
puts {-nostat never add severity and status}
|
|
puts {-hex show integer values as hex}
|
|
puts {-int show numeric values instead of strings}
|
|
puts {-prec <digits> override the PREC field}
|
|
puts {-plain don't do any formatting}
|
|
puts {-timeout <sec> timeout cawait after <sec> seconds}
|
|
puts {-n <num> exit after <num> updates (for camon)}
|
|
puts {-version print version and exit}
|
|
puts {-help print this help text and exit}
|
|
}
|
|
|
|
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] }
|
|
{^-num} { set argv [lrange $argv 1 end] }
|
|
{^-n} { set n [lindex $argv 1]
|
|
set argv [lrange $argv 2 end] }
|
|
default { lappend flags $flag
|
|
set argv [lrange $argv 1 end] }
|
|
}
|
|
}
|
|
|
|
if {[llength $argv] == 0} { printHelp; exit 1 }
|
|
|
|
package require Epics
|
|
|
|
proc bgerror {msg} {
|
|
global errorInfo
|
|
puts stderr $errorInfo
|
|
}
|
|
|
|
proc formatval {channel {value {}} {sevr {}} {stat {}} {time {}}} {
|
|
global info flags prec
|
|
set clock [clock seconds]
|
|
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 {$time == {}} {
|
|
set value $VAL
|
|
set stat $STAT
|
|
set sevr $SEVR
|
|
set time $TIME
|
|
}
|
|
if {$TYPE == "DBF_STRING" && [string length $value] == 39} {
|
|
puts "reread $channel as $channel$"
|
|
set value [pvget $channel$]
|
|
}
|
|
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 {$PREC < 0} {
|
|
set val [format "%.[expr -$PREC]e" $val]
|
|
} else {
|
|
set val [format "%.${PREC}f" $val]
|
|
}
|
|
}
|
|
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
|
|
set EGU ""
|
|
}
|
|
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 ""
|
|
foreach flag $flags {
|
|
switch -- $flag {
|
|
"-date" {lappend time [format "%02d.%02d.%02d" $d $m $y]}
|
|
"-localdate" {lappend time [clock format $clock -format "%d.%m.%y"]}
|
|
"-time" {lappend time [format "%02d:%02d:%05.2f" $H $M $S]}
|
|
"-localtime" {lappend time [clock format $clock -format "%H:%M:%S"]}
|
|
"-timestamp" {lappend time [format "%.9f" [expr [clock scan "$m/$d/$y $H:$M"]+$S]]}
|
|
"-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
|
|
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]
|
|
}
|
|
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 [expr $condition] {
|
|
puts $newval
|
|
exit
|
|
}
|
|
}
|
|
|
|
set faults 0
|
|
|
|
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 {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\""
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
exit $faults
|
|
|