325 lines
9.5 KiB
Tcl
Executable File
325 lines
9.5 KiB
Tcl
Executable File
#!/usr/bin/tclsh
|
|
|
|
# ca* by Dirk Zimoch
|
|
# $Source: /cvs/G/EPICS/App/scripts/ca,v $
|
|
# $Date: 2006/10/02 12:25:31 $
|
|
|
|
regsub -all {\$} {ca* by Dirk Zimoch
|
|
$Source: /cvs/G/EPICS/App/scripts/ca,v $
|
|
$Revision: 1.14 $
|
|
$Date: 2006/10/02 12:25:31 $} {} version
|
|
|
|
set auto_path [concat $env(SLSBASE)/lib/tcl $auto_path]
|
|
|
|
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)}
|
|
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 {-prec <digits> override the PREC field}
|
|
puts {-plain don't do any formatting}
|
|
puts {-timeout <sec> timeout cawait after <sec> seconds}
|
|
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 {}
|
|
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] }
|
|
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 {$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_STRING" || $TYPE == "DBF_ENUM"} {
|
|
set val \"$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 ""
|
|
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"]}
|
|
"-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
|
|
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
|
|
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
|
|
}
|
|
"putq" {
|
|
foreach {channel setvalue} $argv {
|
|
if [catch {pvputq $channel $setvalue} 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
|
|
}
|
|
}
|
|
}
|
|
"put" {
|
|
set channels {}
|
|
foreach {channel setvalue} $argv {
|
|
if [catch {
|
|
pvput $channel $setvalue
|
|
} msg] {
|
|
puts stderr $msg
|
|
incr faults
|
|
}
|
|
if [catch {
|
|
pvget $channel
|
|
lappend channels $channel
|
|
} msg] {
|
|
puts stderr $msg
|
|
incr 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:\n$info($channel)"
|
|
}
|
|
regexp {^[^\.]*} $channel base
|
|
catch {
|
|
set rtyp [pvget $base.RTYP]
|
|
puts "RTYP\t$rtyp"
|
|
}
|
|
catch {
|
|
set desc [pvget $base.DESC]
|
|
puts "DESC\t\"$desc\""
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
exit $faults
|
|
|