Symaptic: os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/trace.test@260cb5ec6c19

     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.17 2006/11/04 01:37:56 msofer 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 } {}

   234 # append no longer triggers read traces when fetching the old values of

   235 # variables before doing the append operation. However, lappend _does_

   236 # still trigger these read traces. Also lappend triggers only one write

   237 # trace: after appending all arguments to the list.

   239 test trace-3.1 {trace variable read-modify-writes} {

   240     catch {unset x}

   241     set info {}

   242     trace add variable x read traceScalarAppend

   243     append x 123

   244     append x 456

   245     lappend x 789

   246     set info

   247 } {x {} read 0 123456}

   248 test trace-3.2 {trace variable read-modify-writes} {

   249     catch {unset x}

   250     set info {}

   251     trace add variable x {read write} traceScalarAppend

   252     append x 123

   253     lappend x 456

   254     set info

   255 } {x {} write 0 123 x {} read 0 123 x {} write 0 {123 456}}

   257 # Basic unset-tracing on variables

   259 test trace-4.1 {trace variable unsets} {

   260     catch {unset x}

   261     set info {}

   262     trace add variable x unset traceScalar

   263     catch {unset x}

   264     set info

   265 } {x {} unset 1 {can't read "x": no such variable}}

   266 test trace-4.2 {variable mustn't exist during unset trace} {

   267     catch {unset x}

   268     set x 1234

   269     set info {}

   270     trace add variable x unset traceScalar

   271     unset x

   272     set info

   273 } {x {} unset 1 {can't read "x": no such variable}}

   274 test trace-4.3 {unset traces mustn't be called during reads and writes} {

   275     catch {unset x}

   276     set info {}

   277     trace add variable x unset traceScalar

   278     set x 44

   279     set x

   280     set info

   281 } {}

   282 test trace-4.4 {trace unsets on array elements} {

   283     catch {unset x}

   284     set x(0) 18

   285     set info {}

   286     trace add variable x(1) unset traceArray

   287     catch {unset x(1)}

   288     set info

   289 } {x 1 unset 1 {can't read "x(1)": no such element in array}}

   290 test trace-4.5 {trace unsets on array elements} {

   291     catch {unset x}

   292     set x(1) 18

   293     set info {}

   294     trace add variable x(1) unset traceArray

   295     unset x(1)

   296     set info

   297 } {x 1 unset 1 {can't read "x(1)": no such element in array}}

   298 test trace-4.6 {trace unsets on array elements} {

   299     catch {unset x}

   300     set x(1) 18

   301     set info {}

   302     trace add variable x(1) unset traceArray

   303     unset x

   304     set info

   305 } {x 1 unset 1 {can't read "x(1)": no such variable}}

   306 test trace-4.7 {trace unsets on whole arrays} {

   307     catch {unset x}

   308     set x(1) 18

   309     set info {}

   310     trace add variable x unset traceProc

   311     catch {unset x(0)}

   312     set info

   313 } {}

   314 test trace-4.8 {trace unsets on whole arrays} {

   315     catch {unset x}

   316     set x(1) 18

   317     set x(2) 144

   318     set x(3) 14

   319     set info {}

   320     trace add variable x unset traceProc

   321     unset x(1)

   322     set info

   323 } {x 1 unset}

   324 test trace-4.9 {trace unsets on whole arrays} {

   325     catch {unset x}

   326     set x(1) 18

   327     set x(2) 144

   328     set x(3) 14

   329     set info {}

   330     trace add variable x unset traceProc

   331     unset x

   332     set info

   333 } {x {} unset}

   335 # Array tracing on variables

   336 test trace-5.1 {array traces fire on accesses via [array]} {

   337     catch {unset x}

   338     set x(b) 2

   339     trace add variable x array traceArray2

   340     set ::info {}

   341     array set x {a 1}

   342     set ::info

   343 } {x {} array}

   344 test trace-5.2 {array traces do not fire on normal accesses} {

   345     catch {unset x}

   346     set x(b) 2

   347     trace add variable x array traceArray2

   348     set ::info {}

   349     set x(a) 1

   350     set x(b) $x(a)

   351     set ::info

   352 } {}

   353 test trace-5.3 {array traces do not outlive variable} {

   354     catch {unset x}

   355     trace add variable x array traceArray2

   356     set ::info {}

   357     set x(a) 1

   358     unset x

   359     array set x {a 1}

   360     set ::info

   361 } {}

   362 test trace-5.4 {array traces properly listed in trace information} {

   363     catch {unset x}

   364     trace add variable x array traceArray2

   365     set result [trace info variable x]

   366     set result

   367 } [list [list array traceArray2]]

   368 test trace-5.5 {array traces properly listed in trace information} {

   369     catch {unset x}

   370     trace variable x a traceArray2

   371     set result [trace vinfo x]

   372     set result

   373 } [list [list a traceArray2]]

   374 test trace-5.6 {array traces don't fire on scalar variables} {

   375     catch {unset x}

   376     set x foo

   377     trace add variable x array traceArray2

   378     set ::info {}

   379     catch {array set x {a 1}}

   380     set ::info

   381 } {}

   382 test trace-5.7 {array traces fire for undefined variables} {

   383     catch {unset x}

   384     trace add variable x array traceArray2

   385     set ::info {}

   386     array set x {a 1}

   387     set ::info

   388 } {x {} array}

   389 test trace-5.8 {array traces fire for undefined variables} {

   390     catch {unset x}

   391     trace add variable x array {set x(foo) 1 ;#}

   392     set res "names: [array names x]"

   393 } {names: foo}

   395 # Trace multiple trace types at once.

   397 test trace-6.1 {multiple ops traced at once} {

   398     catch {unset x}

   399     set info {}

   400     trace add variable x {read write unset} traceProc

   401     catch {set x}

   402     set x 22

   403     set x

   404     set x 33

   405     unset x

   406     set info

   407 } {x {} read x {} write x {} read x {} write x {} unset}

   408 test trace-6.2 {multiple ops traced on array element} {

   409     catch {unset x}

   410     set info {}

   411     trace add variable x(0) {read write unset} traceProc

   412     catch {set x(0)}

   413     set x(0) 22

   414     set x(0)

   415     set x(0) 33

   416     unset x(0)

   417     unset x

   418     set info

   419 } {x 0 read x 0 write x 0 read x 0 write x 0 unset}

   420 test trace-6.3 {multiple ops traced on whole array} {

   421     catch {unset x}

   422     set info {}

   423     trace add variable x {read write unset} traceProc

   424     catch {set x(0)}

   425     set x(0) 22

   426     set x(0)

   427     set x(0) 33

   428     unset x(0)

   429     unset x

   430     set info

   431 } {x 0 write x 0 read x 0 write x 0 unset x {} unset}

   433 # Check order of invocation of traces

   435 test trace-7.1 {order of invocation of traces} {

   436     catch {unset x}

   437     set info {}

   438     trace add variable x read "traceTag 1"

   439     trace add variable x read "traceTag 2"

   440     trace add variable x read "traceTag 3"

   441     catch {set x}

   442     set x 22

   443     set x

   444     set info

   445 } {3 2 1 3 2 1}

   446 test trace-7.2 {order of invocation of traces} {

   447     catch {unset x}

   448     set x(0) 44

   449     set info {}

   450     trace add variable x(0) read "traceTag 1"

   451     trace add variable x(0) read "traceTag 2"

   452     trace add variable x(0) read "traceTag 3"

   453     set x(0)

   454     set info

   455 } {3 2 1}

   456 test trace-7.3 {order of invocation of traces} {

   457     catch {unset x}

   458     set x(0) 44

   459     set info {}

   460     trace add variable x(0) read "traceTag 1"

   461     trace add variable x read "traceTag A1"

   462     trace add variable x(0) read "traceTag 2"

   463     trace add variable x read "traceTag A2"

   464     trace add variable x(0) read "traceTag 3"

   465     trace add variable x read "traceTag A3"

   466     set x(0)

   467     set info

   468 } {A3 A2 A1 3 2 1}

   470 # Check effects of errors in trace procedures

   472 test trace-8.1 {error returns from traces} {

   473     catch {unset x}

   474     set x 123

   475     set info {}

   476     trace add variable x read "traceTag 1"

   477     trace add variable x read traceError

   478     list [catch {set x} msg] $msg $info

   479 } {1 {can't read "x": trace returned error} {}}

   480 test trace-8.2 {error returns from traces} {

   481     catch {unset x}

   482     set x 123

   483     set info {}

   484     trace add variable x write "traceTag 1"

   485     trace add variable x write traceError

   486     list [catch {set x 44} msg] $msg $info

   487 } {1 {can't set "x": trace returned error} {}}

   488 test trace-8.3 {error returns from traces} {

   489     catch {unset x}

   490     set x 123

   491     set info {}

   492     trace add variable x write traceError

   493     list [catch {append x 44} msg] $msg $info

   494 } {1 {can't set "x": trace returned error} {}}

   495 test trace-8.4 {error returns from traces} {

   496     catch {unset x}

   497     set x 123

   498     set info {}

   499     trace add variable x unset "traceTag 1"

   500     trace add variable x unset traceError

   501     list [catch {unset x} msg] $msg $info

   502 } {0 {} 1}

   503 test trace-8.5 {error returns from traces} {

   504     catch {unset x}

   505     set x(0) 123

   506     set info {}

   507     trace add variable x(0) read "traceTag 1"

   508     trace add variable x read "traceTag 2"

   509     trace add variable x read traceError

   510     trace add variable x read "traceTag 3"

   511     list [catch {set x(0)} msg] $msg $info

   512 } {1 {can't read "x(0)": trace returned error} 3}

   513 test trace-8.6 {error returns from traces} {

   514     catch {unset x}

   515     set x 123

   516     trace add variable x unset traceError

   517     list [catch {unset x} msg] $msg

   518 } {0 {}}

   519 test trace-8.7 {error returns from traces} {

   520     # This test just makes sure that the memory for the error message

   521     # gets deallocated correctly when the trace is invoked again or

   522     # when the trace is deleted.

   523     catch {unset x}

   524     set x 123

   525     trace add variable x read traceError

   526     catch {set x}

   527     catch {set x}

   528     trace remove variable x read traceError

   529 } {}

   530 test trace-8.8 {error returns from traces} {

   531     # Yet more elaborate memory corruption testing that checks nothing

   532     # bad happens when the trace deletes itself and installs something

   533     # new.  Alas, there is no neat way to guarantee that this test will

   534     # fail if there is a problem, but that's life and with the new code

   535     # it should *never* fail.

   536     #

   537     # Adapted from Bug #219393 reported by Don Porter.

   538     catch {rename ::foo {}}

   539     proc foo {old args} {

   540 	trace remove variable ::x write [list foo $old]

   541 	trace add    variable ::x write [list foo $::x]

   542 	error "foo"

   543     }

   544     catch {unset ::x ::y}

   545     set x junk

   546     trace add variable ::x write [list foo $x]

   547     for {set y 0} {$y<100} {incr y} {

   548 	catch {set x junk}

   549     }

   550     unset x

   551 } {}

   553 # Check to see that variables are expunged before trace

   554 # procedures are invoked, so trace procedure can even manipulate

   555 # a new copy of the variables.

   557 test trace-9.1 {be sure variable is unset before trace is called} {

   558     catch {unset x}

   559     set x 33

   560     set info {}

   561     trace add variable x unset {traceCheck {uplevel set x}}

   562     unset x

   563     set info

   564 } {1 {can't read "x": no such variable}}

   565 test trace-9.2 {be sure variable is unset before trace is called} {

   566     catch {unset x}

   567     set x 33

   568     set info {}

   569     trace add variable x unset {traceCheck {uplevel set x 22}}

   570     unset x

   571     concat $info [list [catch {set x} msg] $msg]

   572 } {0 22 0 22}

   573 test trace-9.3 {be sure traces are cleared before unset trace called} {

   574     catch {unset x}

   575     set x 33

   576     set info {}

   577     trace add variable x unset {traceCheck {uplevel trace info variable x}}

   578     unset x

   579     set info

   580 } {0 {}}

   581 test trace-9.4 {set new trace during unset trace} {

   582     catch {unset x}

   583     set x 33

   584     set info {}

   585     trace add variable x unset {traceCheck {global x; trace add variable x unset traceProc}}

   586     unset x

   587     concat $info [trace info variable x]

   588 } {0 {} {unset traceProc}}

   590 test trace-10.1 {make sure array elements are unset before traces are called} {

   591     catch {unset x}

   592     set x(0) 33

   593     set info {}

   594     trace add variable x(0) unset {traceCheck {uplevel set x(0)}}

   595     unset x(0)

   596     set info

   597 } {1 {can't read "x(0)": no such element in array}}

   598 test trace-10.2 {make sure array elements are unset before traces are called} {

   599     catch {unset x}

   600     set x(0) 33

   601     set info {}

   602     trace add variable x(0) unset {traceCheck {uplevel set x(0) zzz}}

   603     unset x(0)

   604     concat $info [list [catch {set x(0)} msg] $msg]

   605 } {0 zzz 0 zzz}

   606 test trace-10.3 {array elements are unset before traces are called} {

   607     catch {unset x}

   608     set x(0) 33

   609     set info {}

   610     trace add variable x(0) unset {traceCheck {global x; trace info variable x(0)}}

   611     unset x(0)

   612     set info

   613 } {0 {}}

   614 test trace-10.4 {set new array element trace during unset trace} {

   615     catch {unset x}

   616     set x(0) 33

   617     set info {}

   618     trace add variable x(0) unset {traceCheck {uplevel {trace add variable x(0) read {}}}}

   619     catch {unset x(0)}

   620     concat $info [trace info variable x(0)]

   621 } {0 {} {read {}}}

   623 test trace-11.1 {make sure arrays are unset before traces are called} {

   624     catch {unset x}

   625     set x(0) 33

   626     set info {}

   627     trace add variable x unset {traceCheck {uplevel set x(0)}}

   628     unset x

   629     set info

   630 } {1 {can't read "x(0)": no such variable}}

   631 test trace-11.2 {make sure arrays are unset before traces are called} {

   632     catch {unset x}

   633     set x(y) 33

   634     set info {}

   635     trace add variable x unset {traceCheck {uplevel set x(y) 22}}

   636     unset x

   637     concat $info [list [catch {set x(y)} msg] $msg]

   638 } {0 22 0 22}

   639 test trace-11.3 {make sure arrays are unset before traces are called} {

   640     catch {unset x}

   641     set x(y) 33

   642     set info {}

   643     trace add variable x unset {traceCheck {uplevel array exists x}}

   644     unset x

   645     set info

   646 } {0 0}

   647 test trace-11.4 {make sure arrays are unset before traces are called} {

   648     catch {unset x}

   649     set x(y) 33

   650     set info {}

   651     set cmd {traceCheck {uplevel {trace info variable x}}}

   652     trace add variable x unset $cmd

   653     unset x

   654     set info

   655 } {0 {}}

   656 test trace-11.5 {set new array trace during unset trace} {

   657     catch {unset x}

   658     set x(y) 33

   659     set info {}

   660     trace add variable x unset {traceCheck {global x; trace add variable x read {}}}

   661     unset x

   662     concat $info [trace info variable x]

   663 } {0 {} {read {}}}

   664 test trace-11.6 {create scalar during array unset trace} {

   665     catch {unset x}

   666     set x(y) 33

   667     set info {}

   668     trace add variable x unset {traceCheck {global x; set x 44}}

   669     unset x

   670     concat $info [list [catch {set x} msg] $msg]

   671 } {0 44 0 44}

   673 # Check special conditions (e.g. errors) in Tcl_TraceVar2.

   675 test trace-12.1 {creating array when setting variable traces} {

   676     catch {unset x}

   677     set info {}

   678     trace add variable x(0) write traceProc

   679     list [catch {set x 22} msg] $msg

   680 } {1 {can't set "x": variable is array}}

   681 test trace-12.2 {creating array when setting variable traces} {

   682     catch {unset x}

   683     set info {}

   684     trace add variable x(0) write traceProc

   685     list [catch {set x(0)} msg] $msg

   686 } {1 {can't read "x(0)": no such element in array}}

   687 test trace-12.3 {creating array when setting variable traces} {

   688     catch {unset x}

   689     set info {}

   690     trace add variable x(0) write traceProc

   691     set x(0) 22

   692     set info

   693 } {x 0 write}

   694 test trace-12.4 {creating variable when setting variable traces} {

   695     catch {unset x}

   696     set info {}

   697     trace add variable x write traceProc

   698     list [catch {set x} msg] $msg

   699 } {1 {can't read "x": no such variable}}

   700 test trace-12.5 {creating variable when setting variable traces} {

   701     catch {unset x}

   702     set info {}

   703     trace add variable x write traceProc

   704     set x 22

   705     set info

   706 } {x {} write}

   707 test trace-12.6 {creating variable when setting variable traces} {

   708     catch {unset x}

   709     set info {}

   710     trace add variable x write traceProc

   711     set x(0) 22

   712     set info

   713 } {x 0 write}

   714 test trace-12.7 {create array element during read trace} {

   715     catch {unset x}

   716     set x(2) zzz

   717     trace add variable x read {traceCrtElement xyzzy}

   718     list [catch {set x(3)} msg] $msg

   719 } {0 xyzzy}

   720 test trace-12.8 {errors when setting variable traces} {

   721     catch {unset x}

   722     set x 44

   723     list [catch {trace add variable x(0) write traceProc} msg] $msg

   724 } {1 {can't trace "x(0)": variable isn't array}}

   726 # Check trace deletion

   728 test trace-13.1 {delete one trace from another} {

   729     proc delTraces {args} {

   730 	global x

   731 	trace remove variable x read {traceTag 2}

   732 	trace remove variable x read {traceTag 3}

   733 	trace remove variable x read {traceTag 4}

   734     }

   735     catch {unset x}

   736     set x 44

   737     set info {}

   738     trace add variable x read {traceTag 1}

   739     trace add variable x read {traceTag 2}

   740     trace add variable x read {traceTag 3}

   741     trace add variable x read {traceTag 4}

   742     trace add variable x read delTraces

   743     trace add variable x read {traceTag 5}

   744     set x

   745     set info

   746 } {5 1}

   747 test trace-13.2 {leak when unsetting traced variable} \

   748     -constraints memory -body {

   749 	set end [getbytes]

   750 	proc f args {}

   751 	for {set i 0} {$i < 5} {incr i} {

   752 	    trace add variable bepa write f

   753 	    set bepa a

   754 	    unset bepa

   755 	    set tmp $end

   756 	    set end [getbytes]

   757 	}

   758 	expr {$end - $tmp}

   759     } -cleanup {

   760 	unset -nocomplain end i tmp

   761     } -result 0

   762 test trace-13.3 {leak when removing traces} \

   763     -constraints memory -body {

   764 	set end [getbytes]

   765 	proc f args {}

   766 	for {set i 0} {$i < 5} {incr i} {

   767 	    trace add variable bepa write f

   768 	    set bepa a

   769 	    trace remove variable bepa write f

   770 	    set tmp $end

   771 	    set end [getbytes]

   772 	}

   773 	expr {$end - $tmp}

   774     } -cleanup {

   775 	unset -nocomplain end i tmp

   776     } -result 0

   777 test trace-13.4 {leaks in error returns from traces} \

   778     -constraints memory -body {

   779 	set end [getbytes]

   780 	for {set i 0} {$i < 5} {incr i} {

   781 	    set apa {a 1 b 2}

   782 	    set bepa [lrange $apa 0 end]

   783 	    trace add variable bepa write {error hej}

   784 	    catch {set bepa a}

   785 	    unset bepa

   786 	    set tmp $end

   787 	    set end [getbytes]

   788 	}

   789 	expr {$end - $tmp}

   790     } -cleanup {

   791 	unset -nocomplain end i tmp

   792     } -result 0

   794 # Check operation and syntax of "trace" command.

   796 # Syntax for adding/removing variable and command traces is basically the

   797 # same:

   798 #	trace add variable name opList command

   799 #	trace remove variable name opList command

   800 #

   801 # The following loops just get all the common "wrong # args" tests done.

   803 set i 0

   804 set start "wrong # args:"

   805 foreach type {variable command} {

   806     foreach op {add remove} {

   807 	test trace-14.0.[incr i] "trace command, wrong # args errors" {

   808 	    list [catch {trace $op $type} msg] $msg

   809 	} [list 1 "$start should be \"trace $op $type name opList command\""]

   810 	test trace-14.0.[incr i] "trace command wrong # args errors" {

   811 	    list [catch {trace $op $type foo} msg] $msg

   812 	} [list 1 "$start should be \"trace $op $type name opList command\""]

   813 	test trace-14.0.[incr i] "trace command, wrong # args errors" {

   814 	    list [catch {trace $op $type foo bar} msg] $msg

   815 	} [list 1 "$start should be \"trace $op $type name opList command\""]

   816 	test trace-14.0.[incr i] "trace command, wrong # args errors" {

   817 	    list [catch {trace $op $type foo bar baz boo} msg] $msg

   818 	} [list 1 "$start should be \"trace $op $type name opList command\""]

   819     }

   820     test trace-14.0.[incr i] "trace command, wrong # args errors" {

   821 	list [catch {trace info $type foo bar} msg] $msg

   822     } [list 1 "$start should be \"trace info $type name\""]

   823     test trace-14.0.[incr i] "trace command, wrong # args errors" {

   824 	list [catch {trace info $type} msg] $msg

   825     } [list 1 "$start should be \"trace info $type name\""]

   826 }

   828 test trace-14.1 "trace command, wrong # args errors" {

   829     list [catch {trace} msg] $msg

   830 } [list 1 "wrong # args: should be \"trace option ?arg arg ...?\""]

   831 test trace-14.2 "trace command, wrong # args errors" {

   832     list [catch {trace add} msg] $msg

   833 } [list 1 "wrong # args: should be \"trace add type ?arg arg ...?\""]

   834 test trace-14.3 "trace command, wrong # args errors" {

   835     list [catch {trace remove} msg] $msg

   836 } [list 1 "wrong # args: should be \"trace remove type ?arg arg ...?\""]

   837 test trace-14.4 "trace command, wrong # args errors" {

   838     list [catch {trace info} msg] $msg

   839 } [list 1 "wrong # args: should be \"trace info type ?arg arg ...?\""]

   841 test trace-14.5 {trace command, invalid option} {

   842     list [catch {trace gorp} msg] $msg

   843 } [list 1 "bad option \"gorp\": must be add, info, remove, variable, vdelete, or vinfo"]

   845 # Again, [trace ... command] and [trace ... variable] share syntax and

   846 # error message styles for their opList options; these loops test those

   847 # error messages.

   849 set i 0

   850 set errs [list "array, read, unset, or write" "delete or rename" "enter, leave, enterstep, or leavestep"]

   851 set abbvs [list {a r u w} {d r} {}]

   852 proc x {} {}

   853 foreach type {variable command execution} err $errs abbvlist $abbvs {

   854     foreach op {add remove} {

   855 	test trace-14.6.[incr i] "trace $op $type errors" {

   856 	    list [catch {trace $op $type x {y z w} a} msg] $msg

   857 	} [list 1 "bad operation \"y\": must be $err"]

   858 	foreach abbv $abbvlist {

   859 	    test trace-14.6.[incr i] "trace $op $type rejects abbreviations" {

   860 		list [catch {trace $op $type x $abbv a} msg] $msg

   861 	    } [list 1 "bad operation \"$abbv\": must be $err"]

   862 	}

   863 	test trace-14.6.[incr i] "trace $op $type rejects null opList" {

   864 	    list [catch {trace $op $type x {} a} msg] $msg

   865 	} [list 1 "bad operation list \"\": must be one or more of $err"]

   866     }

   867 }

   868 rename x {}

   870 test trace-14.7 {trace command, "trace variable" errors} {

   871     list [catch {trace variable} msg] $msg

   872 } [list 1 "wrong # args: should be \"trace variable name ops command\""]

   873 test trace-14.8 {trace command, "trace variable" errors} {

   874     list [catch {trace variable x} msg] $msg

   875 } [list 1 "wrong # args: should be \"trace variable name ops command\""]

   876 test trace-14.9 {trace command, "trace variable" errors} {

   877     list [catch {trace variable x y} msg] $msg

   878 } [list 1 "wrong # args: should be \"trace variable name ops command\""]

   879 test trace-14.10 {trace command, "trace variable" errors} {

   880     list [catch {trace variable x y z w} msg] $msg

   881 } [list 1 "wrong # args: should be \"trace variable name ops command\""]

   882 test trace-14.11 {trace command, "trace variable" errors} {

   883     list [catch {trace variable x y z} msg] $msg

   884 } [list 1 "bad operations \"y\": should be one or more of rwua"]

   887 test trace-14.12 {trace command ("remove variable" option)} {

   888     catch {unset x}

   889     set info {}

   890     trace add variable x write traceProc

   891     trace remove variable x write traceProc

   892 } {}

   893 test trace-14.13 {trace command ("remove variable" option)} {

   894     catch {unset x}

   895     set info {}

   896     trace add variable x write traceProc

   897     trace remove variable x write traceProc

   898     set x 12345

   899     set info

   900 } {}

   901 test trace-14.14 {trace command ("remove variable" option)} {

   902     catch {unset x}

   903     set info {}

   904     trace add variable x write {traceTag 1}

   905     trace add variable x write traceProc

   906     trace add variable x write {traceTag 2}

   907     set x yy

   908     trace remove variable x write traceProc

   909     set x 12345

   910     trace remove variable x write {traceTag 1}

   911     set x foo

   912     trace remove variable x write {traceTag 2}

   913     set x gorp

   914     set info

   915 } {2 x {} write 1 2 1 2}

   916 test trace-14.15 {trace command ("remove variable" option)} {

   917     catch {unset x}

   918     set info {}

   919     trace add variable x write {traceTag 1}

   920     trace remove variable x write non_existent

   921     set x 12345

   922     set info

   923 } {1}

   924 test trace-14.16 {trace command ("info variable" option)} {

   925     catch {unset x}

   926     trace add variable x write {traceTag 1}

   927     trace add variable x write traceProc

   928     trace add variable x write {traceTag 2}

   929     trace info variable x

   930 } {{write {traceTag 2}} {write traceProc} {write {traceTag 1}}}

   931 test trace-14.17 {trace command ("info variable" option)} {

   932     catch {unset x}

   933     trace info variable x

   934 } {}

   935 test trace-14.18 {trace command ("info variable" option)} {

   936     catch {unset x}

   937     trace info variable x(0)

   938 } {}

   939 test trace-14.19 {trace command ("info variable" option)} {

   940     catch {unset x}

   941     set x 44

   942     trace info variable x(0)

   943 } {}

   944 test trace-14.20 {trace command ("info variable" option)} {

   945     catch {unset x}

   946     set x 44

   947     trace add variable x write {traceTag 1}

   948     proc check {} {global x; trace info variable x}

   949     check

   950 } {{write {traceTag 1}}}

   952 # Check fancy trace commands (long ones, weird arguments, etc.)

   954 test trace-15.1 {long trace command} {

   955     catch {unset x}

   956     set info {}

   957     trace add variable x write {traceTag {This is a very very long argument.  It's \

   958 	designed to test out the facilities of TraceVarProc for dealing \

   959 	with such long arguments by malloc-ing space.  One possibility \

   960 	is that space doesn't get freed properly.  If this happens, then \

   961 	invoking this test over and over again will eventually leak memory.}}

   962     set x 44

   963     set info

   964 } {This is a very very long argument.  It's \

   965 	designed to test out the facilities of TraceVarProc for dealing \

   966 	with such long arguments by malloc-ing space.  One possibility \

   967 	is that space doesn't get freed properly.  If this happens, then \

   968 	invoking this test over and over again will eventually leak memory.}

   969 test trace-15.2 {long trace command result to ignore} {

   970     proc longResult {args} {return "quite a bit of text, designed to

   971 	generate a core leak if this command file is invoked over and over again

   972 	and memory isn't being recycled correctly"}

   973     catch {unset x}

   974     trace add variable x write longResult

   975     set x 44

   976     set x 5

   977     set x abcde

   978 } abcde

   979 test trace-15.3 {special list-handling in trace commands} {

   980     catch {unset "x y z"}

   981     set "x y z(a\n\{)" 44

   982     set info {}

   983     trace add variable "x y z(a\n\{)" write traceProc

   984     set "x y z(a\n\{)" 33

   985     set info

   986 } "{x y z} a\\n\\\{ write"

   988 # Check for proper handling of unsets during traces.

   990 proc traceUnset {unsetName args} {

   991     global info

   992     upvar $unsetName x

   993     lappend info [catch {unset x} msg] $msg [catch {set x} msg] $msg

   994 }

   995 proc traceReset {unsetName resetName args} {

   996     global info

   997     upvar $unsetName x $resetName y

   998     lappend info [catch {unset x} msg] $msg [catch {set y xyzzy} msg] $msg

   999 }

  1000 proc traceReset2 {unsetName resetName args} {

  1001     global info

  1002     lappend info [catch {uplevel unset $unsetName} msg] $msg \

  1003 	    [catch {uplevel set $resetName xyzzy} msg] $msg

  1004 }

  1005 proc traceAppend {string name1 name2 op} {

  1006     global info

  1007     lappend info $string

  1008 }

  1010 test trace-16.1 {unsets during read traces} {

  1011     catch {unset y}

  1012     set y 1234

  1013     set info {}

  1014     trace add variable y read {traceUnset y}

  1015     trace add variable y unset {traceAppend unset}

  1016     lappend info [catch {set y} msg] $msg

  1017 } {unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}}

  1018 test trace-16.2 {unsets during read traces} {

  1019     catch {unset y}

  1020     set y(0) 1234

  1021     set info {}

  1022     trace add variable y(0) read {traceUnset y(0)}

  1023     lappend info [catch {set y(0)} msg] $msg

  1024 } {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such element in array}}

  1025 test trace-16.3 {unsets during read traces} {

  1026     catch {unset y}

  1027     set y(0) 1234

  1028     set info {}

  1029     trace add variable y(0) read {traceUnset y}

  1030     lappend info [catch {set y(0)} msg] $msg

  1031 } {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}}

  1032 test trace-16.4 {unsets during read traces} {

  1033     catch {unset y}

  1034     set y 1234

  1035     set info {}

  1036     trace add variable y read {traceReset y y}

  1037     lappend info [catch {set y} msg] $msg

  1038 } {0 {} 0 xyzzy 0 xyzzy}

  1039 test trace-16.5 {unsets during read traces} {

  1040     catch {unset y}

  1041     set y(0) 1234

  1042     set info {}

  1043     trace add variable y(0) read {traceReset y(0) y(0)}

  1044     lappend info [catch {set y(0)} msg] $msg

  1045 } {0 {} 0 xyzzy 0 xyzzy}

  1046 test trace-16.6 {unsets during read traces} {

  1047     catch {unset y}

  1048     set y(0) 1234

  1049     set info {}

  1050     trace add variable y(0) read {traceReset y y(0)}

  1051     lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg

  1052 } {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}}

  1053 test trace-16.7 {unsets during read traces} {

  1054     catch {unset y}

  1055     set y(0) 1234

  1056     set info {}

  1057     trace add variable y(0) read {traceReset2 y y(0)}

  1058     lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg

  1059 } {0 {} 0 xyzzy 1 {can't read "y(0)": no such element in array} 0 xyzzy}

  1060 test trace-16.8 {unsets during write traces} {

  1061     catch {unset y}

  1062     set y 1234

  1063     set info {}

  1064     trace add variable y write {traceUnset y}

  1065     trace add variable y unset {traceAppend unset}

  1066     lappend info [catch {set y xxx} msg] $msg

  1067 } {unset 0 {} 1 {can't read "x": no such variable} 0 {}}

  1068 test trace-16.9 {unsets during write traces} {

  1069     catch {unset y}

  1070     set y(0) 1234

  1071     set info {}

  1072     trace add variable y(0) write {traceUnset y(0)}

  1073     lappend info [catch {set y(0) xxx} msg] $msg

  1074 } {0 {} 1 {can't read "x": no such variable} 0 {}}

  1075 test trace-16.10 {unsets during write traces} {

  1076     catch {unset y}

  1077     set y(0) 1234

  1078     set info {}

  1079     trace add variable y(0) write {traceUnset y}

  1080     lappend info [catch {set y(0) xxx} msg] $msg

  1081 } {0 {} 1 {can't read "x": no such variable} 0 {}}

  1082 test trace-16.11 {unsets during write traces} {

  1083     catch {unset y}

  1084     set y 1234

  1085     set info {}

  1086     trace add variable y write {traceReset y y}

  1087     lappend info [catch {set y xxx} msg] $msg

  1088 } {0 {} 0 xyzzy 0 xyzzy}

  1089 test trace-16.12 {unsets during write traces} {

  1090     catch {unset y}

  1091     set y(0) 1234

  1092     set info {}

  1093     trace add variable y(0) write {traceReset y(0) y(0)}

  1094     lappend info [catch {set y(0) xxx} msg] $msg

  1095 } {0 {} 0 xyzzy 0 xyzzy}

  1096 test trace-16.13 {unsets during write traces} {

  1097     catch {unset y}

  1098     set y(0) 1234

  1099     set info {}

  1100     trace add variable y(0) write {traceReset y y(0)}

  1101     lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg

  1102 } {0 {} 1 {can't set "y": upvar refers to element in deleted array} 0 {} 1 {can't read "y(0)": no such variable}}

  1103 test trace-16.14 {unsets during write traces} {

  1104     catch {unset y}

  1105     set y(0) 1234

  1106     set info {}

  1107     trace add variable y(0) write {traceReset2 y y(0)}

  1108     lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg

  1109 } {0 {} 0 xyzzy 0 {} 0 xyzzy}

  1110 test trace-16.15 {unsets during unset traces} {

  1111     catch {unset y}

  1112     set y 1234

  1113     set info {}

  1114     trace add variable y unset {traceUnset y}

  1115     lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg

  1116 } {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}}

  1117 test trace-16.16 {unsets during unset traces} {

  1118     catch {unset y}

  1119     set y(0) 1234

  1120     set info {}

  1121     trace add variable y(0) unset {traceUnset y(0)}

  1122     lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg

  1123 } {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}}

  1124 test trace-16.17 {unsets during unset traces} {

  1125     catch {unset y}

  1126     set y(0) 1234

  1127     set info {}

  1128     trace add variable y(0) unset {traceUnset y}

  1129     lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg

  1130 } {0 {} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such variable}}

  1131 test trace-16.18 {unsets during unset traces} {

  1132     catch {unset y}

  1133     set y 1234

  1134     set info {}

  1135     trace add variable y unset {traceReset2 y y}

  1136     lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg

  1137 } {1 {can't unset "y": no such variable} 0 xyzzy 0 {} 0 xyzzy}

  1138 test trace-16.19 {unsets during unset traces} {

  1139     catch {unset y}

  1140     set y(0) 1234

  1141     set info {}

  1142     trace add variable y(0) unset {traceReset2 y(0) y(0)}

  1143     lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg

  1144 } {1 {can't unset "y(0)": no such element in array} 0 xyzzy 0 {} 0 xyzzy}

  1145 test trace-16.20 {unsets during unset traces} {

  1146     catch {unset y}

  1147     set y(0) 1234

  1148     set info {}

  1149     trace add variable y(0) unset {traceReset2 y y(0)}

  1150     lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg

  1151 } {0 {} 0 xyzzy 0 {} 0 xyzzy}

  1152 test trace-16.21 {unsets cancelling traces} {

  1153     catch {unset y}

  1154     set y 1234

  1155     set info {}

  1156     trace add variable y read {traceAppend first}

  1157     trace add variable y read {traceUnset y}

  1158     trace add variable y read {traceAppend third}

  1159     trace add variable y unset {traceAppend unset}

  1160     lappend info [catch {set y} msg] $msg

  1161 } {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}}

  1162 test trace-16.22 {unsets cancelling traces} {

  1163     catch {unset y}

  1164     set y(0) 1234

  1165     set info {}

  1166     trace add variable y(0) read {traceAppend first}

  1167     trace add variable y(0) read {traceUnset y}

  1168     trace add variable y(0) read {traceAppend third}

  1169     trace add variable y(0) unset {traceAppend unset}

  1170     lappend info [catch {set y(0)} msg] $msg

  1171 } {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}}

  1173 # Check various non-interference between traces and other things.

  1175 test trace-17.1 {trace doesn't prevent unset errors} {

  1176     catch {unset x}

  1177     set info {}

  1178     trace add variable x unset {traceProc}

  1179     list [catch {unset x} msg] $msg $info

  1180 } {1 {can't unset "x": no such variable} {x {} unset}}

  1181 test trace-17.2 {traced variables must survive procedure exits} {

  1182     catch {unset x}

  1183     proc p1 {} {global x; trace add variable x write traceProc}

  1184     p1

  1185     trace info variable x

  1186 } {{write traceProc}}

  1187 test trace-17.3 {traced variables must survive procedure exits} {

  1188     catch {unset x}

  1189     set info {}

  1190     proc p1 {} {global x; trace add variable x write traceProc}

  1191     p1

  1192     set x 44

  1193     set info

  1194 } {x {} write}

  1196 # Be sure that procedure frames are released before unset traces

  1197 # are invoked.

  1199 test trace-18.1 {unset traces on procedure returns} {

  1200     proc p1 {x y} {set a 44; p2 14}

  1201     proc p2 {z} {trace add variable z unset {traceCheck {lsort [uplevel {info vars}]}}}

  1202     set info {}

  1203     p1 foo bar

  1204     set info

  1205 } {0 {a x y}}

  1206 test trace-18.2 {namespace delete / trace vdelete combo} {

  1207     namespace eval ::foo {

  1208 	variable x 123

  1209     }

  1210     proc p1 args {

  1211 	trace vdelete ::foo::x u p1

  1212     }

  1213     trace variable ::foo::x u p1

  1214     namespace delete ::foo

  1215     info exists ::foo::x

  1216 } 0

  1217 test trace-18.3 {namespace delete / trace vdelete combo, Bug \#1337229} {

  1218     namespace eval ::ns {}

  1219     trace add variable ::ns::var unset {unset ::ns::var ;#}

  1220     namespace delete ::ns

  1221 } {}

  1222 test trace-18.4 {namespace delete / trace vdelete combo, Bug \#1338280} {

  1223     namespace eval ::ref {}

  1224     set ::ref::var1 AAA

  1225     trace add variable ::ref::var1 unset doTrace

  1226     set ::ref::var2 BBB

  1227     trace add variable ::ref::var2 {unset} doTrace

  1228     proc doTrace {vtraced vidx op} {

  1229 	global info

  1230 	append info [catch {set ::$vtraced}][llength [info vars ::ref::*]]

  1231     }

  1232     set info {}

  1233     namespace delete ::ref

  1234     rename doTrace {}

  1235     set info

  1236 } 1110

  1238 # Delete arrays when done, so they can be re-used as scalars

  1239 # elsewhere.

  1241 catch {unset x}

  1242 catch {unset y}

  1244 test trace-19.0.1 {trace add command (command existence)} {

  1245     # Just in case!

  1246     catch {rename nosuchname ""}

  1247     list [catch {trace add command nosuchname rename traceCommand} msg] $msg

  1248 } {1 {unknown command "nosuchname"}}

  1249 test trace-19.0.2 {trace add command (command existence in ns)} {

  1250     list [catch {trace add command nosuchns::nosuchname rename traceCommand} msg] $msg

  1251 } {1 {unknown command "nosuchns::nosuchname"}}

  1254 test trace-19.1 {trace add command (rename option)} {

  1255     proc foo {} {}

  1256     catch {rename bar {}}

  1257     trace add command foo rename traceCommand

  1258     rename foo bar

  1259     set info

  1260 } {::foo ::bar rename}

  1261 test trace-19.2 {traces stick with renamed commands} {

  1262     proc foo {} {}

  1263     catch {rename bar {}}

  1264     trace add command foo rename traceCommand

  1265     rename foo bar

  1266     rename bar foo

  1267     set info

  1268 } {::bar ::foo rename}

  1269 test trace-19.2.1 {trace add command rename trace exists} {

  1270     proc foo {} {}

  1271     trace add command foo rename traceCommand

  1272     trace info command foo

  1273 } {{rename traceCommand}}

  1274 test trace-19.3 {command rename traces don't fire on command deletion} {

  1275     proc foo {} {}

  1276     set info {}

  1277     trace add command foo rename traceCommand

  1278     rename foo {}

  1279     set info

  1280 } {}

  1281 test trace-19.4 {trace add command rename doesn't trace recreated commands} {

  1282     proc foo {} {}

  1283     catch {rename bar {}}

  1284     trace add command foo rename traceCommand

  1285     proc foo {} {}

  1286     rename foo bar

  1287     set info

  1288 } {}

  1289 test trace-19.5 {trace add command deleted removes traces} {

  1290     proc foo {} {}

  1291     trace add command foo rename traceCommand

  1292     proc foo {} {}

  1293     trace info command foo

  1294 } {}

  1296 namespace eval tc {}

  1297 proc tc::tcfoo {} {}

  1298 test trace-19.6 {trace add command rename in namespace} {

  1299     trace add command tc::tcfoo rename traceCommand

  1300     rename tc::tcfoo tc::tcbar

  1301     set info

  1302 } {::tc::tcfoo ::tc::tcbar rename}

  1303 test trace-19.7 {trace add command rename in namespace back again} {

  1304     rename tc::tcbar tc::tcfoo

  1305     set info

  1306 } {::tc::tcbar ::tc::tcfoo rename}

  1307 test trace-19.8 {trace add command rename in namespace to out of namespace} {

  1308     rename tc::tcfoo tcbar

  1309     set info

  1310 } {::tc::tcfoo ::tcbar rename}

  1311 test trace-19.9 {trace add command rename back into namespace} {

  1312     rename tcbar tc::tcfoo

  1313     set info

  1314 } {::tcbar ::tc::tcfoo rename}

  1315 test trace-19.10 {trace add command failed rename doesn't trigger trace} {

  1316     set info {}

  1317     proc foo {} {}

  1318     proc bar {} {}

  1319     trace add command foo {rename delete} traceCommand

  1320     catch {rename foo bar}

  1321     set info

  1322 } {}

  1323 catch {rename foo {}}

  1324 catch {rename bar {}}

  1325 test trace-19.11 {trace add command qualifies when renamed in namespace} {

  1326     set info {}

  1327     namespace eval tc {rename tcfoo tcbar}

  1328     set info

  1329 } {::tc::tcfoo ::tc::tcbar rename}

  1331 # Make sure it exists again

  1332 proc foo {} {}

  1334 test trace-20.1 {trace add command (delete option)} {

  1335     trace add command foo delete traceCommand

  1336     rename foo ""

  1337     set info

  1338 } {::foo {} delete}

  1339 test trace-20.2 {trace add command delete doesn't trace recreated commands} {

  1340     set info {}

  1341     proc foo {} {}

  1342     rename foo ""

  1343     set info

  1344 } {}

  1345 test trace-20.2.1 {trace add command delete trace info} {

  1346     proc foo {} {}

  1347     trace add command foo delete traceCommand

  1348     trace info command foo

  1349 } {{delete traceCommand}}

  1350 test trace-20.3 {trace add command implicit delete} {

  1351     proc foo {} {}

  1352     trace add command foo delete traceCommand

  1353     proc foo {} {}

  1354     set info

  1355 } {::foo {} delete}

  1356 test trace-20.3.1 {trace add command delete trace info} {

  1357     proc foo {} {}

  1358     trace info command foo

  1359 } {}

  1360 test trace-20.4 {trace add command rename followed by delete} {

  1361     set infotemp {}

  1362     proc foo {} {}

  1363     trace add command foo {rename delete} traceCommand

  1364     rename foo bar

  1365     lappend infotemp $info

  1366     rename bar {}

  1367     lappend infotemp $info

  1368     set info $infotemp

  1369     unset infotemp

  1370     set info

  1371 } {{::foo ::bar rename} {::bar {} delete}}

  1372 catch {rename foo {}}

  1373 catch {rename bar {}}

  1375 test trace-20.5 {trace add command rename and delete} {

  1376     set infotemp {}

  1377     set info {}

  1378     proc foo {} {}

  1379     trace add command foo {rename delete} traceCommand

  1380     rename foo bar

  1381     lappend infotemp $info

  1382     rename bar {}

  1383     lappend infotemp $info

  1384     set info $infotemp

  1385     unset infotemp

  1386     set info

  1387 } {{::foo ::bar rename} {::bar {} delete}}

  1389 test trace-20.6 {trace add command rename and delete in subinterp} {

  1390     set tc [interp create]

  1391     foreach p {traceCommand} {

  1392 	$tc eval [list proc $p [info args $p] [info body $p]]

  1393     }

  1394     $tc eval [list set infotemp {}]

  1395     $tc eval [list set info {}]

  1396     $tc eval [list proc foo {} {}]

  1397     $tc eval [list trace add command foo {rename delete} traceCommand]

  1398     $tc eval [list rename foo bar]

  1399     $tc eval {lappend infotemp $info}

  1400     $tc eval [list rename bar {}]

  1401     $tc eval {lappend infotemp $info}

  1402     $tc eval {set info $infotemp}

  1403     $tc eval [list unset infotemp]

  1404     set info [$tc eval [list set info]]

  1405     interp delete $tc

  1406     set info

  1407 } {{::foo ::bar rename} {::bar {} delete}}

  1409 # I'd like it if this test could give 'foo {} d' as a result,

  1410 # but interp deletion means there is no interp to evaluate

  1411 # the trace in.

  1412 test trace-20.7 {trace add command delete in subinterp while being deleted} {

  1413     set info {}

  1414     set tc [interp create]

  1415     interp alias $tc traceCommand {} traceCommand

  1416     $tc eval [list proc foo {} {}]

  1417     $tc eval [list trace add command foo {rename delete} traceCommand]

  1418     interp delete $tc

  1419     set info

  1420 } {}

  1422 proc traceDelete {cmd old new op} {

  1423     eval trace remove command $cmd [lindex [trace info command $cmd] 0]

  1424     global info

  1425     set info [list $old $new $op]

  1426 }

  1427 proc traceCmdrename {cmd old new op} {

  1428     rename $old someothername

  1429 }

  1430 proc traceCmddelete {cmd old new op} {

  1431     rename $old ""

  1432 }

  1433 test trace-20.8 {trace delete while trace is active} {

  1434     set info {}

  1435     proc foo {} {}

  1436     catch {rename bar {}}

  1437     trace add command foo {rename delete} [list traceDelete foo]

  1438     rename foo bar

  1439     list [set info] [trace info command bar]

  1440 } {{::foo ::bar rename} {}}

  1442 test trace-20.9 {rename trace deletes command} {

  1443     set info {}

  1444     proc foo {} {}

  1445     catch {rename bar {}}

  1446     catch {rename someothername {}}

  1447     trace add command foo rename [list traceCmddelete foo]

  1448     rename foo bar

  1449     list [info commands foo] [info commands bar] [info commands someothername]

  1450 } {{} {} {}}

  1452 test trace-20.10 {rename trace renames command} {

  1453     set info {}

  1454     proc foo {} {}

  1455     catch {rename bar {}}

  1456     catch {rename someothername {}}

  1457     trace add command foo rename [list traceCmdrename foo]

  1458     rename foo bar

  1459     set info [list [info commands foo] [info commands bar] [info commands someothername]]

  1460     rename someothername {}

  1461     set info

  1462 } {{} {} someothername}

  1464 test trace-20.11 {delete trace deletes command} {

  1465     set info {}

  1466     proc foo {} {}

  1467     catch {rename bar {}}

  1468     catch {rename someothername {}}

  1469     trace add command foo delete [list traceCmddelete foo]

  1470     rename foo {}

  1471     list [info commands foo] [info commands bar] [info commands someothername]

  1472 } {{} {} {}}

  1474 test trace-20.12 {delete trace renames command} {

  1475     set info {}

  1476     proc foo {} {}

  1477     catch {rename bar {}}

  1478     catch {rename someothername {}}

  1479     trace add command foo delete [list traceCmdrename foo]

  1480     rename foo bar

  1481     rename bar {}

  1482     # None of these should exist.

  1483     list [info commands foo] [info commands bar] [info commands someothername]

  1484 } {{} {} {}}

  1486 test trace-20.13 {rename trace discards result [Bug 1355342]} {

  1487     proc foo {} {}

  1488     trace add command foo rename {set w Aha!;#}

  1489     list [rename foo bar] [rename bar {}]

  1490 } {{} {}}

  1491 test trace-20.14 {rename trace discards error result [Bug 1355342]} {

  1492     proc foo {} {}

  1493     trace add command foo rename {error}

  1494     list [rename foo bar] [rename bar {}]

  1495 } {{} {}}

  1496 test trace-20.15 {delete trace discards result [Bug 1355342]} {

  1497     proc foo {} {}

  1498     trace add command foo delete {set w Aha!;#}

  1499     rename foo {}

  1500 } {}

  1501 test trace-20.16 {delete trace discards error result [Bug 1355342]} {

  1502     proc foo {} {}

  1503     trace add command foo delete {error}

  1504     rename foo {}

  1505 } {}

  1507 proc foo {b} { set a $b }

  1510 # Delete arrays when done, so they can be re-used as scalars

  1511 # elsewhere.

  1513 catch {unset x}

  1514 catch {unset y}

  1516 # Delete procedures when done, so we don't clash with other tests

  1517 # (e.g. foobar will clash with 'unknown' tests).

  1518 catch {rename foobar {}}

  1519 catch {rename foo {}}

  1520 catch {rename bar {}}

  1522 proc foo {a} {

  1523     set b $a

  1524 }

  1526 proc traceExecute {args} {

  1527     global info

  1528     lappend info $args

  1529 }

  1531 test trace-21.1 {trace execution: enter} {

  1532     set info {}

  1533     trace add execution foo enter [list traceExecute foo]

  1534     foo 1

  1535     trace remove execution foo enter [list traceExecute foo]

  1536     set info

  1537 } {{foo {foo 1} enter}}

  1539 test trace-21.2 {trace exeuction: leave} {

  1540     set info {}

  1541     trace add execution foo leave [list traceExecute foo]

  1542     foo 2

  1543     trace remove execution foo leave [list traceExecute foo]

  1544     set info

  1545 } {{foo {foo 2} 0 2 leave}}

  1547 test trace-21.3 {trace exeuction: enter, leave} {

  1548     set info {}

  1549     trace add execution foo {enter leave} [list traceExecute foo]

  1550     foo 3

  1551     trace remove execution foo {enter leave} [list traceExecute foo]

  1552     set info

  1553 } {{foo {foo 3} enter} {foo {foo 3} 0 3 leave}}

  1555 test trace-21.4 {trace execution: enter, leave, enterstep} {

  1556     set info {}

  1557     trace add execution foo {enter leave enterstep} [list traceExecute foo]

  1558     foo 3

  1559     trace remove execution foo {enter leave enterstep} [list traceExecute foo]

  1560     set info

  1561 } {{foo {foo 3} enter} {foo {set b 3} enterstep} {foo {foo 3} 0 3 leave}}

  1563 test trace-21.5 {trace execution: enter, leave, enterstep, leavestep} {

  1564     set info {}

  1565     trace add execution foo {enter leave enterstep leavestep} [list traceExecute foo]

  1566     foo 3

  1567     trace remove execution foo {enter leave enterstep leavestep} [list traceExecute foo]

  1568     set info

  1569 } {{foo {foo 3} enter} {foo {set b 3} enterstep} {foo {set b 3} 0 3 leavestep} {foo {foo 3} 0 3 leave}}

  1571 test trace-21.6 {trace execution: enterstep, leavestep} {

  1572     set info {}

  1573     trace add execution foo {enterstep leavestep} [list traceExecute foo]

  1574     foo 3

  1575     trace remove execution foo {enterstep leavestep} [list traceExecute foo]

  1576     set info

  1577 } {{foo {set b 3} enterstep} {foo {set b 3} 0 3 leavestep}}

  1579 test trace-21.7 {trace execution: enterstep} {

  1580     set info {}

  1581     trace add execution foo {enterstep} [list traceExecute foo]

  1582     foo 3

  1583     trace remove execution foo {enterstep} [list traceExecute foo]

  1584     set info

  1585 } {{foo {set b 3} enterstep}}

  1587 test trace-21.8 {trace execution: leavestep} {

  1588     set info {}

  1589     trace add execution foo {leavestep} [list traceExecute foo]

  1590     foo 3

  1591     trace remove execution foo {leavestep} [list traceExecute foo]

  1592     set info

  1593 } {{foo {set b 3} 0 3 leavestep}}

  1595 test trace-21.9 {trace execution: TCL_EVAL_GLOBAL} testevalobjv {

  1596     trace add execution foo enter soom

  1597     proc ::soom args {lappend ::info SUCCESS [info level]}

  1598     set ::info {}

  1599     namespace eval test_ns_1 {

  1600         proc soom args {lappend ::info FAIL [info level]}

  1601         # [testevalobjv 1 ...] ought to produce the same

  1602 	# results as [uplevel #0 ...].

  1603         testevalobjv 1 foo x

  1604 	uplevel #0 foo x

  1605     }

  1606     namespace delete test_ns_1

  1607     trace remove execution foo enter soom

  1608     set ::info

  1609 } {SUCCESS 1 SUCCESS 1}

  1611 test trace-21.10 {trace execution: TCL_EVAL_GLOBAL} testevalobjv {

  1612     trace add execution foo leave soom

  1613     proc ::soom args {lappend ::info SUCCESS [info level]}

  1614     set ::info {}

  1615     namespace eval test_ns_1 {

  1616         proc soom args {lappend ::info FAIL [info level]}

  1617         # [testevalobjv 1 ...] ought to produce the same

  1618 	# results as [uplevel #0 ...].

  1619         testevalobjv 1 foo x

  1620 	uplevel #0 foo x

  1621     }

  1622     namespace delete test_ns_1

  1623     trace remove execution foo leave soom

  1624     set ::info

  1625 } {SUCCESS 1 SUCCESS 1}

  1627 test trace-21.11 {trace execution and alias} -setup {

  1628     set res {}

  1629     proc ::x {} {return ::}

  1630     namespace eval a {}

  1631     proc ::a::x {} {return ::a}

  1632     interp alias {} y {} x

  1633 } -body {

  1634     lappend res [namespace eval ::a y]

  1635     trace add execution ::x enter {

  1636       rename ::x {}

  1637 	proc ::x {} {return ::}

  1638     #}

  1639     lappend res [namespace eval ::a y]

  1640 } -cleanup {

  1641     namespace delete a

  1642     rename ::x {}

  1643 } -result {:: ::}

  1645 proc factorial {n} {

  1646     if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }

  1647     return 1

  1648 }

  1650 test trace-22.1 {recursive(1) trace execution: enter} {

  1651     set info {}

  1652     trace add execution factorial {enter} [list traceExecute factorial]

  1653     factorial 1

  1654     trace remove execution factorial {enter} [list traceExecute factorial]

  1655     set info

  1656 } {{factorial {factorial 1} enter}}

  1658 test trace-22.2 {recursive(2) trace execution: enter} {

  1659     set info {}

  1660     trace add execution factorial {enter} [list traceExecute factorial]

  1661     factorial 2

  1662     trace remove execution factorial {enter} [list traceExecute factorial]

  1663     set info

  1664 } {{factorial {factorial 2} enter} {factorial {factorial 1} enter}}

  1666 test trace-22.3 {recursive(3) trace execution: enter} {

  1667     set info {}

  1668     trace add execution factorial {enter} [list traceExecute factorial]

  1669     factorial 3

  1670     trace remove execution factorial {enter} [list traceExecute factorial]

  1671     set info

  1672 } {{factorial {factorial 3} enter} {factorial {factorial 2} enter} {factorial {factorial 1} enter}}

  1674 test trace-23.1 {recursive(1) trace execution: enter, leave, enterstep, leavestep} {

  1675     set info {}

  1676     trace add execution factorial {enter leave enterstep leavestep} [list traceExecute]

  1677     factorial 1

  1678     trace remove execution factorial {enter leave enterstep leavestep} [list traceExecute]

  1679     join $info "\n"

  1680 } {{factorial 1} enter

  1681 {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep

  1682 {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 0 {} leavestep

  1683 {return 1} enterstep

  1684 {return 1} 2 1 leavestep

  1685 {factorial 1} 0 1 leave}

  1687 test trace-23.2 {recursive(2) trace execution: enter, leave, enterstep, leavestep} {

  1688     set info {}

  1689     trace add execution factorial {enter leave enterstep leavestep} [list traceExecute]

  1690     factorial 2

  1691     trace remove execution factorial {enter leave enterstep leavestep} [list traceExecute]

  1692     join $info "\n"

  1693 } {{factorial 2} enter

  1694 {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep

  1695 {expr {$n * [factorial [expr {$n -1 }]]}} enterstep

  1696 {expr {$n -1 }} enterstep

  1697 {expr {$n -1 }} 0 1 leavestep

  1698 {factorial 1} enterstep

  1699 {factorial 1} enter

  1700 {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep

  1701 {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 0 {} leavestep

  1702 {return 1} enterstep

  1703 {return 1} 2 1 leavestep

  1704 {factorial 1} 0 1 leave

  1705 {factorial 1} 0 1 leavestep

  1706 {expr {$n * [factorial [expr {$n -1 }]]}} 0 2 leavestep

  1707 {return 2} enterstep

  1708 {return 2} 2 2 leavestep

  1709 {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 2 2 leavestep

  1710 {factorial 2} 0 2 leave}

  1712 test trace-23.3 {recursive(3) trace execution: enter, leave, enterstep, leavestep} {

  1713     set info {}

  1714     trace add execution factorial {enter leave enterstep leavestep} [list traceExecute]

  1715     factorial 3

  1716     trace remove execution factorial {enter leave enterstep leavestep} [list traceExecute]

  1717     join $info "\n"

  1718 } {{factorial 3} enter

  1719 {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep

  1720 {expr {$n * [factorial [expr {$n -1 }]]}} enterstep

  1721 {expr {$n -1 }} enterstep

  1722 {expr {$n -1 }} 0 2 leavestep

  1723 {factorial 2} enterstep

  1724 {factorial 2} enter

  1725 {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep

  1726 {expr {$n * [factorial [expr {$n -1 }]]}} enterstep

  1727 {expr {$n -1 }} enterstep

  1728 {expr {$n -1 }} 0 1 leavestep

  1729 {factorial 1} enterstep

  1730 {factorial 1} enter

  1731 {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep

  1732 {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 0 {} leavestep

  1733 {return 1} enterstep

  1734 {return 1} 2 1 leavestep

  1735 {factorial 1} 0 1 leave

  1736 {factorial 1} 0 1 leavestep

  1737 {expr {$n * [factorial [expr {$n -1 }]]}} 0 2 leavestep

  1738 {return 2} enterstep

  1739 {return 2} 2 2 leavestep

  1740 {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 2 2 leavestep

  1741 {factorial 2} 0 2 leave

  1742 {factorial 2} 0 2 leavestep

  1743 {expr {$n * [factorial [expr {$n -1 }]]}} 0 6 leavestep

  1744 {return 6} enterstep

  1745 {return 6} 2 6 leavestep

  1746 {if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 2 6 leavestep

  1747 {factorial 3} 0 6 leave}

  1749 proc traceDelete {cmd args} {

  1750     eval trace remove execution $cmd [lindex [trace info execution $cmd] 0]

  1751     global info

  1752     set info $args

  1753 }

  1755 test trace-24.1 {delete trace during enter trace} {

  1756     set info {}

  1757     trace add execution foo enter [list traceDelete foo]

  1758     foo 1

  1759     list $info [catch {trace info execution foo} res] $res

  1760 } {{{foo 1} enter} 0 {}}

  1762 test trace-24.2 {delete trace during leave trace} {

  1763     set info {}

  1764     trace add execution foo leave [list traceDelete foo]

  1765     foo 1

  1766     list $info [catch {trace info execution foo} res] $res

  1767 } {{{foo 1} 0 1 leave} 0 {}}

  1769 test trace-24.3 {delete trace during enter-leave trace} {

  1770     set info {}

  1771     trace add execution foo {enter leave} [list traceDelete foo]

  1772     foo 1

  1773     list $info [catch {trace info execution foo} res] $res

  1774 } {{{foo 1} enter} 0 {}}

  1776 test trace-24.4 {delete trace during all exec traces} {

  1777     set info {}

  1778     trace add execution foo {enter leave enterstep leavestep} [list traceDelete foo]

  1779     foo 1

  1780     list $info [catch {trace info execution foo} res] $res

  1781 } {{{foo 1} enter} 0 {}}

  1783 test trace-24.5 {delete trace during all exec traces except enter} {

  1784     set info {}

  1785     trace add execution foo {leave enterstep leavestep} [list traceDelete foo]

  1786     foo 1

  1787     list $info [catch {trace info execution foo} res] $res

  1788 } {{{set b 1} enterstep} 0 {}}

  1790 proc traceDelete {cmd args} {

  1791     rename $cmd {}

  1792     global info

  1793     set info $args

  1794 }

  1796 proc foo {a} {

  1797     set b $a

  1798 }

  1800 test trace-25.1 {delete command during enter trace} {

  1801     set info {}

  1802     trace add execution foo enter [list traceDelete foo]

  1803     catch {foo 1} err

  1804     list $err $info [catch {trace info execution foo} res] $res

  1805 } {{invalid command name "foo"} {{foo 1} enter} 1 {unknown command "foo"}}

  1807 proc foo {a} {

  1808     set b $a

  1809 }

  1811 test trace-25.2 {delete command during leave trace} {

  1812     set info {}

  1813     trace add execution foo leave [list traceDelete foo]

  1814     foo 1

  1815     list $info [catch {trace info execution foo} res] $res

  1816 } {{{foo 1} 0 1 leave} 1 {unknown command "foo"}}

  1818 proc foo {a} {

  1819     set b $a

  1820 }

  1822 test trace-25.3 {delete command during enter then leave trace} {

  1823     set info {}

  1824     trace add execution foo enter [list traceDelete foo]

  1825     trace add execution foo leave [list traceDelete foo]

  1826     catch {foo 1} err

  1827     list $err $info [catch {trace info execution foo} res] $res

  1828 } {{invalid command name "foo"} {{foo 1} enter} 1 {unknown command "foo"}}

  1830 proc foo {a} {

  1831     set b $a

  1832 }

  1833 proc traceExecute2 {args} {

  1834     global info

  1835     lappend info $args

  1836 }

  1838 # This shows the peculiar consequences of having two traces

  1839 # at the same time: as well as tracing the procedure you want

  1840 test trace-25.4 {order dependencies of two enter traces} {

  1841     set info {}

  1842     trace add execution foo enter [list traceExecute traceExecute]

  1843     trace add execution foo enter [list traceExecute2 traceExecute2]

  1844     catch {foo 1} err

  1845     trace remove execution foo enter [list traceExecute traceExecute]

  1846     trace remove execution foo enter [list traceExecute2 traceExecute2]

  1847     join [list $err [join $info \n] [trace info execution foo]] "\n"

  1848 } {1

  1849 traceExecute2 {foo 1} enter

  1850 traceExecute {foo 1} enter

  1851 }

  1853 test trace-25.5 {order dependencies of two step traces} {

  1854     set info {}

  1855     trace add execution foo enterstep [list traceExecute traceExecute]

  1856     trace add execution foo enterstep [list traceExecute2 traceExecute2]

  1857     catch {foo 1} err

  1858     trace remove execution foo enterstep [list traceExecute traceExecute]

  1859     trace remove execution foo enterstep [list traceExecute2 traceExecute2]

  1860     join [list $err [join $info \n] [trace info execution foo]] "\n"

  1861 } {1

  1862 traceExecute2 {set b 1} enterstep

  1863 traceExecute {set b 1} enterstep

  1864 }

  1866 # We don't want the result string (5th argument), or the results

  1867 # will get unmanageable.

  1868 proc tracePostExecute {args} {

  1869     global info

  1870     lappend info [concat [lrange $args 0 2] [lindex $args 4]]

  1871 }

  1872 proc tracePostExecute2 {args} {

  1873     global info

  1874     lappend info [concat [lrange $args 0 2] [lindex $args 4]]

  1875 }

  1877 test trace-25.6 {order dependencies of two leave traces} {

  1878     set info {}

  1879     trace add execution foo leave [list tracePostExecute tracePostExecute]

  1880     trace add execution foo leave [list tracePostExecute2 tracePostExecute2]

  1881     catch {foo 1} err

  1882     trace remove execution foo leave [list tracePostExecute tracePostExecute]

  1883     trace remove execution foo leave [list tracePostExecute2 tracePostExecute2]

  1884     join [list $err [join $info \n] [trace info execution foo]] "\n"

  1885 } {1

  1886 tracePostExecute {foo 1} 0 leave

  1887 tracePostExecute2 {foo 1} 0 leave

  1888 }

  1890 test trace-25.7 {order dependencies of two leavestep traces} {

  1891     set info {}

  1892     trace add execution foo leavestep [list tracePostExecute tracePostExecute]

  1893     trace add execution foo leavestep [list tracePostExecute2 tracePostExecute2]

  1894     catch {foo 1} err

  1895     trace remove execution foo leavestep [list tracePostExecute tracePostExecute]

  1896     trace remove execution foo leavestep [list tracePostExecute2 tracePostExecute2]

  1897     join [list $err [join $info \n] [trace info execution foo]] "\n"

  1898 } {1

  1899 tracePostExecute {set b 1} 0 leavestep

  1900 tracePostExecute2 {set b 1} 0 leavestep

  1901 }

  1903 proc foo {a} {

  1904     set b $a

  1905 }

  1907 proc traceDelete {cmd args} {

  1908     rename $cmd {}

  1909     global info

  1910     set info $args

  1911 }

  1913 test trace-25.8 {delete command during enter leave and enter/leave-step traces} {

  1914     set info {}

  1915     trace add execution foo enter [list traceDelete foo]

  1916     trace add execution foo leave [list traceDelete foo]

  1917     trace add execution foo enterstep [list traceDelete foo]

  1918     trace add execution foo leavestep [list traceDelete foo]

  1919     catch {foo 1} err

  1920     list $err $info [catch {trace info execution foo} res] $res

  1921 } {{invalid command name "foo"} {{foo 1} enter} 1 {unknown command "foo"}}

  1923 proc foo {a} {

  1924     set b $a

  1925 }

  1927 test trace-25.9 {delete command during enter leave and leavestep traces} {

  1928     set info {}

  1929     trace add execution foo enter [list traceDelete foo]

  1930     trace add execution foo leave [list traceDelete foo]

  1931     trace add execution foo leavestep [list traceDelete foo]

  1932     catch {foo 1} err

  1933     list $err $info [catch {trace info execution foo} res] $res

  1934 } {{invalid command name "foo"} {{foo 1} enter} 1 {unknown command "foo"}}

  1936 proc foo {a} {

  1937     set b $a

  1938 }

  1940 test trace-25.10 {delete command during leave and leavestep traces} {

  1941     set info {}

  1942     trace add execution foo leave [list traceDelete foo]

  1943     trace add execution foo leavestep [list traceDelete foo]

  1944     catch {foo 1} err

  1945     list $err $info [catch {trace info execution foo} res] $res

  1946 } {1 {{set b 1} 0 1 leavestep} 1 {unknown command "foo"}}

  1948 proc foo {a} {

  1949     set b $a

  1950 }

  1952 test trace-25.11 {delete command during enter and enterstep traces} {

  1953     set info {}

  1954     trace add execution foo enter [list traceDelete foo]

  1955     trace add execution foo enterstep [list traceDelete foo]

  1956     catch {foo 1} err

  1957     list $err $info [catch {trace info execution foo} res] $res

  1958 } {{invalid command name "foo"} {{foo 1} enter} 1 {unknown command "foo"}}

  1960 test trace-26.1 {trace targetCmd when invoked through an alias} {

  1961     proc foo {args} {

  1962 	set b $args

  1963     }

  1964     set info {}

  1965     trace add execution foo enter [list traceExecute foo]

  1966     interp alias {} bar {} foo 1

  1967     bar 2

  1968     trace remove execution foo enter [list traceExecute foo]

  1969     set info

  1970 } {{foo {foo 1 2} enter}}

  1971 test trace-26.2 {trace targetCmd when invoked through an alias} {

  1972     proc foo {args} {

  1973 	set b $args

  1974     }

  1975     set info {}

  1976     trace add execution foo enter [list traceExecute foo]

  1977     interp create child

  1978     interp alias child bar {} foo 1

  1979     child eval bar 2

  1980     interp delete child

  1981     trace remove execution foo enter [list traceExecute foo]

  1982     set info

  1983 } {{foo {foo 1 2} enter}}

  1985 test trace-27.1 {memory leak in rename trace (604609)} {

  1986     catch {rename bar {}}

  1987     proc foo {} {error foo}

  1988     trace add command foo rename {rename foo "" ;#}

  1989     rename foo bar

  1990     info commands foo

  1991 } {}

  1993 test trace-27.2 {command trace remove nonsense} {

  1994     list [catch {trace remove command thisdoesntexist \

  1995       {delete rename} bar} res] $res

  1996 } {1 {unknown command "thisdoesntexist"}}

  1998 test trace-27.3 {command trace info nonsense} {

  1999     list [catch {trace info command thisdoesntexist} res] $res

  2000 } {1 {unknown command "thisdoesntexist"}}

  2003 test trace-28.1 {enterstep and leavestep traces with update idletasks (615043)} {

  2004     catch {rename foo {}}

  2005     proc foo {} {

  2006         set a 1

  2007         update idletasks

  2008         set b 1

  2009     }

  2011     set info {}

  2012     trace add execution foo {enter enterstep leavestep leave} \

  2013         [list traceExecute foo]

  2014     update

  2015     after idle {set a "idle"}

  2016     foo

  2018     trace remove execution foo {enter enterstep leavestep leave} \

  2019         [list traceExecute foo]

  2020     rename foo {}

  2021     catch {unset a}

  2022     join $info "\n"

  2023 } {foo foo enter

  2024 foo {set a 1} enterstep

  2025 foo {set a 1} 0 1 leavestep

  2026 foo {update idletasks} enterstep

  2027 foo {set a idle} enterstep

  2028 foo {set a idle} 0 idle leavestep

  2029 foo {update idletasks} 0 {} leavestep

  2030 foo {set b 1} enterstep

  2031 foo {set b 1} 0 1 leavestep

  2032 foo foo 0 1 leave}

  2034 test trace-28.2 {exec traces with 'error'} {

  2035     set info {}

  2036     set res {}

  2038     proc foo {} {

  2039 	if {[catch {bar}]} {

  2040 	    return "error"

  2041 	} else {

  2042 	    return "ok"

  2043 	}

  2044     }

  2046     proc bar {} { error "msg" }

  2048     lappend res [foo]

  2050     trace add execution foo {enter enterstep leave leavestep} \

  2051       [list traceExecute foo]

  2053     # With the trace active

  2055     lappend res [foo]

  2057     trace remove execution foo {enter enterstep leave leavestep} \

  2058       [list traceExecute foo]

  2060     list $res [join $info \n]

  2061 } {{error error} {foo foo enter

  2062 foo {if {[catch {bar}]} {

  2063 	    return "error"

  2064 	} else {

  2065 	    return "ok"

  2066 	}} enterstep

  2067 foo {catch bar} enterstep

  2068 foo bar enterstep

  2069 foo {error msg} enterstep

  2070 foo {error msg} 1 msg leavestep

  2071 foo bar 1 msg leavestep

  2072 foo {catch bar} 0 1 leavestep

  2073 foo {return error} enterstep

  2074 foo {return error} 2 error leavestep

  2075 foo {if {[catch {bar}]} {

  2076 	    return "error"

  2077 	} else {

  2078 	    return "ok"

  2079 	}} 2 error leavestep

  2080 foo foo 0 error leave}}

  2082 test trace-28.3 {exec traces with 'return -code error'} {

  2083     set info {}

  2084     set res {}

  2086     proc foo {} {

  2087 	if {[catch {bar}]} {

  2088 	    return "error"

  2089 	} else {

  2090 	    return "ok"

  2091 	}

  2092     }

  2094     proc bar {} { return -code error "msg" }

  2096     lappend res [foo]

  2098     trace add execution foo {enter enterstep leave leavestep} \

  2099       [list traceExecute foo]

  2101     # With the trace active

  2103     lappend res [foo]

  2105     trace remove execution foo {enter enterstep leave leavestep} \

  2106       [list traceExecute foo]

  2108     list $res [join $info \n]

  2109 } {{error error} {foo foo enter

  2110 foo {if {[catch {bar}]} {

  2111 	    return "error"

  2112 	} else {

  2113 	    return "ok"

  2114 	}} enterstep

  2115 foo {catch bar} enterstep

  2116 foo bar enterstep

  2117 foo {return -code error msg} enterstep

  2118 foo {return -code error msg} 2 msg leavestep

  2119 foo bar 1 msg leavestep

  2120 foo {catch bar} 0 1 leavestep

  2121 foo {return error} enterstep

  2122 foo {return error} 2 error leavestep

  2123 foo {if {[catch {bar}]} {

  2124 	    return "error"

  2125 	} else {

  2126 	    return "ok"

  2127 	}} 2 error leavestep

  2128 foo foo 0 error leave}}

  2130 test trace-28.4 {exec traces in slave with 'return -code error'} {

  2131     interp create slave

  2132     interp alias slave traceExecute {} traceExecute

  2133     set info {}

  2134     set res [interp eval slave {

  2135 	set info {}

  2136 	set res {}

  2138 	proc foo {} {

  2139 	    if {[catch {bar}]} {

  2140 		return "error"

  2141 	    } else {

  2142 		return "ok"

  2143 	    }

  2144 	}

  2146 	proc bar {} { return -code error "msg" }

  2148 	lappend res [foo]

  2150 	trace add execution foo {enter enterstep leave leavestep} \

  2151 	  [list traceExecute foo]

  2153 	# With the trace active

  2155 	lappend res [foo]

  2157 	trace remove execution foo {enter enterstep leave leavestep} \

  2158 	  [list traceExecute foo]

  2160 	list $res

  2161     }]

  2162     interp delete slave

  2163     lappend res [join $info \n]

  2164 } {{error error} {foo foo enter

  2165 foo {if {[catch {bar}]} {

  2166 		return "error"

  2167 	    } else {

  2168 		return "ok"

  2169 	    }} enterstep

  2170 foo {catch bar} enterstep

  2171 foo bar enterstep

  2172 foo {return -code error msg} enterstep

  2173 foo {return -code error msg} 2 msg leavestep

  2174 foo bar 1 msg leavestep

  2175 foo {catch bar} 0 1 leavestep

  2176 foo {return error} enterstep

  2177 foo {return error} 2 error leavestep

  2178 foo {if {[catch {bar}]} {

  2179 		return "error"

  2180 	    } else {

  2181 		return "ok"

  2182 	    }} 2 error leavestep

  2183 foo foo 0 error leave}}

  2185 test trace-28.5 {exec traces} {

  2186     set info {}

  2187     proc foo {args} { set a 1 }

  2188     trace add execution foo {enter enterstep leave leavestep} \

  2189       [list traceExecute foo]

  2190     after idle [list foo test-28.4]

  2191     update

  2192     # Complicated way of removing traces

  2193     set ti [lindex [eval [list trace info execution ::foo]] 0]

  2194     if {[llength $ti]} {

  2195 	eval [concat [list trace remove execution foo] $ti]

  2196     }

  2197     join $info \n

  2198 } {foo {foo test-28.4} enter

  2199 foo {set a 1} enterstep

  2200 foo {set a 1} 0 1 leavestep

  2201 foo {foo test-28.4} 0 1 leave}

  2203 test trace-28.6 {exec traces firing order} {

  2204     set info {}

  2205     proc enterStep {cmd op} {lappend ::info "enter $cmd/$op"}

  2206     proc leaveStep {cmd code result op} {lappend ::info "leave $cmd/$code/$result/$op"}

  2208     proc foo x {

  2209 	set b x=$x

  2210 	incr x

  2211     }

  2212     trace add execution foo enterstep enterStep

  2213     trace add execution foo leavestep leaveStep

  2214     foo 42

  2215     rename foo {}

  2216     join $info \n

  2217 } {enter set b x=42/enterstep

  2218 leave set b x=42/0/x=42/leavestep

  2219 enter incr x/enterstep

  2220 leave incr x/0/43/leavestep}

  2222 test trace-28.7 {exec trace information} {

  2223     set info {}

  2224     proc foo x { incr x }

  2225     proc bar {args} {}

  2226     trace add execution foo {enter leave enterstep leavestep} bar

  2227     set info [trace info execution foo]

  2228     trace remove execution foo {enter leave enterstep leavestep} bar

  2229 } {}

  2231 test trace-28.8 {exec trace remove nonsense} {

  2232     list [catch {trace remove execution thisdoesntexist \

  2233       {enter leave enterstep leavestep} bar} res] $res

  2234 } {1 {unknown command "thisdoesntexist"}}

  2236 test trace-28.9 {exec trace info nonsense} {

  2237     list [catch {trace info execution thisdoesntexist} res] $res

  2238 } {1 {unknown command "thisdoesntexist"}}

  2240 test trace-28.10 {exec trace info nonsense} {

  2241     list [catch {trace remove execution} res] $res

  2242 } {1 {wrong # args: should be "trace remove execution name opList command"}}

  2244 # Missing test number to keep in sync with the 8.5 branch

  2245 # (want to backport those tests?)

  2247 test trace-31.1 {command and execution traces shared struct} {

  2248     # Tcl Bug 807243

  2249     proc foo {} {}

  2250     trace add command foo delete foo

  2251     trace add execution foo enter foo

  2252     set result [trace info command foo]

  2253     trace remove command foo delete foo

  2254     trace remove execution foo enter foo

  2255     rename foo {}

  2256     set result

  2257 } [list [list delete foo]]

  2258 test trace-31.2 {command and execution traces shared struct} {

  2259     # Tcl Bug 807243

  2260     proc foo {} {}

  2261     trace add command foo delete foo

  2262     trace add execution foo enter foo

  2263     set result [trace info execution foo]

  2264     trace remove command foo delete foo

  2265     trace remove execution foo enter foo

  2266     rename foo {}

  2267     set result

  2268 } [list [list enter foo]]

  2270 test trace-32.1 {

  2271     TraceCommandInfo refcount decr in TraceCommandProc w/o loss of reference

  2272 } {

  2273     # Tcl Bug 811483

  2274     proc foo {} {}

  2275     trace add command foo delete foo

  2276     trace add execution foo enter foo

  2277     set result [trace info command foo]

  2278     rename foo {}

  2279     set result

  2280 } [list [list delete foo]]

  2282 test trace-33.1 {variable match with remove variable} {

  2283     unset -nocomplain x

  2284     trace variable x w foo

  2285     trace remove variable x write foo

  2286     llength [trace info variable x]

  2287 } 0

  2289 test trace-34.1 {Bug 1201035} {

  2290     set ::x [list]

  2291     proc foo {} {lappend ::x foo}

  2292     proc bar args {

  2293 	lappend ::x $args

  2294 	trace remove execution foo leavestep bar

  2295 	trace remove execution foo enterstep bar

  2296 	trace add execution foo leavestep bar

  2297 	trace add execution foo enterstep bar

  2298 	lappend ::x done

  2299     }

  2300     trace add execution foo leavestep bar

  2301     trace add execution foo enterstep bar

  2302     foo

  2303     set ::x

  2304 } {{{lappend ::x foo} enterstep} done foo}

  2306 test trace-34.2 {Bug 1224585} {

  2307     proc foo {} {}

  2308     proc bar args {trace remove execution foo leave soom}

  2309     trace add execution foo leave bar

  2310     trace add execution foo leave soom

  2311     foo

  2312 } {}

  2314 test trace-34.3 {Bug 1224585} {

  2315     proc foo {} {set x {}}

  2316     proc bar args {trace remove execution foo enterstep soom}

  2317     trace add execution foo enterstep soom

  2318     trace add execution foo enterstep bar

  2319     foo

  2320 } {}

  2322 # We test here for the half-documented and currently valid interplay between

  2323 # delete traces and namespace deletion.

  2324 test trace-34.4 {Bug 1047286} {

  2325     variable x notrace

  2326     proc callback {old - -} {

  2327         variable x "$old exists: [namespace which -command $old]"

  2328     }

  2329     namespace eval ::foo {proc bar {} {}}

  2330     trace add command ::foo::bar delete [namespace code callback]

  2331     namespace delete ::foo

  2332     set x

  2333 } {::foo::bar exists: ::foo::bar}

  2335 test trace-34.5 {Bug 1047286} {

  2336     variable x notrace

  2337     proc callback {old - -} {

  2338         variable x "$old exists: [namespace which -command $old]"

  2339     }

  2340     namespace eval ::foo {proc bar {} {}}

  2341     trace add command ::foo::bar delete [namespace code callback]

  2342     namespace eval ::foo namespace delete ::foo

  2343     set x

  2344 } {::foo::bar exists: }

  2346 test trace-34.6 {Bug 1458266} -setup {

  2347     proc dummy {} {}

  2348     proc stepTraceHandler {cmdString args} {

  2349 	variable log

  2350 	append log "[expr {[info level] - 1}]: [lindex [split $cmdString] 0]\n"

  2351 	dummy

  2352 	isTracedInside_2

  2353     }

  2354     proc cmdTraceHandler {cmdString args} {

  2355 	# silent

  2356     }

  2357     proc isTracedInside_1 {} {

  2358 	isTracedInside_2

  2359     }

  2360     proc isTracedInside_2 {} {

  2361 	set x 2

  2362     }

  2363 } -body {

  2364     variable log {}

  2365     trace add execution isTracedInside_1 enterstep stepTraceHandler

  2366     trace add execution isTracedInside_2 enterstep stepTraceHandler

  2367     isTracedInside_1

  2368     variable first $log

  2369     set log {}

  2370     trace add execution dummy enter cmdTraceHandler

  2371     isTracedInside_1

  2372     variable second $log

  2373     expr {($first eq $second) ? "ok" : "\n$first\nand\n\n$second\ndiffer"}

  2374 } -cleanup {

  2375     unset -nocomplain log first second

  2376     rename dummy {}

  2377     rename stepTraceHandler {}

  2378     rename cmdTraceHandler {}

  2379     rename isTracedInside_1 {}

  2380     rename isTracedInside_2 {}

  2381 } -result ok

  2383 # Delete procedures when done, so we don't clash with other tests

  2384 # (e.g. foobar will clash with 'unknown' tests).

  2385 catch {rename foobar {}}

  2386 catch {rename foo {}}

  2387 catch {rename bar {}}

  2389 # Unset the varaible when done

  2390 catch {unset info}

  2392 # cleanup

  2393 ::tcltest::cleanupTests

  2394 return

author	sl
	Tue, 10 Jun 2014 14:32:02 +0200
changeset 1	260cb5ec6c19
permissions	-rw-r--r--