summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorMiguel Sofer <miguel.sofer@gmail.com>2002-07-29 15:56:53 (GMT)
committerMiguel Sofer <miguel.sofer@gmail.com>2002-07-29 15:56:53 (GMT)
commit75164b5a8a9172465a393abd3e3a6d9c7674e7d8 (patch)
tree3f080f45cb9304d12e125a5dcda51cac698ad730
parentedeb2f602f676509e74e81b4d65bb966dc28e395 (diff)
downloadtcl-75164b5a8a9172465a393abd3e3a6d9c7674e7d8.zip
tcl-75164b5a8a9172465a393abd3e3a6d9c7674e7d8.tar.gz
tcl-75164b5a8a9172465a393abd3e3a6d9c7674e7d8.tar.bz2
bugfix, new tests for new [interp alias] code
-rw-r--r--ChangeLog12
-rw-r--r--generic/tcl.h4
-rw-r--r--generic/tclBasic.c18
-rw-r--r--generic/tclInterp.c6
-rw-r--r--generic/tclObj.c7
-rw-r--r--tests/interp.test28
6 files changed, 58 insertions, 17 deletions
diff --git a/ChangeLog b/ChangeLog
index 96a4453..ac4c9a5 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,15 @@
+2002-07-29 Miguel Sofer <msofer@users.sourceforge.net>
+
+ * generic/tcl.h:
+ * generic/tclBasic.c:
+ * generic/tclInterp.c: added the new flag TCL_EVAL_INVOKE to
+ the interface of the Tcl_Eval* functions, removing the
+ TCL_EVAL_NO_TRACEBACK added yesterday: alias invocations not only
+ require no tracebacks, but also look up the command name in the
+ global scope - see new test interp-9.4
+ * tests/interp.test: added 9.3 to test for safety of aliases to
+ hidden commands, 9.4 to test for correct command lookup scope.
+
2002-07-29 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* generic/regc_locale.c (cclass): [[:xdigit:]] is only a defined
diff --git a/generic/tcl.h b/generic/tcl.h
index d090013..3e6e19c 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -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: tcl.h,v 1.137 2002/07/29 00:25:49 msofer Exp $
+ * RCS: @(#) $Id: tcl.h,v 1.138 2002/07/29 15:56:53 msofer Exp $
*/
#ifndef _TCL
@@ -984,7 +984,7 @@ typedef struct Tcl_DString {
#define TCL_NO_EVAL 0x10000
#define TCL_EVAL_GLOBAL 0x20000
#define TCL_EVAL_DIRECT 0x40000
-#define TCL_EVAL_NO_TRACEBACK 0x80000
+#define TCL_EVAL_INVOKE 0x80000
/*
* Special freeProc values that may be passed to Tcl_SetResult (see
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index ef2a29c..e927654 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.66 2002/07/29 00:25:49 msofer Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.67 2002/07/29 15:56:53 msofer Exp $
*/
#include "tclInt.h"
@@ -2926,8 +2926,8 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags)
* used. */
int flags; /* Collection of OR-ed bits that control
* the evaluation of the script. Only
- * TCL_EVAL_GLOBAL is currently
- * supported. */
+ * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE are
+ * currently supported. */
{
Command *cmdPtr;
@@ -2957,8 +2957,14 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags)
* command words as arguments. Then call ourselves recursively
* to execute it.
*/
-
+
+ savedVarFramePtr = iPtr->varFramePtr;
+ if (flags & TCL_EVAL_INVOKE) {
+ iPtr->varFramePtr = NULL;
+ }
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
+ iPtr->varFramePtr = savedVarFramePtr;
+
if (cmdPtr == NULL) {
newObjv = (Tcl_Obj **) ckalloc((unsigned)
((objc + 1) * sizeof (Tcl_Obj *)));
@@ -3101,7 +3107,7 @@ Tcl_EvalObjv(interp, objc, objv, flags)
* the words that make up the command. */
int flags; /* Collection of OR-ed bits that control
* the evaluation of the script. Only
- * TCL_EVAL_GLOBAL and TCL_EVAL_NO_TRACEBACK
+ * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE
* are currently supported. */
{
Interp *iPtr = (Interp *)interp;
@@ -3158,7 +3164,7 @@ Tcl_EvalObjv(interp, objc, objv, flags)
}
}
- if ((code == TCL_ERROR) && !(flags & TCL_EVAL_NO_TRACEBACK)) {
+ if ((code == TCL_ERROR) && !(flags & TCL_EVAL_INVOKE)) {
/*
* If there was an error, a command string will be needed for the
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 65c41d9..06d81fe 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInterp.c,v 1.13 2002/07/29 00:25:49 msofer Exp $
+ * RCS: @(#) $Id: tclInterp.c,v 1.14 2002/07/29 15:56:54 msofer Exp $
*/
#include "tclInt.h"
@@ -1452,11 +1452,11 @@ AliasObjCmd(clientData, interp, objc, objv)
if (targetInterp != interp) {
Tcl_Preserve((ClientData) targetInterp);
- result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_NO_TRACEBACK);
+ result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE);
TclTransferResult(targetInterp, result, interp);
Tcl_Release((ClientData) targetInterp);
} else {
- result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_NO_TRACEBACK);
+ result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE);
}
if (cmdv != cmdArr) {
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 9dc2b90..926fa9f 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -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: tclObj.c,v 1.33 2002/04/26 08:34:35 dkf Exp $
+ * RCS: @(#) $Id: tclObj.c,v 1.34 2002/07/29 15:56:54 msofer Exp $
*/
#include "tclInt.h"
@@ -2852,9 +2852,8 @@ Tcl_GetCommandFromObj(interp, objPtr)
register Tcl_Obj *objPtr; /* The object containing the command's
* name. If the name starts with "::", will
* be looked up in global namespace. Else,
- * looked up first in the current namespace
- * if contextNsPtr is NULL, then in global
- * namespace. */
+ * looked up first in the current namespace,
+ * then in global namespace. */
{
Interp *iPtr = (Interp *) interp;
register ResolvedCmdName *resPtr;
diff --git a/tests/interp.test b/tests/interp.test
index d5699cd..b05454f 100644
--- a/tests/interp.test
+++ b/tests/interp.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: interp.test,v 1.16 2002/07/29 00:25:49 msofer Exp $
+# RCS: @(#) $Id: interp.test,v 1.17 2002/07/29 15:56:54 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -280,7 +280,7 @@ test interp-8.3 {testing basic alias invocation} {
list [catch {a alias} msg] $msg
} {1 {wrong # args: should be "a alias aliasName ?targetName? ?args..?"}}
-# Part 8: Testing aliases for non-existent targets
+# Part 8: Testing aliases for non-existent or hidden targets
test interp-9.1 {testing aliases for non-existent targets} {
catch {interp create a}
a alias zop nonexistent-command-in-master
@@ -292,6 +292,30 @@ test interp-9.2 {testing aliases for non-existent targets} {
proc nonexistent-command-in-master {} {return i_exist!}
a eval zop
} i_exist!
+test interp-9.3 {testing aliases for hidden commands} {
+ catch {interp create a}
+ a eval {proc p {} {return ENTER_A}}
+ interp alias {} p a p
+ lappend res [list [catch p msg] $msg]
+ interp hide a p
+ lappend res [list [catch p msg] $msg]
+ rename p {}
+ interp delete a
+ set res
+ } {{0 ENTER_A} {1 {invalid command name "p"}}}
+test interp-9.4 {testing aliases and namespace commands} {
+ proc p {} {return GLOBAL}
+ namespace eval tst {
+ proc p {} {return NAMESPACE}
+ }
+ interp alias {} a {} p
+ set res [a]
+ lappend res [namespace eval tst a]
+ rename p {}
+ rename a {}
+ namespace delete tst
+ set res
+ } {GLOBAL GLOBAL}
if {[info command nonexistent-command-in-master] != ""} {
rename nonexistent-command-in-master {}