开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Windows编程 > 通讯编程 > 查看源码
trace.test
资源名称：ns-allinone-2.33.tar.gz　[点击查看]
上传用户：rrhhcc
上传日期：2015-12-11
资源大小：54129k
文件大小：74k
源码类别：

通讯编程

开发平台：

Visual C++

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