From aea6c6f98570eb34604011e06d7fc4d5b9cc256a Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 28 Feb 2006 15:44:35 +0000 Subject: * generic/tclBasic.c: Corrections to be sure that TCL_EVAL_GLOBAL * tests/parse.test: evaluations act the same as [uplevel #0] * tests/trace.test: evaluations, even when execution traces or invocations of [::unknown] are present. [Bug 1439836]. --- ChangeLog | 7 +++++++ generic/tclBasic.c | 15 +++++++++++++-- tests/parse.test | 55 ++++++++++++++++++++++++++++++++++++++++++++---------- tests/trace.test | 36 ++++++++++++++++++++++++++++++++++- 4 files changed, 100 insertions(+), 13 deletions(-) diff --git a/ChangeLog b/ChangeLog index 7ab9659..4b00641 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2006-02-28 Don Porter + + * generic/tclBasic.c: Corrections to be sure that TCL_EVAL_GLOBAL + * tests/parse.test: evaluations act the same as [uplevel #0] + * tests/trace.test: evaluations, even when execution traces or + invocations of [::unknown] are present. [Bug 1439836]. + 2006-02-16 Don Porter * generic/tclIndexObj.c: Disallow the "ambiguous" error message diff --git a/generic/tclBasic.c b/generic/tclBasic.c index b3474bb..f70af71 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.75.2.19 2005/11/18 23:07:26 msofer Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.75.2.20 2006/02/28 15:44:35 dgp Exp $ */ #include "tclInt.h" @@ -3034,7 +3034,8 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags) 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 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags) * 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 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags) 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 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags) 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 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags) traceCode = TclCheckInterpTraces(interp, command, length, cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv); } + iPtr->varFramePtr = savedVarFramePtr; if (traceCode == TCL_OK) { iPtr->flags |= saveErrFlags; } 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 -- cgit v0.12