dzach: For this code I've used Tclkit 8.6b1 (from Pat Thoyts's bleeding-edge builds [L1 ]) 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 level] - 2}]
if { $level > 0 } {
return [lindex [info level $level ] 0]
} else {
if { [info script] ne {} } {
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_ for global trace. Comment out for class-instance-wide trace
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] }
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 {
while {[llength $args]} {
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 {![llength $args]} 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 global, i.e. it traces method calls originating from any class using it, so that interactions between objects can be monitored in the same output. By changing class variable var_ to an instance variable, e.g. by commenting out my eval upvar [self class] varname var_ ] var_, the behaviour can change to class-instance-wide trace, i.e. each instance will have its own 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