scripts/baselog.itcl

   1 # vim: ft=tcl foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4
   2
   3 class tlc::Baselog {
   4         public {
   5                 variable baselog_threshold              ""
   6                 variable baselog_instancename   ""
   7         }
   8
   9         protected {
  10                 method log {lvl {msg ""} args}
  11         }
  12
  13         private {
  14                 common lvlmap
  15                 common classmap
  16                 common hotfuncs
  17                 common using_hotfuncs   0
  18                 common remote
  19                 common redir
  20                 common helpers
  21
  22                 method c {args}
  23         }
  24
  25         array set lvlmap {
  26                 trivia          5
  27                 debug           10
  28                 notify          20
  29                 notice          20
  30                 warning         30
  31                 warn            30
  32                 error           40
  33                 fatal           50
  34         }
  35
  36         array set helpers {}
  37         array set classmap {}
  38         array set hotfuncs {}
  39
  40         proc remote_logging {ip port} {
  41                 set remote      [socket $ip $port]
  42                 fconfigure $remote -translation binary -encoding binary -blocking 1 -buffering none
  43         }
  44
  45         proc load_classmap {fn} {
  46                 if {[catch {set fp [open $fn r]} errmsg]} {
  47                         error "Problem opening classmap file: $errmsg"
  48                 }
  49                 set dat [read $fp]
  50                 close $fp
  51
  52                 if {[catch {
  53                         array set tmp   [tlc::decomment $dat]
  54                 } errmsg]} {
  55                         error "Error parsing classmap: should be a list of key value pairs, optionally commented"
  56                 }
  57
  58                 foreach {key val} [array get tmp] {
  59                         if {[info exists lvlmap($val)]} {
  60                                 set val $lvlmap($val)
  61                         }
  62                         if {![string is integer -strict $val]} {
  63                                 error "Log threshold for $key is not an integer or a valid symbolic level ($val)"
  64                         }
  65                         set classmap($key)      $val
  66                 }
  67         }
  68
  69         proc load_hotfuncs {fn} {
  70                 if {[catch {set fp [open $fn r]} errmsg]} {
  71                         error "Problem opening hotfuncs file: $errmsg"
  72                 }
  73                 set dat [read $fp]
  74                 close $fp
  75
  76                 if {[catch {
  77                         array set tmp   [tlc::decomment $dat]
  78                 } errmsg]} {
  79                         error "Error parsing hotfuncs: should be a list of key value pairs, optionally commented"
  80                 }
  81
  82                 foreach {key val} [array get tmp] {
  83                         if {[info exists lvlmap($val)]} {
  84                                 set val $lvlmap($val)
  85                         }
  86                         if {![string is integer -strict $val]} {
  87                                 error "Log threshold for $key is not an integer or a valid symbolic level ($val)"
  88                         }
  89                         set hotfuncs($key)      $val
  90                 }
  91
  92                 set using_hotfuncs      1
  93         }
  94
  95         proc timestamp_function {func} {
  96                 if {$func == ""} {
  97                         array unset helpers timestamp
  98                 } else {
  99                         set helpers(timestamp)  $func
 100                 }
 101         }
 102
 103         proc timestamp {} {
 104                 # Get a timestamp <<<
 105                 if {[info exists helpers(timestamp)]} {
 106                         set cmd         [linsert [lrange $helpers(timestamp) 1 end] 0 \
 107                                         [lindex $helpers(timestamp) 0]]
 108                         set now         [uplevel #0 $cmd]
 109                 } else {
 110                         if {[package vsatisfies [info tclversion] 8.5]} {
 111                                 set now [clock microseconds]
 112                         } else {
 113                                 set now [expr {wide([clock seconds]) * 1000000}]
 114                         }
 115                 }
 116                 # Get a timestamp >>>
 117
 118                 return $now
 119         }
 120
 121         proc output_function {func} {
 122                 set helpers(output)     $func
 123         }
 124
 125         proc redir_output {cb} {
 126                 set redir       $cb
 127         }
 128 }
 129
 130
 131 body tlc::Baselog::log {lvl {msg ""} args} { #<<<1
 132         # Get a timestamp <<<
 133         set now         [timestamp]
 134         #if {[info exists helpers(timestamp)]} {
 135         #       set cmd         [linsert [lrange $helpers(timestamp) 1 end] 0 \
 136         #                       [lindex $helpers(timestamp) 0]]
 137         #       set now         [uplevel #0 $cmd]
 138         #} else {
 139         #       if {[package vsatisfies [info tclversion] 8.5]} {
 140         #               set now [clock microseconds]
 141         #       } else {
 142         #               set now [expr {[clock seconds] * 1000000}]
 143         #       }
 144         #}
 145         # Get a timestamp >>>
 146
 147         array set switches {
 148                 -suppressed     {}
 149         }
 150         array set switches      $args
 151         if {[info exists switches(-suppress)]} {
 152                 set switches(-suppressed)       $switches(-suppress)
 153         }
 154         if {![string is integer -strict $lvl]} {
 155                 if {![info exists lvlmap($lvl)]} {
 156                         set lvl         10
 157                 } else {
 158                         set lvl         $lvlmap($lvl)
 159                 }
 160         }
 161
 162         set caller_inf          [info level -1]
 163         set name                        [lindex $caller_inf 0]
 164         set passed_args         [lrange $caller_inf 1 end]
 165         if {$name == {}} {
 166                 set fqname                      "<unknown>"
 167                 set caller_args_def     {}
 168                 for {set i 1} {$i <= [llength $passed_args]} {incr i} {
 169                         lappend caller_args_def "<unknown$i>"
 170                 }
 171         } else {
 172                 set fqname                      [uplevel 1 [list namespace origin $name]]
 173                 set caller_args_def     [uplevel 1 [list info args $name]]
 174         }
 175
 176         set logzone                     [namespace qualifiers $fqname]
 177
 178         if {[info exists helpers(output)]} {
 179                 set output_cmd          [linsert [lrange $helpers(output) 1 end] 0 \
 180                                 [lindex $helpers(output) 0]]
 181
 182                 set ns          [namespace qualifiers $logzone]
 183                 set class       [namespace tail $logzone]
 184                 set method      [namespace tail $fqname]
 185
 186                 set substmap    [list "\n" "%n" "\t" "%t" "%" "%%"]
 187                 set argdesc     {}
 188                 set idx         0
 189                 foreach arg $caller_args_def {
 190                         if {$arg == "args"} {
 191                                 set this_passed_arg     [lrange $passed_args $idx end]
 192                         } else {
 193                                 set this_passed_arg     [lindex $passed_args $idx]
 194                         }
 195
 196                         set alen        [string length $this_passed_arg]
 197                         if {[lsearch $switches(-suppressed) $arg] != -1} {
 198                                 set this_passed_arg "#<suppressed>"
 199                                 set this_passed_arg_type        [list info suppressed]
 200                         } elseif {$this_passed_arg == ""} {
 201                                 set this_passed_arg     "{}"
 202                                 set this_passed_arg_type        [list info blank]
 203                         } elseif {$alen > 23} {
 204                                 set this_passed_arg     [string range $this_passed_arg 0 21]
 205                                 set this_passed_arg     [string map $substmap $this_passed_arg]
 206                                 set this_passed_arg_type        [list value_trunc $alen]
 207                         } elseif {![string is print $this_passed_arg]} {
 208                                 set this_passed_arg     "#<nonprint($alen)>"
 209                                 set this_passed_arg_type        [list info nonprint]
 210                         } else {
 211                                 set this_passed_arg     [string map $substmap $this_passed_arg]
 212                                 set this_passed_arg_type        [list value_whole $alen]
 213                         }
 214
 215                         lappend argdesc [list $arg $this_passed_arg $this_passed_arg_type]
 216                         incr idx
 217                 }
 218
 219                 uplevel #0 $output_cmd [list $now $baselog_instancename $ns $class $method $argdesc $lvl $msg]
 220         } else {
 221                 if {$baselog_threshold != ""} {
 222                         set threshold           $baselog_threshold
 223                 } elseif {[info exists classmap($logzone)]} {
 224                         set threshold           $classmap($logzone)
 225                 } else {
 226                         set threshold           $::tlc::log(threshold)
 227                 }
 228
 229                 if {$lvl < $threshold} {
 230                         if {!($using_hotfuncs)} return
 231
 232                         # Check our callers for a hotfunc <<<
 233                         for {
 234                                 set i           [expr {[info level] - 1}]
 235                                 set depth       1
 236                         } {
 237                                 $i > 0
 238                         } {
 239                                 incr i -1
 240                                 incr depth
 241                         } {
 242                                 set stackname   [lindex [info level $i] 0]
 243                                 if {$stackname == {}} continue
 244                                 set fqname              [uplevel $depth [list namespace origin $stackname]]
 245
 246                                 if {[info exists hotfuncs($fqname)]} {
 247                                         set threshold   $hotfuncs($fqname)
 248                                         if {$lvl >= $threshold} break
 249                                 }
 250                         }
 251                         if {$lvl < $threshold} return
 252                         # Check our callers for a hotfunc >>>
 253                 }
 254
 255                 if {$baselog_instancename != ""} {
 256                         set instance_prefix     "[c red]$baselog_instancename[c norm] "
 257                 } else {
 258                         set instance_prefix ""
 259                 }
 260                 set ns          [namespace qualifiers $logzone]
 261                 set class       [namespace tail $logzone]
 262                 set method      [namespace tail $fqname]
 263                 set fqname_coloured     "${instance_prefix}${ns}::[c red]$class[c norm]::[c bright yellow]$method[c norm]"
 264
 265                 set substmap    [list "\n" "[c purple]\\n[c white]" "\t" "[c purple]\\t[c white]"]
 266                 set argdesc     {}
 267                 set idx         0
 268                 foreach arg $caller_args_def {
 269                         if {$arg == "args"} {
 270                                 set this_passed_arg     [lrange $passed_args $idx end]
 271                         } else {
 272                                 set this_passed_arg     [lindex $passed_args $idx]
 273                         }
 274
 275                         set alen        [string length $this_passed_arg]
 276                         if {[lsearch $switches(-suppressed) $arg] != -1} {
 277                                 set this_passed_arg "#<suppressed>"
 278                         } elseif {$this_passed_arg == ""} {
 279                                 set this_passed_arg     "{}"
 280                         } elseif {$alen > 23} {
 281                                 set this_passed_arg     [string range $this_passed_arg 0 21]
 282                                 set this_passed_arg     [string map $substmap $this_passed_arg]
 283                                 set this_passed_arg     "[c underline bright white]$this_passed_arg[c norm]/[c red]$alen[c norm]"
 284                         } elseif {![string is print $this_passed_arg]} {
 285                                 set this_passed_arg     "#<nonprint($alen)>"
 286                         } else {
 287                                 set this_passed_arg     [string map $substmap $this_passed_arg]
 288                                 set this_passed_arg     "[c underline bright white]$this_passed_arg[c norm]"
 289                         }
 290
 291                         lappend argdesc "[c green]$arg[c norm]$this_passed_arg"
 292                         incr idx
 293                 }
 294
 295                 set argtext     [join $argdesc " "]
 296
 297                 set outmsg      "${fqname_coloured} $argtext"
 298                 if {$msg != ""} {
 299                         set fg  "bright white"
 300                         if {$lvl >= 40} {
 301                                 set bg  "red"
 302                         } elseif {$lvl >= 30} {
 303                                 set bg  "purple"
 304                         } elseif {$lvl >= 20} {
 305                                 #set bg "green"
 306                                 #set fg "black"
 307                                 set bg  "blue"
 308                         } elseif {$lvl >= 10} {
 309                                 set bg  "blue"
 310                                 set fg  "yellow"
 311                         } else {
 312                                 set bg  "none"
 313                         }
 314                         append outmsg   ": [c bg_$bg $fg]$msg[c norm]"
 315                 }
 316
 317                 if {[info exists redir] && $redir != ""} {
 318                         uplevel #0 [list $redir $outmsg]
 319                 } elseif {[info exists remote]} {
 320                         puts $remote $outmsg
 321                 } else {
 322                         puts stderr $outmsg
 323                 }
 324         }
 325 }
 326
 327
 328 body tlc::Baselog::c {args} { #<<<1
 329         set build       ""
 330         foreach name $args {
 331                 switch -- [string tolower $name] {
 332                         "black"         {append build "\e\[30m"}
 333                         "red"           {append build "\e\[31m"}
 334                         "green"         {append build "\e\[32m"}
 335                         "yellow"        {append build "\e\[33m"}
 336                         "blue"          {append build "\e\[34m"}
 337                         "purple"        {append build "\e\[35m"}
 338                         "cyan"          {append build "\e\[36m"}
 339                         "white"         {append build "\e\[37m"}
 340                         "bg_black"      {append build "\e\[40m"}
 341                         "bg_red"        {append build "\e\[41m"}
 342                         "bg_green"      {append build "\e\[42m"}
 343                         "bg_yellow"     {append build "\e\[43m"}
 344                         "bg_blue"       {append build "\e\[44m"}
 345                         "bg_purple"     {append build "\e\[45m"}
 346                         "bg_cyan"       {append build "\e\[46m"}
 347                         "bg_white"      {append build "\e\[47m"}
 348                         "inverse"       {append build "\e\[7m"}
 349                         "bold"          {append build "\e\[5m"}
 350                         "underline"     {append build "\e\[4m"}
 351                         "bright"        {append build "\e\[1m"}
 352                         "norm"          {append build "\e\[0m"}
 353                         default         {append build ""}
 354                 }
 355         }
 356
 357         return $build
 358 }
 359
 360