utilities/ca

#!/usr/bin/tclsh --
# $Id: ca,v 1.5 2002/12/17 17:24:47 zimoch Exp $
# $Log: ca,v $
# Revision 1.5  2002/12/17 17:24:47  zimoch
# help added
#
# Revision 1.4  2002/10/02 08:38:10  zimoch
# Original DELTA version with CVS tags
#
#

HEADER="$Header: /cvs/G/EPICS/App/scripts/ca,v 1.5 2002/12/17 17:24:47 zimoch Exp $"

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

if {[lsearch $flags -regexp -- {-(v(er(sion)?)?)}]} {
    puts {\$Source: /cvs/G/EPICS/App/scripts/ca,v $}
    puts {\$Revision: 1.5 $}
    puts {\$Date: 2002/12/17 17:24:47 $}
    exit
}

if {[lsearch $flags -regexp -- {-(\?)|(h(elp)?)}] || [llength $argv] == 0} {
    puts "usage: caget [flags] <channel> [<channel> ...]"
    puts "       caput [flags] <channel> <value> [<channel> <value> ...]"
    puts "       cainfo [flags] <channel> [<channel> ...]"
    puts "       camon [flags] <channel> [<channel> ...]"
    puts "       cado [flags] <channel> [<channel> ...]"
    puts "       cagets [flags] <channel> [<channel> ...]\n"
    puts "caget reads and formats values from channels (arrays too)"
    puts "caput writes, waits until processing finishes and reads back"
    puts "cainfo reads additional information"
    puts "camon starts monitors (terminate with CTRL-C)"
    puts "cado writes 1 and does not wait"
    puts "cagets writes 1 to .PROC and reads after processing has finished\n"
    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"
    exit
}

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}