diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/parse.test | 55 | ||||
| -rw-r--r-- | tests/trace.test | 36 |
2 files changed, 80 insertions, 11 deletions
diff --git a/tests/parse.test b/tests/parse.test index 124ab0f..dae14e9 100644 --- a/tests/parse.test +++ b/tests/parse.test @@ -8,10 +8,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: parse.test,v 1.11.2.2 2005/03/18 16:33:43 dgp Exp $ +# RCS: @(#) $Id: parse.test,v 1.11.2.3 2006/02/28 15:44:36 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest + package require tcltest 2 namespace import -force ::tcltest::* } @@ -218,16 +218,17 @@ test parse-7.1 {Tcl_FreeParse and ExpandTokenArray procedures} { testparser {$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) } 0 } {- {$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) } 16 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 {}} -test parse-8.1 {Tcl_EvalObjv procedure} { +testConstraint testevalobjv [llength [info commands testevalobjv]] +test parse-8.1 {Tcl_EvalObjv procedure} testevalobjv { testevalobjv 0 concat this is a test } {this is a test} -test parse-8.2 {Tcl_EvalObjv procedure, unknown commands} { +test parse-8.2 {Tcl_EvalObjv procedure, unknown commands} testevalobjv { rename unknown unknown.old set x [catch {testevalobjv 10 asdf poiu} msg] rename unknown.old unknown list $x $msg } {1 {invalid command name "asdf"}} -test parse-8.3 {Tcl_EvalObjv procedure, unknown commands} { +test parse-8.3 {Tcl_EvalObjv procedure, unknown commands} testevalobjv { rename unknown unknown.old proc unknown args { return "unknown $args" @@ -237,7 +238,7 @@ test parse-8.3 {Tcl_EvalObjv procedure, unknown commands} { rename unknown.old unknown list $x $msg } {0 {unknown asdf poiu}} -test parse-8.4 {Tcl_EvalObjv procedure, unknown commands} { +test parse-8.4 {Tcl_EvalObjv procedure, unknown commands} testevalobjv { rename unknown unknown.old proc unknown args { error "I don't like that command" @@ -247,11 +248,11 @@ test parse-8.4 {Tcl_EvalObjv procedure, unknown commands} { rename unknown.old unknown list $x $msg } {1 {I don't like that command}} -test parse-8.5 {Tcl_EvalObjv procedure, command traces} { +test parse-8.5 {Tcl_EvalObjv procedure, command traces} testevalobjv { testevalobjv 0 set x 123 testcmdtrace tracetest {testevalobjv 0 set x $x} } {{testevalobjv 0 set x $x} {testevalobjv 0 set x 123} {set x 123} {set x 123}} -test parse-8.7 {Tcl_EvalObjv procedure, TCL_EVAL_GLOBAL flag} { +test parse-8.7 {Tcl_EvalObjv procedure, TCL_EVAL_GLOBAL flag} testevalobjv { proc x {} { set y 23 set z [testevalobjv 1 set y] @@ -261,7 +262,7 @@ test parse-8.7 {Tcl_EvalObjv procedure, TCL_EVAL_GLOBAL flag} { set y 16 x } {16 23} -test parse-8.8 {Tcl_EvalObjv procedure, async handlers} { +test parse-8.8 {Tcl_EvalObjv procedure, async handlers} testevalobjv { proc async1 {result code} { global aresult acode set aresult $result @@ -275,9 +276,43 @@ test parse-8.8 {Tcl_EvalObjv procedure, async handlers} { testasync delete set x } {0 {new result} 0 original} -test parse-8.9 {Tcl_EvalObjv procedure, exceptional return} { +test parse-8.9 {Tcl_EvalObjv procedure, exceptional return} testevalobjv { list [catch {testevalobjv 0 error message} msg] $msg } {1 message} +test parse-8.10 {Tcl_EvalObjv procedure, TCL_EVAL_GLOBAL} testevalobjv { + rename ::unknown unknown.save + proc ::unknown args {lappend ::info [info level]} + catch {rename ::noSuchCommand {}} + set ::info {} + namespace eval test_ns_1 { + testevalobjv 1 noSuchCommand + uplevel #0 noSuchCommand + } + namespace delete test_ns_1 + rename ::unknown {} + rename unknown.save ::unknown + set ::info +} {1 1} +test parse-8.11 {Tcl_EvalObjv procedure, TCL_EVAL_INVOKE} testevalobjv { + rename ::unknown unknown.save + proc ::unknown args {lappend ::info [info level]; uplevel 1 foo} + proc ::foo args {lappend ::info global} + catch {rename ::noSuchCommand {}} + set ::slave [interp create] + $::slave alias bar noSuchCommand + set ::info {} + namespace eval test_ns_1 { + proc foo args {lappend ::info namespace} + $::slave eval bar + testevalobjv 1 [list $::slave eval bar] + uplevel #0 [list $::slave eval bar] + } + namespace delete test_ns_1 + rename ::foo {} + rename ::unknown {} + rename unknown.save ::unknown + set ::info +} [subst {[set level 2; incr level [info level]] namespace 1 global 1 global}] test parse-9.1 {Tcl_LogCommandInfo, line numbers} { catch {unset x} diff --git a/tests/trace.test b/tests/trace.test index 4409fe1..21536ad 100644 --- a/tests/trace.test +++ b/tests/trace.test @@ -11,7 +11,7 @@ # 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.2.14 2005/11/18 23:44:37 msofer Exp $ +# RCS: @(#) $Id: trace.test,v 1.26.2.15 2006/02/28 15:44:36 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -21,6 +21,8 @@ if {[lsearch [namespace children] ::tcltest] == -1} { # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] +testConstraint testevalobjv [llength [info commands testevalobjv]] + proc getbytes {} { set lines [split [memory info] "\n"] lindex [lindex $lines 3] 3 @@ -1590,6 +1592,38 @@ test trace-21.8 {trace execution: leavestep} { set info } {{foo {set b 3} 0 3 leavestep}} +test trace-21.9 {trace execution: TCL_EVAL_GLOBAL} testevalobjv { + trace add execution foo enter soom + proc ::soom args {lappend ::info SUCCESS [info level]} + set ::info {} + namespace eval test_ns_1 { + proc soom args {lappend ::info FAIL [info level]} + # [testevalobjv 1 ...] ought to produce the same + # results as [uplevel #0 ...]. + testevalobjv 1 foo x + uplevel #0 foo x + } + namespace delete test_ns_1 + trace remove execution foo enter soom + set ::info +} {SUCCESS 1 SUCCESS 1} + +test trace-21.10 {trace execution: TCL_EVAL_GLOBAL} testevalobjv { + trace add execution foo leave soom + proc ::soom args {lappend ::info SUCCESS [info level]} + set ::info {} + namespace eval test_ns_1 { + proc soom args {lappend ::info FAIL [info level]} + # [testevalobjv 1 ...] ought to produce the same + # results as [uplevel #0 ...]. + testevalobjv 1 foo x + uplevel #0 foo x + } + namespace delete test_ns_1 + trace remove execution foo leave soom + set ::info +} {SUCCESS 1 SUCCESS 1} + proc factorial {n} { if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] } return 1 |