utilities/ca

#!/usr/bin/tclsh
# $Id: ca,v 1.6 2002/12/17 17:34:49 zimoch Exp $
# $Source: /cvs/G/EPICS/App/scripts/ca,v $
# $Log: ca,v $
# Revision 1.6  2002/12/17 17:34:49  zimoch
# debugged
#
# 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
#
#

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 -regexp $flags {-(v(er(sion)?)?)}] != -1} {
    puts "ca* by Dirk Zimoch"
    puts [string trim {$Source: /cvs/G/EPICS/App/scripts/ca,v $} $]
    puts [string trim {$Revision: 1.6 $} $]
    puts [string trim {$Date: 2002/12/17 17:34:49 $} $]
    exit
}

if {[lsearch -regexp $flags {-(\?)|(h(elp)?)}] != -1 || [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> ...]
         }
    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
         }
    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}