summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2005-09-08 13:38:08 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2005-09-08 13:38:08 (GMT)
commit408838f622f7e0872c7547f38512364490472a41 (patch)
tree393a4b16a1f30211a43214ab16344f7efccba378
parent33749182b894f13cecd1163b82537b5cad1a5f27 (diff)
downloadtcl-408838f622f7e0872c7547f38512364490472a41.zip
tcl-408838f622f7e0872c7547f38512364490472a41.tar.gz
tcl-408838f622f7e0872c7547f38512364490472a41.tar.bz2
Added support machinery for TIP#254 tests
-rw-r--r--ChangeLog3
-rw-r--r--generic/tclTest.c277
2 files changed, 271 insertions, 9 deletions
diff --git a/ChangeLog b/ChangeLog
index b27fdb8..bbd8429 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -5,7 +5,8 @@
* generic/tclLink.c (LinkTraceProc,ObjValue): Added many new of C var
* generic/tcl.h: to link to, making it
* doc/LinkVar.3: easier to seamlessly
- couple C code and Tcl scripts in an application. [Patch 1242844]
+ * generic/tclTest.c (TestlinkCmd): couple C code and Tcl
+ scripts in an application. [Patch 1242844]
2005-09-07 Don Porter <dgp@users.sourceforge.net>
diff --git a/generic/tclTest.c b/generic/tclTest.c
index d0f6406..e966e4c 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -14,7 +14,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.92 2005/08/24 17:56:23 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclTest.c,v 1.93 2005/09/08 13:38:09 dkf Exp $
*/
#define TCL_TEST
@@ -2560,6 +2560,17 @@ TestlinkCmd(dummy, interp, argc, argv)
static double realVar = 1.23;
static Tcl_WideInt wideVar = Tcl_LongAsWide(79);
static char *stringVar = NULL;
+
+ static char charVar = '@';
+ static unsigned char ucharVar = 130;
+ static short shortVar = 3000;
+ static unsigned short ushortVar = 60000;
+ static unsigned int uintVar = 0xbeeffeed;
+ static long longVar = 123456789L;
+ static unsigned long ulongVar = 3456789012;
+ static float floatVar = 4.5;
+ static Tcl_WideUInt uwideVar = (Tcl_WideUInt) Tcl_LongAsWide(123);
+
static int created = 0;
char buffer[2*TCL_DOUBLE_SPACE];
int writable, flag;
@@ -2567,14 +2578,17 @@ TestlinkCmd(dummy, interp, argc, argv)
if (argc < 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " option ?arg arg arg arg arg?\"", (char *) NULL);
+ " option ?arg arg arg arg arg arg arg arg arg arg arg arg",
+ " arg arg?\"", (char *) NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "create") == 0) {
- if (argc != 7) {
+ if (argc != 16) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " ", argv[1],
- " intRO realRO boolRO stringRO wideRO\"", (char *) NULL);
+ " intRO realRO boolRO stringRO wideRO charRO ucharRO shortRO",
+ " ushortRO uintRO longRO ulongRO floatRO uwideRO\"",
+ (char *) NULL);
return TCL_ERROR;
}
if (created) {
@@ -2583,6 +2597,15 @@ TestlinkCmd(dummy, interp, argc, argv)
Tcl_UnlinkVar(interp, "bool");
Tcl_UnlinkVar(interp, "string");
Tcl_UnlinkVar(interp, "wide");
+ Tcl_UnlinkVar(interp, "char");
+ Tcl_UnlinkVar(interp, "uchar");
+ Tcl_UnlinkVar(interp, "short");
+ Tcl_UnlinkVar(interp, "ushort");
+ Tcl_UnlinkVar(interp, "uint");
+ Tcl_UnlinkVar(interp, "long");
+ Tcl_UnlinkVar(interp, "ulong");
+ Tcl_UnlinkVar(interp, "float");
+ Tcl_UnlinkVar(interp, "uwide");
}
created = 1;
if (Tcl_GetBoolean(interp, argv[2], &writable) != TCL_OK) {
@@ -2625,12 +2648,94 @@ TestlinkCmd(dummy, interp, argc, argv)
TCL_LINK_WIDE_INT | flag) != TCL_OK) {
return TCL_ERROR;
}
+ if (Tcl_GetBoolean(interp, argv[7], &writable) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
+ if (Tcl_LinkVar(interp, "char", (char *) &charVar,
+ TCL_LINK_CHAR | flag) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (Tcl_GetBoolean(interp, argv[8], &writable) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
+ if (Tcl_LinkVar(interp, "uchar", (char *) &ucharVar,
+ TCL_LINK_UCHAR | flag) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (Tcl_GetBoolean(interp, argv[9], &writable) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
+ if (Tcl_LinkVar(interp, "short", (char *) &shortVar,
+ TCL_LINK_SHORT | flag) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (Tcl_GetBoolean(interp, argv[10], &writable) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
+ if (Tcl_LinkVar(interp, "ushort", (char *) &ushortVar,
+ TCL_LINK_USHORT | flag) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (Tcl_GetBoolean(interp, argv[11], &writable) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
+ if (Tcl_LinkVar(interp, "uint", (char *) &uintVar,
+ TCL_LINK_UINT | flag) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (Tcl_GetBoolean(interp, argv[12], &writable) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
+ if (Tcl_LinkVar(interp, "long", (char *) &longVar,
+ TCL_LINK_LONG | flag) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (Tcl_GetBoolean(interp, argv[13], &writable) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
+ if (Tcl_LinkVar(interp, "ulong", (char *) &ulongVar,
+ TCL_LINK_ULONG | flag) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (Tcl_GetBoolean(interp, argv[14], &writable) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
+ if (Tcl_LinkVar(interp, "float", (char *) &floatVar,
+ TCL_LINK_FLOAT | flag) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (Tcl_GetBoolean(interp, argv[15], &writable) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
+ if (Tcl_LinkVar(interp, "uwide", (char *) &uwideVar,
+ TCL_LINK_WIDE_UINT | 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");
+ Tcl_UnlinkVar(interp, "char");
+ Tcl_UnlinkVar(interp, "uchar");
+ Tcl_UnlinkVar(interp, "short");
+ Tcl_UnlinkVar(interp, "ushort");
+ Tcl_UnlinkVar(interp, "uint");
+ Tcl_UnlinkVar(interp, "long");
+ Tcl_UnlinkVar(interp, "ulong");
+ Tcl_UnlinkVar(interp, "float");
+ Tcl_UnlinkVar(interp, "uwide");
created = 0;
} else if (strcmp(argv[1], "get") == 0) {
TclFormatInt(buffer, intVar);
@@ -2646,11 +2751,36 @@ TestlinkCmd(dummy, interp, argc, argv)
tmp = Tcl_NewWideIntObj(wideVar);
Tcl_AppendElement(interp, Tcl_GetString(tmp));
Tcl_DecrRefCount(tmp);
+ TclFormatInt(buffer, (int) charVar);
+ Tcl_AppendElement(interp, buffer);
+ TclFormatInt(buffer, (int) ucharVar);
+ Tcl_AppendElement(interp, buffer);
+ TclFormatInt(buffer, (int) shortVar);
+ Tcl_AppendElement(interp, buffer);
+ TclFormatInt(buffer, (int) ushortVar);
+ Tcl_AppendElement(interp, buffer);
+ TclFormatInt(buffer, (int) uintVar);
+ Tcl_AppendElement(interp, buffer);
+ tmp = Tcl_NewLongObj(longVar);
+ Tcl_AppendElement(interp, Tcl_GetString(tmp));
+ Tcl_DecrRefCount(tmp);
+ tmp = Tcl_NewLongObj((long)ulongVar);
+ Tcl_AppendElement(interp, Tcl_GetString(tmp));
+ Tcl_DecrRefCount(tmp);
+ Tcl_PrintDouble((Tcl_Interp *) NULL, (double)floatVar, buffer);
+ Tcl_AppendElement(interp, buffer);
+ tmp = Tcl_NewWideIntObj((Tcl_WideInt)uwideVar);
+ Tcl_AppendElement(interp, Tcl_GetString(tmp));
+ Tcl_DecrRefCount(tmp);
} else if (strcmp(argv[1], "set") == 0) {
- if (argc != 7) {
+ int v;
+
+ if (argc != 16) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " ", argv[1],
- " intValue realValue boolValue stringValue wideValue\"",
+ " intValue realValue boolValue stringValue wideValue",
+ " charValue ucharValue shortValue ushortValue uintValue",
+ " longValue ulongValue floatValue uwideValue\"",
(char *) NULL);
return TCL_ERROR;
}
@@ -2688,11 +2818,74 @@ TestlinkCmd(dummy, interp, argc, argv)
}
Tcl_DecrRefCount(tmp);
}
+ if (argv[7][0]) {
+ if (Tcl_GetInt(interp, argv[7], &v) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ charValue = (char) v;
+ }
+ if (argv[8][0]) {
+ if (Tcl_GetInt(interp, argv[8], &v) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ ucharValue = (unsigned char) v;
+ }
+ if (argv[9][0]) {
+ if (Tcl_GetInt(interp, argv[9], &v) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ shortValue = (short) v;
+ }
+ if (argv[10][0]) {
+ if (Tcl_GetInt(interp, argv[10], &v) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ ushortValue = (unsigned short) v;
+ }
+ if (argv[11][0]) {
+ if (Tcl_GetInt(interp, argv[11], &v) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ uintValue = (unsigned int) v;
+ }
+ if (argv[12][0]) {
+ if (Tcl_GetInt(interp, argv[12], &v) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ longValue = (long) v;
+ }
+ if (argv[13][0]) {
+ if (Tcl_GetInt(interp, argv[13], &v) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ ulongValue = (unsigned long) v;
+ }
+ if (argv[14][0]) {
+ double d;
+ if (Tcl_GetDouble(interp, argv[14], &d) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ floatValue = (float) d;
+ }
+ if (argv[15][0]) {
+ Tcl_WideInt w;
+ tmp = Tcl_NewStringObj(argv[15], -1);
+ if (Tcl_GetWideIntFromObj(interp, tmp, &w) != TCL_OK) {
+ Tcl_DecrRefCount(tmp);
+ return TCL_ERROR;
+ }
+ Tcl_DecrRefCount(tmp);
+ uwideValue = (Tcl_WideUInt) w;
+ }
} else if (strcmp(argv[1], "update") == 0) {
- if (argc != 7) {
+ int v;
+
+ if (argc != 16) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " ", argv[1],
- "intValue realValue boolValue stringValue wideValue\"",
+ " intValue realValue boolValue stringValue wideValue",
+ " charValue ucharValue shortValue ushortValue uintValue",
+ " longValue ulongValue floatValue uwideValue\"",
(char *) NULL);
return TCL_ERROR;
}
@@ -2735,6 +2928,74 @@ TestlinkCmd(dummy, interp, argc, argv)
Tcl_DecrRefCount(tmp);
Tcl_UpdateLinkedVar(interp, "wide");
}
+ if (argv[7][0]) {
+ if (Tcl_GetInt(interp, argv[7], &v) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ charValue = (char) v;
+ Tcl_UpdateLinkedVar(interp, "char");
+ }
+ if (argv[8][0]) {
+ if (Tcl_GetInt(interp, argv[8], &v) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ ucharValue = (unsigned char) v;
+ Tcl_UpdateLinkedVar(interp, "uchar");
+ }
+ if (argv[9][0]) {
+ if (Tcl_GetInt(interp, argv[9], &v) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ shortValue = (short) v;
+ Tcl_UpdateLinkedVar(interp, "short");
+ }
+ if (argv[10][0]) {
+ if (Tcl_GetInt(interp, argv[10], &v) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ ushortValue = (unsigned short) v;
+ Tcl_UpdateLinkedVar(interp, "ushort");
+ }
+ if (argv[11][0]) {
+ if (Tcl_GetInt(interp, argv[11], &v) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ uintValue = (unsigned int) v;
+ Tcl_UpdateLinkedVar(interp, "uint");
+ }
+ if (argv[12][0]) {
+ if (Tcl_GetInt(interp, argv[12], &v) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ longValue = (long) v;
+ Tcl_UpdateLinkedVar(interp, "long");
+ }
+ if (argv[13][0]) {
+ if (Tcl_GetInt(interp, argv[13], &v) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ ulongValue = (unsigned long) v;
+ Tcl_UpdateLinkedVar(interp, "ulong");
+ }
+ if (argv[14][0]) {
+ double d;
+ if (Tcl_GetDouble(interp, argv[14], &d) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ floatValue = (float) d;
+ Tcl_UpdateLinkedVar(interp, "float");
+ }
+ if (argv[15][0]) {
+ Tcl_WideInt w;
+ tmp = Tcl_NewStringObj(argv[15], -1);
+ if (Tcl_GetWideIntFromObj(interp, tmp, &w) != TCL_OK) {
+ Tcl_DecrRefCount(tmp);
+ return TCL_ERROR;
+ }
+ Tcl_DecrRefCount(tmp);
+ uwideValue = (Tcl_WideUInt) w;
+ Tcl_UpdateLinkedVar(interp, "uwide");
+ }
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": should be create, delete, get, set, or update",