1 # vim: ft=tcl foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4
5 variable baselog_threshold
""
6 variable baselog_instancename
""
10 method log
{lvl
{msg
""} args
}
17 common using_hotfuncs
0
40 proc remote_logging
{ip port
} {
41 set remote
[socket $ip $port]
42 fconfigure $remote -translation binary -encoding binary -blocking 1 -buffering none
45 proc load_classmap
{fn
} {
46 if {[catch {set fp
[open $fn r
]} errmsg
]} {
47 error "Problem opening classmap file: $errmsg"
53 array set tmp
[tlc
::decomment $dat]
55 error "Error parsing classmap: should be a list of key value pairs, optionally commented"
58 foreach {key val
} [array get tmp
] {
59 if {[info exists lvlmap
($val)]} {
62 if {![string is integer
-strict $val]} {
63 error "Log threshold for $key is not an integer or a valid symbolic level ($val)"
65 set classmap
($key) $val
69 proc load_hotfuncs
{fn
} {
70 if {[catch {set fp
[open $fn r
]} errmsg
]} {
71 error "Problem opening hotfuncs file: $errmsg"
77 array set tmp
[tlc
::decomment $dat]
79 error "Error parsing hotfuncs: should be a list of key value pairs, optionally commented"
82 foreach {key val
} [array get tmp
] {
83 if {[info exists lvlmap
($val)]} {
86 if {![string is integer
-strict $val]} {
87 error "Log threshold for $key is not an integer or a valid symbolic level ($val)"
89 set hotfuncs
($key) $val
95 proc timestamp_function
{func
} {
97 array unset helpers timestamp
99 set helpers
(timestamp
) $func
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]
110 if {[package vsatisfies
[info tclversion
] 8.5]} {
111 set now
[clock microseconds
]
113 set now
[expr {wide
([clock seconds
]) * 1000000}]
116 # Get a timestamp >>>
121 proc output_function
{func
} {
122 set helpers
(output
) $func
125 proc redir_output
{cb
} {
131 body tlc
::Baselog::log {lvl
{msg
""} args
} { #<<<1
132 # Get a 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]
139 # if {[package vsatisfies [info tclversion] 8.5]} {
140 # set now [clock microseconds]
142 # set now [expr {[clock seconds] * 1000000}]
145 # Get a timestamp >>>
150 array set switches
$args
151 if {[info exists switches
(-suppress)]} {
152 set switches
(-suppressed) $switches(-suppress)
154 if {![string is integer
-strict $lvl]} {
155 if {![info exists lvlmap
($lvl)]} {
158 set lvl
$lvlmap($lvl)
162 set caller_inf
[info level
-1]
163 set name
[lindex $caller_inf 0]
164 set passed_args
[lrange $caller_inf 1 end
]
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>"
172 set fqname
[uplevel 1 [list namespace origin
$name]]
173 set caller_args_def
[uplevel 1 [list info args
$name]]
176 set logzone
[namespace qualifiers
$fqname]
178 if {[info exists helpers
(output
)]} {
179 set output_cmd
[linsert [lrange $helpers(output
) 1 end
] 0 \
180 [lindex $helpers(output
) 0]]
182 set ns
[namespace qualifiers
$logzone]
183 set class
[namespace tail
$logzone]
184 set method
[namespace tail
$fqname]
186 set substmap
[list "\n" "%n" "\t" "%t" "%" "%%"]
189 foreach arg
$caller_args_def {
190 if {$arg == "args"} {
191 set this_passed_arg
[lrange $passed_args $idx end
]
193 set this_passed_arg
[lindex $passed_args $idx]
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
]
211 set this_passed_arg
[string map
$substmap $this_passed_arg]
212 set this_passed_arg_type
[list value_whole
$alen]
215 lappend argdesc
[list $arg $this_passed_arg $this_passed_arg_type]
219 uplevel #0 $output_cmd [list $now $baselog_instancename $ns $class $method $argdesc $lvl $msg]
221 if {$baselog_threshold != ""} {
222 set threshold
$baselog_threshold
223 } elseif
{[info exists classmap
($logzone)]} {
224 set threshold
$classmap($logzone)
226 set threshold
$::tlc::log(threshold
)
229 if {$lvl < $threshold} {
230 if {!($using_hotfuncs)} return
232 # Check our callers for a hotfunc <<<
234 set i
[expr {[info level
] - 1}]
242 set stackname
[lindex [info level
$i] 0]
243 if {$stackname == {}} continue
244 set fqname
[uplevel $depth [list namespace origin
$stackname]]
246 if {[info exists hotfuncs
($fqname)]} {
247 set threshold
$hotfuncs($fqname)
248 if {$lvl >= $threshold} break
251 if {$lvl < $threshold} return
252 # Check our callers for a hotfunc >>>
255 if {$baselog_instancename != ""} {
256 set instance_prefix
"[c red]$baselog_instancename[c norm] "
258 set instance_prefix
""
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]"
265 set substmap
[list "\n" "[c purple]\\n[c white]" "\t" "[c purple]\\t[c white]"]
268 foreach arg
$caller_args_def {
269 if {$arg == "args"} {
270 set this_passed_arg
[lrange $passed_args $idx end
]
272 set this_passed_arg
[lindex $passed_args $idx]
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)>"
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]"
291 lappend argdesc
"[c green]$arg[c norm]$this_passed_arg"
295 set argtext
[join $argdesc " "]
297 set outmsg
"${fqname_coloured} $argtext"
299 set fg
"bright white"
302 } elseif
{$lvl >= 30} {
304 } elseif
{$lvl >= 20} {
308 } elseif
{$lvl >= 10} {
314 append outmsg
": [c bg_$bg $fg]$msg[c norm]"
317 if {[info exists redir
] && $redir != ""} {
318 uplevel #0 [list $redir $outmsg]
319 } elseif
{[info exists remote
]} {
328 body tlc
::Baselog::c {args
} { #<<<1
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
""}