trace.test

来自「tcl是工具命令语言」· TEST 代码 · 共 2,078 行 · 第 1/5 页

    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}
    }
    unset x
} {}

# 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 info 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 info 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 info 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 info 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 info 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 info 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 info $type foo bar} msg] $msg
    } [list 1 "$start should be \"trace info $type name\""]
    test trace-14.0.[incr i] "trace command, wrong # args errors" {
	list [catch {trace info $type} msg] $msg
    } [list 1 "$start should be \"trace info $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 info} msg] $msg
} [list 1 "wrong # args: should be \"trace info 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, info, 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" "enter, leave, enterstep, or leavestep"]
set abbvs [list {a r u w} {d r} {}]
proc x {} {}
foreach type {variable command execution} 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"]
    }
}
rename x {}

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}