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