summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorMiguel Sofer <miguel.sofer@gmail.com>2002-07-29 00:25:48 (GMT)
committerMiguel Sofer <miguel.sofer@gmail.com>2002-07-29 00:25:48 (GMT)
commit8aac5314070c34799ffa1a70feb28b35584bc49a (patch)
tree208b34b62a4fbd5ad2e737a2db9c09e81c11e01d
parent8ad6452f7dc366f56dcb758bea0740353758aa73 (diff)
downloadtcl-8aac5314070c34799ffa1a70feb28b35584bc49a.zip
tcl-8aac5314070c34799ffa1a70feb28b35584bc49a.tar.gz
tcl-8aac5314070c34799ffa1a70feb28b35584bc49a.tar.bz2
Fix for [Bug 582522] - aliases now fire execution traces on the target
command. Optimisation of alias invocation.
-rw-r--r--ChangeLog16
-rw-r--r--generic/tcl.h3
-rw-r--r--generic/tclBasic.c10
-rw-r--r--generic/tclInterp.c157
-rw-r--r--tests/interp.test16
-rw-r--r--tests/stack.test6
-rw-r--r--tests/trace.test29
7 files changed, 136 insertions, 101 deletions
diff --git a/ChangeLog b/ChangeLog
index 2d337fa..fbbc6bd 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,19 @@
+2002-07-28 Miguel Sofer <msofer@users.sourceforge.net>
+
+ * generic/tcl.h:
+ * generic/tclBasic.c: added the new flag TCL_EVAL_NO_TRACEBACK to
+ the interface of the Tcl_Eval* functions. Modified the error
+ message for too many nested evaluations.
+ * generic/tclInterp.h: changed the Alias struct to be of variable
+ length and store the prefix arguments directly (instead of a
+ pointer to a Tcl_Obj list). Made AliasObjCmd call Tcl_EvalObjv
+ instead of TclObjInvoke - thus making aliases trigger execution
+ traces [Bug 582522].
+ * tests/interp.test:
+ * tests/stack.test: adapted to the new error message.
+ * tests/trace.test: added tests for aliases firing the exec
+ traces.
+
2002-07-27 Mo DeJong <mdejong@users.sourceforge.net>
* unix/Makefile.in: Revert fix for Tcl bug 529801
diff --git a/generic/tcl.h b/generic/tcl.h
index 4fc6592..d090013 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.136 2002/07/22 16:51:47 vincentdarley Exp $
+ * RCS: @(#) $Id: tcl.h,v 1.137 2002/07/29 00:25:49 msofer Exp $
*/
#ifndef _TCL
@@ -984,6 +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
/*
* Special freeProc values that may be passed to Tcl_SetResult (see
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index a2d1dcd..ef2a29c 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.65 2002/07/19 12:31:09 dkf Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.66 2002/07/29 00:25:49 msofer Exp $
*/
#include "tclInt.h"
@@ -2876,7 +2876,7 @@ TclInterpReady(interp)
if (((iPtr->numLevels) >= iPtr->maxNestingDepth)
|| (TclpCheckStackSpace() == 0)) {
Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "too many nested calls to Tcl_Eval (infinite loop?)", -1);
+ "too many nested evaluations (infinite loop?)", -1);
return TCL_ERROR;
}
@@ -3101,8 +3101,8 @@ 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 is currently
- * supported. */
+ * TCL_EVAL_GLOBAL and TCL_EVAL_NO_TRACEBACK
+ * are currently supported. */
{
Interp *iPtr = (Interp *)interp;
Trace *tracePtr;
@@ -3158,7 +3158,7 @@ Tcl_EvalObjv(interp, objc, objv, flags)
}
}
- if (code == TCL_ERROR) {
+ if ((code == TCL_ERROR) && !(flags & TCL_EVAL_NO_TRACEBACK)) {
/*
* If there was an error, a command string will be needed for the
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index c522607..65c41d9 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.12 2002/03/07 20:17:22 dgp Exp $
+ * RCS: @(#) $Id: tclInterp.c,v 1.13 2002/07/29 00:25:49 msofer Exp $
*/
#include "tclInt.h"
@@ -35,12 +35,6 @@ typedef struct Alias {
Tcl_Obj *namePtr; /* Name of alias command in slave interp. */
Tcl_Interp *targetInterp; /* Interp in which target command will be
* invoked. */
- Tcl_Obj *prefixPtr; /* Tcl list making up the prefix of the
- * target command to be invoked in the target
- * interpreter. Additional arguments
- * specified when calling the alias in the
- * slave interp will be appended to the prefix
- * before the command is invoked. */
Tcl_Command slaveCmd; /* Source command in slave interpreter,
* bound to command that invokes the target
* command in the target interpreter. */
@@ -56,6 +50,16 @@ typedef struct Alias {
* redirecting to it. Random access to this
* hash table is never required - we are using
* a hash table only for convenience. */
+ unsigned int objc; /* Count of Tcl_Obj in the prefix of the
+ * target command to be invoked in the
+ * target interpreter. Additional arguments
+ * specified when calling the alias in the
+ * slave interp will be appended to the prefix
+ * before the command is invoked. */
+ Tcl_Obj *objPtr; /* The first actual prefix object - the target
+ * command name; this has to be at the end of the
+ * structure, which will be extended to accomodate
+ * the remaining objects in the prefix. */
} Alias;
/*
@@ -945,7 +949,8 @@ Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr,
return TCL_ERROR;
}
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
- Tcl_ListObjGetElements(NULL, aliasPtr->prefixPtr, &objc, &objv);
+ objc = aliasPtr->objc;
+ objv = &aliasPtr->objPtr;
if (targetInterpPtr != NULL) {
*targetInterpPtr = aliasPtr->targetInterp;
@@ -1005,7 +1010,8 @@ Tcl_GetAliasObj(interp, aliasName, targetInterpPtr, targetNamePtr, objcPtr,
return TCL_ERROR;
}
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
- Tcl_ListObjGetElements(NULL, aliasPtr->prefixPtr, &objc, &objv);
+ objc = aliasPtr->objc;
+ objv = &aliasPtr->objPtr;
if (targetInterpPtr != (Tcl_Interp **) NULL) {
*targetInterpPtr = aliasPtr->targetInterp;
@@ -1075,17 +1081,16 @@ TclPreventAliasLoop(interp, cmdInterp, cmd)
aliasPtr = (Alias *) cmdPtr->objClientData;
nextAliasPtr = aliasPtr;
while (1) {
- int objc;
- Tcl_Obj **objv;
+ Tcl_Obj *cmdNamePtr;
/*
* If the target of the next alias in the chain is the same as
* the source alias, we have a loop.
*/
- Tcl_ListObjGetElements(NULL, nextAliasPtr->prefixPtr, &objc, &objv);
+ cmdNamePtr = nextAliasPtr->objPtr;
aliasCmd = Tcl_FindCommand(nextAliasPtr->targetInterp,
- Tcl_GetString(objv[0]),
+ Tcl_GetString(cmdNamePtr),
Tcl_GetGlobalNamespace(nextAliasPtr->targetInterp),
/*flags*/ 0);
if (aliasCmd == (Tcl_Command) NULL) {
@@ -1151,14 +1156,24 @@ AliasCreate(interp, slaveInterp, masterInterp, namePtr, targetNamePtr,
Target *targetPtr;
Slave *slavePtr;
Master *masterPtr;
+ int i;
+ Tcl_Obj **prefv;
- aliasPtr = (Alias *) ckalloc((unsigned) sizeof(Alias));
+ aliasPtr = (Alias *) ckalloc((unsigned) (sizeof(Alias)
+ + objc * sizeof(Tcl_Obj *)));
aliasPtr->namePtr = namePtr;
Tcl_IncrRefCount(aliasPtr->namePtr);
aliasPtr->targetInterp = masterInterp;
- aliasPtr->prefixPtr = Tcl_NewListObj(1, &targetNamePtr);
- Tcl_ListObjReplace(NULL, aliasPtr->prefixPtr, 1, 0, objc, objv);
- Tcl_IncrRefCount(aliasPtr->prefixPtr);
+
+ aliasPtr->objc = objc + 1;
+ prefv = &aliasPtr->objPtr;
+
+ *prefv = targetNamePtr;
+ Tcl_IncrRefCount(targetNamePtr);
+ for (i = 0; i < objc; i++) {
+ *(++prefv) = objv[i];
+ Tcl_IncrRefCount(objv[i]);
+ }
aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp,
Tcl_GetString(namePtr), AliasObjCmd, (ClientData) aliasPtr,
@@ -1175,7 +1190,9 @@ AliasCreate(interp, slaveInterp, masterInterp, namePtr, targetNamePtr,
Command *cmdPtr;
Tcl_DecrRefCount(aliasPtr->namePtr);
- Tcl_DecrRefCount(aliasPtr->prefixPtr);
+ for (i = 0; i < objc; i++) {
+ Tcl_DecrRefCount(objv[i]);
+ }
cmdPtr = (Command *) aliasPtr->slaveCmd;
cmdPtr->clientData = NULL;
@@ -1264,7 +1281,7 @@ static int
AliasDelete(interp, slaveInterp, namePtr)
Tcl_Interp *interp; /* Interpreter for result & errors. */
Tcl_Interp *slaveInterp; /* Interpreter containing alias. */
- Tcl_Obj *namePtr; /* Name of alias to describe. */
+ Tcl_Obj *namePtr; /* Name of alias to delete. */
{
Slave *slavePtr;
Alias *aliasPtr;
@@ -1316,6 +1333,7 @@ AliasDescribe(interp, slaveInterp, namePtr)
Slave *slavePtr;
Tcl_HashEntry *hPtr;
Alias *aliasPtr;
+ Tcl_Obj *prefixPtr;
/*
* If the alias has been renamed in the slave, the master can still use
@@ -1329,7 +1347,8 @@ AliasDescribe(interp, slaveInterp, namePtr)
return TCL_OK;
}
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
- Tcl_SetObjResult(interp, aliasPtr->prefixPtr);
+ prefixPtr = Tcl_NewListObj((int) aliasPtr->objc, &aliasPtr->objPtr);
+ Tcl_SetObjResult(interp, prefixPtr);
return TCL_OK;
}
@@ -1400,84 +1419,51 @@ AliasObjCmd(clientData, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument vector. */
{
+#define ALIAS_CMDV_PREALLOC 10
Tcl_Interp *targetInterp;
Alias *aliasPtr;
int result, prefc, cmdc;
- Tcl_Obj *cmdPtr;
Tcl_Obj **prefv, **cmdv;
-
+ Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC];
aliasPtr = (Alias *) clientData;
targetInterp = aliasPtr->targetInterp;
- Tcl_Preserve((ClientData) targetInterp);
-
- ((Interp *) targetInterp)->numLevels++;
-
- Tcl_ResetResult(targetInterp);
- Tcl_AllowExceptions(targetInterp);
-
- /*
- * Check depth of nested calls with AliasObjCmd: if this gets too large,
- * it's probably because of an infinite loop somewhere.
- */
-
- if (((Interp *) targetInterp)->numLevels >
- ((Interp *) targetInterp)->maxNestingDepth) {
- Tcl_AppendToObj(Tcl_GetObjResult(targetInterp),
- "too many nested calls to AliasObjCmd (infinite loop using alias?)", -1);
- result = TCL_ERROR;
- goto done;
- }
-
/*
* Append the arguments to the command prefix and invoke the command
* in the target interp's global namespace.
*/
- Tcl_ListObjGetElements(NULL, aliasPtr->prefixPtr, &prefc, &prefv);
- cmdPtr = Tcl_NewListObj(prefc, prefv);
- Tcl_ListObjReplace(NULL, cmdPtr, prefc, 0, objc - 1, objv + 1);
- Tcl_ListObjGetElements(NULL, cmdPtr, &cmdc, &cmdv);
- result = TclObjInvoke(targetInterp, cmdc, cmdv,
- TCL_INVOKE_NO_TRACEBACK);
- Tcl_DecrRefCount(cmdPtr);
+ prefc = aliasPtr->objc;
+ prefv = &aliasPtr->objPtr;
+ cmdc = prefc + objc - 1;
+ if (cmdc <= ALIAS_CMDV_PREALLOC) {
+ cmdv = cmdArr;
+ } else {
+ cmdv = (Tcl_Obj **) ckalloc((unsigned) (cmdc * sizeof(Tcl_Obj *)));
+ }
- /*
- * Check if we are at the bottom of the stack for the target interpreter.
- * If so, check for special return codes.
- */
-
- if (((Interp *) targetInterp)->numLevels == 0) {
- if (result == TCL_RETURN) {
- result = TclUpdateReturnInfo((Interp *) targetInterp);
- }
- if ((result != TCL_OK) && (result != TCL_ERROR)) {
- Tcl_ResetResult(targetInterp);
- if (result == TCL_BREAK) {
- Tcl_SetObjResult(targetInterp,
- Tcl_NewStringObj("invoked \"break\" outside of a loop",
- -1));
- } else if (result == TCL_CONTINUE) {
- Tcl_SetObjResult(targetInterp,
- Tcl_NewStringObj(
- "invoked \"continue\" outside of a loop",
- -1));
- } else {
- char buf[32 + TCL_INTEGER_SPACE];
-
- sprintf(buf, "command returned bad code: %d", result);
- Tcl_SetObjResult(targetInterp, Tcl_NewStringObj(buf, -1));
- }
- result = TCL_ERROR;
- }
+ prefv = &aliasPtr->objPtr;
+ memcpy((VOID *) cmdv, (VOID *) prefv,
+ (size_t) (prefc * sizeof(Tcl_Obj *)));
+ memcpy((VOID *) (cmdv+prefc), (VOID *) (objv+1),
+ (size_t) ((objc-1) * sizeof(Tcl_Obj *)));
+
+ Tcl_ResetResult(targetInterp);
+
+ if (targetInterp != interp) {
+ Tcl_Preserve((ClientData) targetInterp);
+ result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_NO_TRACEBACK);
+ TclTransferResult(targetInterp, result, interp);
+ Tcl_Release((ClientData) targetInterp);
+ } else {
+ result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_NO_TRACEBACK);
}
- done:
- ((Interp *) targetInterp)->numLevels--;
-
- TclTransferResult(targetInterp, result, interp);
- Tcl_Release((ClientData) targetInterp);
+ if (cmdv != cmdArr) {
+ ckfree((char *) cmdv);
+ }
return result;
+#undef ALIAS_CMDV_PREALLOC
}
/*
@@ -1504,11 +1490,16 @@ AliasObjCmdDeleteProc(clientData)
{
Alias *aliasPtr;
Target *targetPtr;
+ int i;
+ Tcl_Obj **objv;
aliasPtr = (Alias *) clientData;
Tcl_DecrRefCount(aliasPtr->namePtr);
- Tcl_DecrRefCount(aliasPtr->prefixPtr);
+ objv = &aliasPtr->objPtr;
+ for (i = 0; i < aliasPtr->objc; i++) {
+ Tcl_DecrRefCount(objv[i]);
+ }
Tcl_DeleteHashEntry(aliasPtr->aliasEntryPtr);
targetPtr = (Target *) Tcl_GetHashValue(aliasPtr->targetEntryPtr);
diff --git a/tests/interp.test b/tests/interp.test
index f82151e..d5699cd 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.15 2002/07/01 07:52:03 dgp Exp $
+# RCS: @(#) $Id: interp.test,v 1.16 2002/07/29 00:25:49 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -2433,7 +2433,7 @@ test interp-29.3.1 {recursion limit} {
}]
interp delete $i
set r
-} {1 {too many nested calls to Tcl_Eval (infinite loop?)} 48}
+} {1 {too many nested evaluations (infinite loop?)} 48}
test interp-29.3.2 {recursion limit} {
set i [interp create]
@@ -2445,7 +2445,7 @@ test interp-29.3.2 {recursion limit} {
}]
interp delete $i
set r
-} {1 {too many nested calls to Tcl_Eval (infinite loop?)} 48}
+} {1 {too many nested evaluations (infinite loop?)} 48}
test interp-29.3.3 {recursion limit} {
set i [interp create]
@@ -2457,7 +2457,7 @@ test interp-29.3.3 {recursion limit} {
}]
interp delete $i
set r
-} {1 {too many nested calls to Tcl_Eval (infinite loop?)} 48}
+} {1 {too many nested evaluations (infinite loop?)} 48}
test interp-29.3.4 {recursion limit error reporting} {
interp create slave
@@ -2542,7 +2542,7 @@ test interp-29.3.7 {recursion limit error reporting} {
set r2 [slave eval { set msg }]
interp delete slave
list $r1 $r2
-} {1 {too many nested calls to Tcl_Eval (infinite loop?)}}
+} {1 {too many nested evaluations (infinite loop?)}}
test interp-29.3.8 {recursion limit error reporting} {
interp create slave
@@ -2564,7 +2564,7 @@ test interp-29.3.8 {recursion limit error reporting} {
set r2 [slave eval { set msg }]
interp delete slave
list $r1 $r2
-} {1 {too many nested calls to Tcl_Eval (infinite loop?)}}
+} {1 {too many nested evaluations (infinite loop?)}}
test interp-29.3.9 {recursion limit error reporting} {
interp create slave
@@ -2608,7 +2608,7 @@ test interp-29.3.10 {recursion limit error reporting} {
set r2 [slave eval { set msg }]
interp delete slave
list $r1 $r2
-} {1 {too many nested calls to Tcl_Eval (infinite loop?)}}
+} {1 {too many nested evaluations (infinite loop?)}}
test interp-29.3.11 {recursion limit error reporting} {
interp create slave
@@ -2630,7 +2630,7 @@ test interp-29.3.11 {recursion limit error reporting} {
set r2 [slave eval { set msg }]
interp delete slave
list $r1 $r2
-} {1 {too many nested calls to Tcl_Eval (infinite loop?)}}
+} {1 {too many nested evaluations (infinite loop?)}}
test interp-29.3.12 {recursion limit error reporting} {
interp create slave
diff --git a/tests/stack.test b/tests/stack.test
index 8d07bfb..828352b 100644
--- a/tests/stack.test
+++ b/tests/stack.test
@@ -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: stack.test,v 1.14 2002/06/22 04:19:47 dgp Exp $
+# RCS: @(#) $Id: stack.test,v 1.15 2002/07/29 00:25:49 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -43,7 +43,7 @@ test stack-1.1 {maxNestingDepth reached on infinite recursion} {minStack2400} {
catch {recurse} rv
rename recurse {}
set rv
-} {too many nested calls to Tcl_Eval (infinite loop?)}
+} {too many nested evaluations (infinite loop?)}
test stack-2.1 {maxNestingDepth reached on infinite recursion} {minStack2400} {
# do this in a slave to not mess with parent
@@ -53,7 +53,7 @@ test stack-2.1 {maxNestingDepth reached on infinite recursion} {minStack2400} {
set msg [$slave eval { catch {foo} msg ; set msg }]
interp delete $slave
set msg
-} {too many nested calls to AliasObjCmd (infinite loop using alias?)}
+} {too many nested evaluations (infinite loop?)}
# cleanup
::tcltest::cleanupTests
diff --git a/tests/trace.test b/tests/trace.test
index 2229b69..10c70c9 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.20 2002/07/18 13:37:46 msofer Exp $
+# RCS: @(#) $Id: trace.test,v 1.21 2002/07/29 00:25:50 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -1805,6 +1805,32 @@ test trace-25.11 {delete command during enter and enterstep traces} {
list $err $info [trace info execution foo]
} {{invalid command name "foo"} {{foo 1} enter} {unknown command "foo"}}
+test trace-26.1 {trace targetCmd when invoked through an alias} {
+ proc foo {args} {
+ set b $args
+ }
+ set info {}
+ trace add execution foo enter [list traceExecute foo]
+ interp alias {} bar {} foo 1
+ bar 2
+ trace remove execution foo enter [list traceExecute foo]
+ set info
+} {{foo {foo 1 2} enter}}
+test trace-26.2 {trace targetCmd when invoked through an alias} {
+ proc foo {args} {
+ set b $args
+ }
+ set info {}
+ trace add execution foo enter [list traceExecute foo]
+ interp create child
+ interp alias child bar {} foo 1
+ child eval bar 2
+ interp delete child
+ trace remove execution foo enter [list traceExecute foo]
+ set info
+} {{foo {foo 1 2} enter}}
+
+
# Delete procedures when done, so we don't clash with other tests
# (e.g. foobar will clash with 'unknown' tests).
catch {rename foobar {}}
@@ -1814,3 +1840,4 @@ catch {rename bar {}}
# cleanup
::tcltest::cleanupTests
return
+