trace.test

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

# 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.26 2003/02/03 20:16:54 kennykb 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]
}

test trace-0.0 {memory corruption in trace (Tcl Bug 484339)} {
    # You may need Purify or Electric Fence to reliably
    # see this one fail.
    catch {unset z}
    trace add variable z array {set z(foo) 1 ;#}
    set res "names: [array names z]"
    catch {unset ::z}
    trace variable ::z w {unset ::z; error "memory corruption";#}
    list [catch {set ::z 1} msg] $msg
} {1 {can't set "::z": memory corruption}}

# 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
} {}
test trace-1.11 {read traces that modify the array structure} {
    catch {unset x}
    set x(bar) 0 
    trace variable x r {set x(foo) 1 ;#} 
    trace variable x r {unset -nocomplain x(bar) ;#} 
    array get x
} {}
test trace-1.12 {read traces that modify the array structure} {
    catch {unset x}
    set x(bar) 0 
    trace variable x r {unset -nocomplain x(bar) ;#} 
    trace variable x r {set x(foo) 1 ;#} 
    array get x
} {}
test trace-1.13 {read traces that modify the array structure} {
    catch {unset x}
    set x(bar) 0 
    trace variable x r {set x(foo) 1 ;#} 
    trace variable x r {unset -nocomplain x;#} 
    list [catch {array get x} res] $res
} {1 {can't read "x(bar)": no such variable}}
test trace-1.14 {read traces that modify the array structure} {
    catch {unset x}
    set x(bar) 0 
    trace variable x r {unset -nocomplain x;#} 
    trace variable x r {set x(foo) 1 ;#} 
    list [catch {array get x} res] $res
} {1 {can't read "x(bar)": no such variable}}

# 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 info 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)