os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/trace.test
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/trace.test Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,2394 @@
1.4 +# Commands covered: trace
1.5 +#
1.6 +# This file contains a collection of tests for one or more of the Tcl
1.7 +# built-in commands. Sourcing this file into Tcl runs the tests and
1.8 +# generates output for errors. No output means no errors were found.
1.9 +#
1.10 +# Copyright (c) 1991-1993 The Regents of the University of California.
1.11 +# Copyright (c) 1994 Sun Microsystems, Inc.
1.12 +# Copyright (c) 1998-1999 by Scriptics Corporation.
1.13 +#
1.14 +# See the file "license.terms" for information on usage and redistribution
1.15 +# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.16 +#
1.17 +# RCS: @(#) $Id: trace.test,v 1.26.2.17 2006/11/04 01:37:56 msofer Exp $
1.18 +
1.19 +if {[lsearch [namespace children] ::tcltest] == -1} {
1.20 + package require tcltest
1.21 + namespace import -force ::tcltest::*
1.22 +}
1.23 +
1.24 +# Used for constraining memory leak tests
1.25 +testConstraint memory [llength [info commands memory]]
1.26 +
1.27 +testConstraint testevalobjv [llength [info commands testevalobjv]]
1.28 +
1.29 +proc getbytes {} {
1.30 + set lines [split [memory info] "\n"]
1.31 + lindex [lindex $lines 3] 3
1.32 +}
1.33 +
1.34 +proc traceScalar {name1 name2 op} {
1.35 + global info
1.36 + set info [list $name1 $name2 $op [catch {uplevel set $name1} msg] $msg]
1.37 +}
1.38 +proc traceScalarAppend {name1 name2 op} {
1.39 + global info
1.40 + lappend info $name1 $name2 $op [catch {uplevel set $name1} msg] $msg
1.41 +}
1.42 +proc traceArray {name1 name2 op} {
1.43 + global info
1.44 + set info [list $name1 $name2 $op [catch {uplevel set [set name1]($name2)} msg] $msg]
1.45 +}
1.46 +proc traceArray2 {name1 name2 op} {
1.47 + global info
1.48 + set info [list $name1 $name2 $op]
1.49 +}
1.50 +proc traceProc {name1 name2 op} {
1.51 + global info
1.52 + set info [concat $info [list $name1 $name2 $op]]
1.53 +}
1.54 +proc traceTag {tag args} {
1.55 + global info
1.56 + set info [concat $info $tag]
1.57 +}
1.58 +proc traceError {args} {
1.59 + error "trace returned error"
1.60 +}
1.61 +proc traceCheck {cmd args} {
1.62 + global info
1.63 + set info [list [catch $cmd msg] $msg]
1.64 +}
1.65 +proc traceCrtElement {value name1 name2 op} {
1.66 + uplevel set ${name1}($name2) $value
1.67 +}
1.68 +proc traceCommand {oldName newName op} {
1.69 + global info
1.70 + set info [list $oldName $newName $op]
1.71 +}
1.72 +
1.73 +test trace-0.0 {memory corruption in trace (Tcl Bug 484339)} {
1.74 + # You may need Purify or Electric Fence to reliably
1.75 + # see this one fail.
1.76 + catch {unset z}
1.77 + trace add variable z array {set z(foo) 1 ;#}
1.78 + set res "names: [array names z]"
1.79 + catch {unset ::z}
1.80 + trace variable ::z w {unset ::z; error "memory corruption";#}
1.81 + list [catch {set ::z 1} msg] $msg
1.82 +} {1 {can't set "::z": memory corruption}}
1.83 +
1.84 +# Read-tracing on variables
1.85 +
1.86 +test trace-1.1 {trace variable reads} {
1.87 + catch {unset x}
1.88 + set info {}
1.89 + trace add variable x read traceScalar
1.90 + list [catch {set x} msg] $msg $info
1.91 +} {1 {can't read "x": no such variable} {x {} read 1 {can't read "x": no such variable}}}
1.92 +test trace-1.2 {trace variable reads} {
1.93 + catch {unset x}
1.94 + set x 123
1.95 + set info {}
1.96 + trace add variable x read traceScalar
1.97 + list [catch {set x} msg] $msg $info
1.98 +} {0 123 {x {} read 0 123}}
1.99 +test trace-1.3 {trace variable reads} {
1.100 + catch {unset x}
1.101 + set info {}
1.102 + trace add variable x read traceScalar
1.103 + set x 123
1.104 + set info
1.105 +} {}
1.106 +test trace-1.4 {trace array element reads} {
1.107 + catch {unset x}
1.108 + set info {}
1.109 + trace add variable x(2) read traceArray
1.110 + list [catch {set x(2)} msg] $msg $info
1.111 +} {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}}}
1.112 +test trace-1.5 {trace array element reads} {
1.113 + catch {unset x}
1.114 + set x(2) zzz
1.115 + set info {}
1.116 + trace add variable x(2) read traceArray
1.117 + list [catch {set x(2)} msg] $msg $info
1.118 +} {0 zzz {x 2 read 0 zzz}}
1.119 +test trace-1.6 {trace array element reads} {
1.120 + catch {unset x}
1.121 + set info {}
1.122 + trace add variable x read traceArray2
1.123 + proc p {} {
1.124 + global x
1.125 + set x(2) willi
1.126 + return $x(2)
1.127 + }
1.128 + list [catch {p} msg] $msg $info
1.129 +} {0 willi {x 2 read}}
1.130 +test trace-1.7 {trace array element reads, create element undefined if nonexistant} {
1.131 + catch {unset x}
1.132 + set info {}
1.133 + trace add variable x read q
1.134 + proc q {name1 name2 op} {
1.135 + global info
1.136 + set info [list $name1 $name2 $op]
1.137 + global $name1
1.138 + set ${name1}($name2) wolf
1.139 + }
1.140 + proc p {} {
1.141 + global x
1.142 + set x(X) willi
1.143 + return $x(Y)
1.144 + }
1.145 + list [catch {p} msg] $msg $info
1.146 +} {0 wolf {x Y read}}
1.147 +test trace-1.8 {trace reads on whole arrays} {
1.148 + catch {unset x}
1.149 + set info {}
1.150 + trace add variable x read traceArray
1.151 + list [catch {set x(2)} msg] $msg $info
1.152 +} {1 {can't read "x(2)": no such variable} {}}
1.153 +test trace-1.9 {trace reads on whole arrays} {
1.154 + catch {unset x}
1.155 + set x(2) zzz
1.156 + set info {}
1.157 + trace add variable x read traceArray
1.158 + list [catch {set x(2)} msg] $msg $info
1.159 +} {0 zzz {x 2 read 0 zzz}}
1.160 +test trace-1.10 {trace variable reads} {
1.161 + catch {unset x}
1.162 + set x 444
1.163 + set info {}
1.164 + trace add variable x read traceScalar
1.165 + unset x
1.166 + set info
1.167 +} {}
1.168 +test trace-1.11 {read traces that modify the array structure} {
1.169 + catch {unset x}
1.170 + set x(bar) 0
1.171 + trace variable x r {set x(foo) 1 ;#}
1.172 + trace variable x r {unset -nocomplain x(bar) ;#}
1.173 + array get x
1.174 +} {}
1.175 +test trace-1.12 {read traces that modify the array structure} {
1.176 + catch {unset x}
1.177 + set x(bar) 0
1.178 + trace variable x r {unset -nocomplain x(bar) ;#}
1.179 + trace variable x r {set x(foo) 1 ;#}
1.180 + array get x
1.181 +} {}
1.182 +test trace-1.13 {read traces that modify the array structure} {
1.183 + catch {unset x}
1.184 + set x(bar) 0
1.185 + trace variable x r {set x(foo) 1 ;#}
1.186 + trace variable x r {unset -nocomplain x;#}
1.187 + list [catch {array get x} res] $res
1.188 +} {1 {can't read "x(bar)": no such variable}}
1.189 +test trace-1.14 {read traces that modify the array structure} {
1.190 + catch {unset x}
1.191 + set x(bar) 0
1.192 + trace variable x r {unset -nocomplain x;#}
1.193 + trace variable x r {set x(foo) 1 ;#}
1.194 + list [catch {array get x} res] $res
1.195 +} {1 {can't read "x(bar)": no such variable}}
1.196 +
1.197 +# Basic write-tracing on variables
1.198 +
1.199 +test trace-2.1 {trace variable writes} {
1.200 + catch {unset x}
1.201 + set info {}
1.202 + trace add variable x write traceScalar
1.203 + set x 123
1.204 + set info
1.205 +} {x {} write 0 123}
1.206 +test trace-2.2 {trace writes to array elements} {
1.207 + catch {unset x}
1.208 + set info {}
1.209 + trace add variable x(33) write traceArray
1.210 + set x(33) 444
1.211 + set info
1.212 +} {x 33 write 0 444}
1.213 +test trace-2.3 {trace writes on whole arrays} {
1.214 + catch {unset x}
1.215 + set info {}
1.216 + trace add variable x write traceArray
1.217 + set x(abc) qq
1.218 + set info
1.219 +} {x abc write 0 qq}
1.220 +test trace-2.4 {trace variable writes} {
1.221 + catch {unset x}
1.222 + set x 1234
1.223 + set info {}
1.224 + trace add variable x write traceScalar
1.225 + set x
1.226 + set info
1.227 +} {}
1.228 +test trace-2.5 {trace variable writes} {
1.229 + catch {unset x}
1.230 + set x 1234
1.231 + set info {}
1.232 + trace add variable x write traceScalar
1.233 + unset x
1.234 + set info
1.235 +} {}
1.236 +
1.237 +# append no longer triggers read traces when fetching the old values of
1.238 +# variables before doing the append operation. However, lappend _does_
1.239 +# still trigger these read traces. Also lappend triggers only one write
1.240 +# trace: after appending all arguments to the list.
1.241 +
1.242 +test trace-3.1 {trace variable read-modify-writes} {
1.243 + catch {unset x}
1.244 + set info {}
1.245 + trace add variable x read traceScalarAppend
1.246 + append x 123
1.247 + append x 456
1.248 + lappend x 789
1.249 + set info
1.250 +} {x {} read 0 123456}
1.251 +test trace-3.2 {trace variable read-modify-writes} {
1.252 + catch {unset x}
1.253 + set info {}
1.254 + trace add variable x {read write} traceScalarAppend
1.255 + append x 123
1.256 + lappend x 456
1.257 + set info
1.258 +} {x {} write 0 123 x {} read 0 123 x {} write 0 {123 456}}
1.259 +
1.260 +# Basic unset-tracing on variables
1.261 +
1.262 +test trace-4.1 {trace variable unsets} {
1.263 + catch {unset x}
1.264 + set info {}
1.265 + trace add variable x unset traceScalar
1.266 + catch {unset x}
1.267 + set info
1.268 +} {x {} unset 1 {can't read "x": no such variable}}
1.269 +test trace-4.2 {variable mustn't exist during unset trace} {
1.270 + catch {unset x}
1.271 + set x 1234
1.272 + set info {}
1.273 + trace add variable x unset traceScalar
1.274 + unset x
1.275 + set info
1.276 +} {x {} unset 1 {can't read "x": no such variable}}
1.277 +test trace-4.3 {unset traces mustn't be called during reads and writes} {
1.278 + catch {unset x}
1.279 + set info {}
1.280 + trace add variable x unset traceScalar
1.281 + set x 44
1.282 + set x
1.283 + set info
1.284 +} {}
1.285 +test trace-4.4 {trace unsets on array elements} {
1.286 + catch {unset x}
1.287 + set x(0) 18
1.288 + set info {}
1.289 + trace add variable x(1) unset traceArray
1.290 + catch {unset x(1)}
1.291 + set info
1.292 +} {x 1 unset 1 {can't read "x(1)": no such element in array}}
1.293 +test trace-4.5 {trace unsets on array elements} {
1.294 + catch {unset x}
1.295 + set x(1) 18
1.296 + set info {}
1.297 + trace add variable x(1) unset traceArray
1.298 + unset x(1)
1.299 + set info
1.300 +} {x 1 unset 1 {can't read "x(1)": no such element in array}}
1.301 +test trace-4.6 {trace unsets on array elements} {
1.302 + catch {unset x}
1.303 + set x(1) 18
1.304 + set info {}
1.305 + trace add variable x(1) unset traceArray
1.306 + unset x
1.307 + set info
1.308 +} {x 1 unset 1 {can't read "x(1)": no such variable}}
1.309 +test trace-4.7 {trace unsets on whole arrays} {
1.310 + catch {unset x}
1.311 + set x(1) 18
1.312 + set info {}
1.313 + trace add variable x unset traceProc
1.314 + catch {unset x(0)}
1.315 + set info
1.316 +} {}
1.317 +test trace-4.8 {trace unsets on whole arrays} {
1.318 + catch {unset x}
1.319 + set x(1) 18
1.320 + set x(2) 144
1.321 + set x(3) 14
1.322 + set info {}
1.323 + trace add variable x unset traceProc
1.324 + unset x(1)
1.325 + set info
1.326 +} {x 1 unset}
1.327 +test trace-4.9 {trace unsets on whole arrays} {
1.328 + catch {unset x}
1.329 + set x(1) 18
1.330 + set x(2) 144
1.331 + set x(3) 14
1.332 + set info {}
1.333 + trace add variable x unset traceProc
1.334 + unset x
1.335 + set info
1.336 +} {x {} unset}
1.337 +
1.338 +# Array tracing on variables
1.339 +test trace-5.1 {array traces fire on accesses via [array]} {
1.340 + catch {unset x}
1.341 + set x(b) 2
1.342 + trace add variable x array traceArray2
1.343 + set ::info {}
1.344 + array set x {a 1}
1.345 + set ::info
1.346 +} {x {} array}
1.347 +test trace-5.2 {array traces do not fire on normal accesses} {
1.348 + catch {unset x}
1.349 + set x(b) 2
1.350 + trace add variable x array traceArray2
1.351 + set ::info {}
1.352 + set x(a) 1
1.353 + set x(b) $x(a)
1.354 + set ::info
1.355 +} {}
1.356 +test trace-5.3 {array traces do not outlive variable} {
1.357 + catch {unset x}
1.358 + trace add variable x array traceArray2
1.359 + set ::info {}
1.360 + set x(a) 1
1.361 + unset x
1.362 + array set x {a 1}
1.363 + set ::info
1.364 +} {}
1.365 +test trace-5.4 {array traces properly listed in trace information} {
1.366 + catch {unset x}
1.367 + trace add variable x array traceArray2
1.368 + set result [trace info variable x]
1.369 + set result
1.370 +} [list [list array traceArray2]]
1.371 +test trace-5.5 {array traces properly listed in trace information} {
1.372 + catch {unset x}
1.373 + trace variable x a traceArray2
1.374 + set result [trace vinfo x]
1.375 + set result
1.376 +} [list [list a traceArray2]]
1.377 +test trace-5.6 {array traces don't fire on scalar variables} {
1.378 + catch {unset x}
1.379 + set x foo
1.380 + trace add variable x array traceArray2
1.381 + set ::info {}
1.382 + catch {array set x {a 1}}
1.383 + set ::info
1.384 +} {}
1.385 +test trace-5.7 {array traces fire for undefined variables} {
1.386 + catch {unset x}
1.387 + trace add variable x array traceArray2
1.388 + set ::info {}
1.389 + array set x {a 1}
1.390 + set ::info
1.391 +} {x {} array}
1.392 +test trace-5.8 {array traces fire for undefined variables} {
1.393 + catch {unset x}
1.394 + trace add variable x array {set x(foo) 1 ;#}
1.395 + set res "names: [array names x]"
1.396 +} {names: foo}
1.397 +
1.398 +# Trace multiple trace types at once.
1.399 +
1.400 +test trace-6.1 {multiple ops traced at once} {
1.401 + catch {unset x}
1.402 + set info {}
1.403 + trace add variable x {read write unset} traceProc
1.404 + catch {set x}
1.405 + set x 22
1.406 + set x
1.407 + set x 33
1.408 + unset x
1.409 + set info
1.410 +} {x {} read x {} write x {} read x {} write x {} unset}
1.411 +test trace-6.2 {multiple ops traced on array element} {
1.412 + catch {unset x}
1.413 + set info {}
1.414 + trace add variable x(0) {read write unset} traceProc
1.415 + catch {set x(0)}
1.416 + set x(0) 22
1.417 + set x(0)
1.418 + set x(0) 33
1.419 + unset x(0)
1.420 + unset x
1.421 + set info
1.422 +} {x 0 read x 0 write x 0 read x 0 write x 0 unset}
1.423 +test trace-6.3 {multiple ops traced on whole array} {
1.424 + catch {unset x}
1.425 + set info {}
1.426 + trace add variable x {read write unset} traceProc
1.427 + catch {set x(0)}
1.428 + set x(0) 22
1.429 + set x(0)
1.430 + set x(0) 33
1.431 + unset x(0)
1.432 + unset x
1.433 + set info
1.434 +} {x 0 write x 0 read x 0 write x 0 unset x {} unset}
1.435 +
1.436 +# Check order of invocation of traces
1.437 +
1.438 +test trace-7.1 {order of invocation of traces} {
1.439 + catch {unset x}
1.440 + set info {}
1.441 + trace add variable x read "traceTag 1"
1.442 + trace add variable x read "traceTag 2"
1.443 + trace add variable x read "traceTag 3"
1.444 + catch {set x}
1.445 + set x 22
1.446 + set x
1.447 + set info
1.448 +} {3 2 1 3 2 1}
1.449 +test trace-7.2 {order of invocation of traces} {
1.450 + catch {unset x}
1.451 + set x(0) 44
1.452 + set info {}
1.453 + trace add variable x(0) read "traceTag 1"
1.454 + trace add variable x(0) read "traceTag 2"
1.455 + trace add variable x(0) read "traceTag 3"
1.456 + set x(0)
1.457 + set info
1.458 +} {3 2 1}
1.459 +test trace-7.3 {order of invocation of traces} {
1.460 + catch {unset x}
1.461 + set x(0) 44
1.462 + set info {}
1.463 + trace add variable x(0) read "traceTag 1"
1.464 + trace add variable x read "traceTag A1"
1.465 + trace add variable x(0) read "traceTag 2"
1.466 + trace add variable x read "traceTag A2"
1.467 + trace add variable x(0) read "traceTag 3"
1.468 + trace add variable x read "traceTag A3"
1.469 + set x(0)
1.470 + set info
1.471 +} {A3 A2 A1 3 2 1}
1.472 +
1.473 +# Check effects of errors in trace procedures
1.474 +
1.475 +test trace-8.1 {error returns from traces} {
1.476 + catch {unset x}
1.477 + set x 123
1.478 + set info {}
1.479 + trace add variable x read "traceTag 1"
1.480 + trace add variable x read traceError
1.481 + list [catch {set x} msg] $msg $info
1.482 +} {1 {can't read "x": trace returned error} {}}
1.483 +test trace-8.2 {error returns from traces} {
1.484 + catch {unset x}
1.485 + set x 123
1.486 + set info {}
1.487 + trace add variable x write "traceTag 1"
1.488 + trace add variable x write traceError
1.489 + list [catch {set x 44} msg] $msg $info
1.490 +} {1 {can't set "x": trace returned error} {}}
1.491 +test trace-8.3 {error returns from traces} {
1.492 + catch {unset x}
1.493 + set x 123
1.494 + set info {}
1.495 + trace add variable x write traceError
1.496 + list [catch {append x 44} msg] $msg $info
1.497 +} {1 {can't set "x": trace returned error} {}}
1.498 +test trace-8.4 {error returns from traces} {
1.499 + catch {unset x}
1.500 + set x 123
1.501 + set info {}
1.502 + trace add variable x unset "traceTag 1"
1.503 + trace add variable x unset traceError
1.504 + list [catch {unset x} msg] $msg $info
1.505 +} {0 {} 1}
1.506 +test trace-8.5 {error returns from traces} {
1.507 + catch {unset x}
1.508 + set x(0) 123
1.509 + set info {}
1.510 + trace add variable x(0) read "traceTag 1"
1.511 + trace add variable x read "traceTag 2"
1.512 + trace add variable x read traceError
1.513 + trace add variable x read "traceTag 3"
1.514 + list [catch {set x(0)} msg] $msg $info
1.515 +} {1 {can't read "x(0)": trace returned error} 3}
1.516 +test trace-8.6 {error returns from traces} {
1.517 + catch {unset x}
1.518 + set x 123
1.519 + trace add variable x unset traceError
1.520 + list [catch {unset x} msg] $msg
1.521 +} {0 {}}
1.522 +test trace-8.7 {error returns from traces} {
1.523 + # This test just makes sure that the memory for the error message
1.524 + # gets deallocated correctly when the trace is invoked again or
1.525 + # when the trace is deleted.
1.526 + catch {unset x}
1.527 + set x 123
1.528 + trace add variable x read traceError
1.529 + catch {set x}
1.530 + catch {set x}
1.531 + trace remove variable x read traceError
1.532 +} {}
1.533 +test trace-8.8 {error returns from traces} {
1.534 + # Yet more elaborate memory corruption testing that checks nothing
1.535 + # bad happens when the trace deletes itself and installs something
1.536 + # new. Alas, there is no neat way to guarantee that this test will
1.537 + # fail if there is a problem, but that's life and with the new code
1.538 + # it should *never* fail.
1.539 + #
1.540 + # Adapted from Bug #219393 reported by Don Porter.
1.541 + catch {rename ::foo {}}
1.542 + proc foo {old args} {
1.543 + trace remove variable ::x write [list foo $old]
1.544 + trace add variable ::x write [list foo $::x]
1.545 + error "foo"
1.546 + }
1.547 + catch {unset ::x ::y}
1.548 + set x junk
1.549 + trace add variable ::x write [list foo $x]
1.550 + for {set y 0} {$y<100} {incr y} {
1.551 + catch {set x junk}
1.552 + }
1.553 + unset x
1.554 +} {}
1.555 +
1.556 +# Check to see that variables are expunged before trace
1.557 +# procedures are invoked, so trace procedure can even manipulate
1.558 +# a new copy of the variables.
1.559 +
1.560 +test trace-9.1 {be sure variable is unset before trace is called} {
1.561 + catch {unset x}
1.562 + set x 33
1.563 + set info {}
1.564 + trace add variable x unset {traceCheck {uplevel set x}}
1.565 + unset x
1.566 + set info
1.567 +} {1 {can't read "x": no such variable}}
1.568 +test trace-9.2 {be sure variable is unset before trace is called} {
1.569 + catch {unset x}
1.570 + set x 33
1.571 + set info {}
1.572 + trace add variable x unset {traceCheck {uplevel set x 22}}
1.573 + unset x
1.574 + concat $info [list [catch {set x} msg] $msg]
1.575 +} {0 22 0 22}
1.576 +test trace-9.3 {be sure traces are cleared before unset trace called} {
1.577 + catch {unset x}
1.578 + set x 33
1.579 + set info {}
1.580 + trace add variable x unset {traceCheck {uplevel trace info variable x}}
1.581 + unset x
1.582 + set info
1.583 +} {0 {}}
1.584 +test trace-9.4 {set new trace during unset trace} {
1.585 + catch {unset x}
1.586 + set x 33
1.587 + set info {}
1.588 + trace add variable x unset {traceCheck {global x; trace add variable x unset traceProc}}
1.589 + unset x
1.590 + concat $info [trace info variable x]
1.591 +} {0 {} {unset traceProc}}
1.592 +
1.593 +test trace-10.1 {make sure array elements are unset before traces are called} {
1.594 + catch {unset x}
1.595 + set x(0) 33
1.596 + set info {}
1.597 + trace add variable x(0) unset {traceCheck {uplevel set x(0)}}
1.598 + unset x(0)
1.599 + set info
1.600 +} {1 {can't read "x(0)": no such element in array}}
1.601 +test trace-10.2 {make sure array elements are unset before traces are called} {
1.602 + catch {unset x}
1.603 + set x(0) 33
1.604 + set info {}
1.605 + trace add variable x(0) unset {traceCheck {uplevel set x(0) zzz}}
1.606 + unset x(0)
1.607 + concat $info [list [catch {set x(0)} msg] $msg]
1.608 +} {0 zzz 0 zzz}
1.609 +test trace-10.3 {array elements are unset before traces are called} {
1.610 + catch {unset x}
1.611 + set x(0) 33
1.612 + set info {}
1.613 + trace add variable x(0) unset {traceCheck {global x; trace info variable x(0)}}
1.614 + unset x(0)
1.615 + set info
1.616 +} {0 {}}
1.617 +test trace-10.4 {set new array element trace during unset trace} {
1.618 + catch {unset x}
1.619 + set x(0) 33
1.620 + set info {}
1.621 + trace add variable x(0) unset {traceCheck {uplevel {trace add variable x(0) read {}}}}
1.622 + catch {unset x(0)}
1.623 + concat $info [trace info variable x(0)]
1.624 +} {0 {} {read {}}}
1.625 +
1.626 +test trace-11.1 {make sure arrays are unset before traces are called} {
1.627 + catch {unset x}
1.628 + set x(0) 33
1.629 + set info {}
1.630 + trace add variable x unset {traceCheck {uplevel set x(0)}}
1.631 + unset x
1.632 + set info
1.633 +} {1 {can't read "x(0)": no such variable}}
1.634 +test trace-11.2 {make sure arrays are unset before traces are called} {
1.635 + catch {unset x}
1.636 + set x(y) 33
1.637 + set info {}
1.638 + trace add variable x unset {traceCheck {uplevel set x(y) 22}}
1.639 + unset x
1.640 + concat $info [list [catch {set x(y)} msg] $msg]
1.641 +} {0 22 0 22}
1.642 +test trace-11.3 {make sure arrays are unset before traces are called} {
1.643 + catch {unset x}
1.644 + set x(y) 33
1.645 + set info {}
1.646 + trace add variable x unset {traceCheck {uplevel array exists x}}
1.647 + unset x
1.648 + set info
1.649 +} {0 0}
1.650 +test trace-11.4 {make sure arrays are unset before traces are called} {
1.651 + catch {unset x}
1.652 + set x(y) 33
1.653 + set info {}
1.654 + set cmd {traceCheck {uplevel {trace info variable x}}}
1.655 + trace add variable x unset $cmd
1.656 + unset x
1.657 + set info
1.658 +} {0 {}}
1.659 +test trace-11.5 {set new array trace during unset trace} {
1.660 + catch {unset x}
1.661 + set x(y) 33
1.662 + set info {}
1.663 + trace add variable x unset {traceCheck {global x; trace add variable x read {}}}
1.664 + unset x
1.665 + concat $info [trace info variable x]
1.666 +} {0 {} {read {}}}
1.667 +test trace-11.6 {create scalar during array unset trace} {
1.668 + catch {unset x}
1.669 + set x(y) 33
1.670 + set info {}
1.671 + trace add variable x unset {traceCheck {global x; set x 44}}
1.672 + unset x
1.673 + concat $info [list [catch {set x} msg] $msg]
1.674 +} {0 44 0 44}
1.675 +
1.676 +# Check special conditions (e.g. errors) in Tcl_TraceVar2.
1.677 +
1.678 +test trace-12.1 {creating array when setting variable traces} {
1.679 + catch {unset x}
1.680 + set info {}
1.681 + trace add variable x(0) write traceProc
1.682 + list [catch {set x 22} msg] $msg
1.683 +} {1 {can't set "x": variable is array}}
1.684 +test trace-12.2 {creating array when setting variable traces} {
1.685 + catch {unset x}
1.686 + set info {}
1.687 + trace add variable x(0) write traceProc
1.688 + list [catch {set x(0)} msg] $msg
1.689 +} {1 {can't read "x(0)": no such element in array}}
1.690 +test trace-12.3 {creating array when setting variable traces} {
1.691 + catch {unset x}
1.692 + set info {}
1.693 + trace add variable x(0) write traceProc
1.694 + set x(0) 22
1.695 + set info
1.696 +} {x 0 write}
1.697 +test trace-12.4 {creating variable when setting variable traces} {
1.698 + catch {unset x}
1.699 + set info {}
1.700 + trace add variable x write traceProc
1.701 + list [catch {set x} msg] $msg
1.702 +} {1 {can't read "x": no such variable}}
1.703 +test trace-12.5 {creating variable when setting variable traces} {
1.704 + catch {unset x}
1.705 + set info {}
1.706 + trace add variable x write traceProc
1.707 + set x 22
1.708 + set info
1.709 +} {x {} write}
1.710 +test trace-12.6 {creating variable when setting variable traces} {
1.711 + catch {unset x}
1.712 + set info {}
1.713 + trace add variable x write traceProc
1.714 + set x(0) 22
1.715 + set info
1.716 +} {x 0 write}
1.717 +test trace-12.7 {create array element during read trace} {
1.718 + catch {unset x}
1.719 + set x(2) zzz
1.720 + trace add variable x read {traceCrtElement xyzzy}
1.721 + list [catch {set x(3)} msg] $msg
1.722 +} {0 xyzzy}
1.723 +test trace-12.8 {errors when setting variable traces} {
1.724 + catch {unset x}
1.725 + set x 44
1.726 + list [catch {trace add variable x(0) write traceProc} msg] $msg
1.727 +} {1 {can't trace "x(0)": variable isn't array}}
1.728 +
1.729 +# Check trace deletion
1.730 +
1.731 +test trace-13.1 {delete one trace from another} {
1.732 + proc delTraces {args} {
1.733 + global x
1.734 + trace remove variable x read {traceTag 2}
1.735 + trace remove variable x read {traceTag 3}
1.736 + trace remove variable x read {traceTag 4}
1.737 + }
1.738 + catch {unset x}
1.739 + set x 44
1.740 + set info {}
1.741 + trace add variable x read {traceTag 1}
1.742 + trace add variable x read {traceTag 2}
1.743 + trace add variable x read {traceTag 3}
1.744 + trace add variable x read {traceTag 4}
1.745 + trace add variable x read delTraces
1.746 + trace add variable x read {traceTag 5}
1.747 + set x
1.748 + set info
1.749 +} {5 1}
1.750 +test trace-13.2 {leak when unsetting traced variable} \
1.751 + -constraints memory -body {
1.752 + set end [getbytes]
1.753 + proc f args {}
1.754 + for {set i 0} {$i < 5} {incr i} {
1.755 + trace add variable bepa write f
1.756 + set bepa a
1.757 + unset bepa
1.758 + set tmp $end
1.759 + set end [getbytes]
1.760 + }
1.761 + expr {$end - $tmp}
1.762 + } -cleanup {
1.763 + unset -nocomplain end i tmp
1.764 + } -result 0
1.765 +test trace-13.3 {leak when removing traces} \
1.766 + -constraints memory -body {
1.767 + set end [getbytes]
1.768 + proc f args {}
1.769 + for {set i 0} {$i < 5} {incr i} {
1.770 + trace add variable bepa write f
1.771 + set bepa a
1.772 + trace remove variable bepa write f
1.773 + set tmp $end
1.774 + set end [getbytes]
1.775 + }
1.776 + expr {$end - $tmp}
1.777 + } -cleanup {
1.778 + unset -nocomplain end i tmp
1.779 + } -result 0
1.780 +test trace-13.4 {leaks in error returns from traces} \
1.781 + -constraints memory -body {
1.782 + set end [getbytes]
1.783 + for {set i 0} {$i < 5} {incr i} {
1.784 + set apa {a 1 b 2}
1.785 + set bepa [lrange $apa 0 end]
1.786 + trace add variable bepa write {error hej}
1.787 + catch {set bepa a}
1.788 + unset bepa
1.789 + set tmp $end
1.790 + set end [getbytes]
1.791 + }
1.792 + expr {$end - $tmp}
1.793 + } -cleanup {
1.794 + unset -nocomplain end i tmp
1.795 + } -result 0
1.796 +
1.797 +# Check operation and syntax of "trace" command.
1.798 +
1.799 +# Syntax for adding/removing variable and command traces is basically the
1.800 +# same:
1.801 +# trace add variable name opList command
1.802 +# trace remove variable name opList command
1.803 +#
1.804 +# The following loops just get all the common "wrong # args" tests done.
1.805 +
1.806 +set i 0
1.807 +set start "wrong # args:"
1.808 +foreach type {variable command} {
1.809 + foreach op {add remove} {
1.810 + test trace-14.0.[incr i] "trace command, wrong # args errors" {
1.811 + list [catch {trace $op $type} msg] $msg
1.812 + } [list 1 "$start should be \"trace $op $type name opList command\""]
1.813 + test trace-14.0.[incr i] "trace command wrong # args errors" {
1.814 + list [catch {trace $op $type foo} msg] $msg
1.815 + } [list 1 "$start should be \"trace $op $type name opList command\""]
1.816 + test trace-14.0.[incr i] "trace command, wrong # args errors" {
1.817 + list [catch {trace $op $type foo bar} msg] $msg
1.818 + } [list 1 "$start should be \"trace $op $type name opList command\""]
1.819 + test trace-14.0.[incr i] "trace command, wrong # args errors" {
1.820 + list [catch {trace $op $type foo bar baz boo} msg] $msg
1.821 + } [list 1 "$start should be \"trace $op $type name opList command\""]
1.822 + }
1.823 + test trace-14.0.[incr i] "trace command, wrong # args errors" {
1.824 + list [catch {trace info $type foo bar} msg] $msg
1.825 + } [list 1 "$start should be \"trace info $type name\""]
1.826 + test trace-14.0.[incr i] "trace command, wrong # args errors" {
1.827 + list [catch {trace info $type} msg] $msg
1.828 + } [list 1 "$start should be \"trace info $type name\""]
1.829 +}
1.830 +
1.831 +test trace-14.1 "trace command, wrong # args errors" {
1.832 + list [catch {trace} msg] $msg
1.833 +} [list 1 "wrong # args: should be \"trace option ?arg arg ...?\""]
1.834 +test trace-14.2 "trace command, wrong # args errors" {
1.835 + list [catch {trace add} msg] $msg
1.836 +} [list 1 "wrong # args: should be \"trace add type ?arg arg ...?\""]
1.837 +test trace-14.3 "trace command, wrong # args errors" {
1.838 + list [catch {trace remove} msg] $msg
1.839 +} [list 1 "wrong # args: should be \"trace remove type ?arg arg ...?\""]
1.840 +test trace-14.4 "trace command, wrong # args errors" {
1.841 + list [catch {trace info} msg] $msg
1.842 +} [list 1 "wrong # args: should be \"trace info type ?arg arg ...?\""]
1.843 +
1.844 +test trace-14.5 {trace command, invalid option} {
1.845 + list [catch {trace gorp} msg] $msg
1.846 +} [list 1 "bad option \"gorp\": must be add, info, remove, variable, vdelete, or vinfo"]
1.847 +
1.848 +# Again, [trace ... command] and [trace ... variable] share syntax and
1.849 +# error message styles for their opList options; these loops test those
1.850 +# error messages.
1.851 +
1.852 +set i 0
1.853 +set errs [list "array, read, unset, or write" "delete or rename" "enter, leave, enterstep, or leavestep"]
1.854 +set abbvs [list {a r u w} {d r} {}]
1.855 +proc x {} {}
1.856 +foreach type {variable command execution} err $errs abbvlist $abbvs {
1.857 + foreach op {add remove} {
1.858 + test trace-14.6.[incr i] "trace $op $type errors" {
1.859 + list [catch {trace $op $type x {y z w} a} msg] $msg
1.860 + } [list 1 "bad operation \"y\": must be $err"]
1.861 + foreach abbv $abbvlist {
1.862 + test trace-14.6.[incr i] "trace $op $type rejects abbreviations" {
1.863 + list [catch {trace $op $type x $abbv a} msg] $msg
1.864 + } [list 1 "bad operation \"$abbv\": must be $err"]
1.865 + }
1.866 + test trace-14.6.[incr i] "trace $op $type rejects null opList" {
1.867 + list [catch {trace $op $type x {} a} msg] $msg
1.868 + } [list 1 "bad operation list \"\": must be one or more of $err"]
1.869 + }
1.870 +}
1.871 +rename x {}
1.872 +
1.873 +test trace-14.7 {trace command, "trace variable" errors} {
1.874 + list [catch {trace variable} msg] $msg
1.875 +} [list 1 "wrong # args: should be \"trace variable name ops command\""]
1.876 +test trace-14.8 {trace command, "trace variable" errors} {
1.877 + list [catch {trace variable x} msg] $msg
1.878 +} [list 1 "wrong # args: should be \"trace variable name ops command\""]
1.879 +test trace-14.9 {trace command, "trace variable" errors} {
1.880 + list [catch {trace variable x y} msg] $msg
1.881 +} [list 1 "wrong # args: should be \"trace variable name ops command\""]
1.882 +test trace-14.10 {trace command, "trace variable" errors} {
1.883 + list [catch {trace variable x y z w} msg] $msg
1.884 +} [list 1 "wrong # args: should be \"trace variable name ops command\""]
1.885 +test trace-14.11 {trace command, "trace variable" errors} {
1.886 + list [catch {trace variable x y z} msg] $msg
1.887 +} [list 1 "bad operations \"y\": should be one or more of rwua"]
1.888 +
1.889 +
1.890 +test trace-14.12 {trace command ("remove variable" option)} {
1.891 + catch {unset x}
1.892 + set info {}
1.893 + trace add variable x write traceProc
1.894 + trace remove variable x write traceProc
1.895 +} {}
1.896 +test trace-14.13 {trace command ("remove variable" option)} {
1.897 + catch {unset x}
1.898 + set info {}
1.899 + trace add variable x write traceProc
1.900 + trace remove variable x write traceProc
1.901 + set x 12345
1.902 + set info
1.903 +} {}
1.904 +test trace-14.14 {trace command ("remove variable" option)} {
1.905 + catch {unset x}
1.906 + set info {}
1.907 + trace add variable x write {traceTag 1}
1.908 + trace add variable x write traceProc
1.909 + trace add variable x write {traceTag 2}
1.910 + set x yy
1.911 + trace remove variable x write traceProc
1.912 + set x 12345
1.913 + trace remove variable x write {traceTag 1}
1.914 + set x foo
1.915 + trace remove variable x write {traceTag 2}
1.916 + set x gorp
1.917 + set info
1.918 +} {2 x {} write 1 2 1 2}
1.919 +test trace-14.15 {trace command ("remove variable" option)} {
1.920 + catch {unset x}
1.921 + set info {}
1.922 + trace add variable x write {traceTag 1}
1.923 + trace remove variable x write non_existent
1.924 + set x 12345
1.925 + set info
1.926 +} {1}
1.927 +test trace-14.16 {trace command ("info variable" option)} {
1.928 + catch {unset x}
1.929 + trace add variable x write {traceTag 1}
1.930 + trace add variable x write traceProc
1.931 + trace add variable x write {traceTag 2}
1.932 + trace info variable x
1.933 +} {{write {traceTag 2}} {write traceProc} {write {traceTag 1}}}
1.934 +test trace-14.17 {trace command ("info variable" option)} {
1.935 + catch {unset x}
1.936 + trace info variable x
1.937 +} {}
1.938 +test trace-14.18 {trace command ("info variable" option)} {
1.939 + catch {unset x}
1.940 + trace info variable x(0)
1.941 +} {}
1.942 +test trace-14.19 {trace command ("info variable" option)} {
1.943 + catch {unset x}
1.944 + set x 44
1.945 + trace info variable x(0)
1.946 +} {}
1.947 +test trace-14.20 {trace command ("info variable" option)} {
1.948 + catch {unset x}
1.949 + set x 44
1.950 + trace add variable x write {traceTag 1}
1.951 + proc check {} {global x; trace info variable x}
1.952 + check
1.953 +} {{write {traceTag 1}}}
1.954 +
1.955 +# Check fancy trace commands (long ones, weird arguments, etc.)
1.956 +
1.957 +test trace-15.1 {long trace command} {
1.958 + catch {unset x}
1.959 + set info {}
1.960 + trace add variable x write {traceTag {This is a very very long argument. It's \
1.961 + designed to test out the facilities of TraceVarProc for dealing \
1.962 + with such long arguments by malloc-ing space. One possibility \
1.963 + is that space doesn't get freed properly. If this happens, then \
1.964 + invoking this test over and over again will eventually leak memory.}}
1.965 + set x 44
1.966 + set info
1.967 +} {This is a very very long argument. It's \
1.968 + designed to test out the facilities of TraceVarProc for dealing \
1.969 + with such long arguments by malloc-ing space. One possibility \
1.970 + is that space doesn't get freed properly. If this happens, then \
1.971 + invoking this test over and over again will eventually leak memory.}
1.972 +test trace-15.2 {long trace command result to ignore} {
1.973 + proc longResult {args} {return "quite a bit of text, designed to
1.974 + generate a core leak if this command file is invoked over and over again
1.975 + and memory isn't being recycled correctly"}
1.976 + catch {unset x}
1.977 + trace add variable x write longResult
1.978 + set x 44
1.979 + set x 5
1.980 + set x abcde
1.981 +} abcde
1.982 +test trace-15.3 {special list-handling in trace commands} {
1.983 + catch {unset "x y z"}
1.984 + set "x y z(a\n\{)" 44
1.985 + set info {}
1.986 + trace add variable "x y z(a\n\{)" write traceProc
1.987 + set "x y z(a\n\{)" 33
1.988 + set info
1.989 +} "{x y z} a\\n\\\{ write"
1.990 +
1.991 +# Check for proper handling of unsets during traces.
1.992 +
1.993 +proc traceUnset {unsetName args} {
1.994 + global info
1.995 + upvar $unsetName x
1.996 + lappend info [catch {unset x} msg] $msg [catch {set x} msg] $msg
1.997 +}
1.998 +proc traceReset {unsetName resetName args} {
1.999 + global info
1.1000 + upvar $unsetName x $resetName y
1.1001 + lappend info [catch {unset x} msg] $msg [catch {set y xyzzy} msg] $msg
1.1002 +}
1.1003 +proc traceReset2 {unsetName resetName args} {
1.1004 + global info
1.1005 + lappend info [catch {uplevel unset $unsetName} msg] $msg \
1.1006 + [catch {uplevel set $resetName xyzzy} msg] $msg
1.1007 +}
1.1008 +proc traceAppend {string name1 name2 op} {
1.1009 + global info
1.1010 + lappend info $string
1.1011 +}
1.1012 +
1.1013 +test trace-16.1 {unsets during read traces} {
1.1014 + catch {unset y}
1.1015 + set y 1234
1.1016 + set info {}
1.1017 + trace add variable y read {traceUnset y}
1.1018 + trace add variable y unset {traceAppend unset}
1.1019 + lappend info [catch {set y} msg] $msg
1.1020 +} {unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}}
1.1021 +test trace-16.2 {unsets during read traces} {
1.1022 + catch {unset y}
1.1023 + set y(0) 1234
1.1024 + set info {}
1.1025 + trace add variable y(0) read {traceUnset y(0)}
1.1026 + lappend info [catch {set y(0)} msg] $msg
1.1027 +} {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such element in array}}
1.1028 +test trace-16.3 {unsets during read traces} {
1.1029 + catch {unset y}
1.1030 + set y(0) 1234
1.1031 + set info {}
1.1032 + trace add variable y(0) read {traceUnset y}
1.1033 + lappend info [catch {set y(0)} msg] $msg
1.1034 +} {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}}
1.1035 +test trace-16.4 {unsets during read traces} {
1.1036 + catch {unset y}
1.1037 + set y 1234
1.1038 + set info {}
1.1039 + trace add variable y read {traceReset y y}
1.1040 + lappend info [catch {set y} msg] $msg
1.1041 +} {0 {} 0 xyzzy 0 xyzzy}
1.1042 +test trace-16.5 {unsets during read traces} {
1.1043 + catch {unset y}
1.1044 + set y(0) 1234
1.1045 + set info {}
1.1046 + trace add variable y(0) read {traceReset y(0) y(0)}
1.1047 + lappend info [catch {set y(0)} msg] $msg
1.1048 +} {0 {} 0 xyzzy 0 xyzzy}
1.1049 +test trace-16.6 {unsets during read traces} {
1.1050 + catch {unset y}
1.1051 + set y(0) 1234
1.1052 + set info {}
1.1053 + trace add variable y(0) read {traceReset y y(0)}
1.1054 + lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg
1.1055 +} {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}}
1.1056 +test trace-16.7 {unsets during read traces} {
1.1057 + catch {unset y}
1.1058 + set y(0) 1234
1.1059 + set info {}
1.1060 + trace add variable y(0) read {traceReset2 y y(0)}
1.1061 + lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg
1.1062 +} {0 {} 0 xyzzy 1 {can't read "y(0)": no such element in array} 0 xyzzy}
1.1063 +test trace-16.8 {unsets during write traces} {
1.1064 + catch {unset y}
1.1065 + set y 1234
1.1066 + set info {}
1.1067 + trace add variable y write {traceUnset y}
1.1068 + trace add variable y unset {traceAppend unset}
1.1069 + lappend info [catch {set y xxx} msg] $msg
1.1070 +} {unset 0 {} 1 {can't read "x": no such variable} 0 {}}
1.1071 +test trace-16.9 {unsets during write traces} {
1.1072 + catch {unset y}
1.1073 + set y(0) 1234
1.1074 + set info {}
1.1075 + trace add variable y(0) write {traceUnset y(0)}
1.1076 + lappend info [catch {set y(0) xxx} msg] $msg
1.1077 +} {0 {} 1 {can't read "x": no such variable} 0 {}}
1.1078 +test trace-16.10 {unsets during write traces} {
1.1079 + catch {unset y}
1.1080 + set y(0) 1234
1.1081 + set info {}
1.1082 + trace add variable y(0) write {traceUnset y}
1.1083 + lappend info [catch {set y(0) xxx} msg] $msg
1.1084 +} {0 {} 1 {can't read "x": no such variable} 0 {}}
1.1085 +test trace-16.11 {unsets during write traces} {
1.1086 + catch {unset y}
1.1087 + set y 1234
1.1088 + set info {}
1.1089 + trace add variable y write {traceReset y y}
1.1090 + lappend info [catch {set y xxx} msg] $msg
1.1091 +} {0 {} 0 xyzzy 0 xyzzy}
1.1092 +test trace-16.12 {unsets during write traces} {
1.1093 + catch {unset y}
1.1094 + set y(0) 1234
1.1095 + set info {}
1.1096 + trace add variable y(0) write {traceReset y(0) y(0)}
1.1097 + lappend info [catch {set y(0) xxx} msg] $msg
1.1098 +} {0 {} 0 xyzzy 0 xyzzy}
1.1099 +test trace-16.13 {unsets during write traces} {
1.1100 + catch {unset y}
1.1101 + set y(0) 1234
1.1102 + set info {}
1.1103 + trace add variable y(0) write {traceReset y y(0)}
1.1104 + lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg
1.1105 +} {0 {} 1 {can't set "y": upvar refers to element in deleted array} 0 {} 1 {can't read "y(0)": no such variable}}
1.1106 +test trace-16.14 {unsets during write traces} {
1.1107 + catch {unset y}
1.1108 + set y(0) 1234
1.1109 + set info {}
1.1110 + trace add variable y(0) write {traceReset2 y y(0)}
1.1111 + lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg
1.1112 +} {0 {} 0 xyzzy 0 {} 0 xyzzy}
1.1113 +test trace-16.15 {unsets during unset traces} {
1.1114 + catch {unset y}
1.1115 + set y 1234
1.1116 + set info {}
1.1117 + trace add variable y unset {traceUnset y}
1.1118 + lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg
1.1119 +} {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}}
1.1120 +test trace-16.16 {unsets during unset traces} {
1.1121 + catch {unset y}
1.1122 + set y(0) 1234
1.1123 + set info {}
1.1124 + trace add variable y(0) unset {traceUnset y(0)}
1.1125 + lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg
1.1126 +} {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}}
1.1127 +test trace-16.17 {unsets during unset traces} {
1.1128 + catch {unset y}
1.1129 + set y(0) 1234
1.1130 + set info {}
1.1131 + trace add variable y(0) unset {traceUnset y}
1.1132 + lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg
1.1133 +} {0 {} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such variable}}
1.1134 +test trace-16.18 {unsets during unset traces} {
1.1135 + catch {unset y}
1.1136 + set y 1234
1.1137 + set info {}
1.1138 + trace add variable y unset {traceReset2 y y}
1.1139 + lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg
1.1140 +} {1 {can't unset "y": no such variable} 0 xyzzy 0 {} 0 xyzzy}
1.1141 +test trace-16.19 {unsets during unset traces} {
1.1142 + catch {unset y}
1.1143 + set y(0) 1234
1.1144 + set info {}
1.1145 + trace add variable y(0) unset {traceReset2 y(0) y(0)}
1.1146 + lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg
1.1147 +} {1 {can't unset "y(0)": no such element in array} 0 xyzzy 0 {} 0 xyzzy}
1.1148 +test trace-16.20 {unsets during unset traces} {
1.1149 + catch {unset y}
1.1150 + set y(0) 1234
1.1151 + set info {}
1.1152 + trace add variable y(0) unset {traceReset2 y y(0)}
1.1153 + lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg
1.1154 +} {0 {} 0 xyzzy 0 {} 0 xyzzy}
1.1155 +test trace-16.21 {unsets cancelling traces} {
1.1156 + catch {unset y}
1.1157 + set y 1234
1.1158 + set info {}
1.1159 + trace add variable y read {traceAppend first}
1.1160 + trace add variable y read {traceUnset y}
1.1161 + trace add variable y read {traceAppend third}
1.1162 + trace add variable y unset {traceAppend unset}
1.1163 + lappend info [catch {set y} msg] $msg
1.1164 +} {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}}
1.1165 +test trace-16.22 {unsets cancelling traces} {
1.1166 + catch {unset y}
1.1167 + set y(0) 1234
1.1168 + set info {}
1.1169 + trace add variable y(0) read {traceAppend first}
1.1170 + trace add variable y(0) read {traceUnset y}
1.1171 + trace add variable y(0) read {traceAppend third}
1.1172 + trace add variable y(0) unset {traceAppend unset}
1.1173 + lappend info [catch {set y(0)} msg] $msg
1.1174 +} {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}}
1.1175 +
1.1176 +# Check various non-interference between traces and other things.
1.1177 +
1.1178 +test trace-17.1 {trace doesn't prevent unset errors} {
1.1179 + catch {unset x}
1.1180 + set info {}
1.1181 + trace add variable x unset {traceProc}
1.1182 + list [catch {unset x} msg] $msg $info
1.1183 +} {1 {can't unset "x": no such variable} {x {} unset}}
1.1184 +test trace-17.2 {traced variables must survive procedure exits} {
1.1185 + catch {unset x}
1.1186 + proc p1 {} {global x; trace add variable x write traceProc}
1.1187 + p1
1.1188 + trace info variable x
1.1189 +} {{write traceProc}}
1.1190 +test trace-17.3 {traced variables must survive procedure exits} {
1.1191 + catch {unset x}
1.1192 + set info {}
1.1193 + proc p1 {} {global x; trace add variable x write traceProc}
1.1194 + p1
1.1195 + set x 44
1.1196 + set info
1.1197 +} {x {} write}
1.1198 +
1.1199 +# Be sure that procedure frames are released before unset traces
1.1200 +# are invoked.
1.1201 +
1.1202 +test trace-18.1 {unset traces on procedure returns} {
1.1203 + proc p1 {x y} {set a 44; p2 14}
1.1204 + proc p2 {z} {trace add variable z unset {traceCheck {lsort [uplevel {info vars}]}}}
1.1205 + set info {}
1.1206 + p1 foo bar
1.1207 + set info
1.1208 +} {0 {a x y}}
1.1209 +test trace-18.2 {namespace delete / trace vdelete combo} {
1.1210 + namespace eval ::foo {
1.1211 + variable x 123
1.1212 + }
1.1213 + proc p1 args {
1.1214 + trace vdelete ::foo::x u p1
1.1215 + }
1.1216 + trace variable ::foo::x u p1
1.1217 + namespace delete ::foo
1.1218 + info exists ::foo::x
1.1219 +} 0
1.1220 +test trace-18.3 {namespace delete / trace vdelete combo, Bug \#1337229} {
1.1221 + namespace eval ::ns {}
1.1222 + trace add variable ::ns::var unset {unset ::ns::var ;#}
1.1223 + namespace delete ::ns
1.1224 +} {}
1.1225 +test trace-18.4 {namespace delete / trace vdelete combo, Bug \#1338280} {
1.1226 + namespace eval ::ref {}
1.1227 + set ::ref::var1 AAA
1.1228 + trace add variable ::ref::var1 unset doTrace
1.1229 + set ::ref::var2 BBB
1.1230 + trace add variable ::ref::var2 {unset} doTrace
1.1231 + proc doTrace {vtraced vidx op} {
1.1232 + global info
1.1233 + append info [catch {set ::$vtraced}][llength [info vars ::ref::*]]
1.1234 + }
1.1235 + set info {}
1.1236 + namespace delete ::ref
1.1237 + rename doTrace {}
1.1238 + set info
1.1239 +} 1110
1.1240 +
1.1241 +# Delete arrays when done, so they can be re-used as scalars
1.1242 +# elsewhere.
1.1243 +
1.1244 +catch {unset x}
1.1245 +catch {unset y}
1.1246 +
1.1247 +test trace-19.0.1 {trace add command (command existence)} {
1.1248 + # Just in case!
1.1249 + catch {rename nosuchname ""}
1.1250 + list [catch {trace add command nosuchname rename traceCommand} msg] $msg
1.1251 +} {1 {unknown command "nosuchname"}}
1.1252 +test trace-19.0.2 {trace add command (command existence in ns)} {
1.1253 + list [catch {trace add command nosuchns::nosuchname rename traceCommand} msg] $msg
1.1254 +} {1 {unknown command "nosuchns::nosuchname"}}
1.1255 +
1.1256 +
1.1257 +test trace-19.1 {trace add command (rename option)} {
1.1258 + proc foo {} {}
1.1259 + catch {rename bar {}}
1.1260 + trace add command foo rename traceCommand
1.1261 + rename foo bar
1.1262 + set info
1.1263 +} {::foo ::bar rename}
1.1264 +test trace-19.2 {traces stick with renamed commands} {
1.1265 + proc foo {} {}
1.1266 + catch {rename bar {}}
1.1267 + trace add command foo rename traceCommand
1.1268 + rename foo bar
1.1269 + rename bar foo
1.1270 + set info
1.1271 +} {::bar ::foo rename}
1.1272 +test trace-19.2.1 {trace add command rename trace exists} {
1.1273 + proc foo {} {}
1.1274 + trace add command foo rename traceCommand
1.1275 + trace info command foo
1.1276 +} {{rename traceCommand}}
1.1277 +test trace-19.3 {command rename traces don't fire on command deletion} {
1.1278 + proc foo {} {}
1.1279 + set info {}
1.1280 + trace add command foo rename traceCommand
1.1281 + rename foo {}
1.1282 + set info
1.1283 +} {}
1.1284 +test trace-19.4 {trace add command rename doesn't trace recreated commands} {
1.1285 + proc foo {} {}
1.1286 + catch {rename bar {}}
1.1287 + trace add command foo rename traceCommand
1.1288 + proc foo {} {}
1.1289 + rename foo bar
1.1290 + set info
1.1291 +} {}
1.1292 +test trace-19.5 {trace add command deleted removes traces} {
1.1293 + proc foo {} {}
1.1294 + trace add command foo rename traceCommand
1.1295 + proc foo {} {}
1.1296 + trace info command foo
1.1297 +} {}
1.1298 +
1.1299 +namespace eval tc {}
1.1300 +proc tc::tcfoo {} {}
1.1301 +test trace-19.6 {trace add command rename in namespace} {
1.1302 + trace add command tc::tcfoo rename traceCommand
1.1303 + rename tc::tcfoo tc::tcbar
1.1304 + set info
1.1305 +} {::tc::tcfoo ::tc::tcbar rename}
1.1306 +test trace-19.7 {trace add command rename in namespace back again} {
1.1307 + rename tc::tcbar tc::tcfoo
1.1308 + set info
1.1309 +} {::tc::tcbar ::tc::tcfoo rename}
1.1310 +test trace-19.8 {trace add command rename in namespace to out of namespace} {
1.1311 + rename tc::tcfoo tcbar
1.1312 + set info
1.1313 +} {::tc::tcfoo ::tcbar rename}
1.1314 +test trace-19.9 {trace add command rename back into namespace} {
1.1315 + rename tcbar tc::tcfoo
1.1316 + set info
1.1317 +} {::tcbar ::tc::tcfoo rename}
1.1318 +test trace-19.10 {trace add command failed rename doesn't trigger trace} {
1.1319 + set info {}
1.1320 + proc foo {} {}
1.1321 + proc bar {} {}
1.1322 + trace add command foo {rename delete} traceCommand
1.1323 + catch {rename foo bar}
1.1324 + set info
1.1325 +} {}
1.1326 +catch {rename foo {}}
1.1327 +catch {rename bar {}}
1.1328 +test trace-19.11 {trace add command qualifies when renamed in namespace} {
1.1329 + set info {}
1.1330 + namespace eval tc {rename tcfoo tcbar}
1.1331 + set info
1.1332 +} {::tc::tcfoo ::tc::tcbar rename}
1.1333 +
1.1334 +# Make sure it exists again
1.1335 +proc foo {} {}
1.1336 +
1.1337 +test trace-20.1 {trace add command (delete option)} {
1.1338 + trace add command foo delete traceCommand
1.1339 + rename foo ""
1.1340 + set info
1.1341 +} {::foo {} delete}
1.1342 +test trace-20.2 {trace add command delete doesn't trace recreated commands} {
1.1343 + set info {}
1.1344 + proc foo {} {}
1.1345 + rename foo ""
1.1346 + set info
1.1347 +} {}
1.1348 +test trace-20.2.1 {trace add command delete trace info} {
1.1349 + proc foo {} {}
1.1350 + trace add command foo delete traceCommand
1.1351 + trace info command foo
1.1352 +} {{delete traceCommand}}
1.1353 +test trace-20.3 {trace add command implicit delete} {
1.1354 + proc foo {} {}
1.1355 + trace add command foo delete traceCommand
1.1356 + proc foo {} {}
1.1357 + set info
1.1358 +} {::foo {} delete}
1.1359 +test trace-20.3.1 {trace add command delete trace info} {
1.1360 + proc foo {} {}
1.1361 + trace info command foo
1.1362 +} {}
1.1363 +test trace-20.4 {trace add command rename followed by delete} {
1.1364 + set infotemp {}
1.1365 + proc foo {} {}
1.1366 + trace add command foo {rename delete} traceCommand
1.1367 + rename foo bar
1.1368 + lappend infotemp $info
1.1369 + rename bar {}
1.1370 + lappend infotemp $info
1.1371 + set info $infotemp
1.1372 + unset infotemp
1.1373 + set info
1.1374 +} {{::foo ::bar rename} {::bar {} delete}}
1.1375 +catch {rename foo {}}
1.1376 +catch {rename bar {}}
1.1377 +
1.1378 +test trace-20.5 {trace add command rename and delete} {
1.1379 + set infotemp {}
1.1380 + set info {}
1.1381 + proc foo {} {}
1.1382 + trace add command foo {rename delete} traceCommand
1.1383 + rename foo bar
1.1384 + lappend infotemp $info
1.1385 + rename bar {}
1.1386 + lappend infotemp $info
1.1387 + set info $infotemp
1.1388 + unset infotemp
1.1389 + set info
1.1390 +} {{::foo ::bar rename} {::bar {} delete}}
1.1391 +
1.1392 +test trace-20.6 {trace add command rename and delete in subinterp} {
1.1393 + set tc [interp create]
1.1394 + foreach p {traceCommand} {
1.1395 + $tc eval [list proc $p [info args $p] [info body $p]]
1.1396 + }
1.1397 + $tc eval [list set infotemp {}]
1.1398 + $tc eval [list set info {}]
1.1399 + $tc eval [list proc foo {} {}]
1.1400 + $tc eval [list trace add command foo {rename delete} traceCommand]
1.1401 + $tc eval [list rename foo bar]
1.1402 + $tc eval {lappend infotemp $info}
1.1403 + $tc eval [list rename bar {}]
1.1404 + $tc eval {lappend infotemp $info}
1.1405 + $tc eval {set info $infotemp}
1.1406 + $tc eval [list unset infotemp]
1.1407 + set info [$tc eval [list set info]]
1.1408 + interp delete $tc
1.1409 + set info
1.1410 +} {{::foo ::bar rename} {::bar {} delete}}
1.1411 +
1.1412 +# I'd like it if this test could give 'foo {} d' as a result,
1.1413 +# but interp deletion means there is no interp to evaluate
1.1414 +# the trace in.
1.1415 +test trace-20.7 {trace add command delete in subinterp while being deleted} {
1.1416 + set info {}
1.1417 + set tc [interp create]
1.1418 + interp alias $tc traceCommand {} traceCommand
1.1419 + $tc eval [list proc foo {} {}]
1.1420 + $tc eval [list trace add command foo {rename delete} traceCommand]
1.1421 + interp delete $tc
1.1422 + set info
1.1423 +} {}
1.1424 +
1.1425 +proc traceDelete {cmd old new op} {
1.1426 + eval trace remove command $cmd [lindex [trace info command $cmd] 0]
1.1427 + global info
1.1428 + set info [list $old $new $op]
1.1429 +}
1.1430 +proc traceCmdrename {cmd old new op} {
1.1431 + rename $old someothername
1.1432 +}
1.1433 +proc traceCmddelete {cmd old new op} {
1.1434 + rename $old ""
1.1435 +}
1.1436 +test trace-20.8 {trace delete while trace is active} {
1.1437 + set info {}
1.1438 + proc foo {} {}
1.1439 + catch {rename bar {}}
1.1440 + trace add command foo {rename delete} [list traceDelete foo]
1.1441 + rename foo bar
1.1442 + list [set info] [trace info command bar]
1.1443 +} {{::foo ::bar rename} {}}
1.1444 +
1.1445 +test trace-20.9 {rename trace deletes command} {
1.1446 + set info {}
1.1447 + proc foo {} {}
1.1448 + catch {rename bar {}}
1.1449 + catch {rename someothername {}}
1.1450 + trace add command foo rename [list traceCmddelete foo]
1.1451 + rename foo bar
1.1452 + list [info commands foo] [info commands bar] [info commands someothername]
1.1453 +} {{} {} {}}
1.1454 +
1.1455 +test trace-20.10 {rename trace renames command} {
1.1456 + set info {}
1.1457 + proc foo {} {}
1.1458 + catch {rename bar {}}
1.1459 + catch {rename someothername {}}
1.1460 + trace add command foo rename [list traceCmdrename foo]
1.1461 + rename foo bar
1.1462 + set info [list [info commands foo] [info commands bar] [info commands someothername]]
1.1463 + rename someothername {}
1.1464 + set info
1.1465 +} {{} {} someothername}
1.1466 +
1.1467 +test trace-20.11 {delete trace deletes command} {
1.1468 + set info {}
1.1469 + proc foo {} {}
1.1470 + catch {rename bar {}}
1.1471 + catch {rename someothername {}}
1.1472 + trace add command foo delete [list traceCmddelete foo]
1.1473 + rename foo {}
1.1474 + list [info commands foo] [info commands bar] [info commands someothername]
1.1475 +} {{} {} {}}
1.1476 +
1.1477 +test trace-20.12 {delete trace renames command} {
1.1478 + set info {}
1.1479 + proc foo {} {}
1.1480 + catch {rename bar {}}
1.1481 + catch {rename someothername {}}
1.1482 + trace add command foo delete [list traceCmdrename foo]
1.1483 + rename foo bar
1.1484 + rename bar {}
1.1485 + # None of these should exist.
1.1486 + list [info commands foo] [info commands bar] [info commands someothername]
1.1487 +} {{} {} {}}
1.1488 +
1.1489 +test trace-20.13 {rename trace discards result [Bug 1355342]} {
1.1490 + proc foo {} {}
1.1491 + trace add command foo rename {set w Aha!;#}
1.1492 + list [rename foo bar] [rename bar {}]
1.1493 +} {{} {}}
1.1494 +test trace-20.14 {rename trace discards error result [Bug 1355342]} {
1.1495 + proc foo {} {}
1.1496 + trace add command foo rename {error}
1.1497 + list [rename foo bar] [rename bar {}]
1.1498 +} {{} {}}
1.1499 +test trace-20.15 {delete trace discards result [Bug 1355342]} {
1.1500 + proc foo {} {}
1.1501 + trace add command foo delete {set w Aha!;#}
1.1502 + rename foo {}
1.1503 +} {}
1.1504 +test trace-20.16 {delete trace discards error result [Bug 1355342]} {
1.1505 + proc foo {} {}
1.1506 + trace add command foo delete {error}
1.1507 + rename foo {}
1.1508 +} {}
1.1509 +
1.1510 +proc foo {b} { set a $b }
1.1511 +
1.1512 +
1.1513 +# Delete arrays when done, so they can be re-used as scalars
1.1514 +# elsewhere.
1.1515 +
1.1516 +catch {unset x}
1.1517 +catch {unset y}
1.1518 +
1.1519 +# Delete procedures when done, so we don't clash with other tests
1.1520 +# (e.g. foobar will clash with 'unknown' tests).
1.1521 +catch {rename foobar {}}
1.1522 +catch {rename foo {}}
1.1523 +catch {rename bar {}}
1.1524 +
1.1525 +proc foo {a} {
1.1526 + set b $a
1.1527 +}
1.1528 +
1.1529 +proc traceExecute {args} {
1.1530 + global info
1.1531 + lappend info $args
1.1532 +}
1.1533 +
1.1534 +test trace-21.1 {trace execution: enter} {
1.1535 + set info {}
1.1536 + trace add execution foo enter [list traceExecute foo]
1.1537 + foo 1
1.1538 + trace remove execution foo enter [list traceExecute foo]
1.1539 + set info
1.1540 +} {{foo {foo 1} enter}}
1.1541 +
1.1542 +test trace-21.2 {trace exeuction: leave} {
1.1543 + set info {}
1.1544 + trace add execution foo leave [list traceExecute foo]
1.1545 + foo 2
1.1546 + trace remove execution foo leave [list traceExecute foo]
1.1547 + set info
1.1548 +} {{foo {foo 2} 0 2 leave}}
1.1549 +
1.1550 +test trace-21.3 {trace exeuction: enter, leave} {
1.1551 + set info {}
1.1552 + trace add execution foo {enter leave} [list traceExecute foo]
1.1553 + foo 3
1.1554 + trace remove execution foo {enter leave} [list traceExecute foo]
1.1555 + set info
1.1556 +} {{foo {foo 3} enter} {foo {foo 3} 0 3 leave}}
1.1557 +
1.1558 +test trace-21.4 {trace execution: enter, leave, enterstep} {
1.1559 + set info {}
1.1560 + trace add execution foo {enter leave enterstep} [list traceExecute foo]
1.1561 + foo 3
1.1562 + trace remove execution foo {enter leave enterstep} [list traceExecute foo]
1.1563 + set info
1.1564 +} {{foo {foo 3} enter} {foo {set b 3} enterstep} {foo {foo 3} 0 3 leave}}
1.1565 +
1.1566 +test trace-21.5 {trace execution: enter, leave, enterstep, leavestep} {
1.1567 + set info {}
1.1568 + trace add execution foo {enter leave enterstep leavestep} [list traceExecute foo]
1.1569 + foo 3
1.1570 + trace remove execution foo {enter leave enterstep leavestep} [list traceExecute foo]
1.1571 + set info
1.1572 +} {{foo {foo 3} enter} {foo {set b 3} enterstep} {foo {set b 3} 0 3 leavestep} {foo {foo 3} 0 3 leave}}
1.1573 +
1.1574 +test trace-21.6 {trace execution: enterstep, leavestep} {
1.1575 + set info {}
1.1576 + trace add execution foo {enterstep leavestep} [list traceExecute foo]
1.1577 + foo 3
1.1578 + trace remove execution foo {enterstep leavestep} [list traceExecute foo]
1.1579 + set info
1.1580 +} {{foo {set b 3} enterstep} {foo {set b 3} 0 3 leavestep}}
1.1581 +
1.1582 +test trace-21.7 {trace execution: enterstep} {
1.1583 + set info {}
1.1584 + trace add execution foo {enterstep} [list traceExecute foo]
1.1585 + foo 3
1.1586 + trace remove execution foo {enterstep} [list traceExecute foo]
1.1587 + set info
1.1588 +} {{foo {set b 3} enterstep}}
1.1589 +
1.1590 +test trace-21.8 {trace execution: leavestep} {
1.1591 + set info {}
1.1592 + trace add execution foo {leavestep} [list traceExecute foo]
1.1593 + foo 3
1.1594 + trace remove execution foo {leavestep} [list traceExecute foo]
1.1595 + set info
1.1596 +} {{foo {set b 3} 0 3 leavestep}}
1.1597 +
1.1598 +test trace-21.9 {trace execution: TCL_EVAL_GLOBAL} testevalobjv {
1.1599 + trace add execution foo enter soom
1.1600 + proc ::soom args {lappend ::info SUCCESS [info level]}
1.1601 + set ::info {}
1.1602 + namespace eval test_ns_1 {
1.1603 + proc soom args {lappend ::info FAIL [info level]}
1.1604 + # [testevalobjv 1 ...] ought to produce the same
1.1605 + # results as [uplevel #0 ...].
1.1606 + testevalobjv 1 foo x
1.1607 + uplevel #0 foo x
1.1608 + }
1.1609 + namespace delete test_ns_1
1.1610 + trace remove execution foo enter soom
1.1611 + set ::info
1.1612 +} {SUCCESS 1 SUCCESS 1}
1.1613 +
1.1614 +test trace-21.10 {trace execution: TCL_EVAL_GLOBAL} testevalobjv {
1.1615 + trace add execution foo leave soom
1.1616 + proc ::soom args {lappend ::info SUCCESS [info level]}
1.1617 + set ::info {}
1.1618 + namespace eval test_ns_1 {
1.1619 + proc soom args {lappend ::info FAIL [info level]}
1.1620 + # [testevalobjv 1 ...] ought to produce the same
1.1621 + # results as [uplevel #0 ...].
1.1622 + testevalobjv 1 foo x
1.1623 + uplevel #0 foo x
1.1624 + }
1.1625 + namespace delete test_ns_1
1.1626 + trace remove execution foo leave soom
1.1627 + set ::info
1.1628 +} {SUCCESS 1 SUCCESS 1}
1.1629 +
1.1630 +test trace-21.11 {trace execution and alias} -setup {
1.1631 + set res {}
1.1632 + proc ::x {} {return ::}
1.1633 + namespace eval a {}
1.1634 + proc ::a::x {} {return ::a}
1.1635 + interp alias {} y {} x
1.1636 +} -body {
1.1637 + lappend res [namespace eval ::a y]
1.1638 + trace add execution ::x enter {
1.1639 + rename ::x {}
1.1640 + proc ::x {} {return ::}
1.1641 + #}
1.1642 + lappend res [namespace eval ::a y]
1.1643 +} -cleanup {
1.1644 + namespace delete a
1.1645 + rename ::x {}
1.1646 +} -result {:: ::}
1.1647 +
1.1648 +proc factorial {n} {
1.1649 + if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }
1.1650 + return 1
1.1651 +}
1.1652 +
1.1653 +test trace-22.1 {recursive(1) trace execution: enter} {
1.1654 + set info {}
1.1655 + trace add execution factorial {enter} [list traceExecute factorial]
1.1656 + factorial 1
1.1657 + trace remove execution factorial {enter} [list traceExecute factorial]
1.1658 + set info
1.1659 +} {{factorial {factorial 1} enter}}
1.1660 +
1.1661 +test trace-22.2 {recursive(2) trace execution: enter} {
1.1662 + set info {}
1.1663 + trace add execution factorial {enter} [list traceExecute factorial]
1.1664 + factorial 2
1.1665 + trace remove execution factorial {enter} [list traceExecute factorial]
1.1666 + set info
1.1667 +} {{factorial {factorial 2} enter} {factorial {factorial 1} enter}}
1.1668 +
1.1669 +test trace-22.3 {recursive(3) trace execution: enter} {
1.1670 + set info {}
1.1671 + trace add execution factorial {enter} [list traceExecute factorial]
1.1672 + factorial 3
1.1673 + trace remove execution factorial {enter} [list traceExecute factorial]
1.1674 + set info
1.1675 +} {{factorial {factorial 3} enter} {factorial {factorial 2} enter} {factorial {factorial 1} enter}}
1.1676 +
1.1677 +test trace-23.1 {recursive(1) trace execution: enter, leave, enterstep, leavestep} {
1.1678 + set info {}
1.1679 + trace add execution factorial {enter leave enterstep leavestep} [list traceExecute]
1.1680 + factorial 1
1.1681 + trace remove execution factorial {enter leave enterstep leavestep} [list traceExecute]
1.1682 + join $info "\n"
1.1683 +} {{factorial 1} enter
1.1684 +{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep
1.1685 +{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 0 {} leavestep
1.1686 +{return 1} enterstep
1.1687 +{return 1} 2 1 leavestep
1.1688 +{factorial 1} 0 1 leave}
1.1689 +
1.1690 +test trace-23.2 {recursive(2) trace execution: enter, leave, enterstep, leavestep} {
1.1691 + set info {}
1.1692 + trace add execution factorial {enter leave enterstep leavestep} [list traceExecute]
1.1693 + factorial 2
1.1694 + trace remove execution factorial {enter leave enterstep leavestep} [list traceExecute]
1.1695 + join $info "\n"
1.1696 +} {{factorial 2} enter
1.1697 +{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep
1.1698 +{expr {$n * [factorial [expr {$n -1 }]]}} enterstep
1.1699 +{expr {$n -1 }} enterstep
1.1700 +{expr {$n -1 }} 0 1 leavestep
1.1701 +{factorial 1} enterstep
1.1702 +{factorial 1} enter
1.1703 +{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep
1.1704 +{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 0 {} leavestep
1.1705 +{return 1} enterstep
1.1706 +{return 1} 2 1 leavestep
1.1707 +{factorial 1} 0 1 leave
1.1708 +{factorial 1} 0 1 leavestep
1.1709 +{expr {$n * [factorial [expr {$n -1 }]]}} 0 2 leavestep
1.1710 +{return 2} enterstep
1.1711 +{return 2} 2 2 leavestep
1.1712 +{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 2 2 leavestep
1.1713 +{factorial 2} 0 2 leave}
1.1714 +
1.1715 +test trace-23.3 {recursive(3) trace execution: enter, leave, enterstep, leavestep} {
1.1716 + set info {}
1.1717 + trace add execution factorial {enter leave enterstep leavestep} [list traceExecute]
1.1718 + factorial 3
1.1719 + trace remove execution factorial {enter leave enterstep leavestep} [list traceExecute]
1.1720 + join $info "\n"
1.1721 +} {{factorial 3} enter
1.1722 +{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep
1.1723 +{expr {$n * [factorial [expr {$n -1 }]]}} enterstep
1.1724 +{expr {$n -1 }} enterstep
1.1725 +{expr {$n -1 }} 0 2 leavestep
1.1726 +{factorial 2} enterstep
1.1727 +{factorial 2} enter
1.1728 +{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep
1.1729 +{expr {$n * [factorial [expr {$n -1 }]]}} enterstep
1.1730 +{expr {$n -1 }} enterstep
1.1731 +{expr {$n -1 }} 0 1 leavestep
1.1732 +{factorial 1} enterstep
1.1733 +{factorial 1} enter
1.1734 +{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep
1.1735 +{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 0 {} leavestep
1.1736 +{return 1} enterstep
1.1737 +{return 1} 2 1 leavestep
1.1738 +{factorial 1} 0 1 leave
1.1739 +{factorial 1} 0 1 leavestep
1.1740 +{expr {$n * [factorial [expr {$n -1 }]]}} 0 2 leavestep
1.1741 +{return 2} enterstep
1.1742 +{return 2} 2 2 leavestep
1.1743 +{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 2 2 leavestep
1.1744 +{factorial 2} 0 2 leave
1.1745 +{factorial 2} 0 2 leavestep
1.1746 +{expr {$n * [factorial [expr {$n -1 }]]}} 0 6 leavestep
1.1747 +{return 6} enterstep
1.1748 +{return 6} 2 6 leavestep
1.1749 +{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 2 6 leavestep
1.1750 +{factorial 3} 0 6 leave}
1.1751 +
1.1752 +proc traceDelete {cmd args} {
1.1753 + eval trace remove execution $cmd [lindex [trace info execution $cmd] 0]
1.1754 + global info
1.1755 + set info $args
1.1756 +}
1.1757 +
1.1758 +test trace-24.1 {delete trace during enter trace} {
1.1759 + set info {}
1.1760 + trace add execution foo enter [list traceDelete foo]
1.1761 + foo 1
1.1762 + list $info [catch {trace info execution foo} res] $res
1.1763 +} {{{foo 1} enter} 0 {}}
1.1764 +
1.1765 +test trace-24.2 {delete trace during leave trace} {
1.1766 + set info {}
1.1767 + trace add execution foo leave [list traceDelete foo]
1.1768 + foo 1
1.1769 + list $info [catch {trace info execution foo} res] $res
1.1770 +} {{{foo 1} 0 1 leave} 0 {}}
1.1771 +
1.1772 +test trace-24.3 {delete trace during enter-leave trace} {
1.1773 + set info {}
1.1774 + trace add execution foo {enter leave} [list traceDelete foo]
1.1775 + foo 1
1.1776 + list $info [catch {trace info execution foo} res] $res
1.1777 +} {{{foo 1} enter} 0 {}}
1.1778 +
1.1779 +test trace-24.4 {delete trace during all exec traces} {
1.1780 + set info {}
1.1781 + trace add execution foo {enter leave enterstep leavestep} [list traceDelete foo]
1.1782 + foo 1
1.1783 + list $info [catch {trace info execution foo} res] $res
1.1784 +} {{{foo 1} enter} 0 {}}
1.1785 +
1.1786 +test trace-24.5 {delete trace during all exec traces except enter} {
1.1787 + set info {}
1.1788 + trace add execution foo {leave enterstep leavestep} [list traceDelete foo]
1.1789 + foo 1
1.1790 + list $info [catch {trace info execution foo} res] $res
1.1791 +} {{{set b 1} enterstep} 0 {}}
1.1792 +
1.1793 +proc traceDelete {cmd args} {
1.1794 + rename $cmd {}
1.1795 + global info
1.1796 + set info $args
1.1797 +}
1.1798 +
1.1799 +proc foo {a} {
1.1800 + set b $a
1.1801 +}
1.1802 +
1.1803 +test trace-25.1 {delete command during enter trace} {
1.1804 + set info {}
1.1805 + trace add execution foo enter [list traceDelete foo]
1.1806 + catch {foo 1} err
1.1807 + list $err $info [catch {trace info execution foo} res] $res
1.1808 +} {{invalid command name "foo"} {{foo 1} enter} 1 {unknown command "foo"}}
1.1809 +
1.1810 +proc foo {a} {
1.1811 + set b $a
1.1812 +}
1.1813 +
1.1814 +test trace-25.2 {delete command during leave trace} {
1.1815 + set info {}
1.1816 + trace add execution foo leave [list traceDelete foo]
1.1817 + foo 1
1.1818 + list $info [catch {trace info execution foo} res] $res
1.1819 +} {{{foo 1} 0 1 leave} 1 {unknown command "foo"}}
1.1820 +
1.1821 +proc foo {a} {
1.1822 + set b $a
1.1823 +}
1.1824 +
1.1825 +test trace-25.3 {delete command during enter then leave trace} {
1.1826 + set info {}
1.1827 + trace add execution foo enter [list traceDelete foo]
1.1828 + trace add execution foo leave [list traceDelete foo]
1.1829 + catch {foo 1} err
1.1830 + list $err $info [catch {trace info execution foo} res] $res
1.1831 +} {{invalid command name "foo"} {{foo 1} enter} 1 {unknown command "foo"}}
1.1832 +
1.1833 +proc foo {a} {
1.1834 + set b $a
1.1835 +}
1.1836 +proc traceExecute2 {args} {
1.1837 + global info
1.1838 + lappend info $args
1.1839 +}
1.1840 +
1.1841 +# This shows the peculiar consequences of having two traces
1.1842 +# at the same time: as well as tracing the procedure you want
1.1843 +test trace-25.4 {order dependencies of two enter traces} {
1.1844 + set info {}
1.1845 + trace add execution foo enter [list traceExecute traceExecute]
1.1846 + trace add execution foo enter [list traceExecute2 traceExecute2]
1.1847 + catch {foo 1} err
1.1848 + trace remove execution foo enter [list traceExecute traceExecute]
1.1849 + trace remove execution foo enter [list traceExecute2 traceExecute2]
1.1850 + join [list $err [join $info \n] [trace info execution foo]] "\n"
1.1851 +} {1
1.1852 +traceExecute2 {foo 1} enter
1.1853 +traceExecute {foo 1} enter
1.1854 +}
1.1855 +
1.1856 +test trace-25.5 {order dependencies of two step traces} {
1.1857 + set info {}
1.1858 + trace add execution foo enterstep [list traceExecute traceExecute]
1.1859 + trace add execution foo enterstep [list traceExecute2 traceExecute2]
1.1860 + catch {foo 1} err
1.1861 + trace remove execution foo enterstep [list traceExecute traceExecute]
1.1862 + trace remove execution foo enterstep [list traceExecute2 traceExecute2]
1.1863 + join [list $err [join $info \n] [trace info execution foo]] "\n"
1.1864 +} {1
1.1865 +traceExecute2 {set b 1} enterstep
1.1866 +traceExecute {set b 1} enterstep
1.1867 +}
1.1868 +
1.1869 +# We don't want the result string (5th argument), or the results
1.1870 +# will get unmanageable.
1.1871 +proc tracePostExecute {args} {
1.1872 + global info
1.1873 + lappend info [concat [lrange $args 0 2] [lindex $args 4]]
1.1874 +}
1.1875 +proc tracePostExecute2 {args} {
1.1876 + global info
1.1877 + lappend info [concat [lrange $args 0 2] [lindex $args 4]]
1.1878 +}
1.1879 +
1.1880 +test trace-25.6 {order dependencies of two leave traces} {
1.1881 + set info {}
1.1882 + trace add execution foo leave [list tracePostExecute tracePostExecute]
1.1883 + trace add execution foo leave [list tracePostExecute2 tracePostExecute2]
1.1884 + catch {foo 1} err
1.1885 + trace remove execution foo leave [list tracePostExecute tracePostExecute]
1.1886 + trace remove execution foo leave [list tracePostExecute2 tracePostExecute2]
1.1887 + join [list $err [join $info \n] [trace info execution foo]] "\n"
1.1888 +} {1
1.1889 +tracePostExecute {foo 1} 0 leave
1.1890 +tracePostExecute2 {foo 1} 0 leave
1.1891 +}
1.1892 +
1.1893 +test trace-25.7 {order dependencies of two leavestep traces} {
1.1894 + set info {}
1.1895 + trace add execution foo leavestep [list tracePostExecute tracePostExecute]
1.1896 + trace add execution foo leavestep [list tracePostExecute2 tracePostExecute2]
1.1897 + catch {foo 1} err
1.1898 + trace remove execution foo leavestep [list tracePostExecute tracePostExecute]
1.1899 + trace remove execution foo leavestep [list tracePostExecute2 tracePostExecute2]
1.1900 + join [list $err [join $info \n] [trace info execution foo]] "\n"
1.1901 +} {1
1.1902 +tracePostExecute {set b 1} 0 leavestep
1.1903 +tracePostExecute2 {set b 1} 0 leavestep
1.1904 +}
1.1905 +
1.1906 +proc foo {a} {
1.1907 + set b $a
1.1908 +}
1.1909 +
1.1910 +proc traceDelete {cmd args} {
1.1911 + rename $cmd {}
1.1912 + global info
1.1913 + set info $args
1.1914 +}
1.1915 +
1.1916 +test trace-25.8 {delete command during enter leave and enter/leave-step traces} {
1.1917 + set info {}
1.1918 + trace add execution foo enter [list traceDelete foo]
1.1919 + trace add execution foo leave [list traceDelete foo]
1.1920 + trace add execution foo enterstep [list traceDelete foo]
1.1921 + trace add execution foo leavestep [list traceDelete foo]
1.1922 + catch {foo 1} err
1.1923 + list $err $info [catch {trace info execution foo} res] $res
1.1924 +} {{invalid command name "foo"} {{foo 1} enter} 1 {unknown command "foo"}}
1.1925 +
1.1926 +proc foo {a} {
1.1927 + set b $a
1.1928 +}
1.1929 +
1.1930 +test trace-25.9 {delete command during enter leave and leavestep traces} {
1.1931 + set info {}
1.1932 + trace add execution foo enter [list traceDelete foo]
1.1933 + trace add execution foo leave [list traceDelete foo]
1.1934 + trace add execution foo leavestep [list traceDelete foo]
1.1935 + catch {foo 1} err
1.1936 + list $err $info [catch {trace info execution foo} res] $res
1.1937 +} {{invalid command name "foo"} {{foo 1} enter} 1 {unknown command "foo"}}
1.1938 +
1.1939 +proc foo {a} {
1.1940 + set b $a
1.1941 +}
1.1942 +
1.1943 +test trace-25.10 {delete command during leave and leavestep traces} {
1.1944 + set info {}
1.1945 + trace add execution foo leave [list traceDelete foo]
1.1946 + trace add execution foo leavestep [list traceDelete foo]
1.1947 + catch {foo 1} err
1.1948 + list $err $info [catch {trace info execution foo} res] $res
1.1949 +} {1 {{set b 1} 0 1 leavestep} 1 {unknown command "foo"}}
1.1950 +
1.1951 +proc foo {a} {
1.1952 + set b $a
1.1953 +}
1.1954 +
1.1955 +test trace-25.11 {delete command during enter and enterstep traces} {
1.1956 + set info {}
1.1957 + trace add execution foo enter [list traceDelete foo]
1.1958 + trace add execution foo enterstep [list traceDelete foo]
1.1959 + catch {foo 1} err
1.1960 + list $err $info [catch {trace info execution foo} res] $res
1.1961 +} {{invalid command name "foo"} {{foo 1} enter} 1 {unknown command "foo"}}
1.1962 +
1.1963 +test trace-26.1 {trace targetCmd when invoked through an alias} {
1.1964 + proc foo {args} {
1.1965 + set b $args
1.1966 + }
1.1967 + set info {}
1.1968 + trace add execution foo enter [list traceExecute foo]
1.1969 + interp alias {} bar {} foo 1
1.1970 + bar 2
1.1971 + trace remove execution foo enter [list traceExecute foo]
1.1972 + set info
1.1973 +} {{foo {foo 1 2} enter}}
1.1974 +test trace-26.2 {trace targetCmd when invoked through an alias} {
1.1975 + proc foo {args} {
1.1976 + set b $args
1.1977 + }
1.1978 + set info {}
1.1979 + trace add execution foo enter [list traceExecute foo]
1.1980 + interp create child
1.1981 + interp alias child bar {} foo 1
1.1982 + child eval bar 2
1.1983 + interp delete child
1.1984 + trace remove execution foo enter [list traceExecute foo]
1.1985 + set info
1.1986 +} {{foo {foo 1 2} enter}}
1.1987 +
1.1988 +test trace-27.1 {memory leak in rename trace (604609)} {
1.1989 + catch {rename bar {}}
1.1990 + proc foo {} {error foo}
1.1991 + trace add command foo rename {rename foo "" ;#}
1.1992 + rename foo bar
1.1993 + info commands foo
1.1994 +} {}
1.1995 +
1.1996 +test trace-27.2 {command trace remove nonsense} {
1.1997 + list [catch {trace remove command thisdoesntexist \
1.1998 + {delete rename} bar} res] $res
1.1999 +} {1 {unknown command "thisdoesntexist"}}
1.2000 +
1.2001 +test trace-27.3 {command trace info nonsense} {
1.2002 + list [catch {trace info command thisdoesntexist} res] $res
1.2003 +} {1 {unknown command "thisdoesntexist"}}
1.2004 +
1.2005 +
1.2006 +test trace-28.1 {enterstep and leavestep traces with update idletasks (615043)} {
1.2007 + catch {rename foo {}}
1.2008 + proc foo {} {
1.2009 + set a 1
1.2010 + update idletasks
1.2011 + set b 1
1.2012 + }
1.2013 +
1.2014 + set info {}
1.2015 + trace add execution foo {enter enterstep leavestep leave} \
1.2016 + [list traceExecute foo]
1.2017 + update
1.2018 + after idle {set a "idle"}
1.2019 + foo
1.2020 +
1.2021 + trace remove execution foo {enter enterstep leavestep leave} \
1.2022 + [list traceExecute foo]
1.2023 + rename foo {}
1.2024 + catch {unset a}
1.2025 + join $info "\n"
1.2026 +} {foo foo enter
1.2027 +foo {set a 1} enterstep
1.2028 +foo {set a 1} 0 1 leavestep
1.2029 +foo {update idletasks} enterstep
1.2030 +foo {set a idle} enterstep
1.2031 +foo {set a idle} 0 idle leavestep
1.2032 +foo {update idletasks} 0 {} leavestep
1.2033 +foo {set b 1} enterstep
1.2034 +foo {set b 1} 0 1 leavestep
1.2035 +foo foo 0 1 leave}
1.2036 +
1.2037 +test trace-28.2 {exec traces with 'error'} {
1.2038 + set info {}
1.2039 + set res {}
1.2040 +
1.2041 + proc foo {} {
1.2042 + if {[catch {bar}]} {
1.2043 + return "error"
1.2044 + } else {
1.2045 + return "ok"
1.2046 + }
1.2047 + }
1.2048 +
1.2049 + proc bar {} { error "msg" }
1.2050 +
1.2051 + lappend res [foo]
1.2052 +
1.2053 + trace add execution foo {enter enterstep leave leavestep} \
1.2054 + [list traceExecute foo]
1.2055 +
1.2056 + # With the trace active
1.2057 +
1.2058 + lappend res [foo]
1.2059 +
1.2060 + trace remove execution foo {enter enterstep leave leavestep} \
1.2061 + [list traceExecute foo]
1.2062 +
1.2063 + list $res [join $info \n]
1.2064 +} {{error error} {foo foo enter
1.2065 +foo {if {[catch {bar}]} {
1.2066 + return "error"
1.2067 + } else {
1.2068 + return "ok"
1.2069 + }} enterstep
1.2070 +foo {catch bar} enterstep
1.2071 +foo bar enterstep
1.2072 +foo {error msg} enterstep
1.2073 +foo {error msg} 1 msg leavestep
1.2074 +foo bar 1 msg leavestep
1.2075 +foo {catch bar} 0 1 leavestep
1.2076 +foo {return error} enterstep
1.2077 +foo {return error} 2 error leavestep
1.2078 +foo {if {[catch {bar}]} {
1.2079 + return "error"
1.2080 + } else {
1.2081 + return "ok"
1.2082 + }} 2 error leavestep
1.2083 +foo foo 0 error leave}}
1.2084 +
1.2085 +test trace-28.3 {exec traces with 'return -code error'} {
1.2086 + set info {}
1.2087 + set res {}
1.2088 +
1.2089 + proc foo {} {
1.2090 + if {[catch {bar}]} {
1.2091 + return "error"
1.2092 + } else {
1.2093 + return "ok"
1.2094 + }
1.2095 + }
1.2096 +
1.2097 + proc bar {} { return -code error "msg" }
1.2098 +
1.2099 + lappend res [foo]
1.2100 +
1.2101 + trace add execution foo {enter enterstep leave leavestep} \
1.2102 + [list traceExecute foo]
1.2103 +
1.2104 + # With the trace active
1.2105 +
1.2106 + lappend res [foo]
1.2107 +
1.2108 + trace remove execution foo {enter enterstep leave leavestep} \
1.2109 + [list traceExecute foo]
1.2110 +
1.2111 + list $res [join $info \n]
1.2112 +} {{error error} {foo foo enter
1.2113 +foo {if {[catch {bar}]} {
1.2114 + return "error"
1.2115 + } else {
1.2116 + return "ok"
1.2117 + }} enterstep
1.2118 +foo {catch bar} enterstep
1.2119 +foo bar enterstep
1.2120 +foo {return -code error msg} enterstep
1.2121 +foo {return -code error msg} 2 msg leavestep
1.2122 +foo bar 1 msg leavestep
1.2123 +foo {catch bar} 0 1 leavestep
1.2124 +foo {return error} enterstep
1.2125 +foo {return error} 2 error leavestep
1.2126 +foo {if {[catch {bar}]} {
1.2127 + return "error"
1.2128 + } else {
1.2129 + return "ok"
1.2130 + }} 2 error leavestep
1.2131 +foo foo 0 error leave}}
1.2132 +
1.2133 +test trace-28.4 {exec traces in slave with 'return -code error'} {
1.2134 + interp create slave
1.2135 + interp alias slave traceExecute {} traceExecute
1.2136 + set info {}
1.2137 + set res [interp eval slave {
1.2138 + set info {}
1.2139 + set res {}
1.2140 +
1.2141 + proc foo {} {
1.2142 + if {[catch {bar}]} {
1.2143 + return "error"
1.2144 + } else {
1.2145 + return "ok"
1.2146 + }
1.2147 + }
1.2148 +
1.2149 + proc bar {} { return -code error "msg" }
1.2150 +
1.2151 + lappend res [foo]
1.2152 +
1.2153 + trace add execution foo {enter enterstep leave leavestep} \
1.2154 + [list traceExecute foo]
1.2155 +
1.2156 + # With the trace active
1.2157 +
1.2158 + lappend res [foo]
1.2159 +
1.2160 + trace remove execution foo {enter enterstep leave leavestep} \
1.2161 + [list traceExecute foo]
1.2162 +
1.2163 + list $res
1.2164 + }]
1.2165 + interp delete slave
1.2166 + lappend res [join $info \n]
1.2167 +} {{error error} {foo foo enter
1.2168 +foo {if {[catch {bar}]} {
1.2169 + return "error"
1.2170 + } else {
1.2171 + return "ok"
1.2172 + }} enterstep
1.2173 +foo {catch bar} enterstep
1.2174 +foo bar enterstep
1.2175 +foo {return -code error msg} enterstep
1.2176 +foo {return -code error msg} 2 msg leavestep
1.2177 +foo bar 1 msg leavestep
1.2178 +foo {catch bar} 0 1 leavestep
1.2179 +foo {return error} enterstep
1.2180 +foo {return error} 2 error leavestep
1.2181 +foo {if {[catch {bar}]} {
1.2182 + return "error"
1.2183 + } else {
1.2184 + return "ok"
1.2185 + }} 2 error leavestep
1.2186 +foo foo 0 error leave}}
1.2187 +
1.2188 +test trace-28.5 {exec traces} {
1.2189 + set info {}
1.2190 + proc foo {args} { set a 1 }
1.2191 + trace add execution foo {enter enterstep leave leavestep} \
1.2192 + [list traceExecute foo]
1.2193 + after idle [list foo test-28.4]
1.2194 + update
1.2195 + # Complicated way of removing traces
1.2196 + set ti [lindex [eval [list trace info execution ::foo]] 0]
1.2197 + if {[llength $ti]} {
1.2198 + eval [concat [list trace remove execution foo] $ti]
1.2199 + }
1.2200 + join $info \n
1.2201 +} {foo {foo test-28.4} enter
1.2202 +foo {set a 1} enterstep
1.2203 +foo {set a 1} 0 1 leavestep
1.2204 +foo {foo test-28.4} 0 1 leave}
1.2205 +
1.2206 +test trace-28.6 {exec traces firing order} {
1.2207 + set info {}
1.2208 + proc enterStep {cmd op} {lappend ::info "enter $cmd/$op"}
1.2209 + proc leaveStep {cmd code result op} {lappend ::info "leave $cmd/$code/$result/$op"}
1.2210 +
1.2211 + proc foo x {
1.2212 + set b x=$x
1.2213 + incr x
1.2214 + }
1.2215 + trace add execution foo enterstep enterStep
1.2216 + trace add execution foo leavestep leaveStep
1.2217 + foo 42
1.2218 + rename foo {}
1.2219 + join $info \n
1.2220 +} {enter set b x=42/enterstep
1.2221 +leave set b x=42/0/x=42/leavestep
1.2222 +enter incr x/enterstep
1.2223 +leave incr x/0/43/leavestep}
1.2224 +
1.2225 +test trace-28.7 {exec trace information} {
1.2226 + set info {}
1.2227 + proc foo x { incr x }
1.2228 + proc bar {args} {}
1.2229 + trace add execution foo {enter leave enterstep leavestep} bar
1.2230 + set info [trace info execution foo]
1.2231 + trace remove execution foo {enter leave enterstep leavestep} bar
1.2232 +} {}
1.2233 +
1.2234 +test trace-28.8 {exec trace remove nonsense} {
1.2235 + list [catch {trace remove execution thisdoesntexist \
1.2236 + {enter leave enterstep leavestep} bar} res] $res
1.2237 +} {1 {unknown command "thisdoesntexist"}}
1.2238 +
1.2239 +test trace-28.9 {exec trace info nonsense} {
1.2240 + list [catch {trace info execution thisdoesntexist} res] $res
1.2241 +} {1 {unknown command "thisdoesntexist"}}
1.2242 +
1.2243 +test trace-28.10 {exec trace info nonsense} {
1.2244 + list [catch {trace remove execution} res] $res
1.2245 +} {1 {wrong # args: should be "trace remove execution name opList command"}}
1.2246 +
1.2247 +# Missing test number to keep in sync with the 8.5 branch
1.2248 +# (want to backport those tests?)
1.2249 +
1.2250 +test trace-31.1 {command and execution traces shared struct} {
1.2251 + # Tcl Bug 807243
1.2252 + proc foo {} {}
1.2253 + trace add command foo delete foo
1.2254 + trace add execution foo enter foo
1.2255 + set result [trace info command foo]
1.2256 + trace remove command foo delete foo
1.2257 + trace remove execution foo enter foo
1.2258 + rename foo {}
1.2259 + set result
1.2260 +} [list [list delete foo]]
1.2261 +test trace-31.2 {command and execution traces shared struct} {
1.2262 + # Tcl Bug 807243
1.2263 + proc foo {} {}
1.2264 + trace add command foo delete foo
1.2265 + trace add execution foo enter foo
1.2266 + set result [trace info execution foo]
1.2267 + trace remove command foo delete foo
1.2268 + trace remove execution foo enter foo
1.2269 + rename foo {}
1.2270 + set result
1.2271 +} [list [list enter foo]]
1.2272 +
1.2273 +test trace-32.1 {
1.2274 + TraceCommandInfo refcount decr in TraceCommandProc w/o loss of reference
1.2275 +} {
1.2276 + # Tcl Bug 811483
1.2277 + proc foo {} {}
1.2278 + trace add command foo delete foo
1.2279 + trace add execution foo enter foo
1.2280 + set result [trace info command foo]
1.2281 + rename foo {}
1.2282 + set result
1.2283 +} [list [list delete foo]]
1.2284 +
1.2285 +test trace-33.1 {variable match with remove variable} {
1.2286 + unset -nocomplain x
1.2287 + trace variable x w foo
1.2288 + trace remove variable x write foo
1.2289 + llength [trace info variable x]
1.2290 +} 0
1.2291 +
1.2292 +test trace-34.1 {Bug 1201035} {
1.2293 + set ::x [list]
1.2294 + proc foo {} {lappend ::x foo}
1.2295 + proc bar args {
1.2296 + lappend ::x $args
1.2297 + trace remove execution foo leavestep bar
1.2298 + trace remove execution foo enterstep bar
1.2299 + trace add execution foo leavestep bar
1.2300 + trace add execution foo enterstep bar
1.2301 + lappend ::x done
1.2302 + }
1.2303 + trace add execution foo leavestep bar
1.2304 + trace add execution foo enterstep bar
1.2305 + foo
1.2306 + set ::x
1.2307 +} {{{lappend ::x foo} enterstep} done foo}
1.2308 +
1.2309 +test trace-34.2 {Bug 1224585} {
1.2310 + proc foo {} {}
1.2311 + proc bar args {trace remove execution foo leave soom}
1.2312 + trace add execution foo leave bar
1.2313 + trace add execution foo leave soom
1.2314 + foo
1.2315 +} {}
1.2316 +
1.2317 +test trace-34.3 {Bug 1224585} {
1.2318 + proc foo {} {set x {}}
1.2319 + proc bar args {trace remove execution foo enterstep soom}
1.2320 + trace add execution foo enterstep soom
1.2321 + trace add execution foo enterstep bar
1.2322 + foo
1.2323 +} {}
1.2324 +
1.2325 +# We test here for the half-documented and currently valid interplay between
1.2326 +# delete traces and namespace deletion.
1.2327 +test trace-34.4 {Bug 1047286} {
1.2328 + variable x notrace
1.2329 + proc callback {old - -} {
1.2330 + variable x "$old exists: [namespace which -command $old]"
1.2331 + }
1.2332 + namespace eval ::foo {proc bar {} {}}
1.2333 + trace add command ::foo::bar delete [namespace code callback]
1.2334 + namespace delete ::foo
1.2335 + set x
1.2336 +} {::foo::bar exists: ::foo::bar}
1.2337 +
1.2338 +test trace-34.5 {Bug 1047286} {
1.2339 + variable x notrace
1.2340 + proc callback {old - -} {
1.2341 + variable x "$old exists: [namespace which -command $old]"
1.2342 + }
1.2343 + namespace eval ::foo {proc bar {} {}}
1.2344 + trace add command ::foo::bar delete [namespace code callback]
1.2345 + namespace eval ::foo namespace delete ::foo
1.2346 + set x
1.2347 +} {::foo::bar exists: }
1.2348 +
1.2349 +test trace-34.6 {Bug 1458266} -setup {
1.2350 + proc dummy {} {}
1.2351 + proc stepTraceHandler {cmdString args} {
1.2352 + variable log
1.2353 + append log "[expr {[info level] - 1}]: [lindex [split $cmdString] 0]\n"
1.2354 + dummy
1.2355 + isTracedInside_2
1.2356 + }
1.2357 + proc cmdTraceHandler {cmdString args} {
1.2358 + # silent
1.2359 + }
1.2360 + proc isTracedInside_1 {} {
1.2361 + isTracedInside_2
1.2362 + }
1.2363 + proc isTracedInside_2 {} {
1.2364 + set x 2
1.2365 + }
1.2366 +} -body {
1.2367 + variable log {}
1.2368 + trace add execution isTracedInside_1 enterstep stepTraceHandler
1.2369 + trace add execution isTracedInside_2 enterstep stepTraceHandler
1.2370 + isTracedInside_1
1.2371 + variable first $log
1.2372 + set log {}
1.2373 + trace add execution dummy enter cmdTraceHandler
1.2374 + isTracedInside_1
1.2375 + variable second $log
1.2376 + expr {($first eq $second) ? "ok" : "\n$first\nand\n\n$second\ndiffer"}
1.2377 +} -cleanup {
1.2378 + unset -nocomplain log first second
1.2379 + rename dummy {}
1.2380 + rename stepTraceHandler {}
1.2381 + rename cmdTraceHandler {}
1.2382 + rename isTracedInside_1 {}
1.2383 + rename isTracedInside_2 {}
1.2384 +} -result ok
1.2385 +
1.2386 +# Delete procedures when done, so we don't clash with other tests
1.2387 +# (e.g. foobar will clash with 'unknown' tests).
1.2388 +catch {rename foobar {}}
1.2389 +catch {rename foo {}}
1.2390 +catch {rename bar {}}
1.2391 +
1.2392 +# Unset the varaible when done
1.2393 +catch {unset info}
1.2394 +
1.2395 +# cleanup
1.2396 +::tcltest::cleanupTests
1.2397 +return