trace.test

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

    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 ("info 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 info variable x
} {{write {traceTag 2}} {write traceProc} {write {traceTag 1}}}
test trace-14.16 {trace command ("info variable" option)} {
    catch {unset x}
    trace info variable x
} {}
test trace-14.17 {trace command ("info variable" option)} {
    catch {unset x}
    trace info variable x(0)
} {}
test trace-14.18 {trace command ("info variable" option)} {
    catch {unset x}
    set x 44
    trace info variable x(0)
} {}
test trace-14.19 {trace command ("info variable" option)} {
    catch {unset x}
    set x 44
    trace add variable x write {traceTag 1}
    proc check {} {global x; trace info 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 info 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}}
test trace-18.2 {namespace delete / trace vdelete combo} {
    namespace eval ::foo {
	variable x 123
    }
    proc p1 args {
	trace vdelete ::foo::x u p1
    }
    trace variable ::foo::x u p1
    namespace delete ::foo
    info exists ::foo::x
} 0

# 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 info 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 info 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 {}}