timestamp log issues

[tcl-tlc-base.git] / scripts / baselog.itcl

# vim: ft=tcl foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4

class tlc::Baselog {
        public {
                variable baselog_threshold              ""
                variable baselog_instancename   ""
        }

        protected {
                variable debuglogmode   0

                method log {lvl {msg ""} args}
                method parray {args}
        }

        private {
                common lvlmap
                common classmap
                common hotfuncs
                common using_hotfuncs   0
                common remote
                common redir
                common helpers

                method c {args}
        }

        array set lvlmap {
                trivia          5
                debug           10
                notify          20
                notice          20
                warning         30
                warn            30
                error           40
                fatal           50
        }

        array set helpers {}
        array set classmap {}
        array set hotfuncs {}

        proc remote_logging {ip port} {
                set remote      [socket $ip $port]
                fconfigure $remote -translation binary -encoding binary -blocking 1 -buffering none
        }

        proc load_classmap {fn} {
                if {[catch {set fp [open $fn r]} errmsg]} {
                        error "Problem opening classmap file: $errmsg"
                }
                set dat [read $fp]
                close $fp

                if {[catch {
                        array set tmp   [tlc::decomment $dat]
                } errmsg]} {
                        error "Error parsing classmap: should be a list of key value pairs, optionally commented"
                }

                foreach {key val} [array get tmp] {
                        if {[info exists lvlmap($val)]} {
                                set val $lvlmap($val)
                        }
                        if {![string is integer -strict $val]} {
                                error "Log threshold for $key is not an integer or a valid symbolic level ($val)"
                        }
                        set classmap($key)      $val
                }
        }

        proc load_hotfuncs {fn} {
                if {[catch {set fp [open $fn r]} errmsg]} {
                        error "Problem opening hotfuncs file: $errmsg"
                }
                set dat [read $fp]
                close $fp

                if {[catch {
                        array set tmp   [tlc::decomment $dat]
                } errmsg]} {
                        error "Error parsing hotfuncs: should be a list of key value pairs, optionally commented"
                }

                foreach {key val} [array get tmp] {
                        if {[info exists lvlmap($val)]} {
                                set val $lvlmap($val)
                        }
                        if {![string is integer -strict $val]} {
                                error "Log threshold for $key is not an integer or a valid symbolic level ($val)"
                        }
                        set hotfuncs($key)      $val
                }

                set using_hotfuncs      1
        }

        proc timestamp_function {func} {
                array unset helpers timestamp
                return
                if {$func == ""} {
                        array unset helpers timestamp
                } else {
                        set helpers(timestamp)  $func
                }
        }

        proc timestamp {} {
                return  [clock microseconds]
        }

        proc output_function {func} {
                set helpers(output)     $func
        }

        proc redir_output {cb} {
                set redir       $cb
        }
}


body tlc::Baselog::log {lvl {msg ""} args} { #<<<1
        if {$debuglogmode} {puts stderr "foo"}
        # Get a timestamp <<<
        set now         [clock microseconds]
        #if {[info exists helpers(timestamp)]} {
        #       set cmd         [linsert [lrange $helpers(timestamp) 1 end] 0 \
        #                       [lindex $helpers(timestamp) 0]]
        #       set now         [uplevel #0 $cmd]
        #} else {
        #       if {[package vsatisfies [info tclversion] 8.5]} {
        #               set now [clock microseconds]
        #       } else {
        #               set now [expr {[clock seconds] * 1000000}]
        #       }
        #}
        # Get a timestamp >>>

        array set switches {
                -suppressed     {}
        }
        array set switches      $args
        if {[info exists switches(-suppress)]} {
                set switches(-suppressed)       $switches(-suppress)
        }
        if {![string is integer -strict $lvl]} {
                if {![info exists lvlmap($lvl)]} {
                        set lvl         10
                } else {
                        set lvl         $lvlmap($lvl)
                }
        }

        set caller_inf          [info level -1]
        set name                        [lindex $caller_inf 0]
        set passed_args         [lrange $caller_inf 1 end]
        if {$name == {}} {
                set fqname                      "<unknown>"
                set caller_args_def     {}
                for {set i 1} {$i <= [llength $passed_args]} {incr i} {
                        lappend caller_args_def "<unknown$i>"
                }
        } else {
                set fqname                      [uplevel 1 [list namespace origin $name]]
                if {$name eq "namespace"} {
                        set caller_args_def     {}
                } else {
                        set caller_args_def     [uplevel 1 [list info args $name]]
                }
        }

        set logzone                     [namespace qualifiers $fqname]

        if {$debuglogmode} {puts stderr "bar"}
        if {[info exists helpers(output)]} {
                set output_cmd          [linsert [lrange $helpers(output) 1 end] 0 \
                                [lindex $helpers(output) 0]]

                set ns          [namespace qualifiers $logzone]
                set class       [namespace tail $logzone]
                set method      [namespace tail $fqname]

                set substmap    [list "\n" "%n" "\t" "%t" "%" "%%"]
                set argdesc     {}
                set idx         0
                foreach arg $caller_args_def {
                        if {$arg == "args"} {
                                set this_passed_arg     [lrange $passed_args $idx end]
                        } else {
                                set this_passed_arg     [lindex $passed_args $idx]
                        }

                        set alen        [string length $this_passed_arg]
                        if {$arg in $switches(-suppressed)} {
                                set this_passed_arg "#<suppressed>"
                                set this_passed_arg_type        [list info suppressed]
                        } elseif {$this_passed_arg eq ""} {
                                set this_passed_arg     "{}"
                                set this_passed_arg_type        [list info blank]
                        } elseif {$alen > 23} {
                                set this_passed_arg     [string range $this_passed_arg 0 21]
                                set this_passed_arg     [string map $substmap $this_passed_arg]
                                set this_passed_arg_type        [list value_trunc $alen]
                        } elseif {![string is print $this_passed_arg]} {
                                set this_passed_arg     "#<nonprint($alen)>"
                                set this_passed_arg_type        [list info nonprint]
                        } else {
                                set this_passed_arg     [string map $substmap $this_passed_arg]
                                set this_passed_arg_type        [list value_whole $alen]
                        }

                        lappend argdesc [list $arg $this_passed_arg $this_passed_arg_type]
                        incr idx
                }

                #uplevel #0 [list {*}$helpers(output) $now $baselog_instancename $ns $class $method $argdesc $lvl $msg [tlc::build_stackdump]]
                uplevel #0 [list {*}$helpers(output) $now $baselog_instancename $ns $class $method $argdesc $lvl $msg]
        } else {
                if {$baselog_threshold != ""} {
                        set threshold           $baselog_threshold
                } elseif {[info exists classmap($logzone)]} {
                        set threshold           $classmap($logzone)
                } else {
                        set threshold           $::tlc::log(threshold)
                }

                if {$lvl < $threshold} {
                        if {!($using_hotfuncs)} return

                        # Check our callers for a hotfunc <<<
                        for {
                                set i           [expr {[info level] - 1}]
                                set depth       1
                        } {
                                $i > 0
                        } {
                                incr i -1
                                incr depth
                        } {
                                set stackname   [lindex [info level $i] 0]
                                if {$stackname == {}} continue
                                if {[catch {
                                        set fqname              [uplevel $depth [list namespace origin $stackname]]
                                } errmsg]} {
                                        set fqname              "??$stackname"
                                }

                                if {[info exists hotfuncs($fqname)]} {
                                        set threshold   $hotfuncs($fqname)
                                        if {$lvl >= $threshold} break
                                }
                        }
                        if {$lvl < $threshold} return
                        # Check our callers for a hotfunc >>>
                }

                if {$baselog_instancename != ""} {
                        set instance_prefix     "[c red]$baselog_instancename[c norm] "
                } else {
                        set instance_prefix ""
                }
                set ns          [namespace qualifiers $logzone]
                set class       [namespace tail $logzone]
                set method      [namespace tail $fqname]
                set fqname_coloured     "${instance_prefix}${ns}::[c red]$class[c norm]::[c bright yellow]$method[c norm]"

                set substmap    [list "\n" "[c purple]\\n[c white]" "\t" "[c purple]\\t[c white]"]
                set argdesc     {}
                set idx         0
                foreach arg $caller_args_def {
                        if {$arg == "args"} {
                                set this_passed_arg     [lrange $passed_args $idx end]
                        } else {
                                set this_passed_arg     [lindex $passed_args $idx]
                        }

                        set alen        [string length $this_passed_arg]
                        if {[lsearch $switches(-suppressed) $arg] != -1} {
                                set this_passed_arg "#<suppressed>"
                        } elseif {$this_passed_arg == ""} {
                                set this_passed_arg     "{}"
                        } elseif {$alen > 23} {
                                set this_passed_arg     [string range $this_passed_arg 0 21]
                                set this_passed_arg     [string map $substmap $this_passed_arg]
                                set this_passed_arg     "[c underline bright white]$this_passed_arg[c norm]/[c red]$alen[c norm]"
                        } elseif {![string is print $this_passed_arg]} {
                                set this_passed_arg     "#<nonprint($alen)>"
                        } else {
                                set this_passed_arg     [string map $substmap $this_passed_arg]
                                set this_passed_arg     "[c underline bright white]$this_passed_arg[c norm]"
                        }

                        lappend argdesc "[c green]$arg[c norm]$this_passed_arg"
                        incr idx
                }

                set argtext     [join $argdesc " "]

                set outmsg      "${fqname_coloured} $argtext"
                if {$msg != ""} {
                        set fg  "bright white"
                        if {$lvl >= 40} {
                                set bg  "red"
                        } elseif {$lvl >= 30} {
                                set bg  "purple"
                        } elseif {$lvl >= 20} {
                                #set bg "green"
                                #set fg "black"
                                set bg  "blue"
                        } elseif {$lvl >= 10} {
                                set bg  "blue"
                                set fg  "yellow"
                        } else {
                                set bg  "none"
                        }
                        append outmsg   ": [c bg_$bg $fg]$msg[c norm]"
                }

                if {[info exists redir] && $redir != ""} {
                        uplevel #0 [list $redir $outmsg]
                } elseif {[info exists remote]} {
                        puts $remote $outmsg
                } else {
                        puts stderr $outmsg
                }
        }
        if {$debuglogmode} {puts stderr "baz"}
}


body tlc::Baselog::c {args} { #<<<1
        return [tlc::colour {*}$args]
}


body tlc::Baselog::parray {args} { #<<<1
        switch -- [llength $args] {
                1 {
                        uplevel [list ::parray [lindex $args 0]]
                }

                2 {
                        set lvl         [lindex $args 0]
                        set arrname     [lindex $args 1]

                        upvar $arrname a
                        set keys        [array names a]

                        set maxlen      -1
                        foreach key $keys {
                                set thislen     [string length $key]
                                if {$thislen > $maxlen} {
                                        set maxlen      $thislen
                                }
                        }

                        incr maxlen     [string length $arrname]
                        incr maxlen 2

                        set msg "\n"
                        foreach key [lsort $keys] {
                                append msg      [format "%-${maxlen}s = \"%s\"\n" "${arrname}($key)" $a($key)]
                        }

                        uplevel [list log $lvl $msg]
                }

                default {
                        error "Invalid number of arguments, expecting lvl arrayvar" "" \
                                        [list syntax_error]
                }
        }
}