Fixed bug [1700065] - error in trace proc on textvariable doesn't trigger bgerror

3 files changed, 101 insertions, 33 deletions

diff --git a/generic/tkEntry.c b/generic/tkEntry.c
index f6ff9b9..dd753f0 100644
--- a/generic/tkEntry.c
+++ b/generic/tkEntry.c
@@ -391,7 +391,7 @@ static const char *selElementNames[] = {
 
 static int		ConfigureEntry(Tcl_Interp *interp, Entry *entryPtr,
 			    int objc, Tcl_Obj *const objv[], int flags);
-static void		DeleteChars(Entry *entryPtr, int index, int count);
+static int		DeleteChars(Entry *entryPtr, int index, int count);
 static void		DestroyEntry(char *memPtr);
 static void		DisplayEntry(ClientData clientData);
 static void		EntryBlinkProc(ClientData clientData);
@@ -417,7 +417,7 @@ static int		EntryValidateChange(Entry *entryPtr, char *change,
 static void		ExpandPercents(Entry *entryPtr, const char *before,
 			    const char *change, const char *newStr, int index,
 			    int type, Tcl_DString *dsPtr);
-static void		EntryValueChanged(Entry *entryPtr,
+static int		EntryValueChanged(Entry *entryPtr,
 			    const char *newValue);
 static void		EntryVisibleRange(Entry *entryPtr,
 			    double *firstPtr, double *lastPtr);
@@ -427,7 +427,7 @@ static int		EntryWidgetObjCmd(ClientData clientData,
 static void		EntryWorldChanged(ClientData instanceData);
 static int		GetEntryIndex(Tcl_Interp *interp, Entry *entryPtr,
 			    char *string, int *indexPtr);
-static void		InsertChars(Entry *entryPtr, int index, char *string);
+static int		InsertChars(Entry *entryPtr, int index, char *string);
 
 /*
  * These forward declarations are the spinbox specific ones:
@@ -663,7 +663,7 @@ EntryWidgetObjCmd(
 	break;
 
     case COMMAND_DELETE: {
-	int first, last;
+	int first, last, code;
 
 	if ((objc < 3) || (objc > 4)) {
 	    Tcl_WrongNumArgs(interp, 2, objv, "firstIndex ?lastIndex?");
@@ -680,7 +680,10 @@ EntryWidgetObjCmd(
 	    goto error;
 	}
 	if ((last >= first) && (entryPtr->state == STATE_NORMAL)) {
-	    DeleteChars(entryPtr, first, last - first);
+	    code = DeleteChars(entryPtr, first, last - first);
+            if (code != TCL_OK) {
+                goto error;
+            }
 	}
 	break;
     }
@@ -721,7 +724,7 @@ EntryWidgetObjCmd(
     }
 
     case COMMAND_INSERT: {
-	int index;
+	int index, code;
 
 	if (objc != 4) {
 	    Tcl_WrongNumArgs(interp, 2, objv, "index text");
@@ -732,7 +735,10 @@ EntryWidgetObjCmd(
 	    goto error;
 	}
 	if (entryPtr->state == STATE_NORMAL) {
-	    InsertChars(entryPtr, index, Tcl_GetString(objv[3]));
+	    code = InsertChars(entryPtr, index, Tcl_GetString(objv[3]));
+            if (code != TCL_OK) {
+                goto error;
+            }
 	}
 	break;
     }
@@ -1291,6 +1297,9 @@ ConfigureEntry(
     /*
      * If the entry is tied to the value of a variable, create the variable if
      * it doesn't exist, and set the entry's value from the variable's value.
+     * No checking of the return value of EntryValueChanged is needed since it
+     * can only return TCL_ERROR if there is a trace on the textvariable and
+     * since any existing trace on it was eliminated above.
      */
 
     if (entryPtr->textVarName != NULL) {
@@ -1990,7 +1999,8 @@ EntryComputeGeometry(
  *	Add new characters to an entry widget.
  *
  * Results:
- *	None.
+ *	A standard Tcl result. If an error occurred then an error message is
+ *	left in the interp's result.
  *
  * Side effects:
  *	New information gets added to entryPtr; it will be redisplayed soon,
@@ -1999,7 +2009,7 @@ EntryComputeGeometry(
  *----------------------------------------------------------------------
  */
 
-static void
+static int
 InsertChars(
     Entry *entryPtr,		/* Entry that is to get the new elements. */
     int index,			/* Add the new elements before this character
@@ -2017,7 +2027,7 @@ InsertChars(
     byteIndex = Tcl_UtfAtIndex(string, index) - string;
     byteCount = strlen(value);
     if (byteCount == 0) {
-	return;
+	return TCL_OK;
     }
 
     newByteCount = entryPtr->numBytes + byteCount + 1;
@@ -2031,7 +2041,7 @@ InsertChars(
 	    EntryValidateChange(entryPtr, value, newStr, index,
 		    VALIDATE_INSERT) != TCL_OK) {
 	ckfree(newStr);
-	return;
+	return TCL_OK;
     }
 
     ckfree((char *)string);
@@ -2079,7 +2089,7 @@ InsertChars(
     if (entryPtr->insertPos >= index) {
 	entryPtr->insertPos += charsAdded;
     }
-    EntryValueChanged(entryPtr, NULL);
+    return EntryValueChanged(entryPtr, NULL);
 }
 
 /*
@@ -2090,7 +2100,8 @@ InsertChars(
  *	Remove one or more characters from an entry widget.
  *
  * Results:
- *	None.
+ *	A standard Tcl result. If an error occurred then an error message is
+ *	left in the interp's result.
  *
  * Side effects:
  *	Memory gets freed, the entry gets modified and (eventually)
@@ -2099,7 +2110,7 @@ InsertChars(
  *----------------------------------------------------------------------
  */
 
-static void
+static int
 DeleteChars(
     Entry *entryPtr,		/* Entry widget to modify. */
     int index,			/* Index of first character to delete. */
@@ -2113,7 +2124,7 @@ DeleteChars(
 	count = entryPtr->numChars - index;
     }
     if (count <= 0) {
-	return;
+	return TCL_OK;
     }
 
     string = entryPtr->string;
@@ -2135,7 +2146,7 @@ DeleteChars(
 		    VALIDATE_DELETE) != TCL_OK) {
 	ckfree(newStr);
 	ckfree(toDelete);
-	return;
+	return TCL_OK;
     }
 
     ckfree(toDelete);
@@ -2194,7 +2205,7 @@ DeleteChars(
 	    entryPtr->insertPos = index;
 	}
     }
-    EntryValueChanged(entryPtr, NULL);
+    return EntryValueChanged(entryPtr, NULL);
 }
 
 /*
@@ -2207,7 +2218,8 @@ DeleteChars(
  *	is one, and does other bookkeeping such as arranging for redisplay.
  *
  * Results:
- *	None.
+ *	A standard Tcl result. If an error occurred then an error message is
+ *	left in the interp's result.
  *
  * Side effects:
  *	None.
@@ -2215,7 +2227,7 @@ DeleteChars(
  *----------------------------------------------------------------------
  */
 
-static void
+static int
 EntryValueChanged(
     Entry *entryPtr,		/* Entry whose value just changed. */
     const char *newValue)	/* If this value is not NULL, we first force
@@ -2229,7 +2241,7 @@ EntryValueChanged(
 	newValue = NULL;
     } else {
 	newValue = Tcl_SetVar(entryPtr->interp, entryPtr->textVarName,
-		entryPtr->string, TCL_GLOBAL_ONLY);
+		entryPtr->string, TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
     }
 
     if ((newValue != NULL) && (strcmp(newValue, entryPtr->string) != 0)) {
@@ -2251,6 +2263,17 @@ EntryValueChanged(
 	EntryComputeGeometry(entryPtr);
 	EventuallyRedraw(entryPtr);
     }
+
+    /*
+     * An error may have happened when setting the textvariable in case there
+     * is a trace on that variable and the trace proc triggered an error.
+     * Signal this error.
+     */
+
+    if ((entryPtr->textVarName != NULL) && (newValue == NULL)) {
+        return TCL_ERROR;
+    }
+    return TCL_OK;
 }
 
 /*
@@ -3703,7 +3726,7 @@ SpinboxWidgetObjCmd(
 	break;
 
     case SB_CMD_DELETE: {
-	int first, last;
+	int first, last, code;
 
 	if ((objc < 3) || (objc > 4)) {
 	    Tcl_WrongNumArgs(interp, 2, objv, "firstIndex ?lastIndex?");
@@ -3722,7 +3745,10 @@ SpinboxWidgetObjCmd(
 	    }
 	}
 	if ((last >= first) && (entryPtr->state == STATE_NORMAL)) {
-	    DeleteChars(entryPtr, first, last - first);
+	    code = DeleteChars(entryPtr, first, last - first);
+            if (code != TCL_OK) {
+                goto error;
+            }
 	}
 	break;
     }
@@ -3782,7 +3808,7 @@ SpinboxWidgetObjCmd(
     }
 
     case SB_CMD_INSERT: {
-	int index;
+	int index, code;
 
 	if (objc != 4) {
 	    Tcl_WrongNumArgs(interp, 2, objv, "index text");
@@ -3793,7 +3819,10 @@ SpinboxWidgetObjCmd(
 	    goto error;
 	}
 	if (entryPtr->state == STATE_NORMAL) {
-	    InsertChars(entryPtr, index, Tcl_GetString(objv[3]));
+	    code = InsertChars(entryPtr, index, Tcl_GetString(objv[3]));
+            if (code != TCL_OK) {
+                goto error;
+            }
 	}
 	break;
     }
@@ -4001,16 +4030,22 @@ SpinboxWidgetObjCmd(
 	break;
     }
 
-    case SB_CMD_SET:
+    case SB_CMD_SET: {
+	int code = TCL_OK;
+
 	if (objc > 3) {
 	    Tcl_WrongNumArgs(interp, 2, objv, "?string?");
 	    goto error;
 	}
 	if (objc == 3) {
-	    EntryValueChanged(entryPtr, Tcl_GetString(objv[2]));
+	    code = EntryValueChanged(entryPtr, Tcl_GetString(objv[2]));
+            if (code != TCL_OK) {
+                goto error;
+            }
 	}
 	Tcl_SetStringObj(Tcl_GetObjResult(interp), entryPtr->string, -1);
 	break;
+    }
 
     case SB_CMD_VALIDATE: {
 	int code;
@@ -4151,7 +4186,7 @@ GetSpinboxElement(
  *	TCL_OK.
  *
  * Side effects:
- *	An background error condition may arise when invoking the callback.
+ *	A background error condition may arise when invoking the callback.
  *	The widget value may change.
  *
  *--------------------------------------------------------------
@@ -4182,6 +4217,7 @@ SpinboxInvoke(
 	return TCL_OK;
     }
 
+    code = TCL_OK;
     if (fabs(sbPtr->increment) > MIN_DBL_VAL) {
 	if (sbPtr->listObj != NULL) {
 	    Tcl_Obj *objPtr;
@@ -4227,7 +4263,7 @@ SpinboxInvoke(
 		}
 	    }
 	    Tcl_ListObjIndex(interp, sbPtr->listObj, sbPtr->eIndex, &objPtr);
-	    EntryValueChanged(entryPtr, Tcl_GetString(objPtr));
+	    code = EntryValueChanged(entryPtr, Tcl_GetString(objPtr));
 	} else if (!DOUBLES_EQ(sbPtr->fromValue, sbPtr->toValue)) {
 	    double dvalue;
 
@@ -4274,9 +4310,12 @@ SpinboxInvoke(
 		}
 	    }
 	    sprintf(sbPtr->formatBuf, sbPtr->valueFormat, dvalue);
-	    EntryValueChanged(entryPtr, sbPtr->formatBuf);
+	    code = EntryValueChanged(entryPtr, sbPtr->formatBuf);
 	}
     }
+    if (code != TCL_OK) {
+        return TCL_ERROR;
+    }
 
     if (sbPtr->command != NULL) {
 	Tcl_DStringInit(&script);
diff --git a/tests/entry.test b/tests/entry.test
index 27acfc1..da8f280 100644
--- a/tests/entry.test
+++ b/tests/entry.test
@@ -1621,13 +1621,26 @@ test entry-22.1 {lost namespaced textvar} {
     namespace eval test { variable foo {a b} }
     entry .e -textvariable ::test::foo
     namespace delete test
-    .e insert end "more stuff"
-    .e delete 5 end
-    catch {set ::test::foo} result
-    list [.e get] [.e cget -textvar] $result
+    catch {.e insert end "more stuff"} result1
+    catch {.e delete 5 end} result2
+    catch {set ::test::foo} result3
+    list [.e get] [.e cget -textvar] $result1 $result2 $result3
 } [list "a bmo" ::test::foo \
+	{can't set "::test::foo": parent namespace doesn't exist} \
+	{can't set "::test::foo": parent namespace doesn't exist} \
 	{can't read "::test::foo": no such variable}]
 
+test entry-23.1 {error in trace proc attached to the textvariable} {
+    destroy .e
+    trace variable myvar w traceit
+    proc traceit args {error "Intentional error here!"}
+    entry .e -textvariable myvar
+    catch {.e insert end mystring} result1
+    catch {.e delete 0} result2
+    list $result1 $result2
+} [list {can't set "myvar": Intentional error here!} \
+    {can't set "myvar": Intentional error here!}]
+
 destroy .e
 
 # XXX Still need to write tests for EntryBlinkProc, EntryFocusProc,
diff --git a/tests/spinbox.test b/tests/spinbox.test
index 0661635..5fba390 100644
--- a/tests/spinbox.test
+++ b/tests/spinbox.test
@@ -1583,6 +1583,22 @@ test spinbox-23.1 {selection present while disabled, bug 637828} {
 } {1 1 345}
 
 destroy .e
+
+test spinbox-24.1 {error in trace proc attached to the textvariable} {
+    destroy .s
+    trace variable myvar w traceit
+    proc traceit args {error "Intentional error here!"}
+    spinbox .s -textvariable myvar -from 1 -to 10
+    catch {.s set mystring} result1
+    catch {.s insert 0 mystring} result2
+    catch {.s delete 0} result3
+    catch {.s invoke buttonup} result4
+    list $result1 $result2 $result3 $result4
+} [list {can't set "myvar": Intentional error here!} \
+    {can't set "myvar": Intentional error here!} \
+    {can't set "myvar": Intentional error here!} \
+    {can't set "myvar": Intentional error here!}]
+
 catch {unset ::e ::vVals}
 
 ##