diff options
Diffstat (limited to 'generic/tclTrace.c')
-rw-r--r-- | generic/tclTrace.c | 97 |
1 files changed, 79 insertions, 18 deletions
diff --git a/generic/tclTrace.c b/generic/tclTrace.c index c0cde49..8663eae 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -52,7 +52,7 @@ typedef struct { * invoked 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 + size_t 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. */ @@ -143,7 +143,7 @@ static int TraceVarEx(Tcl_Interp *interp, const char *part1, * trace procs */ -typedef struct StringTraceData { +typedef struct { ClientData clientData; /* Client data from Tcl_CreateTrace */ Tcl_CmdTraceProc *proc; /* Trace function from Tcl_CreateTrace */ } StringTraceData; @@ -191,8 +191,10 @@ Tcl_TraceObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { int optionIndex; +#ifndef TCL_REMOVE_OBSOLETE_TRACES const char *name; const char *flagOps, *p; +#endif /* Main sub commands to 'trace' */ static const char *const traceOptions[] = { "add", "info", "remove", @@ -278,7 +280,7 @@ Tcl_TraceObjCmd( opsList = Tcl_NewObj(); Tcl_IncrRefCount(opsList); - flagOps = Tcl_GetStringFromObj(objv[3], &numFlags); + flagOps = TclGetStringFromObj(objv[3], &numFlags); if (numFlags == 0) { Tcl_DecrRefCount(opsList); goto badVarOps; @@ -365,12 +367,14 @@ Tcl_TraceObjCmd( } return TCL_OK; +#ifndef TCL_REMOVE_OBSOLETE_TRACES badVarOps: 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; +#endif } /* @@ -462,7 +466,7 @@ TraceExecutionObjCmd( break; } } - command = Tcl_GetStringFromObj(objv[5], &commandLength); + command = TclGetStringFromObj(objv[5], &commandLength); length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { TraceCommandInfo *tcmdPtr = ckalloc( @@ -544,7 +548,7 @@ TraceExecutionObjCmd( tcmdPtr->flags = 0; } - if ((--tcmdPtr->refCount) <= 0) { + if (tcmdPtr->refCount-- <= 1) { ckfree(tcmdPtr); } break; @@ -701,7 +705,7 @@ TraceCommandObjCmd( } } - command = Tcl_GetStringFromObj(objv[5], &commandLength); + command = TclGetStringFromObj(objv[5], &commandLength); length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { TraceCommandInfo *tcmdPtr = ckalloc( @@ -748,7 +752,7 @@ TraceCommandObjCmd( Tcl_UntraceCommand(interp, name, flags | TCL_TRACE_DELETE, TraceCommandProc, clientData); tcmdPtr->flags |= TCL_TRACE_DESTROYED; - if ((--tcmdPtr->refCount) <= 0) { + if (tcmdPtr->refCount-- <= 1) { ckfree(tcmdPtr); } break; @@ -904,7 +908,7 @@ TraceVariableObjCmd( break; } } - command = Tcl_GetStringFromObj(objv[5], &commandLength); + command = TclGetStringFromObj(objv[5], &commandLength); length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { CombinedTraceVarInfo *ctvarPtr = ckalloc( @@ -912,9 +916,11 @@ TraceVariableObjCmd( + 1 + length); ctvarPtr->traceCmdInfo.flags = flags; +#ifndef TCL_REMOVE_OBSOLETE_TRACES if (objv[0] == NULL) { ctvarPtr->traceCmdInfo.flags |= TCL_TRACE_OLD_STYLE; } +#endif ctvarPtr->traceCmdInfo.length = length; flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT; memcpy(ctvarPtr->traceCmdInfo.command, command, length+1); @@ -939,7 +945,11 @@ TraceVariableObjCmd( TraceVarInfo *tvarPtr = clientData; if ((tvarPtr->length == length) - && ((tvarPtr->flags & ~TCL_TRACE_OLD_STYLE)==flags) + && ((tvarPtr->flags +#ifndef TCL_REMOVE_OBSOLETE_TRACES +& ~TCL_TRACE_OLD_STYLE +#endif + )==flags) && (strncmp(command, tvarPtr->command, (size_t) length) == 0)) { Tcl_UntraceVar2(interp, name, NULL, @@ -1130,7 +1140,7 @@ Tcl_TraceCommand( /* * 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++; @@ -1138,7 +1148,7 @@ Tcl_TraceCommand( cmdPtr->flags |= CMD_HAS_EXEC_TRACES; } - + return TCL_OK; } @@ -1223,7 +1233,7 @@ Tcl_UntraceCommand( } tracePtr->flags = 0; - if ((--tracePtr->refCount) <= 0) { + if (tracePtr->refCount-- <= 1) { ckfree(tracePtr); } @@ -1245,7 +1255,7 @@ Tcl_UntraceCommand( /* * Bug 3484621: up the interp's epoch if this is a BC'ed command */ - + if (cmdPtr->compileProc != NULL) { Interp *iPtr = (Interp *) interp; iPtr->compileEpoch++; @@ -1382,7 +1392,7 @@ TraceCommandProc( Tcl_RestoreInterpState(interp, state); tcmdPtr->refCount--; } - if ((--tcmdPtr->refCount) <= 0) { + if (tcmdPtr->refCount-- <= 1) { ckfree(tcmdPtr); } } @@ -1474,7 +1484,7 @@ TclCheckExecutionTraces( } traceCode = TraceExecutionProc(tcmdPtr, interp, curLevel, command, (Tcl_Command) cmdPtr, objc, objv); - if ((--tcmdPtr->refCount) <= 0) { + if (tcmdPtr->refCount-- <= 1) { ckfree(tcmdPtr); } } @@ -1721,7 +1731,7 @@ CommandObjTraceDeleted( { TraceCommandInfo *tcmdPtr = clientData; - if ((--tcmdPtr->refCount) <= 0) { + if (tcmdPtr->refCount-- <= 1) { ckfree(tcmdPtr); } } @@ -1889,7 +1899,8 @@ TraceExecutionProc( * interpreter. */ - traceCode = Tcl_Eval(interp, Tcl_DStringValue(&cmd)); + traceCode = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), + Tcl_DStringLength(&cmd), 0); tcmdPtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS; /* @@ -1936,7 +1947,7 @@ TraceExecutionProc( } } if (call) { - if ((--tcmdPtr->refCount) <= 0) { + if (tcmdPtr->refCount-- <= 1) { ckfree(tcmdPtr); } } @@ -2467,6 +2478,47 @@ TclVarTraceExists( /* *---------------------------------------------------------------------- * + * TclCheckArrayTraces -- + * + * This function is invoked to when we operate on an array variable, + * to allow any array traces to fire. + * + * Results: + * Returns TCL_OK to indicate normal operation. Returns TCL_ERROR if + * invocation of a trace function indicated an error. When TCL_ERROR is + * returned, then error information is left in interp. + * + * Side effects: + * Almost anything can happen, depending on trace; this function itself + * doesn't have any side effects. + * + *---------------------------------------------------------------------- + */ + +int +TclCheckArrayTraces( + Tcl_Interp *interp, + Var *varPtr, + Var *arrayPtr, + Tcl_Obj *name, + int index) +{ + int code = TCL_OK; + + if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) + && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { + Interp *iPtr = (Interp *)interp; + + code = TclObjCallVarTraces(iPtr, arrayPtr, varPtr, name, NULL, + (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| TCL_TRACE_ARRAY), + /* leaveErrMsg */ 1, index); + } + return code; +} + +/* + *---------------------------------------------------------------------- + * * TclCallVarTraces -- * * This function is invoked to find and invoke relevant trace functions @@ -2511,6 +2563,9 @@ TclObjCallVarTraces( if (!part1Ptr) { part1Ptr = localName(iPtr->varFramePtr, index); } + if (!part1Ptr) { + Tcl_Panic("Cannot trace a variable with no name"); + } part1 = TclGetString(part1Ptr); part2 = part2Ptr? TclGetString(part2Ptr) : NULL; @@ -2815,6 +2870,7 @@ DisposeTraceResult( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_UntraceVar void Tcl_UntraceVar( @@ -2830,6 +2886,7 @@ Tcl_UntraceVar( { Tcl_UntraceVar2(interp, varName, NULL, flags, proc, clientData); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -2984,6 +3041,7 @@ Tcl_UntraceVar2( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_VarTraceInfo ClientData Tcl_VarTraceInfo( @@ -3001,6 +3059,7 @@ Tcl_VarTraceInfo( return Tcl_VarTraceInfo2(interp, varName, NULL, flags, proc, prevClientData); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -3093,6 +3152,7 @@ Tcl_VarTraceInfo2( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_TraceVar int Tcl_TraceVar( @@ -3110,6 +3170,7 @@ Tcl_TraceVar( { return Tcl_TraceVar2(interp, varName, NULL, flags, proc, clientData); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- |