diff --git a/ca b/ca new file mode 100755 index 0000000..393934d --- /dev/null +++ b/ca @@ -0,0 +1,167 @@ +#!/usr/bin/tclsh +# $Id: ca,v 1.4 2002/10/02 08:38:10 zimoch Exp $ +# $Log: ca,v $ +# Revision 1.4 2002/10/02 08:38:10 zimoch +# Original DELTA version with CVS tags +# +# +set auto_path [concat $env(SLSBASE)/lib/tcl $auto_path] +package require Epics + +if {![regexp {gets|get|put|info|mon|do} [file tail $argv0] command]} { + if [regexp {gets|get|put|info|mon|do} [lindex $argv 0] command] { + set argv [lrange $argv 1 end] + } else { + puts stderr "unknown command: should be one of gets, get, put, info, mon, do" + exit 1 + } +} + +set flags {} +while {[string match "-*" [lindex $argv 0]]} { + lappend flags [lindex $argv 0] + set argv [lrange $argv 1 end] +} + + +proc bgerror {msg} { + global errorInfo + puts stderr $errorInfo +} + +proc formatval {channel {value {}} {sevr {}} {stat {}} {time {}}} { + global info flags + set clock [clock seconds] + set EGU "" + foreach {attr val} $info($channel) { + set $attr $val + } + if [string match *.* $channel] { + catch {unset PREC} + set EGU "" + } + if {$time == {}} { + set value $VAL + set stat $STAT + set sevr $SEVR + set time $TIME + } + if [info exists PREC] { + foreach val $value { + if {$PREC < 0} { + lappend formatted [format "%.[expr -$PREC]e" $val] + } else { + lappend formatted [format "%.${PREC}f" $val] + } + } + set value [list $formatted] + } elseif {$SIZE == 1 && [llength $value] != 1} { + set value \"$value\" + } else { + set value [list $value] + } + + if {$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" {append time [format "%02d.%02d.%02d " $d $m $y]} + "-localdate" {append time [clock format $clock -format "%d.%m.%y "]} + "-time" {append time [format "%02d:%02d:%05.2f " $H $M $S]} + "-localtime" {append time [clock format $clock -format "%H:%M:%S "]} + } + } + return "$time$channel $value $EGU$status" +} + +proc monitor {channel 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 {[info exists oldval($channel)] && $oldval($channel) == $newval} return + set oldval($channel) $newval + puts $newval +} + +if {$command == "gets"} { + foreach channel $argv { + regexp {^[^\.]*} $channel base + pvput $base.PROC 1 + } +} + +if {$command == "put"} { + set channels {} + foreach {channel setvalue} $argv { + if [catch { + pvput $channel $setvalue + } msg] { + puts stderr "pvput: $msg" + } + if [catch { + pvget $channel + lappend channels $channel + } msg] { + puts stderr "pvget: $msg" + } + } +} else { + set channels $argv +} + +if {$command == "do"} { + foreach channel $channels { + if [catch {pvputq $channel 1} msg] { + puts stderr "pvputq: $msg" + } + } + exit +} + +foreach channel $channels { + if [catch {set info($channel) [pvinfo $channel]} msg] { + puts stderr "pvinfo: $msg" + } + switch $command { + "mon" { + if [catch {pvmon $channel "monitor $channel"} msg] { + puts stderr "pvmon: $msg" + } + } + "put" - + "gets" - + "get" { + if [info exists info($channel)] { + puts [formatval $channel] + } + } + "info" { + if [info exists info($channel)] { + puts "$channel:\n$info($channel)" + } + } + } +} + +if {$command == "mon"} {vwait forever} +