trace.test

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

    set info {}
    trace add execution foo leave [list traceDelete foo]
    foo 1
    list $info [catch {trace info execution foo} res] $res
} {{{foo 1} 0 1 leave} 1 {unknown command "foo"}}

proc foo {a} {
    set b $a
}

test trace-25.3 {delete command during enter then leave trace} {
    set info {}
    trace add execution foo enter [list traceDelete foo]
    trace add execution foo leave [list traceDelete foo]
    catch {foo 1} err
    list $err $info [catch {trace info execution foo} res] $res
} {{invalid command name "foo"} {{foo 1} enter} 1 {unknown command "foo"}}

proc foo {a} {
    set b $a
}
proc traceExecute2 {args} {
    global info
    lappend info $args
}

# This shows the peculiar consequences of having two traces
# at the same time: as well as tracing the procedure you want
test trace-25.4 {order dependencies of two enter traces} {
    set info {}
    trace add execution foo enter [list traceExecute traceExecute]
    trace add execution foo enter [list traceExecute2 traceExecute2]
    catch {foo 1} err
    trace remove execution foo enter [list traceExecute traceExecute]
    trace remove execution foo enter [list traceExecute2 traceExecute2]
    join [list $err [join $info \n] [trace info execution foo]] "\n"
} {1
traceExecute2 {foo 1} enter
traceExecute {foo 1} enter
}

test trace-25.5 {order dependencies of two step traces} {
    set info {}
    trace add execution foo enterstep [list traceExecute traceExecute]
    trace add execution foo enterstep [list traceExecute2 traceExecute2]
    catch {foo 1} err
    trace remove execution foo enterstep [list traceExecute traceExecute]
    trace remove execution foo enterstep [list traceExecute2 traceExecute2]
    join [list $err [join $info \n] [trace info execution foo]] "\n"
} {1
traceExecute2 {set b 1} enterstep
traceExecute {set b 1} enterstep
}

# We don't want the result string (5th argument), or the results
# will get unmanageable.
proc tracePostExecute {args} {
    global info
    lappend info [concat [lrange $args 0 2] [lindex $args 4]]
}
proc tracePostExecute2 {args} {
    global info
    lappend info [concat [lrange $args 0 2] [lindex $args 4]]
}

test trace-25.6 {order dependencies of two leave traces} {
    set info {}
    trace add execution foo leave [list tracePostExecute tracePostExecute]
    trace add execution foo leave [list tracePostExecute2 tracePostExecute2]
    catch {foo 1} err
    trace remove execution foo leave [list tracePostExecute tracePostExecute]
    trace remove execution foo leave [list tracePostExecute2 tracePostExecute2]
    join [list $err [join $info \n] [trace info execution foo]] "\n"
} {1
tracePostExecute {foo 1} 0 leave
tracePostExecute2 {foo 1} 0 leave
}

test trace-25.7 {order dependencies of two leavestep traces} {
    set info {}
    trace add execution foo leavestep [list tracePostExecute tracePostExecute]
    trace add execution foo leavestep [list tracePostExecute2 tracePostExecute2]
    catch {foo 1} err
    trace remove execution foo leavestep [list tracePostExecute tracePostExecute]
    trace remove execution foo leavestep [list tracePostExecute2 tracePostExecute2]
    join [list $err [join $info \n] [trace info execution foo]] "\n"
} {1
tracePostExecute {set b 1} 0 leavestep
tracePostExecute2 {set b 1} 0 leavestep
}

proc foo {a} {
    set b $a
}

proc traceDelete {cmd args} {
    rename $cmd {}
    global info
    set info $args
}

test trace-25.8 {delete command during enter leave and enter/leave-step traces} {
    set info {}
    trace add execution foo enter [list traceDelete foo]
    trace add execution foo leave [list traceDelete foo]
    trace add execution foo enterstep [list traceDelete foo]
    trace add execution foo leavestep [list traceDelete foo]
    catch {foo 1} err
    list $err $info [catch {trace info execution foo} res] $res
} {{invalid command name "foo"} {{foo 1} enter} 1 {unknown command "foo"}}

proc foo {a} {
    set b $a
}

test trace-25.9 {delete command during enter leave and leavestep traces} {
    set info {}
    trace add execution foo enter [list traceDelete foo]
    trace add execution foo leave [list traceDelete foo]
    trace add execution foo leavestep [list traceDelete foo]
    catch {foo 1} err
    list $err $info [catch {trace info execution foo} res] $res
} {{invalid command name "foo"} {{foo 1} enter} 1 {unknown command "foo"}}

proc foo {a} {
    set b $a
}

test trace-25.10 {delete command during leave and leavestep traces} {
    set info {}
    trace add execution foo leave [list traceDelete foo]
    trace add execution foo leavestep [list traceDelete foo]
    catch {foo 1} err
    list $err $info [catch {trace info execution foo} res] $res
} {1 {{set b 1} 0 1 leavestep} 1 {unknown command "foo"}}

proc foo {a} {
    set b $a
}

test trace-25.11 {delete command during enter and enterstep traces} {
    set info {}
    trace add execution foo enter [list traceDelete foo]
    trace add execution foo enterstep [list traceDelete foo]
    catch {foo 1} err
    list $err $info [catch {trace info execution foo} res] $res
} {{invalid command name "foo"} {{foo 1} enter} 1 {unknown command "foo"}}

test trace-26.1 {trace targetCmd when invoked through an alias} {
    proc foo {args} {
	set b $args
    }
    set info {}
    trace add execution foo enter [list traceExecute foo]
    interp alias {} bar {} foo 1
    bar 2
    trace remove execution foo enter [list traceExecute foo]
    set info
} {{foo {foo 1 2} enter}}
test trace-26.2 {trace targetCmd when invoked through an alias} {
    proc foo {args} {
	set b $args
    }
    set info {}
    trace add execution foo enter [list traceExecute foo]
    interp create child
    interp alias child bar {} foo 1
    child eval bar 2
    interp delete child
    trace remove execution foo enter [list traceExecute foo]
    set info
} {{foo {foo 1 2} enter}}

test trace-27.1 {memory leak in rename trace (604609)} {
    catch {rename bar {}}
    proc foo {} {error foo}
    trace add command foo rename {rename foo "" ;#}
    rename foo bar
    info commands foo
} {}

test trace-27.2 {command trace remove nonsense} {
    list [catch {trace remove command thisdoesntexist \
      {delete rename} bar} res] $res
} {1 {unknown command "thisdoesntexist"}}

test trace-27.3 {command trace info nonsense} {
    list [catch {trace info command thisdoesntexist} res] $res
} {1 {unknown command "thisdoesntexist"}}


test trace-28.1 {enterstep and leavestep traces with update idletasks (615043)} {
    catch {rename foo {}}
    proc foo {} {
        set a 1
        update idletasks
        set b 1
    }

    set info {}
    trace add execution foo {enter enterstep leavestep leave} \
        [list traceExecute foo]
    update
    after idle {set a "idle"}
    foo

    trace remove execution foo {enter enterstep leavestep leave} \
        [list traceExecute foo]
    rename foo {}
    catch {unset a}
    join $info "\n"
} {foo foo enter
foo {set a 1} enterstep
foo {set a 1} 0 1 leavestep
foo {update idletasks} enterstep
foo {set a idle} enterstep
foo {set a idle} 0 idle leavestep
foo {update idletasks} 0 {} leavestep
foo {set b 1} enterstep
foo {set b 1} 0 1 leavestep
foo foo 0 1 leave}

test trace-28.2 {exec traces with 'error'} {
    set info {}
    set res {}
    
    proc foo {} {
	if {[catch {bar}]} {
	    return "error"
	} else {
	    return "ok"
	}
    }

    proc bar {} { error "msg" }

    lappend res [foo]

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

    # With the trace active

    lappend res [foo]

    trace remove execution foo {enter enterstep leave leavestep} \
      [list traceExecute foo]
    
    list $res [join $info \n]
} {{error error} {foo foo enter
foo {if {[catch {bar}]} {
	    return "error"
	} else {
	    return "ok"
	}} enterstep
foo {catch bar} enterstep
foo bar enterstep
foo {error msg} enterstep
foo {error msg} 1 msg leavestep
foo bar 1 msg leavestep
foo {catch bar} 0 1 leavestep
foo {return error} enterstep
foo {return error} 2 error leavestep
foo {if {[catch {bar}]} {
	    return "error"
	} else {
	    return "ok"
	}} 2 error leavestep
foo foo 0 error leave}}

test trace-28.3 {exec traces with 'return -code error'} {
    set info {}
    set res {}
    
    proc foo {} {
	if {[catch {bar}]} {
	    return "error"
	} else {
	    return "ok"
	}
    }

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

    lappend res [foo]

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

    # With the trace active

    lappend res [foo]

    trace remove execution foo {enter enterstep leave leavestep} \
      [list traceExecute foo]
    
    list $res [join $info \n]
} {{error error} {foo foo enter
foo {if {[catch {bar}]} {
	    return "error"
	} else {
	    return "ok"
	}} enterstep
foo {catch bar} enterstep
foo bar enterstep
foo {return -code error msg} enterstep
foo {return -code error msg} 2 msg leavestep
foo bar 1 msg leavestep
foo {catch bar} 0 1 leavestep
foo {return error} enterstep
foo {return error} 2 error leavestep
foo {if {[catch {bar}]} {
	    return "error"
	} else {
	    return "ok"
	}} 2 error leavestep
foo foo 0 error leave}}

test trace-28.4 {exec traces in slave with 'return -code error'} {knownBug} {
    interp create slave
    interp alias slave traceExecute {} traceExecute
    set res [interp eval slave {
	set info {}
	set res {}
	
	proc foo {} {
	    if {[catch {bar}]} {
		return "error"
	    } else {
		return "ok"
	    }
	}
	
	proc bar {} { return -code error "msg" }
	
	lappend res [foo]
	
	trace add execution foo {enter enterstep leave leavestep} \
	  [list traceExecute foo]
	
	# With the trace active
	
	lappend res [foo]
	
	trace remove execution foo {enter enterstep leave leavestep} \
	  [list traceExecute foo]
	
	list $res [join $info \n]
    }]
    interp delete slave
    set res
} {{error error} {foo foo enter
foo {if {[catch {bar}]} {
	    return "error"
	} else {
	    return "ok"
	}} enterstep
foo {catch bar} enterstep
foo bar enterstep
foo {return -code error msg} enterstep
foo {return -code error msg} 2 msg leavestep
foo bar 1 msg leavestep
foo {catch bar} 0 1 leavestep
foo {return error} enterstep
foo {return error} 2 error leavestep
foo {if {[catch {bar}]} {
	    return "error"
	} else {
	    return "ok"
	}} 2 error leavestep
foo foo 0 error leave}}

test trace-28.5 {exec traces} {
    set info {}
    proc foo {args} { set a 1 }
    trace add execution foo {enter enterstep leave leavestep} \
      [list traceExecute foo]
    after idle [list foo test-28.4]
    update
    # Complicated way of removing traces
    set ti [lindex [eval [list trace info execution ::foo]] 0]
    if {[llength $ti]} {
	eval [concat [list trace remove execution foo] $ti]
    }
    join $info \n
} {foo {foo test-28.4} enter
foo {set a 1} enterstep
foo {set a 1} 0 1 leavestep
foo {foo test-28.4} 0 1 leave}

test trace-28.6 {exec traces firing order} {
    set info {}
    proc enterStep {cmd op} {lappend ::info "enter $cmd/$op"}
    proc leaveStep {cmd code result op} {lappend ::info "leave $cmd/$code/$result/$op"}

    proc foo x {
	set b x=$x
	incr x
    }
    trace add execution foo enterstep enterStep
    trace add execution foo leavestep leaveStep
    foo 42
    rename foo {}
    join $info \n
} {enter set b x=42/enterstep
leave set b x=42/0/x=42/leavestep
enter incr x/enterstep
leave incr x/0/43/leavestep}

test trace-28.7 {exec trace information} {
    set info {}
    proc foo x { incr x }
    proc bar {args} {}
    trace add execution foo {enter leave en