Tcl Source Code

Check-in [9f162eb401]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Merge Harald's "robust-async-connect-tests" branch. Thanks!
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 9f162eb401c88fc4b0d809a8f76c46eb5ede9ecb
User & Date: jan.nijtmans 2017-04-10 12:39:54
References
2020-11-17
09:07 Closed ticket [42d50ebd0c]: Unix test results on socket -async depend on timing and network configuration plus 7 other changes artifact: 2b3923566e user: oehhar
Context
2017-04-10
16:21
More minor style fixes. check-in: 4809613b1b user: dkf tags: trunk
12:39
Merge Harald's "robust-async-connect-tests" branch. Thanks! check-in: 9f162eb401 user: jan.nijtmans tags: trunk
2017-04-09
16:51
Minor style issues through the socket implementation code. check-in: 11fdde797a user: dkf tags: trunk
2014-07-31
08:39
merge trunk Closed-Leaf check-in: 8faac4e42d user: jan.nijtmans tags: robust-async-connect-tests
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclTest.c.

62
63
64
65
66
67
68












69
70
71
72
73
74
75
    int id;			/* Identifier for this handler. */
    Tcl_AsyncHandler handler;	/* Tcl's token for the handler. */
    char *command;		/* Command to invoke when the handler is
				 * invoked. */
    struct TestAsyncHandler *nextPtr;
				/* Next is list of handlers. */
} TestAsyncHandler;













TCL_DECLARE_MUTEX(asyncTestMutex)

static TestAsyncHandler *firstHandler = NULL;

/*
 * The dynamic string below is used by the "testdstring" command to test the







>
>
>
>
>
>
>
>
>
>
>
>







62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
    int id;			/* Identifier for this handler. */
    Tcl_AsyncHandler handler;	/* Tcl's token for the handler. */
    char *command;		/* Command to invoke when the handler is
				 * invoked. */
    struct TestAsyncHandler *nextPtr;
				/* 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;

/*
 * The dynamic string below is used by the "testdstring" command to test the
359
360
361
362
363
364
365


366
367
368
369
370
371
372
			    int objc, Tcl_Obj *const objv[]);
static int		TestGetIndexFromObjStructObjCmd(
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
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		TestFilesystemObjCmd(ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
static int		TestSimpleFilesystemObjCmd(
			    ClientData dummy, Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);







>
>







371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
			    int objc, Tcl_Obj *const objv[]);
static int		TestGetIndexFromObjStructObjCmd(
			    ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
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[]);
static int		TestSimpleFilesystemObjCmd(
			    ClientData dummy, Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
671
672
673
674
675
676
677


678
679
680
681
682
683
684
    Tcl_CreateCommand(interp, "testseterrorcode", TestseterrorcodeCmd,
	    NULL, NULL);
    Tcl_CreateObjCommand(interp, "testsetobjerrorcode",
	    TestsetobjerrorcodeCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "testnumutfchars",
	    TestNumUtfCharsCmd, NULL, NULL);
    Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd,


	    NULL, NULL);
    Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd,
	    NULL, NULL);
    Tcl_CreateCommand(interp, "testtranslatefilename",
	    TesttranslatefilenameCmd, NULL, NULL);
    Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, NULL, NULL);
#ifndef TCL_NO_DEPRECATED







>
>







685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
    Tcl_CreateCommand(interp, "testseterrorcode", TestseterrorcodeCmd,
	    NULL, NULL);
    Tcl_CreateObjCommand(interp, "testsetobjerrorcode",
	    TestsetobjerrorcodeCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "testnumutfchars",
	    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",
	    TesttranslatefilenameCmd, NULL, NULL);
    Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, NULL, NULL);
#ifndef TCL_NO_DEPRECATED
6073
6074
6075
6076
6077
6078
6079





































































6080
6081
6082
6083
6084
6085
6086
		TclChannelEventScriptInvoker, (ClientData) esPtr);
	return TCL_OK;
    }
    Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of "
	    "add, delete, list, set, or removeall", NULL);
    return TCL_ERROR;
}






































































/*
 *----------------------------------------------------------------------
 *
 * TestWrongNumArgsObjCmd --
 *
 *	Test the Tcl_WrongNumArgs function.







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







6089
6090
6091
6092
6093
6094
6095
6096
6097
6098
6099
6100
6101
6102
6103
6104
6105
6106
6107
6108
6109
6110
6111
6112
6113
6114
6115
6116
6117
6118
6119
6120
6121
6122
6123
6124
6125
6126
6127
6128
6129
6130
6131
6132
6133
6134
6135
6136
6137
6138
6139
6140
6141
6142
6143
6144
6145
6146
6147
6148
6149
6150
6151
6152
6153
6154
6155
6156
6157
6158
6159
6160
6161
6162
6163
6164
6165
6166
6167
6168
6169
6170
6171
		TclChannelEventScriptInvoker, (ClientData) esPtr);
	return TCL_OK;
    }
    Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of "
	    "add, delete, list, set, or removeall", NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * 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.

Changes to tests/socket.test.

56
57
58
59
60
61
62

63
64




65
66
67
68
69
70
71
72








73
74
75
76
77
78
79
# either in Tcl or in the environment; if they are, it attempts to connect to
# the server. If the connection is successful, the tests using the remote
# server will be performed; otherwise, it will attempt to start the remote
# server (via exec) on platforms that support this, on the local host,
# 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::*





# Some tests require the Thread package or exec command
testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}]
testConstraint exec [llength [info commands exec]]

# Produce a random port number in the Dynamic/Private range
# from 49152 through 65535.
proc randport {} { expr {int(rand()*16383+49152)} }









# 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
# here, so that OSes that don't have this problem can run the tests at full
# speed.
set server [socket -server {apply {{s a p} {set ::s1 $s}}} 0]







>
|
|
>
>
>
>








>
>
>
>
>
>
>
>







56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
# either in Tcl or in the environment; if they are, it attempts to connect to
# the server. If the connection is successful, the tests using the remote
# server will be performed; otherwise, it will attempt to start the remote
# server (via exec) on platforms that support this, on the local host,
# listening at port 2048. If all fails, a message is printed and the tests
# using the remote server are not performed.

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-}]}]
testConstraint exec [llength [info commands exec]]

# Produce a random port number in the Dynamic/Private range
# 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
# here, so that OSes that don't have this problem can run the tests at full
# speed.
set server [socket -server {apply {{s a p} {set ::s1 $s}}} 0]
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271




2272
2273
2274

2275
2276
2277
2278
2279
2280
2281
        vwait x
        close $sock
    } -cleanup {
        catch {close $sock}
        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} \
    -body {
        set sock [socket -async localhost [randport]]




        fconfigure $sock -blocking 0
        puts $sock ok
        flush $sock

        fileevent $sock writable {set x 1}
        vwait x
        close $sock
    } -cleanup {
        catch {close $sock}
        catch {unset x}
    } -result {socket is not connected} -returnCodes 1







|


>
>
>
>



>







2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
        vwait x
        close $sock
    } -cleanup {
        catch {close $sock}
        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 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
    } -cleanup {
        catch {close $sock}
        catch {unset x}
    } -result {socket is not connected} -returnCodes 1

Changes to unix/tclUnixSock.c.

48
49
50
51
52
53
54


55
56
57
58
59
60
61
    TcpState *statePtr;
    int fd;
    struct TcpFdList *next;
} TcpFdList;

struct TcpState {
    Tcl_Channel channel;	/* Channel associated with this file. */


    TcpFdList fds;		/* The file descriptors of the sockets. */
    int flags;			/* ORed combination of the bitfields defined
				 * below. */
    int interest;		/* Event types of interest */

    /*
     * Only needed for server sockets







>
>







48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
    TcpState *statePtr;
    int fd;
    struct TcpFdList *next;
} 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. */
    int interest;		/* Event types of interest */

    /*
     * Only needed for server sockets
88
89
90
91
92
93
94









95
96
97
98
99
100
101
#define TCP_ASYNC_CONNECT	(1<<1)	/* Async connect in progress. */
#define TCP_ASYNC_PENDING	(1<<4)	/* TcpConnect was called to
					 * process an async connect. This
					 * flag indicates that reentry is
					 * still pending */
#define TCP_ASYNC_FAILED	(1<<5)	/* An async connect finally failed */










/*
 * 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
 * connection request will fail.
 */








>
>
>
>
>
>
>
>
>







90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
#define TCP_ASYNC_CONNECT	(1<<1)	/* Async connect in progress. */
#define TCP_ASYNC_PENDING	(1<<4)	/* TcpConnect was called to
					 * process an async connect. This
					 * flag indicates that reentry is
					 * still pending */
#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
 * connection request will fail.
 */

439
440
441
442
443
444
445













446
447
448
449
450
451
452
    /*
     * Check if an async connect is running. If not return ok
     */

    if (!(statePtr->flags & TCP_ASYNC_PENDING)) {
	return 0;
    }














    if (errorCodePtr == NULL || (statePtr->flags & TCP_NONBLOCKING)) {
        timeout = 0;
    } else {
        timeout = -1;
    }
    do {







>
>
>
>
>
>
>
>
>
>
>
>
>







450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
    /*
     * Check if an async connect is running. If not return ok
     */

    if (!(statePtr->flags & TCP_ASYNC_PENDING)) {
	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 {
        timeout = -1;
    }
    do {

Changes to win/tclWinSock.c.

120
121
122
123
124
125
126


127
128
129
130
131
132
133
    TcpState *statePtr;
    SOCKET fd;
    struct TcpFdList *next;
} TcpFdList;

struct TcpState {
    Tcl_Channel channel;	/* Channel associated with this socket. */


    struct TcpFdList *sockets;	/* Windows SOCKET handle. */
    int flags;			/* Bit field comprised of the flags described
				 * below. */
    int watchEvents;		/* OR'ed combination of FD_READ, FD_WRITE,
				 * FD_CLOSE, FD_ACCEPT and FD_CONNECT that
				 * indicate which events are interesting. */
    volatile int readyEvents;	/* OR'ed combination of FD_READ, FD_WRITE,







>
>







120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
    TcpState *statePtr;
    SOCKET fd;
    struct TcpFdList *next;
} 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. */
    int watchEvents;		/* OR'ed combination of FD_READ, FD_WRITE,
				 * FD_CLOSE, FD_ACCEPT and FD_CONNECT that
				 * indicate which events are interesting. */
    volatile int readyEvents;	/* OR'ed combination of FD_READ, FD_WRITE,
179
180
181
182
183
184
185









186
187
188
189
190
191
192
					 * socket */
#define TCP_ASYNC_PENDING	(1<<4)	/* TcpConnect was called to
					 * process an async connect. This
					 * flag indicates that reentry is
					 * still pending */
#define TCP_ASYNC_FAILED	(1<<5)	/* An async connect finally failed */










/*
 * The following structure is what is added to the Tcl event queue when a
 * socket event occurs.
 */

typedef struct {
    Tcl_Event header;		/* Information that is standard for all







>
>
>
>
>
>
>
>
>







181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
					 * socket */
#define TCP_ASYNC_PENDING	(1<<4)	/* TcpConnect was called to
					 * process an async connect. This
					 * flag indicates that reentry is
					 * still pending */
#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.
 */

typedef struct {
    Tcl_Event header;		/* Information that is standard for all
593
594
595
596
597
598
599














600
601
602
603
604
605
606
    /*
     * Check if an async connect is running. If not return ok
     */

    if (!(statePtr->flags & TCP_ASYNC_CONNECT)) {
	return 0;
    }















    /*
     * Be sure to disable event servicing so we are truly modal.
     */

    oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE);








>
>
>
>
>
>
>
>
>
>
>
>
>
>







604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
    /*
     * Check if an async connect is running. If not return ok
     */

    if (!(statePtr->flags & TCP_ASYNC_CONNECT)) {
	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)
     * - 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.
     */

    oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE);

1288
1289
1290
1291
1292
1293
1294

1295

1296
1297
1298
1299
1300
1301
1302
    /*
     * Go one step in async connect
     *
     * If any error is thrown save it as backround error to report eventually
     * below.
     */


    WaitForConnect(statePtr, NULL);


    sock = statePtr->sockets->fd;
    if (optionName != NULL) {
	len = strlen(optionName);
    }

    if ((len > 1) && (optionName[1] == 'e') &&







>
|
>







1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
    /*
     * Go one step in async connect
     *
     * If any error is thrown save it as backround error to report eventually
     * below.
     */

    if (! (statePtr->testFlags & TCP_ASYNC_TEST_MODE) ) {
	WaitForConnect(statePtr, NULL);
    }

    sock = statePtr->sockets->fd;
    if (optionName != NULL) {
	len = strlen(optionName);
    }

    if ((len > 1) && (optionName[1] == 'e') &&