From abf853d0bba19a6b5d8271bda9049f20c1c85bf5 Mon Sep 17 00:00:00 2001 From: sbron Date: Wed, 31 Aug 2022 11:06:38 +0000 Subject: Implement modification of the 'name2' trace callback argument. --- doc/trace.n | 20 ++++++++++---------- doc/upvar.n | 4 ++++ generic/tclEnv.c | 23 ++--------------------- generic/tclInt.h | 3 +++ generic/tclTrace.c | 23 +++++++++++++++++++---- generic/tclVar.c | 19 +++++++++++++++---- tests/upvar.test | 8 ++++---- 7 files changed, 57 insertions(+), 43 deletions(-) diff --git a/doc/trace.n b/doc/trace.n index 570b263..959acc2 100644 --- a/doc/trace.n +++ b/doc/trace.n @@ -229,18 +229,18 @@ When the trace triggers, three arguments are appended to \fIcommandPrefix name1 name2 op\fR .CE .PP -\fIName1\fR and \fIname2\fR give the name(s) for the variable -being accessed: if the variable is a scalar then \fIname1\fR -gives the variable's name and \fIname2\fR is an empty string; -if the variable is an array element then \fIname1\fR gives the -name of the array and name2 gives the index into the array; -if an entire array is being deleted and the trace was registered +\fIName1\fR gives the name for the variable being accessed. +This is not necessarily the same as the name used in the +\fBtrace variable\fR command: the \fBupvar\fR command allows a +procedure to reference a variable under a different name. +If the trace was originally set on an array or array element, +\fIname2\fR provides which index into the array was affected. +This information is present even when \fIname1\fR refers to a +scalar, which may happen if the \fBupvar\fR command was used to +create a reference to a single array element. +If an entire array is being deleted and the trace was registered on the overall array, rather than a single element, then \fIname1\fR gives the array name and \fIname2\fR is an empty string. -\fIName1\fR and \fIname2\fR are not necessarily the same as the -name used in the \fBtrace variable\fR command: the \fBupvar\fR -command allows a procedure to reference a variable under a -different name. \fIOp\fR indicates what operation is being performed on the variable, and is one of \fBread\fR, \fBwrite\fR, or \fBunset\fR as defined above. diff --git a/doc/upvar.n b/doc/upvar.n index 6ad1237..b0324b2 100644 --- a/doc/upvar.n +++ b/doc/upvar.n @@ -97,6 +97,10 @@ set originalVar 1 trace variable originalVar w \fItraceproc\fR \fIsetByUpvar\fR originalVar 2 .CE +.PP +If \fIotherVar\fR refers to an element of an array, then the element +name is passed as the second argument to the trace procedure. This +may be important information in case of traces set on an entire array. .SH EXAMPLE A \fBdecr\fR command that works like \fBincr\fR except it subtracts the value from the variable instead of adding it: diff --git a/generic/tclEnv.c b/generic/tclEnv.c index 98d871a..73a8b84 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -60,10 +60,6 @@ static struct { #define tNTL sizeof(techar) -/* Copied from tclVar.c - should possibly be moved to tclInt.h */ -#define VarHashGetKey(varPtr) \ - (((VarInHash *)(varPtr))->entry.key.objPtr) - /* * Declarations for local functions defined in this file: */ @@ -648,26 +644,11 @@ EnvTraceProc( } /* - * When an env array element is accessed via an upvar reference, there - * are two possibilities: - * 1. The upvar references the complete array. In this case name1 may be - * something else than "env", but that doesn't affect anything. name2 - * will still be the correct name for the enviroment variable to use. - * 2. The upvar references a single element of the array. In this case - * name2 will be NULL and name1 is the name of the alias. This alias - * must be resolved to the actual key of the array element. + * If name2 is NULL, then return and do nothing. */ if (name2 == NULL) { - Var *varPtr, *arrayPtr; - Tcl_Obj *name; - - name = Tcl_NewStringObj(name1, -1); - Tcl_IncrRefCount(name); - varPtr = TclObjLookupVarEx(interp, name, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - Tcl_DecrRefCount(name); - name2 = Tcl_GetString(VarHashGetKey(varPtr)); + return NULL; } /* diff --git a/generic/tclInt.h b/generic/tclInt.h index f5b25dc..6657cef 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -872,6 +872,9 @@ typedef struct VarInHash { #define VarHashRefCount(varPtr) \ ((VarInHash *) (varPtr))->refCount +#define VarHashGetKey(varPtr) \ + (((VarInHash *)(varPtr))->entry.key.objPtr) + /* * Macros for direct variable access by TEBC. */ diff --git a/generic/tclTrace.c b/generic/tclTrace.c index f830a77..8999858 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -2634,6 +2634,7 @@ TclCallVarTraces( Tcl_InterpState state = NULL; Tcl_HashEntry *hPtr; int traceflags = flags & VAR_ALL_TRACES; + const char *element; /* * If there are already similar trace functions active for the variable, @@ -2685,6 +2686,20 @@ TclCallVarTraces( } } + /* Keep the original pointer for possible use in an error message */ + element = part2; + if (part2 == NULL) { + if (TclIsVarArrayElement(varPtr)) { + Tcl_Obj *keyObj = VarHashGetKey(varPtr); + part2 = Tcl_GetString(keyObj); + } + } else if ((flags & VAR_TRACED_UNSET) && !(flags & VAR_ARRAY_ELEMENT)) { + /* On unset traces, part2 has already been set by the caller, and + * the VAR_ARRAY_ELEMENT flag indicates whether the accessed + * variable actually has a second part, or is a scalar */ + element = NULL; + } + /* * Invoke traces on the array containing the variable, if relevant. */ @@ -2805,13 +2820,13 @@ TclCallVarTraces( Tcl_AppendObjToErrorInfo((Tcl_Interp *)iPtr, Tcl_ObjPrintf( "\n (%s trace on \"%s%s%s%s\")", type, part1, - (part2 ? "(" : ""), (part2 ? part2 : ""), - (part2 ? ")" : "") )); + (element ? "(" : ""), (element ? element : ""), + (element ? ")" : "") )); if (disposeFlags & TCL_TRACE_RESULT_OBJECT) { - TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, verb, + TclVarErrMsg((Tcl_Interp *) iPtr, part1, element, verb, TclGetString((Tcl_Obj *) result)); } else { - TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, verb, result); + TclVarErrMsg((Tcl_Interp *) iPtr, part1, element, verb, result); } iPtr->flags &= ~(ERR_ALREADY_LOGGED); Tcl_DiscardInterpState(state); diff --git a/generic/tclVar.c b/generic/tclVar.c index b38575b..44645b5 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -108,9 +108,6 @@ VarHashNextVar( return VarHashGetValue(hPtr); } -#define VarHashGetKey(varPtr) \ - (((VarInHash *)(varPtr))->entry.key.objPtr) - #define VarHashDeleteTable(tablePtr) \ Tcl_DeleteHashTable(&(tablePtr)->table) @@ -2580,9 +2577,23 @@ UnsetVarStruct( if ((dummyVar.flags & VAR_TRACED_UNSET) || (arrayPtr && (arrayPtr->flags & VAR_TRACED_UNSET))) { + + /* + * Pass the array element name to TclObjCallVarTraces(), because + * it cannot be determined from dummyVar. Alternatively, indicate + * via flags whether the variable involved in the code that caused + * the trace to be triggered was an array element, for the correct + * formatting of error messages. + */ + if (part2Ptr) { + flags |= VAR_ARRAY_ELEMENT; + } else if (TclIsVarArrayElement(varPtr)) { + part2Ptr = VarHashGetKey(varPtr); + } + dummyVar.flags &= ~VAR_TRACE_ACTIVE; TclObjCallVarTraces(iPtr, arrayPtr, &dummyVar, part1Ptr, part2Ptr, - (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) + (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|VAR_ARRAY_ELEMENT)) | TCL_TRACE_UNSETS, /* leaveErrMsg */ 0, index); diff --git a/tests/upvar.test b/tests/upvar.test index 3682521..6330fa6 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -221,7 +221,7 @@ test upvar-5.4 {read trace on upvar array element} -body { set x --- p1 foo bar set x -} -result {{x1 {} read} x1} +} -result {{x1 c read} x1} test upvar-5.5 {write trace on upvar array element} -body { proc p1 {a b} { array set foo {c 22 d 33} @@ -236,7 +236,7 @@ test upvar-5.5 {write trace on upvar array element} -body { set x --- p1 foo bar set x -} -result {{x1 {} write} x1} +} -result {{x1 c write} x1} test upvar-5.6 {unset trace on upvar array element} -body { proc p1 {a b} { array set foo {c 22 d 33} @@ -251,7 +251,7 @@ test upvar-5.6 {unset trace on upvar array element} -body { set x --- p1 foo bar set x -} -result {{x1 {} unset} x1} +} -result {{x1 c unset} x1} test upvar-5.7 {trace on non-existent upvar array element} -body { proc p1 {a b} { array set foo {} @@ -267,7 +267,7 @@ test upvar-5.7 {trace on non-existent upvar array element} -body { set x --- lappend x [p1 foo bar] set x -} -result {{x1 {} write} x1 {hi there}} +} -result {{x1 hi write} x1 {hi there}} test upvar-6.1 {retargeting an upvar} { proc p1 {} { -- cgit v0.12