Tcl Library Source Code

2013-04-04  Andreas Kupries  <aku@hephaistos>

	* support/installation/modules.tcl (Module): 
	* modules/debug: debug narrator module adapted
	  from Colin McCormack's Debug wub utility package.

2013-03-21  Andreas Kupries  <[email protected]>

	* aclocal.m4: [Bug 3608581]: Extended check for executable
	* configure: extension to recognize an MSYS environment as Windows
	  and requiring a ".exe" suffix. Regenerated configure.

2013-03-11  Andreas Kupries  <[email protected]>

2013-04-08  Andreas Kupries <[email protected]>

	* debug.man: Added documentation.
	* debug_caller.man:
	* debug_heartbeat.man:
	* debug_timestamp.man:

2013-04-04  Andreas Kupries  <aku@hephaistos>

	* New module and packages for generating a debug
	  narrative. Adapted from the Wub utility package
	  Debug, by Colin McCormack.

## -*- tcl -*-
# ### ### ### ######### ######### #########

## Utility command for use as debug prefix command to un-mangle snit
## and TclOO method calls.

# ### ### ### ######### ######### #########
## Requisites

package require Tcl 8.5
package require debug

namespace eval ::debug {
    namespace export caller
    namespace ensemble create
}

# ### ### ### ######### ######### #########
## API & Implementation

proc ::debug::caller {} {
    # For snit (type)methods, rework the command line to be more
    # legible and in line with what the user would expect. To this end
    # we pull the primary command out of the arguments, be it type or
    # object, massage the command to match the original (type)method
    # name, then resort and expand the words to match the call before
    # the snit got its claws into it.

    set a [lassign [info level -1] m]
    regsub {.*Snit_} $m {} m
    switch -glob -- $m {
	htypemethod* {
	    # primary = type, a = type
	    set a [lassign $a primary]
	    set m [string map {_ { }} [string range $m 11 end]]
	}
	typemethod* {
	    # primary = type, a = type
	    set a [lassign $a primary]
	    set m [string range $m 10 end]
	}
	hmethod* {
	    # primary = self, a = type selfns self win ...
	    set a [lassign $a _ _ primary _]
	    set m [string map {_ { }} [string range $m 7 end]]
	}
	method* {
	    # primary = self, a = type selfns self win ...
	    set a [lassign $a _ _ primary _]
	    set m [string range $m 6 end]
	}
	destructor -
	constructor {
	    # primary = self, a = type selfns self win ...
	    set a [lassign $a _ _ primary _]
	}
	typeconstructor {
	    return [list {*}$a $m]
	}
	default {
	    # Unknown
	    return [list $m {*}$a]
	}
    }
    return [list $primary {*}$m {*}$a]
}

# ### ######### ###########################
## Ready for use

package provide debug::caller 1
return

[comment {-*- tcl -*- doctools manpage}]
[manpage_begin debug n 1]
[copyright {200?, Colin McCormack, Wub Server Utilities}]
[copyright {2012, Andreas Kupries <[email protected]>}]
[moddesc {debug narrative}]
[titledesc {debug narrative - core}]
[category  {debugging, tracing, and logging}]
[keywords debug trace log narrative]
[require Tcl 8.5]
[require debug [opt 1]]
[description]

Debugging areas of interest are represented by 'tags' which have
independently settable levels of interest (an integer, higher is more
detailed).

[section API]

[list_begin definitions]

[comment {= = == === ===== ======== ============= =====================}]
[call [cmd debug.[var tag]] [arg message] [opt [arg level]]]

For each known tag the package creates a command with this signatur
the user can then use to provide the debug narrative of the tag.

The narrative [arg message] is provided as a Tcl script whose value is
[cmd subst]ed in the caller's scope if and only if the current level of
interest for the [arg tag] matches or exceeds the call's [arg level]
of detail.  This is useful, as one can place arbitrarily complex
narrative in code without unnecessarily evaluating it.

[para] See methods [method level] and [method setting] for querying
and manipulating the current level of detail for tags.

[para] The actually printed text consists of not only the
[arg message], but also global and tag-specific prefix and suffix,
should they exist, with each line in the message having the specified
headers and trailers.

[para] All these parts are [cmd subst]ableTcl scripts, which are
substituted once per message before assembly.


[comment {= = == === ===== ======== ============= =====================}]
[call [cmd debug] [method 2array]]

This method returns a dictionary mapping the names of all debug tags
currently known to the package to their state and log level. The
latter are encoded in a single numeric value, where a negative number
indicates an inactive tag at the level given by the absolute value, and
a positive number is an active tag at that level.

[para] See also method [method settings] below.

[comment {= = == === ===== ======== ============= =====================}]
[call [cmd debug] [method define] [arg tag]]

This method registers the named [arg tag] with the package.  If the
tag was not known before it is placed in an inactive state. The state
of an already known tag is left untouched.

[para] The result of the method is the empty string.

[comment {= = == === ===== ======== ============= =====================}]
[call [cmd debug] [method header] [arg text]]

This method defines a global [cmd subst]able Tcl script which provides
a text printed before each line of output.

[para] Note how this is tag-independent.

[para] Further note that the header substitution happens only once per
actual printed message, i.e. all lines of the same message will have
the same actual heading text.

[para] The result of the method is the specified text.

[comment {= = == === ===== ======== ============= =====================}]
[call [cmd debug] [method level] [arg tag] [opt [arg level]] [opt [arg fd]]]

This method sets the detail-[arg level] for the [arg tag], and the
channel [arg fd] to write the tags narration into.

The level is an integer value >= 0 defaulting to [const 1].

The channel defaults to [const stderr].

[para] The result of the method is the new detail-level for the tag.

[comment {= = == === ===== ======== ============= =====================}]
[call [cmd debug] [method names]]

This method returns a list containing the names of all debug tags
currently known to the package.

[comment {= = == === ===== ======== ============= =====================}]
[call [cmd debug] [method off] [arg tag]]

This method registers the named [arg tag] with the package and sets it
inactive.

[para] The result of the method is the empty string.

[comment {= = == === ===== ======== ============= =====================}]
[call [cmd debug] [method on] [arg tag]]

This method registers the named [arg tag] with the package, as active.

[para] The result of the method is the empty string.

[comment {= = == === ===== ======== ============= =====================}]
[call [cmd debug] [method parray] [arg arrayvarname]]

This is a convenience method formatting the named array like the
builtin command [cmd parray], except it returns the resulting string
instead of writing it directly to [const stdout].

[para] This makes it suitable for use in debug messages.

[comment {= = == === ===== ======== ============= =====================}]
[call [cmd debug] [method pdict] [arg dict]]

This is a convenience method formatting the dictionary similarly to
how the builtin command [cmd parray] does for array, and returns the
resulting string.

[para] This makes it suitable for use in debug messages.

[comment {= = == === ===== ======== ============= =====================}]
[call [cmd debug] [method prefix] [arg tag] [opt [arg text]]]

This method is similar to the method [method header] above, in that it
defines [cmd subst]able Tcl script which provides more text for debug
messages.

[para] In contrast to [method header] the generated text is added to the
user's message before it is split into lines, making it a per-message
extension.

[para] Furthermore the script is tag-dependent.

[para] In exception to that, a script for tag [const ::] is applied
to all messages.

[para] If both global and tag-dependent prefix exist, both are
applied, with the global prefix coming before the tag-dependent
prefix.

[para] Note that the prefix substitution happens only once per
actual printed message.

[para] The result of the method is the empty string.

[para] If the [arg tag] was not known at the time of the call it is
registered, and set inactive.

[comment {= = == === ===== ======== ============= =====================}]
[call [cmd debug] [method setting] ([arg tag] [arg level]) ... [opt [arg fd]]]

This method is a multi-tag variant of method [method level] above,
with the functionality of methods [method on], and [method off] also
folded in.

[para] Each named [arg tag] is set to the detail-[arg level] following
it, with a negative level deactivating the tag, and a positive level
activating it.

[para] If the last argument is not followed by a level it is not
treated as tag name, but as the channel all the named tags should
print their messages to.

[para] The result of the method is the empty string.

[comment {= = == === ===== ======== ============= =====================}]
[call [cmd debug] [method suffix] [arg tag] [opt [arg text]]]

This method is similar to the method [method trailer] below, in that
it defines [cmd subst]able Tcl script which provides more text for
debug messages.

[para] In contrast to [method trailer] the generated text is added to
the user's message before it is split into lines, making it a
per-message extension.

[para] Furthermore the script is tag-dependent.

[para] In exception to that, a script for tag [const ::] is applied
to all messages.

[para] If both global and tag-dependent suffix exist, both are
applied, with the global suffix coming after the tag-dependent suffix.

[para] Note that the suffix substitution happens only once per actual
printed message.

[para] The result of the method is the empty string.

[para] If the [arg tag] was not known at the time of the call it is
registered, and set inactive.

[comment {= = == === ===== ======== ============= =====================}]
[call [cmd debug] [method trailer] [arg text]]

This method defines a global [cmd subst]able Tcl script which provides
a text printed after each line of output (before the EOL however).

[para] Note how this is tag-independent.

[para] Further note that the trailer substitution happens only once
per actual printed message, i.e. all lines of the same message will
have the same actual trailing text.

[para] The result of the method is the specified text.

[comment {= = == === ===== ======== ============= =====================}]
[list_end]

[section {BUGS, IDEAS, FEEDBACK}]

This document, and the package it describes, will undoubtedly contain
bugs and other problems.

Please report such in the category [emph debug] of the
[uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}].

Please also report any ideas for enhancements you may have for either
package and/or documentation.

[manpage_end]

# Debug - a debug narrative logger.
# -- Colin McCormack / originally Wub server utilities
#
# 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.)

# # ## ### ##### ######## ############# #####################
## Requisites

package require Tcl 8.5

namespace eval ::debug {
    namespace export -clear \
	define on off prefix suffix header trailer \
	names 2array level setting parray
    namespace ensemble create -subcommands {}
}

# # ## ### ##### ######## ############# #####################
## API & Implementation

proc ::debug::noop {args} {}

proc ::debug::debug {tag message {level 1}} {
    variable detail
    if {$detail($tag) < $level} {
	#puts stderr "$tag @@@ $detail($tag) >= $level"
	return
    }

    variable prefix
    variable suffix
    variable header
    variable trailer
    variable fds
    set fd $fds($tag)

    # Assemble the shown text from the user message and the various
    # prefixes and suffices (global + per-tag).

    set themessage ""
    if {[info exists prefix(::)]}   { append themessage $prefix(::)   }
    if {[info exists prefix($tag)]} { append themessage $prefix($tag) }
    append themessage $message
    if {[info exists suffix($tag)]} { append themessage $suffix($tag) }
    if {[info exists suffix(::)]}   { append themessage $suffix(::)   }

    # Resolve variables references and command invokations embedded
    # into the message with plain text.
    set code [catch {
	set smessage [uplevel 1 [list ::subst -nobackslashes $themessage]]
	set sheader  [uplevel 1 [list ::subst -nobackslashes $header]]
	set strailer [uplevel 1 [list ::subst -nobackslashes $trailer]]
    } __ eo]

    # And dump an internal error if that resolution failed.
    if {$code} {
	if {[catch {
	    set caller [info level -1]
	}]} { set caller GLOBAL }
	if {[string length $caller] >= 1000} {
	    set caller "[string range $caller 0 200]...[string range $caller end-200 end]"
	}
	foreach line [split $caller \n] {
	    puts -nonewline $fd "@@(DebugError from $tag ($eo): $line)"
	}
	return
    }

    # From here we have a good message to show. We only shorten it a
    # bit if its a bit excessive in size.

    if {[string length $smessage] > 4096} {
	set head [string range $smessage 0 2048]
	set tail [string range $smessage end-2048 end]
	set smessage "${head}...(truncated)...$tail"
    }

    foreach line [split $smessage \n] {
	puts $fd "$sheader$tag | $line$strailer"
    }
    return
}

# names - return names of debug tags
proc ::debug::names {} {
    variable detail
    return [lsort [array names detail]]
}

proc ::debug::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 ::debug::level {tag {level ""} {fd stderr}} {
    variable detail
    # TODO: Force level >=0.
    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)
}

proc ::debug::header  {text} { variable header  $text }
proc ::debug::trailer {text} { variable trailer $text }

proc ::debug::define {tag} {
    if {[interp alias {} debug.$tag] ne {}} return
    off $tag
    return
}

# Set a prefix/suffix to use for tag.
# The global (tag-independent) prefix/suffix is adressed through tag '::'.
# This works because colon (:) is an illegal character for user-specified tags.

proc ::debug::prefix {tag {theprefix {}}} {
    variable prefix
    set prefix($tag) $theprefix

    if {[interp alias {} debug.$tag] ne {}} return
    off $tag
    return
}

proc ::debug::suffix {tag {theprefix {}}} {
    variable suffix
    set suffix($tag) $theprefix

    if {[interp alias {} debug.$tag] ne {}} return
    off $tag
    return
}

# turn on debugging for tag
proc ::debug::on {tag {level ""} {fd stderr}} {
    variable active
    set active($tag) 1
    level $tag $level $fd
    interp alias {} debug.$tag {} ::debug::debug $tag
    return
}

# turn off debugging for tag
proc ::debug::off {tag {level ""} {fd stderr}} {
    variable active
    set active($tag) 1
    level $tag $level $fd
    interp alias {} debug.$tag {} ::debug::noop
    return
}

proc ::debug::setting {args} {
    if {[llength $args] == 1} {
	set args [lindex $args 0]
    }
    set fd stderr
    if {[llength $args] % 2} {
	set fd   [lindex $args end]
	set args [lrange $args 0 end-1]
    }
    foreach {tag level} $args {
	if {$level > 0} {
	    level $tag $level $fd
	    interp alias {} debug.$tag {} ::debug::debug $tag
	} else {
	    level $tag [expr {-$level}] $fd
	    interp alias {} debug.$tag {} ::debug::noop
	}
    }
    return
}

# # ## ### ##### ######## ############# #####################
## Convenience command. Format an array as multi-line message.

proc ::debug::parray {a {pattern *}} {
    upvar 1 $a array
    if {![array exists array]} {
	error "\"$a\" isn't an array"
    }
    pdict [array get array] $pattern
}

proc ::debug::pdict {dict {pattern *}} {
    set maxl 0
    set names [lsort -dict [dict keys $dict $pattern]]
    foreach name $names {
	if {[string length $name] > $maxl} {
	    set maxl [string length $name]
	}
    }
    set maxl [expr {$maxl + [string length $a] + 2}]
    set lines {}
    foreach name $names {
	set nameString [format %s(%s) $a $name]
	lappend lines [format "%-*s = %s" \
			   $maxl $nameString \
			   [dict get $dict $name]]
    }
    return [join $lines \n]
}

# # ## ### ##### ######## ############# #####################

namespace eval debug {
    variable detail     ; # map: TAG -> level of interest
    variable prefix     ; # map: TAG -> message prefix to use
    variable suffix     ; # map: TAG -> message suffix to use
    variable fds        ; # map: TAG -> handle of open channel to log to.
    variable header  {} ; # per-line heading, subst'ed
    variable trailer {} ; # per-line ending, subst'ed

    # Notes:
    # - The tag '::' is reserved. "prefix" and "suffix" use it to store
    #   the global message prefix / suffix.
    # - prefix and suffix are applied per message.
    # - header and trailer are per line. And should not generate multiple lines!
}

# # ## ### ##### ######## ############# #####################
## Ready

package provide debug 1.0
return

[comment {-*- tcl -*- doctools manpage}]
[manpage_begin debug::caller n 1]
[copyright {2012, Andreas Kupries <[email protected]>}]
[moddesc {debug narrative}]
[titledesc {debug narrative - caller}]
[category  {debugging, tracing, and logging}]
[keywords debug trace log narrative]
[require Tcl 8.5]
[require debug::caller [opt 1]]
[description]
[para]

[section API]

[list_begin definitions]
[call [cmd debug] [method caller]]

This method is at its core a simple [example {[info level -1]}],
making it useful in a tag-specific prefix to automatically
provide caller information for all uses of the tag. Or in a
message, when only specific places need such detail.

[para] Beyond that it contains code recognizing the various
internal forms of method calls generated by the [package snit]
OO system and rewrites these to their original form, for
better readability.

[list_end]

[section {BUGS, IDEAS, FEEDBACK}]

This document, and the package it describes, will undoubtedly contain
bugs and other problems.

Please report such in the category [emph debug] of the
[uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}].

Please also report any ideas for enhancements you may have for either
package and/or documentation.

[manpage_end]

[comment {-*- tcl -*- doctools manpage}]
[manpage_begin debug::heartbeat n 1]
[copyright {200?, Colin McCormack, Wub Server Utilities}]
[copyright {2012, Andreas Kupries <[email protected]>}]
[moddesc {debug narrative}]
[titledesc {debug narrative - heartbeat}]
[category  {debugging, tracing, and logging}]
[keywords debug trace log narrative heartbeat]
[require Tcl 8.5]
[require debug [opt 1]]
[description]
[para]

[section API]

[list_begin definitions]

[call [cmd debug] [method heartbeat] [opt [arg delta]]]

This method activates or disables a heartbeat with which to monitor
the event loop of an event-based Tcl application.

[para] It reserves the debug tag [const heartbeat] for its operation
and writes a message every [arg delta] milliseconds.

[para] A [arg delta]-value <= 0 disables the heartbeat.

[para] The message produced by the heartbeat contains a sequence
counter and the time in milliseconds since the last beat, thus
providing insight into timing variationsn and deviations from the
nominal [arg delta].

[list_end]

[section {BUGS, IDEAS, FEEDBACK}]

This document, and the package it describes, will undoubtedly contain
bugs and other problems.

Please report such in the category [emph debug] of the
[uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}].

Please also report any ideas for enhancements you may have for either
package and/or documentation.

[manpage_end]

[comment {-*- tcl -*- doctools manpage}]
[manpage_begin debug::timestamp n 1]
[copyright {200?, Colin McCormack, Wub Server Utilities}]
[copyright {2012, Andreas Kupries <[email protected]>}]
[moddesc {debug narrative}]
[titledesc {debug narrative - timestamping}]
[category  {debugging, tracing, and logging}]
[keywords debug trace log narrative timestamps]
[require Tcl 8.5]
[require debug [opt 1]]
[description]
[para]

[section API]

[list_begin definitions]

[call [cmd debug] [method timestamp]]

This method returns millisecond timing information since a baseline or
last call, making it useful in a tag-specific prefix to automatically
provide caller information for all uses of the tag. Or in a message,
when only specific places need such detail.

[list_end]

[section {BUGS, IDEAS, FEEDBACK}]

This document, and the package it describes, will undoubtedly contain
bugs and other problems.

Please report such in the category [emph debug] of the
[uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}].

Please also report any ideas for enhancements you may have for either
package and/or documentation.

[manpage_end]

# -*- tcl -*
# Debug -- Heartbeat. Track operation of Tcl's eventloop.
# -- Colin McCormack / originally Wub server utilities

# # ## ### ##### ######## ############# #####################
## Requisites

package require Tcl 8.5
package require debug

namespace eval ::debug {
    namespace export heartbeat
    namespace ensemble create
}

# # ## ### ##### ######## ############# #####################
## API & Implementation

proc ::debug::heartbeat {{delta 500}} {
    variable duration $delta
    variable timer

    if {$duration > 0} {
	# stop a previous heartbeat before starting the next
	catch { after cancel $timer }
	on heartbeat
	every $duration {
	    debug.heartbeat {[debug::pulse]}
	}
    } else {
	catch { after cancel $timer }
	off heartbeat
    }
}

proc ::debug::every {ms body} {
    eval $body
    variable timer [after $ms [info level 0]]
    return
}

proc ::debug::pulse {} {
    variable duration
    variable hbtimer
    variable heartbeat

    set now  [::tcl::clock::milliseconds]
    set diff [expr {$now - $hbtimer - $duration}]

    set hbtimer $now

    return [list [incr heartbeat] $diff]
}

# # ## ### ##### ######## ############# #####################

namespace eval ::debug {
    variable duration  0 ; # milliseconds between heart-beats
    variable heartbeat 0 ; # beat counter
    variable hbtimer   [::tcl::clock::milliseconds]
    variable timer
}

# # ## ### ##### ######## ############# #####################
## Ready

package provide debug::heartbeat 1
return

if {![package vsatisfies [package require Tcl] 8.5]} return
package ifneeded debug            1 [list source [file join $dir debug.tcl]]
package ifneeded debug::heartbeat 1 [list source [file join $dir heartbeat.tcl]]
package ifneeded debug::timestamp 1 [list source [file join $dir timestamp.tcl]]
package ifneeded debug::caller    1 [list source [file join $dir caller.tcl]]

# -*- tcl -*
# Debug -- Timestamps.
# -- Colin McCormack / originally Wub server utilities
#
# Generate timestamps for debug messages.
# The provided commands are for use in prefixes and headers.

# # ## ### ##### ######## ############# #####################
## Requisites

package require Tcl 8.5
package require debug

namespace eval ::debug {
    namespace export timestamp
    namespace ensemble create
}

# # ## ### ##### ######## ############# #####################
## API & Implementation

proc ::debug::timestamp {} {
    variable timestamp::delta
    variable timestamp::baseline

    set now [::tcl::clock::milliseconds]
    if {$delta} {
	set time "${now}-[expr {$now - $delta}]mS "
    } else {
	set time "${now}mS "
    }
    set delta $now
    return $time
}

# # ## ### ##### ######## ############# #####################

namespace eval ::debug::timestamp {
    variable delta    0
    variable baseline [::tcl::clock::milliseconds]
}

# # ## ### ##### ######## ############# #####################
## Ready

package provide debug::timestamp 1
return

Module  cmdline     _tcl  _man  _null
Module  comm        _tcl  _man  _null
Module  control      _tci _man  _null
Module  coroutine   _tcl _null  _null
Module  counter     _tcl  _man  _null
Module  crc         _tcl  _man  _null
Module  csv         _tcl  _man _exa
Module  debug       _tcl _null  _null
Module  des         _tcl  _man  _null
Module  dns          _msg _man _exa
Module  docstrip    _tcl  _man  _null
Module  doctools     _doc _man _exa
Module  doctools2base _tcl _man _null
Module  doctools2idx  _tcl _man _null
Module  doctools2toc  _tcl _man _null