Tcl Source Code

Check-in [632f70c01d]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

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

Overview
Comment:[0b8c387cf7] Replace deprecated Tcl_VarEval(). socket accept callbacks now always evaluate in global context. *** POTENTIAL INCOMPATIBILITY ***
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk | potential incompatibility
Files: files | file ages | folders
SHA1: 632f70c01d3132cc8f5027a9fd52757319b36814
User & Date: dgp 2016-03-17 13:25:11
Context
2016-03-20
20:42
[1af8de570511] Fix crash in [string replace] caused by cut-n-paste. check-in: 0d8edd300b user: dkf tags: trunk
2016-03-17
15:54
merge trunk check-in: f37df7edbc user: jan.nijtmans tags: tip-439, semver
13:31
merge trunk check-in: 419214420d user: dgp tags: novem
13:25
[0b8c387cf7] Replace deprecated Tcl_VarEval(). socket accept callbacks now always evaluate in global... check-in: 632f70c01d user: dgp tags: trunk, potential incompatibility
13:19
merge 8.6 bug fixes check-in: 24feef28e8 user: dgp tags: trunk
2016-03-16
14:52
Merge trunk. Add TCL_EVAL_GLOBAL flag to Tcl_EvalObjEx(), for reason mentioned in [0b8c387cf7]. Closed-Leaf check-in: 727564218e user: jan.nijtmans tags: bug-0b8c387cf7
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclIOCmd.c.

12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
..
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
....
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378

1379
1380








1381
1382

1383
1384

1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395

1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
....
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
....
1481
1482
1483
1484
1485
1486
1487
1488

1489
1490
1491
1492
1493
1494
1495
....
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
....
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595

1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
#include "tclInt.h"

/*
 * Callback structure for accept callback in a TCP server.
 */

typedef struct AcceptCallback {
    char *script;		/* Script to invoke. */
    Tcl_Interp *interp;		/* Interpreter in which to run it. */
} AcceptCallback;

/*
 * Thread local storage used to maintain a per-thread stdout channel obj.
 * It must be per-thread because of std channel limitations.
 */
................................................................................
static Tcl_ThreadDataKey dataKey;

/*
 * Static functions for this file:
 */

static void		FinalizeIOCmdTSD(ClientData clientData);
static void		AcceptCallbackProc(ClientData callbackData,
			    Tcl_Channel chan, char *address, int port);
static int		ChanPendingObjCmd(ClientData unused,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
static int		ChanTruncateObjCmd(ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
static void		RegisterTcpServerInterpCleanup(Tcl_Interp *interp,
................................................................................
    /*
     * Check if the callback is still valid; the interpreter may have gone
     * away, this is signalled by setting the interp field of the callback
     * data to NULL.
     */

    if (acceptCallbackPtr->interp != NULL) {
	char portBuf[TCL_INTEGER_SPACE];
	char *script = acceptCallbackPtr->script;
	Tcl_Interp *interp = acceptCallbackPtr->interp;

	int result;









	Tcl_Preserve(script);
	Tcl_Preserve(interp);


	TclFormatInt(portBuf, port);

	Tcl_RegisterChannel(interp, chan);

	/*
	 * Artificially bump the refcount to protect the channel from being
	 * deleted while the script is being evaluated.
	 */

	Tcl_RegisterChannel(NULL, chan);

	result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan),
		" ", address, " ", portBuf, NULL);

	if (result != TCL_OK) {
	    Tcl_BackgroundException(interp, result);
	    Tcl_UnregisterChannel(interp, chan);
	}

	/*
	 * Decrement the artificially bumped refcount. After this it is not
	 * safe anymore to use "chan", because it may now be deleted.
	 */

	Tcl_UnregisterChannel(NULL, chan);

	Tcl_Release(interp);
	Tcl_Release(script);
    } else {
	/*
	 * The interpreter has been deleted, so there is no useful way to use
	 * the client socket - just close it.
	 */

	Tcl_Close(NULL, chan);
................................................................................
    AcceptCallback *acceptCallbackPtr = callbackData;
				/* The actual data. */

    if (acceptCallbackPtr->interp != NULL) {
	UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp,
		acceptCallbackPtr);
    }
    Tcl_EventuallyFree(acceptCallbackPtr->script, TCL_DYNAMIC);
    ckfree(acceptCallbackPtr);
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_SocketObjCmd --
................................................................................
    static const char *const socketOptions[] = {
	"-async", "-myaddr", "-myport", "-server", NULL
    };
    enum socketOptions {
	SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER
    };
    int optionIndex, a, server = 0, port, myport = 0, async = 0;
    const char *host, *script = NULL, *myaddr = NULL;

    Tcl_Channel chan;

    if (TclpHasSockets(interp) != TCL_OK) {
	return TCL_ERROR;
    }

    for (a = 1; a < objc; a++) {
................................................................................
	    server = 1;
	    a++;
	    if (a >= objc) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"no argument given for -server option", -1));
		return TCL_ERROR;
	    }
	    script = TclGetString(objv[a]);
	    break;
	default:
	    Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions");
	}
    }
    if (server) {
	host = myaddr;		/* NULL implies INADDR_ANY */
................................................................................
    } else {
	goto wrongNumArgs;
    }

    if (server) {
	AcceptCallback *acceptCallbackPtr =
		ckalloc(sizeof(AcceptCallback));
	unsigned len = strlen(script) + 1;
	char *copyScript = ckalloc(len);

	memcpy(copyScript, script, len);

	acceptCallbackPtr->script = copyScript;
	acceptCallbackPtr->interp = interp;
	chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc,
		acceptCallbackPtr);
	if (chan == NULL) {
	    ckfree(copyScript);
	    ckfree(acceptCallbackPtr);
	    return TCL_ERROR;
	}

	/*
	 * Register with the interpreter to let us know when the interpreter
	 * is deleted (by having the callback set the interp field of the






|







 







|
<







 







<
<

>
|

>
>
>
>
>
>
>
>
|
<
>

<
>









|
|
>













<







 







|







 







|
>







 







|







 







<
<

<
>
|




|







12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
..
33
34
35
36
37
38
39
40

41
42
43
44
45
46
47
....
1368
1369
1370
1371
1372
1373
1374


1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387

1388
1389

1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415

1416
1417
1418
1419
1420
1421
1422
....
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
....
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
....
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
....
1592
1593
1594
1595
1596
1597
1598


1599

1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
#include "tclInt.h"

/*
 * Callback structure for accept callback in a TCP server.
 */

typedef struct AcceptCallback {
    Tcl_Obj *script;		/* Script to invoke. */
    Tcl_Interp *interp;		/* Interpreter in which to run it. */
} AcceptCallback;

/*
 * Thread local storage used to maintain a per-thread stdout channel obj.
 * It must be per-thread because of std channel limitations.
 */
................................................................................
static Tcl_ThreadDataKey dataKey;

/*
 * Static functions for this file:
 */

static void		FinalizeIOCmdTSD(ClientData clientData);
static Tcl_TcpAcceptProc AcceptCallbackProc;

static int		ChanPendingObjCmd(ClientData unused,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
static int		ChanTruncateObjCmd(ClientData dummy,
			    Tcl_Interp *interp, int objc,
			    Tcl_Obj *const objv[]);
static void		RegisterTcpServerInterpCleanup(Tcl_Interp *interp,
................................................................................
    /*
     * Check if the callback is still valid; the interpreter may have gone
     * away, this is signalled by setting the interp field of the callback
     * data to NULL.
     */

    if (acceptCallbackPtr->interp != NULL) {


	Tcl_Interp *interp = acceptCallbackPtr->interp;
	Tcl_Obj *script, *objv[2];
	int result = TCL_OK;

	objv[0] = acceptCallbackPtr->script;
	objv[1] = Tcl_NewListObj(3, NULL);
	Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewStringObj(
		Tcl_GetChannelName(chan), -1));
	Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewStringObj(address, -1));
	Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewIntObj(port));

	script = Tcl_ConcatObj(2, objv);
	Tcl_IncrRefCount(script);

	Tcl_DecrRefCount(objv[1]);


	Tcl_Preserve(interp);
	Tcl_RegisterChannel(interp, chan);

	/*
	 * Artificially bump the refcount to protect the channel from being
	 * deleted while the script is being evaluated.
	 */

	Tcl_RegisterChannel(NULL, chan);

	result = Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT|TCL_EVAL_GLOBAL);
	Tcl_DecrRefCount(script);

	if (result != TCL_OK) {
	    Tcl_BackgroundException(interp, result);
	    Tcl_UnregisterChannel(interp, chan);
	}

	/*
	 * Decrement the artificially bumped refcount. After this it is not
	 * safe anymore to use "chan", because it may now be deleted.
	 */

	Tcl_UnregisterChannel(NULL, chan);

	Tcl_Release(interp);

    } else {
	/*
	 * The interpreter has been deleted, so there is no useful way to use
	 * the client socket - just close it.
	 */

	Tcl_Close(NULL, chan);
................................................................................
    AcceptCallback *acceptCallbackPtr = callbackData;
				/* The actual data. */

    if (acceptCallbackPtr->interp != NULL) {
	UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp,
		acceptCallbackPtr);
    }
    Tcl_DecrRefCount(acceptCallbackPtr->script);
    ckfree(acceptCallbackPtr);
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_SocketObjCmd --
................................................................................
    static const char *const socketOptions[] = {
	"-async", "-myaddr", "-myport", "-server", NULL
    };
    enum socketOptions {
	SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER
    };
    int optionIndex, a, server = 0, port, myport = 0, async = 0;
    const char *host, *myaddr = NULL;
    Tcl_Obj *script = NULL;
    Tcl_Channel chan;

    if (TclpHasSockets(interp) != TCL_OK) {
	return TCL_ERROR;
    }

    for (a = 1; a < objc; a++) {
................................................................................
	    server = 1;
	    a++;
	    if (a >= objc) {
		Tcl_SetObjResult(interp, Tcl_NewStringObj(
			"no argument given for -server option", -1));
		return TCL_ERROR;
	    }
	    script = objv[a];
	    break;
	default:
	    Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions");
	}
    }
    if (server) {
	host = myaddr;		/* NULL implies INADDR_ANY */
................................................................................
    } else {
	goto wrongNumArgs;
    }

    if (server) {
	AcceptCallback *acceptCallbackPtr =
		ckalloc(sizeof(AcceptCallback));




	Tcl_IncrRefCount(script);
	acceptCallbackPtr->script = script;
	acceptCallbackPtr->interp = interp;
	chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc,
		acceptCallbackPtr);
	if (chan == NULL) {
	    Tcl_DecrRefCount(script);
	    ckfree(acceptCallbackPtr);
	    return TCL_ERROR;
	}

	/*
	 * Register with the interpreter to let us know when the interpreter
	 * is deleted (by having the callback set the interp field of the