# Commands covered: trace # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: trace.test,v 1.1.1.2 2009/03/23 15:10:42 duncan Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] testConstraint testevalobjv [llength [info commands testevalobjv]] proc getbytes {} { set lines [split [memory info] "\n"] lindex [lindex $lines 3] 3 } proc traceScalar {name1 name2 op} { global info set info [list $name1 $name2 $op [catch {uplevel set $name1} msg] $msg] } proc traceScalarAppend {name1 name2 op} { global info lappend info $name1 $name2 $op [catch {uplevel set $name1} msg] $msg } proc traceArray {name1 name2 op} { global info set info [list $name1 $name2 $op [catch {uplevel set [set name1]($name2)} msg] $msg] } proc traceArray2 {name1 name2 op} { global info set info [list $name1 $name2 $op] } proc traceProc {name1 name2 op} { global info set info [concat $info [list $name1 $name2 $op]] } proc traceTag {tag args} { global info set info [concat $info $tag] } proc traceError {args} { error "trace returned error" } proc traceCheck {cmd args} { global info set info [list [catch $cmd msg] $msg] } proc traceCrtElement {value name1 name2 op} { uplevel set ${name1}($name2) $value } proc traceCommand {oldName newName op} { global info set info [list $oldName $newName $op] } test trace-0.0 {memory corruption in trace (Tcl Bug 484339)} { # You may need Purify or Electric Fence to reliably # see this one fail. catch {unset z} trace add variable z array {set z(foo) 1 ;#} set res "names: [array names z]" catch {unset ::z} trace variable ::z w {unset ::z; error "memory corruption";#} list [catch {set ::z 1} msg] $msg } {1 {can't set "::z": memory corruption}} # Read-tracing on variables test trace-1.1 {trace variable reads} { catch {unset x} set info {} trace add variable x read traceScalar list [catch {set x} msg] $msg $info } {1 {can't read "x": no such variable} {x {} read 1 {can't read "x": no such variable}}} test trace-1.2 {trace variable reads} { catch {unset x} set x 123 set info {} trace add variable x read traceScalar list [catch {set x} msg] $msg $info } {0 123 {x {} read 0 123}} test trace-1.3 {trace variable reads} { catch {unset x} set info {} trace add variable x read traceScalar set x 123 set info } {} test trace-1.4 {trace array element reads} { catch {unset x} set info {} trace add variable x(2) read traceArray list [catch {set x(2)} msg] $msg $info } {1 {can't read "x(2)": no such element in array} {x 2 read 1 {can't read "x(2)": no such element in array}}} test trace-1.5 {trace array element reads} { catch {unset x} set x(2) zzz set info {} trace add variable x(2) read traceArray list [catch {set x(2)} msg] $msg $info } {0 zzz {x 2 read 0 zzz}} test trace-1.6 {trace array element reads} { catch {unset x} set info {} trace add variable x read traceArray2 proc p {} { global x set x(2) willi return $x(2) } list [catch {p} msg] $msg $info } {0 willi {x 2 read}} test trace-1.7 {trace array element reads, create element undefined if nonexistant} { catch {unset x} set info {} trace add variable x read q proc q {name1 name2 op} { global info set info [list $name1 $name2 $op] global $name1 set ${name1}($name2) wolf } proc p {} { global x set x(X) willi return $x(Y) } list [catch {p} msg] $msg $info } {0 wolf {x Y read}} test trace-1.8 {trace reads on whole arrays} { catch {unset x} set info {} trace add variable x read traceArray list [catch {set x(2)} msg] $msg $info } {1 {can't read "x(2)": no such variable} {}} test trace-1.9 {trace reads on whole arrays} { catch {unset x} set x(2) zzz set info {} trace add variable x read traceArray list [catch {set x(2)} msg] $msg $info } {0 zzz {x 2 read 0 zzz}} test trace-1.10 {trace variable reads} { catch {unset x} set x 444 set info {} trace add variable x read traceScalar unset x set info } {} test trace-1.11 {read traces that modify the array structure} { catch {unset x} set x(bar) 0 trace variable x r {set x(foo) 1 ;#} trace variable x r {unset -nocomplain x(bar) ;#} array get x } {} test trace-1.12 {read traces that modify the array structure} { catch {unset x} set x(bar) 0 trace variable x r {unset -nocomplain x(bar) ;#} trace variable x r {set x(foo) 1 ;#} array get x } {} test trace-1.13 {read traces that modify the array structure} { catch {unset x} set x(bar) 0 trace variable x r {set x(foo) 1 ;#} trace variable x r {unset -nocomplain x;#} list [catch {array get x} res] $res } {1 {can't read "x(bar)": no such variable}} test trace-1.14 {read traces that modify the array structure} { catch {unset x} set x(bar) 0 trace variable x r {unset -nocomplain x;#} trace variable x r {set x(foo) 1 ;#} list [catch {array get x} res] $res } {1 {can't read "x(bar)": no such variable}} # Basic write-tracing on variables test trace-2.1 {trace variable writes} { catch {unset x} set info {} trace add variable x write traceScalar set x 123 set info } {x {} write 0 123} test trace-2.2 {trace writes to array elements} { catch {unset x} set info {} trace add variable x(33) write traceArray set x(33) 444 set info } {x 33 write 0 444} test trace-2.3 {trace writes on whole arrays} { catch {unset x} set info {} trace add variable x write traceArray set x(abc) qq set info } {x abc write 0 qq} test trace-2.4 {trace variable writes} { catch {unset x} set x 1234 set info {} trace add variable x write traceScalar set x set info } {} test trace-2.5 {trace variable writes} { catch {unset x} set x 1234 set info {} trace add variable x write traceScalar unset x set info } {} test trace-2.6 {trace variable writes on compiled local} { # # Check correct function of whole array traces on compiled local # arrays [Bug 1770591]. The corresponding function for read traces is # already indirectly tested in trace-1.7 # catch {unset x} set info {} proc p {} { trace add variable x write traceArray set x(X) willy } p set info } {x X write 0 willy} test trace-2.7 {trace variable writes on errorInfo} -body { # # Check correct behaviour of write traces on errorInfo. # [Bug 1773040] trace add variable ::errorInfo write traceScalar catch {set dne} lrange [set info] 0 2 } -cleanup { # always remove trace on errorInfo otherwise further tests will fail unset ::errorInfo } -result {::errorInfo {} write} # append no longer triggers read traces when fetching the old values of # variables before doing the append operation. However, lappend _does_ # still trigger these read traces. Also lappend triggers only one write # trace: after appending all arguments to the list. test trace-3.1 {trace variable read-modify-writes} { catch {unset x} set info {} trace add variable x read traceScalarAppend append x 123 append x 456 lappend x 789 set info } {x {} read 0 123456} test trace-3.2 {trace variable read-modify-writes} { catch {unset x} set info {} trace add variable x {read write} traceScalarAppend append x 123 lappend x 456 set info } {x {} write 0 123 x {} read 0 123 x {} write 0 {123 456}} # Basic unset-tracing on variables test trace-4.1 {trace variable unsets} { catch {unset x} set info {} trace add variable x unset traceScalar catch {unset x} set info } {x {} unset 1 {can't read "x": no such variable}} test trace-4.2 {variable mustn't exist during unset trace} { catch {unset x} set x 1234 set info {} trace add variable x unset traceScalar unset x set info } {x {} unset 1 {can't read "x": no such variable}} test trace-4.3 {unset traces mustn't be called during reads and writes} { catch {unset x} set info {} trace add variable x unset traceScalar set x 44 set x set info } {} test trace-4.4 {trace unsets on array elements} { catch {unset x} set x(0) 18 set info {} trace add variable x(1) unset traceArray catch {unset x(1)} set info } {x 1 unset 1 {can't read "x(1)": no such element in array}} test trace-4.5 {trace unsets on array elements} { catch {unset x} set x(1) 18 set info {} trace add variable x(1) unset traceArray unset x(1) set info } {x 1 unset 1 {can't read "x(1)": no such element in array}} test trace-4.6 {trace unsets on array elements} { catch {unset x} set x(1) 18 set info {} trace add variable x(1) unset traceArray unset x set info } {x 1 unset 1 {can't read "x(1)": no such variable}} test trace-4.7 {trace unsets on whole arrays} { catch {unset x} set x(1) 18 set info {} trace add variable x unset traceProc catch {unset x(0)} set info } {} test trace-4.8 {trace unsets on whole arrays} { catch {unset x} set x(1) 18 set x(2) 144 set x(3) 14 set info {} trace add variable x unset traceProc unset x(1) set info } {x 1 unset} test trace-4.9 {trace unsets on whole arrays} { catch {unset x} set x(1) 18 set x(2) 144 set x(3) 14 set info {} trace add variable x unset traceProc unset x set info } {x {} unset} # Array tracing on variables test trace-5.1 {array traces fire on accesses via [array]} { catch {unset x} set x(b) 2 trace add variable x array traceArray2 set ::info {} array set x {a 1} set ::info } {x {} array} test trace-5.2 {array traces do not fire on normal accesses} { catch {unset x} set x(b) 2 trace add variable x array traceArray2 set ::info {} set x(a) 1 set x(b) $x(a) set ::info } {} test trace-5.3 {array traces do not outlive variable} { catch {unset x} trace add variable x array traceArray2 set ::info {} set x(a) 1 unset x array set x {a 1} set ::info } {} test trace-5.4 {array traces properly listed in trace information} { catch {unset x} trace add variable x array traceArray2 set result [trace info variable x] set result } [list [list array traceArray2]] test trace-5.5 {array traces properly listed in trace information} { catch {unset x} trace variable x a traceArray2 set result [trace vinfo x] set result } [list [list a traceArray2]] test trace-5.6 {array traces don't fire on scalar variables} { catch {unset x} set x foo trace add variable x array traceArray2 set ::info {} catch {array set x {a 1}} set ::info } {} test trace-5.7 {array traces fire for undefined variables} { catch {unset x} trace add variable x array traceArray2 set ::info {} array set x {a 1} set ::info } {x {} array} test trace-5.8 {array traces fire for undefined variables} { catch {unset x} trace add variable x array {set x(foo) 1 ;#} set res "names: [array names x]" } {names: foo} # Trace multiple trace types at once. test trace-6.1 {multiple ops traced at once} { catch {unset x} set info {} trace add variable x {read write unset} traceProc catch {set x} set x 22 set x set x 33 unset x set info } {x {} read x {} write x {} read x {} write x {} unset} test trace-6.2 {multiple ops traced on array element} { catch {unset x} set info {} trace add variable x(0) {read write unset} traceProc catch {set x(0)} set x(0) 22 set x(0) set x(0) 33 unset x(0) unset x set info } {x 0 read x 0 write x 0 read x 0 write x 0 unset} test trace-6.3 {multiple ops traced on whole array} { catch {unset x} set info {} trace add variable x {read write unset} traceProc catch {set x(0)} set x(0) 22 set x(0) set x(0) 33 unset x(0) unset x set info } {x 0 write x 0 read x 0 write x 0 unset x {} unset} # Check order of invocation of traces test trace-7.1 {order of invocation of traces} { catch {unset x} set info {} trace add variable x read "traceTag 1" trace add variable x read "traceTag 2" trace add variable x read "traceTag 3" catch {set x} set x 22 set x set info } {3 2 1 3 2 1} test trace-7.2 {order of invocation of traces} { catch {unset x} set x(0) 44 set info {} trace add variable x(0) read "traceTag 1" trace add variable x(0) read "traceTag 2" trace add variable x(0) read "traceTag 3" set x(0) set info } {3 2 1} test trace-7.3 {order of invocation of traces} { catch {unset x} set x(0) 44 set info {} trace add variable x(0) read "traceTag 1" trace add variable x read "traceTag A1" trace add variable x(0) read "traceTag 2" trace add variable x read "traceTag A2" trace add variable x(0) read "traceTag 3" trace add variable x read "traceTag A3" set x(0) set info } {A3 A2 A1 3 2 1} # Check effects of errors in trace procedures test trace-8.1 {error returns from traces} { catch {unset x} set x 123 set info {} trace add variable x read "traceTag 1" trace add variable x read traceError list [catch {set x} msg] $msg $info } {1 {can't read "x": trace returned error} {}} test trace-8.2 {error returns from traces} { catch {unset x} set x 123 set info {} trace add variable x write "traceTag 1" trace add variable x write traceError list [catch {set x 44} msg] $msg $info } {1 {can't set "x": trace returned error} {}} test trace-8.3 {error returns from traces} { catch {unset x} set x 123 set info {} trace add variable x write traceError list [catch {append x 44} msg] $msg $info } {1 {can't set "x": trace returned error} {}} test trace-8.4 {error returns from traces} { catch {unset x} set x 123 set info {} trace add variable x unset "traceTag 1" trace add variable x unset traceError list [catch {unset x} msg] $msg $info } {0 {} 1} test trace-8.5 {error returns from traces} { catch {unset x} set x(0) 123 set info {} trace add variable x(0) read "traceTag 1" trace add variable x read "traceTag 2" trace add variable x read traceError trace add variable x read "traceTag 3" list [catch {set x(0)} msg] $msg $info } {1 {can't read "x(0)": trace returned error} 3} test trace-8.6 {error returns from traces} { catch {unset x} set x 123 trace add variable x unset traceError list [catch {unset x} msg] $msg } {0 {}} test trace-8.7 {error returns from traces} { # This test just makes sure that the memory for the error message # gets deallocated correctly when the trace is invoked again or # when the trace is deleted. catch {unset x} set x 123 trace add variable x read traceError catch {set x} catch {set x} trace remove variable x read traceError } {} test trace-8.8 {error returns from traces} { # Yet more elaborate memory corruption testing that checks nothing # bad happens when the trace deletes itself and installs something # new. Alas, there is no neat way to guarantee that this test will # fail if there is a problem, but that's life and with the new code # it should *never* fail. # # Adapted from Bug #219393 reported by Don Porter. catch {rename ::foo {}} proc foo {old args} { trace remove variable ::x write [list foo $old] trace add variable ::x write [list foo $::x] error "foo" } catch {unset ::x ::y} set x junk trace add variable ::x write [list foo $x] for {set y 0} {$y<100} {incr y} { catch {set x junk} } unset x } {} # Check to see that variables are expunged before trace # procedures are invoked, so trace procedure can even manipulate # a new copy of the variables. test trace-9.1 {be sure variable is unset before trace is called} { catch {unset x} set x 33 set info {} trace add variable x unset {traceCheck {uplevel set x}} unset x set info } {1 {can't read "x": no such variable}} test trace-9.2 {be sure variable is unset before trace is called} { catch {unset x} set x 33 set info {} trace add variable x unset {traceCheck {uplevel set x 22}} unset x concat $info [list [catch {set x} msg] $msg] } {0 22 0 22} test trace-9.3 {be sure traces are cleared before unset trace called} { catch {unset x} set x 33 set info {} trace add variable x unset {traceCheck {uplevel trace info variable x}} unset x set info } {0 {}} test trace-9.4 {set new trace during unset trace} { catch {unset x} set x 33 set info {} trace add variable x unset {traceCheck {global x; trace add variable x unset traceProc}} unset x concat $info [trace info variable x] } {0 {} {unset traceProc}} test trace-10.1 {make sure array elements are unset before traces are called} { catch {unset x} set x(0) 33 set info {} trace add variable x(0) unset {traceCheck {uplevel set x(0)}} unset x(0) set info } {1 {can't read "x(0)": no such element in array}} test trace-10.2 {make sure array elements are unset before traces are called} { catch {unset x} set x(0) 33 set info {} trace add variable x(0) unset {traceCheck {uplevel set x(0) zzz}} unset x(0) concat $info [list [catch {set x(0)} msg] $msg] } {0 zzz 0 zzz} test trace-10.3 {array elements are unset before traces are called} { catch {unset x} set x(0) 33 set info {} trace add variable x(0) unset {traceCheck {global x; trace info variable x(0)}} unset x(0) set info } {0 {}} test trace-10.4 {set new array element trace during unset trace} { catch {unset x} set x(0) 33 set info {} trace add variable x(0) unset {traceCheck {uplevel {trace add variable x(0) read {}}}} catch {unset x(0)} concat $info [trace info variable x(0)] } {0 {} {read {}}} test trace-11.1 {make sure arrays are unset before traces are called} { catch {unset x} set x(0) 33 set info {} trace add variable x unset {traceCheck {uplevel set x(0)}} unset x set info } {1 {can't read "x(0)": no such variable}} test trace-11.2 {make sure arrays are unset before traces are called} { catch {unset x} set x(y) 33 set info {} trace add variable x unset {traceCheck {uplevel set x(y) 22}} unset x concat $info [list [catch {set x(y)} msg] $msg] } {0 22 0 22} test trace-11.3 {make sure arrays are unset before traces are called} { catch {unset x} set x(y) 33 set info {} trace add variable x unset {traceCheck {uplevel array exists x}} unset x set info } {0 0} test trace-11.4 {make sure arrays are unset before traces are called} { catch {unset x} set x(y) 33 set info {} set cmd {traceCheck {uplevel {trace info variable x}}} trace add variable x unset $cmd unset x set info } {0 {}} test trace-11.5 {set new array trace during unset trace} { catch {unset x} set x(y) 33 set info {} trace add variable x unset {traceCheck {global x; trace add variable x read {}}} unset x concat $info [trace info variable x] } {0 {} {read {}}} test trace-11.6 {create scalar during array unset trace} { catch {unset x} set x(y) 33 set info {} trace add variable x unset {traceCheck {global x; set x 44}} unset x concat $info [list [catch {set x} msg] $msg] } {0 44 0 44} # Check special conditions (e.g. errors) in Tcl_TraceVar2. test trace-12.1 {creating array when setting variable traces} { catch {unset x} set info {} trace add variable x(0) write traceProc list [catch {set x 22} msg] $msg } {1 {can't set "x": variable is array}} test trace-12.2 {creating array when setting variable traces} { catch {unset x} set info {} trace add variable x(0) write traceProc list [catch {set x(0)} msg] $msg } {1 {can't read "x(0)": no such element in array}} test trace-12.3 {creating array when setting variable traces} { catch {unset x} set info {} trace add variable x(0) write traceProc set x(0) 22 set info } {x 0 write} test trace-12.4 {creating variable when setting variable traces} { catch {unset x} set info {} trace add variable x write traceProc list [catch {set x} msg] $msg } {1 {can't read "x": no such variable}} test trace-12.5 {creating variable when setting variable traces} { catch {unset x} set info {} trace add variable x write traceProc set x 22 set info } {x {} write} test trace-12.6 {creating variable when setting variable traces} { catch {unset x} set info {} trace add variable x write traceProc set x(0) 22 set info } {x 0 write} test trace-12.7 {create array element during read trace} { catch {unset x} set x(2) zzz trace add variable x read {traceCrtElement xyzzy} list [catch {set x(3)} msg] $msg } {0 xyzzy} test trace-12.8 {errors when setting variable traces} { catch {unset x} set x 44 list [catch {trace add variable x(0) write traceProc} msg] $msg } {1 {can't trace "x(0)": variable isn't array}} # Check trace deletion test trace-13.1 {delete one trace from another} { proc delTraces {args} { global x trace remove variable x read {traceTag 2} trace remove variable x read {traceTag 3} trace remove variable x read {traceTag 4} } catch {unset x} set x 44 set info {} trace add variable x read {traceTag 1} trace add variable x read {traceTag 2} trace add variable x read {traceTag 3} trace add variable x read {traceTag 4} trace add variable x read delTraces trace add variable x read {traceTag 5} set x set info } {5 1} test trace-13.2 {leak when unsetting traced variable} \ -constraints memory -body { set end [getbytes] proc f args {} for {set i 0} {$i < 5} {incr i} { trace add variable bepa write f set bepa a unset bepa set tmp $end set end [getbytes] } expr {$end - $tmp} } -cleanup { unset -nocomplain end i tmp } -result 0 test trace-13.3 {leak when removing traces} \ -constraints memory -body { set end [getbytes] proc f args {} for {set i 0} {$i < 5} {incr i} { trace add variable bepa write f set bepa a trace remove variable bepa write f set tmp $end set end [getbytes] } expr {$end - $tmp} } -cleanup { unset -nocomplain end i tmp } -result 0 test trace-13.4 {leaks in error returns from traces} \ -constraints memory -body { set end [getbytes] for {set i 0} {$i < 5} {incr i} { set apa {a 1 b 2} set bepa [lrange $apa 0 end] trace add variable bepa write {error hej} catch {set bepa a} unset bepa set tmp $end set end [getbytes] } expr {$end - $tmp} } -cleanup { unset -nocomplain end i tmp } -result 0 # Check operation and syntax of "trace" command. # Syntax for adding/removing variable and command traces is basically the # same: # trace add variable name opList command # trace remove variable name opList command # # The following loops just get all the common "wrong # args" tests done. set i 0 set start "wrong # args:" foreach type {variable command} { foreach op {add remove} { test trace-14.0.[incr i] "trace command, wrong # args errors" { list [catch {trace $op $type} msg] $msg } [list 1 "$start should be \"trace $op $type name opList command\""] test trace-14.0.[incr i] "trace command wrong # args errors" { list [catch {trace $op $type foo} msg] $msg } [list 1 "$start should be \"trace $op $type name opList command\""] test trace-14.0.[incr i] "trace command, wrong # args errors" { list [catch {trace $op $type foo bar} msg] $msg } [list 1 "$start should be \"trace $op $type name opList command\""] test trace-14.0.[incr i] "trace command, wrong # args errors" { list [catch {trace $op $type foo bar baz boo} msg] $msg } [list 1 "$start should be \"trace $op $type name opList command\""] } test trace-14.0.[incr i] "trace command, wrong # args errors" { list [catch {trace info $type foo bar} msg] $msg } [list 1 "$start should be \"trace info $type name\""] test trace-14.0.[incr i] "trace command, wrong # args errors" { list [catch {trace info $type} msg] $msg } [list 1 "$start should be \"trace info $type name\""] } test trace-14.1 "trace command, wrong # args errors" { list [catch {trace} msg] $msg } [list 1 "wrong # args: should be \"trace option ?arg arg ...?\""] test trace-14.2 "trace command, wrong # args errors" { list [catch {trace add} msg] $msg } [list 1 "wrong # args: should be \"trace add type ?arg arg ...?\""] test trace-14.3 "trace command, wrong # args errors" { list [catch {trace remove} msg] $msg } [list 1 "wrong # args: should be \"trace remove type ?arg arg ...?\""] test trace-14.4 "trace command, wrong # args errors" { list [catch {trace info} msg] $msg } [list 1 "wrong # args: should be \"trace info type ?arg arg ...?\""] test trace-14.5 {trace command, invalid option} { list [catch {trace gorp} msg] $msg } [list 1 "bad option \"gorp\": must be add, info, remove, variable, vdelete, or vinfo"] # Again, [trace ... command] and [trace ... variable] share syntax and # error message styles for their opList options; these loops test those # error messages. set i 0 set errs [list "array, read, unset, or write" "delete or rename" "enter, leave, enterstep, or leavestep"] set abbvs [list {a r u w} {d r} {}] proc x {} {} foreach type {variable command execution} err $errs abbvlist $abbvs { foreach op {add remove} { test trace-14.6.[incr i] "trace $op $type errors" { list [catch {trace $op $type x {y z w} a} msg] $msg } [list 1 "bad operation \"y\": must be $err"] foreach abbv $abbvlist { test trace-14.6.[incr i] "trace $op $type rejects abbreviations" { list [catch {trace $op $type x $abbv a} msg] $msg } [list 1 "bad operation \"$abbv\": must be $err"] } test trace-14.6.[incr i] "trace $op $type rejects null opList" { list [catch {trace $op $type x {} a} msg] $msg } [list 1 "bad operation list \"\": must be one or more of $err"] } } rename x {} test trace-14.7 {trace command, "trace variable" errors} { list [catch {trace variable} msg] $msg } [list 1 "wrong # args: should be \"trace variable name ops command\""] test trace-14.8 {trace command, "trace variable" errors} { list [catch {trace variable x} msg] $msg } [list 1 "wrong # args: should be \"trace variable name ops command\""] test trace-14.9 {trace command, "trace variable" errors} { list [catch {trace variable x y} msg] $msg } [list 1 "wrong # args: should be \"trace variable name ops command\""] test trace-14.10 {trace command, "trace variable" errors} { list [catch {trace variable x y z w} msg] $msg } [list 1 "wrong # args: should be \"trace variable name ops command\""] test trace-14.11 {trace command, "trace variable" errors} { list [catch {trace variable x y z} msg] $msg } [list 1 "bad operations \"y\": should be one or more of rwua"] test trace-14.12 {trace command ("remove variable" option)} { catch {unset x} set info {} trace add variable x write traceProc trace remove variable x write traceProc } {} test trace-14.13 {trace command ("remove variable" option)} { catch {unset x} set info {} trace add variable x write traceProc trace remove variable x write traceProc set x 12345 set info } {} test trace-14.14 {trace command ("remove variable" option)} { catch {unset x} set info {} trace add variable x write {traceTag 1} trace add variable x write traceProc trace add variable x write {traceTag 2} set x yy trace remove variable x write traceProc set x 12345 trace remove variable x write {traceTag 1} set x foo trace remove variable x write {traceTag 2} set x gorp set info } {2 x {} write 1 2 1 2} test trace-14.15 {trace command ("remove variable" option)} { catch {unset x} set info {} trace add variable x write {traceTag 1} trace remove variable x write non_existent set x 12345 set info } {1} test trace-14.16 {trace command ("info variable" option)} { catch {unset x} trace add variable x write {traceTag 1} trace add variable x write traceProc trace add variable x write {traceTag 2} trace info variable x } {{write {traceTag 2}} {write traceProc} {write {traceTag 1}}} test trace-14.17 {trace command ("info variable" option)} { catch {unset x} trace info variable x } {} test trace-14.18 {trace command ("info variable" option)} { catch {unset x} trace info variable x(0) } {} test trace-14.19 {trace command ("info variable" option)} { catch {unset x} set x 44 trace info variable x(0) } {} test trace-14.20 {trace command ("info variable" option)} { catch {unset x} set x 44 trace add variable x write {traceTag 1} proc check {} {global x; trace info variable x} check } {{write {traceTag 1}}} # Check fancy trace commands (long ones, weird arguments, etc.) test trace-15.1 {long trace command} { catch {unset x} set info {} trace add variable x write {traceTag {This is a very very long argument. It's \ designed to test out the facilities of TraceVarProc for dealing \ with such long arguments by malloc-ing space. One possibility \ is that space doesn't get freed properly. If this happens, then \ invoking this test over and over again will eventually leak memory.}} set x 44 set info } {This is a very very long argument. It's \ designed to test out the facilities of TraceVarProc for dealing \ with such long arguments by malloc-ing space. One possibility \ is that space doesn't get freed properly. If this happens, then \ invoking this test over and over again will eventually leak memory.} test trace-15.2 {long trace command result to ignore} { proc longResult {args} {return "quite a bit of text, designed to generate a core leak if this command file is invoked over and over again and memory isn't being recycled correctly"} catch {unset x} trace add variable x write longResult set x 44 set x 5 set x abcde } abcde test trace-15.3 {special list-handling in trace commands} { catch {unset "x y z"} set "x y z(a\n\{)" 44 set info {} trace add variable "x y z(a\n\{)" write traceProc set "x y z(a\n\{)" 33 set info } "{x y z} a\\n\\\{ write" # Check for proper handling of unsets during traces. proc traceUnset {unsetName args} { global info upvar $unsetName x lappend info [catch {unset x} msg] $msg [catch {set x} msg] $msg } proc traceReset {unsetName resetName args} { global info upvar $unsetName x $resetName y lappend info [catch {unset x} msg] $msg [catch {set y xyzzy} msg] $msg } proc traceReset2 {unsetName resetName args} { global info lappend info [catch {uplevel unset $unsetName} msg] $msg \ [catch {uplevel set $resetName xyzzy} msg] $msg } proc traceAppend {string name1 name2 op} { global info lappend info $string } test trace-16.1 {unsets during read traces} { catch {unset y} set y 1234 set info {} trace add variable y read {traceUnset y} trace add variable y unset {traceAppend unset} lappend info [catch {set y} msg] $msg } {unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}} test trace-16.2 {unsets during read traces} { catch {unset y} set y(0) 1234 set info {} trace add variable y(0) read {traceUnset y(0)} lappend info [catch {set y(0)} msg] $msg } {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such element in array}} test trace-16.3 {unsets during read traces} { catch {unset y} set y(0) 1234 set info {} trace add variable y(0) read {traceUnset y} lappend info [catch {set y(0)} msg] $msg } {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}} test trace-16.4 {unsets during read traces} { catch {unset y} set y 1234 set info {} trace add variable y read {traceReset y y} lappend info [catch {set y} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-16.5 {unsets during read traces} { catch {unset y} set y(0) 1234 set info {} trace add variable y(0) read {traceReset y(0) y(0)} lappend info [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-16.6 {unsets during read traces} { catch {unset y} set y(0) 1234 set info {} trace add variable y(0) read {traceReset y y(0)} lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 1 {can't set "y": upvar refers to element in deleted array} 1 {can't read "y(0)": no such variable} 1 {can't read "y(0)": no such variable}} test trace-16.7 {unsets during read traces} { catch {unset y} set y(0) 1234 set info {} trace add variable y(0) read {traceReset2 y y(0)} lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 1 {can't read "y(0)": no such element in array} 0 xyzzy} test trace-16.8 {unsets during write traces} { catch {unset y} set y 1234 set info {} trace add variable y write {traceUnset y} trace add variable y unset {traceAppend unset} lappend info [catch {set y xxx} msg] $msg } {unset 0 {} 1 {can't read "x": no such variable} 0 {}} test trace-16.9 {unsets during write traces} { catch {unset y} set y(0) 1234 set info {} trace add variable y(0) write {traceUnset y(0)} lappend info [catch {set y(0) xxx} msg] $msg } {0 {} 1 {can't read "x": no such variable} 0 {}} test trace-16.10 {unsets during write traces} { catch {unset y} set y(0) 1234 set info {} trace add variable y(0) write {traceUnset y} lappend info [catch {set y(0) xxx} msg] $msg } {0 {} 1 {can't read "x": no such variable} 0 {}} test trace-16.11 {unsets during write traces} { catch {unset y} set y 1234 set info {} trace add variable y write {traceReset y y} lappend info [catch {set y xxx} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-16.12 {unsets during write traces} { catch {unset y} set y(0) 1234 set info {} trace add variable y(0) write {traceReset y(0) y(0)} lappend info [catch {set y(0) xxx} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-16.13 {unsets during write traces} { catch {unset y} set y(0) 1234 set info {} trace add variable y(0) write {traceReset y y(0)} lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 1 {can't set "y": upvar refers to element in deleted array} 0 {} 1 {can't read "y(0)": no such variable}} test trace-16.14 {unsets during write traces} { catch {unset y} set y(0) 1234 set info {} trace add variable y(0) write {traceReset2 y y(0)} lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 0 {} 0 xyzzy} test trace-16.15 {unsets during unset traces} { catch {unset y} set y 1234 set info {} trace add variable y unset {traceUnset y} lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg } {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y": no such variable}} test trace-16.16 {unsets during unset traces} { catch {unset y} set y(0) 1234 set info {} trace add variable y(0) unset {traceUnset y(0)} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such element in array}} test trace-16.17 {unsets during unset traces} { catch {unset y} set y(0) 1234 set info {} trace add variable y(0) unset {traceUnset y} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such variable}} test trace-16.18 {unsets during unset traces} { catch {unset y} set y 1234 set info {} trace add variable y unset {traceReset2 y y} lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg } {1 {can't unset "y": no such variable} 0 xyzzy 0 {} 0 xyzzy} test trace-16.19 {unsets during unset traces} { catch {unset y} set y(0) 1234 set info {} trace add variable y(0) unset {traceReset2 y(0) y(0)} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {1 {can't unset "y(0)": no such element in array} 0 xyzzy 0 {} 0 xyzzy} test trace-16.20 {unsets during unset traces} { catch {unset y} set y(0) 1234 set info {} trace add variable y(0) unset {traceReset2 y y(0)} lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg } {0 {} 0 xyzzy 0 {} 0 xyzzy} test trace-16.21 {unsets cancelling traces} { catch {unset y} set y 1234 set info {} trace add variable y read {traceAppend first} trace add variable y read {traceUnset y} trace add variable y read {traceAppend third} trace add variable y unset {traceAppend unset} lappend info [catch {set y} msg] $msg } {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}} test trace-16.22 {unsets cancelling traces} { catch {unset y} set y(0) 1234 set info {} trace add variable y(0) read {traceAppend first} trace add variable y(0) read {traceUnset y} trace add variable y(0) read {traceAppend third} trace add variable y(0) unset {traceAppend unset} lappend info [catch {set y(0)} msg] $msg } {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}} # Check various non-interference between traces and other things. test trace-17.1 {trace doesn't prevent unset errors} { catch {unset x} set info {} trace add variable x unset {traceProc} list [catch {unset x} msg] $msg $info } {1 {can't unset "x": no such variable} {x {} unset}} test trace-17.2 {traced variables must survive procedure exits} { catch {unset x} proc p1 {} {global x; trace add variable x write traceProc} p1 trace info variable x } {{write traceProc}} test trace-17.3 {traced variables must survive procedure exits} { catch {unset x} set info {} proc p1 {} {global x; trace add variable x write traceProc} p1 set x 44 set info } {x {} write} # Be sure that procedure frames are released before unset traces # are invoked. test trace-18.1 {unset traces on procedure returns} { proc p1 {x y} {set a 44; p2 14} proc p2 {z} {trace add variable z unset {traceCheck {lsort [uplevel {info vars}]}}} set info {} p1 foo bar set info } {0 {a x y}} test trace-18.2 {namespace delete / trace vdelete combo} { namespace eval ::foo { variable x 123 } proc p1 args { trace vdelete ::foo::x u p1 } trace variable ::foo::x u p1 namespace delete ::foo info exists ::foo::x } 0 test trace-18.3 {namespace delete / trace vdelete combo, Bug \#1337229} { namespace eval ::ns {} trace add variable ::ns::var unset {unset ::ns::var ;#} namespace delete ::ns } {} test trace-18.4 {namespace delete / trace vdelete combo, Bug \#1338280} { namespace eval ::ref {} set ::ref::var1 AAA trace add variable ::ref::var1 unset doTrace set ::ref::var2 BBB trace add variable ::ref::var2 {unset} doTrace proc doTrace {vtraced vidx op} { global info append info [catch {set ::$vtraced}][llength [info vars ::ref::*]] } set info {} namespace delete ::ref rename doTrace {} set info } 1110 # Delete arrays when done, so they can be re-used as scalars # elsewhere. catch {unset x} catch {unset y} test trace-19.0.1 {trace add command (command existence)} { # Just in case! catch {rename nosuchname ""} list [catch {trace add command nosuchname rename traceCommand} msg] $msg } {1 {unknown command "nosuchname"}} test trace-19.0.2 {trace add command (command existence in ns)} { list [catch {trace add command nosuchns::nosuchname rename traceCommand} msg] $msg } {1 {unknown command "nosuchns::nosuchname"}} test trace-19.1 {trace add command (rename option)} { proc foo {} {} catch {rename bar {}} trace add command foo rename traceCommand rename foo bar set info } {::foo ::bar rename} test trace-19.2 {traces stick with renamed commands} { proc foo {} {} catch {rename bar {}} trace add command foo rename traceCommand rename foo bar rename bar foo set info } {::bar ::foo rename} test trace-19.2.1 {trace add command rename trace exists} { proc foo {} {} trace add command foo rename traceCommand trace info command foo } {{rename traceCommand}} test trace-19.3 {command rename traces don't fire on command deletion} { proc foo {} {} set info {} trace add command foo rename traceCommand rename foo {} set info } {} test trace-19.4 {trace add command rename doesn't trace recreated commands} { proc foo {} {} catch {rename bar {}} trace add command foo rename traceCommand proc foo {} {} rename foo bar set info } {} test trace-19.5 {trace add command deleted removes traces} { proc foo {} {} trace add command foo rename traceCommand proc foo {} {} trace info command foo } {} namespace eval tc {} proc tc::tcfoo {} {} test trace-19.6 {trace add command rename in namespace} { trace add command tc::tcfoo rename traceCommand rename tc::tcfoo tc::tcbar set info } {::tc::tcfoo ::tc::tcbar rename} test trace-19.7 {trace add command rename in namespace back again} { rename tc::tcbar tc::tcfoo set info } {::tc::tcbar ::tc::tcfoo rename} test trace-19.8 {trace add command rename in namespace to out of namespace} { rename tc::tcfoo tcbar set info } {::tc::tcfoo ::tcbar rename} test trace-19.9 {trace add command rename back into namespace} { rename tcbar tc::tcfoo set info } {::tcbar ::tc::tcfoo rename} test trace-19.10 {trace add command failed rename doesn't trigger trace} { set info {} proc foo {} {} proc bar {} {} trace add command foo {rename delete} traceCommand catch {rename foo bar} set info } {} catch {rename foo {}} catch {rename bar {}} test trace-19.11 {trace add command qualifies when renamed in namespace} { set info {} namespace eval tc {rename tcfoo tcbar} set info } {::tc::tcfoo ::tc::tcbar rename} # Make sure it exists again proc foo {} {} test trace-20.1 {trace add command (delete option)} { trace add command foo delete traceCommand rename foo "" set info } {::foo {} delete} test trace-20.2 {trace add command delete doesn't trace recreated commands} { set info {} proc foo {} {} rename foo "" set info } {} test trace-20.2.1 {trace add command delete trace info} { proc foo {} {} trace add command foo delete traceCommand trace info command foo } {{delete traceCommand}} test trace-20.3 {trace add command implicit delete} { proc foo {} {} trace add command foo delete traceCommand proc foo {} {} set info } {::foo {} delete} test trace-20.3.1 {trace add command delete trace info} { proc foo {} {} trace info command foo } {} test trace-20.4 {trace add command rename followed by delete} { set infotemp {} proc foo {} {} trace add command foo {rename delete} traceCommand rename foo bar lappend infotemp $info rename bar {} lappend infotemp $info set info $infotemp unset infotemp set info } {{::foo ::bar rename} {::bar {} delete}} catch {rename foo {}} catch {rename bar {}} test trace-20.5 {trace add command rename and delete} { set infotemp {} set info {} proc foo {} {} trace add command foo {rename delete} traceCommand rename foo bar lappend infotemp $info rename bar {} lappend infotemp $info set info $infotemp unset infotemp set info } {{::foo ::bar rename} {::bar {} delete}} test trace-20.6 {trace add command rename and delete in subinterp} { set tc [interp create] foreach p {traceCommand} { $tc eval [list proc $p [info args $p] [info body $p]] } $tc eval [list set infotemp {}] $tc eval [list set info {}] $tc eval [list proc foo {} {}] $tc eval [list trace add command foo {rename delete} traceCommand] $tc eval [list rename foo bar] $tc eval {lappend infotemp $info} $tc eval [list rename bar {}] $tc eval {lappend infotemp $info} $tc eval {set info $infotemp} $tc eval [list unset infotemp] set info [$tc eval [list set info]] interp delete $tc set info } {{::foo ::bar rename} {::bar {} delete}} # I'd like it if this test could give 'foo {} d' as a result, # but interp deletion means there is no interp to evaluate # the trace in. test trace-20.7 {trace add command delete in subinterp while being deleted} { set info {} set tc [interp create] interp alias $tc traceCommand {} traceCommand $tc eval [list proc foo {} {}] $tc eval [list trace add command foo {rename delete} traceCommand] interp delete $tc set info } {} proc traceDelete {cmd old new op} { eval trace remove command $cmd [lindex [trace info command $cmd] 0] global info set info [list $old $new $op] } proc traceCmdrename {cmd old new op} { rename $old someothername } proc traceCmddelete {cmd old new op} { rename $old "" } test trace-20.8 {trace delete while trace is active} { set info {} proc foo {} {} catch {rename bar {}} trace add command foo {rename delete} [list traceDelete foo] rename foo bar list [set info] [trace info command bar] } {{::foo ::bar rename} {}} test trace-20.9 {rename trace deletes command} { set info {} proc foo {} {} catch {rename bar {}} catch {rename someothername {}} trace add command foo rename [list traceCmddelete foo] rename foo bar list [info commands foo] [info commands bar] [info commands someothername] } {{} {} {}} test trace-20.10 {rename trace renames command} { set info {} proc foo {} {} catch {rename bar {}} catch {rename someothername {}} trace add command foo rename [list traceCmdrename foo] rename foo bar set info [list [info commands foo] [info commands bar] [info commands someothername]] rename someothername {} set info } {{} {} someothername} test trace-20.11 {delete trace deletes command} { set info {} proc foo {} {} catch {rename bar {}} catch {rename someothername {}} trace add command foo delete [list traceCmddelete foo] rename foo {} list [info commands foo] [info commands bar] [info commands someothername] } {{} {} {}} test trace-20.12 {delete trace renames command} { set info {} proc foo {} {} catch {rename bar {}} catch {rename someothername {}} trace add command foo delete [list traceCmdrename foo] rename foo bar rename bar {} # None of these should exist. list [info commands foo] [info commands bar] [info commands someothername] } {{} {} {}} test trace-20.13 {rename trace discards result [Bug 1355342]} { proc foo {} {} trace add command foo rename {set w Aha!;#} list [rename foo bar] [rename bar {}] } {{} {}} test trace-20.14 {rename trace discards error result [Bug 1355342]} { proc foo {} {} trace add command foo rename {error} list [rename foo bar] [rename bar {}] } {{} {}} test trace-20.15 {delete trace discards result [Bug 1355342]} { proc foo {} {} trace add command foo delete {set w Aha!;#} rename foo {} } {} test trace-20.16 {delete trace discards error result [Bug 1355342]} { proc foo {} {} trace add command foo delete {error} rename foo {} } {} proc foo {b} { set a $b } # Delete arrays when done, so they can be re-used as scalars # elsewhere. catch {unset x} catch {unset y} # Delete procedures when done, so we don't clash with other tests # (e.g. foobar will clash with 'unknown' tests). catch {rename foobar {}} catch {rename foo {}} catch {rename bar {}} proc foo {a} { set b $a } proc traceExecute {args} { global info lappend info $args } test trace-21.1 {trace execution: enter} { set info {} trace add execution foo enter [list traceExecute foo] foo 1 trace remove execution foo enter [list traceExecute foo] set info } {{foo {foo 1} enter}} test trace-21.2 {trace exeuction: leave} { set info {} trace add execution foo leave [list traceExecute foo] foo 2 trace remove execution foo leave [list traceExecute foo] set info } {{foo {foo 2} 0 2 leave}} test trace-21.3 {trace exeuction: enter, leave} { set info {} trace add execution foo {enter leave} [list traceExecute foo] foo 3 trace remove execution foo {enter leave} [list traceExecute foo] set info } {{foo {foo 3} enter} {foo {foo 3} 0 3 leave}} test trace-21.4 {trace execution: enter, leave, enterstep} { set info {} trace add execution foo {enter leave enterstep} [list traceExecute foo] foo 3 trace remove execution foo {enter leave enterstep} [list traceExecute foo] set info } {{foo {foo 3} enter} {foo {set b 3} enterstep} {foo {foo 3} 0 3 leave}} test trace-21.5 {trace execution: enter, leave, enterstep, leavestep} { set info {} trace add execution foo {enter leave enterstep leavestep} [list traceExecute foo] foo 3 trace remove execution foo {enter leave enterstep leavestep} [list traceExecute foo] set info } {{foo {foo 3} enter} {foo {set b 3} enterstep} {foo {set b 3} 0 3 leavestep} {foo {foo 3} 0 3 leave}} test trace-21.6 {trace execution: enterstep, leavestep} { set info {} trace add execution foo {enterstep leavestep} [list traceExecute foo] foo 3 trace remove execution foo {enterstep leavestep} [list traceExecute foo] set info } {{foo {set b 3} enterstep} {foo {set b 3} 0 3 leavestep}} test trace-21.7 {trace execution: enterstep} { set info {} trace add execution foo {enterstep} [list traceExecute foo] foo 3 trace remove execution foo {enterstep} [list traceExecute foo] set info } {{foo {set b 3} enterstep}} test trace-21.8 {trace execution: leavestep} { set info {} trace add execution foo {leavestep} [list traceExecute foo] foo 3 trace remove execution foo {leavestep} [list traceExecute foo] set info } {{foo {set b 3} 0 3 leavestep}} test trace-21.9 {trace execution: TCL_EVAL_GLOBAL} testevalobjv { trace add execution foo enter soom proc ::soom args {lappend ::info SUCCESS [info level]} set ::info {} namespace eval test_ns_1 { proc soom args {lappend ::info FAIL [info level]} # [testevalobjv 1 ...] ought to produce the same # results as [uplevel #0 ...]. testevalobjv 1 foo x uplevel #0 foo x } namespace delete test_ns_1 trace remove execution foo enter soom set ::info } {SUCCESS 1 SUCCESS 1} test trace-21.10 {trace execution: TCL_EVAL_GLOBAL} testevalobjv { trace add execution foo leave soom proc ::soom args {lappend ::info SUCCESS [info level]} set ::info {} namespace eval test_ns_1 { proc soom args {lappend ::info FAIL [info level]} # [testevalobjv 1 ...] ought to produce the same # results as [uplevel #0 ...]. testevalobjv 1 foo x uplevel #0 foo x } namespace delete test_ns_1 trace remove execution foo leave soom set ::info } {SUCCESS 1 SUCCESS 1} test trace-21.11 {trace execution and alias} -setup { set res {} proc ::x {} {return ::} namespace eval a {} proc ::a::x {} {return ::a} interp alias {} y {} x } -body { lappend res [namespace eval ::a y] trace add execution ::x enter { rename ::x {} proc ::x {} {return ::} #} lappend res [namespace eval ::a y] } -cleanup { namespace delete a rename ::x {} } -result {:: ::} proc factorial {n} { if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] } return 1 } test trace-22.1 {recursive(1) trace execution: enter} { set info {} trace add execution factorial {enter} [list traceExecute factorial] factorial 1 trace remove execution factorial {enter} [list traceExecute factorial] set info } {{factorial {factorial 1} enter}} test trace-22.2 {recursive(2) trace execution: enter} { set info {} trace add execution factorial {enter} [list traceExecute factorial] factorial 2 trace remove execution factorial {enter} [list traceExecute factorial] set info } {{factorial {factorial 2} enter} {factorial {factorial 1} enter}} test trace-22.3 {recursive(3) trace execution: enter} { set info {} trace add execution factorial {enter} [list traceExecute factorial] factorial 3 trace remove execution factorial {enter} [list traceExecute factorial] set info } {{factorial {factorial 3} enter} {factorial {factorial 2} enter} {factorial {factorial 1} enter}} test trace-23.1 {recursive(1) trace execution: enter, leave, enterstep, leavestep} { set info {} trace add execution factorial {enter leave enterstep leavestep} [list traceExecute] factorial 1 trace remove execution factorial {enter leave enterstep leavestep} [list traceExecute] join $info "\n" } {{factorial 1} enter {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 0 {} leavestep {return 1} enterstep {return 1} 2 1 leavestep {factorial 1} 0 1 leave} test trace-23.2 {recursive(2) trace execution: enter, leave, enterstep, leavestep} { set info {} trace add execution factorial {enter leave enterstep leavestep} [list traceExecute] factorial 2 trace remove execution factorial {enter leave enterstep leavestep} [list traceExecute] join $info "\n" } {{factorial 2} enter {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep {expr {$n * [factorial [expr {$n -1 }]]}} enterstep {expr {$n -1 }} enterstep {expr {$n -1 }} 0 1 leavestep {factorial 1} enterstep {factorial 1} enter {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 0 {} leavestep {return 1} enterstep {return 1} 2 1 leavestep {factorial 1} 0 1 leave {factorial 1} 0 1 leavestep {expr {$n * [factorial [expr {$n -1 }]]}} 0 2 leavestep {return 2} enterstep {return 2} 2 2 leavestep {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 2 2 leavestep {factorial 2} 0 2 leave} test trace-23.3 {recursive(3) trace execution: enter, leave, enterstep, leavestep} { set info {} trace add execution factorial {enter leave enterstep leavestep} [list traceExecute] factorial 3 trace remove execution factorial {enter leave enterstep leavestep} [list traceExecute] join $info "\n" } {{factorial 3} enter {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep {expr {$n * [factorial [expr {$n -1 }]]}} enterstep {expr {$n -1 }} enterstep {expr {$n -1 }} 0 2 leavestep {factorial 2} enterstep {factorial 2} enter {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep {expr {$n * [factorial [expr {$n -1 }]]}} enterstep {expr {$n -1 }} enterstep {expr {$n -1 }} 0 1 leavestep {factorial 1} enterstep {factorial 1} enter {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 0 {} leavestep {return 1} enterstep {return 1} 2 1 leavestep {factorial 1} 0 1 leave {factorial 1} 0 1 leavestep {expr {$n * [factorial [expr {$n -1 }]]}} 0 2 leavestep {return 2} enterstep {return 2} 2 2 leavestep {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 2 2 leavestep {factorial 2} 0 2 leave {factorial 2} 0 2 leavestep {expr {$n * [factorial [expr {$n -1 }]]}} 0 6 leavestep {return 6} enterstep {return 6} 2 6 leavestep {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 2 6 leavestep {factorial 3} 0 6 leave} proc traceDelete {cmd args} { eval trace remove execution $cmd [lindex [trace info execution $cmd] 0] global info set info $args } test trace-24.1 {delete trace during enter trace} { set info {} trace add execution foo enter [list traceDelete foo] foo 1 list $info [catch {trace info execution foo} res] $res } {{{foo 1} enter} 0 {}} test trace-24.2 {delete trace during leave trace} { set info {} trace add execution foo leave [list traceDelete foo] foo 1 list $info [catch {trace info execution foo} res] $res } {{{foo 1} 0 1 leave} 0 {}} test trace-24.3 {delete trace during enter-leave trace} { set info {} trace add execution foo {enter leave} [list traceDelete foo] foo 1 list $info [catch {trace info execution foo} res] $res } {{{foo 1} enter} 0 {}} test trace-24.4 {delete trace during all exec traces} { set info {} trace add execution foo {enter leave enterstep leavestep} [list traceDelete foo] foo 1 list $info [catch {trace info execution foo} res] $res } {{{foo 1} enter} 0 {}} test trace-24.5 {delete trace during all exec traces except enter} { set info {} trace add execution foo {leave enterstep leavestep} [list traceDelete foo] foo 1 list $info [catch {trace info execution foo} res] $res } {{{set b 1} enterstep} 0 {}} proc traceDelete {cmd args} { rename $cmd {} global info set info $args } proc foo {a} { set b $a } test trace-25.1 {delete command during enter trace} { set info {} trace add execution foo enter [list traceDelete foo] catch {foo 1} err list $err $info [catch {trace info execution foo} res] $res } {{invalid command name "foo"} {{foo 1} enter} 1 {unknown command "foo"}} proc foo {a} { set b $a } test trace-25.2 {delete command during leave trace} { set info {} trace add execution foo leave [list traceDelete foo] foo 1 list $info [catch {trace info execution foo} res] $res } {{{foo 1} 0 1 leave} 1 {unknown command "foo"}} proc foo {a} { set b $a } test trace-25.3 {delete command during enter then leave trace} { set info {} trace add execution foo enter [list traceDelete foo] trace add execution foo leave [list traceDelete foo] catch {foo 1} err list $err $info [catch {trace info execution foo} res] $res } {{invalid command name "foo"} {{foo 1} enter} 1 {unknown command "foo"}} proc foo {a} { set b $a } proc traceExecute2 {args} { global info lappend info $args } # This shows the peculiar consequences of having two traces # at the same time: as well as tracing the procedure you want test trace-25.4 {order dependencies of two enter traces} { set info {} trace add execution foo enter [list traceExecute traceExecute] trace add execution foo enter [list traceExecute2 traceExecute2] catch {foo 1} err trace remove execution foo enter [list traceExecute traceExecute] trace remove execution foo enter [list traceExecute2 traceExecute2] join [list $err [join $info \n] [trace info execution foo]] "\n" } {1 traceExecute2 {foo 1} enter traceExecute {foo 1} enter } test trace-25.5 {order dependencies of two step traces} { set info {} trace add execution foo enterstep [list traceExecute traceExecute] trace add execution foo enterstep [list traceExecute2 traceExecute2] catch {foo 1} err trace remove execution foo enterstep [list traceExecute traceExecute] trace remove execution foo enterstep [list traceExecute2 traceExecute2] join [list $err [join $info \n] [trace info execution foo]] "\n" } {1 traceExecute2 {set b 1} enterstep traceExecute {set b 1} enterstep } # We don't want the result string (5th argument), or the results # will get unmanageable. proc tracePostExecute {args} { global info lappend info [concat [lrange $args 0 2] [lindex $args 4]] } proc tracePostExecute2 {args} { global info lappend info [concat [lrange $args 0 2] [lindex $args 4]] } test trace-25.6 {order dependencies of two leave traces} { set info {} trace add execution foo leave [list tracePostExecute tracePostExecute] trace add execution foo leave [list tracePostExecute2 tracePostExecute2] catch {foo 1} err trace remove execution foo leave [list tracePostExecute tracePostExecute] trace remove execution foo leave [list tracePostExecute2 tracePostExecute2] join [list $err [join $info \n] [trace info execution foo]] "\n" } {1 tracePostExecute {foo 1} 0 leave tracePostExecute2 {foo 1} 0 leave } test trace-25.7 {order dependencies of two leavestep traces} { set info {} trace add execution foo leavestep [list tracePostExecute tracePostExecute] trace add execution foo leavestep [list tracePostExecute2 tracePostExecute2] catch {foo 1} err trace remove execution foo leavestep [list tracePostExecute tracePostExecute] trace remove execution foo leavestep [list tracePostExecute2 tracePostExecute2] join [list $err [join $info \n] [trace info execution foo]] "\n" } {1 tracePostExecute {set b 1} 0 leavestep tracePostExecute2 {set b 1} 0 leavestep } proc foo {a} { set b $a } proc traceDelete {cmd args} { rename $cmd {} global info set info $args } test trace-25.8 {delete command during enter leave and enter/leave-step traces} { set info {} trace add execution foo enter [list traceDelete foo] trace add execution foo leave [list traceDelete foo] trace add execution foo enterstep [list traceDelete foo] trace add execution foo leavestep [list traceDelete foo] catch {foo 1} err list $err $info [catch {trace info execution foo} res] $res } {{invalid command name "foo"} {{foo 1} enter} 1 {unknown command "foo"}} proc foo {a} { set b $a } test trace-25.9 {delete command during enter leave and leavestep traces} { set info {} trace add execution foo enter [list traceDelete foo] trace add execution foo leave [list traceDelete foo] trace add execution foo leavestep [list traceDelete foo] catch {foo 1} err list $err $info [catch {trace info execution foo} res] $res } {{invalid command name "foo"} {{foo 1} enter} 1 {unknown command "foo"}} proc foo {a} { set b $a } test trace-25.10 {delete command during leave and leavestep traces} { set info {} trace add execution foo leave [list traceDelete foo] trace add execution foo leavestep [list traceDelete foo] catch {foo 1} err list $err $info [catch {trace info execution foo} res] $res } {1 {{set b 1} 0 1 leavestep} 1 {unknown command "foo"}} proc foo {a} { set b $a } test trace-25.11 {delete command during enter and enterstep traces} { set info {} trace add execution foo enter [list traceDelete foo] trace add execution foo enterstep [list traceDelete foo] catch {foo 1} err list $err $info [catch {trace info execution foo} res] $res } {{invalid command name "foo"} {{foo 1} enter} 1 {unknown command "foo"}} test trace-26.1 {trace targetCmd when invoked through an alias} { proc foo {args} { set b $args } set info {} trace add execution foo enter [list traceExecute foo] interp alias {} bar {} foo 1 bar 2 trace remove execution foo enter [list traceExecute foo] set info } {{foo {foo 1 2} enter}} test trace-26.2 {trace targetCmd when invoked through an alias} { proc foo {args} { set b $args } set info {} trace add execution foo enter [list traceExecute foo] interp create child interp alias child bar {} foo 1 child eval bar 2 interp delete child trace remove execution foo enter [list traceExecute foo] set info } {{foo {foo 1 2} enter}} test trace-27.1 {memory leak in rename trace (604609)} { catch {rename bar {}} proc foo {} {error foo} trace add command foo rename {rename foo "" ;#} rename foo bar info commands foo } {} test trace-27.2 {command trace remove nonsense} { list [catch {trace remove command thisdoesntexist \ {delete rename} bar} res] $res } {1 {unknown command "thisdoesntexist"}} test trace-27.3 {command trace info nonsense} { list [catch {trace info command thisdoesntexist} res] $res } {1 {unknown command "thisdoesntexist"}} test trace-28.1 {enterstep and leavestep traces with update idletasks (615043)} { catch {rename foo {}} proc foo {} { set a 1 update idletasks set b 1 } set info {} trace add execution foo {enter enterstep leavestep leave} \ [list traceExecute foo] update after idle {set a "idle"} foo trace remove execution foo {enter enterstep leavestep leave} \ [list traceExecute foo] rename foo {} catch {unset a} join $info "\n" } {foo foo enter foo {set a 1} enterstep foo {set a 1} 0 1 leavestep foo {update idletasks} enterstep foo {set a idle} enterstep foo {set a idle} 0 idle leavestep foo {update idletasks} 0 {} leavestep foo {set b 1} enterstep foo {set b 1} 0 1 leavestep foo foo 0 1 leave} test trace-28.2 {exec traces with 'error'} { set info {} set res {} proc foo {} { if {[catch {bar}]} { return "error" } else { return "ok" } } proc bar {} { error "msg" } lappend res [foo] trace add execution foo {enter enterstep leave leavestep} \ [list traceExecute foo] # With the trace active lappend res [foo] trace remove execution foo {enter enterstep leave leavestep} \ [list traceExecute foo] list $res [join $info \n] } {{error error} {foo foo enter foo {if {[catch {bar}]} { return "error" } else { return "ok" }} enterstep foo {catch bar} enterstep foo bar enterstep foo {error msg} enterstep foo {error msg} 1 msg leavestep foo bar 1 msg leavestep foo {catch bar} 0 1 leavestep foo {return error} enterstep foo {return error} 2 error leavestep foo {if {[catch {bar}]} { return "error" } else { return "ok" }} 2 error leavestep foo foo 0 error leave}} test trace-28.3 {exec traces with 'return -code error'} { set info {} set res {} proc foo {} { if {[catch {bar}]} { return "error" } else { return "ok" } } proc bar {} { return -code error "msg" } lappend res [foo] trace add execution foo {enter enterstep leave leavestep} \ [list traceExecute foo] # With the trace active lappend res [foo] trace remove execution foo {enter enterstep leave leavestep} \ [list traceExecute foo] list $res [join $info \n] } {{error error} {foo foo enter foo {if {[catch {bar}]} { return "error" } else { return "ok" }} enterstep foo {catch bar} enterstep foo bar enterstep foo {return -code error msg} enterstep foo {return -code error msg} 2 msg leavestep foo bar 1 msg leavestep foo {catch bar} 0 1 leavestep foo {return error} enterstep foo {return error} 2 error leavestep foo {if {[catch {bar}]} { return "error" } else { return "ok" }} 2 error leavestep foo foo 0 error leave}} test trace-28.4 {exec traces in slave with 'return -code error'} { interp create slave interp alias slave traceExecute {} traceExecute set info {} set res [interp eval slave { set info {} set res {} proc foo {} { if {[catch {bar}]} { return "error" } else { return "ok" } } proc bar {} { return -code error "msg" } lappend res [foo] trace add execution foo {enter enterstep leave leavestep} \ [list traceExecute foo] # With the trace active lappend res [foo] trace remove execution foo {enter enterstep leave leavestep} \ [list traceExecute foo] list $res }] interp delete slave lappend res [join $info \n] } {{error error} {foo foo enter foo {if {[catch {bar}]} { return "error" } else { return "ok" }} enterstep foo {catch bar} enterstep foo bar enterstep foo {return -code error msg} enterstep foo {return -code error msg} 2 msg leavestep foo bar 1 msg leavestep foo {catch bar} 0 1 leavestep foo {return error} enterstep foo {return error} 2 error leavestep foo {if {[catch {bar}]} { return "error" } else { return "ok" }} 2 error leavestep foo foo 0 error leave}} test trace-28.5 {exec traces} { set info {} proc foo {args} { set a 1 } trace add execution foo {enter enterstep leave leavestep} \ [list traceExecute foo] after idle [list foo test-28.4] update # Complicated way of removing traces set ti [lindex [eval [list trace info execution ::foo]] 0] if {[llength $ti]} { eval [concat [list trace remove execution foo] $ti] } join $info \n } {foo {foo test-28.4} enter foo {set a 1} enterstep foo {set a 1} 0 1 leavestep foo {foo test-28.4} 0 1 leave} test trace-28.6 {exec traces firing order} { set info {} proc enterStep {cmd op} {lappend ::info "enter $cmd/$op"} proc leaveStep {cmd code result op} {lappend ::info "leave $cmd/$code/$result/$op"} proc foo x { set b x=$x incr x } trace add execution foo enterstep enterStep trace add execution foo leavestep leaveStep foo 42 rename foo {} join $info \n } {enter set b x=42/enterstep leave set b x=42/0/x=42/leavestep enter incr x/enterstep leave incr x/0/43/leavestep} test trace-28.7 {exec trace information} { set info {} proc foo x { incr x } proc bar {args} {} trace add execution foo {enter leave enterstep leavestep} bar set info [trace info execution foo] trace remove execution foo {enter leave enterstep leavestep} bar } {} test trace-28.8 {exec trace remove nonsense} { list [catch {trace remove execution thisdoesntexist \ {enter leave enterstep leavestep} bar} res] $res } {1 {unknown command "thisdoesntexist"}} test trace-28.9 {exec trace info nonsense} { list [catch {trace info execution thisdoesntexist} res] $res } {1 {unknown command "thisdoesntexist"}} test trace-28.10 {exec trace info nonsense} { list [catch {trace remove execution} res] $res } {1 {wrong # args: should be "trace remove execution name opList command"}} # Missing test number to keep in sync with the 8.5 branch # (want to backport those tests?) test trace-31.1 {command and execution traces shared struct} { # Tcl Bug 807243 proc foo {} {} trace add command foo delete foo trace add execution foo enter foo set result [trace info command foo] trace remove command foo delete foo trace remove execution foo enter foo rename foo {} set result } [list [list delete foo]] test trace-31.2 {command and execution traces shared struct} { # Tcl Bug 807243 proc foo {} {} trace add command foo delete foo trace add execution foo enter foo set result [trace info execution foo] trace remove command foo delete foo trace remove execution foo enter foo rename foo {} set result } [list [list enter foo]] test trace-32.1 { TraceCommandInfo refcount decr in TraceCommandProc w/o loss of reference } { # Tcl Bug 811483 proc foo {} {} trace add command foo delete foo trace add execution foo enter foo set result [trace info command foo] rename foo {} set result } [list [list delete foo]] test trace-33.1 {variable match with remove variable} { unset -nocomplain x trace variable x w foo trace remove variable x write foo llength [trace info variable x] } 0 test trace-34.1 {Bug 1201035} { set ::x [list] proc foo {} {lappend ::x foo} proc bar args { lappend ::x $args trace remove execution foo leavestep bar trace remove execution foo enterstep bar trace add execution foo leavestep bar trace add execution foo enterstep bar lappend ::x done } trace add execution foo leavestep bar trace add execution foo enterstep bar foo set ::x } {{{lappend ::x foo} enterstep} done foo} test trace-34.2 {Bug 1224585} { proc foo {} {} proc bar args {trace remove execution foo leave soom} trace add execution foo leave bar trace add execution foo leave soom foo } {} test trace-34.3 {Bug 1224585} { proc foo {} {set x {}} proc bar args {trace remove execution foo enterstep soom} trace add execution foo enterstep soom trace add execution foo enterstep bar foo } {} # We test here for the half-documented and currently valid interplay between # delete traces and namespace deletion. test trace-34.4 {Bug 1047286} { variable x notrace proc callback {old - -} { variable x "$old exists: [namespace which -command $old]" } namespace eval ::foo {proc bar {} {}} trace add command ::foo::bar delete [namespace code callback] namespace delete ::foo set x } {::foo::bar exists: ::foo::bar} test trace-34.5 {Bug 1047286} { variable x notrace proc callback {old - -} { variable x "$old exists: [namespace which -command $old]" } namespace eval ::foo {proc bar {} {}} trace add command ::foo::bar delete [namespace code callback] namespace eval ::foo namespace delete ::foo set x } {::foo::bar exists: } test trace-34.6 {Bug 1458266} -setup { proc dummy {} {} proc stepTraceHandler {cmdString args} { variable log append log "[expr {[info level] - 1}]: [lindex [split $cmdString] 0]\n" dummy isTracedInside_2 } proc cmdTraceHandler {cmdString args} { # silent } proc isTracedInside_1 {} { isTracedInside_2 } proc isTracedInside_2 {} { set x 2 } } -body { variable log {} trace add execution isTracedInside_1 enterstep stepTraceHandler trace add execution isTracedInside_2 enterstep stepTraceHandler isTracedInside_1 variable first $log set log {} trace add execution dummy enter cmdTraceHandler isTracedInside_1 variable second $log expr {($first eq $second) ? "ok" : "\n$first\nand\n\n$second\ndiffer"} } -cleanup { unset -nocomplain log first second rename dummy {} rename stepTraceHandler {} rename cmdTraceHandler {} rename isTracedInside_1 {} rename isTracedInside_2 {} } -result ok # Delete procedures when done, so we don't clash with other tests # (e.g. foobar will clash with 'unknown' tests). catch {rename foobar {}} catch {rename foo {}} catch {rename bar {}} # Unset the varaible when done catch {unset info} # cleanup ::tcltest::cleanupTests return