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
}
}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:
#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