Fix for [Bug 582522] - aliases now fire execution traces on the target

command. Optimisation of alias invocation.

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
+