# Debug - a debug narrative logger.
#
# Debugging areas of interest are represented by 'tokens' which have
# independantly settable levels of interest (an integer, higher is more detailed)
#
# Debug narrative is provided as a tcl script whose value is [subst]ed in the
# caller's scope if and only if the current level of interest matches or exceeds
# the Debug call's level of detail. This is useful, as one can place arbitrarily
# complex narrative in code without unnecessarily evaluating it.
#
# TODO: potentially different streams for different areas of interest.
# (currently only stderr is used. there is some complexity in efficient
# cross-threaded streams.)
package provide Debug 2.0
namespace eval Debug {
variable detail
variable level 0
variable fds
proc noop {args} {}
proc debug {tag message {level 1}} {
variable detail
if {$detail($tag) >= $level} {
variable fds
set fd $fds($tag)
set code [catch {
uplevel 1 ::subst -nobackslashes [list $message]
} result eo]
if {$code} {
set x [info level -1]
puts -nonewline $fd @@[string map {\n \\n \r \\r} "(DebugError from $tag [if {[string length $x] < 1000} {set x} else {set x "[string range $x 0 200]...[string range $x end-200 end]"}] ($eo)):"]
} else {
if {[string length $result] > 4096} {
set result "[string range $result 0 4096]...(truncated) ... [string range $result end-4096 end]"
}
puts $fd "$tag @@[string map {\n \\n} $result]"
}
} else {
#puts stderr "$tag @@@ $detail($tag) >= $level"
}
}
# names - return names of debug tags
proc names {} {
variable detail
return [lsort [array names detail]]
}
proc 2array {} {
variable detail
set result {}
foreach n [lsort [array names detail]] {
if {[interp alias {} Debug.$n] ne "::Debug::noop"} {
lappend result $n $detail($n)
} else {
lappend result $n -$detail($n)
}
}
return $result
}
# level - set level and fd for tag
proc level {tag {level ""} {fd stderr}} {
variable detail
if {$level ne ""} {
set detail($tag) $level
}
if {![info exists detail($tag)]} {
set detail($tag) 1
}
variable fds
set fds($tag) $fd
return $detail($tag)
}
# turn on debugging for tag
proc on {tag {level ""} {fd stderr}} {
level $tag $level $fd
interp alias {} Debug.$tag {} ::Debug::debug $tag
}
# turn off debugging for tag
proc off {tag {level ""} {fd stderr}} {
level $tag $level $fd
interp alias {} Debug.$tag {} ::Debug::noop
}
namespace export -clear *
namespace ensemble create -subcommands {}
}