Original DELTA version with CVS tags

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}
+