CMcC 26Aug08

Debug is a package to produce debug narrative.  It is useful because a deselected debugging narrative stream is implemented as a very efficient ''noop'', so it encourages the user to create narratives as complex as necessary for understanding.

'''Usage'''

First declare a narrative stream thus:

   Debug on FOO 100

Where ''FOO'' is the narrative stream's name, and ''100'' is the level of interest we have in it.  By convention, higher numbers are more detailed.

Then, scatter narrative through your code thus:

   Debug.FOO {this is an arbitrary expression containing $vars [and exprs]} 10

If the level of interest of the narrative line is less than the currently assigned level of interest, the narrative is evaluated and the output sent to the stream's open file descriptor.


   # 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 {}
   }

----
!!!!!!
%| enter categories here |%
!!!!!!