Attachment "1677512.patch" to
ticket [1677512fff]
added by
dgp
2007-03-18 02:00:49.
Index: generic/tclListObj.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclListObj.c,v
retrieving revision 1.42
diff -u -r1.42 tclListObj.c
--- generic/tclListObj.c 17 Mar 2007 05:04:16 -0000 1.42
+++ generic/tclListObj.c 17 Mar 2007 18:13:10 -0000
@@ -1255,6 +1255,158 @@
/* Index args. */
Tcl_Obj *valuePtr) /* Value arg to 'lset'. */
{
+#if 1
+ int index, result;
+ Tcl_Obj *subListPtr, *retValuePtr, *chainPtr;
+
+ /*
+ * If there are no indices, simply return the new value.
+ * (Without indices, [lset] is a synonym for [set].
+ */
+
+ if (indexCount == 0) {
+ Tcl_IncrRefCount(valuePtr);
+ return valuePtr;
+ }
+
+ /*
+ * If the list is shared, make a copy we can modify (copy-on-write).
+ * We use Tcl_DuplicateObj() instead of TclListObjCopy() for a few
+ * reasons: 1) we have not yet confirmed listPtr is actually a list;
+ * 2) We make a verbatim copy of any existing string rep, and when
+ * we combine that with the delayed invalidation of string reps of
+ * modified Tcl_Obj's implemented below, the outcome is that any
+ * error condition that causes this routine to return NULL, will
+ * leave the string rep of listPtr and all elements to be unchanged.
+ */
+
+ subListPtr = Tcl_IsShared(listPtr) ? Tcl_DuplicateObj(listPtr) : listPtr;
+
+ /*
+ * Anchor the linked list of Tcl_Obj's whose string reps must be
+ * invalidated if the operation succeeds.
+ */
+
+ retValuePtr = subListPtr;
+ chainPtr = NULL;
+
+ /*
+ * Loop through all the index arguments, and for each one dive
+ * into the appropriate sublist.
+ */
+
+ do {
+ int elemCount;
+ Tcl_Obj *parentList, **elemPtrs;
+
+ /* Check for the possible error conditions... */
+ result = TCL_ERROR;
+ if (Tcl_ListObjGetElements(interp, subListPtr, &elemCount, &elemPtrs)
+ != TCL_OK) {
+ /* ...the sublist we're indexing into isn't a list at all. */
+ break;
+ }
+
+ if (TclGetIntForIndex(interp, *indexArray++, elemCount - 1, &index)
+ != TCL_OK) {
+ /* ...the index we're trying to use isn't an index at all. */
+ break;
+ }
+
+ if (index < 0 || index >= elemCount) {
+ /* ...the index points outside the sublist. */
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("list index out of range", -1));
+ break;
+ }
+
+ /*
+ * No error conditions. As long as we're not yet on the last
+ * index, determine the next sublist for the next pass through
+ * the loop, and take steps to make sure it is an unshared copy,
+ * as we intend to modify it.
+ */
+
+ result = TCL_OK;
+ if (--indexCount) {
+ parentList = subListPtr;
+ subListPtr = elemPtrs[index];
+ if (Tcl_IsShared(subListPtr)) {
+ subListPtr = Tcl_DuplicateObj(subListPtr);
+ }
+
+ /*
+ * Replace the original elemPtr[index] in parentList with a copy
+ * we know to be unshared. This call will also deal with the
+ * situation where parentList shares its intrep with other
+ * Tcl_Obj's. Dealing with the shared intrep case can cause
+ * subListPtr to become shared again, so detect that case and
+ * make and store another copy.
+ */
+
+ TclListObjSetElement(NULL, parentList, index, subListPtr);
+ if (Tcl_IsShared(subListPtr)) {
+ subListPtr = Tcl_DuplicateObj(subListPtr);
+ TclListObjSetElement(NULL, parentList, index, subListPtr);
+ }
+
+ /*
+ * The TclListObjSetElement() calls do not spoil the string
+ * rep of parentList, and that's fine for now, since all we've
+ * done so far is replace a list element with an unshared copy.
+ * The list value remains the same, so the string rep. is still
+ * valid, and unchanged, which is good because if this whole
+ * routine returns NULL, we'd like to leave no change to the
+ * value of the lset variable. Later on, when we set valuePtr
+ * in its proper place, then all containing lists will have
+ * their values changed, and will need their string reps spoiled.
+ * We maintain a list of all those Tcl_Obj's (via a little intrep
+ * surgery) so we can spoil them at that time.
+ */
+
+ parentList->internalRep.twoPtrValue.ptr2 = (void *) chainPtr;
+ chainPtr = parentList;
+ }
+ } while (indexCount > 0);
+
+ /*
+ * Either we've detected and error condition, and exited the loop
+ * with result == TCL_ERROR, or we've successfully reached the last
+ * index, and we're ready to store valuePtr. In either case, we
+ * need to clean up our string spoiling list of Tcl_Obj's.
+ */
+
+ while (chainPtr) {
+ Tcl_Obj *objPtr = chainPtr;
+
+ if (result == TCL_OK) {
+
+ /*
+ * We're going to store valuePtr, so spoil string reps
+ * of all containing lists.
+ */
+
+ Tcl_InvalidateStringRep(objPtr);
+ }
+
+ /* Clear away our intrep surgery mess */
+ chainPtr = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2;
+ objPtr->internalRep.twoPtrValue.ptr2 = NULL;
+ }
+
+ if (result != TCL_OK) {
+ /* Error return; message is already in interp */
+ return NULL;
+ }
+
+ /* Store valuePtr in proper sublist and return */
+ TclListObjSetElement(NULL, subListPtr, index, valuePtr);
+ Tcl_InvalidateStringRep(subListPtr);
+ Tcl_IncrRefCount(retValuePtr);
+ return retValuePtr;
+
+#else
+
int duplicated; /* Flag == 1 if the obj has been duplicated, 0
* otherwise. */
Tcl_Obj *retValuePtr; /* Pointer to the list to be returned. */
@@ -1436,6 +1588,7 @@
Tcl_DecrRefCount(retValuePtr);
}
return NULL;
+#endif
}
/*
Index: tests/lset.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/lset.test,v
retrieving revision 1.7
diff -u -r1.7 lset.test
--- tests/lset.test 20 Oct 2005 12:27:29 -0000 1.7
+++ tests/lset.test 17 Mar 2007 18:13:10 -0000
@@ -390,6 +390,23 @@
list $a [lindex $a 1]
} "{ { 1 2 } { 3 4 } } { 3 4 }"
+testConstraint testobj [llength [info commands testobj]]
+test lset-15.1 {lset: shared intrep [Bug 1677512]} -setup {
+ teststringobj set 1 {{1 2} 3}
+ testobj convert 1 list
+ testobj duplicate 1 2
+ variable x [teststringobj get 1]
+ variable y [teststringobj get 2]
+ testobj freeallvars
+ set l [list $y z]
+ unset y
+} -constraints testobj -body {
+ lset l 0 0 0 5
+ lindex $x 0 0
+} -cleanup {
+ unset -nocomplain x l
+} -result 1
+
catch {unset noRead}
catch {unset noWrite}
catch {rename failTrace {}}
