#!/usr/bin/tclsh

# ca* by Dirk Zimoch
# $Source: /cvs/G/EPICS/App/scripts/ca,v $
# $Date: 2006/10/02 12:25:31 $

regsub -all {\$} {ca* by Dirk Zimoch
$Source: /cvs/G/EPICS/App/scripts/ca,v $
$Revision: 1.14 $
$Date: 2006/10/02 12:25:31 $} {} version

set auto_path [concat $env(SLSBASE)/lib/tcl $auto_path]

proc printHelp {} {
    puts {usage: caget [flags] <channel> [<channel> ...]}
    puts {       cagets [flags] <channel> [<channel> ...]}
    puts {       caput [flags] <channel> <value> [<channel> <value> ...]}
    puts {       caputq [flags] <channel> <value> [<channel> <value> ...]}
    puts {       cainfo [flags] <channel> [<channel> ...]}
    puts {       camon [flags] <channel> [<channel> ...]}
    puts {       cado [flags] <channel> [<channel> ...]}
    puts {       cawait [flags] <channel> '<condition>' [<channel> '<condition>'...]
         }
    puts {caget   reads and formats values from channels (arrays too)}
    puts {cagets  writes 1 to .PROC and reads after processing has finished}
    puts {caput   writes, waits until processing finishes and reads back}
    puts {caputq  writes but does not wait for processing}
    puts {cainfo  reads additional information}
    puts {camon   starts monitors (terminate with CTRL-C)}
    puts {cado    writes 1 but does not wait for processing}
    puts {cawait  waits until any condition ('>4.3', '!3...5', etc) matches 
         }
    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 and status}
    puts {-nostat        never add severity and status}
    puts {-hex           show integer values as hex}
    puts {-prec <digits> override the PREC field}
    puts {-plain         don't do any formatting}
    puts {-timeout <sec> timeout cawait after <sec> seconds}
    puts {-version       print version and exit}
    puts {-help          print this help text and exit}
}

if {![regexp {gets|get|putq|put|info|mon|do|wait} [file tail $argv0] command]} {
    if [regexp {gets|get|putq|put|info|mon|do|wait} [lindex $argv 0] command] {
        set argv [lrange $argv 1 end]
    } else {
        printHelp
        exit 1
    }
}

set flags {}
while {[string match "-*" [set flag [lindex $argv 0]]]} {
    switch -regexp -- $flag {
        {^-(\?)|(h(elp)?)$}  { printHelp; exit}
        {^-(v(er(sion)?)?)$} { puts $version; exit }
        {^-timeout}          { set timeout [lindex $argv 1]
                               set argv [lrange $argv 2 end] }
        {^-prec}             { set prec [lindex $argv 1]
                               set argv [lrange $argv 2 end] }
        default              { lappend flags $flag
                               set argv [lrange $argv 1 end] }
    }
}

if {[llength $argv] == 0} { printHelp; exit 1 }

package require Epics

proc bgerror {msg} {
    global errorInfo
    puts stderr $errorInfo
}

proc formatval {channel {value {}} {sevr {}} {stat {}} {time {}}} {
    global info flags prec
    set clock [clock seconds]
    set EGU ""
    foreach {attr val} $info($channel) {
        set $attr $val
    }
    if {[lsearch $flags -plain] != -1} {
        set formatted $VAL
        set status ""
        set channel ""
        set EGU ""
    } else {
        if {[info exists PREC] && [info exists prec]} {
            set PREC $prec
        }
        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 {$TYPE == "DBF_STRING" || $TYPE == "DBF_ENUM"} {
                set val \"$val\"
            } else {
                if {[lsearch $flags -hex] != -1} {
                    catch {
                        set val [format "0x%x" [expr int($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 parsecond {cond} {
    set cond [string trim $cond]
    if {[string index $cond 0] == "!"} {
        #puts -nonewline stderr "not "
        return "!([parsecond [string range $cond 1 end]])"
    }
    if [regexp {^(.*)\.\.\.(.*)} $cond match v1 v2] {
        #puts stderr "in range $v1 ... $v2"
        return "\$value >= \"$v1\" && \$value <= \"$v2\""
    }
    if [regexp {^(<=|>=|<|>|==)(.*)} $cond match op val] {
        #puts stderr "$op $val"
        return "\$value $op \"$val\""
    }
    if {[string index $cond 0] == "="} {
        #puts stderr "== [string range $cond 1 end]"
        return "\$value == \"[string range $cond 1 end]\""
    }
    #puts stderr "== $cond"
    return "\$value == \"$cond\""
}

proc monitor {channel condition 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 {$condition == {}} {
        if {[info exists oldval($channel)] && $oldval($channel) == $newval} return
        set oldval($channel) $newval
        puts $newval
        return
    }
    if [expr $condition] {
        puts $newval
        exit
    }
}

set faults 0

switch $command {
    "do" {
        foreach channel $argv {
            if [catch {pvputq $channel 1} msg] {
                puts stderr $msg
                incr faults
            }
        }
        exit $faults
    }
    "putq" {
        foreach {channel setvalue} $argv {
            if [catch {pvputq $channel $setvalue} msg] {
                puts stderr $msg
                incr faults
            }
        }
        exit $faults
    }
    "gets" {
        set channels $argv
        foreach channel $argv {
            regexp {^[^\.]*} $channel base
            if [catch {pvput $base.PROC 1} msg] {
                puts stderr $msg
                incr faults
            }
        }
    }
    "put" {
        set channels {}
        foreach {channel setvalue} $argv {
            if [catch {
                pvput $channel $setvalue
            } msg] {
                puts stderr $msg
                incr faults
            }
            if [catch {
                pvget $channel
                lappend channels $channel
            } msg] {
                puts stderr $msg
                incr faults
            }
        }
    }
    "mon" {
        foreach channel $argv {
            if [catch {set info($channel) [pvinfo $channel]} msg] {
                puts stderr $msg
                incr faults
            }
            if [catch {pvmon $channel "monitor $channel {}"} msg] {
                puts stderr $msg
            }
        }
        catch {vwait forever}
        exit
    }
    "wait" {
        foreach {channel condition} $argv {
            if [catch {set info($channel) [pvinfo $channel]} msg] {
                puts stderr $msg
                incr faults
            }
            if [catch {pvmon $channel "monitor $channel [list [parsecond $condition]]"} msg] {
                puts stderr $msg
            }
        }
        if [info exists timeout] {
            after [expr int($timeout*1000)] {
                puts stderr "cawait timed out"
                exit 1
            }
        }
        catch {vwait forever}
        exit
    }
    default {
        set channels $argv
    }
}


foreach channel $channels {
    if [catch {set info($channel) [pvinfo $channel]} msg] {
        puts stderr $msg
        incr faults
    }
    switch $command {
        "put" -
        "gets" -
        "get" {
            if [info exists info($channel)] {
                puts [formatval $channel]
            }
        }
        "info" {
            if [info exists info($channel)] {
                puts "$channel:\n$info($channel)"
            }
            regexp {^[^\.]*} $channel base
            catch {
                set rtyp [pvget $base.RTYP]
                puts "RTYP\t$rtyp"
            }
            catch {
                set desc [pvget $base.DESC]
                puts "DESC\t\"$desc\""
            }
        }
    }
}

exit $faults