Version 1 of debug

Updated 2008-08-26 12:32:55 by CMcC

CMcC 26Aug08

Debug is a package to produce debug narrative.

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

---