path: root/tests/trace.test

# Commands covered:  trace
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: trace.test,v 1.13 2001/11/21 17:37:49 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

proc traceScalar {name1 name2 op} {
    global info
    set info [list $name1 $name2 $op [catch {uplevel set $name1} msg] $msg]
}
proc traceScalarAppend {name1 name2 op} {
    global info
    lappend info $name1 $name2 $op [catch {uplevel set $name1} msg] $msg
}
proc traceArray {name1 name2 op} {
    global info
    set info [list $name1 $name2 $op [catch {uplevel set [set name1]($name2)} msg] $msg]
}
proc traceArray2 {name1 name2 op} {
    global info
    set info [list $name1 $name2 $op]
}
proc traceProc {name1 name2 op} {
    global info
    set info [concat $info [list $name1 $name2 $op]]
}
proc traceTag {tag args} {
    global info
    set info [concat $info $tag]
}
proc traceError {args} {
    error "trace returned error"
}
proc traceCheck {cmd args} {
    global info
    set info [list [catch $cmd msg] $msg]
}
proc traceCrtElement {value name1 name2 op} {
    uplevel set ${name1}($name2) $value
}
proc traceCommand {oldName newName op} {
    global info
    set info [list $oldName $newName $op]
}
# Read-tracing on variables

test trace-1.1 {trace variable reads} {
    catch {unset x}
    set info {}
    trace add variable x read traceScalar
    list [catch {set x} msg] $msg $info
} {1 {can't read "x": no such variable} {x {} read 1 {can't read "x": no such variable}}}
test trace-1.2 {trace variable reads} {
    catch {unset x}
    set x 123
    set info {}
    trace add variable x read traceScalar
    list [catch {set x} msg] $msg $info
} {0 123 {x {} read 0 123}}
test trace-1.3 {trace variable reads} {
    catch {unset x}
    set info {}
    trace add variable x read traceScalar
    set x 123
    set info
} {}
test trace-1.4 {trace array element reads} {
    catch {unset x}
    set info {}
    trace add variable x(2) read traceArray
    list [catch {set x(2)} msg] $msg $info
} {1 {can't read "x(2)": no such element in array} {x 2 read 1 {can't read "x(2)": no such element in array}}}
test trace-1.5 {trace array element reads} {
    catch {unset x}
    set x(2) zzz
    set info {}
    trace add variable x(2) read traceArray
    list [catch {set x(2)} msg] $msg $info
} {0 zzz {x 2 read 0 zzz}}
test trace-1.6 {trace array element reads} {
    catch {unset x}
    set info {}
    trace add variable x read traceArray2
    proc p {} {
        global x
        set x(2) willi
        return $x(2)
    }
    list [catch {p} msg] $msg $info
} {0 willi {x 2 read}}
test trace-1.7 {trace array element reads, create element undefined if nonexistant} {
    catch {unset x}
    set info {}
    trace add variable x read q
    proc q {name1 name2 op} {
        global info
        set info [list $name1 $name2 $op]
        global $name1
        set ${name1}($name2) wolf
    }
    proc p {} {
        global x
        set x(X) willi
        return $x(Y)
    }
    list [catch {p} msg] $msg $info
} {0 wolf {x Y read}}
test trace-1.8 {trace reads on whole arrays} {
    catch {unset x}
    set info {}
    trace add variable x read traceArray
    list [catch {set x(2)} msg] $msg $info
} {1 {can't read "x(2)": no such variable} {}}
test trace-1.9 {trace reads on whole arrays} {
    catch {unset x}
    set x(2) zzz
    set info {}
    trace add variable x read traceArray
    list [catch {set x(2)} msg] $msg $info
} {0 zzz {x 2 read 0 zzz}}
test trace-1.10 {trace variable reads} {
    catch {unset x}
    set x 444
    set info {}
    trace add variable x read traceScalar
    unset x
    set info
} {}

# Basic write-tracing on variables

test trace-2.1 {trace variable writes} {
    catch {unset x}
    set info {}
    trace add variable x write traceScalar
    set x 123
    set info
} {x {} write 0 123}
test trace-2.2 {trace writes to array elements} {
    catch {unset x}
    set info {}
    trace add variable x(33) write traceArray
    set x(33) 444
    set info
} {x 33 write 0 444}
test trace-2.3 {trace writes on whole arrays} {
    catch {unset x}
    set info {}
    trace add variable x write traceArray
    set x(abc) qq
    set info
} {x abc write 0 qq}
test trace-2.4 {trace variable writes} {
    catch {unset x}
    set x 1234
    set info {}
    trace add variable x write traceScalar
    set x
    set info
} {}
test trace-2.5 {trace variable writes} {
    catch {unset x}
    set x 1234
    set info {}
    trace add variable x write traceScalar
    unset x
    set info
} {}

# append no longer triggers read traces when fetching the old values of
# variables before doing the append operation. However, lappend _does_
# still trigger these read traces. Also lappend triggers only one write
# trace: after appending all arguments to the list.

test trace-3.1 {trace variable read-modify-writes} {
    catch {unset x}
    set info {}
    trace add variable x read traceScalarAppend
    append x 123
    append x 456
    lappend x 789
    set info
} {x {} read 0 123456}
test trace-3.2 {trace variable read-modify-writes} {
    catch {unset x}
    set info {}
    trace add variable x {read write} traceScalarAppend
    append x 123
    lappend x 456
    set info
} {x {} write 0 123 x {} read 0 123 x {} write 0 {123 456}}

# Basic unset-tracing on variables

test trace-4.1 {trace variable unsets} {
    catch {unset x}
    set info {}
    trace add variable x unset traceScalar
    catch {unset x}
    set info
} {x {} unset 1 {can't read "x": no such variable}}
test trace-4.2 {variable mustn't exist during unset trace} {
    catch {unset x}
    set x 1234
    set info {}
    trace add variable x unset traceScalar
    unset x
    set info
} {x {} unset 1 {can't read "x": no such variable}}
test trace-4.3 {unset traces mustn't be called during reads and writes} {
    catch {unset x}
    set info {}
    trace add variable x unset traceScalar
    set x 44
    set x
    set info
} {}
test trace-4.4 {trace unsets on array elements} {
    catch {unset x}
    set x(0) 18
    set info {}
    trace add variable x(1) unset traceArray
    catch {unset x(1)}
    set info
} {x 1 unset 1 {can't read "x(1)": no such element in array}}
test trace-4.5 {trace unsets on array elements} {
    catch {unset x}
    set x(1) 18
    set info {}
    trace add variable x(1) unset traceArray
    unset x(1)
    set info
} {x 1 unset 1 {can't read "x(1)": no such element in array}}
test trace-4.6 {trace unsets on array elements} {
    catch {unset x}
    set x(1) 18
    set info {}
    trace add variable x(1) unset traceArray
    unset x
    set info
} {x 1 unset 1 {can't read "x(1)": no such variable}}
test trace-4.7 {trace unsets on whole arrays} {
    catch {unset x}
    set x(1) 18
    set info {}
    trace add variable x unset traceProc
    catch {unset x(0)}
    set info
} {}
test trace-4.8 {trace unsets on whole arrays} {
    catch {unset x}
    set x(1) 18
    set x(2) 144
    set x(3) 14
    set info {}
    trace add variable x unset traceProc
    unset x(1)
    set info
} {x 1 unset}
test trace-4.9 {trace unsets on whole arrays} {
    catch {unset x}
    set x(1) 18
    set x(2) 144
    set x(3) 14
    set info {}
    trace add variable x unset traceProc
    unset x
    set info
} {x {} unset}

# Array tracing on variables
test trace-5.1 {array traces fire on accesses via [array]} {
    catch {unset x}
    set x(b) 2
    trace add variable x array traceArray2
    set ::info {}
    array set x {a 1}
    set ::info
} {x {} array}
test trace-5.2 {array traces do not fire on normal accesses} {
    catch {unset x}
    set x(b) 2
    trace add variable x array traceArray2
    set ::info {}
    set x(a) 1
    set x(b) $x(a)
    set ::info
} {}
test trace-5.3 {array traces do not outlive variable} {
    catch {unset x}
    trace add variable x array traceArray2
    set ::info {}
    set x(a) 1
    unset x
    array set x {a 1}
    set ::info
} {}
test trace-5.4 {array traces properly listed in trace information} {
    catch {unset x}
    trace add variable x array traceArray2
    set result [trace list variable x]
    set result
} [list [list array traceArray2]]
test trace-5.5 {array traces properly listed in trace information} {
    catch {unset x}
    trace variable x a traceArray2
    set result [trace vinfo x]
    set result
} [list [list a traceArray2]]
test trace-5.6 {array traces don't fire on scalar variables} {
    catch {unset x}
    set x foo
    trace add variable x array traceArray2
    set ::info {}
    catch {array set x {a 1}}
    set ::info
} {}
test trace-5.7 {array traces fire for undefined variables} {
    catch {unset x}
    trace add variable x array traceArray2
    set ::info {}
    array set x {a 1}
    set ::info
} {x {} array}
test trace-5.8 {array traces fire for undefined variables} {
    catch {unset x}
    trace add variable x array {set x(foo) 1 ;#}
    set res "names: [array names x]"
} {names: foo}
    
# Trace multiple trace types at once.

test trace-6.1 {multiple ops traced at once} {
    catch {unset x}
    set info {}
    trace add variable x {read write unset} traceProc
    catch {set x}
    set x 22
    set x
    set x 33
    unset x
    set info
} {x {} read x {} write x {} read x {} write x {} unset}
test trace-6.2 {multiple ops traced on array element} {
    catch {unset x}
    set info {}
    trace add variable x(0) {read write unset} traceProc
    catch {set x(0)}
    set x(0) 22
    set x(0)
    set x(0) 33
    unset x(0)
    unset x
    set info
} {x 0 read x 0 write x 0 read x 0 write x 0 unset}
test trace-6.3 {multiple ops traced on whole array} {
    catch {unset x}
    set info {}
    trace add variable x {read write unset} traceProc
    catch {set x(0)}
    set x(0) 22
    set x(0)
    set x(0) 33
    unset x(0)
    unset x
    set info
} {x 0 write x 0 read x 0 write x 0 unset x {} unset}

# Check order of invocation of traces

test trace-7.1 {order of invocation of traces} {
    catch {unset x}
    set info {}
    trace add variable x read "traceTag 1"
    trace add variable x read "traceTag 2"
    trace add variable x read "traceTag 3"
    catch {set x}
    set x 22
    set x
    set info
} {3 2 1 3 2 1}
test trace-7.2 {order of invocation of traces} {
    catch {unset x}
    set x(0) 44
    set info {}
    trace add variable x(0) read "traceTag 1"
    trace add variable x(0) read "traceTag 2"
    trace add variable x(0) read "traceTag 3"
    set x(0)
    set info
} {3 2 1}
test trace-7.3 {order of invocation of traces} {
    catch {unset x}
    set x(0) 44
    set info {}
    trace add variable x(0) read "traceTag 1"
    trace add variable x read "traceTag A1"
    trace add variable x(0) read "traceTag 2"
    trace add variable x read "traceTag A2"
    trace add variable x(0) read "traceTag 3"
    trace add variable x read "traceTag A3"
    set x(0)
    set info
} {A3 A2 A1 3 2 1}

# Check effects of errors in trace procedures

test trace-8.1 {error returns from traces} {
    catch {unset x}
    set x 123
    set info {}
    trace add variable x read "traceTag 1"
    trace add variable x read traceError
    list [catch {set x} msg] $msg $info
} {1 {can't read "x": trace returned error} {}}
test trace-8.2 {error returns from traces} {
    catch {unset x}
    set x 123
    set info {}
    trace add variable x write "traceTag 1"
    trace add variable x write traceError
    list [catch {set x 44} msg] $msg $info
} {1 {can't set "x": trace returned error} {}}
test trace-8.3 {error returns from traces} {
    catch {unset x}
    set x 123
    set info {}
    trace add variable x write traceError
    list [catch {append x 44} msg] $msg $info
} {1 {can't set "x": trace returned error} {}}
test trace-8.4 {error returns from traces} {
    catch {unset x}
    set x 123
    set info {}
    trace add variable x unset "traceTag 1"
    trace add variable x unset traceError
    list [catch {unset x} msg] $msg $info
} {0 {} 1}
test trace-8.5 {error returns from traces} {
    catch {unset x}
    set x(0) 123
    set info {}
    trace add variable x(0) read "traceTag 1"
    trace add variable x read "traceTag 2"
    trace add variable x read traceError
    trace add variable x read "traceTag 3"
    list [catch {set x(0)} msg] $msg $info
} {1 {can't read "x(0)": trace returned error} 3}
test trace-8.6 {error returns from traces} {
    catch {unset x}
    set x 123
    trace add variable x unset traceError
    list [catch {unset x} msg] $msg
} {0 {}}
test trace-8.7 {error returns from traces} {
    # This test just makes sure that the memory for the error message
    # gets deallocated correctly when the trace is invoked again or
    # when the trace is deleted.
    catch {unset x}
    set x 123
    trace add variable x read traceError
    catch {set x}
    catch {set x}
    trace remove variable x read traceError
} {}
test trace-8.8 {error returns from traces} {
    # Yet more elaborate memory corruption testing that checks nothing
    # bad happens when the trace deletes itself and installs something
    # new.  Alas, there is no neat way to guarantee that this test will
    # fail if there is a problem, but that's life and with the new code
    # it should *never* fail.
    #
    # Adapted from Bug #219393 reported by Don Porter.
    catch {rename ::foo {}}
    proc foo {old args} {
	trace remove variable ::x write [list foo $old]
	trace add    variable ::x write [list foo $::x]
	error "foo"
    }
    catch {unset ::x ::y}
    set x junk
    trace add variable ::x write [list foo $x]
    for {set y 0} {$y<100} {incr y} {
	catch {set x junk}
    }
} {}

# Check to see that variables are expunged before trace
# procedures are invoked, so trace procedure can even manipulate
# a new copy of the variables.

test trace-9.1 {be sure variable is unset before trace is called} {
    catch {unset x}
    set x 33
    set info {}
    trace add variable x unset {traceCheck {uplevel set x}}
    unset x
    set info
} {1 {can't read "x": no such variable}}
test trace-9.2 {be sure variable is unset before trace is called} {
    catch {unset x}
    set x 33
    set info {}
    trace add variable x unset {traceCheck {uplevel set x 22}}
    unset x
    concat $info [list [catch {set x} msg] $msg]
} {0 22 0 22}
test trace-9.3 {be sure traces are cleared before unset trace called} {
    catch {unset x}
    set x 33
    set info {}
    trace add variable x unset {traceCheck {uplevel trace list variable x}}
    unset x
    set info
} {0 {}}
test trace-9.4 {set new trace during unset trace} {
    catch {unset x}
    set x 33
    set info {}
    trace add variable x unset {traceCheck {global x; trace add variable x unset traceProc}}
    unset x
    concat $info [trace list variable x]
} {0 {} {unset traceProc}}

test trace-10.1 {make sure array elements are unset before traces are called} {
    catch {unset x}
    set x(0) 33
    set info {}
    trace add variable x(0) unset {traceCheck {uplevel set x(0)}}
    unset x(0)
    set info
} {1 {can't read "x(0)": no such element in array}}
test trace-10.2 {make sure array elements are unset before traces are called} {
    catch {unset x}
    set x(0) 33
    set info {}
    trace add variable x(0) unset {traceCheck {uplevel set x(0) zzz}}
    unset x(0)
    concat $info [list [catch {set x(0)} msg] $msg]
} {0 zzz 0 zzz}
test trace-10.3 {array elements are unset before traces are called} {
    catch {unset x}
    set x(0) 33
    set info {}
    trace add variable x(0) unset {traceCheck {global x; trace list variable x(0)}}
    unset x(0)
    set info
} {0 {}}
test trace-10.4 {set new array element trace during unset trace} {
    catch {unset x}
    set x(0) 33
    set info {}
    trace add variable x(0) unset {traceCheck {uplevel {trace add variable x(0) read {}}}}
    catch {unset x(0)}
    concat $info [trace list variable x(0)]
} {0 {} {read {}}}

test trace-11.1 {make sure arrays are unset before traces are called} {
    catch {unset x}
    set x(0) 33
    set info {}
    trace add variable x unset {traceCheck {uplevel set x(0)}}
    unset x
    set info
} {1 {can't read "x(0)": no such variable}}
test trace-11.2 {make sure arrays are unset before traces are called} {
    catch {unset x}
    set x(y) 33
    set info {}
    trace add variable x unset {traceCheck {uplevel set x(y) 22}}
    unset x
    concat $info [list [catch {set x(y)} msg] $msg]
} {0 22 0 22}
test trace-11.3 {make sure arrays are unset before traces are called} {
    catch {unset x}
    set x(y) 33
    set info {}
    trace add variable x unset {traceCheck {uplevel array exists x}}
    unset x
    set info
} {0 0}
test trace-11.4 {make sure arrays are unset before traces are called} {
    catch {unset x}
    set x(y) 33
    set info {}
    set cmd {traceCheck {uplevel {trace list variable x}}}
    trace add variable x unset $cmd
    unset x
    set info
} {0 {}}
test trace-11.5 {set new array trace during unset trace} {
    catch {unset x}
    set x(y) 33
    set info {}
    trace add variable x unset {traceCheck {global x; trace add variable x read {}}}
    unset x
    concat $info [trace list variable x]
} {0 {} {read {}}}
test trace-11.6 {create scalar during array unset trace} {
    catch {unset x}
    set x(y) 33
    set info {}
    trace add variable x unset {traceCheck {global x; set x 44}}
    unset x
    concat $info [list [catch {set x} msg] $msg]
} {0 44 0 44}

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

test trace-12.1 {creating array when setting variable traces} {
    catch {unset x}
    set info {}
    trace add variable x(0) write traceProc
    list [catch {set x 22} msg] $msg
} {1 {can't set "x": variable is array}}
test trace-12.2 {creating array when setting variable traces} {
    catch {unset x}
    set info {}
    trace add variable x(0) write traceProc
    list [catch {set x(0)} msg] $msg
} {1 {can't read "x(0)": no such element in array}}
test trace-12.3 {creating array when setting variable traces} {
    catch {unset x}
    set info {}
    trace add variable x(0) write traceProc
    set x(0) 22
    set info
} {x 0 write}
test trace-12.4 {creating variable when setting variable traces} {
    catch {unset x}
    set info {}
    trace add variable x write traceProc
    list [catch {set x} msg] $msg
} {1 {can't read "x": no such variable}}
test trace-12.5 {creating variable when setting variable traces} {
    catch {unset x}
    set info {}
    trace add variable x write traceProc
    set x 22
    set info
} {x {} write}
test trace-12.6 {creating variable when setting variable traces} {
    catch {unset x}
    set info {}
    trace add variable x write traceProc
    set x(0) 22
    set info
} {x 0 write}
test trace-12.7 {create array element during read trace} {
    catch {unset x}
    set x(2) zzz
    trace add variable x read {traceCrtElement xyzzy}
    list [catch {set x(3)} msg] $msg
} {0 xyzzy}
test trace-12.8 {errors when setting variable traces} {
    catch {unset x}
    set x 44
    list [catch {trace add variable x(0) write traceProc} msg] $msg
} {1 {can't trace "x(0)": variable isn't array}}

# Check deleting one trace from another.

test trace-13.1 {delete one trace from another} {
    proc delTraces {args} {
	global x
	trace remove variable x read {traceTag 2}
	trace remove variable x read {traceTag 3}
	trace remove variable x read {traceTag 4}
    }
    catch {unset x}
    set x 44
    set info {}
    trace add variable x read {traceTag 1}
    trace add variable x read {traceTag 2}
    trace add variable x read {traceTag 3}
    trace add variable x read {traceTag 4}
    trace add variable x read delTraces 
    trace add variable x read {traceTag 5}
    set x
    set info
} {5 1}

# Check operation and syntax of "trace" command.

# Syntax for adding/removing variable and command traces is basically the
# same:
#	trace add variable name opList command
#	trace remove variable name opList command
#
# The following loops just get all the common "wrong # args" tests done.

set i 0
set start "wrong # args:"
foreach type {variable command} {
    foreach op {add remove} {
	test trace-14.0.[incr i] "trace command, wrong # args errors" {
	    list [catch {trace $op $type} msg] $msg
	} [list 1 "$start should be \"trace $op $type name opList command\""]
	test trace-14.0.[incr i] "trace command wrong # args errors" {
	    list [catch {trace $op $type foo} msg] $msg
	} [list 1 "$start should be \"trace $op $type name opList command\""]
	test trace-14.0.[incr i] "trace command, wrong # args errors" {
	    list [catch {trace $op $type foo bar} msg] $msg
	} [list 1 "$start should be \"trace $op $type name opList command\""]
	test trace-14.0.[incr i] "trace command, wrong # args errors" {
	    list [catch {trace $op $type foo bar baz boo} msg] $msg
	} [list 1 "$start should be \"trace $op $type name opList command\""]
    }
    test trace-14.0.[incr i] "trace command, wrong # args errors" {
	list [catch {trace list $type foo bar} msg] $msg
    } [list 1 "$start should be \"trace list $type name\""]
    test trace-14.0.[incr i] "trace command, wrong # args errors" {
	list [catch {trace list $type} msg] $msg
    } [list 1 "$start should be \"trace list $type name\""]
}

test trace-14.1 "trace command, wrong # args errors" {
    list [catch {trace} msg] $msg
} [list 1 "wrong # args: should be \"trace option ?arg arg ...?\""]
test trace-14.2 "trace command, wrong # args errors" {
    list [catch {trace add} msg] $msg
} [list 1 "wrong # args: should be \"trace add type ?arg arg ...?\""]
test trace-14.3 "trace command, wrong # args errors" {
    list [catch {trace remove} msg] $msg
} [list 1 "wrong # args: should be \"trace remove type ?arg arg ...?\""]
test trace-14.4 "trace command, wrong # args errors" {
    list [catch {trace list} msg] $msg
} [list 1 "wrong # args: should be \"trace list type ?arg arg ...?\""]

test trace-14.5 {trace command, invalid option} {
    list [catch {trace gorp} msg] $msg
} [list 1 "bad option \"gorp\": must be add, list, remove, variable, vdelete, or vinfo"]

# Again, [trace ... command] and [trace ... variable] share syntax and
# error message styles for their opList options; these loops test those 
# error messages.

set i 0
set errs [list "array, read, unset, or write" "delete or rename"]
set abbvs [list {a r u w} {d r}]
foreach type {variable command} err $errs abbvlist $abbvs {
    foreach op {add remove} {
	test trace-14.6.[incr i] "trace $op $type errors" {
	    list [catch {trace $op $type x {y z w} a} msg] $msg
	} [list 1 "bad operation \"y\": must be $err"]
	foreach abbv $abbvlist {
	    test trace-14.6.[incr i] "trace $op $type rejects abbreviations" {
		list [catch {trace $op $type x $abbv a} msg] $msg
	    } [list 1 "bad operation \"$abbv\": must be $err"]
	}
	test trace-14.6.[incr i] "trace $op $type rejects null opList" {
	    list [catch {trace $op $type x {} a} msg] $msg
	} [list 1 "bad operation list \"\": must be one or more of $err"]
    }
}

test trace-14.7 {trace command, "trace variable" errors} {
    list [catch {trace variable} msg] $msg
} [list 1 "wrong # args: should be \"trace variable name ops command\""]
test trace-14.8 {trace command, "trace variable" errors} {
    list [catch {trace variable x} msg] $msg
} [list 1 "wrong # args: should be \"trace variable name ops command\""]
test trace-14.9 {trace command, "trace variable" errors} {
    list [catch {trace variable x y} msg] $msg
} [list 1 "wrong # args: should be \"trace variable name ops command\""]
test trace-14.10 {trace command, "trace variable" errors} {
    list [catch {trace variable x y z w} msg] $msg
} [list 1 "wrong # args: should be \"trace variable name ops command\""]
test trace-14.11 {trace command, "trace variable" errors} {
    list [catch {trace variable x y z} msg] $msg
} [list 1 "bad operations \"y\": should be one or more of rwua"]


test trace-14.9 {trace command ("remove variable" option)} {
    catch {unset x}
    set info {}
    trace add variable x write traceProc
    trace remove variable x write traceProc
} {}
test trace-14.10 {trace command ("remove variable" option)} {
    catch {unset x}
    set info {}
    trace add variable x write traceProc
    trace remove variable x write traceProc
    set x 12345
    set info
} {}
test trace-14.11 {trace command ("remove variable" option)} {
    catch {unset x}
    set info {}
    trace add variable x write {traceTag 1}
    trace add variable x write traceProc
    trace add variable x write {traceTag 2}
    set x yy
    trace remove variable x write traceProc
    set x 12345
    trace remove variable x write {traceTag 1}
    set x foo
    trace remove variable x write {traceTag 2}
    set x gorp
    set info
} {2 x {} write 1 2 1 2}
test trace-14.12 {trace command ("remove variable" option)} {
    catch {unset x}
    set info {}
    trace add variable x write {traceTag 1}
    trace remove variable x write non_existent
    set x 12345
    set info
} {1}
test trace-14.15 {trace command ("list variable" option)} {
    catch {unset x}
    trace add variable x write {traceTag 1}
    trace add variable x write traceProc
    trace add variable x write {traceTag 2}
    trace list variable x
} {{write {traceTag 2}} {write traceProc} {write {traceTag 1}}}
test trace-14.16 {trace command ("list variable" option)} {
    catch {unset x}
    trace list variable x
} {}
test trace-14.17 {trace command ("list variable" option)} {
    catch {unset x}
    trace list variable x(0)
} {}
test trace-14.18 {trace command ("list variable" option)} {
    catch {unset x}
    set x 44
    trace list variable x(0)
} {}
test trace-14.19 {trace command ("list variable" option)} {
    catch {unset x}
    set x 44
    trace add variable x write {traceTag 1}
    proc check {} {global x; trace list variable x}
    check
} {{write {traceTag 1}}}

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

test trace-15.1 {long trace command} {
    catch {unset x}
    set info {}
    trace add variable x write {traceTag {This is a very very long argument.  It's \
	designed to test out the facilities of TraceVarProc for dealing \
	with such long arguments by malloc-ing space.  One possibility \
	is that space doesn't get freed properly.  If this happens, then \
	invoking this test over and over again will eventually leak memory.}}
    set x 44
    set info
} {This is a very very long argument.  It's \
	designed to test out the facilities of TraceVarProc for dealing \
	with such long arguments by malloc-ing space.  One possibility \
	is that space doesn't get freed properly.  If this happens, then \
	invoking this test over and over again will eventually leak memory.}
test trace-15.2 {long trace command result to ignore} {
    proc longResult {args} {return "quite a bit of text, designed to
	generate a core leak if this command file is invoked over and over again
	and memory isn't being recycled correctly"}
    catch {unset x}
    trace add variable x write longResult
    set x 44
    set x 5
    set x abcde
} abcde
test trace-15.3 {special list-handling in trace commands} {
    catch {unset "x y z"}
    set "x y z(a\n\{)" 44
    set info {}
    trace add variable "x y z(a\n\{)" write traceProc
    set "x y z(a\n\{)" 33
    set info
} "{x y z} a\\n\\{ write"

# Check for proper handling of unsets during traces.

proc traceUnset {unsetName args} {
    global info
    upvar $unsetName x
    lappend info [catch {unset x} msg] $msg [catch {set x} msg] $msg
}
proc traceReset {unsetName resetName args} {
    global info
    upvar $unsetName x $resetName y
    lappend info [catch {unset x} msg] $msg [catch {set y xyzzy} msg] $msg
}
proc traceReset2 {unsetName resetName args} {
    global info
    lappend info [catch {uplevel unset $unsetName} msg] $msg \
	    [catch {uplevel set $resetName xyzzy} msg] $msg
}
proc traceAppend {string name1 name2 op} {
    global info
    lappend info $string
}

test trace-16.1 {unsets during read traces} {
    catch {unset y}
    set y 1234
    set info {}
    trace add variable y read {traceUnset y}
    trace add variable y unset {traceAppend unset}
    lappend info [catch {set y} msg] $msg
} {unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}}
test trace-16.2 {unsets during read traces} {
    catch {unset y}
    set y(0) 1234
    set info {}
    trace add variable y(0) read {traceUnset y(0)}
    lappend info [catch {set y(0)} msg] $msg
} {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such element in array}}
test trace-16.3 {unsets during read traces} {
    catch {unset y}
    set y(0) 1234
    set info {}
    trace add variable y(0) read {traceUnset y}
    lappend info [catch {set y(0)} msg] $msg
} {0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}}
test trace-16.4 {unsets during read traces} {
    catch {unset y}
    set y 1234
    set info {}
    trace add variable y read {traceReset y y}
    lappend info [catch {set y} msg] $msg
} {0 {} 0 xyzzy 0 xyzzy}
test trace-16.5 {unsets during read traces} {
    catch {unset y}
    set y(0) 1234
    set info {}
    trace add variable y(0) read {traceReset y(0) y(0)}
    lappend info [catch {set y(0)} msg] $msg
} {0 {} 0 xyzzy 0 xyzzy}
test trace-16.6 {unsets during read traces} {
    catch {unset y}
    set y(0) 1234
    set info {}
    trace add variable y(0) read {traceReset y y(0)}
    lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 1 {can't set "y": upvar refers to element in deleted array} 1 {can't read "y(0)": no such variable} 1 {can't read "y(0)": no such variable}}
test trace-16.7 {unsets during read traces} {
    catch {unset y}
    set y(0) 1234
    set info {}
    trace add variable y(0) read {traceReset2 y y(0)}
    lappend info [catch {set y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 0 xyzzy 1 {can't read "y(0)": no such element in array} 0 xyzzy}
test trace-16.8 {unsets during write traces} {
    catch {unset y}
    set y 1234
    set info {}
    trace add variable y write {traceUnset y}
    trace add variable y unset {traceAppend unset}
    lappend info [catch {set y xxx} msg] $msg
} {unset 0 {} 1 {can't read "x": no such variable} 0 {}}
test trace-16.9 {unsets during write traces} {
    catch {unset y}
    set y(0) 1234
    set info {}
    trace add variable y(0) write {traceUnset y(0)}
    lappend info [catch {set y(0) xxx} msg] $msg
} {0 {} 1 {can't read "x": no such variable} 0 {}}
test trace-16.10 {unsets during write traces} {
    catch {unset y}
    set y(0) 1234
    set info {}
    trace add variable y(0) write {traceUnset y}
    lappend info [catch {set y(0) xxx} msg] $msg
} {0 {} 1 {can't read "x": no such variable} 0 {}}
test trace-16.11 {unsets during write traces} {
    catch {unset y}
    set y 1234
    set info {}
    trace add variable y write {traceReset y y}
    lappend info [catch {set y xxx} msg] $msg
} {0 {} 0 xyzzy 0 xyzzy}
test trace-16.12 {unsets during write traces} {
    catch {unset y}
    set y(0) 1234
    set info {}
    trace add variable y(0) write {traceReset y(0) y(0)}
    lappend info [catch {set y(0) xxx} msg] $msg
} {0 {} 0 xyzzy 0 xyzzy}
test trace-16.13 {unsets during write traces} {
    catch {unset y}
    set y(0) 1234
    set info {}
    trace add variable y(0) write {traceReset y y(0)}
    lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 1 {can't set "y": upvar refers to element in deleted array} 0 {} 1 {can't read "y(0)": no such variable}}
test trace-16.14 {unsets during write traces} {
    catch {unset y}
    set y(0) 1234
    set info {}
    trace add variable y(0) write {traceReset2 y y(0)}
    lappend info [catch {set y(0) xxx} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 0 xyzzy 0 {} 0 xyzzy}
test trace-16.15 {unsets during unset traces} {
    catch {unset y}
    set y 1234
    set info {}
    trace add variable y unset {traceUnset y}
    lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg
} {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y": no such variable}}
test trace-16.16 {unsets during unset traces} {
    catch {unset y}
    set y(0) 1234
    set info {}
    trace add variable y(0) unset {traceUnset y(0)}
    lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {1 {can't unset "x": no such variable} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such element in array}}
test trace-16.17 {unsets during unset traces} {
    catch {unset y}
    set y(0) 1234
    set info {}
    trace add variable y(0) unset {traceUnset y}
    lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 1 {can't read "x": no such variable} 0 {} 1 {can't read "y(0)": no such variable}}
test trace-16.18 {unsets during unset traces} {
    catch {unset y}
    set y 1234
    set info {}
    trace add variable y unset {traceReset2 y y}
    lappend info [catch {unset y} msg] $msg [catch {set y} msg] $msg
} {1 {can't unset "y": no such variable} 0 xyzzy 0 {} 0 xyzzy}
test trace-16.19 {unsets during unset traces} {
    catch {unset y}
    set y(0) 1234
    set info {}
    trace add variable y(0) unset {traceReset2 y(0) y(0)}
    lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {1 {can't unset "y(0)": no such element in array} 0 xyzzy 0 {} 0 xyzzy}
test trace-16.20 {unsets during unset traces} {
    catch {unset y}
    set y(0) 1234
    set info {}
    trace add variable y(0) unset {traceReset2 y y(0)}
    lappend info [catch {unset y(0)} msg] $msg [catch {set y(0)} msg] $msg
} {0 {} 0 xyzzy 0 {} 0 xyzzy}
test trace-16.21 {unsets cancelling traces} {
    catch {unset y}
    set y 1234
    set info {}
    trace add variable y read {traceAppend first}
    trace add variable y read {traceUnset y}
    trace add variable y read {traceAppend third}
    trace add variable y unset {traceAppend unset}
    lappend info [catch {set y} msg] $msg
} {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y": no such variable}}
test trace-16.22 {unsets cancelling traces} {
    catch {unset y}
    set y(0) 1234
    set info {}
    trace add variable y(0) read {traceAppend first}
    trace add variable y(0) read {traceUnset y}
    trace add variable y(0) read {traceAppend third}
    trace add variable y(0) unset {traceAppend unset}
    lappend info [catch {set y(0)} msg] $msg
} {third unset 0 {} 1 {can't read "x": no such variable} 1 {can't read "y(0)": no such variable}}

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

test trace-17.1 {trace doesn't prevent unset errors} {
    catch {unset x}
    set info {}
    trace add variable x unset {traceProc}
    list [catch {unset x} msg] $msg $info
} {1 {can't unset "x": no such variable} {x {} unset}}
test trace-17.2 {traced variables must survive procedure exits} {
    catch {unset x}
    proc p1 {} {global x; trace add variable x write traceProc}
    p1
    trace list variable x
} {{write traceProc}}
test trace-17.3 {traced variables must survive procedure exits} {
    catch {unset x}
    set info {}
    proc p1 {} {global x; trace add variable x write traceProc}
    p1
    set x 44
    set info
} {x {} write}

# Be sure that procedure frames are released before unset traces
# are invoked.

test trace-18.1 {unset traces on procedure returns} {
    proc p1 {x y} {set a 44; p2 14}
    proc p2 {z} {trace add variable z unset {traceCheck {lsort [uplevel {info vars}]}}}
    set info {}
    p1 foo bar
    set info
} {0 {a x y}}

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

catch {unset x}
catch {unset y}

test trace-18.2 {trace add command (command existence)} {
    # Just in case!
    catch {rename nosuchname ""}
    list [catch {trace add command nosuchname rename traceCommand} msg] $msg
} {1 {unknown command "nosuchname"}}
test trace-18.3 {trace add command (command existence in ns)} {
    list [catch {trace add command nosuchns::nosuchname rename traceCommand} msg] $msg
} {1 {unknown command "nosuchns::nosuchname"}}


test trace-19.1 {trace add command (rename option)} {
    proc foo {} {}
    catch {rename bar {}}
    trace add command foo rename traceCommand
    rename foo bar
    set info
} {foo bar rename}
test trace-19.2 {traces stick with renamed commands} {
    proc foo {} {}
    catch {rename bar {}}
    trace add command foo rename traceCommand
    rename foo bar
    rename bar foo
    set info
} {bar foo rename}
test trace-19.2.1 {trace add command rename trace exists} {
    proc foo {} {}
    trace add command foo rename traceCommand
    trace list command foo
} {{rename traceCommand}}
test trace-19.3 {command rename traces don't fire on command deletion} {
    proc foo {} {}
    set info {}
    trace add command foo rename traceCommand
    rename foo {}
    set info
} {}
test trace-19.4 {trace add command rename doesn't trace recreated commands} {
    proc foo {} {}
    catch {rename bar {}}
    trace add command foo rename traceCommand
    proc foo {} {}
    rename foo bar
    set info
} {}
test trace-19.5 {trace add command deleted removes traces} {
    proc foo {} {}
    trace add command foo rename traceCommand
    proc foo {} {}
    trace list command foo
} {}

namespace eval tc {}
proc tc::tcfoo {} {}
test trace-19.6 {trace add command rename in namespace} {
    trace add command tc::tcfoo rename traceCommand
    rename tc::tcfoo tc::tcbar
    set info
} {tc::tcfoo tc::tcbar rename}
test trace-19.7 {trace add command rename in namespace back again} {
    rename tc::tcbar tc::tcfoo
    set info
} {tc::tcbar tc::tcfoo rename}
test trace-19.8 {trace add command rename in namespace to out of namespace} {
    rename tc::tcfoo tcbar
    set info
} {tc::tcfoo tcbar rename}
test trace-19.9 {trace add command rename back into namespace} {
    rename tcbar tc::tcfoo
    set info
} {tcbar tc::tcfoo rename}
test trace-19.10 {trace add command failed rename doesn't trigger trace} {
    set info {}
    proc foo {} {}
    proc bar {} {}
    trace add command foo {rename delete} traceCommand
    catch {rename foo bar}
    set info
} {}
catch {rename foo {}}
catch {rename bar {}}

# Make sure it exists again
proc foo {} {}

test trace-20.1 {trace add command (delete option)} {
    trace add command foo delete traceCommand
    rename foo ""
    set info
} {foo {} delete}
test trace-20.2 {trace add command delete doesn't trace recreated commands} {
    set info {}
    proc foo {} {}
    rename foo ""
    set info
} {}
test trace-20.2.1 {trace add command delete trace info} {
    proc foo {} {}
    trace add command foo delete traceCommand
    trace list command foo
} {{delete traceCommand}}
test trace-20.3 {trace add command implicit delete} {
    proc foo {} {}
    trace add command foo delete traceCommand
    proc foo {} {}
    set info
} {foo {} delete}
test trace-20.3.1 {trace add command delete trace info} {
    proc foo {} {}
    trace list command foo
} {}
test trace-20.4 {trace add command rename followed by delete} {
    set infotemp {}
    proc foo {} {}
    trace add command foo {rename delete} traceCommand
    rename foo bar
    lappend infotemp $info
    rename bar {}
    lappend infotemp $info
    set info $infotemp
    unset infotemp
    set info
} {{foo bar rename} {bar {} delete}}
catch {rename foo {}}
catch {rename bar {}}

test trace-20.5 {trace add command rename and delete} {
    set infotemp {}
    set info {}
    proc foo {} {}
    trace add command foo {rename delete} traceCommand
    rename foo bar
    lappend infotemp $info
    rename bar {}
    lappend infotemp $info
    set info $infotemp
    unset infotemp
    set info
} {{foo bar rename} {bar {} delete}}

test trace-20.6 {trace add command rename and delete in subinterp} {
    set tc [interp create]
    foreach p {traceCommand} {
	$tc eval [list proc $p [info args $p] [info body $p]]
    }
    $tc eval [list set infotemp {}]
    $tc eval [list set info {}]
    $tc eval [list proc foo {} {}]
    $tc eval [list trace add command foo {rename delete} traceCommand]
    $tc eval [list rename foo bar]
    $tc eval {lappend infotemp $info}
    $tc eval [list rename bar {}]
    $tc eval {lappend infotemp $info}
    $tc eval {set info $infotemp}
    $tc eval [list unset infotemp]
    set info [$tc eval [list set info]]
    interp delete $tc
    set info
} {{foo bar rename} {bar {} delete}}

# I'd like it if this test could give 'foo {} d' as a result,
# but interp deletion means there is no interp to evaluate
# the trace in.
test trace-20.7 {trace add command delete in subinterp while being deleted} {
    set info {}
    set tc [interp create]
    interp alias $tc traceCommand {} traceCommand
    $tc eval [list proc foo {} {}]
    $tc eval [list trace add command foo {rename delete} traceCommand]
    interp delete $tc
    set info
} {}

proc traceDelete {cmd old new op} {
    eval trace remove command $cmd [lindex [trace list command $cmd] 0]
    global info
    set info [list $old $new $op]
}
proc traceCmdrename {cmd old new op} {
    rename $old someothername
}
proc traceCmddelete {cmd old new op} {
    rename $old ""
}
test trace-20.8 {trace delete while trace is active} {
    set info {}
    proc foo {} {}
    catch {rename bar {}}
    trace add command foo {rename delete} [list traceDelete foo]
    rename foo bar
    list [set info] [trace list command bar]
} {{foo bar rename} {}}

test trace-20.9 {rename trace deletes command} {
    set info {}
    proc foo {} {}
    catch {rename bar {}}
    catch {rename someothername {}}
    trace add command foo rename [list traceCmddelete foo]
    rename foo bar
    list [info commands foo] [info commands bar] [info commands someothername]
} {{} {} {}}

test trace-20.10 {rename trace renames command} {
    set info {}
    proc foo {} {}
    catch {rename bar {}}
    catch {rename someothername {}}
    trace add command foo rename [list traceCmdrename foo]
    rename foo bar
    set info [list [info commands foo] [info commands bar] [info commands someothername]]
    rename someothername {}
    set info
} {{} {} someothername}

test trace-20.11 {delete trace deletes command} {
    set info {}
    proc foo {} {}
    catch {rename bar {}}
    catch {rename someothername {}}
    trace add command foo delete [list traceCmddelete foo]
    rename foo {}
    list [info commands foo] [info commands bar] [info commands someothername]
} {{} {} {}}

test trace-20.12 {delete trace renames command} {
    set info {}
    proc foo {} {}
    catch {rename bar {}}
    catch {rename someothername {}}
    trace add command foo delete [list traceCmdrename foo]
    rename foo bar
    rename bar {}
    # None of these should exist.
    list [info commands foo] [info commands bar] [info commands someothername]
} {{} {} {}}

proc foo {b} { set a $b }


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

catch {unset x}
catch {unset y}

# Delete procedures when done, so we don't clash with other tests
# (e.g. foobar will clash with 'unknown' tests).
catch {rename foobar {}}
catch {rename foo {}}
catch {rename bar {}}

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

catch {unset x}
catch {unset y}


# cleanup
::tcltest::cleanupTests
return