summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2006-02-28 15:47:10 (GMT)
committerdgp <dgp@users.sourceforge.net>2006-02-28 15:47:10 (GMT)
commitee4fdde97a86a54e979eba422b462f0c45ae9121 (patch)
tree60936ebfe7abee67de474ed25fe62f127d92aee8
parent79c06cebc59a8bb6423c763367e84015e5fb0322 (diff)
downloadtcl-ee4fdde97a86a54e979eba422b462f0c45ae9121.zip
tcl-ee4fdde97a86a54e979eba422b462f0c45ae9121.tar.gz
tcl-ee4fdde97a86a54e979eba422b462f0c45ae9121.tar.bz2
* generic/tclBasic.c: Corrections to be sure that TCL_EVAL_GLOBAL
* tests/namespace.test: evaluations act the same as [uplevel #0] * tests/parse.test: evaluations, even when execution traces or * tests/trace.test: invocations of [::unknown] are present. [Bug 1439836].
-rw-r--r--ChangeLog8
-rw-r--r--generic/tclBasic.c10
-rw-r--r--tests/namespace.test11
-rw-r--r--tests/parse.test36
-rw-r--r--tests/trace.test35
5 files changed, 92 insertions, 8 deletions
diff --git a/ChangeLog b/ChangeLog
index 7e446d4..912cc06 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,11 @@
+2006-02-28 Don Porter <dgp@users.sourceforge.net>
+
+ * generic/tclBasic.c: Corrections to be sure that TCL_EVAL_GLOBAL
+ * tests/namespace.test: evaluations act the same as [uplevel #0]
+ * tests/parse.test: evaluations, even when execution traces or
+ * tests/trace.test: invocations of [::unknown] are present.
+ [Bug 1439836].
+
2006-02-22 Don Porter <dgp@users.sourceforge.net>
* generic/tclBasic.c: Corrected a few bugs in how [namespace unknown]
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 7744858..dcfedc4 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclBasic.c,v 1.191 2006/02/22 17:42:04 dgp Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.192 2006/02/28 15:47:10 dgp Exp $
*/
#include "tclInt.h"
@@ -3348,6 +3348,9 @@ TclEvalObjvInternal(
* while loop one more time.
*/
+ if (flags & TCL_EVAL_GLOBAL) {
+ iPtr->varFramePtr = NULL;
+ }
if (iPtr->tracePtr != NULL && traceCode == TCL_OK) {
traceCode = TclCheckInterpTraces(interp, command, length,
cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv);
@@ -3356,6 +3359,7 @@ TclEvalObjvInternal(
traceCode = TclCheckExecutionTraces(interp, command, length,
cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv);
}
+ iPtr->varFramePtr = savedVarFramePtr;
cmdPtr->refCount--;
}
if (cmdEpoch != cmdPtr->cmdEpoch) {
@@ -3400,6 +3404,9 @@ TclEvalObjvInternal(
*/
if (!(cmdPtr->flags & CMD_IS_DELETED)) {
+ if (flags & TCL_EVAL_GLOBAL) {
+ iPtr->varFramePtr = NULL;
+ }
if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) {
traceCode = TclCheckExecutionTraces(interp, command, length,
cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv);
@@ -3408,6 +3415,7 @@ TclEvalObjvInternal(
traceCode = TclCheckInterpTraces(interp, command, length,
cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv);
}
+ iPtr->varFramePtr = savedVarFramePtr;
}
TclCleanupCommand(cmdPtr);
diff --git a/tests/namespace.test b/tests/namespace.test
index f6092cc..00f5243 100644
--- a/tests/namespace.test
+++ b/tests/namespace.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: namespace.test,v 1.55 2006/02/27 19:43:58 dgp Exp $
+# RCS: @(#) $Id: namespace.test,v 1.56 2006/02/28 15:47:10 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -2545,18 +2545,19 @@ test namespace-52.11 {unknown: with TCL_EVAL_INVOKE} -setup {
}
}
catch {rename ::noSuchCommand {}}
- set slave [interp create]
+ set ::slave [interp create]
} -body {
- $slave alias bar noSuchCommand
+ $::slave alias bar noSuchCommand
namespace eval test_ns_1 {
namespace unknown unknown
proc unknown args {
return FAIL
}
- $slave eval bar
+ $::slave eval bar
}
} -cleanup {
- interp delete $slave
+ interp delete $::slave
+ unset ::slave
namespace delete test_ns_1
rename ::unknown {}
rename unknown.save ::unknown
diff --git a/tests/parse.test b/tests/parse.test
index 8481a6f..fa1f344 100644
--- a/tests/parse.test
+++ b/tests/parse.test
@@ -8,7 +8,7 @@
# 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.21 2005/05/10 18:35:22 kennykb Exp $
+# RCS: @(#) $Id: parse.test,v 1.22 2006/02/28 15:47:10 dgp Exp $
if {[catch {package require tcltest 2.0.2}]} {
puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
@@ -365,6 +365,40 @@ test parse-8.8 {Tcl_EvalObjv procedure, async handlers} -constraints {
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} testevalex {
catch {unset x}
diff --git a/tests/trace.test b/tests/trace.test
index 7766431..657c86a 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.47 2005/11/18 23:42:12 msofer Exp $
+# RCS: @(#) $Id: trace.test,v 1.48 2006/02/28 15:47:10 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -19,6 +19,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
}
testConstraint testcmdtrace [llength [info commands testcmdtrace]]
+testConstraint testevalobjv [llength [info commands testevalobjv]]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
@@ -1594,6 +1595,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