Attachment "1439836.patch" to
ticket [1439836fff]
added by
dgp
2006-02-28 06:49:11.
Index: generic/tclBasic.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBasic.c,v
retrieving revision 1.75.2.19
diff -u -r1.75.2.19 tclBasic.c
--- generic/tclBasic.c 18 Nov 2005 23:07:26 -0000 1.75.2.19
+++ generic/tclBasic.c 27 Feb 2006 23:46:44 -0000
@@ -3034,7 +3034,8 @@
code = TCL_ERROR;
} else {
iPtr->numLevels++;
- code = TclEvalObjvInternal(interp, objc+1, newObjv, command, length, 0);
+ code = TclEvalObjvInternal(interp, objc+1, newObjv,
+ command, length, flags);
iPtr->numLevels--;
}
Tcl_DecrRefCount(newObjv[0]);
@@ -3053,6 +3054,10 @@
* any existing traces, then the set checkTraces to 0 and
* go through this while loop one more time.
*/
+ savedVarFramePtr = iPtr->varFramePtr;
+ 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);
@@ -3062,6 +3067,7 @@
traceCode = TclCheckExecutionTraces(interp, command, length,
cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv);
}
+ iPtr->varFramePtr = savedVarFramePtr;
cmdPtr->refCount--;
if (cmdEpoch != cmdPtr->cmdEpoch) {
/* The command has been modified in some way */
@@ -3095,6 +3101,10 @@
if (!(cmdPtr->flags & CMD_IS_DELETED)) {
int saveErrFlags = iPtr->flags
& (ERR_IN_PROGRESS | ERR_ALREADY_LOGGED | ERROR_CODE_SET);
+ savedVarFramePtr = iPtr->varFramePtr;
+ 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);
@@ -3103,6 +3113,7 @@
traceCode = TclCheckInterpTraces(interp, command, length,
cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv);
}
+ iPtr->varFramePtr = savedVarFramePtr;
if (traceCode == TCL_OK) {
iPtr->flags |= saveErrFlags;
}
Index: tests/parse.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/parse.test,v
retrieving revision 1.11.2.2
diff -u -r1.11.2.2 parse.test
--- tests/parse.test 18 Mar 2005 16:33:43 -0000 1.11.2.2
+++ tests/parse.test 27 Feb 2006 23:46:44 -0000
@@ -11,7 +11,7 @@
# RCS: @(#) $Id: parse.test,v 1.11.2.2 2005/03/18 16:33:43 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
+ package require tcltest 2
namespace import -force ::tcltest::*
}
@@ -218,16 +218,17 @@
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 @@
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 @@
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 @@
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 @@
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}
Index: tests/trace.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/trace.test,v
retrieving revision 1.26.2.14
diff -u -r1.26.2.14 trace.test
--- tests/trace.test 18 Nov 2005 23:44:37 -0000 1.26.2.14
+++ tests/trace.test 27 Feb 2006 23:46:45 -0000
@@ -21,6 +21,8 @@
# 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 @@
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
