From 9355455bbbdf3472b04c9f8f101a2ad35164baa7 Mon Sep 17 00:00:00 2001 From: vincentdarley Date: Fri, 17 Jan 2003 14:19:28 +0000 Subject: execution trace, command trace and stringObj bug fixes --- ChangeLog | 25 ++++++ generic/tclBasic.c | 48 +++++----- generic/tclCmdMZ.c | 231 ++++++++++++++++++++++++++++++++++--------------- generic/tclInt.h | 6 +- generic/tclStringObj.c | 70 ++++++++++----- tests/stringObj.test | 4 +- tests/trace.test | 129 ++++++++++++++++++++------- 7 files changed, 367 insertions(+), 146 deletions(-) diff --git a/ChangeLog b/ChangeLog index efc2727..8f3c070 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,28 @@ +2003-01-16 Vince Darley + + * generic/tclStringObj.c: Tcl_SetObjLength fix for when + the object has a unicode string rep. Fixes [Bug 635200] + * tests/stringObj.test: removed 'knownBug' constraint from + test 14.1 now that this bug is fixed. + + * generic/tclInt.h: + * generic/tclBasic.c: + * generic/tclCmdMZ.z: + * tests/trace.test: execution and command tracing bug fixes and + cleanup. In particular fixed [Bug 655645], [Bug 615043], + [Bug 571385] + - fixed some subtle cleanup problems with tracing. This + required replacing Tcl_Preserve/Tcl_Release with a more + robust refCount approach. Solves at least one known crash + caused by memory corruption. + - fixed some confusion in the code between new style traces + (Tcl 8.4) and the very limited 'Tcl_CreateTrace' which existed + before. + - made behaviour consistent with documentation (several + tests even contradicted the documentation before). + - fixed some minor error message details + - added a number of new tests + 2003-01-16 Jeff Hobbs * win/tclWinSerial.c (SerialOutputProc): add casts for diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 6fe4db2..6702240 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.70 2002/09/06 00:20:29 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.71 2003/01/17 14:19:40 vincentdarley Exp $ */ #include "tclInt.h" @@ -1075,7 +1075,7 @@ DeleteInterpProc(interp) } TclFreePackageInfo(iPtr); while (iPtr->tracePtr != NULL) { - Tcl_DeleteTrace( (Tcl_Interp*) iPtr, (Tcl_Trace) iPtr->tracePtr ); + Tcl_DeleteTrace((Tcl_Interp*) iPtr, (Tcl_Trace) iPtr->tracePtr); } if (iPtr->execEnvPtr != NULL) { TclDeleteExecEnv(iPtr->execEnvPtr); @@ -2420,7 +2420,9 @@ Tcl_DeleteCommandFromToken(interp, cmd) tracePtr = cmdPtr->tracePtr; while (tracePtr != NULL) { CommandTrace *nextPtr = tracePtr->nextPtr; - Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); + if ((--tracePtr->refCount) <= 0) { + ckfree((char*)tracePtr); + } tracePtr = nextPtr; } cmdPtr->tracePtr = NULL; @@ -2513,6 +2515,7 @@ Tcl_DeleteCommandFromToken(interp, cmd) TclCleanupCommand(cmdPtr); return 0; } + static char * CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags) Interp *iPtr; /* Interpreter containing command. */ @@ -2562,7 +2565,9 @@ CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags) flags |= TCL_TRACE_DESTROYED; } active.cmdPtr = cmdPtr; + Tcl_Preserve((ClientData) iPtr); + for (tracePtr = cmdPtr->tracePtr; tracePtr != NULL; tracePtr = active.nextTracePtr) { active.nextTracePtr = tracePtr->nextPtr; @@ -2577,11 +2582,13 @@ CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags) (Tcl_Command) cmdPtr, oldNamePtr); oldName = TclGetString(oldNamePtr); } - Tcl_Preserve((ClientData) tracePtr); + tracePtr->refCount++; (*tracePtr->traceProc)(tracePtr->clientData, (Tcl_Interp *) iPtr, oldName, newName, flags); cmdPtr->flags &= ~tracePtr->flags; - Tcl_Release((ClientData) tracePtr); + if ((--tracePtr->refCount) <= 0) { + ckfree((char*)tracePtr); + } } /* @@ -2604,7 +2611,6 @@ CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags) Tcl_Release((ClientData) iPtr); return result; } - /* *---------------------------------------------------------------------- @@ -3012,7 +3018,8 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags) if ((checkTraces) && (command != NULL)) { int cmdEpoch = cmdPtr->cmdEpoch; cmdPtr->refCount++; - /* If the first set of traces modifies/deletes the command or + /* + * If the first set of traces modifies/deletes the command or * any existing traces, then the set checkTraces to 0 and * go through this while loop one more time. */ @@ -4797,9 +4804,8 @@ Tcl_CreateObjTrace( interp, level, flags, proc, clientData, delProc ) /* Test if this trace allows inline compilation of commands */ - if ( ! ( flags & TCL_ALLOW_INLINE_COMPILATION ) ) { - - if ( iPtr->tracesForbiddingInline == 0 ) { + if (!(flags & TCL_ALLOW_INLINE_COMPILATION)) { + if (iPtr->tracesForbiddingInline == 0) { /* * When the first trace forbidding inline compilation is @@ -4815,7 +4821,7 @@ Tcl_CreateObjTrace( interp, level, flags, proc, clientData, delProc ) iPtr->compileEpoch++; iPtr->flags |= DONT_COMPILE_CMDS_INLINE; } - ++ iPtr->tracesForbiddingInline; + iPtr->tracesForbiddingInline++; } tracePtr = (Trace *) ckalloc(sizeof(Trace)); @@ -4998,17 +5004,17 @@ Tcl_DeleteTrace(interp, trace) { Interp *iPtr = (Interp *) interp; Trace *tracePtr = (Trace *) trace; - register Trace **tracePtr2 = &( iPtr->tracePtr ); + register Trace **tracePtr2 = &(iPtr->tracePtr); /* * Locate the trace entry in the interpreter's trace list, * and remove it from the list. */ - while ( (*tracePtr2) != NULL && (*tracePtr2) != tracePtr ) { + while ((*tracePtr2) != NULL && (*tracePtr2) != tracePtr) { tracePtr2 = &((*tracePtr2)->nextPtr); } - if ( *tracePtr2 == NULL ) { + if (*tracePtr2 == NULL) { return; } (*tracePtr2) = (*tracePtr2)->nextPtr; @@ -5020,11 +5026,11 @@ Tcl_DeleteTrace(interp, trace) * take advantage of it. */ - if ( ! (tracePtr->flags & TCL_ALLOW_INLINE_COMPILATION ) ) { - -- iPtr->tracesForbiddingInline; - if ( iPtr->tracesForbiddingInline == 0 ) { + if (!(tracePtr->flags & TCL_ALLOW_INLINE_COMPILATION)) { + iPtr->tracesForbiddingInline--; + if (iPtr->tracesForbiddingInline == 0) { iPtr->flags &= ~DONT_COMPILE_CMDS_INLINE; - ++ iPtr->compileEpoch; + iPtr->compileEpoch++; } } @@ -5032,13 +5038,13 @@ Tcl_DeleteTrace(interp, trace) * Execute any delete callback. */ - if ( tracePtr->delProc != NULL ) { - ( tracePtr->delProc )( tracePtr->clientData ); + if (tracePtr->delProc != NULL) { + (tracePtr->delProc)(tracePtr->clientData); } /* Delete the trace object */ - Tcl_EventuallyFree( (char*) tracePtr, TCL_DYNAMIC); + Tcl_EventuallyFree((char*)tracePtr, TCL_DYNAMIC); } /* diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 0b2903e..d3deaae 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdMZ.c,v 1.79 2002/11/13 22:11:40 vincentdarley Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.80 2003/01/17 14:19:44 vincentdarley Exp $ */ #include "tclInt.h" @@ -54,6 +54,10 @@ typedef struct { * step trace */ int curFlags; /* Trace flags for the current command */ int curCode; /* Return code for the current command */ + int refCount; /* Used to ensure this structure is + * not 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 * size will be as large as necessary to * hold command. This field must be the @@ -288,7 +292,8 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) endOfForLoop: if ((objc - i) < (2 - about)) { - Tcl_WrongNumArgs(interp, 1, objv, "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"); + Tcl_WrongNumArgs(interp, 1, objv, + "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"); return TCL_ERROR; } objc -= i; @@ -3181,7 +3186,7 @@ TclTraceExecutionObjCmd(interp, optionIndex, objc, objv) int i, listLen, result; Tcl_Obj **elemPtrs; if (objc != 6) { - Tcl_WrongNumArgs(interp, 3, objv, "name opList execution"); + Tcl_WrongNumArgs(interp, 3, objv, "name opList command"); return TCL_ERROR; } /* @@ -3196,7 +3201,8 @@ TclTraceExecutionObjCmd(interp, optionIndex, objc, objv) } if (listLen == 0) { Tcl_SetResult(interp, "bad operation list \"\": must be " - "one or more of enter, leave, enterstep, or leavestep", TCL_STATIC); + "one or more of enter, leave, enterstep, or leavestep", + TCL_STATIC); return TCL_ERROR; } for (i = 0; i < listLen; i++) { @@ -3231,6 +3237,7 @@ TclTraceExecutionObjCmd(interp, optionIndex, objc, objv) tcmdPtr->startLevel = 0; tcmdPtr->startCmd = NULL; tcmdPtr->length = length; + tcmdPtr->refCount = 1; flags |= TCL_TRACE_DELETE; if (flags & (TRACE_EXEC_ENTER_STEP | TRACE_EXEC_LEAVE_STEP)) { flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); @@ -3250,25 +3257,34 @@ TclTraceExecutionObjCmd(interp, optionIndex, objc, objv) */ TraceCommandInfo *tcmdPtr; - ClientData clientData; - clientData = 0; + ClientData clientData = NULL; name = Tcl_GetString(objv[3]); + + /* First ensure the name given is valid */ + if (Tcl_FindCommand(interp, name, NULL, + TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } + while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, - TraceCommandProc, clientData)) != 0) { + TraceCommandProc, clientData)) != NULL) { tcmdPtr = (TraceCommandInfo *) clientData; /* - * In checking the 'flags' field we must remove any extraneous - * flags which may have been temporarily added by various pieces - * of the trace mechanism. + * In checking the 'flags' field we must remove any + * extraneous flags which may have been temporarily + * added by various pieces of the trace mechanism. */ if ((tcmdPtr->length == length) - && ((tcmdPtr->flags & (TCL_TRACE_ANY_EXEC | TCL_TRACE_RENAME | + && ((tcmdPtr->flags & (TCL_TRACE_ANY_EXEC | + TCL_TRACE_RENAME | TCL_TRACE_DELETE)) == flags) && (strncmp(command, tcmdPtr->command, (size_t) length) == 0)) { flags |= TCL_TRACE_DELETE; - if (flags & (TRACE_EXEC_ENTER_STEP | TRACE_EXEC_LEAVE_STEP)) { - flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); + if (flags & (TRACE_EXEC_ENTER_STEP | + TRACE_EXEC_LEAVE_STEP)) { + flags |= (TCL_TRACE_ENTER_EXEC | + TCL_TRACE_LEAVE_EXEC); } Tcl_UntraceCommand(interp, name, flags, TraceCommandProc, clientData); @@ -3283,11 +3299,12 @@ TclTraceExecutionObjCmd(interp, optionIndex, objc, objv) ckfree((char *)tcmdPtr->startCmd); } } - /* Postpone deletion */ if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { + /* Postpone deletion */ tcmdPtr->flags = 0; - } else { - Tcl_EventuallyFree((ClientData) tcmdPtr, TCL_DYNAMIC); + } + if ((--tcmdPtr->refCount) <= 0) { + ckfree((char*)tcmdPtr); } break; } @@ -3303,11 +3320,18 @@ TclTraceExecutionObjCmd(interp, optionIndex, objc, objv) return TCL_ERROR; } - resultListPtr = Tcl_GetObjResult(interp); - clientData = 0; + clientData = NULL; name = Tcl_GetString(objv[3]); + + /* First ensure the name given is valid */ + if (Tcl_FindCommand(interp, name, NULL, + TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } + + resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, - TraceCommandProc, clientData)) != 0) { + TraceCommandProc, clientData)) != NULL) { TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; @@ -3323,7 +3347,7 @@ TclTraceExecutionObjCmd(interp, optionIndex, objc, objv) elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); if (tcmdPtr->flags & TCL_TRACE_ENTER_EXEC) { Tcl_ListObjAppendElement(NULL, elemObjPtr, - Tcl_NewStringObj("enter",6)); + Tcl_NewStringObj("enter",5)); } if (tcmdPtr->flags & TCL_TRACE_LEAVE_EXEC) { Tcl_ListObjAppendElement(NULL, elemObjPtr, @@ -3335,12 +3359,13 @@ TclTraceExecutionObjCmd(interp, optionIndex, objc, objv) } if (tcmdPtr->flags & TCL_TRACE_LEAVE_DURING_EXEC) { Tcl_ListObjAppendElement(NULL, elemObjPtr, - Tcl_NewStringObj("leavestep",10)); + Tcl_NewStringObj("leavestep",9)); } Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); - - elemObjPtr = Tcl_NewStringObj(tcmdPtr->command, -1); - Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr); + elemObjPtr = NULL; + + Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, + Tcl_NewStringObj(tcmdPtr->command, -1)); Tcl_ListObjAppendElement(interp, resultListPtr, eachTraceObjPtr); } @@ -3436,6 +3461,7 @@ TclTraceCommandObjCmd(interp, optionIndex, objc, objv) tcmdPtr->startLevel = 0; tcmdPtr->startCmd = NULL; tcmdPtr->length = length; + tcmdPtr->refCount = 1; flags |= TCL_TRACE_DELETE; strcpy(tcmdPtr->command, command); name = Tcl_GetString(objv[3]); @@ -3452,11 +3478,17 @@ TclTraceCommandObjCmd(interp, optionIndex, objc, objv) */ TraceCommandInfo *tcmdPtr; - ClientData clientData; - clientData = 0; + ClientData clientData = NULL; name = Tcl_GetString(objv[3]); + + /* First ensure the name given is valid */ + if (Tcl_FindCommand(interp, name, NULL, + TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } + while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, - TraceCommandProc, clientData)) != 0) { + TraceCommandProc, clientData)) != NULL) { tcmdPtr = (TraceCommandInfo *) clientData; if ((tcmdPtr->length == length) && (tcmdPtr->flags == flags) @@ -3465,7 +3497,10 @@ TclTraceCommandObjCmd(interp, optionIndex, objc, objv) Tcl_UntraceCommand(interp, name, flags | TCL_TRACE_DELETE, TraceCommandProc, clientData); - ckfree((char *) tcmdPtr); + tcmdPtr->flags |= TCL_TRACE_DESTROYED; + if ((--tcmdPtr->refCount) <= 0) { + ckfree((char *) tcmdPtr); + } break; } } @@ -3480,11 +3515,18 @@ TclTraceCommandObjCmd(interp, optionIndex, objc, objv) return TCL_ERROR; } - resultListPtr = Tcl_GetObjResult(interp); - clientData = 0; + clientData = NULL; name = Tcl_GetString(objv[3]); + + /* First ensure the name given is valid */ + if (Tcl_FindCommand(interp, name, NULL, + TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } + + resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); while ((clientData = Tcl_CommandTraceInfo(interp, name, 0, - TraceCommandProc, clientData)) != 0) { + TraceCommandProc, clientData)) != NULL) { TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData; @@ -3636,8 +3678,8 @@ TclTraceVariableObjCmd(interp, optionIndex, objc, objv) && (tvarPtr->flags == flags) && (strncmp(command, tvarPtr->command, (size_t) length) == 0)) { - Tcl_UntraceVar2(interp, name, NULL, - flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT, + Tcl_UntraceVar2(interp, name, NULL, + flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT, TraceVarProc, clientData); Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC); break; @@ -3719,8 +3761,9 @@ TclTraceVariableObjCmd(interp, optionIndex, objc, objv) * the clientData argument is NULL then the first such trace is * returned; otherwise, the next relevant one after the one * given by clientData will be returned. If the command - * doesn't exist, or if there are no (more) traces for it, - * then NULL is returned. + * doesn't exist then an error message is left in the interpreter + * and NULL is returned. Also, if there are no (more) traces for + * the given command, NULL is returned. * * Side effects: * None. @@ -3826,6 +3869,7 @@ Tcl_TraceCommand(interp, cmdName, flags, proc, clientData) tracePtr->flags = flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC); tracePtr->nextPtr = cmdPtr->tracePtr; + tracePtr->refCount = 1; cmdPtr->tracePtr = tracePtr; if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { cmdPtr->flags |= CMD_HAS_EXEC_TRACES; @@ -3881,7 +3925,9 @@ Tcl_UntraceCommand(interp, cmdName, flags, proc, clientData) if (tracePtr == NULL) { return; } - if ((tracePtr->traceProc == proc) && ((tracePtr->flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC)) == flags) + if ((tracePtr->traceProc == proc) + && ((tracePtr->flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE | + TCL_TRACE_ANY_EXEC)) == flags) && (tracePtr->clientData == clientData)) { if (tracePtr->flags & TCL_TRACE_ANY_EXEC) { hasExecTraces = 1; @@ -3908,7 +3954,10 @@ Tcl_UntraceCommand(interp, cmdName, flags, proc, clientData) prevPtr->nextPtr = tracePtr->nextPtr; } tracePtr->flags = 0; - Tcl_EventuallyFree((int*)tracePtr, TCL_DYNAMIC); + + if ((--tracePtr->refCount) <= 0) { + ckfree((char*)tracePtr); + } if (hasExecTraces) { for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; tracePtr != NULL ; @@ -3962,7 +4011,7 @@ TraceCommandProc(clientData, interp, oldName, newName, flags) int code; Tcl_DString cmd; - Tcl_Preserve((ClientData) tcmdPtr); + tcmdPtr->refCount++; if ((tcmdPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) { /* @@ -4020,14 +4069,14 @@ TraceCommandProc(clientData, interp, oldName, newName, flags) ckfree((char *)tcmdPtr->startCmd); } } - /* Postpone deletion, until exec trace returns */ if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { + /* Postpone deletion, until exec trace returns */ tcmdPtr->flags = 0; - } else { - Tcl_EventuallyFree((ClientData) tcmdPtr, TCL_DYNAMIC); } } - Tcl_Release((ClientData) tcmdPtr); + if ((--tcmdPtr->refCount) <= 0) { + ckfree((char*)tcmdPtr); + } return; } @@ -4057,7 +4106,8 @@ TraceCommandProc(clientData, interp, oldName, newName, flags) *---------------------------------------------------------------------- */ int -TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code, traceFlags, objc, objv) +TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code, + traceFlags, objc, objv) Tcl_Interp *interp; /* The current interpreter. */ CONST char *command; /* Pointer to beginning of the current * command string. */ @@ -4077,7 +4127,7 @@ TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code, traceFlags, obj TraceCommandInfo* tcmdPtr; if (command == NULL || cmdPtr->tracePtr == NULL) { - return(traceCode); + return traceCode; } curLevel = ((iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level); @@ -4087,9 +4137,9 @@ TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code, traceFlags, obj active.cmdPtr = cmdPtr; lastTracePtr = NULL; - for ( tracePtr = cmdPtr->tracePtr; - (traceCode == TCL_OK) && (tracePtr != NULL); - tracePtr = active.nextTracePtr) { + for (tracePtr = cmdPtr->tracePtr; + (traceCode == TCL_OK) && (tracePtr != NULL); + tracePtr = active.nextTracePtr) { if (traceFlags & TCL_TRACE_LEAVE_EXEC) { /* execute the trace command in order of creation for "leave" */ active.nextTracePtr = NULL; @@ -4105,8 +4155,12 @@ TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code, traceFlags, obj if (tcmdPtr->flags != 0) { tcmdPtr->curFlags = traceFlags | TCL_TRACE_EXEC_DIRECT; tcmdPtr->curCode = code; + tcmdPtr->refCount++; traceCode = TraceExecutionProc((ClientData)tcmdPtr, interp, curLevel, command, (Tcl_Command)cmdPtr, objc, objv); + if ((--tcmdPtr->refCount) <= 0) { + ckfree((char*)tcmdPtr); + } } lastTracePtr = tracePtr; } @@ -4137,7 +4191,8 @@ TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code, traceFlags, obj *---------------------------------------------------------------------- */ int -TclCheckInterpTraces(interp, command, numChars, cmdPtr, code, traceFlags, objc, objv) +TclCheckInterpTraces(interp, command, numChars, cmdPtr, code, + traceFlags, objc, objv) Tcl_Interp *interp; /* The current interpreter. */ CONST char *command; /* Pointer to beginning of the current * command string. */ @@ -4171,9 +4226,10 @@ TclCheckInterpTraces(interp, command, numChars, cmdPtr, code, traceFlags, objc, (traceCode == TCL_OK) && (tracePtr != NULL); tracePtr = active.nextTracePtr) { if (traceFlags & TCL_TRACE_ENTER_EXEC) { - /* execute the trace command in reverse order of creation + /* + * Execute the trace command in reverse order of creation * for "enterstep" operation. The order is changed for - * ""enterstep" instead of for "leavestep as was done in + * "enterstep" instead of for "leavestep" as was done in * TclCheckExecutionTraces because for step traces, * Tcl_CreateObjTrace creates one more linked list of traces * which results in one more reversal of trace invocation. @@ -4195,22 +4251,28 @@ TclCheckInterpTraces(interp, command, numChars, cmdPtr, code, traceFlags, objc, * The proc invoked might delete the traced command which * which might try to free tracePtr. We want to use tracePtr * until the end of this if section, so we use - * Tcl_Preserve() and Tcl_Release() to be sureit is not + * Tcl_Preserve() and Tcl_Release() to be sure it is not * freed while we still need it. */ Tcl_Preserve((ClientData) tracePtr); tracePtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; - if ((tracePtr->flags != TCL_TRACE_EXEC_IN_PROGRESS) && + + if (tracePtr->flags & (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC)) { + /* New style trace */ + if ((tracePtr->flags != TCL_TRACE_EXEC_IN_PROGRESS) && ((tracePtr->flags & traceFlags) != 0)) { - tcmdPtr = (TraceCommandInfo*)tracePtr->clientData; - tcmdPtr->curFlags = traceFlags; - tcmdPtr->curCode = code; - traceCode = (tracePtr->proc)((ClientData)tcmdPtr, - (Tcl_Interp*)interp, - curLevel, command, - (Tcl_Command)cmdPtr, - objc, objv); + tcmdPtr = (TraceCommandInfo*)tracePtr->clientData; + tcmdPtr->curFlags = traceFlags; + tcmdPtr->curCode = code; + traceCode = (tracePtr->proc)((ClientData)tcmdPtr, + (Tcl_Interp*)interp, + curLevel, command, + (Tcl_Command)cmdPtr, + objc, objv); + } } else { + /* Old-style trace */ + if (traceFlags & TCL_TRACE_ENTER_EXEC) { /* * Old-style interpreter-wide traces only trigger @@ -4287,14 +4349,38 @@ CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv) /* *---------------------------------------------------------------------- * + * CommandObjTraceDeleted -- + * + * Ensure the trace is correctly deleted by decrementing its + * refCount and only deleting if no other references exist. + * + * Results: + * None. + * + * Side effects: + * May release memory. + * + *---------------------------------------------------------------------- + */ +static void +CommandObjTraceDeleted(ClientData clientData) { + TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData; + if ((--tcmdPtr->refCount) <= 0) { + ckfree((char*)tcmdPtr); + } +} + +/* + *---------------------------------------------------------------------- + * * TraceExecutionProc -- * * This procedure is invoked whenever code relevant to a * 'trace execution' command is executed. It is called in one * of two ways in Tcl's core: * - * (i) by the TclCheckExecutionTraces, when an execution trace has been - * triggered. + * (i) by the TclCheckExecutionTraces, when an execution trace + * has been triggered. * (ii) by TclCheckInterpTraces, when a prior execution trace has * created a trace of the internals of a procedure, passing in * this procedure as the one to be called. @@ -4326,7 +4412,7 @@ TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, * not allow any further execution trace callbacks to * be called for the same trace. */ - return(traceCode); + return traceCode; } if (!(flags & TCL_INTERP_DESTROYED)) { @@ -4339,7 +4425,8 @@ TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, * operations, but with either of the step operations. */ if (flags & TCL_TRACE_EXEC_DIRECT) { - call = flags & tcmdPtr->flags & (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC); + call = flags & tcmdPtr->flags & (TCL_TRACE_ENTER_EXEC | + TCL_TRACE_LEAVE_EXEC); } else { call = 1; } @@ -4423,7 +4510,7 @@ TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, tcmdPtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS; iPtr->flags |= INTERP_TRACE_IN_PROGRESS; - Tcl_Preserve((ClientData)tcmdPtr); + tcmdPtr->refCount++; /* * This line can have quite arbitrary side-effects, * including deleting the trace, the command being @@ -4454,14 +4541,17 @@ TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, * interpreter trace when it reaches the end of this proc. */ if ((flags & TCL_TRACE_ENTER_EXEC) && (tcmdPtr->stepTrace == NULL) - && (tcmdPtr->flags & (TCL_TRACE_ENTER_DURING_EXEC | TCL_TRACE_LEAVE_DURING_EXEC))) { + && (tcmdPtr->flags & (TCL_TRACE_ENTER_DURING_EXEC | + TCL_TRACE_LEAVE_DURING_EXEC))) { tcmdPtr->startLevel = level; tcmdPtr->startCmd = (char *) ckalloc((unsigned) (strlen(command) + 1)); strcpy(tcmdPtr->startCmd, command); + tcmdPtr->refCount++; tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0, (tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2, - TraceExecutionProc, (ClientData)tcmdPtr, NULL); + TraceExecutionProc, (ClientData)tcmdPtr, + CommandObjTraceDeleted); } } if (flags & TCL_TRACE_DESTROYED) { @@ -4472,12 +4562,13 @@ TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, ckfree((char *)tcmdPtr->startCmd); } } - Tcl_EventuallyFree((ClientData)tcmdPtr, TCL_DYNAMIC); } if (call) { - Tcl_Release((ClientData)tcmdPtr); + if ((--tcmdPtr->refCount) <= 0) { + ckfree((char*)tcmdPtr); + } } - return(traceCode); + return traceCode; } /* diff --git a/generic/tclInt.h b/generic/tclInt.h index 956ec4d..ff49a21 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.114 2003/01/09 10:38:29 vincentdarley Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.115 2003/01/17 14:19:49 vincentdarley Exp $ */ #ifndef _TCLINT @@ -287,6 +287,10 @@ typedef struct CommandTrace { * TCL_TRACE_RENAME, TCL_TRACE_DELETE. */ struct CommandTrace *nextPtr; /* Next in list of traces associated with * a particular command. */ + int refCount; /* Used to ensure this structure is + * not deleted too early. Keeps track + * of how many pieces of code have + * a pointer to this structure. */ } CommandTrace; /* diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index c951ae5..436dea6 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -33,7 +33,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStringObj.c,v 1.26 2002/11/13 22:11:41 vincentdarley Exp $ */ + * RCS: @(#) $Id: tclStringObj.c,v 1.27 2003/01/17 14:19:52 vincentdarley Exp $ */ #include "tclInt.h" @@ -753,7 +753,6 @@ Tcl_SetObjLength(objPtr, length) * representation of object, not including * terminating null byte. */ { - char *new; String *stringPtr; if (Tcl_IsShared(objPtr)) { @@ -762,34 +761,61 @@ Tcl_SetObjLength(objPtr, length) SetStringFromAny(NULL, objPtr); /* - * Invalidate the unicode data. + * We don't want to invalidate the unicode data if it exists, since + * if we are handling a Unicode object, objPtr->bytes may actually be + * NULL. Therefore either we must create that entry, or we must + * assume the object is being re-used as Unicode. For efficiency we + * do the latter. */ stringPtr = GET_STRING(objPtr); - stringPtr->numChars = -1; - stringPtr->uallocated = 0; - if (length > (int) stringPtr->allocated) { + if (stringPtr->uallocated > 0) { + stringPtr->numChars = length; - /* - * Not enough space in current string. Reallocate the string - * space and free the old string. - */ - if (objPtr->bytes != tclEmptyStringRep) { - new = (char *) ckrealloc((char *)objPtr->bytes, - (unsigned)(length+1)); - } else { - new = (char *) ckalloc((unsigned) (length+1)); - if (objPtr->bytes != NULL && objPtr->length != 0) { - memcpy((VOID *) new, (VOID *) objPtr->bytes, - (size_t) objPtr->length); - Tcl_InvalidateStringRep(objPtr); + if (length > (int) stringPtr->uallocated) { + stringPtr = (String *) ckrealloc((char*) stringPtr, + STRING_SIZE(length)); + stringPtr->uallocated = length; + } + /* Ensure the string is NULL-terminated */ + stringPtr->unicode[length] = 0; + + if (objPtr->bytes != NULL && (length > objPtr->length)) { + /* + * There is a utf-8 representation which is too short -- we + * are lengthening the string, and so we must discard it. + */ + Tcl_InvalidateStringRep(objPtr); + } + } else { + stringPtr->numChars = -1; + stringPtr->uallocated = 0; + + if (length > (int) stringPtr->allocated) { + char *new; + + /* + * Not enough space in current string. Reallocate the string + * space and free the old string. + */ + if (objPtr->bytes != tclEmptyStringRep) { + new = (char *) ckrealloc((char *)objPtr->bytes, + (unsigned)(length+1)); + } else { + new = (char *) ckalloc((unsigned) (length+1)); + if (objPtr->bytes != NULL && objPtr->length != 0) { + memcpy((VOID *) new, (VOID *) objPtr->bytes, + (size_t) objPtr->length); + Tcl_InvalidateStringRep(objPtr); + } } + objPtr->bytes = new; + stringPtr->allocated = length; } - objPtr->bytes = new; - stringPtr->allocated = length; + } - + objPtr->length = length; if ((objPtr->bytes != NULL) && (objPtr->bytes != tclEmptyStringRep)) { objPtr->bytes[length] = 0; diff --git a/tests/stringObj.test b/tests/stringObj.test index c2db812..b27557d 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: stringObj.test,v 1.12 2002/11/13 22:11:41 vincentdarley Exp $ +# RCS: @(#) $Id: stringObj.test,v 1.13 2003/01/17 14:19:54 vincentdarley Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -415,7 +415,7 @@ test stringObj-13.6 {Tcl_GetCharLength with mixed width chars} { list [string length $a] [string length $a] } {10 10} -test stringObj-14.1 {Tcl_SetObjLength on pure unicode object} {knownBug} { +test stringObj-14.1 {Tcl_SetObjLength on pure unicode object} { teststringobj set 1 foo teststringobj getunicode 1 teststringobj append 1 bar -1 diff --git a/tests/trace.test b/tests/trace.test index 2e8b61b..52a6c4e 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.24 2002/11/13 22:11:41 vincentdarley Exp $ +# RCS: @(#) $Id: trace.test,v 1.25 2003/01/17 14:19:55 vincentdarley Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -865,27 +865,27 @@ test trace-14.12 {trace command ("remove variable" option)} { set x 12345 set info } {1} -test trace-14.15 {trace command ("list variable" option)} { +test trace-14.15 {trace command ("info variable" option)} { catch {unset x} trace add variable x write {traceTag 1} trace add variable x write traceProc trace add variable x write {traceTag 2} trace info variable x } {{write {traceTag 2}} {write traceProc} {write {traceTag 1}}} -test trace-14.16 {trace command ("list variable" option)} { +test trace-14.16 {trace command ("info variable" option)} { catch {unset x} trace info variable x } {} -test trace-14.17 {trace command ("list variable" option)} { +test trace-14.17 {trace command ("info variable" option)} { catch {unset x} trace info variable x(0) } {} -test trace-14.18 {trace command ("list variable" option)} { +test trace-14.18 {trace command ("info variable" option)} { catch {unset x} set x 44 trace info variable x(0) } {} -test trace-14.19 {trace command ("list variable" option)} { +test trace-14.19 {trace command ("info variable" option)} { catch {unset x} set x 44 trace add variable x write {traceTag 1} @@ -1604,36 +1604,36 @@ test trace-24.1 {delete trace during enter trace} { set info {} trace add execution foo enter [list traceDelete foo] foo 1 - list $info [trace info execution foo] -} {{{foo 1} enter} {}} + list $info [catch {trace info execution foo} res] $res +} {{{foo 1} enter} 0 {}} test trace-24.2 {delete trace during leave trace} { set info {} trace add execution foo leave [list traceDelete foo] foo 1 - list $info [trace info execution foo] -} {{{foo 1} 0 1 leave} {}} + list $info [catch {trace info execution foo} res] $res +} {{{foo 1} 0 1 leave} 0 {}} test trace-24.3 {delete trace during enter-leave trace} { set info {} trace add execution foo {enter leave} [list traceDelete foo] foo 1 - list $info [trace info execution foo] -} {{{foo 1} enter} {}} + list $info [catch {trace info execution foo} res] $res +} {{{foo 1} enter} 0 {}} test trace-24.4 {delete trace during all exec traces} { set info {} trace add execution foo {enter leave enterstep leavestep} [list traceDelete foo] foo 1 - list $info [trace info execution foo] -} {{{foo 1} enter} {}} + list $info [catch {trace info execution foo} res] $res +} {{{foo 1} enter} 0 {}} test trace-24.5 {delete trace during all exec traces except enter} { set info {} trace add execution foo {leave enterstep leavestep} [list traceDelete foo] foo 1 - list $info [trace info execution foo] -} {{{set b 1} enterstep} {}} + list $info [catch {trace info execution foo} res] $res +} {{{set b 1} enterstep} 0 {}} proc traceDelete {cmd args} { rename $cmd {} @@ -1649,8 +1649,8 @@ test trace-25.1 {delete command during enter trace} { set info {} trace add execution foo enter [list traceDelete foo] catch {foo 1} err - list $err $info [trace info execution foo] -} {{invalid command name "foo"} {{foo 1} enter} {unknown command "foo"}} + list $err $info [catch {trace info execution foo} res] $res +} {{invalid command name "foo"} {{foo 1} enter} 1 {unknown command "foo"}} proc foo {a} { set b $a @@ -1660,8 +1660,8 @@ test trace-25.2 {delete command during leave trace} { set info {} trace add execution foo leave [list traceDelete foo] foo 1 - list $info [trace info execution foo] -} {{{foo 1} 0 1 leave} {unknown command "foo"}} + list $info [catch {trace info execution foo} res] $res +} {{{foo 1} 0 1 leave} 1 {unknown command "foo"}} proc foo {a} { set b $a @@ -1672,8 +1672,8 @@ test trace-25.3 {delete command during enter then leave trace} { trace add execution foo enter [list traceDelete foo] trace add execution foo leave [list traceDelete foo] catch {foo 1} err - list $err $info [trace info execution foo] -} {{invalid command name "foo"} {{foo 1} enter} {unknown command "foo"}} + list $err $info [catch {trace info execution foo} res] $res +} {{invalid command name "foo"} {{foo 1} enter} 1 {unknown command "foo"}} proc foo {a} { set b $a @@ -1765,8 +1765,8 @@ test trace-25.8 {delete command during enter leave and enter/leave-step traces} trace add execution foo enterstep [list traceDelete foo] trace add execution foo leavestep [list traceDelete foo] catch {foo 1} err - list $err $info [trace info execution foo] -} {{invalid command name "foo"} {{foo 1} enter} {unknown command "foo"}} + list $err $info [catch {trace info execution foo} res] $res +} {{invalid command name "foo"} {{foo 1} enter} 1 {unknown command "foo"}} proc foo {a} { set b $a @@ -1778,8 +1778,8 @@ test trace-25.9 {delete command during enter leave and leavestep traces} { trace add execution foo leave [list traceDelete foo] trace add execution foo leavestep [list traceDelete foo] catch {foo 1} err - list $err $info [trace info execution foo] -} {{invalid command name "foo"} {{foo 1} enter} {unknown command "foo"}} + list $err $info [catch {trace info execution foo} res] $res +} {{invalid command name "foo"} {{foo 1} enter} 1 {unknown command "foo"}} proc foo {a} { set b $a @@ -1790,8 +1790,8 @@ test trace-25.10 {delete command during leave and leavestep traces} { trace add execution foo leave [list traceDelete foo] trace add execution foo leavestep [list traceDelete foo] catch {foo 1} err - list $err $info [trace info execution foo] -} {1 {{set b 1} 0 1 leavestep} {unknown command "foo"}} + list $err $info [catch {trace info execution foo} res] $res +} {1 {{set b 1} 0 1 leavestep} 1 {unknown command "foo"}} proc foo {a} { set b $a @@ -1802,8 +1802,8 @@ test trace-25.11 {delete command during enter and enterstep traces} { trace add execution foo enter [list traceDelete foo] trace add execution foo enterstep [list traceDelete foo] catch {foo 1} err - list $err $info [trace info execution foo] -} {{invalid command name "foo"} {{foo 1} enter} {unknown command "foo"}} + list $err $info [catch {trace info execution foo} res] $res +} {{invalid command name "foo"} {{foo 1} enter} 1 {unknown command "foo"}} test trace-26.1 {trace targetCmd when invoked through an alias} { proc foo {args} { @@ -1838,6 +1838,16 @@ test trace-27.1 {memory leak in rename trace (604609)} { info commands foo } {} +test trace-27.2 {command trace remove nonsense} { + list [catch {trace remove command thisdoesntexist \ + {delete rename} bar} res] $res +} {1 {unknown command "thisdoesntexist"}} + +test trace-27.3 {command trace info nonsense} { + list [catch {trace info command thisdoesntexist} res] $res +} {1 {unknown command "thisdoesntexist"}} + + test trace-28.1 {enterstep and leavestep traces with update idletasks (615043)} { catch {rename foo {}} proc foo {} { @@ -2019,6 +2029,65 @@ foo {if {[catch {bar}]} { }} 2 error leavestep foo foo 0 error leave}} +test trace-28.5 {exec traces} { + set info {} + proc foo {args} { set a 1 } + trace add execution foo {enter enterstep leave leavestep} \ + [list traceExecute foo] + after idle [list foo test-28.4] + update + # Complicated way of removing traces + set ti [lindex [eval [list trace info execution ::foo]] 0] + if {[llength $ti]} { + eval [concat [list trace remove execution foo] $ti] + } + join $info \n +} {foo {foo test-28.4} enter +foo {set a 1} enterstep +foo {set a 1} 0 1 leavestep +foo {foo test-28.4} 0 1 leave} + +test trace-28.6 {exec traces firing order} { + set info {} + proc enterStep {cmd op} {lappend ::info "enter $cmd/$op"} + proc leaveStep {cmd code result op} {lappend ::info "leave $cmd/$code/$result/$op"} + + proc foo x { + set b x=$x + incr x + } + trace add execution foo enterstep enterStep + trace add execution foo leavestep leaveStep + foo 42 + rename foo {} + join $info \n +} {enter set b x=42/enterstep +leave set b x=42/0/x=42/leavestep +enter incr x/enterstep +leave incr x/0/43/leavestep} + +test trace-28.7 {exec trace information} { + set info {} + proc foo x { incr x } + proc bar {args} {} + trace add execution foo {enter leave enterstep leavestep} bar + set info [trace info execution foo] + trace remove execution foo {enter leave enterstep leavestep} bar +} {} + +test trace-28.8 {exec trace remove nonsense} { + list [catch {trace remove execution thisdoesntexist \ + {enter leave enterstep leavestep} bar} res] $res +} {1 {unknown command "thisdoesntexist"}} + +test trace-28.9 {exec trace info nonsense} { + list [catch {trace info execution thisdoesntexist} res] $res +} {1 {unknown command "thisdoesntexist"}} + +test trace-28.10 {exec trace info nonsense} { + list [catch {trace remove execution} res] $res +} {1 {wrong # args: should be "trace remove execution name opList command"}} + # Delete procedures when done, so we don't clash with other tests # (e.g. foobar will clash with 'unknown' tests). catch {rename foobar {}} -- cgit v0.12