From 08ae73aad6ee1d98f047b30b335d9721c71a8c5f Mon Sep 17 00:00:00 2001
From: cyan <cyan.ogilvie@gmail.com>
Date: Fri, 28 Oct 2022 14:57:26 +0200
Subject: [PATCH] Fix element sharing of array list backing stores

---
 configure.ac         |  2 +-
 generic/api.c        | 14 +++++++++++++-
 generic/json_types.c | 12 +++++++++++-
 tests/set.test       | 17 +++++++++++++++++
 4 files changed, 42 insertions(+), 3 deletions(-)

diff --git a/configure.ac b/configure.ac
index c151e19..8fb4543 100644
--- a/configure.ac
+++ b/configure.ac
@@ -19,7 +19,7 @@ dnl	to configure the system for the local environment.
 # so that we create the export library with the dll.
 #-----------------------------------------------------------------------
 
-AC_INIT([rl_json],[0.11.3])
+AC_INIT([rl_json],[0.11.4])
 
 #--------------------------------------------------------------------
 # Call TEA_INIT as the first TEA_ macro to set up initial vars.
diff --git a/generic/api.c b/generic/api.c
index 2022e8e..e303d62 100644
--- a/generic/api.c
+++ b/generic/api.c
@@ -552,7 +552,19 @@ int JSON_Set(Tcl_Interp* interp, Tcl_Obj* obj, Tcl_Obj *path, Tcl_Obj* replaceme
 						goto followed_path;
 					} else {
 						target = av[index];
-						if (Tcl_IsShared(target)) {
+						// If we rely on the reference counts of the list
+						// element objects, the list intrep sharing on dup
+						// breaks things here - although the list is duplicated
+						// the element refcounts aren't incremented, so we
+						// still see the element as unshared here.  We could
+						// just always dup and replace it here but that is
+						// inefficient for the case of multiple sets down this
+						// path when the value truely is unshared, so we work
+						// around it in the array type dup by recreating a new
+						// list backing the array, with new references to each
+						// of the element objects.  That way the logic here
+						// about whether the path value is shared is correct.
+						if (/*1 ||*/ Tcl_IsShared(target)) {
 							target = Tcl_DuplicateObj(target);
 							TEST_OK_LABEL(finally, code, Tcl_ListObjReplace(interp, val, index, 1, 1, &target));
 						}
diff --git a/generic/json_types.c b/generic/json_types.c
index 7e2cedc..ab9da7f 100644
--- a/generic/json_types.c
+++ b/generic/json_types.c
@@ -338,7 +338,17 @@ static void dup_internal_rep(Tcl_Obj* src, Tcl_Obj* dest, Tcl_ObjType* objtype)
 		// Panic and go via the string rep
 		Tcl_IncrRefCount((Tcl_Obj*)(destir.twoPtrValue.ptr1 = Tcl_NewStringObj(str, len)));
 	} else {
-		destir.twoPtrValue.ptr1 = srcir->twoPtrValue.ptr1;
+		if (objtype == &json_array) {
+			Tcl_Obj**	ov = NULL;
+			int			oc;
+			// The list type's internal structure sharing on duplicates messes up our sharing,
+			// rather recreate a fresh list referencing the original element objects instead
+			if (TCL_OK != Tcl_ListObjGetElements(NULL, srcir->twoPtrValue.ptr1, &oc, &ov))
+				Tcl_Panic("Unable to retrieve the array elements from the shadow Tcl list while duplicating json array object");
+			destir.twoPtrValue.ptr1 = Tcl_NewListObj(oc, ov);
+		} else {
+			destir.twoPtrValue.ptr1 = srcir->twoPtrValue.ptr1;
+		}
 	}
 
 	destir.twoPtrValue.ptr2 = srcir->twoPtrValue.ptr2;
diff --git a/tests/set.test b/tests/set.test
index d77ef58..eba9f85 100644
--- a/tests/set.test
+++ b/tests/set.test
@@ -423,6 +423,23 @@ test set-8.1.1 {json set into a template} -body { #<<<
 	unset -nocomplain foo bar template
 } -result {{"foo":"fooval","bar":"barval"}}
 #>>>
+test set-10.2 {JSON set on shared value} -setup { #<<<
+	set object {["a", "b"]}
+	proc t {object v} {
+		#puts stderr "-----------------------------------------"
+		#puts stderr "t, object rep: [tcl::unsupported::representation $object]"
+		#puts stderr "t before: [json debug $object]"
+		json set object 0 [json string $v]
+		#puts stderr "t after: [json debug $object]"
+		json get $object 0
+	}
+} -body {
+   list [t $object us-west-2] [t $object us-west-1] [json get $object 0]
+} -cleanup {
+   catch {rename t {}}
+   unset -nocomplain object
+} -result {us-west-2 us-west-1 a}
+#>>>
 
 ::tcltest::cleanupTests
 return