utilities/ca

#!/usr/bin/tclsh
# $Id: ca,v 1.9 2003/04/10 14:10:21 zimoch Exp $
# $Source: /cvs/G/EPICS/App/scripts/ca,v $
# $Log: ca,v $
# Revision 1.9  2003/04/10 14:10:21  zimoch
# added "" to all string/enum values
#
# Revision 1.8  2003/04/10 12:53:36  zimoch
# added -hex flag
#
# Revision 1.7  2003/04/07 09:19:57  zimoch
# added exitstatus and some flags
#
# 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
#
#

regsub -all {\$} {ca* by Dirk Zimoch
$Source: /cvs/G/EPICS/App/scripts/ca,v $
$Revision: 1.9 $
$Date: 2003/04/10 14:10:21 $} {} version

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 $version
    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}
    puts {-noname     don't add channel name}
    puts {-nounit     don't add units}
    puts {-stat       always add severity/status}
    puts {-nostat     never add severity/status}
    puts {-hex        show integer values as hex}
    puts {-version    print version and exit}
    puts {-help       print this help text and exit}
    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 {$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 {[lsearch $flags -hex] != -1} {
            if [catch {
                set val [format "0x%x" [expr int($val)]]
            } message] {
                puts stderr "error $message"
            }
        }
        if {$TYPE == "DBF_STRING" || $TYPE == "DBF_ENUM"} {
            set val \"$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 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
}

set exitstatus 0
if {$command == "gets"} {
    foreach channel $argv {
        regexp {^[^\.]*} $channel base
        if [catch {pvput $base.PROC 1} msg] {
            puts stderr "pvput: $msg"
            incr exitstatus
        }
    }
}

if {$command == "put"} {
    set channels {}
    foreach {channel setvalue} $argv {
        if [catch {
            pvput $channel $setvalue
        } msg] {
            puts stderr "pvput: $msg"
            incr exitstatus
        }
        if [catch {
            pvget $channel
            lappend channels $channel
        } msg] {
            puts stderr "pvget: $msg"
            incr exitstatus
        }
    }
} else {
    set channels $argv
}

if {$command == "do"} {
    foreach channel $channels {
        if [catch {pvputq $channel 1} msg] {
            puts stderr "pvputq: $msg"
            incr exitstatus
        }
    }
    exit $exitstatus
}

foreach channel $channels {
    if [catch {set info($channel) [pvinfo $channel]} msg] {
        puts stderr "pvinfo: $msg"
        incr exitstatus
    }
    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}
exit $exitstatus