Merge up to the 8.6.0 release.

1 files changed, 94 insertions, 58 deletions

diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index 2e8759e..519f201 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.c
@@ -10,8 +10,6 @@
  *
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * RCS: @(#) $Id: tclTrace.c,v 1.60 2010/08/22 18:53:26 nijtmans Exp $
  */
 
 #include "tclInt.h"
@@ -24,11 +22,11 @@ typedef struct {
     int flags;			/* Operations for which Tcl command is to be
 				 * invoked. */
     size_t length;		/* Number of non-NUL chars. in command. */
-    char command[4];		/* Space for Tcl command to invoke. Actual
+    char command[1];		/* Space for Tcl command to invoke. Actual
 				 * size will be as large as necessary to hold
 				 * command. This field must be the last in the
-				 * structure, so that it can be larger than 4
-				 * bytes. */
+				 * structure, so that it can be larger than 1
+				 * byte. */
 } TraceVarInfo;
 
 typedef struct {
@@ -58,11 +56,11 @@ typedef struct {
 				 * deleted too early. Keeps track of how many
 				 * pieces of code have a pointer to this
 				 * structure. */
-    char command[4];		/* Space for Tcl command to invoke. Actual
+    char command[1];		/* Space for Tcl command to invoke. Actual
 				 * size will be as large as necessary to hold
 				 * command. This field must be the last in the
-				 * structure, so that it can be larger than 4
-				 * bytes. */
+				 * structure, so that it can be larger than 1
+				 * byte. */
 } TraceCommandInfo;
 
 /*
@@ -115,7 +113,7 @@ static const char *const traceTypeOptions[] = {
 static Tcl_TraceTypeObjCmd *const traceSubCmds[] = {
     TraceExecutionObjCmd,
     TraceCommandObjCmd,
-    TraceVariableObjCmd,
+    TraceVariableObjCmd
 };
 
 /*
@@ -368,8 +366,10 @@ Tcl_TraceObjCmd(
     return TCL_OK;
 
   badVarOps:
-    Tcl_AppendResult(interp, "bad operations \"", flagOps,
-	    "\": should be one or more of rwua", NULL);
+    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+	    "bad operations \"%s\": should be one or more of rwua",
+	    flagOps));
+    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "BADOPS", NULL);
     return TCL_ERROR;
 }
 
@@ -435,9 +435,11 @@ TraceExecutionObjCmd(
 	    return result;
 	}
 	if (listLen == 0) {
-	    Tcl_SetResult(interp, "bad operation list \"\": must be "
-		    "one or more of enter, leave, enterstep, or leavestep",
-		    TCL_STATIC);
+	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		    "bad operation list \"\": must be one or more of"
+		    " enter, leave, enterstep, or leavestep", -1));
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
+		    NULL);
 	    return TCL_ERROR;
 	}
 	for (i = 0; i < listLen; i++) {
@@ -463,9 +465,8 @@ TraceExecutionObjCmd(
 	command = Tcl_GetStringFromObj(objv[5], &commandLength);
 	length = (size_t) commandLength;
 	if ((enum traceOptions) optionIndex == TRACE_ADD) {
-	    TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)
-		    ckalloc((unsigned) (sizeof(TraceCommandInfo)
-			    - sizeof(tcmdPtr->command) + length + 1));
+	    TraceCommandInfo *tcmdPtr = ckalloc(
+		    TclOffset(TraceCommandInfo, command) + 1 + length);
 
 	    tcmdPtr->flags = flags;
 	    tcmdPtr->stepTrace = NULL;
@@ -482,7 +483,7 @@ TraceExecutionObjCmd(
 	    name = Tcl_GetString(objv[3]);
 	    if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc,
 		    tcmdPtr) != TCL_OK) {
-		ckfree((char *) tcmdPtr);
+		ckfree(tcmdPtr);
 		return TCL_ERROR;
 	    }
 	} else {
@@ -533,7 +534,7 @@ TraceExecutionObjCmd(
 			Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
 			tcmdPtr->stepTrace = NULL;
 			if (tcmdPtr->startCmd != NULL) {
-			    ckfree((char *) tcmdPtr->startCmd);
+			    ckfree(tcmdPtr->startCmd);
 			}
 		    }
 		    if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
@@ -544,7 +545,7 @@ TraceExecutionObjCmd(
 			tcmdPtr->flags = 0;
 		    }
 		    if ((--tcmdPtr->refCount) <= 0) {
-			ckfree((char *) tcmdPtr);
+			ckfree(tcmdPtr);
 		    }
 		    break;
 		}
@@ -677,8 +678,11 @@ TraceCommandObjCmd(
 	    return result;
 	}
 	if (listLen == 0) {
-	    Tcl_SetResult(interp, "bad operation list \"\": must be "
-		    "one or more of delete or rename", TCL_STATIC);
+	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		    "bad operation list \"\": must be one or more of"
+		    " delete or rename", -1));
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
+		    NULL);
 	    return TCL_ERROR;
 	}
 
@@ -700,9 +704,8 @@ TraceCommandObjCmd(
 	command = Tcl_GetStringFromObj(objv[5], &commandLength);
 	length = (size_t) commandLength;
 	if ((enum traceOptions) optionIndex == TRACE_ADD) {
-	    TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)
-		    ckalloc((unsigned) (sizeof(TraceCommandInfo)
-			    - sizeof(tcmdPtr->command) + length + 1));
+	    TraceCommandInfo *tcmdPtr = ckalloc(
+		    TclOffset(TraceCommandInfo, command) + 1 + length);
 
 	    tcmdPtr->flags = flags;
 	    tcmdPtr->stepTrace = NULL;
@@ -715,7 +718,7 @@ TraceCommandObjCmd(
 	    name = Tcl_GetString(objv[3]);
 	    if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc,
 		    tcmdPtr) != TCL_OK) {
-		ckfree((char *) tcmdPtr);
+		ckfree(tcmdPtr);
 		return TCL_ERROR;
 	    }
 	} else {
@@ -746,7 +749,7 @@ TraceCommandObjCmd(
 			    TraceCommandProc, clientData);
 		    tcmdPtr->flags |= TCL_TRACE_DESTROYED;
 		    if ((--tcmdPtr->refCount) <= 0) {
-			ckfree((char *) tcmdPtr);
+			ckfree(tcmdPtr);
 		    }
 		    break;
 		}
@@ -874,8 +877,11 @@ TraceVariableObjCmd(
 	    return result;
 	}
 	if (listLen == 0) {
-	    Tcl_SetResult(interp, "bad operation list \"\": must be "
-		    "one or more of array, read, unset, or write", TCL_STATIC);
+	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		    "bad operation list \"\": must be one or more of"
+		    " array, read, unset, or write", -1));
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
+		    NULL);
 	    return TCL_ERROR;
 	}
 	for (i = 0; i < listLen ; i++) {
@@ -901,9 +907,9 @@ TraceVariableObjCmd(
 	command = Tcl_GetStringFromObj(objv[5], &commandLength);
 	length = (size_t) commandLength;
 	if ((enum traceOptions) optionIndex == TRACE_ADD) {
-	    CombinedTraceVarInfo *ctvarPtr = (CombinedTraceVarInfo *)
-		    ckalloc((unsigned) (sizeof(CombinedTraceVarInfo)
-		    + length + 1 - sizeof(ctvarPtr->traceCmdInfo.command)));
+	    CombinedTraceVarInfo *ctvarPtr = ckalloc(
+		    TclOffset(CombinedTraceVarInfo, traceCmdInfo.command)
+		    + 1 + length);
 
 	    ctvarPtr->traceCmdInfo.flags = flags;
 	    if (objv[0] == NULL) {
@@ -918,7 +924,7 @@ TraceVariableObjCmd(
 	    name = Tcl_GetString(objv[3]);
 	    if (TraceVarEx(interp, name, NULL, (VarTrace *) ctvarPtr)
 		    != TCL_OK) {
-		ckfree((char *) ctvarPtr);
+		ckfree(ctvarPtr);
 		return TCL_ERROR;
 	    }
 	} else {
@@ -1112,7 +1118,7 @@ Tcl_TraceCommand(
      * Set up trace information.
      */
 
-    tracePtr = (CommandTrace *) ckalloc(sizeof(CommandTrace));
+    tracePtr = ckalloc(sizeof(CommandTrace));
     tracePtr->traceProc = proc;
     tracePtr->clientData = clientData;
     tracePtr->flags = flags &
@@ -1121,8 +1127,18 @@ Tcl_TraceCommand(
     tracePtr->refCount = 1;
     cmdPtr->tracePtr = tracePtr;
     if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
+	/*
+	 * Bug 3484621: up the interp's epoch if this is a BC'ed command
+	 */
+	
+	if ((cmdPtr->compileProc != NULL) && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES)){
+	    Interp *iPtr = (Interp *) interp;
+	    iPtr->compileEpoch++;
+	}
 	cmdPtr->flags |= CMD_HAS_EXEC_TRACES;
     }
+
+    
     return TCL_OK;
 }
 
@@ -1208,7 +1224,7 @@ Tcl_UntraceCommand(
     tracePtr->flags = 0;
 
     if ((--tracePtr->refCount) <= 0) {
-	ckfree((char *) tracePtr);
+	ckfree(tracePtr);
     }
 
     if (hasExecTraces) {
@@ -1225,6 +1241,15 @@ Tcl_UntraceCommand(
 	 */
 
 	cmdPtr->flags &= ~CMD_HAS_EXEC_TRACES;
+
+        /*
+	 * Bug 3484621: up the interp's epoch if this is a BC'ed command
+	 */
+	
+	if (cmdPtr->compileProc != NULL) {
+	    Interp *iPtr = (Interp *) interp;
+	    iPtr->compileEpoch++;
+	}
     }
 }
 
@@ -1276,9 +1301,9 @@ TraceCommandProc(
 	Tcl_DStringAppendElement(&cmd, oldName);
 	Tcl_DStringAppendElement(&cmd, (newName ? newName : ""));
 	if (flags & TCL_TRACE_RENAME) {
-	    Tcl_DStringAppend(&cmd, " rename", 7);
+	    TclDStringAppendLiteral(&cmd, " rename");
 	} else if (flags & TCL_TRACE_DELETE) {
-	    Tcl_DStringAppend(&cmd, " delete", 7);
+	    TclDStringAppendLiteral(&cmd, " delete");
 	}
 
 	/*
@@ -1315,7 +1340,7 @@ TraceCommandProc(
 	    Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
 	    tcmdPtr->stepTrace = NULL;
 	    if (tcmdPtr->startCmd != NULL) {
-		ckfree((char *) tcmdPtr->startCmd);
+		ckfree(tcmdPtr->startCmd);
 	    }
 	}
 	if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
@@ -1358,7 +1383,7 @@ TraceCommandProc(
 	tcmdPtr->refCount--;
     }
     if ((--tcmdPtr->refCount) <= 0) {
-	ckfree((char *) tcmdPtr);
+	ckfree(tcmdPtr);
     }
 }
 
@@ -1450,7 +1475,7 @@ TclCheckExecutionTraces(
 		traceCode = TraceExecutionProc(tcmdPtr, interp, curLevel,
 			command, (Tcl_Command) cmdPtr, objc, objv);
 		if ((--tcmdPtr->refCount) <= 0) {
-		    ckfree((char *) tcmdPtr);
+		    ckfree(tcmdPtr);
 		}
 	    }
 	}
@@ -1693,7 +1718,7 @@ CommandObjTraceDeleted(
     TraceCommandInfo *tcmdPtr = clientData;
 
     if ((--tcmdPtr->refCount) <= 0) {
-	ckfree((char *) tcmdPtr);
+	ckfree(tcmdPtr);
     }
 }
 
@@ -1776,7 +1801,7 @@ TraceExecutionProc(
 	    Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
 	    tcmdPtr->stepTrace = NULL;
 	    if (tcmdPtr->startCmd != NULL) {
-		ckfree((char *) tcmdPtr->startCmd);
+		ckfree(tcmdPtr->startCmd);
 	    }
 	}
 
@@ -1908,7 +1933,7 @@ TraceExecutionProc(
     }
     if (call) {
 	if ((--tcmdPtr->refCount) <= 0) {
-	    ckfree((char *) tcmdPtr);
+	    ckfree(tcmdPtr);
 	}
     }
     return traceCode;
@@ -1972,24 +1997,24 @@ TraceVarProc(
 #ifndef TCL_REMOVE_OBSOLETE_TRACES
 	    if (tvarPtr->flags & TCL_TRACE_OLD_STYLE) {
 		if (flags & TCL_TRACE_ARRAY) {
-		    Tcl_DStringAppend(&cmd, " a", 2);
+		    TclDStringAppendLiteral(&cmd, " a");
 		} else if (flags & TCL_TRACE_READS) {
-		    Tcl_DStringAppend(&cmd, " r", 2);
+		    TclDStringAppendLiteral(&cmd, " r");
 		} else if (flags & TCL_TRACE_WRITES) {
-		    Tcl_DStringAppend(&cmd, " w", 2);
+		    TclDStringAppendLiteral(&cmd, " w");
 		} else if (flags & TCL_TRACE_UNSETS) {
-		    Tcl_DStringAppend(&cmd, " u", 2);
+		    TclDStringAppendLiteral(&cmd, " u");
 		}
 	    } else {
 #endif
 		if (flags & TCL_TRACE_ARRAY) {
-		    Tcl_DStringAppend(&cmd, " array", 6);
+		    TclDStringAppendLiteral(&cmd, " array");
 		} else if (flags & TCL_TRACE_READS) {
-		    Tcl_DStringAppend(&cmd, " read", 5);
+		    TclDStringAppendLiteral(&cmd, " read");
 		} else if (flags & TCL_TRACE_WRITES) {
-		    Tcl_DStringAppend(&cmd, " write", 6);
+		    TclDStringAppendLiteral(&cmd, " write");
 		} else if (flags & TCL_TRACE_UNSETS) {
-		    Tcl_DStringAppend(&cmd, " unset", 6);
+		    TclDStringAppendLiteral(&cmd, " unset");
 		}
 #ifndef TCL_REMOVE_OBSOLETE_TRACES
 	    }
@@ -2025,6 +2050,7 @@ TraceVarProc(
 	    }
 	    if (code != TCL_OK) {		/* copy error msg to result */
 		Tcl_Obj *errMsgObj = Tcl_GetObjResult(interp);
+
 		Tcl_IncrRefCount(errMsgObj);
 		result = (char *) errMsgObj;
 	    }
@@ -2134,7 +2160,7 @@ Tcl_CreateObjTrace(
 	iPtr->tracesForbiddingInline++;
     }
 
-    tracePtr = (Trace *) ckalloc(sizeof(Trace));
+    tracePtr = ckalloc(sizeof(Trace));
     tracePtr->level = level;
     tracePtr->proc = proc;
     tracePtr->clientData = clientData;
@@ -2197,8 +2223,7 @@ Tcl_CreateTrace(
 				 * command. */
     ClientData clientData)	/* Arbitrary value word to pass to proc. */
 {
-    StringTraceData *data = (StringTraceData *)
-	    ckalloc(sizeof(StringTraceData));
+    StringTraceData *data = ckalloc(sizeof(StringTraceData));
 
     data->clientData = clientData;
     data->proc = proc;
@@ -2555,7 +2580,7 @@ TclCallVarTraces(
 		    char *newPart1;
 
 		    Tcl_DStringInit(&nameCopy);
-		    Tcl_DStringAppend(&nameCopy, part1, (p-part1));
+		    Tcl_DStringAppend(&nameCopy, part1, p-part1);
 		    newPart1 = Tcl_DStringValue(&nameCopy);
 		    newPart1[offset] = 0;
 		    part1 = newPart1;
@@ -2693,7 +2718,8 @@ TclCallVarTraces(
 	    if (disposeFlags & TCL_TRACE_RESULT_OBJECT) {
 		Tcl_SetObjResult((Tcl_Interp *)iPtr, (Tcl_Obj *) result);
 	    } else {
-		Tcl_SetResult((Tcl_Interp *)iPtr, result, TCL_STATIC);
+		Tcl_SetObjResult((Tcl_Interp *)iPtr,
+			Tcl_NewStringObj(result, -1));
 	    }
 	    Tcl_AddErrorInfo((Tcl_Interp *)iPtr, "");
 
@@ -2880,6 +2906,16 @@ Tcl_UntraceVar2(
      * The code below makes it possible to delete traces while traces are
      * active: it makes sure that the deleted trace won't be processed by
      * TclCallVarTraces.
+     *
+     * Caveat (Bug 3062331): When an unset trace handler on a variable
+     * tries to delete a different unset trace handler on the same variable,
+     * the results may be surprising.  When variable unset traces fire, the
+     * traced variable is already gone.  So the TclLookupVar() call above
+     * will not find that variable, and not finding it will never reach here
+     * to perform the deletion.  This means callers of Tcl_UntraceVar*()
+     * attempting to delete unset traces from within the handler of another
+     * unset trace have to account for the possibility that their call to
+     * Tcl_UntraceVar*() is a no-op.
      */
 
     for (activePtr = iPtr->activeVarTracePtr;  activePtr != NULL;
@@ -3108,7 +3144,7 @@ Tcl_TraceVar2(
     register VarTrace *tracePtr;
     int result;
 
-    tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace));
+    tracePtr = ckalloc(sizeof(VarTrace));
     tracePtr->traceProc = proc;
     tracePtr->clientData = clientData;
     tracePtr->flags = flags;
@@ -3116,7 +3152,7 @@ Tcl_TraceVar2(
     result = TraceVarEx(interp, part1, part2, tracePtr);
 
     if (result != TCL_OK) {
-	ckfree((char *) tracePtr);
+	ckfree(tracePtr);
     }
     return result;
 }