Replaced option "-unsupported1" by test command "testsocket debugflags" (thanks Donal, Donald).

4 files changed, 118 insertions, 80 deletions

diff --git a/generic/tclTest.c b/generic/tclTest.c
index a27c95a..80a2a37 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -75,6 +75,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;
@@ -362,6 +374,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[]);
@@ -666,6 +680,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",
@@ -5970,6 +5986,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.
diff --git a/tests/socket.test b/tests/socket.test
index b006cb4..839e9d2 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -72,10 +72,10 @@ testConstraint exec [llength [info commands exec]]
 # from 49152 through 65535.
 proc randport {} { expr {int(rand()*16383+49152)} }
 
-# Check if socket_test option is available
-testConstraint sockettest [expr {![catch {
+# Check if testsocket testflags is available
+testConstraint testsocket_testflags [expr {![catch {
         set h [socket -async localhost [randport]]
-        fconfigure $h -unsupported1 1
+        testsocket testflags $h 0
         close $h
     }]}]
 
@@ -2170,14 +2170,17 @@ test socket-14.11.0 {pending [socket -async] and nonblocking [puts], no listener
         unset x
     } -result {socket is not connected} -returnCodes 1
 test socket-14.11.1 {pending [socket -async] and nonblocking [puts], no listener, flush} \
-    -constraints {socket sockettest} \
+    -constraints {socket testsocket_testflags} \
     -body {
         set sock [socket -async localhost [randport]]
-        fconfigure $sock -unsupported1 1
+        # Set the socket in async test mode.
+        # The async connect will not be continued on the following fconfigure
+        # and puts/flush. Thus, the connect will fail after them.
+        testsocket testflags $sock 1
         fconfigure $sock -blocking 0
         puts $sock ok
         flush $sock
-        fconfigure $sock -unsupported1 0
+        testsocket testflags $sock 0
         fileevent $sock writable {set x 1}
         vwait x
         close $sock
diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c
index cf5d7b9..fdd4287 100644
--- a/unix/tclUnixSock.c
+++ b/unix/tclUnixSock.c
@@ -52,6 +52,8 @@ typedef struct TcpFdList {
 
 struct TcpState {
     Tcl_Channel channel;	/* Channel associated with this file. */
+    int testFlags;              /* bit field for tests. Is set by testsocket
+                                 * test procedure */
     TcpFdList fds;		/* The file descriptors of the sockets. */
     int flags;			/* ORed combination of the bitfields defined
 				 * below. */
@@ -89,7 +91,13 @@ struct TcpState {
 					 * flag indicates that reentry is
 					 * still pending */
 #define TCP_ASYNC_FAILED	(1<<5)	/* An async connect finally failed */
-#define TCP_ASYNC_TEST_MODE	(1<<6)	/* Async testing activated
+
+/*
+ * These bits may be ORed together into the "testFlags" field of a TcpState
+ * structure.
+ */
+
+#define TCP_ASYNC_TEST_MODE	(1<<0)	/* Async testing activated
 					 * Do not automatically continue connection
 					 * process */
 
@@ -128,9 +136,6 @@ static int		TcpClose2Proc(ClientData instanceData,
 			    Tcl_Interp *interp, int flags);
 static int		TcpGetHandleProc(ClientData instanceData,
 			    int direction, ClientData *handlePtr);
-static int              TcpSetOptionProc(ClientData instanceData,
-                            Tcl_Interp *interp, const char *optionName,
-                            const char *value);
 static int		TcpGetOptionProc(ClientData instanceData,
 			    Tcl_Interp *interp, const char *optionName,
 			    Tcl_DString *dsPtr);
@@ -153,7 +158,7 @@ static const Tcl_ChannelType tcpChannelType = {
     TcpInputProc,		/* Input proc. */
     TcpOutputProc,		/* Output proc. */
     NULL,			/* Seek proc. */
-    TcpSetOptionProc,		/* Set option proc. */
+    NULL,			/* Set option proc. */
     TcpGetOptionProc,		/* Get option proc. */
     TcpWatchProc,		/* Initialize notifier. */
     TcpGetHandleProc,		/* Get OS handles out of channel. */
@@ -453,11 +458,9 @@ WaitForConnect(
      *   (errorCodePtr != NULL && ! flags & TCP_NONBLOCKING)
      */
 
-    if ( (statePtr->flags & TCP_ASYNC_TEST_MODE)
-	    && !(errorCodePtr != NULL && !(statePtr->flags & TCP_NONBLOCKING))) {
-        if (errorCodePtr != NULL) {
-            *errorCodePtr = EWOULDBLOCK;
-        }
+    if ( (statePtr->testFlags & TCP_ASYNC_TEST_MODE)
+	    && ! (errorCodePtr != NULL && ! (statePtr->flags & TCP_NONBLOCKING))) {
+	*errorCodePtr = EWOULDBLOCK;
 	return -1;
     }
     
@@ -769,50 +772,6 @@ TcpHostPortList(
 /*
  *----------------------------------------------------------------------
  *
- * TcpSetOptionProc --
- *
- *	Sets Tcp channel specific options.
- *
- * Results:
- *	None, unless an error happens.
- *
- * Side effects:
- *	Changes attributes of the socket at the system level.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-TcpSetOptionProc(
-    ClientData instanceData,	/* Socket state. */
-    Tcl_Interp *interp,		/* For error reporting - can be NULL. */
-    const char *optionName,	/* Name of the option to set. */
-    const char *value)		/* New value for option. */
-{
-    TcpState *statePtr = instanceData;
-
-    /*
-     * Set socket test int value
-     */
-    if (!strcmp(optionName, "-unsupported1")) {
-	int intValue;
-	if (Tcl_GetInt(interp, value, &intValue) != TCL_OK) {
-		return TCL_ERROR;
-	}
-	if (intValue & 1) {
-		SET_BITS(statePtr->flags,TCP_ASYNC_TEST_MODE);
-	} else {
-		CLEAR_BITS(statePtr->flags,TCP_ASYNC_TEST_MODE);
-	}
-	return TCL_OK;
-    }
-
-    return Tcl_BadChannelOption(interp, optionName, "");
-}
-
-/*
- *----------------------------------------------------------------------
- *
  * TcpGetOptionProc --
  *
  *	Computes an option value for a TCP socket based channel, or a list of
diff --git a/win/tclWinSock.c b/win/tclWinSock.c
index 2703309..d6c8e3a 100644
--- a/win/tclWinSock.c
+++ b/win/tclWinSock.c
@@ -133,6 +133,8 @@ typedef struct TcpFdList {
 
 struct TcpState {
     Tcl_Channel channel;	/* Channel associated with this socket. */
+    int testFlags;              /* bit field for tests. Is set by testsocket
+                                 * test procedure */
     struct TcpFdList *sockets;	/* Windows SOCKET handle. */
     int flags;			/* Bit field comprised of the flags described
 				 * below. */
@@ -191,7 +193,13 @@ struct TcpState {
 					 * flag indicates that reentry is
 					 * still pending */
 #define TCP_ASYNC_FAILED	(1<<5)	/* An async connect finally failed */
-#define TCP_ASYNC_TEST_MODE	(1<<6)	/* Async testing activated
+
+/*
+ * These bits may be ORed together into the "testFlags" field of a TcpState
+ * structure.
+ */
+
+#define TCP_ASYNC_TEST_MODE	(1<<0)	/* Async testing activated
 					 * Do not automatically continue connection
 					 * process */
 
@@ -612,7 +620,7 @@ WaitForConnect(
      * - Call by the event queue (errorCodePtr == NULL)
      */
 
-    if ( (statePtr->flags & TCP_ASYNC_TEST_MODE)
+    if ( (statePtr->testFlags & TCP_ASYNC_TEST_MODE)
 	    && errorCodePtr != NULL && (statePtr->flags & TCP_NONBLOCKING)) {
 	*errorCodePtr = EWOULDBLOCK;
 	return -1;
@@ -1140,7 +1148,6 @@ TcpSetOptionProc(
     const char *optionName,	/* Name of the option to set. */
     const char *value)		/* New value for option. */
 {
-    TcpState *statePtr = instanceData;
 #ifdef TCL_FEATURE_KEEPALIVE_NAGLE
     TcpState *statePtr = instanceData;
     SOCKET sock;
@@ -1160,22 +1167,6 @@ TcpSetOptionProc(
 	return TCL_ERROR;
     }
 
-    /*
-     * Set socket test int value
-     */
-    if (!strcmp(optionName, "-unsupported1")) {
-	int intValue;
-	if (Tcl_GetInt(interp, value, &intValue) != TCL_OK) {
-		return TCL_ERROR;
-	}
-	if (intValue & 1) {
-		SET_BITS(statePtr->flags,TCP_ASYNC_TEST_MODE);
-	} else {
-		CLEAR_BITS(statePtr->flags,TCP_ASYNC_TEST_MODE);
-	}
-	return TCL_OK;
-    }
-
 #ifdef TCL_FEATURE_KEEPALIVE_NAGLE
     #error "TCL_FEATURE_KEEPALIVE_NAGLE not reviewed for whether to treat statePtr->sockets as single fd or list"
     sock = statePtr->sockets->fd;
@@ -1288,7 +1279,7 @@ TcpGetOptionProc(
      * Go one step in async connect
      * If any error is thrown save it as backround error to report eventually below
      */
-    if (! (statePtr->flags & TCP_ASYNC_TEST_MODE) ) {
+    if (! (statePtr->testFlags & TCP_ASYNC_TEST_MODE) ) {
 	WaitForConnect(statePtr, NULL);
     }