Version 0 of TclOO trace filter

Updated 2010-01-17 21:51:42 by dzach

Using the 'filter' subcommand to trace class method calls

To use this code, Tcl 8.6 is needed.

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

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