Fix [39f6304c2e]: Tcl_LinkVar is not tolerant to minus, plus, dot

2 files changed, 256 insertions, 40 deletions

diff --git a/generic/tclLink.c b/generic/tclLink.c
index cf7fa17..0b21997 100644
--- a/generic/tclLink.c
+++ b/generic/tclLink.c
@@ -67,6 +67,10 @@ typedef struct Link {
 static char *		LinkTraceProc(ClientData clientData,Tcl_Interp *interp,
 			    CONST char *name1, CONST char *name2, int flags);
 static Tcl_Obj *	ObjValue(Link *linkPtr);
+static int		GetInvalidIntFromObj(Tcl_Obj *objPtr,
+				int *intPtr);
+static int		GetInvalidDoubleFromObj(Tcl_Obj *objPtr,
+				double *doublePtr);
 
 /*
  * Convenience macro for accessing the value of the C variable pointed to by a
@@ -382,9 +386,12 @@ LinkTraceProc(
     case TCL_LINK_INT:
 	if (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i)
 		!= TCL_OK) {
-	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+	    if (GetInvalidIntFromObj(valueObj, &linkPtr->lastValue.i)
+		    != TCL_OK) {
+		Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
 		    TCL_GLOBAL_ONLY);
-	    return "variable must have integer value";
+		return "variable must have integer value";
+	    }
 	}
 	LinkedVar(int) = linkPtr->lastValue.i;
 	break;
@@ -392,12 +399,15 @@ LinkTraceProc(
     case TCL_LINK_WIDE_INT:
 	if (Tcl_GetWideIntFromObj(NULL, valueObj, &linkPtr->lastValue.w)
 		!= TCL_OK) {
-	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+	    if (GetInvalidIntFromObj(valueObj, &valueInt)
+		    != TCL_OK) {
+		Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
 		    TCL_GLOBAL_ONLY);
-	    return "variable must have integer value";
-	} else {
-	    LinkedVar(Tcl_WideInt) = linkPtr->lastValue.w;
+		return "variable must have integer value";
+	    }
+	    linkPtr->lastValue.w = (Tcl_WideInt) valueInt;
 	}
+	LinkedVar(Tcl_WideInt) = linkPtr->lastValue.w;
 	break;
 
     case TCL_LINK_DOUBLE:
@@ -406,13 +416,15 @@ LinkTraceProc(
 #ifdef ACCEPT_NAN
 	    if (valueObj->typePtr != &tclDoubleType) {
 #endif
-		Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
-			ObjValue(linkPtr), TCL_GLOBAL_ONLY);
-		return "variable must have real value";
+		if (GetInvalidDoubleFromObj(valueObj, &linkPtr->lastValue.d)
+			!= TCL_OK) {
+		    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+			TCL_GLOBAL_ONLY);
+		    return "variable must have real value";
+		}
 #ifdef ACCEPT_NAN
-	    } else {
-		linkPtr->lastValue.d = valueObj->internalRep.doubleValue;
 	    }
+	    linkPtr->lastValue.d = valueObj->internalRep.doubleValue;
 #endif
 	}
 	LinkedVar(double) = linkPtr->lastValue.d;
@@ -431,9 +443,12 @@ LinkTraceProc(
     case TCL_LINK_CHAR:
 	if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
 		|| valueInt < SCHAR_MIN || valueInt > SCHAR_MAX) {
-	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
-		    TCL_GLOBAL_ONLY);
-	    return "variable must have char value";
+	    if (GetInvalidIntFromObj(valueObj, &valueInt)
+		    != TCL_OK) {
+		Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+			TCL_GLOBAL_ONLY);
+		return "variable must have char value";
+	    }
 	}
 	linkPtr->lastValue.c = (char)valueInt;
 	LinkedVar(char) = linkPtr->lastValue.c;
@@ -442,9 +457,12 @@ LinkTraceProc(
     case TCL_LINK_UCHAR:
 	if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
 		|| valueInt < 0 || valueInt > UCHAR_MAX) {
-	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
-		    TCL_GLOBAL_ONLY);
-	    return "variable must have unsigned char value";
+	    if (GetInvalidIntFromObj(valueObj, &valueInt)
+		    != TCL_OK) {
+		Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+			TCL_GLOBAL_ONLY);
+		return "variable must have unsigned char value";
+	    }
 	}
 	linkPtr->lastValue.uc = (unsigned char) valueInt;
 	LinkedVar(unsigned char) = linkPtr->lastValue.uc;
@@ -453,9 +471,12 @@ LinkTraceProc(
     case TCL_LINK_SHORT:
 	if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
 		|| valueInt < SHRT_MIN || valueInt > SHRT_MAX) {
-	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
-		    TCL_GLOBAL_ONLY);
-	    return "variable must have short value";
+	    if (GetInvalidIntFromObj(valueObj, &valueInt)
+		    != TCL_OK) {
+		Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+			TCL_GLOBAL_ONLY);
+		return "variable must have short value";
+	    }
 	}
 	linkPtr->lastValue.s = (short)valueInt;
 	LinkedVar(short) = linkPtr->lastValue.s;
@@ -464,9 +485,12 @@ LinkTraceProc(
     case TCL_LINK_USHORT:
 	if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
 		|| valueInt < 0 || valueInt > USHRT_MAX) {
-	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
-		    TCL_GLOBAL_ONLY);
-	    return "variable must have unsigned short value";
+	    if (GetInvalidIntFromObj(valueObj, &valueInt)
+		    != TCL_OK) {
+		Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+			TCL_GLOBAL_ONLY);
+		return "variable must have unsigned short value";
+	    }
 	}
 	linkPtr->lastValue.us = (unsigned short)valueInt;
 	LinkedVar(unsigned short) = linkPtr->lastValue.us;
@@ -475,9 +499,13 @@ LinkTraceProc(
     case TCL_LINK_UINT:
 	if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
 		|| valueWide < 0 || valueWide > UINT_MAX) {
-	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
-		    TCL_GLOBAL_ONLY);
-	    return "variable must have unsigned int value";
+	    if (GetInvalidIntFromObj(valueObj, &valueInt)
+		    != TCL_OK) {
+		Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+			TCL_GLOBAL_ONLY);
+		return "variable must have unsigned int value";
+	    }
+	    linkPtr->lastValue.ui = (unsigned int)valueInt;
 	} else {
 	    linkPtr->lastValue.ui = (unsigned int)valueWide;
 	}
@@ -487,9 +515,13 @@ LinkTraceProc(
     case TCL_LINK_LONG:
 	if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
 		|| valueWide < LONG_MIN || valueWide > LONG_MAX) {
-	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
-		    TCL_GLOBAL_ONLY);
-	    return "variable must have long value";
+	    if (GetInvalidIntFromObj(valueObj, &valueInt)
+		    != TCL_OK) {
+		Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+			TCL_GLOBAL_ONLY);
+		return "variable must have long value";
+	    }
+	    linkPtr->lastValue.l = (long)valueInt;
 	} else {
 	    linkPtr->lastValue.l = (long)valueWide;
 	}
@@ -499,9 +531,13 @@ LinkTraceProc(
     case TCL_LINK_ULONG:
 	if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
 		|| valueWide < 0 || (Tcl_WideUInt) valueWide > ULONG_MAX) {
-	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
-		    TCL_GLOBAL_ONLY);
-	    return "variable must have unsigned long value";
+	    if (GetInvalidIntFromObj(valueObj, &valueInt)
+		    != TCL_OK) {
+		Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+			TCL_GLOBAL_ONLY);
+		return "variable must have unsigned long value";
+	    }
+	    linkPtr->lastValue.ul = (unsigned long)valueInt;
 	} else {
 	    linkPtr->lastValue.ul = (unsigned long)valueWide;
 	}
@@ -513,9 +549,13 @@ LinkTraceProc(
 	 * FIXME: represent as a bignum.
 	 */
 	if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK) {
-	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
-		    TCL_GLOBAL_ONLY);
-	    return "variable must have unsigned wide int value";
+	    if (GetInvalidIntFromObj(valueObj, &valueInt)
+		    != TCL_OK) {
+		Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+			TCL_GLOBAL_ONLY);
+		return "variable must have unsigned wide int value";
+	    }
+	    linkPtr->lastValue.uw = (Tcl_WideUInt)valueInt;
 	} else {
 	    linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide;
 	}
@@ -525,12 +565,14 @@ LinkTraceProc(
     case TCL_LINK_FLOAT:
 	if (Tcl_GetDoubleFromObj(NULL, valueObj, &valueDouble) != TCL_OK
 		|| valueDouble < -FLT_MAX || valueDouble > FLT_MAX) {
-	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
-		    TCL_GLOBAL_ONLY);
-	    return "variable must have float value";
-	} else {
-	    linkPtr->lastValue.f = (float)valueDouble;
+	    if (GetInvalidDoubleFromObj(valueObj, &valueDouble)
+		    != TCL_OK) {
+		Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+			TCL_GLOBAL_ONLY);
+		return "variable must have float value";
+	    }
 	}
+	linkPtr->lastValue.f = (float)valueDouble;
 	LinkedVar(float) = linkPtr->lastValue.f;
 	break;
 
@@ -635,6 +677,96 @@ ObjValue(
 	return resultObj;
     }
 }
+
+static int SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
+
+static Tcl_ObjType invalidRealType = {
+    "invalidReal",			/* name */
+    NULL,				/* freeIntRepProc */
+    NULL,				/* dupIntRepProc */
+    NULL,				/* updateStringProc */
+    SetInvalidRealFromAny		/* setFromAnyProc */
+};
+
+static int
+SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) {
+    int length;
+    const char *str;
+    const char *endPtr;
+
+    str = TclGetStringFromObj(objPtr, &length);
+    if ((length == 1) && (str[0] == '.')){
+	objPtr->typePtr = &invalidRealType;
+	objPtr->internalRep.doubleValue = 0.0;
+	return TCL_OK;
+    }
+    if (TclParseNumber(NULL, objPtr, NULL, str, length, &endPtr,
+	    TCL_PARSE_DECIMAL_ONLY) == TCL_OK) {
+	/* If number is followed by [eE][+-]?, then it is an invalid
+	 * double, but it could be the start of a valid double. */
+	if (*endPtr == 'e' || *endPtr == 'E') {
+	    ++endPtr;
+	    if (*endPtr == '+' || *endPtr == '-') ++endPtr;
+	    if (*endPtr == 0) {
+		double doubleValue = 0.0;
+		Tcl_GetDoubleFromObj(NULL, objPtr, &doubleValue);
+		if (objPtr->typePtr->freeIntRepProc) objPtr->typePtr->freeIntRepProc(objPtr);
+		objPtr->typePtr = &invalidRealType;
+		objPtr->internalRep.doubleValue = doubleValue;
+		return TCL_OK;
+	    }
+	}
+    }
+    return TCL_ERROR;
+}
+
+
+/*
+ * This function checks for integer representations, which are valid
+ * when linking with C variables, but which are invalid in other
+ * contexts in Tcl. Handled are "+", "-", "0x", "0b" and "0o" (upper-
+ * and lowercase). See bug [39f6304c2e].
+ */
+int
+GetInvalidIntFromObj(Tcl_Obj *objPtr,
+				int *intPtr)
+{
+    int length;
+    const char *str = TclGetStringFromObj(objPtr, &length);
+
+    if ((length == 1) && strchr("+-", str[0])) {
+	*intPtr = (str[0] == '+');
+	return TCL_OK;
+    } else if ((length == 2) && (str[0] == '0') && strchr("xXbBoO", str[1])) {
+	*intPtr = 0;
+	return TCL_OK;
+    }
+    return TCL_ERROR;
+}
+
+/*
+ * This function checks for double representations, which are valid
+ * when linking with C variables, but which are invalid in other
+ * contexts in Tcl. Handled are ".", "+", "-", "0x", "0b" and "0o"
+ * (upper- and lowercase) and sequences like "1e-". See bug [39f6304c2e].
+ */
+int
+GetInvalidDoubleFromObj(Tcl_Obj *objPtr,
+				double *doublePtr)
+{
+    int intValue, result;
+
+    if ((objPtr->typePtr == &invalidRealType) ||
+	    (SetInvalidRealFromAny(NULL, objPtr) == TCL_OK)) {
+	*doublePtr = objPtr->internalRep.doubleValue;
+	return TCL_OK;
+    }
+    result = GetInvalidIntFromObj(objPtr, &intValue);
+    if (result == TCL_OK) {
+	*doublePtr = (double) intValue;
+    }
+    return result;
+}
 
 /*
  * Local Variables:
diff --git a/tests/link.test b/tests/link.test
index 3b423ec..7bde482 100644
--- a/tests/link.test
+++ b/tests/link.test
@@ -78,6 +78,90 @@ test link-2.5 {writing bad values into variables} {testlink} {
     testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
     list [catch {set wide gorp} msg] $msg $bool
 } {1 {can't set "wide": variable must have integer value} 1}
+test link-2.6 {writing C variables from Tcl} -constraints {testlink} -setup {
+    testlink delete
+} -body {
+    testlink set 43 1.21 4 - 56785678 64 250 30000 60000 0xbaadbeef 12321 32123 3.25 1231231234
+    testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+    set int "+"
+    set real "+"
+    set bool 1
+    set string "+"
+    set wide "+"
+    set char "+"
+    set uchar "+"
+    set short "+"
+    set ushort "+"
+    set uint "+"
+    set long "+"
+    set ulong "+"
+    set float "+"
+    set uwide "+"
+    concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide
+} -result {1 1.0 1 + 1 1 1 1 1 1 1 1 1.0 1 | + + 1 + + + + + + + + + + +}
+test link-2.7 {writing C variables from Tcl} -constraints {testlink} -setup {
+    testlink delete
+} -body {
+    testlink set 43 1.21 4 - 56785678 64 250 30000 60000 0xbaadbeef 12321 32123 3.25 1231231234
+    testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+    set int "-"
+    set real "-"
+    set bool 0
+    set string "-"
+    set wide "-"
+    set char "-"
+    set uchar "-"
+    set short "-"
+    set ushort "-"
+    set uint "-"
+    set long "-"
+    set ulong "-"
+    set float "-"
+    set uwide "-"
+    concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide
+} -result {0 0.0 0 - 0 0 0 0 0 0 0 0 0.0 0 | - - 0 - - - - - - - - - - -}
+test link-2.8 {writing C variables from Tcl} -constraints {testlink} -setup {
+    testlink delete
+} -body {
+    testlink set 43 1.21 4 - 56785678 64 250 30000 60000 0xbaadbeef 12321 32123 3.25 1231231234
+    testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+    set int "0x"
+    set real "0b"
+    set bool 0
+    set string "0"
+    set wide "0O"
+    set char "0X"
+    set uchar "0B"
+    set short "0O"
+    set ushort "0x"
+    set uint "0b"
+    set long "0o"
+    set ulong "0X"
+    set float "0B"
+    set uwide "0O"
+    concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide
+} -result {0 0.0 0 0 0 0 0 0 0 0 0 0 0.0 0 | 0x 0b 0 0 0O 0X 0B 0O 0x 0b 0o 0X 0B 0O}
+test link-2.8 {writing C variables from Tcl} -constraints {testlink} -setup {
+    testlink delete
+} -body {
+    testlink set 43 1.21 4 - 56785678 64 250 30000 60000 0xbaadbeef 12321 32123 3.25 1231231234
+    testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1
+    set int 0
+    set real 5000e
+    set bool 0
+    set string 0
+    set wide 0
+    set char 0
+    set uchar 0
+    set short 0
+    set ushort 0
+    set uint 0
+    set long 0
+    set ulong 0
+    set float -60.00e+
+    set uwide 0
+    concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide
+} -result {0 5000.0 0 0 0 0 0 0 0 0 0 0 -60.0 0 | 0 5000e 0 0 0 0 0 0 0 0 0 0 -60.00e+ 0}
 
 test link-3.1 {read-only variables} {testlink} {
     testlink delete