#!/usr/bin/tclsh

# ca* by Dirk Zimoch
# $Source: /cvs/G/EPICS/App/scripts/ca,v $
# $Date: 2017/02/23 08:19:10 $

regsub -all {\$} {ca* by Dirk Zimoch
$Source: /cvs/G/EPICS/App/scripts/ca,v $
$Revision: 1.36 $
$Date: 2017/02/23 08:19:10 $} {} version

package require Tclx
package require Epics

# possible flags and what they are for
set possFlags(-date) "          add record time stamp date"
set possFlags(-d) "             same as -date"
set possFlags(-localdate) "     add host date"
set possFlags(-time) "          add record time stamp time"
set possFlags(-timestamp) "     add floating point time stamp"
set possFlags(-tfmt) "<format>  add user formatted time stamp"
set possFlags(-ltfmt) "<format> add user formatted host time"
set possFlags(-t) "             same as -time"
set possFlags(-localtime) "     add host time"
set possFlags(-noname) "        don't add channel name"
set possFlags(-nounit) "        don't add units"
set possFlags(-stat) "          always add severity and status"
set possFlags(-nostat) "        never add severity and status"
set possFlags(-hex) "           show integer values as hex"
set possFlags(-int) "           show numeric values instead of strings"
set possFlags(-prec) "<digits>  override the PREC field"
set possFlags(-plain) "         don't do any formatting"
set possFlags(-timeout) "<sec>  timeout cawait after <sec> seconds"
set possFlags(-num) "           show enums as numeric values"
set possFlags(-n) "<num>        exit after <num> updates (for camon)"
set possFlags(-version) "       print version and exit"
set possFlags(-help) "          print this help text and exit"
set possFlags(-period) "<sec>   execute periodically (in particular caget)"
set possFlags(-sep) " <string>  print separator (with -period)"

proc printHelp {} {
    global possFlags
    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:}
    foreach {f} [lsort [array names possFlags]] {
       puts "$f $possFlags($f)"
    }
}
proc check_n {i} {
   #is i an integer? 
   #incr n to compensate for connect that is counted , too
   global n
   set n $i
   if {[catch {incr n}]} {puts stderr "-n flag expects an integer"; set n 1}
}
proc check_flag {f} {
   global flags possFlags
   if {[clength [array names possFlags -exact $f]] > 0} {
      lappend flags $f
   } else {puts stderr "not valid flag: $f"}
}
   
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] }
        {^-n$}               { check_n [lindex $argv 1];
                               set argv [lrange $argv 2 end] }
        {^-period$}          { set period [lindex $argv 1];
                               set argv [lrange $argv 2 end] }
        {^-sep$}             { set sep [lindex $argv 1];
                               set argv [lrange $argv 2 end] }
        {^-tfmt$}            { lappend flags $flag;
                               set tfmt [lindex $argv 1];
                               set argv [lrange $argv 2 end] }
        {^-ltfmt$}           { lappend flags $flag;
                               set ltfmt [lindex $argv 1];
                               set argv [lrange $argv 2 end] }
        default              { check_flag $flag
                               set argv [lrange $argv 1 end] }
    }
}
if {[llength $argv] == 0} { printHelp; exit 1 }

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

proc formatval {channel {value {}} {sevr {}} {stat {}} {time {}}} {
    global info flags prec tfmt ltfmt 
    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 {$value == {}} {
            set value $VAL
        }
        if {$time == {}} {
            set time $TIME
        }
        if {$sevr == {}} {
            set sevr $SEVR
        }
        if {$stat == {}} {
            set stat $STAT
        }
        if {$TYPE == "DBF_STRING" && [string length $value] == 39} {
            # long string: try to re-read as array of char
            set field [file extension $channel]
            if {$field != "" && $field != ".VAL"} {
                catch {
                    set value [pvget $channel$]
                    set TYPE "DBF_CHAR"
                    set SIZE [llength $value]
                }
            }
        }
        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 [catch { # new Tcl fails on NaN. Suck.
                    if {$PREC < 0} {
                        set val [format "%.[expr -$PREC]e" $val]
                    } else {
                        set val [format "%.${PREC}f" $val]
                    }
                }] {
                    set val "NaN"
                }
            }
            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
        }
        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 ""
    set microseconds [clock microseconds]
    set seconds [expr $microseconds/1000000]
    foreach flag $flags {
        switch -- $flag {
            "-d"         -
            "-date"      {append time [format " %02d.%02d.%02d" $d $m $y]}
            "-localdate" {append time [clock format $seconds -format " %d.%m.%y"]}
            "-t"         -
            "-time"      {append time [format " %02d:%02d:%09.6f" $H $M $S]}
            "-localtime" {append time [clock format $seconds -format " %H:%M:%S."] [string range $microseconds end-5 end]}
            "-timestamp" {append time [format " %s" [expr [clock scan "$m/$d/$y $H:$M"]+$S]]}
            "-tfmt"      {append time [clock format [clock scan "$m/$d/$y $H:$M:[expr int($S)]"] -format [regsub -all "%N" " $tfmt" [format "%09d" [expr int(($S-int($S))*1e9)]]]]}
            "-ltfmt"     {append time [clock format $seconds -format [regsub -all "%N" " $ltfmt" [string range $microseconds end-5 end]000]]}
            "-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 flags
    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]
    }
    foreach {attr val} $info($channel) {
        set $attr $val
    }
    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 {$TYPE == "DBF_ENUM" && [lsearch $flags -num] >= 0} {
       set v [lsearch $ENUM $value]
       if {$v != -1} {set value $v}
    }

    if [expr $condition] {
        puts $newval
        exit
    } 
}

set faults 0

while 1 {
    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 {
            if {[info exists info($channel)]} {
                pvget $channel
            }
            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\""
                }
            }
        }
    }
    if {![info exists period]} { break }
    if {$n > 0 && [incr n -1] <= 1} { break }
    if {[info exists sep]} {puts $sep}
    after [expr int($period*1000)]
}

exit $faults