summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclLink.c169
1 files changed, 129 insertions, 40 deletions
diff --git a/generic/tclLink.c b/generic/tclLink.c
index cf7fa17..f719ade 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,53 @@ ObjValue(
return resultObj;
}
}
+/*
+ * This function works almost the same as Tcl_GetBooleanFromObj(), only
+ * it doesn't have an interpreter to report errors, and it considers
+ * the character sequences "0x", "0b" and "0o" as valid, for purpose
+ * of the link functionality in Tcl. 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_GetBooleanFromObj(NULL, objPtr, intPtr);
+}
+
+/*
+ * This function works almost the same as Tcl_GetBooleanFromObj(), only
+ * it returns a double in stead of an integer, it doesn't have an interpreter
+ * to report errors, and it considers the character sequences ".", "0x", "0b"
+ * and "0o" as valid, for purpose of the link functionality in Tcl.
+ * See bug [39f6304c2e].
+ */
+int
+GetInvalidDoubleFromObj(Tcl_Obj *objPtr,
+ double *doublePtr)
+{
+ int length, intValue, result;
+ const char *str = TclGetStringFromObj(objPtr, &length);
+
+ if ((length == 1) && (str[0] == '.')){
+ *doublePtr = 0.0;
+ return TCL_OK;
+ }
+ result = GetInvalidIntFromObj(objPtr, &intValue);
+ if (result == TCL_OK) {
+ *doublePtr = (double) intValue;
+ }
+ return result;
+}
/*
* Local Variables:
generated by cgit v0.12 at 2024-11-22 03:46:24 (GMT)