summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authorjan.nijtmans <nijtmans@users.sourceforge.net>2017-04-10 12:39:54 (GMT)
committerjan.nijtmans <nijtmans@users.sourceforge.net>2017-04-10 12:39:54 (GMT)
commitf15e17cb4325805681b5479390866fae1621a4d9 (patch)
treedb47406be713ada278bfad3b9fd62c29c2c30b39 /generic
parent22946a554a465a115602ba3324fb7fd8ea5590b4 (diff)
parent27be6e4e9ada6489a2bb9de775cab72378825b2b (diff)
downloadtcl-f15e17cb4325805681b5479390866fae1621a4d9.zip
tcl-f15e17cb4325805681b5479390866fae1621a4d9.tar.gz
tcl-f15e17cb4325805681b5479390866fae1621a4d9.tar.bz2
Merge Harald's "robust-async-connect-tests" branch. Thanks!
Diffstat (limited to 'generic')
-rw-r--r--generic/tclTest.c85
1 files changed, 85 insertions, 0 deletions
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 0f019bb..547dc9a 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -67,6 +67,18 @@ typedef struct TestAsyncHandler {
/* Next is list of handlers. */
} TestAsyncHandler;
+/*
+ * Start of the socket driver state structure to acces field testFlags
+ */
+
+typedef struct TcpState TcpState;
+
+struct TcpState {
+ Tcl_Channel channel; /* Channel associated with this socket. */
+ int testFlags; /* bit field for tests. Is set by testsocket
+ * test procedure */
+};
+
TCL_DECLARE_MUTEX(asyncTestMutex)
static TestAsyncHandler *firstHandler = NULL;
@@ -364,6 +376,8 @@ static int TestChannelCmd(ClientData clientData,
Tcl_Interp *interp, int argc, const char **argv);
static int TestChannelEventCmd(ClientData clientData,
Tcl_Interp *interp, int argc, const char **argv);
+static int TestSocketCmd(ClientData clientData,
+ Tcl_Interp *interp, int argc, const char **argv);
static int TestFilesystemObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -676,6 +690,8 @@ Tcltest_Init(
TestNumUtfCharsCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd,
NULL, NULL);
+ Tcl_CreateCommand(interp, "testsocket", TestSocketCmd,
+ NULL, NULL);
Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testtranslatefilename",
@@ -6081,6 +6097,75 @@ TestChannelEventCmd(
/*
*----------------------------------------------------------------------
*
+ * TestSocketCmd --
+ *
+ * Implements the Tcl "testsocket" debugging command and its
+ * subcommands. This is part of the testing environment.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+static int
+TestSocketCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Interpreter for result. */
+ int argc, /* Count of additional args. */
+ const char **argv) /* Additional arg strings. */
+{
+ const char *cmdName; /* Sub command. */
+ size_t len; /* Length of subcommand string. */
+
+ if (argc < 2) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " subcommand ?additional args..?\"", NULL);
+ return TCL_ERROR;
+ }
+ cmdName = argv[1];
+ len = strlen(cmdName);
+
+ if ((cmdName[0] == 't') && (strncmp(cmdName, "testflags", len) == 0)) {
+ Tcl_Channel hChannel;
+ int modePtr;
+ TcpState *statePtr;
+ /* Set test value in the socket driver
+ */
+ /* Check for argument "channel name"
+ */
+ if (argc < 4) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " testflags channel flags\"", NULL);
+ return TCL_ERROR;
+ }
+ hChannel = Tcl_GetChannel(interp, argv[2], &modePtr);
+ if ( NULL == hChannel ) {
+ Tcl_AppendResult(interp, "unknown channel:", argv[2], NULL);
+ return TCL_ERROR;
+ }
+ statePtr = (TcpState *)Tcl_GetChannelInstanceData(hChannel);
+ if ( NULL == statePtr) {
+ Tcl_AppendResult(interp, "No channel instance data:", argv[2],
+ NULL);
+ return TCL_ERROR;
+ }
+ statePtr->testFlags = atoi(argv[3]);
+ return TCL_OK;
+ }
+
+ Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be "
+ "testflags", NULL);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestWrongNumArgsObjCmd --
*
* Test the Tcl_WrongNumArgs function.