Proctrace arranges for the proc execution sequence
to be printed on the standard output with time stamps.
Not as powerful as Tcl_CreateTrace but still useful
for taking a quick look at the sequence.

----
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 proc

----
[glennj]: 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> returning

----


Usage: 
 proctrace on ?-mute? ?pattern_list?
 proctrace off

By default, all procs are traced except the proctrace
itself. If a pattern list is specified then only those
procedures whose names match one of the patterns are traced.
The matching is performed with "string match" command.
If -mute switch is used then only the procedures which
do not match any of the patterns are traced.

Limitation: if proctrace is run not from the command
prompt but from a script, the application must use
the event loop.

Hope you'll find it useful...

Igor Volobouev


 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
 }