summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclBasic.c48
-rw-r--r--generic/tclCmdMZ.c231
-rw-r--r--generic/tclInt.h6
-rw-r--r--generic/tclStringObj.c70
4 files changed, 241 insertions, 114 deletions
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;
generated by cgit v0.12 at 2024-11-01 19:45:17 (GMT)