Version 3 of TclOO trace filter

Updated 2010-01-17 23:11:55 by dzach

Using the 'filter' subcommand to trace class method calls

dzach: For this code I've used Tclkit 8.6b1 (from Pat Thoyts's bleeding-edge builds ) that comes with TclOO in the core. Additions and corrections are welcome.


# When used inside a proc, 'calledby' returns the name of the caller of that proc. 
# This auxiliary proc is used to trace callers originating outside of class methods:
#
proc ::calledby {} {
        set level expr [info leve - 2]
        if { $level > 0 } {
                return lindex [info level $level 0] 
        } else {
                if { string length [info script ] > 0 } {
                        return info script
                } else {
                        return info nameofexecutable
                }
        }        
}
#
# The OO portion
#
namespace import ::oo::*
catch {Trace destroy}
class create Trace {
        self export varname
        filter Trace
        variable var_
        constructor args {
                my eval upvar [self class] varname var_ ] var_
                if {! info exists var_ } {
                        set var_(defaults) { trace on history {} length 20 methods {} mode exclude print off}
                        array set var_ $var_(defaults)
                }
                next {*}$args
        }
        method Trace args {
                if {lindex [self target 0] eq "::oo::object"} { return next {*}$args }
                my variable var_
                if {! $var_(trace)} { return next {*}$args }
                set caller {}
                if {[catch {
                        set caller lrange [self caller 1 end]
                }]} {
                        set caller calledby
                }
                set meth lindex [self target 1]
                set i list $caller [self $meth $args]
                if {string match "in*" $var_(mode) && $meth ni $var_(methods) || \
                    !string match "in*" $var_(mode) && ($meth in $var_(methods) || $meth eq "trace" || $meth eq "print")
                } {
                        return next {*}$args
                }
                if {$var_(print)} { my print $i }
                set var_(history) lrange [lappend var_(history) $i end-$var_(length) end]
                next {*}$args
        }
        method trace args {
                my variable var_
                while {$args ne {}} {
                        set opt  lindex $args 0
                        if {string index $opt 0 ne "-"} break
                        set i 1
                        switch -glob -- $opt {
                                -on - -of* { set var_(trace) string range $opt 1 end }
                                -le* {
                                        set var_(length) lindex $args $i
                                        incr var_(length) -1
                                        set var_(history) lrange $var_(history) end-$var_(length) end
                                        incr i
                                     }
                                -me* { set var_(methods) lindex $args $i ; incr i }
                                -mo* { set var_(mode) lindex $args $i    ; incr i }
                                -cl* { set var_(history) {} }
                                -re* { array set var_ $var_(defaults) }
                                -pr* {set var_(print) lindex $args $i    ;incr i }
                                default { error "unknown or ambiguous option $opt : may be any of -on, -off, -methods, -mode, -clear, reset or -print" }
                        }
                        incr i $i
                        set args lrange $args $i end
                }
                if {! $var_(trace)} {
                        return "History is turned off. Try \"self trace on\" to turn it on"
                }
                foreach i $var_(history) { my print $i }
        }
        method print args {
                        if {$args eq {}} return
                        lassign {*}$args caller inst meth arg
                        if {$arg ne {}} { set arg "\n\targs = $arg" }
                        puts join "$caller -> $inst $meth"$arg
        }
}

Usage:

Include 'mixin Trace' in the definition of a class. Output is sent to stdout using 'puts'. Use any of the following commands:

  • obj trace ? -on ? ? -off ? : turns tracing on/off. Default is off.
  • obj trace ? -clear ? : clears the history buffer.
  • obj trace ? -length integer ? : limits the number of history items to integer. Default history length is 20.
  • obj trace ? -methods list ? : list of methods to include/exclude, depending on -mode. The default is an empty list.
  • obj trace ? -mode include | exclude ? : include mode traces only methods incuded in -methods list while exclude mode traces all methods except those in the -methods list. Default mode is exclude. Methods trace and print of class Trace are not traced.
  • obj trace ? -print ? on ? ? -off ? : turns trace output during program execution on/off. Default is off.
  • obj trace ? -reset : resets tracing to the default values.

Demonstration:

# create a test class:
% class create c {
        mixin Trace
        constructor {} {my variable cnt; set cnt 0}
        method get {} {my variable cnt;puts $cnt}
        method incr {} {my variable cnt;incr cnt}
}
::c
# create an instance of the class
% c create t
::t

# produce some output
% t incr
1
% t get
1
# see the trace
% t trace
bin/tclkit8.6 -> ::t incr
bin/tclkit8.6 -> ::t get

# the default mode is 'exclude', so by setting '-methods incr' we exclude 'incr' from being traced
% t trace -methods incr
% t incr
2
% t get
2
% t trace
bin/tclkit8.6 -> ::t incr
bin/tclkit8.6 -> ::t get
bin/tclkit8.6 -> ::t get  <-- 'incr' was not traced

# by changing mode to 'include', the previously set '-methods incr' will leave 'incr' as the only method to trace
% t trace -mode include
% t incr
3
% t get
3
% t trace
bin/tclkit8.6 -> ::t incr
bin/tclkit8.6 -> ::t get
bin/tclkit8.6 -> ::t get
bin/tclkit8.6 -> ::t incr <-- 'get' was not traced

# limit the length of trace history items
% t trace -length 2
bin/tclkit8.6 -> ::t get
bin/tclkit8.6 -> ::t incr

# reset the values to the defaults
% t trace -reset

# turn on printing of traces during execution
% t trace -print on
% t incr
bin/tclkit8.6 -> ::t incr
4
% t get
bin/tclkit8.6 -> ::t get
4
% t trace
bin/tclkit8.6 -> ::t incr
bin/tclkit8.6 -> ::t get