diff options
author | dkf <donal.k.fellows@manchester.ac.uk> | 2001-11-07 13:35:21 (GMT) |
---|---|---|
committer | dkf <donal.k.fellows@manchester.ac.uk> | 2001-11-07 13:35:21 (GMT) |
commit | c03f19898ee10b76b9cdca420a91463e18347d3e (patch) | |
tree | 3869aaf5139ee4a031404320db013c959ffe59db | |
parent | c07feeb4d0bf827e20db9c4145c8751a36a9f733 (diff) | |
download | tcl-c03f19898ee10b76b9cdca420a91463e18347d3e.zip tcl-c03f19898ee10b76b9cdca420a91463e18347d3e.tar.gz tcl-c03f19898ee10b76b9cdca420a91463e18347d3e.tar.bz2 |
Following a suggestion by wdi@ccc.uni-erlangen.de (Wolf-Dietrich Ihlenfeldt),
This implements support for linking wide-int variables to Tcl variables.
It also moves the link-var system towards using 8.*-based interfaces!
-rw-r--r-- | doc/LinkVar.3 | 21 | ||||
-rw-r--r-- | generic/tcl.h | 3 | ||||
-rw-r--r-- | generic/tclLink.c | 229 | ||||
-rw-r--r-- | generic/tclTest.c | 61 | ||||
-rw-r--r-- | tests/link.test | 232 |
5 files changed, 309 insertions, 237 deletions
diff --git a/doc/LinkVar.3 b/doc/LinkVar.3 index 0a4a58f..e4ec181 100644 --- a/doc/LinkVar.3 +++ b/doc/LinkVar.3 @@ -5,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: LinkVar.3,v 1.3 2000/04/14 23:01:51 hobbs Exp $ +'\" RCS: @(#) $Id: LinkVar.3,v 1.3.16.1 2001/11/07 13:35:21 dkf Exp $ '\" .so man.macros .TH Tcl_LinkVar 3 7.5 Tcl "Tcl Library Procedures" @@ -34,6 +34,9 @@ temporary modifications to it while parsing the variable name. Address of C variable that is to be linked to \fIvarName\fR. .AP int type in Type of C variable. Must be one of TCL_LINK_INT, TCL_LINK_DOUBLE, +.VS 8.4 +TCL_LINK_WIDE_INT, +.VE 8.4 TCL_LINK_BOOLEAN, or TCL_LINK_STRING, optionally OR'ed with TCL_LINK_READ_ONLY to make Tcl variable read-only. .BE @@ -58,17 +61,27 @@ TCL_LINK_READ_ONLY: \fBTCL_LINK_INT\fR The C variable is of type \fBint\fR. Any value written into the Tcl variable must have a proper integer -form acceptable to \fBTcl_GetInt\fR; attempts to write +form acceptable to \fBTcl_GetIntFromObj\fR; attempts to write non-integer values into \fIvarName\fR will be rejected with Tcl errors. .TP \fBTCL_LINK_DOUBLE\fR The C variable is of type \fBdouble\fR. Any value written into the Tcl variable must have a proper real -form acceptable to \fBTcl_GetDouble\fR; attempts to write +form acceptable to \fBTcl_GetDoubleFromObj\fR; attempts to write non-real values into \fIvarName\fR will be rejected with Tcl errors. .TP +\fBTCL_LINK_WIDE_INT\fR +.VS 8.4 +The C variable is of type \fBTcl_WideInt\fR (which is an integer type +at least 64-bits wide on all platforms that can support it.) +Any value written into the Tcl variable must have a proper integer +form acceptable to \fBTcl_GetWideIntFromObj\fR; attempts to write +non-integer values into \fIvarName\fR will be rejected with +Tcl errors. +.VE 8.4 +.TP \fBTCL_LINK_BOOLEAN\fR The C variable is of type \fBint\fR. If its value is zero then it will read from Tcl as ``0''; @@ -76,7 +89,7 @@ otherwise it will read from Tcl as ``1''. Whenever \fIvarName\fR is modified, the C variable will be set to a 0 or 1 value. Any value written into the Tcl variable must have a proper boolean -form acceptable to \fBTcl_GetBoolean\fR; attempts to write +form acceptable to \fBTcl_GetBooleanFromObj\fR; attempts to write non-boolean values into \fIvarName\fR will be rejected with Tcl errors. .TP diff --git a/generic/tcl.h b/generic/tcl.h index e86be74..d801aab 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tcl.h,v 1.102.2.21 2001/10/19 13:07:15 dkf Exp $ + * RCS: @(#) $Id: tcl.h,v 1.102.2.22 2001/11/07 13:35:21 dkf Exp $ */ #ifndef _TCL @@ -1041,6 +1041,7 @@ typedef struct Tcl_DString { #define TCL_LINK_DOUBLE 2 #define TCL_LINK_BOOLEAN 3 #define TCL_LINK_STRING 4 +#define TCL_LINK_WIDE_INT 5 #define TCL_LINK_READ_ONLY 0x80 diff --git a/generic/tclLink.c b/generic/tclLink.c index 20f9191..60d7bf0 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclLink.c,v 1.3 1999/04/16 00:46:49 stanton Exp $ + * RCS: @(#) $Id: tclLink.c,v 1.3.26.1 2001/11/07 13:35:21 dkf Exp $ */ #include "tclInt.h" @@ -26,7 +26,7 @@ typedef struct Link { Tcl_Interp *interp; /* Interpreter containing Tcl variable. */ - char *varName; /* Name of variable (must be global). This + Tcl_Obj *varName; /* Name of variable (must be global). This * is needed during trace callbacks, since * the actual variable may be aliased at * that time via upvar. */ @@ -35,6 +35,7 @@ typedef struct Link { union { int i; double d; + Tcl_WideInt w; } lastValue; /* Last known value of C variable; used to * avoid string conversions. */ int flags; /* Miscellaneous one-bit values; see below @@ -61,8 +62,7 @@ typedef struct Link { static char * LinkTraceProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, char *name1, char *name2, int flags)); -static char * StringValue _ANSI_ARGS_((Link *linkPtr, - char *buffer)); +static Tcl_Obj * ObjValue _ANSI_ARGS_((Link *linkPtr)); /* *---------------------------------------------------------------------- @@ -96,13 +96,12 @@ Tcl_LinkVar(interp, varName, addr, type) * OR'ed in. */ { Link *linkPtr; - char buffer[TCL_DOUBLE_SPACE]; int code; linkPtr = (Link *) ckalloc(sizeof(Link)); linkPtr->interp = interp; - linkPtr->varName = (char *) ckalloc((unsigned) (strlen(varName) + 1)); - strcpy(linkPtr->varName, varName); + linkPtr->varName = Tcl_NewStringObj(varName, -1); + Tcl_IncrRefCount(linkPtr->varName); linkPtr->addr = addr; linkPtr->type = type & ~TCL_LINK_READ_ONLY; if (type & TCL_LINK_READ_ONLY) { @@ -110,9 +109,9 @@ Tcl_LinkVar(interp, varName, addr, type) } else { linkPtr->flags = 0; } - if (Tcl_SetVar(interp, varName, StringValue(linkPtr, buffer), + if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { - ckfree(linkPtr->varName); + Tcl_DecrRefCount(linkPtr->varName); ckfree((char *) linkPtr); return TCL_ERROR; } @@ -120,7 +119,7 @@ Tcl_LinkVar(interp, varName, addr, type) |TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, (ClientData) linkPtr); if (code != TCL_OK) { - ckfree(linkPtr->varName); + Tcl_DecrRefCount(linkPtr->varName); ckfree((char *) linkPtr); } return code; @@ -159,7 +158,7 @@ Tcl_UnlinkVar(interp, varName) Tcl_UntraceVar(interp, varName, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, (ClientData) linkPtr); - ckfree(linkPtr->varName); + Tcl_DecrRefCount(linkPtr->varName); ckfree((char *) linkPtr); } @@ -188,7 +187,6 @@ Tcl_UpdateLinkedVar(interp, varName) char *varName; /* Name of global variable that is linked. */ { Link *linkPtr; - char buffer[TCL_DOUBLE_SPACE]; int savedFlag; linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY, @@ -198,7 +196,7 @@ Tcl_UpdateLinkedVar(interp, varName) } savedFlag = linkPtr->flags & LINK_BEING_UPDATED; linkPtr->flags |= LINK_BEING_UPDATED; - Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); linkPtr->flags = (linkPtr->flags & ~LINK_BEING_UPDATED) | savedFlag; } @@ -233,10 +231,9 @@ LinkTraceProc(clientData, interp, name1, name2, flags) int flags; /* Miscellaneous additional information. */ { Link *linkPtr = (Link *) clientData; - int changed; - char buffer[TCL_DOUBLE_SPACE]; + int changed, valueLength; char *value, **pp, *result; - Tcl_Obj *objPtr; + Tcl_Obj *objPtr, *valueObj; /* * If the variable is being unset, then just re-create it (with a @@ -245,14 +242,14 @@ LinkTraceProc(clientData, interp, name1, name2, flags) if (flags & TCL_TRACE_UNSETS) { if (flags & TCL_INTERP_DESTROYED) { - ckfree(linkPtr->varName); + Tcl_DecrRefCount(linkPtr->varName); ckfree((char *) linkPtr); } else if (flags & TCL_TRACE_DESTROYED) { - Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); - Tcl_TraceVar(interp, linkPtr->varName, TCL_GLOBAL_ONLY - |TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - LinkTraceProc, (ClientData) linkPtr); + Tcl_TraceVar(interp, Tcl_GetString(linkPtr->varName), + TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES + |TCL_TRACE_UNSETS, LinkTraceProc, (ClientData) linkPtr); } return NULL; } @@ -275,21 +272,24 @@ LinkTraceProc(clientData, interp, name1, name2, flags) if (flags & TCL_TRACE_READS) { switch (linkPtr->type) { - case TCL_LINK_INT: - case TCL_LINK_BOOLEAN: - changed = *(int *)(linkPtr->addr) != linkPtr->lastValue.i; - break; - case TCL_LINK_DOUBLE: - changed = *(double *)(linkPtr->addr) != linkPtr->lastValue.d; - break; - case TCL_LINK_STRING: - changed = 1; - break; - default: - return "internal error: bad linked variable type"; + case TCL_LINK_INT: + case TCL_LINK_BOOLEAN: + changed = *(int *)(linkPtr->addr) != linkPtr->lastValue.i; + break; + case TCL_LINK_DOUBLE: + changed = *(double *)(linkPtr->addr) != linkPtr->lastValue.d; + break; + case TCL_LINK_WIDE_INT: + changed = *(Tcl_WideInt *)(linkPtr->addr) != linkPtr->lastValue.w; + break; + case TCL_LINK_STRING: + changed = 1; + break; + default: + return "internal error: bad linked variable type"; } if (changed) { - Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); } return NULL; @@ -305,12 +305,12 @@ LinkTraceProc(clientData, interp, name1, name2, flags) */ if (linkPtr->flags & LINK_READ_ONLY) { - Tcl_SetVar(interp, linkPtr->varName, StringValue(linkPtr, buffer), + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); return "linked variable is read-only"; } - value = Tcl_GetVar(interp, linkPtr->varName, TCL_GLOBAL_ONLY); - if (value == NULL) { + valueObj = Tcl_ObjGetVar2(interp, linkPtr->varName,NULL, TCL_GLOBAL_ONLY); + if (valueObj == NULL) { /* * This shouldn't ever happen. */ @@ -323,48 +323,62 @@ LinkTraceProc(clientData, interp, name1, name2, flags) result = NULL; switch (linkPtr->type) { - case TCL_LINK_INT: - if (Tcl_GetInt(interp, value, &linkPtr->lastValue.i) != TCL_OK) { - Tcl_SetObjResult(interp, objPtr); - Tcl_SetVar(interp, linkPtr->varName, - StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY); - result = "variable must have integer value"; - goto end; - } - *(int *)(linkPtr->addr) = linkPtr->lastValue.i; - break; - case TCL_LINK_DOUBLE: - if (Tcl_GetDouble(interp, value, &linkPtr->lastValue.d) - != TCL_OK) { - Tcl_SetObjResult(interp, objPtr); - Tcl_SetVar(interp, linkPtr->varName, - StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY); - result = "variable must have real value"; - goto end; - } - *(double *)(linkPtr->addr) = linkPtr->lastValue.d; - break; - case TCL_LINK_BOOLEAN: - if (Tcl_GetBoolean(interp, value, &linkPtr->lastValue.i) - != TCL_OK) { - Tcl_SetObjResult(interp, objPtr); - Tcl_SetVar(interp, linkPtr->varName, - StringValue(linkPtr, buffer), TCL_GLOBAL_ONLY); - result = "variable must have boolean value"; - goto end; - } - *(int *)(linkPtr->addr) = linkPtr->lastValue.i; - break; - case TCL_LINK_STRING: - pp = (char **)(linkPtr->addr); - if (*pp != NULL) { - ckfree(*pp); - } - *pp = (char *) ckalloc((unsigned) (strlen(value) + 1)); - strcpy(*pp, value); - break; - default: - return "internal error: bad linked variable type"; + case TCL_LINK_INT: + if (Tcl_GetIntFromObj(interp, valueObj, &linkPtr->lastValue.i) + != TCL_OK) { + Tcl_SetObjResult(interp, objPtr); + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + result = "variable must have integer value"; + goto end; + } + *(int *)(linkPtr->addr) = linkPtr->lastValue.i; + break; + case TCL_LINK_WIDE_INT: + if (Tcl_GetWideIntFromObj(interp, valueObj, &linkPtr->lastValue.w) + != TCL_OK) { + Tcl_SetObjResult(interp, objPtr); + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + result = "variable must have integer value"; + goto end; + } + *(Tcl_WideInt *)(linkPtr->addr) = linkPtr->lastValue.w; + break; + case TCL_LINK_DOUBLE: + if (Tcl_GetDoubleFromObj(interp, valueObj, &linkPtr->lastValue.d) + != TCL_OK) { + Tcl_SetObjResult(interp, objPtr); + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + result = "variable must have real value"; + goto end; + } + *(double *)(linkPtr->addr) = linkPtr->lastValue.d; + break; + case TCL_LINK_BOOLEAN: + if (Tcl_GetBooleanFromObj(interp, valueObj, &linkPtr->lastValue.i) + != TCL_OK) { + Tcl_SetObjResult(interp, objPtr); + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), + TCL_GLOBAL_ONLY); + result = "variable must have boolean value"; + goto end; + } + *(int *)(linkPtr->addr) = linkPtr->lastValue.i; + break; + case TCL_LINK_STRING: + value = Tcl_GetStringFromObj(valueObj, &valueLength); + valueLength++; + pp = (char **)(linkPtr->addr); + if (*pp != NULL) { + ckfree(*pp); + } + *pp = (char *) ckalloc((unsigned) valueLength); + memcpy(*pp, value, (unsigned) valueLength); + break; + default: + return "internal error: bad linked variable type"; } end: Tcl_DecrRefCount(objPtr); @@ -374,13 +388,13 @@ LinkTraceProc(clientData, interp, name1, name2, flags) /* *---------------------------------------------------------------------- * - * StringValue -- + * ObjValue -- * - * Converts the value of a C variable to a string for use in a + * Converts the value of a C variable to a Tcl_Obj* for use in a * Tcl variable to which it is linked. * * Results: - * The return value is a pointer to a string that represents + * The return value is a pointer to a Tcl_Obj that represents * the value of the C variable given by linkPtr. * * Side effects: @@ -389,42 +403,37 @@ LinkTraceProc(clientData, interp, name1, name2, flags) *---------------------------------------------------------------------- */ -static char * -StringValue(linkPtr, buffer) +static Tcl_Obj * +ObjValue(linkPtr) Link *linkPtr; /* Structure describing linked variable. */ - char *buffer; /* Small buffer to use for converting - * values. Must have TCL_DOUBLE_SPACE - * bytes or more. */ { char *p; switch (linkPtr->type) { - case TCL_LINK_INT: - linkPtr->lastValue.i = *(int *)(linkPtr->addr); - TclFormatInt(buffer, linkPtr->lastValue.i); - return buffer; - case TCL_LINK_DOUBLE: - linkPtr->lastValue.d = *(double *)(linkPtr->addr); - Tcl_PrintDouble((Tcl_Interp *) NULL, linkPtr->lastValue.d, buffer); - return buffer; - case TCL_LINK_BOOLEAN: - linkPtr->lastValue.i = *(int *)(linkPtr->addr); - if (linkPtr->lastValue.i != 0) { - return "1"; - } - return "0"; - case TCL_LINK_STRING: - p = *(char **)(linkPtr->addr); - if (p == NULL) { - return "NULL"; - } - return p; - } + case TCL_LINK_INT: + linkPtr->lastValue.i = *(int *)(linkPtr->addr); + return Tcl_NewIntObj(linkPtr->lastValue.i); + case TCL_LINK_WIDE_INT: + linkPtr->lastValue.w = *(Tcl_WideInt *)(linkPtr->addr); + return Tcl_NewWideIntObj(linkPtr->lastValue.w); + case TCL_LINK_DOUBLE: + linkPtr->lastValue.d = *(double *)(linkPtr->addr); + return Tcl_NewDoubleObj(linkPtr->lastValue.d); + case TCL_LINK_BOOLEAN: + linkPtr->lastValue.i = *(int *)(linkPtr->addr); + return Tcl_NewBooleanObj(linkPtr->lastValue.i != 0); + case TCL_LINK_STRING: + p = *(char **)(linkPtr->addr); + if (p == NULL) { + return Tcl_NewStringObj("NULL", 4); + } + return Tcl_NewStringObj(p, -1); /* * This code only gets executed if the link type is unknown * (shouldn't ever happen). */ - - return "??"; + default: + return Tcl_NewStringObj("??", 2); + } } diff --git a/generic/tclTest.c b/generic/tclTest.c index 902558f..e6baa25 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTest.c,v 1.31.2.3 2001/10/09 15:30:51 dkf Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.31.2.4 2001/11/07 13:35:21 dkf Exp $ */ #define TCL_TEST @@ -1974,22 +1974,31 @@ TestlinkCmd(dummy, interp, argc, argv) static int intVar = 43; static int boolVar = 4; static double realVar = 1.23; + static Tcl_WideInt wideVar = Tcl_LongAsWide(79); static char *stringVar = NULL; static int created = 0; - char buffer[TCL_DOUBLE_SPACE]; + char buffer[2*TCL_DOUBLE_SPACE]; int writable, flag; + Tcl_Obj *tmp; if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " option ?arg arg arg?\"", (char *) NULL); + " option ?arg arg arg arg arg?\"", (char *) NULL); return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { + if (argc != 7) { + Tcl_AppendResult(interp, "wrong # args: should be \"", + argv[0], " ", argv[1], + " intRO realRO boolRO stringRO wideRO\"", (char *) NULL); + return TCL_ERROR; + } if (created) { Tcl_UnlinkVar(interp, "int"); Tcl_UnlinkVar(interp, "real"); Tcl_UnlinkVar(interp, "bool"); Tcl_UnlinkVar(interp, "string"); + Tcl_UnlinkVar(interp, "wide"); } created = 1; if (Tcl_GetBoolean(interp, argv[2], &writable) != TCL_OK) { @@ -2024,11 +2033,20 @@ TestlinkCmd(dummy, interp, argc, argv) TCL_LINK_STRING | flag) != TCL_OK) { return TCL_ERROR; } + if (Tcl_GetBoolean(interp, argv[6], &writable) != TCL_OK) { + return TCL_ERROR; + } + flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + if (Tcl_LinkVar(interp, "wide", (char *) &wideVar, + TCL_LINK_WIDE_INT | flag) != TCL_OK) { + return TCL_ERROR; + } } else if (strcmp(argv[1], "delete") == 0) { Tcl_UnlinkVar(interp, "int"); Tcl_UnlinkVar(interp, "real"); Tcl_UnlinkVar(interp, "bool"); Tcl_UnlinkVar(interp, "string"); + Tcl_UnlinkVar(interp, "wide"); created = 0; } else if (strcmp(argv[1], "get") == 0) { TclFormatInt(buffer, intVar); @@ -2038,11 +2056,18 @@ TestlinkCmd(dummy, interp, argc, argv) TclFormatInt(buffer, boolVar); Tcl_AppendElement(interp, buffer); Tcl_AppendElement(interp, (stringVar == NULL) ? "-" : stringVar); + /* + * Wide ints only have an object-based interface. + */ + tmp = Tcl_NewWideIntObj(wideVar); + Tcl_AppendElement(interp, Tcl_GetString(tmp)); + Tcl_DecrRefCount(tmp); } else if (strcmp(argv[1], "set") == 0) { - if (argc != 6) { + if (argc != 7) { Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " ", argv[1], - "intValue realValue boolValue stringValue\"", (char *) NULL); + argv[0], " ", argv[1], + " intValue realValue boolValue stringValue wideValue\"", + (char *) NULL); return TCL_ERROR; } if (argv[2][0] != 0) { @@ -2071,11 +2096,20 @@ TestlinkCmd(dummy, interp, argc, argv) strcpy(stringVar, argv[5]); } } + if (argv[6][0] != 0) { + tmp = Tcl_NewStringObj(argv[6], -1); + if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) { + Tcl_DecrRefCount(tmp); + return TCL_ERROR; + } + Tcl_DecrRefCount(tmp); + } } else if (strcmp(argv[1], "update") == 0) { - if (argc != 6) { + if (argc != 7) { Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " ", argv[1], - "intValue realValue boolValue stringValue\"", (char *) NULL); + argv[0], " ", argv[1], + "intValue realValue boolValue stringValue wideValue\"", + (char *) NULL); return TCL_ERROR; } if (argv[2][0] != 0) { @@ -2108,6 +2142,15 @@ TestlinkCmd(dummy, interp, argc, argv) } Tcl_UpdateLinkedVar(interp, "string"); } + if (argv[6][0] != 0) { + tmp = Tcl_NewStringObj(argv[6], -1); + if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) { + Tcl_DecrRefCount(tmp); + return TCL_ERROR; + } + Tcl_DecrRefCount(tmp); + Tcl_UpdateLinkedVar(interp, "wide"); + } } else { Tcl_AppendResult(interp, "bad option \"", argv[1], "\": should be create, delete, get, set, or update", diff --git a/tests/link.test b/tests/link.test index f64711a..6ecb59f 100644 --- a/tests/link.test +++ b/tests/link.test @@ -11,246 +11,252 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: link.test,v 1.5 2000/04/10 17:19:01 ericm Exp $ +# RCS: @(#) $Id: link.test,v 1.5.16.1 2001/11/07 13:35:21 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } -if {[info commands testlink] == {}} { - puts "This application hasn't been compiled with the \"testlink\"" - puts "command, so I can't test Tcl_LinkVar et al." - ::tcltest::cleanupTests - return -} +set ::tcltest::testConstraints(testlink) \ + [expr {[info commands testlink] != {}}] foreach i {int real bool string} { catch {unset $i} } -test link-1.1 {reading C variables from Tcl} { +test link-1.1 {reading C variables from Tcl} {testlink} { testlink delete - testlink set 43 1.23 4 - - testlink create 1 1 1 1 - list $int $real $bool $string -} {43 1.23 1 NULL} -test link-1.2 {reading C variables from Tcl} { + testlink set 43 1.23 4 - 12341234 + testlink create 1 1 1 1 1 + list $int $real $bool $string $wide +} {43 1.23 1 NULL 12341234} +test link-1.2 {reading C variables from Tcl} {testlink} { testlink delete - testlink create 1 1 1 1 - testlink set -3 2 0 "A long string with spaces" - list $int $real $bool $string $int $real $bool $string -} {-3 2.0 0 {A long string with spaces} -3 2.0 0 {A long string with spaces}} + testlink create 1 1 1 1 1 + testlink set -3 2 0 "A long string with spaces" 43214321 + list $int $real $bool $string $wide $int $real $bool $string $wide +} {-3 2.0 0 {A long string with spaces} 43214321 -3 2.0 0 {A long string with spaces} 43214321} -test link-2.1 {writing C variables from Tcl} { +test link-2.1 {writing C variables from Tcl} {testlink} { testlink delete - testlink set 43 1.21 4 - - testlink create 1 1 1 1 + testlink set 43 1.21 4 - 56785678 + testlink create 1 1 1 1 1 set int "00721" set real -10.5 set bool true set string abcdef - concat [testlink get] $int $real $bool $string -} {465 -10.5 1 abcdef 00721 -10.5 true abcdef} -test link-2.2 {writing bad values into variables} { + set wide 135135 + concat [testlink get] $int $real $bool $string $wide +} {465 -10.5 1 abcdef 135135 00721 -10.5 true abcdef 135135} +test link-2.2 {writing bad values into variables} {testlink} { testlink delete - testlink set 43 1.23 4 - - testlink create 1 1 1 1 + testlink set 43 1.23 4 - 56785678 + testlink create 1 1 1 1 1 list [catch {set int 09a} msg] $msg $int } {1 {can't set "int": variable must have integer value} 43} -test link-2.3 {writing bad values into variables} { +test link-2.3 {writing bad values into variables} {testlink} { testlink delete - testlink set 43 1.23 4 - - testlink create 1 1 1 1 + testlink set 43 1.23 4 - 56785678 + testlink create 1 1 1 1 1 list [catch {set real 1.x3} msg] $msg $real } {1 {can't set "real": variable must have real value} 1.23} -test link-2.4 {writing bad values into variables} { +test link-2.4 {writing bad values into variables} {testlink} { testlink delete - testlink set 43 1.23 4 - - testlink create 1 1 1 1 + testlink set 43 1.23 4 - 56785678 + testlink create 1 1 1 1 1 list [catch {set bool gorp} msg] $msg $bool } {1 {can't set "bool": variable must have boolean value} 1} +test link-2.5 {writing bad values into variables} {testlink} { + testlink delete + testlink set 43 1.23 4 - 56785678 + testlink create 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-3.1 {read-only variables} { +test link-3.1 {read-only variables} {testlink} { testlink delete - testlink set 43 1.23 4 - - testlink create 0 1 1 0 + testlink set 43 1.23 4 - 56785678 + testlink create 0 1 1 0 0 list [catch {set int 4} msg] $msg $int \ [catch {set real 10.6} msg] $msg $real \ [catch {set bool no} msg] $msg $bool \ - [catch {set string "new value"} msg] $msg $string -} {1 {can't set "int": linked variable is read-only} 43 0 10.6 10.6 0 no no 1 {can't set "string": linked variable is read-only} NULL} -test link-3.2 {read-only variables} { + [catch {set string "new value"} msg] $msg $string \ + [catch {set wide 12341234} msg] $msg $wide +} {1 {can't set "int": linked variable is read-only} 43 0 10.6 10.6 0 no no 1 {can't set "string": linked variable is read-only} NULL 1 {can't set "wide": linked variable is read-only} 56785678} +test link-3.2 {read-only variables} {testlink} { testlink delete - testlink set 43 1.23 4 - - testlink create 1 0 0 1 + testlink set 43 1.23 4 - 56785678 + testlink create 1 0 0 1 1 list [catch {set int 4} msg] $msg $int \ [catch {set real 10.6} msg] $msg $real \ [catch {set bool no} msg] $msg $bool \ - [catch {set string "new value"} msg] $msg $string -} {0 4 4 1 {can't set "real": linked variable is read-only} 1.23 1 {can't set "bool": linked variable is read-only} 1 0 {new value} {new value}} + [catch {set string "new value"} msg] $msg $string\ + [catch {set wide 12341234} msg] $msg $wide +} {0 4 4 1 {can't set "real": linked variable is read-only} 1.23 1 {can't set "bool": linked variable is read-only} 1 0 {new value} {new value} 0 12341234 12341234} -test link-4.1 {unsetting linked variables} { +test link-4.1 {unsetting linked variables} {testlink} { testlink delete - testlink set -6 -2.5 0 stringValue - testlink create 1 1 1 1 - unset int real bool string + testlink set -6 -2.5 0 stringValue 13579 + testlink create 1 1 1 1 1 + unset int real bool string wide list [catch {set int} msg] $msg [catch {set real} msg] $msg \ - [catch {set bool} msg] $msg [catch {set string} msg] $msg -} {0 -6 0 -2.5 0 0 0 stringValue} -test link-4.2 {unsetting linked variables} { + [catch {set bool} msg] $msg [catch {set string} msg] $msg \ + [catch {set wide} msg] $msg +} {0 -6 0 -2.5 0 0 0 stringValue 0 13579} +test link-4.2 {unsetting linked variables} {testlink} { testlink delete - testlink set -6 -2.1 0 stringValue - testlink create 1 1 1 1 - unset int real bool string + testlink set -6 -2.1 0 stringValue 97531 + testlink create 1 1 1 1 1 + unset int real bool string wide set int 102 set real 16 set bool true set string newValue + set wide 333555 testlink get -} {102 16.0 1 newValue} +} {102 16.0 1 newValue 333555} -test link-5.1 {unlinking variables} { +test link-5.1 {unlinking variables} {testlink} { testlink delete - testlink set -6 -2.25 0 stringValue + testlink set -6 -2.25 0 stringValue 13579 testlink delete set int xx1 set real qrst set bool bogus set string 12345 + set wide 875421 testlink get -} {-6 -2.25 0 stringValue} -test link-5.2 {unlinking variables} { +} {-6 -2.25 0 stringValue 13579} +test link-5.2 {unlinking variables} {testlink} { testlink delete - testlink set -6 -2.25 0 stringValue - testlink create 1 1 1 1 + testlink set -6 -2.25 0 stringValue 97531 + testlink create 1 1 1 1 1 testlink delete - testlink set 25 14.7 7 - - list $int $real $bool $string -} {-6 -2.25 0 stringValue} + testlink set 25 14.7 7 - 999999 + list $int $real $bool $string $wide +} {-6 -2.25 0 stringValue 97531} -test link-6.1 {errors in setting up link} { +test link-6.1 {errors in setting up link} {testlink} { testlink delete catch {unset int} set int(44) 1 - list [catch {testlink create 1 1 1 1} msg] $msg + list [catch {testlink create 1 1 1 1 1} msg] $msg } {1 {can't set "int": variable is array}} catch {unset int} -test link-7.1 {access to linked variables via upvar} { +test link-7.1 {access to linked variables via upvar} {testlink} { proc x {} { upvar int y unset y } testlink delete - testlink create 1 0 0 0 - testlink set 14 {} {} {} + testlink create 1 0 0 0 0 + testlink set 14 {} {} {} {} x list [catch {set int} msg] $msg } {0 14} -test link-7.2 {access to linked variables via upvar} { +test link-7.2 {access to linked variables via upvar} {testlink} { proc x {} { upvar int y return [set y] } testlink delete - testlink create 1 0 0 0 - testlink set 0 {} {} {} + testlink create 1 0 0 0 0 + testlink set 0 {} {} {} {} set int - testlink set 23 {} {} {} + testlink set 23 {} {} {} {} x list [x] $int } {23 23} -test link-7.3 {access to linked variables via upvar} { +test link-7.3 {access to linked variables via upvar} {testlink} { proc x {} { upvar int y set y 44 } testlink delete - testlink create 0 0 0 0 - testlink set 11 {} {} {} + testlink create 0 0 0 0 0 + testlink set 11 {} {} {} {} list [catch x msg] $msg $int } {1 {can't set "y": linked variable is read-only} 11} -test link-7.4 {access to linked variables via upvar} { +test link-7.4 {access to linked variables via upvar} {testlink} { proc x {} { upvar int y set y abc } testlink delete - testlink create 1 1 1 1 - testlink set -4 {} {} {} + testlink create 1 1 1 1 1 + testlink set -4 {} {} {} {} list [catch x msg] $msg $int } {1 {can't set "y": variable must have integer value} -4} -test link-7.5 {access to linked variables via upvar} { +test link-7.5 {access to linked variables via upvar} {testlink} { proc x {} { upvar real y set y abc } testlink delete - testlink create 1 1 1 1 - testlink set -4 16.75 {} {} + testlink create 1 1 1 1 1 + testlink set -4 16.75 {} {} {} list [catch x msg] $msg $real } {1 {can't set "y": variable must have real value} 16.75} -test link-7.6 {access to linked variables via upvar} { +test link-7.6 {access to linked variables via upvar} {testlink} { proc x {} { upvar bool y set y abc } testlink delete - testlink create 1 1 1 1 - testlink set -4 16.3 1 {} + testlink create 1 1 1 1 1 + testlink set -4 16.3 1 {} {} list [catch x msg] $msg $bool } {1 {can't set "y": variable must have boolean value} 1} +test link-7.7 {access to linked variables via upvar} {testlink} { + proc x {} { + upvar wide y + set y abc + } + testlink delete + testlink create 1 1 1 1 1 + testlink set -4 16.3 1 {} 778899 + list [catch x msg] $msg $wide +} {1 {can't set "y": variable must have integer value} 778899} -test link-8.1 {Tcl_UpdateLinkedVar procedure} { +test link-8.1 {Tcl_UpdateLinkedVar procedure} {testlink} { proc x args { - global x int real bool string - lappend x $args $int $real $bool $string + global x int real bool string wide + lappend x $args $int $real $bool $string $wide } set x {} - testlink create 1 1 1 1 - testlink set 14 -2.0 0 xyzzy + testlink create 1 1 1 1 1 + testlink set 14 -2.0 0 xyzzy 995511 trace var int w x - testlink update 32 4.0 3 abcd + testlink update 32 4.0 3 abcd 113355 trace vdelete int w x set x -} {{int {} w} 32 -2.0 0 xyzzy} -test link-8.2 {Tcl_UpdateLinkedVar procedure} { +} {{int {} w} 32 -2.0 0 xyzzy 995511} +test link-8.2 {Tcl_UpdateLinkedVar procedure} {testlink} { proc x args { - global x int real bool string - lappend x $args $int $real $bool $string + global x int real bool string wide + lappend x $args $int $real $bool $string $wide } set x {} - testlink create 1 1 1 1 - testlink set 14 -2.0 0 xyzzy + testlink create 1 1 1 1 1 + testlink set 14 -2.0 0 xyzzy 995511 testlink delete trace var int w x - testlink update 32 4.0 6 abcd + testlink update 32 4.0 6 abcd 113355 trace vdelete int w x set x } {} -test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} { - testlink create 0 0 0 0 - list [catch {testlink update 47 {} {} {}} msg] $msg $int +test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} {testlink} { + testlink create 0 0 0 0 0 + list [catch {testlink update 47 {} {} {} {}} msg] $msg $int } {0 {} 47} -testlink set 0 0 0 - -testlink delete -foreach i {int real bool string} { +catch {testlink set 0 0 0 - 0} +catch {testlink delete} +foreach i {int real bool string wide} { catch {unset $i} } # cleanup ::tcltest::cleanupTests return - - - - - - - - - - - - |