diff options
| -rw-r--r-- | ChangeLog | 8 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 41 | ||||
| -rw-r--r-- | tests/trace.test | 35 |
3 files changed, 75 insertions, 9 deletions
@@ -1,3 +1,9 @@ +2002-10-15 Vince Darley <vincentdarley@users.sourceforge.net> + + * generic/tclCmdMZ.c: + * tests/trace.test: applied patch from Hemang Levana to fix + [Bug #615043] in execution traces with idle tasks firing. + 2002-10-14 Jeff Hobbs <jeffh@ActiveState.com> * generic/tclEnv.c (Tcl_PutEnv): correct possible mem leak. @@ -24,7 +30,7 @@ * doc/regexp.n: Typo correction. Thanks Ronnie Brunner. [Bug 606826] -2002-07-22 Vince Darley <vincentdarley@users.sourceforge.net> +2002-10-10 Vince Darley <vincentdarley@users.sourceforge.net> * unix/tclLoadAout.c * unix/tclLoadDl.c diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index f053f33..fc6ad98 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.76 2002/08/22 15:57:54 msofer Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.77 2002/10/15 16:13:46 vincentdarley Exp $ */ #include "tclInt.h" @@ -46,7 +46,12 @@ typedef struct { size_t length; /* Number of non-NULL chars. in command. */ Tcl_Trace stepTrace; /* Used for execution traces, when tracing * inside the given command */ - int startLevel; /* Used for bookkeeping with execution traces */ + int startLevel; /* Used for bookkeeping with step execution + * traces, store the level at which the step + * trace was invoked */ + char *startCmd; /* Used for bookkeeping with step execution + * traces, store the command name which invoked + * step trace */ int curFlags; /* Trace flags for the current command */ int curCode; /* Return code for the current command */ char command[4]; /* Space for Tcl command to invoke. Actual @@ -3187,6 +3192,7 @@ TclTraceExecutionObjCmd(interp, optionIndex, objc, objv) tcmdPtr->flags = flags; tcmdPtr->stepTrace = NULL; tcmdPtr->startLevel = 0; + tcmdPtr->startCmd = NULL; tcmdPtr->length = length; flags |= TCL_TRACE_DELETE; if (flags & (TRACE_EXEC_ENTER_STEP | TRACE_EXEC_LEAVE_STEP)) { @@ -3236,6 +3242,9 @@ TclTraceExecutionObjCmd(interp, optionIndex, objc, objv) */ Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; + if (tcmdPtr->startCmd != NULL) { + ckfree((char *)tcmdPtr->startCmd); + } } /* Postpone deletion */ if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { @@ -3388,6 +3397,7 @@ TclTraceCommandObjCmd(interp, optionIndex, objc, objv) tcmdPtr->flags = flags; tcmdPtr->stepTrace = NULL; tcmdPtr->startLevel = 0; + tcmdPtr->startCmd = NULL; tcmdPtr->length = length; flags |= TCL_TRACE_DELETE; strcpy(tcmdPtr->command, command); @@ -3963,6 +3973,9 @@ TraceCommandProc(clientData, interp, oldName, newName, flags) if (tcmdPtr->stepTrace != NULL) { Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; + if (tcmdPtr->startCmd != NULL) { + ckfree((char *)tcmdPtr->startCmd); + } } /* Postpone deletion, until exec trace returns */ if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { @@ -4289,14 +4302,18 @@ TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, } /* * First, if we have returned back to the level at which we - * created an interpreter trace, we remove it + * created an interpreter trace for enterstep and/or leavestep + * execution traces, we remove it here. */ if (flags & TCL_TRACE_LEAVE_EXEC) { - if ((tcmdPtr->stepTrace != NULL) && (level == tcmdPtr->startLevel)) { + if ((tcmdPtr->stepTrace != NULL) && (level == tcmdPtr->startLevel) + && (strcmp(command, tcmdPtr->startCmd) == 0)) { Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; + if (tcmdPtr->startCmd != NULL) { + ckfree((char *)tcmdPtr->startCmd); + } } - } /* @@ -4381,12 +4398,19 @@ TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, } /* - * Third, create an interpreter trace, if we need one for - * subsequent internal execution traces. + * Third, if there are any step execution traces for this proc, + * we register an interpreter trace to invoke enterstep and/or + * leavestep traces. + * We also need to save the current stack level and the proc + * string in startLevel and startCmd so that we can delete this + * 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->startLevel = level; + tcmdPtr->startCmd = + (char *) ckalloc((unsigned) (strlen(command) + 1)); + strcpy(tcmdPtr->startCmd, command); tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0, (tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2, TraceExecutionProc, (ClientData)tcmdPtr, NULL); @@ -4396,6 +4420,9 @@ TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, if (tcmdPtr->stepTrace != NULL) { Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; + if (tcmdPtr->startCmd != NULL) { + ckfree((char *)tcmdPtr->startCmd); + } } Tcl_EventuallyFree((ClientData)tcmdPtr, TCL_DYNAMIC); } diff --git a/tests/trace.test b/tests/trace.test index 0c21dc3..f72b0bd 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.22 2002/09/06 00:20:29 dgp Exp $ +# RCS: @(#) $Id: trace.test,v 1.23 2002/10/15 16:13:47 vincentdarley Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -1838,12 +1838,45 @@ test trace-27.1 {memory leak in rename trace (604609)} { info commands foo } {} +test trace-28.1 {enterstep and leavestep traces with update idletasks (615043)} { + catch {rename foo {}} + proc foo {} { + set a 1 + update idletasks + set b 1 + } + + set info {} + trace add execution foo {enter enterstep leavestep leave} \ + [list traceExecute foo] + update + after idle {puts idle} + foo + + trace remove execution foo {enter enterstep leavestep leave} \ + [list traceExecute foo] + rename foo {} + join $info "\n" +} {foo foo enter +foo {set a 1} enterstep +foo {set a 1} 0 1 leavestep +foo {update idletasks} enterstep +foo {puts idle} enterstep +foo {puts idle} 0 {} leavestep +foo {update idletasks} 0 {} leavestep +foo {set b 1} enterstep +foo {set b 1} 0 1 leavestep +foo foo 0 1 leave} + # Delete procedures when done, so we don't clash with other tests # (e.g. foobar will clash with 'unknown' tests). catch {rename foobar {}} catch {rename foo {}} catch {rename bar {}} +# Unset the varaible when done +catch {unset info} + # cleanup ::tcltest::cleanupTests return |