Version 6 of TclOO trace filter

Updated 2010-01-18 10:47:39 by AMG

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

        # var_ is a class variable
        variable var_

        constructor args {

                # link instance var_ to the class variable var_
                my eval upvar [[self class] varname var_ ] var_

                # Initialize default values, but only when the first instance gets created. 
                # Subsequent instances will use the existing values
                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 {
                # avoid tracing of system methods
                if {[lindex [self target] 0] eq "::oo::object"} { return [next {*}$args] }
                my variable var_
                if {! $var_(trace)} { return [next {*}$args] }
                set caller {}

                # [self caller] returns error when used outside a class, but we need to trace method calls
                #   that originate outside the class, from a normal proc or a console
                if {[catch {
                        set caller [lrange [self caller] 1 end]
                }]} {
                        # outside caller
                        set caller [calledby]
                }
                set meth [lindex [self target] 1]

                # form a trace data item
                set i [list $caller [self] $meth $args]

                # method filter
                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]
                }

                # print trace item along with execution
                if {$var_(print)} { my print $i }

                # save trace item in history and limit history's length
                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]

                        # parse options

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

                # print a trace item
                puts [join "$caller -> $inst $meth"]$arg
        }
}
===
***Usage:***

Include '''mixin Trace''' in the definition of a class, to trace calls to class methods. Trace is class-wide, i.e. it traces method calls originating from any instances of the class using it, so that interactions between objects can be monitored in the same output. By changing class variable ''var_'' to an instance variable, the behaviour can change to per-class-instance trace, i.e. each instance will have a separate trace history. 

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 incr
2
% t get
2
# see the trace
% t trace
bin/tclkit8.6 -> ::t incr
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
3
% t get
3
% t trace
bin/tclkit8.6 -> ::t incr
bin/tclkit8.6 -> ::t get
bin/tclkit8.6 -> ::t get  <-- 'incr' was not traced, but the 'get' following it was