#!/usr/bin/tclsh

# ca* by Dirk Zimoch
# $Source: /cvs/G/EPICS/App/scripts/ca,v $
# $Date: 2013/07/11 09:49:48 $

regsub -all {\$} {ca* by Dirk Zimoch
$Source: /cvs/G/EPICS/App/scripts/ca,v $
$Revision: 1.25 $
$Date: 2013/07/11 09:49:48 $} {} version

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, or use -n <num>)}
    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 {-int           show numeric values instead of strings}
    puts {-prec <digits> override the PREC field}
    puts {-plain         don't do any formatting}
    puts {-timeout <sec> timeout cawait after <sec> seconds}
    puts {-n <num>       exit after <num> updates (for camon)}
    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 {}
set n 0
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] }
        {^-num}              { set argv [lrange $argv 1 end] }
        {^-n}                { set n [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 {$TYPE == "DBF_STRING" && [string length $value] == 39} {
            puts "reread $channel as $channel$"
            set value [pvget $channel$]
        }
        catch {
            set null 0
            if {$TYPE == "DBF_CHAR" && $SIZE > 1 \
                && [lsearch $flags "-num"] == -1 \
                && [lsearch $flags "-int"] == -1 \
                && [lsearch $flags "-hex"] == -1} {
                foreach char $value {
                    if {$null && $char != 0} {
                        error "Not printable"
                    }
                    if {($char & 0x7f) >= 0x20 || $char == 0x0a || $char == 0x0d && $char != 0x7f} {
                        append s [format "%c" $char]
                    } elseif {$char == 0} {
                        set null 1
                    } else {
                        error "Not prinable"
                    }
                }
                set SIZE 1
                set TYPE DBF_STRING
                set value $s
            }
        }
        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_ENUM" && \
                ([lsearch $flags "-int"] != -1 || [lsearch $flags "-num"] != -1 || [lsearch $flags "-hex"] != -1)} {
                set v [lsearch $ENUM $val]
                if {$v != -1} {set val $v}
                set TYPE "DBF_INT"
            }
            if {$TYPE == "DBF_STRING" || $TYPE == "DBF_ENUM"} {
                set val \"[string map {"\n" "\\n" "\r" "\\r" "\"" "\\\"" "\\" "\\\\"} $val]\"
            } else {
                if {[lsearch $flags -hex] != -1} {
                    catch {
                        set val [format "0x%x" [expr int($val)]]
                    }
                }
            }
            lappend formatted $val
            set EGU ""
        }
        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"]}
            "-timestamp" {lappend time [format "%.9f" [expr [clock scan "$m/$d/$y $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 n
    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
	if {$n > 0 && [incr n -1] < 1} { exit }
        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
    }
    "gets" {
        set channels $argv
        foreach channel $argv {
            regexp {^[^\.]*} $channel base
            if [catch {pvput $base.PROC 1} msg] {
                puts stderr $msg
                incr faults
            }
        }
    }
    "putq" -
    "put" {
        set channels {}
        foreach {channel setvalue} $argv {
            if [catch {set info($channel) [pvinfo $channel]} msg] {
                puts stderr $msg
                incr faults
                continue
            }
            foreach {attr value} $info($channel) {
                set $attr $value
            }
            if {$TYPE == "DBF_CHAR" && $SIZE > 1 && \
                 [lsearch $flags "-int"] == -1 && \
                 [lsearch $flags "-hex"] == -1} {
                set a {}
                for {set i 0} {$i < $SIZE} {incr i} {
                    if {[scan [string index $setvalue $i] "%c" c] == -1} {
                        set c 0
                    }
                    lappend a $c
                }
                set setvalue $a
            }
            if [catch {
                if {$command == "putq"} {
                    pvputq $channel $setvalue
                } else {
                    pvput $channel $setvalue
                    pvget $channel
                    lappend channels $channel
                }
            } msg] {
                puts stderr $msg
                incr faults
            }
            if {$command == "putq"} { exit $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:"
                regexp {^[^\.]*} $channel base
                set HHSV ""
                set HSV ""
                set LSV ""
                set LLSV ""
                foreach {field value} $info($channel) {
                    set extra ""
                    switch $field {
                        HIHI {catch {
                            set HHSV "\t([pvget $base.HHSV])"
                            set HSV  "\t([pvget $base.HSV])"
                            set LSV  "\t([pvget $base.LSV])"
                            set LLSV "\t([pvget $base.LLSV])"
                            set extra $HHSV
                            }
                        }
                        HIGH {set extra $HSV}
                        LOW  {set extra $LSV}
                        LOLO {set extra $LLSV}
                    }
                    puts "$field\t[list $value]$extra"
                }
            }
            catch {
                set rtyp [pvget $base.RTYP]
                puts "RTYP\t$rtyp"
            }
            catch {
                set desc [pvget $base.DESC]
                puts "DESC\t\"$desc\""
            }
        }
    }
}

exit $faults