From 18da054782020f70383cf5764a17be7cf3b0b457 Mon Sep 17 00:00:00 2001
From: sbron <tclcore@tclcode.com>
Date: Sat, 27 Aug 2022 08:14:31 +0000
Subject: Alternative fix for the error messages by chw, which doesn't break
 traces on non-existing array elements.

---
 generic/tclInt.h |  4 ++--
 generic/tclVar.c |  8 +++++---
 tests/env.test   | 18 ++++++++++++++++++
 tests/upvar.test | 16 ++++++++++++++++
 4 files changed, 41 insertions(+), 5 deletions(-)

diff --git a/generic/tclInt.h b/generic/tclInt.h
index 7599f8f..f5b25dc 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -816,8 +816,8 @@ typedef struct VarInHash {
 
 #define TclVarFindHiddenArray(varPtr,arrayPtr)				\
     do {								\
-        if (!arrayPtr && !TclIsVarUndefined(varPtr) &&			\
-              TclIsVarInHash(varPtr) && TclVarParentArray(varPtr)) {	\
+        if ((arrayPtr == NULL) && TclIsVarInHash(varPtr) &&		\
+              (TclVarParentArray(varPtr) != NULL)) {			\
             arrayPtr = TclVarParentArray(varPtr);			\
         }								\
     } while(0)
diff --git a/generic/tclVar.c b/generic/tclVar.c
index c88144f..b38575b 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -1390,6 +1390,7 @@ TclPtrGetVarIdx(
 {
     Interp *iPtr = (Interp *) interp;
     const char *msg;
+    Var *initialArrayPtr = arrayPtr;
 
     TclVarFindHiddenArray(varPtr, arrayPtr);
 
@@ -1438,8 +1439,8 @@ TclPtrGetVarIdx(
     }
 
     if (flags & TCL_LEAVE_ERR_MSG) {
-	if (TclIsVarUndefined(varPtr) && arrayPtr
-		&& !TclIsVarUndefined(arrayPtr)) {
+	if (TclIsVarUndefined(varPtr) && initialArrayPtr
+		&& !TclIsVarUndefined(initialArrayPtr)) {
 	    msg = NOSUCHELEMENT;
 	} else if (TclIsVarArray(varPtr)) {
 	    msg = ISARRAY;
@@ -2447,6 +2448,7 @@ TclPtrUnsetVarIdx(
 {
     Interp *iPtr = (Interp *) interp;
     int result = (TclIsVarUndefined(varPtr)? TCL_ERROR : TCL_OK);
+    Var *initialArrayPtr = arrayPtr;
 
     /*
      * Keep the variable alive until we're done with it. We used to
@@ -2470,7 +2472,7 @@ TclPtrUnsetVarIdx(
     if (result != TCL_OK) {
 	if (flags & TCL_LEAVE_ERR_MSG) {
 	    TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "unset",
-		    ((arrayPtr == NULL) ? NOSUCHVAR : NOSUCHELEMENT), index);
+              ((initialArrayPtr == NULL) ? NOSUCHVAR : NOSUCHELEMENT), index);
 	    Tcl_SetErrorCode(interp, "TCL", "UNSET", "VARNAME", NULL);
 	}
     }
diff --git a/tests/env.test b/tests/env.test
index 30d8319..fb8e22f 100644
--- a/tests/env.test
+++ b/tests/env.test
@@ -443,6 +443,24 @@ test env-7.6 {
 	return [array get env test7_4]
     }}
 } -cleanup cleanup1 -result {}
+
+test env-7.7 {
+    create new (unset) env variable through upvar
+} -setup setup1 -body {
+    apply {{} {
+	unset -nocomplain ::env(test7_7)
+	upvar #0 env(test7_7) var
+	interp create interp1
+	set var newvalue
+	set result [interp1 eval {info exists ::env(test7_7)}]
+	if {$result} {
+	    lappend result [interp1 eval {set ::env(test7_7)}]
+	}
+	interp delete interp1
+	return $result
+    }}
+} -cleanup cleanup1 -result {1 newvalue}
+
 
 test env-8.0 {
     memory usage - valgrind does not report reachable memory
diff --git a/tests/upvar.test b/tests/upvar.test
index 268bb17..3682521 100644
--- a/tests/upvar.test
+++ b/tests/upvar.test
@@ -252,6 +252,22 @@ test upvar-5.6 {unset trace on upvar array element} -body {
     p1 foo bar
     set x
 } -result {{x1 {} unset} x1}
+test upvar-5.7 {trace on non-existent upvar array element} -body {
+    proc p1 {a b} {
+	array set foo {}
+	trace add variable foo {read write unset} tproc
+	p2
+	trace remove variable foo {read write unset} tproc
+	return [array get foo]
+    }
+    proc p2 {} {
+	upvar foo(hi) x1
+	set x1 there
+    }
+    set x ---
+    lappend x [p1 foo bar]
+    set x
+} -result {{x1 {} write} x1 {hi there}}
 
 test upvar-6.1 {retargeting an upvar} {
     proc p1 {} {
-- 
cgit v0.12