Merge Harald's "robust-async-connect-tests" branch. Thanks!

4 files changed, 158 insertions, 4 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.
diff --git a/tests/socket.test b/tests/socket.test
index 80b0251..9a09c0f 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -60,8 +60,13 @@
 # listening at port 2048. If all fails, a message is printed and the tests
 # using the remote server are not performed.
 
-package require tcltest 2
-namespace import -force ::tcltest::*
+if {[lsearch [namespace children] ::tcltest] == -1} {
+    package require tcltest
+    namespace import -force ::tcltest::*
+}
+
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
 
 # Some tests require the Thread package or exec command
 testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
@@ -71,6 +76,14 @@ testConstraint exec [llength [info commands exec]]
 # from 49152 through 65535.
 proc randport {} { expr {int(rand()*16383+49152)} }
 
+# Check if testsocket testflags is available
+testConstraint testsocket_testflags [expr {![catch {
+        set h [socket -async localhost [randport]]
+        testsocket testflags $h 0
+        close $h
+    }]}]
+
+
 # Test the latency of tcp connections over the loopback interface. Some OSes
 # (e.g. NetBSD) seem to use the Nagle algorithm and delayed ACKs, so it takes
 # up to 200ms for a packet sent to localhost to arrive. We're measuring this
@@ -2266,12 +2279,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 nonPortable} \
+    -constraints {socket testsocket_testflags} \
     -body {
         set sock [socket -async localhost [randport]]
+        # 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
+        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 a64157e..0ae500b 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. */
@@ -93,6 +95,15 @@ struct TcpState {
 #define TCP_ASYNC_FAILED	(1<<5)	/* An async connect finally failed */
 
 /*
+ * 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 */
+
+/*
  * The following defines the maximum length of the listen queue. This is the
  * number of outstanding yet-to-be-serviced requests for a connection on a
  * server socket, more than this number of outstanding requests and the
@@ -444,6 +455,19 @@ WaitForConnect(
 	return 0;
     }
 
+    /*
+     * In socket test mode do not continue with the connect
+     * Exceptions are:
+     * - Call by recv/send and blocking socket
+     *   (errorCodePtr != NULL && ! flags & TCP_NONBLOCKING)
+     */
+
+    if ( (statePtr->testFlags & TCP_ASYNC_TEST_MODE)
+	    && ! (errorCodePtr != NULL && ! (statePtr->flags & TCP_NONBLOCKING))) {
+	*errorCodePtr = EWOULDBLOCK;
+	return -1;
+    }
+
     if (errorCodePtr == NULL || (statePtr->flags & TCP_NONBLOCKING)) {
         timeout = 0;
     } else {
diff --git a/win/tclWinSock.c b/win/tclWinSock.c
index d6aca1b..a5d98ae 100644
--- a/win/tclWinSock.c
+++ b/win/tclWinSock.c
@@ -124,6 +124,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. */
@@ -184,6 +186,15 @@ struct TcpState {
 #define TCP_ASYNC_FAILED	(1<<5)	/* An async connect finally failed */
 
 /*
+ * 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 */
+
+/*
  * The following structure is what is added to the Tcl event queue when a
  * socket event occurs.
  */
@@ -599,6 +610,20 @@ WaitForConnect(
     }
 
     /*
+     * In socket test mode do not continue with the connect
+     * Exceptions are:
+     * - Call by recv/send and blocking socket
+     *   (errorCodePtr != NULL && ! flags & TCP_NONBLOCKING)
+     * - Call by the event queue (errorCodePtr == NULL)
+     */
+
+    if ( (statePtr->testFlags & TCP_ASYNC_TEST_MODE)
+	    && errorCodePtr != NULL && (statePtr->flags & TCP_NONBLOCKING)) {
+	*errorCodePtr = EWOULDBLOCK;
+	return -1;
+    }
+
+    /*
      * Be sure to disable event servicing so we are truly modal.
      */
 
@@ -1292,7 +1317,9 @@ TcpGetOptionProc(
      * below.
      */
 
-    WaitForConnect(statePtr, NULL);
+    if (! (statePtr->testFlags & TCP_ASYNC_TEST_MODE) ) {
+	WaitForConnect(statePtr, NULL);
+    }
 
     sock = statePtr->sockets->fd;
     if (optionName != NULL) {