From 53a12f1cf62f19f53ef964da17fc300de9e1ecdb Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Tue, 8 Mar 2016 18:06:06 +0000
Subject: [0b8c387cf7] Replace deprecated Tcl_VarEval() call with reworked
 callback system that uses Tcl_Obj scripts.

---
 generic/tclIOCmd.c | 45 +++++++++++++++++++++++++--------------------
 1 file changed, 25 insertions(+), 20 deletions(-)

diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index 834f225..b7b7b66 100644
--- a/generic/tclIOCmd.c
+++ b/generic/tclIOCmd.c
@@ -16,7 +16,7 @@
  */
 
 typedef struct AcceptCallback {
-    char *script;		/* Script to invoke. */
+    Tcl_Obj *script;		/* Script to invoke. */
     Tcl_Interp *interp;		/* Interpreter in which to run it. */
 } AcceptCallback;
 
@@ -37,8 +37,7 @@ static Tcl_ThreadDataKey dataKey;
  */
 
 static void		FinalizeIOCmdTSD(ClientData clientData);
-static void		AcceptCallbackProc(ClientData callbackData,
-			    Tcl_Channel chan, char *address, int port);
+static Tcl_TcpAcceptProc AcceptCallbackProc;
 static int		ChanPendingObjCmd(ClientData unused,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
@@ -1373,15 +1372,22 @@ AcceptCallbackProc(
      */
 
     if (acceptCallbackPtr->interp != NULL) {
-	char portBuf[TCL_INTEGER_SPACE];
-	char *script = acceptCallbackPtr->script;
 	Tcl_Interp *interp = acceptCallbackPtr->interp;
-	int result;
+	Tcl_Obj *script, *objv[2];
+	int result = TCL_OK;
 
-	Tcl_Preserve(script);
-	Tcl_Preserve(interp);
+	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]);
 
-	TclFormatInt(portBuf, port);
+	Tcl_Preserve(interp);
 	Tcl_RegisterChannel(interp, chan);
 
 	/*
@@ -1391,8 +1397,9 @@ AcceptCallbackProc(
 
 	Tcl_RegisterChannel(NULL, chan);
 
-	result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan),
-		" ", address, " ", portBuf, NULL);
+	result = Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT);
+	Tcl_DecrRefCount(script);
+
 	if (result != TCL_OK) {
 	    Tcl_BackgroundException(interp, result);
 	    Tcl_UnregisterChannel(interp, chan);
@@ -1406,7 +1413,6 @@ AcceptCallbackProc(
 	Tcl_UnregisterChannel(NULL, chan);
 
 	Tcl_Release(interp);
-	Tcl_Release(script);
     } else {
 	/*
 	 * The interpreter has been deleted, so there is no useful way to use
@@ -1450,7 +1456,7 @@ TcpServerCloseProc(
 	UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp,
 		acceptCallbackPtr);
     }
-    Tcl_EventuallyFree(acceptCallbackPtr->script, TCL_DYNAMIC);
+    Tcl_DecrRefCount(acceptCallbackPtr->script);
     ckfree(acceptCallbackPtr);
 }
 
@@ -1485,7 +1491,8 @@ Tcl_SocketObjCmd(
 	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;
+    const char *host, *myaddr = NULL;
+    Tcl_Obj *script = NULL;
     Tcl_Channel chan;
 
     if (TclpHasSockets(interp) != TCL_OK) {
@@ -1548,7 +1555,7 @@ Tcl_SocketObjCmd(
 			"no argument given for -server option", -1));
 		return TCL_ERROR;
 	    }
-	    script = TclGetString(objv[a]);
+	    script = objv[a];
 	    break;
 	default:
 	    Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions");
@@ -1589,16 +1596,14 @@ Tcl_SocketObjCmd(
     if (server) {
 	AcceptCallback *acceptCallbackPtr =
 		ckalloc(sizeof(AcceptCallback));
-	unsigned len = strlen(script) + 1;
-	char *copyScript = ckalloc(len);
 
-	memcpy(copyScript, script, len);
-	acceptCallbackPtr->script = copyScript;
+	Tcl_IncrRefCount(script);
+	acceptCallbackPtr->script = script;
 	acceptCallbackPtr->interp = interp;
 	chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc,
 		acceptCallbackPtr);
 	if (chan == NULL) {
-	    ckfree(copyScript);
+	    Tcl_DecrRefCount(script);
 	    ckfree(acceptCallbackPtr);
 	    return TCL_ERROR;
 	}
-- 
cgit v0.12