1# Commands covered: trace 2# 3# This file contains a collection of tests for one or more of the Tcl 4# built-in commands. Sourcing this file into Tcl runs the tests and 5# generates output for errors. No output means no errors were found. 6# 7# Copyright © 1991-1993 The Regents of the University of California. 8# Copyright © 1994 Sun Microsystems, Inc. 9# Copyright © 1998-1999 Scriptics Corporation. 10# 11# See the file "license.terms" for information on usage and redistribution 12# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 13 14if {"::tcltest" ni [namespace children]} { 15 package require tcltest 2.5 16 namespace import -force ::tcltest::* 17} 18 19::tcltest::loadTestedCommands 20catch [list package require -exact tcl::test [info patchlevel]] 21 22testConstraint testcmdtrace [llength [info commands testcmdtrace]] 23testConstraint testevalobjv [llength [info commands testevalobjv]] 24 25# Used for constraining memory leak tests 26testConstraint memory [llength [info commands memory]] 27 28proc getbytes {} { 29 set lines [split [memory info] "\n"] 30 lindex [lindex $lines 3] 3 31} 32 33proc traceScalar {name1 name2 op} { 34 global info 35 set info [list $name1 $name2 $op [catch {uplevel 1 set $name1} msg] $msg] 36} 37proc traceScalarAppend {name1 name2 op} { 38 global info 39 lappend info $name1 $name2 $op [catch {uplevel 1 set $name1} msg] $msg 40} 41proc traceArray {name1 name2 op} { 42 global info 43 set info [list $name1 $name2 $op [catch {uplevel 1 set [set name1]($name2)} msg] $msg] 44} 45proc traceArray2 {name1 name2 op} { 46 global info 47 set info [list $name1 $name2 $op] 48} 49proc traceProc {name1 name2 op} { 50 global info 51 set info [concat $info [list $name1 $name2 $op]] 52} 53proc traceTag {tag args} { 54 global info 55 set info [concat $info $tag] 56} 57proc traceError {args} { 58 error "trace returned error" 59} 60proc traceCheck {cmd args} { 61 global info 62 set info [list [catch $cmd msg] $msg] 63} 64proc traceCrtElement {value name1 name2 op} { 65 uplevel 1 set ${name1}($name2) $value 66} 67proc traceCommand {oldName newName op} { 68 global info 69 set info [list $oldName $newName $op] 70} 71 72test trace-0.0 {memory corruption in trace (Tcl Bug 484339)} { 73 # You may need Purify or Electric Fence to reliably 74 # see this one fail. 75 unset -nocomplain z 76 trace add variable z array {set z(foo) 1 ;#} 77 set res "names: [array names z]" 78 unset -nocomplain ::z 79 trace variable ::z w {unset ::z; error "memory corruption";#} 80 list [catch {set ::z 1} msg] $msg 81} {1 {can't set "::z": memory corruption}} 82 83# Read-tracing on variables 84 85test trace-1.1 {trace variable reads} { 86 unset -nocomplain x 87 set info {} 88 trace add variable x read traceScalar 89 list [catch {set x} msg] $msg $info 90} {1 {can't read "x": no such variable} {x {} read 1 {can't read "x": no such variable}}} 91test trace-1.2 {trace variable reads} { 92 unset -nocomplain x 93 set x 123 94 set info {} 95 trace add variable x read traceScalar 96 list [catch {set x} msg] $msg $info 97} {0 123 {x {} read 0 123}} 98test trace-1.3 {trace variable reads} { 99 unset -nocomplain x 100 set info {} 101 trace add variable x read traceScalar 102 set x 123 103 set info 104} {} 105test trace-1.4 {trace array element reads} { 106 unset -nocomplain x 107 set info {} 108 trace add variable x(2) read traceArray 109 list [catch {set x(2)} msg] $msg $info 110} {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}}} 111test trace-1.5 {trace array element reads} { 112 unset -nocomplain x 113 set x(2) zzz 114 set info {} 115 trace add variable x(2) read traceArray 116 list [catch {set x(2)} msg] $msg $info 117} {0 zzz {x 2 read 0 zzz}} 118test trace-1.6 {trace array element reads} { 119 unset -nocomplain x 120 set info {} 121 trace add variable x read traceArray2 122 proc p {} { 123 global x 124 set x(2) willi 125 return $x(2) 126 } 127 list [catch {p} msg] $msg $info 128} {0 willi {x 2 read}} 129test trace-1.7 {trace array element reads, create element undefined if nonexistant} { 130 unset -nocomplain x 131 set info {} 132 trace add variable x read q 133 proc q {name1 name2 op} { 134 global info 135 set info [list $name1 $name2 $op] 136 global $name1 137 set ${name1}($name2) wolf 138 } 139 proc p {} { 140 global x 141 set x(X) willi 142 return $x(Y) 143 } 144 list [catch {p} msg] $msg $info 145} {0 wolf {x Y read}} 146test trace-1.8 {trace reads on whole arrays} { 147 unset -nocomplain x 148 set info {} 149 trace add variable x read traceArray 150 list [catch {set x(2)} msg] $msg $info 151} {1 {can't read "x(2)": no such variable} {}} 152test trace-1.9 {trace reads on whole arrays} { 153 unset -nocomplain x 154 set x(2) zzz 155 set info {} 156 trace add variable x read traceArray 157 list [catch {set x(2)} msg] $msg $info 158} {0 zzz {x 2 read 0 zzz}} 159test trace-1.10 {trace variable reads} { 160 unset -nocomplain x 161 set x 444 162 set info {} 163 trace add variable x read traceScalar 164 unset x 165 set info 166} {} 167test trace-1.11 {read traces that modify the array structure} { 168 unset -nocomplain x 169 set x(bar) 0 170 trace variable x r {set x(foo) 1 ;#} 171 trace variable x r {unset -nocomplain x(bar) ;#} 172 array get x 173} {} 174test trace-1.12 {read traces that modify the array structure} { 175 unset -nocomplain x 176 set x(bar) 0 177 trace variable x r {unset -nocomplain x(bar) ;#} 178 trace variable x r {set x(foo) 1 ;#} 179 array get x 180} {} 181test trace-1.13 {read traces that modify the array structure} { 182 unset -nocomplain x 183 set x(bar) 0 184 trace variable x r {set x(foo) 1 ;#} 185 trace variable x r {unset -nocomplain x;#} 186 list [catch {array get x} res] $res 187} {1 {can't read "x(bar)": no such variable}} 188test trace-1.14 {read traces that modify the array structure} { 189 unset -nocomplain x 190 set x(bar) 0 191 trace variable x r {unset -nocomplain x;#} 192 trace variable x r {set x(foo) 1 ;#} 193 list [catch {array get x} res] $res 194} {1 {can't read "x(bar)": no such variable}} 195 196# Basic write-tracing on variables 197 198test trace-2.1 {trace variable writes} { 199 unset -nocomplain x 200 set info {} 201 trace add variable x write traceScalar 202 set x 123 203 set info 204} {x {} write 0 123} 205test trace-2.2 {trace writes to array elements} { 206 unset -nocomplain x 207 set info {} 208 trace add variable x(33) write traceArray 209 set x(33) 444 210 set info 211} {x 33 write 0 444} 212test trace-2.3 {trace writes on whole arrays} { 213 unset -nocomplain x 214 set info {} 215 trace add variable x write traceArray 216 set x(abc) qq 217 set info 218} {x abc write 0 qq} 219test trace-2.4 {trace variable writes} { 220 unset -nocomplain x 221 set x 1234 222 set info {} 223 trace add variable x write traceScalar 224 set x 225 set info 226} {} 227test trace-2.5 {trace variable writes} { 228 unset -nocomplain x 229 set x 1234 230 set info {} 231 trace add variable x write traceScalar 232 unset x 233 set info 234} {} 235test trace-2.6 {trace variable writes on compiled local} { 236 # 237 # Check correct function of whole array traces on compiled local 238 # arrays [Bug 1770591]. The corresponding function for read traces is 239 # already indirectly tested in trace-1.7 240 # 241 unset -nocomplain x 242 set info {} 243 proc p {} { 244 trace add variable x write traceArray 245 set x(X) willy 246 } 247 p 248 set info 249} {x X write 0 willy} 250test trace-2.7 {trace variable writes on errorInfo} -body { 251 # 252 # Check correct behaviour of write traces on errorInfo. 253 # [Bug 1773040] 254 trace add variable ::errorInfo write traceScalar 255 catch {set dne} 256 lrange [set info] 0 2 257} -cleanup { 258 # always remove trace on errorInfo otherwise further tests will fail 259 unset ::errorInfo 260} -result {::errorInfo {} write} 261 262 263 264# append no longer triggers read traces when fetching the old values of 265# variables before doing the append operation. However, lappend _does_ 266# still trigger these read traces. Also lappend triggers only one write 267# trace: after appending all arguments to the list. 268 269test trace-3.1 {trace variable read-modify-writes} { 270 unset -nocomplain x 271 set info {} 272 trace add variable x read traceScalarAppend 273 append x 123 274 append x 456 275 lappend x 789 276 set info 277} {x {} read 0 123456} 278test trace-3.2 {trace variable read-modify-writes} { 279 unset -nocomplain x 280 set info {} 281 trace add variable x {read write} traceScalarAppend 282 append x 123 283 lappend x 456 284 set info 285} {x {} write 0 123 x {} read 0 123 x {} write 0 {123 456}} 286 287# Basic unset-tracing on variables 288 289test trace-4.1 {trace variable unsets} { 290 unset -nocomplain x 291 set info {} 292 trace add variable x unset traceScalar 293 unset -nocomplain x 294 set info 295} {x {} unset 1 {can't read "x": no such variable}} 296test trace-4.2 {variable mustn't exist during unset trace} { 297 unset -nocomplain x 298 set x 1234 299 set info {} 300 trace add variable x unset traceScalar 301 unset x 302 set info 303} {x {} unset 1 {can't read "x": no such variable}} 304test trace-4.3 {unset traces mustn't be called during reads and writes} { 305 unset -nocomplain x 306 set info {} 307 trace add variable x unset traceScalar 308 set x 44 309 set x 310 set info 311} {} 312test trace-4.4 {trace unsets on array elements} { 313 unset -nocomplain x 314 set x(0) 18 315 set info {} 316 trace add variable x(1) unset traceArray 317 unset -nocomplain x(1) 318 set info 319} {x 1 unset 1 {can't read "x(1)": no such element in array}} 320test trace-4.5 {trace unsets on array elements} { 321 unset -nocomplain x 322 set x(1) 18 323 set info {} 324 trace add variable x(1) unset traceArray 325 unset x(1) 326 set info 327} {x 1 unset 1 {can't read "x(1)": no such element in array}} 328test trace-4.6 {trace unsets on array elements} { 329 unset -nocomplain x 330 set x(1) 18 331 set info {} 332 trace add variable x(1) unset traceArray 333 unset x 334 set info 335} {x 1 unset 1 {can't read "x(1)": no such variable}} 336test trace-4.7 {trace unsets on whole arrays} { 337 unset -nocomplain x 338 set x(1) 18 339 set info {} 340 trace add variable x unset traceProc 341 unset -nocomplain x(0) 342 set info 343} {} 344test trace-4.8 {trace unsets on whole arrays} { 345 unset -nocomplain x 346 set x(1) 18 347 set x(2) 144 348 set x(3) 14 349 set info {} 350 trace add variable x unset traceProc 351 unset x(1) 352 set info 353} {x 1 unset} 354test trace-4.9 {trace unsets on whole arrays} { 355 unset -nocomplain x 356 set x(1) 18 357 set x(2) 144 358 set x(3) 14 359 set info {} 360 trace add variable x unset traceProc 361 unset x 362 set info 363} {x {} unset} 364 365# Array tracing on variables 366test trace-5.1 {array traces fire on accesses via [array]} { 367 unset -nocomplain x 368 set x(b) 2 369 trace add variable x array traceArray2 370 set ::info {} 371 array set x {a 1} 372 set ::info 373} {x {} array} 374test trace-5.2 {array traces do not fire on normal accesses} { 375 unset -nocomplain x 376 set x(b) 2 377 trace add variable x array traceArray2 378 set ::info {} 379 set x(a) 1 380 set x(b) $x(a) 381 set ::info 382} {} 383test trace-5.3 {array traces do not outlive variable} { 384 unset -nocomplain x 385 trace add variable x array traceArray2 386 set ::info {} 387 set x(a) 1 388 unset x 389 array set x {a 1} 390 set ::info 391} {} 392test trace-5.4 {array traces properly listed in trace information} { 393 unset -nocomplain x 394 trace add variable x array traceArray2 395 set result [trace info variable x] 396 set result 397} [list [list array traceArray2]] 398test trace-5.5 {array traces properly listed in trace information} { 399 unset -nocomplain x 400 trace variable x a traceArray2 401 set result [trace vinfo x] 402 set result 403} [list [list a traceArray2]] 404test trace-5.6 {array traces don't fire on scalar variables} { 405 unset -nocomplain x 406 set x foo 407 trace add variable x array traceArray2 408 set ::info {} 409 catch {array set x {a 1}} 410 set ::info 411} {} 412test trace-5.7 {array traces fire for undefined variables} { 413 unset -nocomplain x 414 trace add variable x array traceArray2 415 set ::info {} 416 array set x {a 1} 417 set ::info 418} {x {} array} 419test trace-5.8 {array traces fire for undefined variables} { 420 unset -nocomplain x 421 trace add variable x array {set x(foo) 1 ;#} 422 set res "names: [array names x]" 423} {names: foo} 424 425# Trace multiple trace types at once. 426 427test trace-6.1 {multiple ops traced at once} { 428 unset -nocomplain x 429 set info {} 430 trace add variable x {read write unset} traceProc 431 catch {set x} 432 set x 22 433 set x 434 set x 33 435 unset x 436 set info 437} {x {} read x {} write x {} read x {} write x {} unset} 438test trace-6.2 {multiple ops traced on array element} { 439 unset -nocomplain x 440 set info {} 441 trace add variable x(0) {read write unset} traceProc 442 catch {set x(0)} 443 set x(0) 22 444 set x(0) 445 set x(0) 33 446 unset x(0) 447 unset x 448 set info 449} {x 0 read x 0 write x 0 read x 0 write x 0 unset} 450test trace-6.3 {multiple ops traced on whole array} { 451 unset -nocomplain x 452 set info {} 453 trace add variable x {read write unset} traceProc 454 catch {set x(0)} 455 set x(0) 22 456 set x(0) 457 set x(0) 33 458 unset x(0) 459 unset x 460 set info 461} {x 0 write x 0 read x 0 write x 0 unset x {} unset} 462 463# Check order of invocation of traces 464 465test trace-7.1 {order of invocation of traces} { 466 unset -nocomplain x 467 set info {} 468 trace add variable x read "traceTag 1" 469 trace add variable x read "traceTag 2" 470 trace add variable x read "traceTag 3" 471 catch {set x} 472 set x 22 473 set x 474 set info 475} {3 2 1 3 2 1} 476test trace-7.2 {order of invocation of traces} { 477 unset -nocomplain x 478 set x(0) 44 479 set info {} 480 trace add variable x(0) read "traceTag 1" 481 trace add variable x(0) read "traceTag 2" 482 trace add variable x(0) read "traceTag 3" 483 set x(0) 484 set info 485} {3 2 1} 486test trace-7.3 {order of invocation of traces} { 487 unset -nocomplain x 488 set x(0) 44 489 set info {} 490 trace add variable x(0) read "traceTag 1" 491 trace add variable x read "traceTag A1" 492 trace add variable x(0) read "traceTag 2" 493 trace add variable x read "traceTag A2" 494 trace add variable x(0) read "traceTag 3" 495 trace add variable x read "traceTag A3" 496 set x(0) 497 set info 498} {A3 A2 A1 3 2 1} 499 500# Check effects of errors in trace procedures 501 502test trace-8.1 {error returns from traces} { 503 unset -nocomplain x 504 set x 123 505 set info {} 506 trace add variable x read "traceTag 1" 507 trace add variable x read traceError 508 list [catch {set x} msg] $msg $info 509} {1 {can't read "x": trace returned error} {}} 510test trace-8.2 {error returns from traces} { 511 unset -nocomplain x 512 set x 123 513 set info {} 514 trace add variable x write "traceTag 1" 515 trace add variable x write traceError 516 list [catch {set x 44} msg] $msg $info 517} {1 {can't set "x": trace returned error} {}} 518test trace-8.3 {error returns from traces} { 519 unset -nocomplain x 520 set x 123 521 set info {} 522 trace add variable x write traceError 523 list [catch {append x 44} msg] $msg $info 524} {1 {can't set "x": trace returned error} {}} 525test trace-8.4 {error returns from traces} { 526 unset -nocomplain x 527 set x 123 528 set info {} 529 trace add variable x unset "traceTag 1" 530 trace add variable x unset traceError 531 list [catch {unset x} msg] $msg $info 532} {0 {} 1} 533test trace-8.5 {error returns from traces} { 534 unset -nocomplain x 535 set x(0) 123 536 set info {} 537 trace add variable x(0) read "traceTag 1" 538 trace add variable x read "traceTag 2" 539 trace add variable x read traceError 540 trace add variable x read "traceTag 3" 541 list [catch {set x(0)} msg] $msg $info 542} {1 {can't read "x(0)": trace returned error} 3} 543test trace-8.6 {error returns from traces} { 544 unset -nocomplain x 545 set x 123 546 trace add variable x unset traceError 547 list [catch {unset x} msg] $msg 548} {0 {}} 549test trace-8.7 {error returns from traces} { 550 # This test just makes sure that the memory for the error message 551 # gets deallocated correctly when the trace is invoked again or 552 # when the trace is deleted. 553 unset -nocomplain x 554 set x 123 555 trace add variable x read traceError 556 catch {set x} 557 catch {set x} 558 trace remove variable x read traceError 559} {} 560test trace-8.8 {error returns from traces} { 561 # Yet more elaborate memory corruption testing that checks nothing 562 # bad happens when the trace deletes itself and installs something 563 # new. Alas, there is no neat way to guarantee that this test will 564 # fail if there is a problem, but that's life and with the new code 565 # it should *never* fail. 566 # 567 # Adapted from Bug #219393 reported by Don Porter. 568 catch {rename ::foo {}} 569 proc foo {old args} { 570 trace remove variable ::x write [list foo $old] 571 trace add variable ::x write [list foo $::x] 572 error "foo" 573 } 574 unset -nocomplain ::x ::y 575 set x junk 576 trace add variable ::x write [list foo $x] 577 for {set y 0} {$y<100} {incr y} { 578 catch {set x junk} 579 } 580 unset x 581} {} 582 583# Check to see that variables are expunged before trace 584# procedures are invoked, so trace procedure can even manipulate 585# a new copy of the variables. 586 587test trace-9.1 {be sure variable is unset before trace is called} { 588 unset -nocomplain x 589 set x 33 590 set info {} 591 trace add variable x unset {traceCheck {uplevel 1 set x}} 592 unset x 593 set info 594} {1 {can't read "x": no such variable}} 595test trace-9.2 {be sure variable is unset before trace is called} { 596 unset -nocomplain x 597 set x 33 598 set info {} 599 trace add variable x unset {traceCheck {uplevel 1 set x 22}} 600 unset x 601 concat $info [list [catch {set x} msg] $msg] 602} {0 22 0 22} 603test trace-9.3 {be sure traces are cleared before unset trace called} { 604 unset -nocomplain x 605 set x 33 606 set info {} 607 trace add variable x unset {traceCheck {uplevel 1 trace info variable x}} 608 unset x 609 set info 610} {0 {}} 611test trace-9.4 {set new trace during unset trace} { 612 unset -nocomplain x 613 set x 33 614 set info {} 615 trace add variable x unset {traceCheck {global x; trace add variable x unset traceProc}} 616 unset x 617 concat $info [trace info variable x] 618} {0 {} {unset traceProc}} 619 620test trace-10.1 {make sure array elements are unset before traces are called} { 621 unset -nocomplain x 622 set x(0) 33 623 set info {} 624 trace add variable x(0) unset {traceCheck {uplevel 1 set x(0)}} 625 unset x(0) 626 set info 627} {1 {can't read "x(0)": no such element in array}} 628test trace-10.2 {make sure array elements are unset before traces are called} { 629 unset -nocomplain x 630 set x(0) 33 631 set info {} 632 trace add variable x(0) unset {traceCheck {uplevel 1 set x(0) zzz}} 633 unset x(0) 634 concat $info [list [catch {set x(0)} msg] $msg] 635} {0 zzz 0 zzz} 636test trace-10.3 {array elements are unset before traces are called} { 637 unset -nocomplain x 638 set x(0) 33 639 set info {} 640 trace add variable x(0) unset {traceCheck {global x; trace info variable x(0)}} 641 unset x(0) 642 set info 643} {0 {}} 644test trace-10.4 {set new array element trace during unset trace} { 645 unset -nocomplain x 646 set x(0) 33 647 set info {} 648 trace add variable x(0) unset {traceCheck {uplevel 1 {trace add variable x(0) read {}}}} 649 unset -nocomplain x(0) 650 concat $info [trace info variable x(0)] 651} {0 {} {read {}}} 652 653test trace-11.1 {make sure arrays are unset before traces are called} { 654 unset -nocomplain x 655 set x(0) 33 656 set info {} 657 trace add variable x unset {traceCheck {uplevel 1 set x(0)}} 658 unset x 659 set info 660} {1 {can't read "x(0)": no such variable}} 661test trace-11.2 {make sure arrays are unset before traces are called} { 662 unset -nocomplain x 663 set x(y) 33 664 set info {} 665 trace add variable x unset {traceCheck {uplevel 1 set x(y) 22}} 666 unset x 667 concat $info [list [catch {set x(y)} msg] $msg] 668} {0 22 0 22} 669test trace-11.3 {make sure arrays are unset before traces are called} { 670 unset -nocomplain x 671 set x(y) 33 672 set info {} 673 trace add variable x unset {traceCheck {uplevel 1 array exists x}} 674 unset x 675 set info 676} {0 0} 677test trace-11.4 {make sure arrays are unset before traces are called} { 678 unset -nocomplain x 679 set x(y) 33 680 set info {} 681 set cmd {traceCheck {uplevel 1 {trace info variable x}}} 682 trace add variable x unset $cmd 683 unset x 684 set info 685} {0 {}} 686test trace-11.5 {set new array trace during unset trace} { 687 unset -nocomplain x 688 set x(y) 33 689 set info {} 690 trace add variable x unset {traceCheck {global x; trace add variable x read {}}} 691 unset x 692 concat $info [trace info variable x] 693} {0 {} {read {}}} 694test trace-11.6 {create scalar during array unset trace} { 695 unset -nocomplain x 696 set x(y) 33 697 set info {} 698 trace add variable x unset {traceCheck {global x; set x 44}} 699 unset x 700 concat $info [list [catch {set x} msg] $msg] 701} {0 44 0 44} 702 703# Check special conditions (e.g. errors) in Tcl_TraceVar2. 704 705test trace-12.1 {creating array when setting variable traces} { 706 unset -nocomplain x 707 set info {} 708 trace add variable x(0) write traceProc 709 list [catch {set x 22} msg] $msg 710} {1 {can't set "x": variable is array}} 711test trace-12.2 {creating array when setting variable traces} { 712 unset -nocomplain x 713 set info {} 714 trace add variable x(0) write traceProc 715 list [catch {set x(0)} msg] $msg 716} {1 {can't read "x(0)": no such element in array}} 717test trace-12.3 {creating array when setting variable traces} { 718 unset -nocomplain x 719 set info {} 720 trace add variable x(0) write traceProc 721 set x(0) 22 722 set info 723} {x 0 write} 724test trace-12.4 {creating variable when setting variable traces} { 725 unset -nocomplain x 726 set info {} 727 trace add variable x write traceProc 728 list [catch {set x} msg] $msg 729} {1 {can't read "x": no such variable}} 730test trace-12.5 {creating variable when setting variable traces} { 731 unset -nocomplain x 732 set info {} 733 trace add variable x write traceProc 734 set x 22 735 set info 736} {x {} write} 737test trace-12.6 {creating variable when setting variable traces} { 738 unset -nocomplain x 739 set info {} 740 trace add variable x write traceProc 741 set x(0) 22 742 set info 743} {x 0 write} 744test trace-12.7 {create array element during read trace} { 745 unset -nocomplain x 746 set x(2) zzz 747 trace add variable x read {traceCrtElement xyzzy} 748 list [catch {set x(3)} msg] $msg 749} {0 xyzzy} 750test trace-12.8 {errors when setting variable traces} { 751 unset -nocomplain x 752 set x 44 753 list [catch {trace add variable x(0) write traceProc} msg] $msg 754} {1 {can't trace "x(0)": variable isn't array}} 755 756# Check trace deletion 757 758test trace-13.1 {delete one trace from another} { 759 proc delTraces {args} { 760 global x 761 trace remove variable x read {traceTag 2} 762 trace remove variable x read {traceTag 3} 763 trace remove variable x read {traceTag 4} 764 } 765 unset -nocomplain x 766 set x 44 767 set info {} 768 trace add variable x read {traceTag 1} 769 trace add variable x read {traceTag 2} 770 trace add variable x read {traceTag 3} 771 trace add variable x read {traceTag 4} 772 trace add variable x read delTraces 773 trace add variable x read {traceTag 5} 774 set x 775 set info 776} {5 1} 777 778test trace-13.2 {leak when unsetting traced variable} \ 779 -constraints memory -body { 780 set end [getbytes] 781 proc f args {} 782 for {set i 0} {$i < 5} {incr i} { 783 trace add variable bepa write f 784 set bepa a 785 unset bepa 786 set tmp $end 787 set end [getbytes] 788 } 789 expr {$end - $tmp} 790 } -cleanup { 791 unset -nocomplain end i tmp 792 } -result 0 793test trace-13.3 {leak when removing traces} \ 794 -constraints memory -body { 795 set end [getbytes] 796 proc f args {} 797 for {set i 0} {$i < 5} {incr i} { 798 trace add variable bepa write f 799 set bepa a 800 trace remove variable bepa write f 801 set tmp $end 802 set end [getbytes] 803 } 804 expr {$end - $tmp} 805 } -cleanup { 806 unset -nocomplain end i tmp 807 } -result 0 808test trace-13.4 {leaks in error returns from traces} \ 809 -constraints memory -body { 810 set end [getbytes] 811 for {set i 0} {$i < 5} {incr i} { 812 set apa {a 1 b 2} 813 set bepa [lrange $apa 0 end] 814 trace add variable bepa write {error hej} 815 catch {set bepa a} 816 unset bepa 817 set tmp $end 818 set end [getbytes] 819 } 820 expr {$end - $tmp} 821 } -cleanup { 822 unset -nocomplain end i tmp 823 } -result 0 824 825# Check operation and syntax of "trace" command. 826 827# Syntax for adding/removing variable and command traces is basically the 828# same: 829# trace add variable name opList command 830# trace remove variable name opList command 831# 832# The following loops just get all the common "wrong # args" tests done. 833 834set i 0 835set start "wrong # args:" 836foreach type {variable command} { 837 foreach op {add remove} { 838 test trace-14.0.[incr i] "trace command, wrong # args errors" { 839 list [catch {trace $op $type} msg] $msg 840 } [list 1 "$start should be \"trace $op $type name opList command\""] 841 test trace-14.0.[incr i] "trace command wrong # args errors" { 842 list [catch {trace $op $type foo} msg] $msg 843 } [list 1 "$start should be \"trace $op $type name opList command\""] 844 test trace-14.0.[incr i] "trace command, wrong # args errors" { 845 list [catch {trace $op $type foo bar} msg] $msg 846 } [list 1 "$start should be \"trace $op $type name opList command\""] 847 test trace-14.0.[incr i] "trace command, wrong # args errors" { 848 list [catch {trace $op $type foo bar baz boo} msg] $msg 849 } [list 1 "$start should be \"trace $op $type name opList command\""] 850 } 851 test trace-14.0.[incr i] "trace command, wrong # args errors" { 852 list [catch {trace info $type foo bar} msg] $msg 853 } [list 1 "$start should be \"trace info $type name\""] 854 test trace-14.0.[incr i] "trace command, wrong # args errors" { 855 list [catch {trace info $type} msg] $msg 856 } [list 1 "$start should be \"trace info $type name\""] 857} 858 859test trace-14.1 "trace command, wrong # args errors" { 860 list [catch {trace} msg] $msg 861} [list 1 "wrong # args: should be \"trace option ?arg ...?\""] 862test trace-14.2 "trace command, wrong # args errors" { 863 list [catch {trace add} msg] $msg 864} [list 1 "wrong # args: should be \"trace add type ?arg ...?\""] 865test trace-14.3 "trace command, wrong # args errors" { 866 list [catch {trace remove} msg] $msg 867} [list 1 "wrong # args: should be \"trace remove type ?arg ...?\""] 868test trace-14.4 "trace command, wrong # args errors" { 869 list [catch {trace info} msg] $msg 870} [list 1 "wrong # args: should be \"trace info type name\""] 871 872test trace-14.5 {trace command, invalid option} { 873 list [catch {trace gorp} msg] $msg 874} [list 1 "bad option \"gorp\": must be add, info, remove, variable, vdelete, or vinfo"] 875 876# Again, [trace ... command] and [trace ... variable] share syntax and 877# error message styles for their opList options; these loops test those 878# error messages. 879 880set i 0 881set errs [list "array, read, unset, or write" "delete or rename" "enter, leave, enterstep, or leavestep"] 882set abbvs [list {a r u w} {d r} {}] 883proc x {} {} 884foreach type {variable command execution} err $errs abbvlist $abbvs { 885 foreach op {add remove} { 886 test trace-14.6.[incr i] "trace $op $type errors" { 887 list [catch {trace $op $type x {y z w} a} msg] $msg 888 } [list 1 "bad operation \"y\": must be $err"] 889 foreach abbv $abbvlist { 890 test trace-14.6.[incr i] "trace $op $type rejects abbreviations" { 891 list [catch {trace $op $type x $abbv a} msg] $msg 892 } [list 1 "bad operation \"$abbv\": must be $err"] 893 } 894 test trace-14.6.[incr i] "trace $op $type rejects null opList" { 895 list [catch {trace $op $type x {} a} msg] $msg 896 } [list 1 "bad operation list \"\": must be one or more of $err"] 897 } 898} 899rename x {} 900 901test trace-14.7 {trace command, "trace variable" errors} { 902 list [catch {trace variable} msg] $msg 903} [list 1 "wrong # args: should be \"trace variable name ops command\""] 904test trace-14.8 {trace command, "trace variable" errors} { 905 list [catch {trace variable x} msg] $msg 906} [list 1 "wrong # args: should be \"trace variable name ops command\""] 907test trace-14.9 {trace command, "trace variable" errors} { 908 list [catch {trace variable x y} msg] $msg 909} [list 1 "wrong # args: should be \"trace variable name ops command\""] 910test trace-14.10 {trace command, "trace variable" errors} { 911 list [catch {trace variable x y z w} msg] $msg 912} [list 1 "wrong # args: should be \"trace variable name ops command\""] 913test trace-14.11 {trace command, "trace variable" errors} { 914 list [catch {trace variable x y z} msg] $msg 915} [list 1 "bad operations \"y\": should be one or more of rwua"] 916 917 918test trace-14.12 {trace command ("remove variable" option)} { 919 unset -nocomplain x 920 set info {} 921 trace add variable x write traceProc 922 trace remove variable x write traceProc 923} {} 924test trace-14.13 {trace command ("remove variable" option)} { 925 unset -nocomplain x 926 set info {} 927 trace add variable x write traceProc 928 trace remove variable x write traceProc 929 set x 12345 930 set info 931} {} 932test trace-14.14 {trace command ("remove variable" option)} { 933 unset -nocomplain x 934 set info {} 935 trace add variable x write {traceTag 1} 936 trace add variable x write traceProc 937 trace add variable x write {traceTag 2} 938 set x yy 939 trace remove variable x write traceProc 940 set x 12345 941 trace remove variable x write {traceTag 1} 942 set x foo 943 trace remove variable x write {traceTag 2} 944 set x gorp 945 set info 946} {2 x {} write 1 2 1 2} 947test trace-14.15 {trace command ("remove variable" option)} { 948 unset -nocomplain x 949 set info {} 950 trace add variable x write {traceTag 1} 951 trace remove variable x write non_existent 952 set x 12345 953 set info 954} {1} 955test trace-14.16 {trace command ("info variable" option)} { 956 unset -nocomplain x 957 trace add variable x write {traceTag 1} 958 trace add variable x write traceProc 959 trace add variable x write {traceTag 2} 960 trace info variable x 961} {{write {traceTag 2}} {write traceProc} {write {traceTag 1}}} 962test trace-14.17 {trace command ("info variable" option)} { 963 unset -nocomplain x 964 trace info variable x 965} {} 966test trace-14.18 {trace command ("info variable" option)} { 967 unset -nocomplain x 968 trace info variable x(0) 969} {} 970test trace-14.19 {trace command ("info variable" option)} { 971 unset -nocomplain x 972 set x 44 973 trace info variable x(0) 974} {} 975test trace-14.20 {trace command ("info variable" option)} { 976 unset -nocomplain x 977 set x 44 978 trace add variable x write {traceTag 1} 979 proc check {} {global x; trace info variable x} 980 check 981} {{write {traceTag 1}}} 982 983# Check fancy trace commands (long ones, weird arguments, etc.) 984 985test trace-15.1 {long trace command} { 986 unset -nocomplain x 987 set info {} 988 trace add variable x write {traceTag {This is a very very long argument. It's \ 989 designed to test out the facilities of TraceVarProc for dealing \ 990 with such long arguments by malloc-ing space. One possibility \ 991 is that space doesn't get freed properly. If this happens, then \ 992 invoking this test over and over again will eventually leak memory.}} 993 set x 44 994 set info 995} {This is a very very long argument. It's \ 996 designed to test out the facilities of TraceVarProc for dealing \ 997 with such long arguments by malloc-ing space. One possibility \ 998 is that space doesn't get freed properly. If this happens, then \ 999 invoking this test over and over again will eventually leak memory.} 1000test trace-15.2 {long trace command result to ignore} { 1001 proc longResult {args} {return "quite a bit of text, designed to 1002 generate a core leak if this command file is invoked over and over again 1003 and memory isn't being recycled correctly"} 1004 unset -nocomplain x 1005 trace add variable x write longResult 1006 set x 44 1007 set x 5 1008 set x abcde 1009} abcde 1010test trace-15.3 {special list-handling in trace commands} { 1011 unset -nocomplain "x y z" 1012 set "x y z(a\n\{)" 44 1013 set info {} 1014 trace add variable "x y z(a\n\{)" write traceProc 1015 set "x y z(a\n\{)" 33 1016 set info 1017} "{x y z} a\\n\\\{ write" 1018 1019# Check for proper handling of unsets during traces. 1020 1021proc traceUnset {unsetName args} { 1022 global info 1023 upvar 1 $unsetName x 1024 lappend info [catch {unset x} msg] $msg [catch {set x} msg] $msg 1025} 1026proc traceReset {unsetName resetName args} { 1027 global info 1028 upvar 1 $unsetName x $resetName y 1029 lappend info [catch {unset x} msg] $msg [catch {set y xyzzy} msg] $msg 1030} 1031proc traceReset2 {unsetName resetName args} { 1032 global info 1033 lappend info [catch {uplevel 1 unset $unsetName} msg] $msg \ 1034 [catch {uplevel 1 set $resetName xyzzy} msg] $msg 1035} 1036proc traceAppend {string name1 name2 op} { 1037 global info 1038 lappend info $string 1039} 1040 1041test trace-16.1 {unsets during read traces} { 1042 unset -nocomplain y 1043 set y 1234 1044 set info {} 1045 trace add variable y read {traceUnset y} 1046 trace add variable y unset {traceAppend unset} 1047 lappend info [catch {set y} msg] $msg 1048} {unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}} 1049test trace-16.2 {unsets during read traces} { 1050 unset -nocomplain y 1051 set y(0) 1234 1052 set info {} 1053 trace add variable y(0) read {traceUnset y(0)} 1054 lappend info [catch {set y(0)} msg] $msg 1055} {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such element in array}} 1056test trace-16.3 {unsets during read traces} { 1057 unset -nocomplain y 1058 set y(0) 1234 1059 set info {} 1060 trace add variable y(0) read {traceUnset y} 1061 lappend info [catch {set y(0)} msg] $msg 1062} {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}} 1063test trace-16.4 {unsets during read traces} { 1064 unset -nocomplain y 1065 set y 1234 1066 set info {} 1067 trace add variable y read {traceReset y y} 1068 lappend info [catch {set y} msg] $msg 1069} {0 {} 0 xyzzy 0 xyzzy} 1070test trace-16.5 {unsets during read traces} { 1071 unset -nocomplain y 1072 set y(0) 1234 1073 set info {} 1074 trace add variable y(0) read {traceReset y(0) y(0)} 1075 lappend info [catch {set y(0)} msg] $msg 1076} {0 {} 0 xyzzy 0 xyzzy} 1077test trace-16.6 {unsets during read traces} { 1078 unset -nocomplain y 1079 set y(0) 1234 1080 set info {} 1081 trace add variable y(0) read {traceReset y y(0)} 1082 lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg 1083} {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}} 1084test trace-16.7 {unsets during read traces} { 1085 unset -nocomplain y 1086 set y(0) 1234 1087 set info {} 1088 trace add variable y(0) read {traceReset2 y y(0)} 1089 lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg 1090} {0 {} 0 xyzzy 1 {can't read "y(0)": no such element in array} 0 xyzzy} 1091test trace-16.8 {unsets during write traces} { 1092 unset -nocomplain y 1093 set y 1234 1094 set info {} 1095 trace add variable y write {traceUnset y} 1096 trace add variable y unset {traceAppend unset} 1097 lappend info [catch {set y xxx} msg] $msg 1098} {unset 0 {} 1 {can't read "x": no such variable} 0 {}} 1099test trace-16.9 {unsets during write traces} { 1100 unset -nocomplain y 1101 set y(0) 1234 1102 set info {} 1103 trace add variable y(0) write {traceUnset y(0)} 1104 lappend info [catch {set y(0) xxx} msg] $msg 1105} {0 {} 1 {can't read "x": no such variable} 0 {}} 1106test trace-16.10 {unsets during write traces} { 1107 unset -nocomplain y 1108 set y(0) 1234 1109 set info {} 1110 trace add variable y(0) write {traceUnset y} 1111 lappend info [catch {set y(0) xxx} msg] $msg 1112} {0 {} 1 {can't read "x": no such variable} 0 {}} 1113test trace-16.11 {unsets during write traces} { 1114 unset -nocomplain y 1115 set y 1234 1116 set info {} 1117 trace add variable y write {traceReset y y} 1118 lappend info [catch {set y xxx} msg] $msg 1119} {0 {} 0 xyzzy 0 xyzzy} 1120test trace-16.12 {unsets during write traces} { 1121 unset -nocomplain y 1122 set y(0) 1234 1123 set info {} 1124 trace add variable y(0) write {traceReset y(0) y(0)} 1125 lappend info [catch {set y(0) xxx} msg] $msg 1126} {0 {} 0 xyzzy 0 xyzzy} 1127test trace-16.13 {unsets during write traces} { 1128 unset -nocomplain y 1129 set y(0) 1234 1130 set info {} 1131 trace add variable y(0) write {traceReset y y(0)} 1132 lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg 1133} {0 {} 1 {can't set "y": upvar refers to element in deleted array} 0 {} 1 {can't read "y(0)": no such variable}} 1134test trace-16.14 {unsets during write traces} { 1135 unset -nocomplain y 1136 set y(0) 1234 1137 set info {} 1138 trace add variable y(0) write {traceReset2 y y(0)} 1139 lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg 1140} {0 {} 0 xyzzy 0 {} 0 xyzzy} 1141test trace-16.15 {unsets during unset traces} { 1142 unset -nocomplain y 1143 set y 1234 1144 set info {} 1145 trace add variable y unset {traceUnset y} 1146 lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg 1147} {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}} 1148test trace-16.16 {unsets during unset traces} { 1149 unset -nocomplain y 1150 set y(0) 1234 1151 set info {} 1152 trace add variable y(0) unset {traceUnset y(0)} 1153 lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg 1154} {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}} 1155test trace-16.17 {unsets during unset traces} { 1156 unset -nocomplain y 1157 set y(0) 1234 1158 set info {} 1159 trace add variable y(0) unset {traceUnset y} 1160 lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg 1161} {0 {} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such variable}} 1162test trace-16.18 {unsets during unset traces} { 1163 unset -nocomplain y 1164 set y 1234 1165 set info {} 1166 trace add variable y unset {traceReset2 y y} 1167 lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg 1168} {1 {can't unset "y": no such variable} 0 xyzzy 0 {} 0 xyzzy} 1169test trace-16.19 {unsets during unset traces} { 1170 unset -nocomplain y 1171 set y(0) 1234 1172 set info {} 1173 trace add variable y(0) unset {traceReset2 y(0) y(0)} 1174 lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg 1175} {1 {can't unset "y(0)": no such element in array} 0 xyzzy 0 {} 0 xyzzy} 1176test trace-16.20 {unsets during unset traces} { 1177 unset -nocomplain y 1178 set y(0) 1234 1179 set info {} 1180 trace add variable y(0) unset {traceReset2 y y(0)} 1181 lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg 1182} {0 {} 0 xyzzy 0 {} 0 xyzzy} 1183test trace-16.21 {unsets cancelling traces} { 1184 unset -nocomplain y 1185 set y 1234 1186 set info {} 1187 trace add variable y read {traceAppend first} 1188 trace add variable y read {traceUnset y} 1189 trace add variable y read {traceAppend third} 1190 trace add variable y unset {traceAppend unset} 1191 lappend info [catch {set y} msg] $msg 1192} {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}} 1193test trace-16.22 {unsets cancelling traces} { 1194 unset -nocomplain y 1195 set y(0) 1234 1196 set info {} 1197 trace add variable y(0) read {traceAppend first} 1198 trace add variable y(0) read {traceUnset y} 1199 trace add variable y(0) read {traceAppend third} 1200 trace add variable y(0) unset {traceAppend unset} 1201 lappend info [catch {set y(0)} msg] $msg 1202} {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}} 1203 1204# Check various non-interference between traces and other things. 1205 1206test trace-17.1 {trace doesn't prevent unset errors} { 1207 unset -nocomplain x 1208 set info {} 1209 trace add variable x unset {traceProc} 1210 list [catch {unset x} msg] $msg $info 1211} {1 {can't unset "x": no such variable} {x {} unset}} 1212test trace-17.2 {traced variables must survive procedure exits} { 1213 unset -nocomplain x 1214 proc p1 {} {global x; trace add variable x write traceProc} 1215 p1 1216 trace info variable x 1217} {{write traceProc}} 1218test trace-17.3 {traced variables must survive procedure exits} { 1219 unset -nocomplain x 1220 set info {} 1221 proc p1 {} {global x; trace add variable x write traceProc} 1222 p1 1223 set x 44 1224 set info 1225} {x {} write} 1226 1227# Be sure that procedure frames are released before unset traces 1228# are invoked. 1229 1230test trace-18.1 {unset traces on procedure returns} { 1231 proc p1 {x y} {set a 44; p2 14} 1232 proc p2 {z} {trace add variable z unset {traceCheck {lsort [uplevel 1 {info vars}]}}} 1233 set info {} 1234 p1 foo bar 1235 set info 1236} {0 {a x y}} 1237test trace-18.2 {namespace delete / trace vdelete combo} { 1238 namespace eval ::foo { 1239 variable x 123 1240 } 1241 proc p1 args { 1242 trace vdelete ::foo::x u p1 1243 } 1244 trace variable ::foo::x u p1 1245 namespace delete ::foo 1246 info exists ::foo::x 1247} 0 1248test trace-18.3 {namespace delete / trace vdelete combo, Bug \#1337229} { 1249 namespace eval ::ns {} 1250 trace add variable ::ns::var unset {unset ::ns::var ;#} 1251 namespace delete ::ns 1252} {} 1253test trace-18.4 {namespace delete / trace vdelete combo, Bug \#1338280} { 1254 namespace eval ::ref {} 1255 set ::ref::var1 AAA 1256 trace add variable ::ref::var1 unset doTrace 1257 set ::ref::var2 BBB 1258 trace add variable ::ref::var2 {unset} doTrace 1259 proc doTrace {vtraced vidx op} { 1260 global info 1261 append info [catch {set ::$vtraced}][llength [info vars ::ref::*]] 1262 } 1263 set info {} 1264 namespace delete ::ref 1265 rename doTrace {} 1266 set info 1267} 1110 1268 1269# Delete arrays when done, so they can be re-used as scalars 1270# elsewhere. 1271 1272unset -nocomplain x y 1273 1274test trace-19.0.1 {trace add command (command existence)} { 1275 # Just in case! 1276 catch {rename nosuchname ""} 1277 list [catch {trace add command nosuchname rename traceCommand} msg] $msg 1278} {1 {unknown command "nosuchname"}} 1279test trace-19.0.2 {trace add command (command existence in ns)} { 1280 list [catch {trace add command nosuchns::nosuchname rename traceCommand} msg] $msg 1281} {1 {unknown command "nosuchns::nosuchname"}} 1282 1283 1284test trace-19.1 {trace add command (rename option)} { 1285 proc foo {} {} 1286 catch {rename bar {}} 1287 trace add command foo rename traceCommand 1288 rename foo bar 1289 set info 1290} {::foo ::bar rename} 1291test trace-19.2 {traces stick with renamed commands} { 1292 proc foo {} {} 1293 catch {rename bar {}} 1294 trace add command foo rename traceCommand 1295 rename foo bar 1296 rename bar foo 1297 set info 1298} {::bar ::foo rename} 1299test trace-19.2.1 {trace add command rename trace exists} { 1300 proc foo {} {} 1301 trace add command foo rename traceCommand 1302 trace info command foo 1303} {{rename traceCommand}} 1304test trace-19.3 {command rename traces don't fire on command deletion} { 1305 proc foo {} {} 1306 set info {} 1307 trace add command foo rename traceCommand 1308 rename foo {} 1309 set info 1310} {} 1311test trace-19.4 {trace add command rename doesn't trace recreated commands} { 1312 proc foo {} {} 1313 catch {rename bar {}} 1314 set info {} 1315 trace add command foo rename traceCommand 1316 proc foo {} {} 1317 rename foo bar 1318 set info 1319} {} 1320test trace-19.5 {trace add command deleted removes traces} { 1321 proc foo {} {} 1322 trace add command foo rename traceCommand 1323 proc foo {} {} 1324 trace info command foo 1325} {} 1326 1327test trace-19.6 {trace add command rename in namespace} -setup { 1328 namespace eval tc {} 1329 proc tc::tcfoo {} {} 1330} -body { 1331 trace add command tc::tcfoo rename traceCommand 1332 rename tc::tcfoo tc::tcbar 1333 set info 1334} -cleanup { 1335 namespace delete tc 1336} -result {::tc::tcfoo ::tc::tcbar rename} 1337test trace-19.7 {trace add command rename in namespace back again} -setup { 1338 namespace eval tc {} 1339 proc tc::tcfoo {} {} 1340} -body { 1341 trace add command tc::tcfoo rename traceCommand 1342 rename tc::tcfoo tc::tcbar 1343 rename tc::tcbar tc::tcfoo 1344 set info 1345} -cleanup { 1346 namespace delete tc 1347} -result {::tc::tcbar ::tc::tcfoo rename} 1348test trace-19.8 {trace add command rename in namespace to out of namespace} -setup { 1349 namespace eval tc {} 1350 proc tc::tcfoo {} {} 1351} -body { 1352 trace add command tc::tcfoo rename traceCommand 1353 rename tc::tcfoo tcbar 1354 set info 1355} -cleanup { 1356 catch {rename tcbar {}} 1357 namespace delete tc 1358} -result {::tc::tcfoo ::tcbar rename} 1359test trace-19.9 {trace add command rename back into namespace} -setup { 1360 namespace eval tc {} 1361 proc tc::tcfoo {} {} 1362} -body { 1363 trace add command tc::tcfoo rename traceCommand 1364 rename tc::tcfoo tcbar 1365 rename tcbar tc::tcfoo 1366 set info 1367} -cleanup { 1368 namespace delete tc 1369} -result {::tcbar ::tc::tcfoo rename} 1370test trace-19.10 {trace add command failed rename doesn't trigger trace} { 1371 set info {} 1372 proc foo {} {} 1373 proc bar {} {} 1374 trace add command foo {rename delete} traceCommand 1375 catch {rename foo bar} 1376 set info 1377} {} 1378catch {rename foo {}} 1379catch {rename bar {}} 1380 1381test trace-19.11 {trace add command qualifies when renamed in namespace} -setup { 1382 namespace eval tc {} 1383 proc tc::tcfoo {} {} 1384} -body { 1385 set info {} 1386 trace add command tc::tcfoo {rename delete} traceCommand 1387 namespace eval tc {rename tcfoo tcbar} 1388 set info 1389} -cleanup { 1390 namespace delete tc 1391} -result {::tc::tcfoo ::tc::tcbar rename} 1392 1393# Make sure it exists again 1394proc foo {} {} 1395 1396test trace-20.1 {trace add command (delete option)} { 1397 trace add command foo delete traceCommand 1398 rename foo "" 1399 set info 1400} {::foo {} delete} 1401test trace-20.2 {trace add command delete doesn't trace recreated commands} { 1402 set info {} 1403 proc foo {} {} 1404 rename foo "" 1405 set info 1406} {} 1407test trace-20.2.1 {trace add command delete trace info} { 1408 proc foo {} {} 1409 trace add command foo delete traceCommand 1410 trace info command foo 1411} {{delete traceCommand}} 1412test trace-20.3 {trace add command implicit delete} { 1413 proc foo {} {} 1414 trace add command foo delete traceCommand 1415 proc foo {} {} 1416 set info 1417} {::foo {} delete} 1418test trace-20.3.1 {trace add command delete trace info} { 1419 proc foo {} {} 1420 trace info command foo 1421} {} 1422test trace-20.4 {trace add command rename followed by delete} { 1423 set infotemp {} 1424 proc foo {} {} 1425 trace add command foo {rename delete} traceCommand 1426 rename foo bar 1427 lappend infotemp $info 1428 rename bar {} 1429 lappend infotemp $info 1430 set info $infotemp 1431 unset infotemp 1432 set info 1433} {{::foo ::bar rename} {::bar {} delete}} 1434catch {rename foo {}} 1435catch {rename bar {}} 1436 1437test trace-20.5 {trace add command rename and delete} { 1438 set infotemp {} 1439 set info {} 1440 proc foo {} {} 1441 trace add command foo {rename delete} traceCommand 1442 rename foo bar 1443 lappend infotemp $info 1444 rename bar {} 1445 lappend infotemp $info 1446 set info $infotemp 1447 unset infotemp 1448 set info 1449} {{::foo ::bar rename} {::bar {} delete}} 1450 1451test trace-20.6 {trace add command rename and delete in subinterp} { 1452 set tc [interp create] 1453 foreach p {traceCommand} { 1454 $tc eval [list proc $p [info args $p] [info body $p]] 1455 } 1456 $tc eval [list set infotemp {}] 1457 $tc eval [list set info {}] 1458 $tc eval [list proc foo {} {}] 1459 $tc eval [list trace add command foo {rename delete} traceCommand] 1460 $tc eval [list rename foo bar] 1461 $tc eval {lappend infotemp $info} 1462 $tc eval [list rename bar {}] 1463 $tc eval {lappend infotemp $info} 1464 $tc eval {set info $infotemp} 1465 $tc eval [list unset infotemp] 1466 set info [$tc eval [list set info]] 1467 interp delete $tc 1468 set info 1469} {{::foo ::bar rename} {::bar {} delete}} 1470 1471# I'd like it if this test could give 'foo {} d' as a result, 1472# but interp deletion means there is no interp to evaluate 1473# the trace in. 1474test trace-20.7 {trace add command delete in subinterp while being deleted} { 1475 set info {} 1476 set tc [interp create] 1477 interp alias $tc traceCommand {} traceCommand 1478 $tc eval [list proc foo {} {}] 1479 $tc eval [list trace add command foo {rename delete} traceCommand] 1480 interp delete $tc 1481 set info 1482} {} 1483 1484proc traceDelete {cmd old new op} { 1485 trace remove command $cmd {*}[lindex [trace info command $cmd] 0] 1486 global info 1487 set info [list $old $new $op] 1488} 1489proc traceCmdrename {cmd old new op} { 1490 rename $old someothername 1491} 1492proc traceCmddelete {cmd old new op} { 1493 rename $old "" 1494} 1495test trace-20.8 {trace delete while trace is active} { 1496 set info {} 1497 proc foo {} {} 1498 catch {rename bar {}} 1499 trace add command foo {rename delete} [list traceDelete foo] 1500 rename foo bar 1501 list [set info] [trace info command bar] 1502} {{::foo ::bar rename} {}} 1503 1504test trace-20.9 {rename trace deletes command} { 1505 set info {} 1506 proc foo {} {} 1507 catch {rename bar {}} 1508 catch {rename someothername {}} 1509 trace add command foo rename [list traceCmddelete foo] 1510 rename foo bar 1511 list [info commands foo] [info commands bar] [info commands someothername] 1512} {{} {} {}} 1513 1514test trace-20.10 {rename trace renames command} { 1515 set info {} 1516 proc foo {} {} 1517 catch {rename bar {}} 1518 catch {rename someothername {}} 1519 trace add command foo rename [list traceCmdrename foo] 1520 rename foo bar 1521 set info [list [info commands foo] [info commands bar] [info commands someothername]] 1522 rename someothername {} 1523 set info 1524} {{} {} someothername} 1525 1526test trace-20.11 {delete trace deletes command} { 1527 set info {} 1528 proc foo {} {} 1529 catch {rename bar {}} 1530 catch {rename someothername {}} 1531 trace add command foo delete [list traceCmddelete foo] 1532 rename foo {} 1533 list [info commands foo] [info commands bar] [info commands someothername] 1534} {{} {} {}} 1535 1536test trace-20.12 {delete trace renames command} { 1537 set info {} 1538 proc foo {} {} 1539 catch {rename bar {}} 1540 catch {rename someothername {}} 1541 trace add command foo delete [list traceCmdrename foo] 1542 rename foo bar 1543 rename bar {} 1544 # None of these should exist. 1545 list [info commands foo] [info commands bar] [info commands someothername] 1546} {{} {} {}} 1547 1548test trace-20.13 {rename trace discards result [Bug 1355342]} { 1549 proc foo {} {} 1550 trace add command foo rename {set w Aha!;#} 1551 list [rename foo bar] [rename bar {}] 1552} {{} {}} 1553test trace-20.14 {rename trace discards error result [Bug 1355342]} { 1554 proc foo {} {} 1555 trace add command foo rename {error} 1556 list [rename foo bar] [rename bar {}] 1557} {{} {}} 1558test trace-20.15 {delete trace discards result [Bug 1355342]} { 1559 proc foo {} {} 1560 trace add command foo delete {set w Aha!;#} 1561 rename foo {} 1562} {} 1563test trace-20.16 {delete trace discards error result [Bug 1355342]} { 1564 proc foo {} {} 1565 trace add command foo delete {error} 1566 rename foo {} 1567} {} 1568 1569 1570proc foo {b} { set a $b } 1571 1572 1573# Delete arrays when done, so they can be re-used as scalars 1574# elsewhere. 1575 1576unset -nocomplain x y 1577 1578# Delete procedures when done, so we don't clash with other tests 1579# (e.g. foobar will clash with 'unknown' tests). 1580catch {rename foobar {}} 1581catch {rename foo {}} 1582catch {rename bar {}} 1583 1584proc foo {a} { 1585 set b $a 1586} 1587 1588proc traceExecute {args} { 1589 global info 1590 lappend info $args 1591} 1592 1593test trace-21.1 {trace execution: enter} { 1594 set info {} 1595 trace add execution foo enter [list traceExecute foo] 1596 foo 1 1597 trace remove execution foo enter [list traceExecute foo] 1598 set info 1599} {{foo {foo 1} enter}} 1600 1601test trace-21.2 {trace exeuction: leave} { 1602 set info {} 1603 trace add execution foo leave [list traceExecute foo] 1604 foo 2 1605 trace remove execution foo leave [list traceExecute foo] 1606 set info 1607} {{foo {foo 2} 0 2 leave}} 1608 1609test trace-21.3 {trace exeuction: enter, leave} { 1610 set info {} 1611 trace add execution foo {enter leave} [list traceExecute foo] 1612 foo 3 1613 trace remove execution foo {enter leave} [list traceExecute foo] 1614 set info 1615} {{foo {foo 3} enter} {foo {foo 3} 0 3 leave}} 1616 1617test trace-21.4 {trace execution: enter, leave, enterstep} { 1618 set info {} 1619 trace add execution foo {enter leave enterstep} [list traceExecute foo] 1620 foo 3 1621 trace remove execution foo {enter leave enterstep} [list traceExecute foo] 1622 set info 1623} {{foo {foo 3} enter} {foo {set b 3} enterstep} {foo {foo 3} 0 3 leave}} 1624 1625test trace-21.5 {trace execution: enter, leave, enterstep, leavestep} { 1626 set info {} 1627 trace add execution foo {enter leave enterstep leavestep} [list traceExecute foo] 1628 foo 3 1629 trace remove execution foo {enter leave enterstep leavestep} [list traceExecute foo] 1630 set info 1631} {{foo {foo 3} enter} {foo {set b 3} enterstep} {foo {set b 3} 0 3 leavestep} {foo {foo 3} 0 3 leave}} 1632 1633test trace-21.6 {trace execution: enterstep, leavestep} { 1634 set info {} 1635 trace add execution foo {enterstep leavestep} [list traceExecute foo] 1636 foo 3 1637 trace remove execution foo {enterstep leavestep} [list traceExecute foo] 1638 set info 1639} {{foo {set b 3} enterstep} {foo {set b 3} 0 3 leavestep}} 1640 1641test trace-21.7 {trace execution: enterstep} { 1642 set info {} 1643 trace add execution foo {enterstep} [list traceExecute foo] 1644 foo 3 1645 trace remove execution foo {enterstep} [list traceExecute foo] 1646 set info 1647} {{foo {set b 3} enterstep}} 1648 1649test trace-21.8 {trace execution: leavestep} { 1650 set info {} 1651 trace add execution foo {leavestep} [list traceExecute foo] 1652 foo 3 1653 trace remove execution foo {leavestep} [list traceExecute foo] 1654 set info 1655} {{foo {set b 3} 0 3 leavestep}} 1656 1657test trace-21.9 {trace execution: TCL_EVAL_GLOBAL} testevalobjv { 1658 trace add execution foo enter soom 1659 proc ::soom args {lappend ::info SUCCESS [info level]} 1660 set ::info {} 1661 namespace eval test_ns_1 { 1662 proc soom args {lappend ::info FAIL [info level]} 1663 # [testevalobjv 1 ...] ought to produce the same 1664 # results as [uplevel #0 ...]. 1665 testevalobjv 1 foo x 1666 uplevel #0 foo x 1667 } 1668 namespace delete test_ns_1 1669 trace remove execution foo enter soom 1670 set ::info 1671} {SUCCESS 1 SUCCESS 1} 1672 1673test trace-21.10 {trace execution: TCL_EVAL_GLOBAL} testevalobjv { 1674 trace add execution foo leave soom 1675 proc ::soom args {lappend ::info SUCCESS [info level]} 1676 set ::info {} 1677 namespace eval test_ns_1 { 1678 proc soom args {lappend ::info FAIL [info level]} 1679 # [testevalobjv 1 ...] ought to produce the same 1680 # results as [uplevel #0 ...]. 1681 testevalobjv 1 foo x 1682 uplevel #0 foo x 1683 } 1684 namespace delete test_ns_1 1685 trace remove execution foo leave soom 1686 set ::info 1687} {SUCCESS 1 SUCCESS 1} 1688 1689test trace-21.11 {trace execution and alias} -setup { 1690 set res {} 1691 proc ::x {} {return ::} 1692 namespace eval a {} 1693 proc ::a::x {} {return ::a} 1694 interp alias {} y {} x 1695} -body { 1696 lappend res [namespace eval ::a y] 1697 trace add execution ::x enter { 1698 rename ::x {} 1699 proc ::x {} {return ::} 1700 #} 1701 lappend res [namespace eval ::a y] 1702} -cleanup { 1703 namespace delete a 1704 rename ::x {} 1705} -result {:: ::} 1706 1707proc set2 args { 1708 set {*}$args 1709} 1710 1711test trace-21.12 {bug 2438181} -setup { 1712 trace add execution set2 leave {puts one two three #;} 1713} -body { 1714 set2 a hello 1715} -returnCodes 1 -result {wrong # args: should be "puts ?-nonewline? ?channelId? string"} 1716 1717proc factorial {n} { 1718 if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] } 1719 return 1 1720} 1721 1722test trace-22.1 {recursive(1) trace execution: enter} { 1723 set info {} 1724 trace add execution factorial {enter} [list traceExecute factorial] 1725 factorial 1 1726 trace remove execution factorial {enter} [list traceExecute factorial] 1727 set info 1728} {{factorial {factorial 1} enter}} 1729 1730test trace-22.2 {recursive(2) trace execution: enter} { 1731 set info {} 1732 trace add execution factorial {enter} [list traceExecute factorial] 1733 factorial 2 1734 trace remove execution factorial {enter} [list traceExecute factorial] 1735 set info 1736} {{factorial {factorial 2} enter} {factorial {factorial 1} enter}} 1737 1738test trace-22.3 {recursive(3) trace execution: enter} { 1739 set info {} 1740 trace add execution factorial {enter} [list traceExecute factorial] 1741 factorial 3 1742 trace remove execution factorial {enter} [list traceExecute factorial] 1743 set info 1744} {{factorial {factorial 3} enter} {factorial {factorial 2} enter} {factorial {factorial 1} enter}} 1745 1746test trace-23.1 {recursive(1) trace execution: enter, leave, enterstep, leavestep} { 1747 set info {} 1748 trace add execution factorial {enter leave enterstep leavestep} [list traceExecute] 1749 factorial 1 1750 trace remove execution factorial {enter leave enterstep leavestep} [list traceExecute] 1751 join $info "\n" 1752} {{factorial 1} enter 1753{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep 1754{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 0 {} leavestep 1755{return 1} enterstep 1756{return 1} 2 1 leavestep 1757{factorial 1} 0 1 leave} 1758 1759test trace-23.2 {recursive(2) trace execution: enter, leave, enterstep, leavestep} { 1760 set info {} 1761 trace add execution factorial {enter leave enterstep leavestep} [list traceExecute] 1762 factorial 2 1763 trace remove execution factorial {enter leave enterstep leavestep} [list traceExecute] 1764 join $info "\n" 1765} {{factorial 2} enter 1766{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep 1767{expr {$n * [factorial [expr {$n -1 }]]}} enterstep 1768{expr {$n -1 }} enterstep 1769{expr {$n -1 }} 0 1 leavestep 1770{factorial 1} enterstep 1771{factorial 1} enter 1772{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep 1773{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 0 {} leavestep 1774{return 1} enterstep 1775{return 1} 2 1 leavestep 1776{factorial 1} 0 1 leave 1777{factorial 1} 0 1 leavestep 1778{expr {$n * [factorial [expr {$n -1 }]]}} 0 2 leavestep 1779{return 2} enterstep 1780{return 2} 2 2 leavestep 1781{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 2 2 leavestep 1782{factorial 2} 0 2 leave} 1783 1784test trace-23.3 {recursive(3) trace execution: enter, leave, enterstep, leavestep} { 1785 set info {} 1786 trace add execution factorial {enter leave enterstep leavestep} [list traceExecute] 1787 factorial 3 1788 trace remove execution factorial {enter leave enterstep leavestep} [list traceExecute] 1789 join $info "\n" 1790} {{factorial 3} enter 1791{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep 1792{expr {$n * [factorial [expr {$n -1 }]]}} enterstep 1793{expr {$n -1 }} enterstep 1794{expr {$n -1 }} 0 2 leavestep 1795{factorial 2} enterstep 1796{factorial 2} enter 1797{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep 1798{expr {$n * [factorial [expr {$n -1 }]]}} enterstep 1799{expr {$n -1 }} enterstep 1800{expr {$n -1 }} 0 1 leavestep 1801{factorial 1} enterstep 1802{factorial 1} enter 1803{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep 1804{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 0 {} leavestep 1805{return 1} enterstep 1806{return 1} 2 1 leavestep 1807{factorial 1} 0 1 leave 1808{factorial 1} 0 1 leavestep 1809{expr {$n * [factorial [expr {$n -1 }]]}} 0 2 leavestep 1810{return 2} enterstep 1811{return 2} 2 2 leavestep 1812{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 2 2 leavestep 1813{factorial 2} 0 2 leave 1814{factorial 2} 0 2 leavestep 1815{expr {$n * [factorial [expr {$n -1 }]]}} 0 6 leavestep 1816{return 6} enterstep 1817{return 6} 2 6 leavestep 1818{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 2 6 leavestep 1819{factorial 3} 0 6 leave} 1820 1821proc traceDelete {cmd args} { 1822 trace remove execution $cmd {*}[lindex [trace info execution $cmd] 0] 1823 global info 1824 set info $args 1825} 1826 1827test trace-24.1 {delete trace during enter trace} { 1828 set info {} 1829 trace add execution foo enter [list traceDelete foo] 1830 foo 1 1831 list $info [catch {trace info execution foo} res] $res 1832} {{{foo 1} enter} 0 {}} 1833 1834test trace-24.2 {delete trace during leave trace} { 1835 set info {} 1836 trace add execution foo leave [list traceDelete foo] 1837 foo 1 1838 list $info [catch {trace info execution foo} res] $res 1839} {{{foo 1} 0 1 leave} 0 {}} 1840 1841test trace-24.3 {delete trace during enter-leave trace} { 1842 set info {} 1843 trace add execution foo {enter leave} [list traceDelete foo] 1844 foo 1 1845 list $info [catch {trace info execution foo} res] $res 1846} {{{foo 1} enter} 0 {}} 1847 1848test trace-24.4 {delete trace during all exec traces} { 1849 set info {} 1850 trace add execution foo {enter leave enterstep leavestep} [list traceDelete foo] 1851 foo 1 1852 list $info [catch {trace info execution foo} res] $res 1853} {{{foo 1} enter} 0 {}} 1854 1855test trace-24.5 {delete trace during all exec traces except enter} { 1856 set info {} 1857 trace add execution foo {leave enterstep leavestep} [list traceDelete foo] 1858 foo 1 1859 list $info [catch {trace info execution foo} res] $res 1860} {{{set b 1} enterstep} 0 {}} 1861 1862proc traceDelete {cmd args} { 1863 rename $cmd {} 1864 global info 1865 set info $args 1866} 1867 1868proc foo {a} { 1869 set b $a 1870} 1871 1872test trace-25.1 {delete command during enter trace} { 1873 set info {} 1874 trace add execution foo enter [list traceDelete foo] 1875 catch {foo 1} err 1876 list $err $info [catch {trace info execution foo} res] $res 1877} {{invalid command name "foo"} {{foo 1} enter} 1 {unknown command "foo"}} 1878 1879proc foo {a} { 1880 set b $a 1881} 1882 1883test trace-25.2 {delete command during leave trace} { 1884 set info {} 1885 trace add execution foo leave [list traceDelete foo] 1886 foo 1 1887 list $info [catch {trace info execution foo} res] $res 1888} {{{foo 1} 0 1 leave} 1 {unknown command "foo"}} 1889 1890proc foo {a} { 1891 set b $a 1892} 1893 1894test trace-25.3 {delete command during enter then leave trace} { 1895 set info {} 1896 trace add execution foo enter [list traceDelete foo] 1897 trace add execution foo leave [list traceDelete foo] 1898 catch {foo 1} err 1899 list $err $info [catch {trace info execution foo} res] $res 1900} {{invalid command name "foo"} {{foo 1} enter} 1 {unknown command "foo"}} 1901 1902proc foo {a} { 1903 set b $a 1904} 1905proc traceExecute2 {args} { 1906 global info 1907 lappend info $args 1908} 1909 1910# This shows the peculiar consequences of having two traces 1911# at the same time: as well as tracing the procedure you want 1912test trace-25.4 {order dependencies of two enter traces} { 1913 set info {} 1914 trace add execution foo enter [list traceExecute traceExecute] 1915 trace add execution foo enter [list traceExecute2 traceExecute2] 1916 catch {foo 1} err 1917 trace remove execution foo enter [list traceExecute traceExecute] 1918 trace remove execution foo enter [list traceExecute2 traceExecute2] 1919 join [list $err [join $info \n] [trace info execution foo]] "\n" 1920} {1 1921traceExecute2 {foo 1} enter 1922traceExecute {foo 1} enter 1923} 1924 1925test trace-25.5 {order dependencies of two step traces} { 1926 set info {} 1927 trace add execution foo enterstep [list traceExecute traceExecute] 1928 trace add execution foo enterstep [list traceExecute2 traceExecute2] 1929 catch {foo 1} err 1930 trace remove execution foo enterstep [list traceExecute traceExecute] 1931 trace remove execution foo enterstep [list traceExecute2 traceExecute2] 1932 join [list $err [join $info \n] [trace info execution foo]] "\n" 1933} {1 1934traceExecute2 {set b 1} enterstep 1935traceExecute {set b 1} enterstep 1936} 1937 1938# We don't want the result string (5th argument), or the results 1939# will get unmanageable. 1940proc tracePostExecute {args} { 1941 global info 1942 lappend info [concat [lrange $args 0 2] [lindex $args 4]] 1943} 1944proc tracePostExecute2 {args} { 1945 global info 1946 lappend info [concat [lrange $args 0 2] [lindex $args 4]] 1947} 1948 1949test trace-25.6 {order dependencies of two leave traces} { 1950 set info {} 1951 trace add execution foo leave [list tracePostExecute tracePostExecute] 1952 trace add execution foo leave [list tracePostExecute2 tracePostExecute2] 1953 catch {foo 1} err 1954 trace remove execution foo leave [list tracePostExecute tracePostExecute] 1955 trace remove execution foo leave [list tracePostExecute2 tracePostExecute2] 1956 join [list $err [join $info \n] [trace info execution foo]] "\n" 1957} {1 1958tracePostExecute {foo 1} 0 leave 1959tracePostExecute2 {foo 1} 0 leave 1960} 1961 1962test trace-25.7 {order dependencies of two leavestep traces} { 1963 set info {} 1964 trace add execution foo leavestep [list tracePostExecute tracePostExecute] 1965 trace add execution foo leavestep [list tracePostExecute2 tracePostExecute2] 1966 catch {foo 1} err 1967 trace remove execution foo leavestep [list tracePostExecute tracePostExecute] 1968 trace remove execution foo leavestep [list tracePostExecute2 tracePostExecute2] 1969 join [list $err [join $info \n] [trace info execution foo]] "\n" 1970} {1 1971tracePostExecute {set b 1} 0 leavestep 1972tracePostExecute2 {set b 1} 0 leavestep 1973} 1974 1975proc foo {a} { 1976 set b $a 1977} 1978 1979proc traceDelete {cmd args} { 1980 rename $cmd {} 1981 global info 1982 set info $args 1983} 1984 1985test trace-25.8 {delete command during enter leave and enter/leave-step traces} { 1986 set info {} 1987 trace add execution foo enter [list traceDelete foo] 1988 trace add execution foo leave [list traceDelete foo] 1989 trace add execution foo enterstep [list traceDelete foo] 1990 trace add execution foo leavestep [list traceDelete foo] 1991 catch {foo 1} err 1992 list $err $info [catch {trace info execution foo} res] $res 1993} {{invalid command name "foo"} {{foo 1} enter} 1 {unknown command "foo"}} 1994 1995proc foo {a} { 1996 set b $a 1997} 1998 1999test trace-25.9 {delete command during enter leave and leavestep traces} { 2000 set info {} 2001 trace add execution foo enter [list traceDelete foo] 2002 trace add execution foo leave [list traceDelete foo] 2003 trace add execution foo leavestep [list traceDelete foo] 2004 catch {foo 1} err 2005 list $err $info [catch {trace info execution foo} res] $res 2006} {{invalid command name "foo"} {{foo 1} enter} 1 {unknown command "foo"}} 2007 2008proc foo {a} { 2009 set b $a 2010} 2011 2012test trace-25.10 {delete command during leave and leavestep traces} { 2013 set info {} 2014 trace add execution foo leave [list traceDelete foo] 2015 trace add execution foo leavestep [list traceDelete foo] 2016 catch {foo 1} err 2017 list $err $info [catch {trace info execution foo} res] $res 2018} {1 {{set b 1} 0 1 leavestep} 1 {unknown command "foo"}} 2019 2020proc foo {a} { 2021 set b $a 2022} 2023 2024test trace-25.11 {delete command during enter and enterstep traces} { 2025 set info {} 2026 trace add execution foo enter [list traceDelete foo] 2027 trace add execution foo enterstep [list traceDelete foo] 2028 catch {foo 1} err 2029 list $err $info [catch {trace info execution foo} res] $res 2030} {{invalid command name "foo"} {{foo 1} enter} 1 {unknown command "foo"}} 2031 2032test trace-26.1 {trace targetCmd when invoked through an alias} { 2033 proc foo {args} { 2034 set b $args 2035 } 2036 set info {} 2037 trace add execution foo enter [list traceExecute foo] 2038 interp alias {} bar {} foo 1 2039 bar 2 2040 trace remove execution foo enter [list traceExecute foo] 2041 set info 2042} {{foo {foo 1 2} enter}} 2043test trace-26.2 {trace targetCmd when invoked through an alias} { 2044 proc foo {args} { 2045 set b $args 2046 } 2047 set info {} 2048 trace add execution foo enter [list traceExecute foo] 2049 interp create child 2050 interp alias child bar {} foo 1 2051 child eval bar 2 2052 interp delete child 2053 trace remove execution foo enter [list traceExecute foo] 2054 set info 2055} {{foo {foo 1 2} enter}} 2056 2057test trace-27.1 {memory leak in rename trace (604609)} { 2058 catch {rename bar {}} 2059 proc foo {} {error foo} 2060 trace add command foo rename {rename foo "" ;#} 2061 rename foo bar 2062 info commands foo 2063} {} 2064 2065test trace-27.2 {command trace remove nonsense} { 2066 list [catch {trace remove command thisdoesntexist \ 2067 {delete rename} bar} res] $res 2068} {1 {unknown command "thisdoesntexist"}} 2069 2070test trace-27.3 {command trace info nonsense} { 2071 list [catch {trace info command thisdoesntexist} res] $res 2072} {1 {unknown command "thisdoesntexist"}} 2073 2074 2075test trace-28.1 {enterstep and leavestep traces with update idletasks (615043)} { 2076 catch {rename foo {}} 2077 proc foo {} { 2078 set a 1 2079 update idletasks 2080 set b 1 2081 } 2082 2083 set info {} 2084 trace add execution foo {enter enterstep leavestep leave} \ 2085 [list traceExecute foo] 2086 update 2087 after idle {set a "idle"} 2088 foo 2089 2090 trace remove execution foo {enter enterstep leavestep leave} \ 2091 [list traceExecute foo] 2092 rename foo {} 2093 unset -nocomplain a 2094 join $info "\n" 2095} {foo foo enter 2096foo {set a 1} enterstep 2097foo {set a 1} 0 1 leavestep 2098foo {update idletasks} enterstep 2099foo {set a idle} enterstep 2100foo {set a idle} 0 idle leavestep 2101foo {update idletasks} 0 {} leavestep 2102foo {set b 1} enterstep 2103foo {set b 1} 0 1 leavestep 2104foo foo 0 1 leave} 2105 2106test trace-28.2 {exec traces with 'error'} { 2107 set info {} 2108 set res {} 2109 2110 proc foo {} { 2111 if {[catch {bar}]} { 2112 return "error" 2113 } else { 2114 return "ok" 2115 } 2116 } 2117 2118 proc bar {} { error "msg" } 2119 2120 lappend res [foo] 2121 2122 trace add execution foo {enter enterstep leave leavestep} \ 2123 [list traceExecute foo] 2124 2125 # With the trace active 2126 2127 lappend res [foo] 2128 2129 trace remove execution foo {enter enterstep leave leavestep} \ 2130 [list traceExecute foo] 2131 2132 list $res [join $info \n] 2133} {{error error} {foo foo enter 2134foo {if {[catch {bar}]} { 2135 return "error" 2136 } else { 2137 return "ok" 2138 }} enterstep 2139foo {catch bar} enterstep 2140foo bar enterstep 2141foo {error msg} enterstep 2142foo {error msg} 1 msg leavestep 2143foo bar 1 msg leavestep 2144foo {catch bar} 0 1 leavestep 2145foo {return error} enterstep 2146foo {return error} 2 error leavestep 2147foo {if {[catch {bar}]} { 2148 return "error" 2149 } else { 2150 return "ok" 2151 }} 2 error leavestep 2152foo foo 0 error leave}} 2153 2154test trace-28.3 {exec traces with 'return -code error'} { 2155 set info {} 2156 set res {} 2157 2158 proc foo {} { 2159 if {[catch {bar}]} { 2160 return "error" 2161 } else { 2162 return "ok" 2163 } 2164 } 2165 2166 proc bar {} { return -code error "msg" } 2167 2168 lappend res [foo] 2169 2170 trace add execution foo {enter enterstep leave leavestep} \ 2171 [list traceExecute foo] 2172 2173 # With the trace active 2174 2175 lappend res [foo] 2176 2177 trace remove execution foo {enter enterstep leave leavestep} \ 2178 [list traceExecute foo] 2179 2180 list $res [join $info \n] 2181} {{error error} {foo foo enter 2182foo {if {[catch {bar}]} { 2183 return "error" 2184 } else { 2185 return "ok" 2186 }} enterstep 2187foo {catch bar} enterstep 2188foo bar enterstep 2189foo {return -code error msg} enterstep 2190foo {return -code error msg} 2 msg leavestep 2191foo bar 1 msg leavestep 2192foo {catch bar} 0 1 leavestep 2193foo {return error} enterstep 2194foo {return error} 2 error leavestep 2195foo {if {[catch {bar}]} { 2196 return "error" 2197 } else { 2198 return "ok" 2199 }} 2 error leavestep 2200foo foo 0 error leave}} 2201 2202test trace-28.4 {exec traces in child with 'return -code error'} { 2203 interp create child 2204 interp alias child traceExecute {} traceExecute 2205 set info {} 2206 set res [interp eval child { 2207 set info {} 2208 set res {} 2209 2210 proc foo {} { 2211 if {[catch {bar}]} { 2212 return "error" 2213 } else { 2214 return "ok" 2215 } 2216 } 2217 2218 proc bar {} { return -code error "msg" } 2219 2220 lappend res [foo] 2221 2222 trace add execution foo {enter enterstep leave leavestep} \ 2223 [list traceExecute foo] 2224 2225 # With the trace active 2226 2227 lappend res [foo] 2228 2229 trace remove execution foo {enter enterstep leave leavestep} \ 2230 [list traceExecute foo] 2231 2232 list $res 2233 }] 2234 interp delete child 2235 lappend res [join $info \n] 2236} {{error error} {foo foo enter 2237foo {if {[catch {bar}]} { 2238 return "error" 2239 } else { 2240 return "ok" 2241 }} enterstep 2242foo {catch bar} enterstep 2243foo bar enterstep 2244foo {return -code error msg} enterstep 2245foo {return -code error msg} 2 msg leavestep 2246foo bar 1 msg leavestep 2247foo {catch bar} 0 1 leavestep 2248foo {return error} enterstep 2249foo {return error} 2 error leavestep 2250foo {if {[catch {bar}]} { 2251 return "error" 2252 } else { 2253 return "ok" 2254 }} 2 error leavestep 2255foo foo 0 error leave}} 2256 2257test trace-28.5 {exec traces} { 2258 set info {} 2259 proc foo {args} { set a 1 } 2260 trace add execution foo {enter enterstep leave leavestep} \ 2261 [list traceExecute foo] 2262 after idle [list foo test-28.4] 2263 update 2264 # Complicated way of removing traces 2265 set ti [lindex [eval [list trace info execution ::foo]] 0] 2266 if {[llength $ti]} { 2267 eval [concat [list trace remove execution foo] $ti] 2268 } 2269 join $info \n 2270} {foo {foo test-28.4} enter 2271foo {set a 1} enterstep 2272foo {set a 1} 0 1 leavestep 2273foo {foo test-28.4} 0 1 leave} 2274 2275test trace-28.6 {exec traces firing order} { 2276 set info {} 2277 proc enterStep {cmd op} {lappend ::info "enter $cmd/$op"} 2278 proc leaveStep {cmd code result op} {lappend ::info "leave $cmd/$code/$result/$op"} 2279 2280 proc foo x { 2281 set b x=$x 2282 incr x 2283 } 2284 trace add execution foo enterstep enterStep 2285 trace add execution foo leavestep leaveStep 2286 foo 42 2287 rename foo {} 2288 join $info \n 2289} {enter set b x=42/enterstep 2290leave set b x=42/0/x=42/leavestep 2291enter incr x/enterstep 2292leave incr x/0/43/leavestep} 2293 2294test trace-28.7 {exec trace information} { 2295 set info {} 2296 proc foo x { incr x } 2297 proc bar {args} {} 2298 trace add execution foo {enter leave enterstep leavestep} bar 2299 set info [trace info execution foo] 2300 trace remove execution foo {enter leave enterstep leavestep} bar 2301} {} 2302 2303test trace-28.8 {exec trace remove nonsense} { 2304 list [catch {trace remove execution thisdoesntexist \ 2305 {enter leave enterstep leavestep} bar} res] $res 2306} {1 {unknown command "thisdoesntexist"}} 2307 2308test trace-28.9 {exec trace info nonsense} { 2309 list [catch {trace info execution thisdoesntexist} res] $res 2310} {1 {unknown command "thisdoesntexist"}} 2311 2312test trace-28.10 {exec trace info nonsense} { 2313 list [catch {trace remove execution} res] $res 2314} {1 {wrong # args: should be "trace remove execution name opList command"}} 2315 2316test trace-29.1 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} { 2317 testcmdtrace tracetest {set stuff [expr {14 + 16}]} 2318} {{expr {14 + 16}} {expr {14 + 16}} {set stuff [expr {14 + 16}]} {set stuff 30}} 2319test trace-29.2 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} { 2320 testcmdtrace tracetest {set stuff [info tclversion]} 2321} [concat {{info tclversion} {info tclversion} ::tcl::info::tclversion {::tcl::info::tclversion} {set stuff [info tclversion]}} [list "set stuff [info tclversion]"]] 2322test trace-29.3 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} { 2323 testcmdtrace deletetest {set stuff [info tclversion]} 2324} [info tclversion] 2325test trace-29.4 {Tcl_CreateTrace, check that tracing doesn't cause memory faults} {testcmdtrace} { 2326 # Note that the proc call is the same as the variable name, and that 2327 # the call can be direct or indirect by way of another procedure 2328 proc tracer {args} {} 2329 proc tracedLoop {level} { 2330 incr level 2331 tracer 2332 foreach tracer [expr {$level==1 ? {1 2} : {}}] {tracedLoop $level} 2333 } 2334 testcmdtrace tracetest {tracedLoop 0} 2335} {{tracedLoop 0} {tracedLoop 0} {incr level} {incr level} tracer {tracer} {expr {$level==1 ? {1 2} : {}}} {expr {$level==1 ? {1 2} : {}}} {foreach tracer [expr {$level==1 ? {1 2} : {}}] {tracedLoop $level}} {foreach tracer {1 2} {tracedLoop $level}} {tracedLoop $level} {tracedLoop 1} {incr level} {incr level} tracer {tracer} {expr {$level==1 ? {1 2} : {}}} {expr {$level==1 ? {1 2} : {}}} {foreach tracer [expr {$level==1 ? {1 2} : {}}] {tracedLoop $level}} {foreach tracer {} {tracedLoop $level}} {tracedLoop $level} {tracedLoop 1} {incr level} {incr level} tracer {tracer} {expr {$level==1 ? {1 2} : {}}} {expr {$level==1 ? {1 2} : {}}} {foreach tracer [expr {$level==1 ? {1 2} : {}}] {tracedLoop $level}} {foreach tracer {} {tracedLoop $level}}} 2336catch {rename tracer {}} 2337catch {rename tracedLoop {}} 2338 2339test trace-29.5 {Tcl_CreateObjTrace, status return TCL_ERROR} {testcmdtrace} { 2340 proc Error { args } { error "Shouldn't get here" } 2341 set x 1; 2342 list [catch {testcmdtrace resulttest {Error $x}} result] [set result] 2343} {1 {Error $x}} 2344 2345test trace-29.6 {Tcl_CreateObjTrace, status return TCL_RETURN} {testcmdtrace} { 2346 proc Return { args } { error "Shouldn't get here" } 2347 set x 1; 2348 list [catch {testcmdtrace resulttest {Return $x}} result] [set result] 2349} {2 {}} 2350 2351test trace-29.7 {Tcl_CreateObjTrace, status return TCL_BREAK} {testcmdtrace} { 2352 proc Break { args } { error "Shouldn't get here" } 2353 set x 1; 2354 list [catch {testcmdtrace resulttest {Break $x}} result] [set result] 2355} {3 {}} 2356 2357test trace-29.8 {Tcl_CreateObjTrace, status return TCL_CONTINUE} {testcmdtrace} { 2358 proc Continue { args } { error "Shouldn't get here" } 2359 set x 1; 2360 list [catch {testcmdtrace resulttest {Continue $x}} result] [set result] 2361} {4 {}} 2362 2363test trace-29.9 {Tcl_CreateObjTrace, status return unknown} {testcmdtrace} { 2364 proc OtherStatus { args } { error "Shouldn't get here" } 2365 set x 1; 2366 list [catch {testcmdtrace resulttest {OtherStatus $x}} result] [set result] 2367} {6 {}} 2368 2369test trace-29.10 {Tcl_CreateTrace, correct level interpretation} {testcmdtrace} { 2370 proc foo {} {uplevel 1 bar} 2371 proc bar {} {uplevel 1 grok} 2372 proc grok {} {uplevel 1 spock} 2373 proc spock {} {uplevel 1 fascinating} 2374 proc fascinating {} {} 2375 testcmdtrace leveltest {foo} 2376} {foo {foo} {uplevel 1 bar} {uplevel 1 bar} bar {bar} {uplevel 1 grok} {uplevel 1 grok}} 2377 2378test trace-29.11 {Tcl_CreateTrace, multiple traces} {testcmdtrace} { 2379 testcmdtrace doubletest {format xx} 2380} {{format xx} {format xx}} 2381 2382test trace-30.1 {Tcl_DeleteTrace} {emptyTest} { 2383 # the above tests have tested Tcl_DeleteTrace 2384} {} 2385 2386test trace-31.1 {command and execution traces shared struct} { 2387 # Tcl Bug 807243 2388 proc foo {} {} 2389 trace add command foo delete foo 2390 trace add execution foo enter foo 2391 set result [trace info command foo] 2392 trace remove command foo delete foo 2393 trace remove execution foo enter foo 2394 rename foo {} 2395 set result 2396} [list [list delete foo]] 2397test trace-31.2 {command and execution traces shared struct} { 2398 # Tcl Bug 807243 2399 proc foo {} {} 2400 trace add command foo delete foo 2401 trace add execution foo enter foo 2402 set result [trace info execution foo] 2403 trace remove command foo delete foo 2404 trace remove execution foo enter foo 2405 rename foo {} 2406 set result 2407} [list [list enter foo]] 2408 2409test trace-32.1 { 2410 TraceCommandInfo refcount decr in TraceCommandProc w/o loss of reference 2411} { 2412 # Tcl Bug 811483 2413 proc foo {} {} 2414 trace add command foo delete foo 2415 trace add execution foo enter foo 2416 set result [trace info command foo] 2417 rename foo {} 2418 set result 2419} [list [list delete foo]] 2420 2421test trace-33.1 {variable match with remove variable} { 2422 unset -nocomplain x 2423 trace variable x w foo 2424 trace remove variable x write foo 2425 llength [trace info variable x] 2426} 0 2427 2428test trace-34.1 {Bug 1201035} { 2429 set ::x [list] 2430 proc foo {} {lappend ::x foo} 2431 proc bar args { 2432 lappend ::x $args 2433 trace remove execution foo leavestep bar 2434 trace remove execution foo enterstep bar 2435 trace add execution foo leavestep bar 2436 trace add execution foo enterstep bar 2437 lappend ::x done 2438 } 2439 trace add execution foo leavestep bar 2440 trace add execution foo enterstep bar 2441 foo 2442 set ::x 2443} {{{lappend ::x foo} enterstep} done foo} 2444 2445test trace-34.2 {Bug 1224585} { 2446 proc foo {} {} 2447 proc bar args {trace remove execution foo leave soom} 2448 trace add execution foo leave bar 2449 trace add execution foo leave soom 2450 foo 2451} {} 2452 2453test trace-34.3 {Bug 1224585} { 2454 proc foo {} {set x {}} 2455 proc bar args {trace remove execution foo enterstep soom} 2456 trace add execution foo enterstep soom 2457 trace add execution foo enterstep bar 2458 foo 2459} {} 2460 2461# We test here for the half-documented and currently valid interplay between 2462# delete traces and namespace deletion. 2463test trace-34.4 {Bug 1047286} { 2464 variable x notrace 2465 proc callback {old - -} { 2466 variable x "$old exists: [namespace which -command $old]" 2467 } 2468 namespace eval ::foo {proc bar {} {}} 2469 trace add command ::foo::bar delete [namespace code callback] 2470 namespace delete ::foo 2471 set x 2472} {::foo::bar exists: ::foo::bar} 2473 2474test trace-34.5 {Bug 1047286} { 2475 variable x notrace 2476 proc callback {old - -} { 2477 variable x "$old exists: [namespace which -command $old]" 2478 } 2479 namespace eval ::foo {proc bar {} {}} 2480 trace add command ::foo::bar delete [namespace code callback] 2481 namespace eval ::foo namespace delete ::foo 2482 set x 2483} {::foo::bar exists: } 2484 2485test trace-34.6 {Bug 1458266} -setup { 2486 proc dummy {} {} 2487 proc stepTraceHandler {cmdString args} { 2488 variable log 2489 append log "[expr {[info level] - 1}]: [lindex [split $cmdString] 0]\n" 2490 dummy 2491 isTracedInside_2 2492 } 2493 proc cmdTraceHandler {cmdString args} { 2494 # silent 2495 } 2496 proc isTracedInside_1 {} { 2497 isTracedInside_2 2498 } 2499 proc isTracedInside_2 {} { 2500 set x 2 2501 } 2502} -body { 2503 variable log {} 2504 trace add execution isTracedInside_1 enterstep stepTraceHandler 2505 trace add execution isTracedInside_2 enterstep stepTraceHandler 2506 isTracedInside_1 2507 variable first $log 2508 set log {} 2509 trace add execution dummy enter cmdTraceHandler 2510 isTracedInside_1 2511 variable second $log 2512 expr {($first eq $second) ? "ok" : "\n$first\nand\n\n$second\ndiffer"} 2513} -cleanup { 2514 unset -nocomplain log first second 2515 rename dummy {} 2516 rename stepTraceHandler {} 2517 rename cmdTraceHandler {} 2518 rename isTracedInside_1 {} 2519 rename isTracedInside_2 {} 2520} -result ok 2521 2522test trace-35.1 {527164: Keep -errorinfo of traces} -setup { 2523 unset -nocomplain x y 2524} -body { 2525 trace add variable x write {error foo;#} 2526 trace add variable y write {set x 2;#} 2527 list [catch {set y 1} msg opts] $msg [dict get $opts -errorinfo] 2528} -cleanup { 2529 unset -nocomplain x y 2530} -result {1 {can't set "y": can't set "x": foo} {foo 2531 while executing 2532"error foo" 2533 (write trace on "x") 2534 invoked from within 2535"set x 2" 2536 (write trace on "y") 2537 invoked from within 2538"set y 1"}} 2539 2540 2541# 2542# Test for the correct(?) dynamics of execution traces. This test insures that 2543# the dynamics of the original implementation remain valid; note that 2544# these aspects are neither documented nor do they appear in TIP 62 2545 2546proc traceproc {tracevar args} { 2547 append ::$tracevar * 2548} 2549proc untraced {type} { 2550 trace add execution untraced $type {traceproc tracevar} 2551 append ::tracevar - 2552} 2553proc runbase {results base} { 2554 set tt {enter leave enterstep leavestep} 2555 foreach n {1 2 3 4} t $tt r $results { 2556 eval [subst $base] 2557 } 2558} 2559set base { 2560 test trace-36.$n {dynamic trace creation: $t} -setup { 2561 set ::tracevar {} 2562 } -cleanup { 2563 unset ::tracevar 2564 trace remove execution untraced $t {traceproc tracevar} 2565 } -body { 2566 untraced $t 2567 set ::tracevar 2568 } -result {$r} 2569} 2570runbase {- - - -} $base 2571 2572set base { 2573 test trace-37.$n {dynamic trace addition: $t} -setup { 2574 set ::tracevar {} 2575 set ::tracevar2 {} 2576 trace add execution untraced enter {traceproc tracevar2} 2577 } -cleanup { 2578 trace remove execution untraced $t {traceproc tracevar} 2579 trace remove execution untraced enter {traceproc tracevar2} 2580 unset ::tracevar ::tracevar2 2581 } -body { 2582 untraced $t 2583 list \$::tracevar \$::tracevar2 2584 } -result {$r} 2585} 2586runbase {{- *} {-* *} {- *} {- *}} $base 2587 2588set base { 2589 test trace-38.$n {dynamic trace addition: $t} -setup { 2590 set ::tracevar {} 2591 set ::tracevar2 {} 2592 trace add execution untraced leave {traceproc tracevar2} 2593 } -cleanup { 2594 trace remove execution untraced $t {traceproc tracevar} 2595 trace remove execution untraced leave {traceproc tracevar2} 2596 unset ::tracevar ::tracevar2 2597 } -body { 2598 untraced $t 2599 list \$::tracevar \$::tracevar2 2600 } -result {$r} 2601} 2602runbase {{- *} {-* *} {- *} {- *}} $base 2603 2604test trace-39 {bug #3484621: tracing Bc'ed commands} -setup { 2605 set ::traceLog 0 2606 set ::traceCalls 0 2607 set ::bar [list 0 1 2 3] 2608 set res {} 2609 proc dotrace args { 2610 incr ::traceLog 2611 } 2612 proc foo {} { 2613 incr ::traceCalls 2614 # choose a BC'ed command that is 'unlikely' to interfere with tcltest's 2615 # internals 2616 lset ::bar 1 2 2617 } 2618} -body { 2619 foo 2620 lappend res $::traceLog 2621 2622 trace add execution lset enter dotrace 2623 foo 2624 lappend res $::traceLog 2625 2626 trace remove execution lset enter dotrace 2627 foo 2628 lappend res $::traceLog 2629 2630 list $::traceCalls | {*}$res 2631} -cleanup { 2632 unset ::traceLog ::traceCalls ::bar res 2633 rename dotrace {} 2634 rename foo {} 2635} -result {3 | 0 1 1} 2636 2637test trace-39.1 {bug #3485022: tracing Bc'ed commands} -setup { 2638 set ::traceLog 0 2639 set ::traceCalls 0 2640 set res {} 2641 proc dotrace args { 2642 incr ::traceLog 2643 } 2644 proc foo {} { 2645 incr ::traceCalls 2646 string equal zip zap 2647 } 2648} -body { 2649 foo 2650 lappend res $::traceLog 2651 2652 trace add execution ::tcl::string::equal enter dotrace 2653 foo 2654 lappend res $::traceLog 2655 2656 trace remove execution tcl::string::equal enter dotrace 2657 foo 2658 lappend res $::traceLog 2659 2660 list $::traceCalls | {*}$res 2661} -cleanup { 2662 unset ::traceLog ::traceCalls res 2663 rename dotrace {} 2664 rename foo {} 2665} -result {3 | 0 1 1} 2666 2667test trace-40.1 {execution trace errors become command errors} { 2668 proc foo args {} 2669 trace add execution foo enter {rename foo {}; error bar;#} 2670 catch foo m 2671 return -level 0 $m[unset m] 2672} bar 2673 2674# Delete procedures when done, so we don't clash with other tests 2675# (e.g. foobar will clash with 'unknown' tests). 2676catch {rename foobar {}} 2677catch {rename foo {}} 2678catch {rename bar {}} 2679catch {rename untraced {}} 2680catch {rename traceproc {}} 2681catch {rename runbase {}} 2682 2683# Unset the variable when done 2684unset -nocomplain info base 2685 2686# cleanup 2687cleanupTests 2688return 2689