diff options
| -rw-r--r-- | generic/tclLink.c | 212 | ||||
| -rw-r--r-- | tests/link.test | 84 |
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 |