diff options
| -rw-r--r-- | generic/tclLink.c | 80 | ||||
| -rw-r--r-- | tests/link.test | 84 |
2 files changed, 146 insertions, 18 deletions
diff --git a/generic/tclLink.c b/generic/tclLink.c index 8a0cb57..588c750 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 GetInvalidIntOrBooleanFromObj(Tcl_Obj *objPtr, + int *intPtr); +static int GetInvalidDoubleOrBooleanFromObj(Tcl_Obj *objPtr, + double *doublePtr); /* * Convenience macro for accessing the value of the C variable pointed to by a @@ -381,7 +385,7 @@ LinkTraceProc( case TCL_LINK_INT: if (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK) { - if (Tcl_GetBooleanFromObj(NULL, valueObj, &linkPtr->lastValue.i) + if (GetInvalidIntOrBooleanFromObj(valueObj, &linkPtr->lastValue.i) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); @@ -394,7 +398,7 @@ LinkTraceProc( case TCL_LINK_WIDE_INT: if (Tcl_GetWideIntFromObj(NULL, valueObj, &linkPtr->lastValue.w) != TCL_OK) { - if (Tcl_GetBooleanFromObj(NULL, valueObj, &valueInt) + if (GetInvalidIntOrBooleanFromObj(valueObj, &valueInt) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); @@ -411,17 +415,15 @@ LinkTraceProc( #ifdef ACCEPT_NAN if (valueObj->typePtr != &tclDoubleType) { #endif - if (Tcl_GetBooleanFromObj(NULL, valueObj, &valueInt) + if (GetInvalidDoubleOrBooleanFromObj(valueObj, &linkPtr->lastValue.d) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable must have real or boolean value"; } - linkPtr->lastValue.d = (double) valueInt; #ifdef ACCEPT_NAN - } else { - linkPtr->lastValue.d = valueObj->internalRep.doubleValue; } + linkPtr->lastValue.d = valueObj->internalRep.doubleValue; #endif } LinkedVar(double) = linkPtr->lastValue.d; @@ -440,7 +442,7 @@ LinkTraceProc( case TCL_LINK_CHAR: if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK || valueInt < SCHAR_MIN || valueInt > SCHAR_MAX) { - if (Tcl_GetBooleanFromObj(NULL, valueObj, &valueInt) + if (GetInvalidIntOrBooleanFromObj(valueObj, &valueInt) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); @@ -454,7 +456,7 @@ LinkTraceProc( case TCL_LINK_UCHAR: if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK || valueInt < 0 || valueInt > UCHAR_MAX) { - if (Tcl_GetBooleanFromObj(NULL, valueObj, &valueInt) + if (GetInvalidIntOrBooleanFromObj(valueObj, &valueInt) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); @@ -468,7 +470,7 @@ LinkTraceProc( case TCL_LINK_SHORT: if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK || valueInt < SHRT_MIN || valueInt > SHRT_MAX) { - if (Tcl_GetBooleanFromObj(NULL, valueObj, &valueInt) + if (GetInvalidIntOrBooleanFromObj(valueObj, &valueInt) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); @@ -482,7 +484,7 @@ LinkTraceProc( case TCL_LINK_USHORT: if (Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK || valueInt < 0 || valueInt > USHRT_MAX) { - if (Tcl_GetBooleanFromObj(NULL, valueObj, &valueInt) + if (GetInvalidIntOrBooleanFromObj(valueObj, &valueInt) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); @@ -496,7 +498,7 @@ LinkTraceProc( case TCL_LINK_UINT: if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK || valueWide < 0 || valueWide > UINT_MAX) { - if (Tcl_GetBooleanFromObj(NULL, valueObj, &valueInt) + if (GetInvalidIntOrBooleanFromObj(valueObj, &valueInt) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); @@ -512,7 +514,7 @@ LinkTraceProc( case TCL_LINK_LONG: if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK || valueWide < LONG_MIN || valueWide > LONG_MAX) { - if (Tcl_GetBooleanFromObj(NULL, valueObj, &valueInt) + if (GetInvalidIntOrBooleanFromObj(valueObj, &valueInt) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); @@ -528,7 +530,7 @@ LinkTraceProc( case TCL_LINK_ULONG: if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK || valueWide < 0 || (Tcl_WideUInt) valueWide > ULONG_MAX) { - if (Tcl_GetBooleanFromObj(NULL, valueObj, &valueInt) + if (GetInvalidIntOrBooleanFromObj(valueObj, &valueInt) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); @@ -546,7 +548,7 @@ LinkTraceProc( * FIXME: represent as a bignum. */ if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK) { - if (Tcl_GetBooleanFromObj(NULL, valueObj, &valueInt) + if (GetInvalidIntOrBooleanFromObj(valueObj, &valueInt) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); @@ -562,16 +564,14 @@ LinkTraceProc( case TCL_LINK_FLOAT: if (Tcl_GetDoubleFromObj(NULL, valueObj, &valueDouble) != TCL_OK || valueDouble < -FLT_MAX || valueDouble > FLT_MAX) { - if (Tcl_GetBooleanFromObj(NULL, valueObj, &valueInt) + if (GetInvalidDoubleOrBooleanFromObj(valueObj, &valueDouble) != TCL_OK) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return (char *) "variable must have float or boolean value"; } - linkPtr->lastValue.f = (float)valueInt; - } else { - linkPtr->lastValue.f = (float)valueDouble; } + linkPtr->lastValue.f = (float)valueDouble; LinkedVar(float) = linkPtr->lastValue.f; break; @@ -676,6 +676,50 @@ 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 +GetInvalidIntOrBooleanFromObj(Tcl_Obj *objPtr, + int *intPtr) +{ + const char *str = TclGetString(objPtr); + if ((str[0] == '0') && strchr("xXbBoO", str[1]) && (str[2] == 0)){ + *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 +GetInvalidDoubleOrBooleanFromObj(Tcl_Obj *objPtr, + double *doublePtr) +{ + int intValue, result; + const char *str = TclGetString(objPtr); + + if ((str[0] == '.') && (str[1] == 0)){ + *doublePtr = 0.0; + return TCL_OK; + } + result = GetInvalidIntOrBooleanFromObj(objPtr, &intValue); + if (result == TCL_OK) { + *doublePtr = (double) intValue; + } + return result; +} + + /* * Local Variables: diff --git a/tests/link.test b/tests/link.test index 0ea7cf6..71f3767 100644 --- a/tests/link.test +++ b/tests/link.test @@ -89,6 +89,90 @@ test link-2.5 {writing bad values into variables} -setup { testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 list [catch {set wide gorp} msg] $msg $bool } -result {1 {can't set "wide": variable must have integer or boolean 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 "+" + 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 | + + + + + + + + + + + + + +} +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 "-" + 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 | - - - - - - - - - - - - - -} +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 "o" + set real "." + set bool "o" + set string "o" + set wide "o" + set char "o" + set uchar "o" + set short "o" + set ushort "o" + set uint "o" + set long "o" + set ulong "o" + set float "." + set uwide "o" + concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide +} -result {0 0.0 0 o 0 0 0 0 0 0 0 0 0.0 0 | o . o o o o o o o o o o . o} +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-3.1 {read-only variables} -constraints {testlink} -setup { testlink delete |