diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/trace.test | 807 |
1 files changed, 582 insertions, 225 deletions
diff --git a/tests/trace.test b/tests/trace.test index f5d1d0f..11da1a9 100644 --- a/tests/trace.test +++ b/tests/trace.test @@ -11,7 +11,7 @@ # 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.7 2000/07/31 18:03:50 ericm Exp $ +# RCS: @(#) $Id: trace.test,v 1.8 2000/08/25 02:04:29 ericm Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -52,57 +52,60 @@ proc traceCheck {cmd args} { proc traceCrtElement {value name1 name2 op} { uplevel set ${name1}($name2) $value } - +proc traceCommand {oldName newName op} { + global info + set info [list $oldName $newName $op] +} # Read-tracing on variables test trace-1.1 {trace variable reads} { catch {unset x} set info {} - trace var x r traceScalar + trace add variable x read traceScalar list [catch {set x} msg] $msg $info -} {1 {can't read "x": no such variable} {x {} r 1 {can't read "x": no such variable}}} +} {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 var x r traceScalar + trace add variable x read traceScalar list [catch {set x} msg] $msg $info -} {0 123 {x {} r 0 123}} +} {0 123 {x {} read 0 123}} test trace-1.3 {trace variable reads} { catch {unset x} set info {} - trace var x r traceScalar + 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 var x(2) r traceArray + 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 r 1 {can't read "x(2)": no such element in array}}} +} {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 var x(2) r traceArray + trace add variable x(2) read traceArray list [catch {set x(2)} msg] $msg $info -} {0 zzz {x 2 r 0 zzz}} +} {0 zzz {x 2 read 0 zzz}} test trace-1.6 {trace array element reads} { catch {unset x} set info {} - trace variable x r traceArray2 + 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 r}} +} {0 willi {x 2 read}} test trace-1.7 {trace array element reads, create element undefined if nonexistant} { catch {unset x} set info {} - trace variable x r q + trace add variable x read q proc q {name1 name2 op} { global info set info [list $name1 $name2 $op] @@ -115,25 +118,25 @@ test trace-1.7 {trace array element reads, create element undefined if nonexista return $x(Y) } list [catch {p} msg] $msg $info -} {0 wolf {x Y r}} +} {0 wolf {x Y read}} test trace-1.8 {trace reads on whole arrays} { catch {unset x} set info {} - trace var x r traceArray + 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 var x r traceArray + trace add variable x read traceArray list [catch {set x(2)} msg] $msg $info -} {0 zzz {x 2 r 0 zzz}} +} {0 zzz {x 2 read 0 zzz}} test trace-1.10 {trace variable reads} { catch {unset x} set x 444 set info {} - trace var x r traceScalar + trace add variable x read traceScalar unset x set info } {} @@ -143,29 +146,29 @@ test trace-1.10 {trace variable reads} { test trace-2.1 {trace variable writes} { catch {unset x} set info {} - trace var x w traceScalar + trace add variable x write traceScalar set x 123 set info -} {x {} w 0 123} +} {x {} write 0 123} test trace-2.2 {trace writes to array elements} { catch {unset x} set info {} - trace var x(33) w traceArray + trace add variable x(33) write traceArray set x(33) 444 set info -} {x 33 w 0 444} +} {x 33 write 0 444} test trace-2.3 {trace writes on whole arrays} { catch {unset x} set info {} - trace var x w traceArray + trace add variable x write traceArray set x(abc) qq set info -} {x abc w 0 qq} +} {x abc write 0 qq} test trace-2.4 {trace variable writes} { catch {unset x} set x 1234 set info {} - trace var x w traceScalar + trace add variable x write traceScalar set x set info } {} @@ -173,7 +176,7 @@ test trace-2.5 {trace variable writes} { catch {unset x} set x 1234 set info {} - trace var x w traceScalar + trace add variable x write traceScalar unset x set info } {} @@ -186,42 +189,42 @@ test trace-2.5 {trace variable writes} { test trace-3.1 {trace variable read-modify-writes} { catch {unset x} set info {} - trace var x r traceScalarAppend + trace add variable x read traceScalarAppend append x 123 append x 456 lappend x 789 set info -} {x {} r 0 123456} +} {x {} read 0 123456} test trace-3.2 {trace variable read-modify-writes} { catch {unset x} set info {} - trace var x rw traceScalarAppend + trace add variable x {read write} traceScalarAppend append x 123 lappend x 456 set info -} {x {} w 0 123 x {} r 0 123 x {} w 0 {123 456}} +} {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 var x u traceScalar + trace add variable x unset traceScalar catch {unset x} set info -} {x {} u 1 {can't read "x": no such variable}} +} {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 var x u traceScalar + trace add variable x unset traceScalar unset x set info -} {x {} u 1 {can't read "x": no such variable}} +} {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 var x u traceScalar + trace add variable x unset traceScalar set x 44 set x set info @@ -230,31 +233,31 @@ test trace-4.4 {trace unsets on array elements} { catch {unset x} set x(0) 18 set info {} - trace var x(1) u traceArray + trace add variable x(1) unset traceArray catch {unset x(1)} set info -} {x 1 u 1 {can't read "x(1)": no such element in array}} +} {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 var x(1) u traceArray + trace add variable x(1) unset traceArray unset x(1) set info -} {x 1 u 1 {can't read "x(1)": no such element in array}} +} {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 var x(1) u traceArray + trace add variable x(1) unset traceArray unset x set info -} {x 1 u 1 {can't read "x(1)": no such variable}} +} {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 var x u traceProc + trace add variable x unset traceProc catch {unset x(0)} set info } {} @@ -264,38 +267,74 @@ test trace-4.8 {trace unsets on whole arrays} { set x(2) 144 set x(3) 14 set info {} - trace var x u traceProc + trace add variable x unset traceProc unset x(1) set info -} {x 1 u} +} {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 var x u traceProc + 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} + 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} + 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 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 -} {x {} u} +} {} +test trace-5.4 {array traces properly listed in trace information} { + catch {unset x} + trace add variable x array traceArray2 + trace list variable x +} [list [list array traceArray2]] +test trace-5.5 {array traces properly listed in trace information} { + catch {unset x} + trace variable x a traceArray2 + trace vinfo x +} [list [list a traceArray2]] # Trace multiple trace types at once. test trace-5.1 {multiple ops traced at once} { catch {unset x} set info {} - trace var x rwu traceProc + trace add variable x {read write unset} traceProc catch {set x} set x 22 set x set x 33 unset x set info -} {x {} r x {} w x {} r x {} w x {} u} +} {x {} read x {} write x {} read x {} write x {} unset} test trace-5.2 {multiple ops traced on array element} { catch {unset x} set info {} - trace var x(0) rwu traceProc + trace add variable x(0) {read write unset} traceProc catch {set x(0)} set x(0) 22 set x(0) @@ -303,11 +342,11 @@ test trace-5.2 {multiple ops traced on array element} { unset x(0) unset x set info -} {x 0 r x 0 w x 0 r x 0 w x 0 u} +} {x 0 read x 0 write x 0 read x 0 write x 0 unset} test trace-5.3 {multiple ops traced on whole array} { catch {unset x} set info {} - trace var x rwu traceProc + trace add variable x {read write unset} traceProc catch {set x(0)} set x(0) 22 set x(0) @@ -315,16 +354,16 @@ test trace-5.3 {multiple ops traced on whole array} { unset x(0) unset x set info -} {x 0 w x 0 r x 0 w x 0 u x {} u} +} {x 0 write x 0 read x 0 write x 0 unset x {} unset} # Check order of invocation of traces test trace-6.1 {order of invocation of traces} { catch {unset x} set info {} - trace var x r "traceTag 1" - trace var x r "traceTag 2" - trace var x r "traceTag 3" + 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 @@ -334,9 +373,9 @@ test trace-6.2 {order of invocation of traces} { catch {unset x} set x(0) 44 set info {} - trace var x(0) r "traceTag 1" - trace var x(0) r "traceTag 2" - trace var x(0) r "traceTag 3" + 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} @@ -344,12 +383,12 @@ test trace-6.3 {order of invocation of traces} { catch {unset x} set x(0) 44 set info {} - trace var x(0) r "traceTag 1" - trace var x r "traceTag A1" - trace var x(0) r "traceTag 2" - trace var x r "traceTag A2" - trace var x(0) r "traceTag 3" - trace var x r "traceTag A3" + 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} @@ -360,47 +399,47 @@ test trace-7.1 {error returns from traces} { catch {unset x} set x 123 set info {} - trace var x r "traceTag 1" - trace var x r traceError + 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-7.2 {error returns from traces} { catch {unset x} set x 123 set info {} - trace var x w "traceTag 1" - trace var x w traceError + 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-7.3 {error returns from traces} { catch {unset x} set x 123 set info {} - trace var x w traceError + trace add variable x write traceError list [catch {append x 44} msg] $msg $info } {1 {can't set "x": trace returned error} {}} test trace-7.4 {error returns from traces} { catch {unset x} set x 123 set info {} - trace var x u "traceTag 1" - trace var x u traceError + trace add variable x unset "traceTag 1" + trace add variable x unset traceError list [catch {unset x} msg] $msg $info } {0 {} 1} test trace-7.5 {error returns from traces} { catch {unset x} set x(0) 123 set info {} - trace var x(0) r "traceTag 1" - trace var x r "traceTag 2" - trace var x r traceError - trace var x r "traceTag 3" + 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-7.6 {error returns from traces} { catch {unset x} set x 123 - trace var x u traceError + trace add variable x unset traceError list [catch {unset x} msg] $msg } {0 {}} test trace-7.7 {error returns from traces} { @@ -409,10 +448,10 @@ test trace-7.7 {error returns from traces} { # when the trace is deleted. catch {unset x} set x 123 - trace var x r traceError + trace add variable x read traceError catch {set x} catch {set x} - trace vdelete x r traceError + trace remove variable x read traceError } {} # Check to see that variables are expunged before trace @@ -423,7 +462,7 @@ test trace-8.1 {be sure variable is unset before trace is called} { catch {unset x} set x 33 set info {} - trace var x u {traceCheck {uplevel set x}} + trace add variable x unset {traceCheck {uplevel set x}} unset x set info } {1 {can't read "x": no such variable}} @@ -431,7 +470,7 @@ test trace-8.2 {be sure variable is unset before trace is called} { catch {unset x} set x 33 set info {} - trace var x u {traceCheck {uplevel set x 22}} + trace add variable x unset {traceCheck {uplevel set x 22}} unset x concat $info [list [catch {set x} msg] $msg] } {0 22 0 22} @@ -439,7 +478,7 @@ test trace-8.3 {be sure traces are cleared before unset trace called} { catch {unset x} set x 33 set info {} - trace var x u {traceCheck {uplevel trace vinfo x}} + trace add variable x unset {traceCheck {uplevel trace list variable x}} unset x set info } {0 {}} @@ -447,16 +486,16 @@ test trace-8.4 {set new trace during unset trace} { catch {unset x} set x 33 set info {} - trace var x u {traceCheck {global x; trace var x u traceProc}} + trace add variable x unset {traceCheck {global x; trace add variable x unset traceProc}} unset x - concat $info [trace vinfo x] -} {0 {} {u traceProc}} + concat $info [trace list variable x] +} {0 {} {unset traceProc}} test trace-9.1 {make sure array elements are unset before traces are called} { catch {unset x} set x(0) 33 set info {} - trace var x(0) u {traceCheck {uplevel set x(0)}} + 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}} @@ -464,7 +503,7 @@ test trace-9.2 {make sure array elements are unset before traces are called} { catch {unset x} set x(0) 33 set info {} - trace var x(0) u {traceCheck {uplevel set x(0) zzz}} + 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} @@ -472,7 +511,7 @@ test trace-9.3 {array elements are unset before traces are called} { catch {unset x} set x(0) 33 set info {} - trace var x(0) u {traceCheck {global x; trace vinfo x(0)}} + trace add variable x(0) unset {traceCheck {global x; trace list variable x(0)}} unset x(0) set info } {0 {}} @@ -480,16 +519,16 @@ test trace-9.4 {set new array element trace during unset trace} { catch {unset x} set x(0) 33 set info {} - trace var x(0) u {traceCheck {uplevel {trace variable x(0) r {}}}} + trace add variable x(0) unset {traceCheck {uplevel {trace add variable x(0) read {}}}} catch {unset x(0)} - concat $info [trace vinfo x(0)] -} {0 {} {r {}}} + concat $info [trace list variable x(0)] +} {0 {} {read {}}} test trace-10.1 {make sure arrays are unset before traces are called} { catch {unset x} set x(0) 33 set info {} - trace var x u {traceCheck {uplevel set x(0)}} + trace add variable x unset {traceCheck {uplevel set x(0)}} unset x set info } {1 {can't read "x(0)": no such variable}} @@ -497,7 +536,7 @@ test trace-10.2 {make sure arrays are unset before traces are called} { catch {unset x} set x(y) 33 set info {} - trace var x u {traceCheck {uplevel set x(y) 22}} + 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} @@ -505,7 +544,7 @@ test trace-10.3 {make sure arrays are unset before traces are called} { catch {unset x} set x(y) 33 set info {} - trace var x u {traceCheck {uplevel array exists x}} + trace add variable x unset {traceCheck {uplevel array exists x}} unset x set info } {0 0} @@ -513,8 +552,8 @@ test trace-10.4 {make sure arrays are unset before traces are called} { catch {unset x} set x(y) 33 set info {} - set cmd {traceCheck {uplevel {trace vinfo x}}} - trace var x u $cmd + set cmd {traceCheck {uplevel {trace list variable x}}} + trace add variable x unset $cmd unset x set info } {0 {}} @@ -522,15 +561,15 @@ test trace-10.5 {set new array trace during unset trace} { catch {unset x} set x(y) 33 set info {} - trace var x u {traceCheck {global x; trace var x r {}}} + trace add variable x unset {traceCheck {global x; trace add variable x read {}}} unset x - concat $info [trace vinfo x] -} {0 {} {r {}}} + concat $info [trace list variable x] +} {0 {} {read {}}} test trace-10.6 {create scalar during array unset trace} { catch {unset x} set x(y) 33 set info {} - trace var x u {traceCheck {global x; set x 44}} + 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} @@ -540,52 +579,52 @@ test trace-10.6 {create scalar during array unset trace} { test trace-11.1 {creating array when setting variable traces} { catch {unset x} set info {} - trace var x(0) w traceProc + trace add variable x(0) write traceProc list [catch {set x 22} msg] $msg } {1 {can't set "x": variable is array}} test trace-11.2 {creating array when setting variable traces} { catch {unset x} set info {} - trace var x(0) w traceProc + 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-11.3 {creating array when setting variable traces} { catch {unset x} set info {} - trace var x(0) w traceProc + trace add variable x(0) write traceProc set x(0) 22 set info -} {x 0 w} +} {x 0 write} test trace-11.4 {creating variable when setting variable traces} { catch {unset x} set info {} - trace var x w traceProc + trace add variable x write traceProc list [catch {set x} msg] $msg } {1 {can't read "x": no such variable}} test trace-11.5 {creating variable when setting variable traces} { catch {unset x} set info {} - trace var x w traceProc + trace add variable x write traceProc set x 22 set info -} {x {} w} +} {x {} write} test trace-11.6 {creating variable when setting variable traces} { catch {unset x} set info {} - trace var x w traceProc + trace add variable x write traceProc set x(0) 22 set info -} {x 0 w} +} {x 0 write} test trace-11.7 {create array element during read trace} { catch {unset x} set x(2) zzz - trace var x r {traceCrtElement xyzzy} + trace add variable x read {traceCrtElement xyzzy} list [catch {set x(3)} msg] $msg } {0 xyzzy} test trace-11.8 {errors when setting variable traces} { catch {unset x} set x 44 - list [catch {trace var x(0) w traceProc} msg] $msg + list [catch {trace add variable x(0) write traceProc} msg] $msg } {1 {can't trace "x(0)": variable isn't array}} # Check deleting one trace from another. @@ -593,126 +632,185 @@ test trace-11.8 {errors when setting variable traces} { test trace-12.1 {delete one trace from another} { proc delTraces {args} { global x - trace vdel x r {traceTag 2} - trace vdel x r {traceTag 3} - trace vdel x r {traceTag 4} + 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 var x r {traceTag 1} - trace var x r {traceTag 2} - trace var x r {traceTag 3} - trace var x r {traceTag 4} - trace var x r delTraces - trace var x r {traceTag 5} + 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} # Check operation and syntax of "trace" command. -test trace-13.1 {trace command (overall)} { +# 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-13.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-13.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-13.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-13.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-13.0.[incr i] "trace command, wrong # args errors" { + list [catch {trace list $type foo bar} msg] $msg + } [list 1 "$start should be \"trace list $type name\""] + test trace-13.0.[incr i] "trace command, wrong # args errors" { + list [catch {trace list $type} msg] $msg + } [list 1 "$start should be \"trace list $type name\""] +} + +test trace-13.1 "trace command, wrong # args errors" { list [catch {trace} msg] $msg -} {1 {wrong # args: should be "trace option [arg arg ...]"}} -test trace-13.2 {trace command (overall)} { +} [list 1 "wrong # args: should be \"trace option ?arg arg ...?\""] +test trace-13.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-13.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-13.4 "trace command, wrong # args errors" { + list [catch {trace list} msg] $msg +} [list 1 "wrong # args: should be \"trace list type ?arg arg ...?\""] + +test trace-13.5 {trace command, invalid option} { list [catch {trace gorp} msg] $msg -} {1 {bad option "gorp": must be variable, vdelete, or vinfo}} -test trace-13.3 {trace command ("variable" option)} { +} [list 1 "bad option \"gorp\": must be add, list, 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"] +set abbvs [list {a r u w} {d r}] +foreach type {variable command} err $errs abbvlist $abbvs { + foreach op {add remove} { + test trace-13.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-13.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-13.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"] + } +} + +test trace-13.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-13.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-13.9 {trace command, "trace variable" errors} { list [catch {trace variable x y} msg] $msg -} {1 {wrong # args: should be "trace variable name ops command"}} -test trace-13.4 {trace command ("variable" option)} { - list [catch {trace var x y z z2} msg] $msg -} {1 {wrong # args: should be "trace variable name ops command"}} -test trace-13.5 {trace command ("variable" option)} { - list [catch {trace var x y z} msg] $msg -} {1 {bad operations "y": should be one or more of rwu}} -test trace-13.6 {trace command ("vdelete" option)} { - list [catch {trace vdelete x y} msg] $msg -} {1 {wrong # args: should be "trace vdelete name ops command"}} -test trace-13.7 {trace command ("vdelete" option)} { - list [catch {trace vdelete x y z foo} msg] $msg -} {1 {wrong # args: should be "trace vdelete name ops command"}} -test trace-13.8 {trace command ("vdelete" option)} { - list [catch {trace vdelete x y z} msg] $msg -} {1 {bad operations "y": should be one or more of rwu}} -test trace-13.9 {trace command ("vdelete" option)} { - catch {unset x} - set info {} - trace var x w traceProc - trace vdelete x w traceProc +} [list 1 "wrong # args: should be \"trace variable name ops command\""] +test trace-13.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-13.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-13.9 {trace command ("remove variable" option)} { + catch {unset x} + set info {} + trace add variable x write traceProc + trace remove variable x write traceProc } {} -test trace-13.10 {trace command ("vdelete" option)} { +test trace-13.10 {trace command ("remove variable" option)} { catch {unset x} set info {} - trace var x w traceProc - trace vdelete x w traceProc + trace add variable x write traceProc + trace remove variable x write traceProc set x 12345 set info } {} -test trace-13.11 {trace command ("vdelete" option)} { +test trace-13.11 {trace command ("remove variable" option)} { catch {unset x} set info {} - trace var x w {traceTag 1} - trace var x w traceProc - trace var x w {traceTag 2} + trace add variable x write {traceTag 1} + trace add variable x write traceProc + trace add variable x write {traceTag 2} set x yy - trace vdelete x w traceProc + trace remove variable x write traceProc set x 12345 - trace vdelete x w {traceTag 1} + trace remove variable x write {traceTag 1} set x foo - trace vdelete x w {traceTag 2} + trace remove variable x write {traceTag 2} set x gorp set info -} {2 x {} w 1 2 1 2} -test trace-13.12 {trace command ("vdelete" option)} { +} {2 x {} write 1 2 1 2} +test trace-13.12 {trace command ("remove variable" option)} { catch {unset x} set info {} - trace var x w {traceTag 1} - trace vdelete x w non_existent + trace add variable x write {traceTag 1} + trace remove variable x write non_existent set x 12345 set info } {1} -test trace-13.13 {trace command ("vinfo" option)} { - list [catch {trace vinfo} msg] $msg] -} {1 {wrong # args: should be "trace vinfo name"]}} -test trace-13.14 {trace command ("vinfo" option)} { - list [catch {trace vinfo x y} msg] $msg] -} {1 {wrong # args: should be "trace vinfo name"]}} -test trace-13.15 {trace command ("vinfo" option)} { - catch {unset x} - trace var x w {traceTag 1} - trace var x w traceProc - trace var x w {traceTag 2} - trace vinfo x -} {{w {traceTag 2}} {w traceProc} {w {traceTag 1}}} -test trace-13.16 {trace command ("vinfo" option)} { +test trace-13.15 {trace command ("list variable" option)} { catch {unset x} - trace vinfo x + trace add variable x write {traceTag 1} + trace add variable x write traceProc + trace add variable x write {traceTag 2} + trace list variable x +} {{write {traceTag 2}} {write traceProc} {write {traceTag 1}}} +test trace-13.16 {trace command ("list variable" option)} { + catch {unset x} + trace list variable x } {} -test trace-13.17 {trace command ("vinfo" option)} { +test trace-13.17 {trace command ("list variable" option)} { catch {unset x} - trace vinfo x(0) + trace list variable x(0) } {} -test trace-13.18 {trace command ("vinfo" option)} { +test trace-13.18 {trace command ("list variable" option)} { catch {unset x} set x 44 - trace vinfo x(0) + trace list variable x(0) } {} -test trace-13.19 {trace command ("vinfo" option)} { +test trace-13.19 {trace command ("list variable" option)} { catch {unset x} set x 44 - trace var x w {traceTag 1} - proc check {} {global x; trace vinfo x} + trace add variable x write {traceTag 1} + proc check {} {global x; trace list variable x} check -} {{w {traceTag 1}}} +} {{write {traceTag 1}}} # Check fancy trace commands (long ones, weird arguments, etc.) test trace-14.1 {long trace command} { catch {unset x} set info {} - trace var x w {traceTag {This is a very very long argument. It's \ + 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 \ @@ -729,7 +827,7 @@ test trace-14.2 {long trace command result to ignore} { 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 var x w longResult + trace add variable x write longResult set x 44 set x 5 set x abcde @@ -738,10 +836,10 @@ test trace-14.3 {special list-handling in trace commands} { catch {unset "x y z"} set "x y z(a\n\{)" 44 set info {} - trace var "x y z(a\n\{)" w traceProc + trace add variable "x y z(a\n\{)" write traceProc set "x y z(a\n\{)" 33 set info -} "{x y z} a\\n\\{ w" +} "{x y z} a\\n\\{ write" # Check for proper handling of unsets during traces. @@ -769,162 +867,162 @@ test trace-15.1 {unsets during read traces} { catch {unset y} set y 1234 set info {} - trace var y r {traceUnset y} - trace var y u {traceAppend unset} + 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-15.2 {unsets during read traces} { catch {unset y} set y(0) 1234 set info {} - trace var y(0) r {traceUnset y(0)} + 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-15.3 {unsets during read traces} { catch {unset y} set y(0) 1234 set info {} - trace var y(0) r {traceUnset y} + 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-15.4 {unsets during read traces} { catch {unset y} set y 1234 set info {} - trace var y r {traceReset y y} + trace add variable y read {traceReset y y} lappend info [catch {set y} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-15.5 {unsets during read traces} { catch {unset y} set y(0) 1234 set info {} - trace var y(0) r {traceReset y(0) y(0)} + 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-15.6 {unsets during read traces} { catch {unset y} set y(0) 1234 set info {} - trace var y(0) r {traceReset y y(0)} + 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-15.7 {unsets during read traces} { catch {unset y} set y(0) 1234 set info {} - trace var y(0) r {traceReset2 y y(0)} + 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-15.8 {unsets during write traces} { catch {unset y} set y 1234 set info {} - trace var y w {traceUnset y} - trace var y u {traceAppend unset} + 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-15.9 {unsets during write traces} { catch {unset y} set y(0) 1234 set info {} - trace var y(0) w {traceUnset y(0)} + 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-15.10 {unsets during write traces} { catch {unset y} set y(0) 1234 set info {} - trace var y(0) w {traceUnset y} + 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-15.11 {unsets during write traces} { catch {unset y} set y 1234 set info {} - trace var y w {traceReset y y} + trace add variable y write {traceReset y y} lappend info [catch {set y xxx} msg] $msg } {0 {} 0 xyzzy 0 xyzzy} test trace-15.12 {unsets during write traces} { catch {unset y} set y(0) 1234 set info {} - trace var y(0) w {traceReset y(0) y(0)} + 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-15.13 {unsets during write traces} { catch {unset y} set y(0) 1234 set info {} - trace var y(0) w {traceReset y y(0)} + 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-15.14 {unsets during write traces} { catch {unset y} set y(0) 1234 set info {} - trace var y(0) w {traceReset2 y y(0)} + 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-15.15 {unsets during unset traces} { catch {unset y} set y 1234 set info {} - trace var y u {traceUnset y} + 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-15.16 {unsets during unset traces} { catch {unset y} set y(0) 1234 set info {} - trace var y(0) u {traceUnset y(0)} + 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-15.17 {unsets during unset traces} { catch {unset y} set y(0) 1234 set info {} - trace var y(0) u {traceUnset y} + 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-15.18 {unsets during unset traces} { catch {unset y} set y 1234 set info {} - trace var y u {traceReset2 y y} + 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-15.19 {unsets during unset traces} { catch {unset y} set y(0) 1234 set info {} - trace var y(0) u {traceReset2 y(0) y(0)} + 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-15.20 {unsets during unset traces} { catch {unset y} set y(0) 1234 set info {} - trace var y(0) u {traceReset2 y y(0)} + 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-15.21 {unsets cancelling traces} { catch {unset y} set y 1234 set info {} - trace var y r {traceAppend first} - trace var y r {traceUnset y} - trace var y r {traceAppend third} - trace var y u {traceAppend unset} + 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-15.22 {unsets cancelling traces} { catch {unset y} set y(0) 1234 set info {} - trace var y(0) r {traceAppend first} - trace var y(0) r {traceUnset y} - trace var y(0) r {traceAppend third} - trace var y(0) u {traceAppend unset} + 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}} @@ -933,30 +1031,30 @@ test trace-15.22 {unsets cancelling traces} { test trace-16.1 {trace doesn't prevent unset errors} { catch {unset x} set info {} - trace var x u {traceProc} + trace add variable x unset {traceProc} list [catch {unset x} msg] $msg $info -} {1 {can't unset "x": no such variable} {x {} u}} +} {1 {can't unset "x": no such variable} {x {} unset}} test trace-16.2 {traced variables must survive procedure exits} { catch {unset x} - proc p1 {} {global x; trace var x w traceProc} + proc p1 {} {global x; trace add variable x write traceProc} p1 - trace vinfo x -} {{w traceProc}} + trace list variable x +} {{write traceProc}} test trace-16.3 {traced variables must survive procedure exits} { catch {unset x} set info {} - proc p1 {} {global x; trace var x w traceProc} + proc p1 {} {global x; trace add variable x write traceProc} p1 set x 44 set info -} {x {} w} +} {x {} write} # Be sure that procedure frames are released before unset traces # are invoked. test trace-17.1 {unset traces on procedure returns} { proc p1 {x y} {set a 44; p2 14} - proc p2 {z} {trace var z u {traceCheck {lsort [uplevel {info vars}]}}} + proc p2 {z} {trace add variable z unset {traceCheck {lsort [uplevel {info vars}]}}} set info {} p1 foo bar set info @@ -968,6 +1066,265 @@ test trace-17.1 {unset traces on procedure returns} { catch {unset x} catch {unset y} +test trace-17.2 {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-17.3 {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-18.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-18.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-18.2.1 {trace add command rename trace exists} { + proc foo {} {} + trace add command foo rename traceCommand + trace list command foo +} {{rename traceCommand}} +test trace-18.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-18.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-18.5 {trace add command deleted removes traces} { + proc foo {} {} + trace add command foo rename traceCommand + proc foo {} {} + trace list command foo +} {} + +namespace eval tc {} +proc tc::tcfoo {} {} +test trace-18.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-18.7 {trace add command rename in namespace back again} { + rename tc::tcbar tc::tcfoo + set info +} {tc::tcbar tc::tcfoo rename} +test trace-18.8 {trace add command rename in namespace to out of namespace} { + rename tc::tcfoo tcbar + set info +} {tc::tcfoo tcbar rename} +test trace-18.9 {trace add command rename back into namespace} { + rename tcbar tc::tcfoo + set info +} {tcbar tc::tcfoo rename} +test trace-18.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 {}} + +# Make sure it exists again +proc foo {} {} + +test trace-19.1 {trace add command (delete option)} { + trace add command foo delete traceCommand + rename foo "" + set info +} {foo {} delete} +test trace-19.2 {trace add command delete doesn't trace recreated commands} { + set info {} + proc foo {} {} + rename foo "" + set info +} {} +test trace-19.2.1 {trace add command delete trace info} { + proc foo {} {} + trace add command foo delete traceCommand + trace list command foo +} {{delete traceCommand}} +test trace-19.3 {trace add command implicit delete} { + proc foo {} {} + trace add command foo delete traceCommand + proc foo {} {} + set info +} {foo {} delete} +test trace-19.3.1 {trace add command delete trace info} { + proc foo {} {} + trace list command foo +} {} +test trace-19.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-19.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-19.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-19.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 list 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-19.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 list command bar] +} {{foo bar rename} {}} + +test trace-19.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-19.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-19.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-19.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] +} {{} {} {}} + +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 {}} + +# Delete arrays when done, so they can be re-used as scalars +# elsewhere. + +catch {unset x} +catch {unset y} + + # cleanup ::tcltest::cleanupTests return |