Attachment "tip634.patch" to
ticket [2969488fff]
added by
sbron
2022-08-24 12:11:52.
Index: doc/upvar.n
==================================================================
--- doc/upvar.n
+++ doc/upvar.n
@@ -95,16 +95,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 variable
-traces set for the entire array will not be invoked when \fImyVar\fR
-is accessed (but traces on the particular element will still be
-invoked). In particular, if the array is \fBenv\fR, then changes
-made to \fImyVar\fR will not be passed to subprocesses correctly.
.SH EXAMPLE
A \fBdecr\fR command that works like \fBincr\fR except it subtracts
the value from the variable instead of adding it:
.PP
.CS
Index: generic/tclEnv.c
==================================================================
--- generic/tclEnv.c
+++ generic/tclEnv.c
@@ -58,10 +58,14 @@
#endif
} env;
#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:
*/
static char * EnvTraceProc(ClientData clientData, Tcl_Interp *interp,
@@ -642,15 +646,30 @@
TclEnvEpoch++;
return NULL;
}
/*
- * If name2 is NULL, then return and do nothing.
+ * 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 == NULL) {
- return 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));
}
/*
* If a value is being set, call TclSetEnv to do all of the work.
*/
Index: generic/tclInt.h
==================================================================
--- generic/tclInt.h
+++ generic/tclInt.h
@@ -213,19 +213,20 @@
typedef struct Tcl_Ensemble Tcl_Ensemble;
typedef struct NamespacePathEntry NamespacePathEntry;
/*
- * Special hashtable for variables: this is just a Tcl_HashTable with an nsPtr
- * field added at the end: in this way variables can find their namespace
- * without having to copy a pointer in their struct: they can access it via
- * their hPtr->tablePtr.
+ * Special hashtable for variables: this is just a Tcl_HashTable with nsPtr
+ * and arrayPtr fields added at the end: in this way variables can find their
+ * namespace and possibly containing array without having to copy a pointer in
+ * their struct: they can access them via their hPtr->tablePtr.
*/
typedef struct TclVarHashTable {
Tcl_HashTable table;
struct Namespace *nsPtr;
+ struct Var *arrayPtr;
} TclVarHashTable;
/*
* This is for itcl - it likes to search our varTables directly :(
*/
@@ -810,10 +811,18 @@
* MODULE_SCOPE int TclIsVarArrayElement(Var *varPtr);
* MODULE_SCOPE int TclIsVarTemporary(Var *varPtr);
* MODULE_SCOPE int TclIsVarArgument(Var *varPtr);
* MODULE_SCOPE int TclIsVarResolved(Var *varPtr);
*/
+
+#define TclVarFindHiddenArray(varPtr,arrayPtr) \
+ do { \
+ if (!arrayPtr && !TclIsVarUndefined(varPtr) && \
+ TclIsVarInHash(varPtr) && TclVarParentArray(varPtr)) { \
+ arrayPtr = TclVarParentArray(varPtr); \
+ } \
+ } while(0)
#define TclIsVarScalar(varPtr) \
!((varPtr)->flags & (VAR_ARRAY|VAR_LINK))
#define TclIsVarLink(varPtr) \
@@ -855,30 +864,39 @@
#define TclGetVarNsPtr(varPtr) \
(TclIsVarInHash(varPtr) \
? ((TclVarHashTable *) ((((VarInHash *) (varPtr))->entry.tablePtr)))->nsPtr \
: NULL)
+#define TclVarParentArray(varPtr) \
+ ((TclVarHashTable *) ((VarInHash *) (varPtr))->entry.tablePtr)->arrayPtr
+
#define VarHashRefCount(varPtr) \
((VarInHash *) (varPtr))->refCount
/*
* Macros for direct variable access by TEBC.
*/
-#define TclIsVarDirectReadable(varPtr) \
- ( !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_READ)) \
- && (varPtr)->value.objPtr)
+#define TclIsVarTricky(varPtr,trickyFlags) \
+ ( ((varPtr)->flags & (VAR_ARRAY|VAR_LINK|trickyFlags)) \
+ || (TclIsVarInHash(varPtr) \
+ && (TclVarParentArray(varPtr) != NULL) \
+ && (TclVarParentArray(varPtr)->flags & (trickyFlags))))
+
+#define TclIsVarDirectReadable(varPtr) \
+ ( (!TclIsVarTricky(varPtr,VAR_TRACED_READ)) \
+ && (varPtr)->value.objPtr)
#define TclIsVarDirectWritable(varPtr) \
- !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_WRITE|VAR_DEAD_HASH))
+ (!TclIsVarTricky(varPtr,VAR_TRACED_WRITE|VAR_DEAD_HASH))
#define TclIsVarDirectUnsettable(varPtr) \
- !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_READ|VAR_TRACED_WRITE|VAR_TRACED_UNSET|VAR_DEAD_HASH))
+ (!TclIsVarTricky(varPtr,VAR_TRACED_READ|VAR_TRACED_WRITE|VAR_TRACED_UNSET|VAR_DEAD_HASH))
#define TclIsVarDirectModifyable(varPtr) \
- ( !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_READ|VAR_TRACED_WRITE)) \
- && (varPtr)->value.objPtr)
+ ( (!TclIsVarTricky(varPtr,VAR_TRACED_READ|VAR_TRACED_WRITE)) \
+ && (varPtr)->value.objPtr)
#define TclIsVarDirectReadable2(varPtr, arrayPtr) \
(TclIsVarDirectReadable(varPtr) &&\
(!(arrayPtr) || !((arrayPtr)->flags & VAR_TRACED_READ)))
Index: generic/tclVar.c
==================================================================
--- generic/tclVar.c
+++ generic/tclVar.c
@@ -996,10 +996,11 @@
tablePtr = varFramePtr->varTablePtr;
if (create) {
if (tablePtr == NULL) {
tablePtr = (TclVarHashTable *)Tcl_Alloc(sizeof(TclVarHashTable));
TclInitVarHashTable(tablePtr, NULL);
+ tablePtr->arrayPtr = varPtr;
varFramePtr->varTablePtr = tablePtr;
}
varPtr = VarHashCreateVar(tablePtr, varNamePtr, &isNew);
} else {
varPtr = NULL;
@@ -1387,10 +1388,12 @@
* variable, or -1. Only used when part1Ptr is
* NULL. */
{
Interp *iPtr = (Interp *) interp;
const char *msg;
+
+ TclVarFindHiddenArray(varPtr, arrayPtr);
/*
* Invoke any read traces that have been set for the variable.
*/
@@ -1950,10 +1953,12 @@
Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL);
}
goto earlyError;
}
+ TclVarFindHiddenArray(varPtr, arrayPtr);
+
/*
* Invoke any read traces that have been set for the variable if it is
* requested. This was done for INST_LAPPEND_* but that was inconsistent
* with the non-bc instruction, and would cause failures trying to
* lappend to any non-existing ::env var, which is inconsistent with
@@ -2451,10 +2456,12 @@
*/
if (TclIsVarInHash(varPtr)) {
VarHashRefCount(varPtr)++;
}
+
+ TclVarFindHiddenArray(varPtr, arrayPtr);
UnsetVarStruct(varPtr, arrayPtr, iPtr, part1Ptr, part2Ptr, flags, index);
/*
* It's an error to unset an undefined variable.
@@ -6338,10 +6345,11 @@
Namespace *nsPtr)
{
Tcl_InitCustomHashTable(&tablePtr->table,
TCL_CUSTOM_TYPE_KEYS, &tclVarHashKeyType);
tablePtr->nsPtr = nsPtr;
+ tablePtr->arrayPtr = NULL;
}
static Tcl_HashEntry *
AllocVarEntry(
TCL_UNUSED(Tcl_HashTable *),
@@ -6592,10 +6600,11 @@
* Regular TclVarHashTable initialization.
*/
arrayPtr->value.tablePtr = (TclVarHashTable *) tablePtr;
TclInitVarHashTable(arrayPtr->value.tablePtr, TclGetVarNsPtr(arrayPtr));
+ arrayPtr->value.tablePtr->arrayPtr = arrayPtr;
/*
* Default value initialization.
*/
Index: tests/env.test
==================================================================
--- tests/env.test
+++ tests/env.test
@@ -409,10 +409,42 @@
info exists ::env(not_yet_existent)
set ::env(not_yet_existent) "Now I'm here";
return [info exists ::env(test7_3)]
}}
} -cleanup cleanup1 -result 1
+
+test env-7.4 {
+ get env variable through upvar
+} -setup setup1 -body {
+ apply {{} {
+ set ::env(test7_4) origvalue
+ upvar #0 env(test7_4) var
+ return $var
+ }}
+} -cleanup cleanup1 -result origvalue
+
+test env-7.5 {
+ set env variable through upvar
+} -setup setup1 -body {
+ apply {{} {
+ set ::env(test7_4) origvalue
+ upvar #0 env(test7_4) var
+ set var newvalue
+ return $::env(test7_4)
+ }}
+} -cleanup cleanup1 -result newvalue
+
+test env-7.6 {
+ unset env variable through upvar
+} -setup setup1 -body {
+ apply {{} {
+ set ::env(test7_4) origvalue
+ upvar #0 env(test7_4) var
+ unset var
+ return [array get env test7_4]
+ }}
+} -cleanup cleanup1 -result {}
test env-8.0 {
memory usage - valgrind does not report reachable memory
} -body {
set res [set env(__DUMMY__) {i'm with dummy}]
Index: tests/upvar.test
==================================================================
--- tests/upvar.test
+++ tests/upvar.test
@@ -205,10 +205,55 @@
proc p2 {} {upvar c x1; unset x1}
set x ---
p1 foo bar
set x
} {{x1 {} u} x1}
+test upvar-5.4 {read trace on upvar array element} -body {
+ proc p1 {a b} {
+ array set foo {c 22 d 33}
+ trace add variable foo {read write unset} tproc
+ p2
+ trace remove variable foo {read write unset} tproc
+ }
+ proc p2 {} {
+ upvar foo(c) x1
+ set x1
+ }
+ set x ---
+ p1 foo bar
+ set x
+} -result {{x1 {} read} x1}
+test upvar-5.5 {write trace on upvar array element} -body {
+ proc p1 {a b} {
+ array set foo {c 22 d 33}
+ trace add variable foo {read write unset} tproc
+ p2
+ trace remove variable foo {read write unset} tproc
+ }
+ proc p2 {} {
+ upvar foo(c) x1
+ set x1 22
+ }
+ set x ---
+ p1 foo bar
+ set x
+} -result {{x1 {} write} x1}
+test upvar-5.6 {unset trace on upvar array element} -body {
+ proc p1 {a b} {
+ array set foo {c 22 d 33}
+ trace add variable foo {read write unset} tproc
+ p2
+ trace remove variable foo {read write unset} tproc
+ }
+ proc p2 {} {
+ upvar foo(c) x1
+ unset x1
+ }
+ set x ---
+ p1 foo bar
+ set x
+} -result {{x1 {} unset} x1}
test upvar-6.1 {retargeting an upvar} {
proc p1 {} {
set a(0) zeroth
set a(1) first
