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