Fix element sharing of array list backing stores

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.

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));
  }

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;

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