Here is a really simple version of this by davidw:
proc InCommand {} {
uplevel {puts [info level 0]}
}
proc newproc {name args body} {
set body "InCommand\n$body"
realproc $name $args $body
}
rename proc realproc
rename newproc procglennj: the following shows a little more than David's above, but less than Igor's below...
% proc introspectiveProc {name arguments body} {
set entryCode {
set thisproc [lindex [info level 0] 0]
for {set lvl 0} {$lvl > -[info level]} {incr lvl -1} {
set inf [info level $lvl]
set procname [lindex $inf 0]
set parms [lrange $inf 1 end]
puts [format "<%s> %4d: proc='%s', args={%s}" $thisproc $lvl $procname $parms]
}
}
set exitCode {puts "<$thisproc> returning"}
proc $name $arguments [concat $entryCode \; $body \; $exitCode]
}
% introspectiveProc foo args {
puts "here I am in foo"
}
% introspectiveProc bar args {
puts "bar: calling foo"
foo with "some args"
puts "bar: back from foo"
}
% proc main {} {
bar can take many parameters
}
% main
<bar> 0: proc='bar', args={can take many parameters}
<bar> -1: proc='main', args={}
bar: calling foo
<foo> 0: proc='foo', args={with {some args}}
<foo> -1: proc='bar', args={can take many parameters}
<foo> -2: proc='main', args={}
here I am in foo
<foo> returning
bar: back from foo
<bar> returningUsage:
- proctrace on ?-mute? ?pattern_list?
- proctrace off
proc ::proctrace {args} {
global proctrace_script_UnlIkELY_VARiAbLE_NaME
if {[info exists proctrace_script_UnlIkELY_VARiAbLE_NaME]} {
error "previous call is not complete"
}
# Check the first argument. Convert to boolean.
set onoff [lindex $args 0]
if {[string equal $onoff "on"]} {
set onoff 1
} elseif {[string equal $onoff "off"]} {
set onoff 0
}
if {$onoff != 1 && $onoff != 0} {
error "Invalid option \"$onoff\". Must be \"on\" or \"off\"."
}
set body_debug {
# This is the script which will be executed before
# each matching proc runs. It should be a single line.
set debug_line {puts -nonewline "Proctrace @ [clock format\
[clock seconds] -format {%T}]: ";\
catch {puts -nonewline "[lindex [info level -1] 0] --> "};\
puts "[info level 0]"}
}
global proctrace_guard_UnlIkELY_VARiAbLE_NaME
if {$onoff} {
if {[llength $args] > 3} {
error "wrong # of arguments"
}
if {[info exists proctrace_guard_UnlIkELY_VARiAbLE_NaME]} {
error "proc trace is already on"
}
# Parse subsequent arguments
if {[llength $args] > 1} {
set arg1 [lindex $args 1]
if {[string equal $arg1 "-mute"]} {
set mute 1
if {[llength $args] != 3} {
error "wrong # of arguments"
} else {
set name_patterns [lindex $args 2]
}
} else {
set mute 0
set name_patterns $arg1
}
} else {
set mute 1
set name_patterns {}
}
proc ::proctrace_existing_procs {namsp} {
namespace eval $namsp {
set prefix "[namespace current]::"
if {$prefix == "::::"} {
set prefix "::"
}
foreach shortname [info procs] {
set name ${prefix}$shortname
if {[string compare $name ::proctrace_existing_procs] && \
[string compare $name ::proctrace_proc] && \
[string compare $name ::proctrace]} {
set arglist {}
foreach argname [info args $name] {
if {[info default $name $argname value]} {
lappend arglist [list $argname $value]
} else {
lappend arglist $argname
}
}
::proctrace_proc $name $arglist [info body $name]
}
}
foreach child [namespace children] {
::proctrace_existing_procs $child
}
}
return
}
set body2 "foreach pattern \[list ${name_patterns}\] \\"
if {$mute} {
set body3 {{
if {[string match $pattern $name]} {
::proctrace_real_proc $name $arg $body
return
}
}
set newbody "${debug_line}\n$body"
::proctrace_real_proc $name $arg $newbody
return
}
} else {
set body3 {{
if {[string match $pattern $name]} {
set newbody "${debug_line}\n$body"
::proctrace_real_proc $name $arg $newbody
return
}
}
::proctrace_real_proc $name $arg $body
return
}
}
set fullbody [join [list $body_debug $body2 $body3] "\n"]
proc ::proctrace_proc {name arg body} $fullbody
rename ::proc ::proctrace_real_proc
::proctrace_real_proc ::proc {name arg body} $fullbody
# If we are not at level 1 then we have to replace the
# bodies of various procedures from an "after" script.
# Otherwise we probably have to preserve the procedures
# from which this procedure was called up to the top level
# of the stack.
set script {
::proctrace_existing_procs ::
rename ::proctrace_existing_procs {}
rename ::proctrace_proc {}
puts "proc trace is now on"
global proctrace_script_UnlIkELY_VARiAbLE_NaME
unset proctrace_script_UnlIkELY_VARiAbLE_NaME
}
set proctrace_script_UnlIkELY_VARiAbLE_NaME 1
if {[info level] > 1} {
after idle $script
} else {
eval $script
}
set proctrace_guard_UnlIkELY_VARiAbLE_NaME 1
} else {
if {[llength $args] > 1} {
error "wrong # of arguments"
}
if {[info exists proctrace_guard_UnlIkELY_VARiAbLE_NaME] == 0} {
error "proc trace is already off"
}
rename ::proc {}
rename ::proctrace_real_proc ::proc
proc ::proctrace_debug_line {} $body_debug
proc ::proctrace_undo {namsp} {
namespace eval $namsp {
set prefix "[namespace current]::"
if {$prefix == "::::"} {
set prefix "::"
}
foreach shortname [info procs] {
set name ${prefix}$shortname
set bodylines [split [info body $name] "\n"]
if {[string equal [lindex $bodylines 0] \
[::proctrace_debug_line]]} {
set newlines [lreplace $bodylines 0 0]
set newbody [join $newlines "\n"]
set arglist {}
foreach argname [info args $name] {
if {[info default $name $argname value]} {
lappend arglist [list $argname $value]
} else {
lappend arglist $argname
}
}
proc $name $arglist $newbody
}
}
foreach child [namespace children] {
::proctrace_undo $child
}
}
return
}
set script {
::proctrace_undo ::
rename ::proctrace_undo {}
rename ::proctrace_debug_line {}
puts "proc trace is now off"
global proctrace_script_UnlIkELY_VARiAbLE_NaME
unset proctrace_script_UnlIkELY_VARiAbLE_NaME
}
set proctrace_script_UnlIkELY_VARiAbLE_NaME 1
if {[info level] > 1} {
after idle $script
} else {
eval $script
}
unset proctrace_guard_UnlIkELY_VARiAbLE_NaME
}
return
}Zarutian 20. may 2005: so how can I find out if the current procedure were called by an native eventhandler (such as after or fileevent, etc)?
