Modernize Tk_Init() to use Tcl 8.6 features.

4 files changed, 168 insertions, 170 deletions

diff --git a/generic/tkFrame.c b/generic/tkFrame.c
index 057b4b8..f6edfb0 100644
--- a/generic/tkFrame.c
+++ b/generic/tkFrame.c
@@ -447,6 +447,30 @@ TkCreateFrame(
     return result;
 }
 
+int
+TkListCreateFrame(
+    ClientData clientData,	/* Either NULL or pointer to option table. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    Tcl_Obj *listObj,		/* List of arguments. */
+    int toplevel,		/* Non-zero means create a toplevel window,
+				 * zero means create a frame. */
+    Tcl_Obj *nameObj)		/* Should only be non-NULL if there is no main
+				 * window associated with the interpreter.
+				 * Gives the base name to use for the new
+				 * application. */
+    
+{
+    int objc;
+    Tcl_Obj **objv;
+
+    if (TCL_OK != Tcl_ListObjGetElements(interp, listObj, &objc, &objv)) {
+	return TCL_ERROR;
+    }
+    return CreateFrame(clientData, interp, objc, objv,
+	    toplevel ? TYPE_TOPLEVEL : TYPE_FRAME,
+	    nameObj ? Tcl_GetString(nameObj) : NULL);
+}
+
 static int
 CreateFrame(
     ClientData clientData,	/* NULL. */
diff --git a/generic/tkInt.h b/generic/tkInt.h
index 8d5de04..0b502e4 100644
--- a/generic/tkInt.h
+++ b/generic/tkInt.h
@@ -1217,6 +1217,9 @@ MODULE_SCOPE int	TkInitTkCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TkInitFontchooser(Tcl_Interp *interp,
 			    ClientData clientData);
 MODULE_SCOPE void	TkpWarpPointer(TkDisplay *dispPtr);
+MODULE_SCOPE int	TkListCreateFrame(ClientData clientData,
+			    Tcl_Interp *interp, Tcl_Obj *listObj,
+			    int toplevel, Tcl_Obj *nameObj);
 
 #ifdef _WIN32
 #define TkParseColor XParseColor
diff --git a/generic/tkWindow.c b/generic/tkWindow.c
index 95e431c..81ea0e5 100644
--- a/generic/tkWindow.c
+++ b/generic/tkWindow.c
@@ -54,12 +54,6 @@ typedef struct ThreadSpecificData {
 static Tcl_ThreadDataKey dataKey;
 
 /*
- * The Mutex below is used to lock access to the Tk_Uid structs above.
- */
-
-TCL_DECLARE_MUTEX(windowMutex)
-
-/*
  * Default values for "changes" and "atts" fields of TkWindows. Note that Tk
  * always requests all events for all windows, except StructureNotify events
  * on internal windows: these events are generated internally.
@@ -206,40 +200,6 @@ static const TkCmd commands[] = {
 };
 
 /*
- * The variables and table below are used to parse arguments from the "argv"
- * variable in Tk_Init.
- */
-
-static int synchronize = 0;
-static char *name = NULL;
-static char *display = NULL;
-static char *geometry = NULL;
-static char *colormap = NULL;
-static char *use = NULL;
-static char *visual = NULL;
-static int rest = 0;
-
-static const Tk_ArgvInfo argTable[] = {
-    {"-colormap", TK_ARGV_STRING, NULL, (char *) &colormap,
-	"Colormap for main window"},
-    {"-display", TK_ARGV_STRING, NULL, (char *) &display,
-	"Display to use"},
-    {"-geometry", TK_ARGV_STRING, NULL, (char *) &geometry,
-	"Initial geometry for window"},
-    {"-name", TK_ARGV_STRING, NULL, (char *) &name,
-	"Name to use for application"},
-    {"-sync", TK_ARGV_CONSTANT, (char *) 1, (char *) &synchronize,
-	"Use synchronous mode for display server"},
-    {"-visual", TK_ARGV_STRING, NULL, (char *) &visual,
-	"Visual for main window"},
-    {"-use", TK_ARGV_STRING, NULL, (char *) &use,
-	"Id of window in which to embed application"},
-    {"--", TK_ARGV_REST, (char *) 1, (char *) &rest,
-	"Pass all remaining arguments through to script"},
-    {NULL, TK_ARGV_END, NULL, NULL, NULL}
-};
-
-/*
  * Forward declarations to functions defined later in this file:
  */
 
@@ -3035,16 +2995,51 @@ MODULE_SCOPE const TkStubs tkStubs;
  */
 
 static int
+CopyValue(
+    ClientData dummy,
+    Tcl_Obj *objPtr,
+    void *dstPtr)
+{
+    *(Tcl_Obj **)dstPtr = objPtr;
+    return 1;
+}
+
+static int
 Initialize(
     Tcl_Interp *interp)		/* Interpreter to initialize. */
 {
-    char *p;
-    int argc, code;
-    const char **argv;
-    const char *args[20];
-    const char *argString = NULL;
-    Tcl_DString class;
+    int code = TCL_OK;
     ThreadSpecificData *tsdPtr;
+    Tcl_Obj *value = NULL;
+    Tcl_Obj *cmd;
+
+    Tcl_Obj *nameObj = NULL;
+    Tcl_Obj *classObj = NULL;
+    Tcl_Obj *displayObj = NULL;
+    Tcl_Obj *colorMapObj = NULL;
+    Tcl_Obj *useObj = NULL;
+    Tcl_Obj *visualObj = NULL;
+    Tcl_Obj *geometryObj = NULL;
+
+    int sync = 0;
+
+    const Tcl_ArgvInfo table[] = {
+	{TCL_ARGV_CONSTANT, "-sync", INT2PTR(1), &sync,
+		"Use synchronous mode for display server", NULL},
+	{TCL_ARGV_FUNC, "-colormap", CopyValue, &colorMapObj,
+		"Colormap for main window", NULL},
+	{TCL_ARGV_FUNC, "-display", CopyValue, &displayObj,
+		"Display to use", NULL},
+	{TCL_ARGV_FUNC, "-geometry", CopyValue, &geometryObj,
+		"Initial geometry for window", NULL},
+	{TCL_ARGV_FUNC, "-name", CopyValue, &nameObj,
+		"Name to use for application", NULL},
+	{TCL_ARGV_FUNC, "-visual", CopyValue, &visualObj,
+		"Visual for main window", NULL},
+	{TCL_ARGV_FUNC, "-use", CopyValue, &useObj,
+		"Id of window in which to embed application", NULL},
+	TCL_ARGV_AUTO_REST, TCL_ARGV_AUTO_HELP, TCL_ARGV_TABLE_END
+    };
 
     /*
      * Ensure that we are getting a compatible version of Tcl.
@@ -3063,23 +3058,6 @@ Initialize(
     tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
 
     /*
-     * Start by initializing all the static variables to default acceptable
-     * values so that no information is leaked from a previous run of this
-     * code.
-     */
-
-    Tcl_MutexLock(&windowMutex);
-    synchronize = 0;
-    name = NULL;
-    display = NULL;
-    geometry = NULL;
-    colormap = NULL;
-    use = NULL;
-    visual = NULL;
-    rest = 0;
-    argv = NULL;
-
-    /*
      * We start by resetting the result because it might not be clean.
      */
 
@@ -3091,8 +3069,6 @@ Initialize(
 	 * master.
 	 */
 
-	Tcl_DString ds;
-
 	/*
 	 * Step 1 : find the master and construct the interp name (could be a
 	 * function if new APIs were ok). We could also construct the path
@@ -3102,18 +3078,13 @@ Initialize(
 
 	Tcl_Interp *master = interp;
 
-	while (1) {
+	while (Tcl_IsSafe(master)) {
 	    master = Tcl_GetMaster(master);
 	    if (master == NULL) {
 		Tcl_SetObjResult(interp, Tcl_NewStringObj(
 			"no controlling master interpreter", -1));
 		Tcl_SetErrorCode(interp, "TK", "SAFE", "NO_MASTER", NULL);
-		code = TCL_ERROR;
-		goto done;
-	    }
-	    if (!Tcl_IsSafe(master)) {
-		/* Found the trusted master. */
-		break;
+		return TCL_ERROR;
 	    }
 	}
 
@@ -3123,39 +3094,30 @@ Initialize(
 
 	code = Tcl_GetInterpPath(master, interp);
 	if (code != TCL_OK) {
-	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
-		    "error in Tcl_GetInterpPath", -1));
-	    Tcl_SetErrorCode(interp, "TK", "SAFE", "FAILED", NULL);
-	    goto done;
+	    Tcl_Panic("Tcl_GetInterpPath broken!");
 	}
 
 	/*
-	 * Build the string to eval.
+	 * Build the command to eval in trusted master.
 	 */
 
-	Tcl_DStringInit(&ds);
-	Tcl_DStringAppendElement(&ds, "::safe::TkInit");
-	Tcl_DStringAppendElement(&ds, Tcl_GetString(Tcl_GetObjResult(master)));
-
+	cmd = Tcl_NewListObj(2, NULL);
+	Tcl_ListObjAppendElement(NULL, cmd,
+		Tcl_NewStringObj("::safe::TkInit", -1));
+	Tcl_ListObjAppendElement(NULL, cmd, Tcl_GetObjResult(master));
+	
 	/*
 	 * Step 2 : Eval in the master. The argument is the *reversed* interp
 	 * path of the slave.
 	 */
 
-	code = Tcl_EvalEx(master, Tcl_DStringValue(&ds), -1, 0);
+	Tcl_IncrRefCount(cmd);
+	code = Tcl_EvalObjEx(master, cmd, 0);
+	Tcl_DecrRefCount(cmd);
+	Tcl_TransferResult(master, code, interp);
 	if (code != TCL_OK) {
-	    /*
-	     * We might want to transfer the error message or not. We don't.
-	     * (No API to do it and maybe security reasons).
-	     */
-
-	    Tcl_DStringFree(&ds);
-	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
-		    "not allowed to start Tk by master's safe::TkInit", -1));
-	    Tcl_SetErrorCode(interp, "TK", "SAFE", "FAILED", NULL);
-	    goto done;
+	    return code;
 	}
-	Tcl_DStringFree(&ds);
 
 	/*
 	 * Use the master's result as argv. Note: We don't use the Obj
@@ -3163,7 +3125,7 @@ Initialize(
 	 * changing the code below.
 	 */
 
-	argString = Tcl_GetString(Tcl_GetObjResult(master));
+	value = Tcl_GetObjResult(interp);
     } else {
 	/*
 	 * If there is an "argv" variable, get its value, extract out relevant
@@ -3171,50 +3133,67 @@ Initialize(
 	 * that we used.
 	 */
 
-	argString = Tcl_GetVar2(interp, "argv", NULL, TCL_GLOBAL_ONLY);
+	value = Tcl_GetVar2Ex(interp, "argv", NULL, TCL_GLOBAL_ONLY);
     }
-    if (argString != NULL) {
-	char buffer[TCL_INTEGER_SPACE];
 
-	if (Tcl_SplitList(interp, argString, &argc, &argv) != TCL_OK) {
-	argError:
+    if (value) {
+	int objc;
+	Tcl_Obj **objv, **rest;
+	Tcl_Obj *parseList = Tcl_NewListObj(1, NULL);
+
+	Tcl_ListObjAppendElement(NULL, parseList, Tcl_NewObj());
+
+	Tcl_IncrRefCount(value);
+	if (TCL_OK != Tcl_ListObjAppendList(interp, parseList, value) ||
+	    TCL_OK != Tcl_ListObjGetElements(NULL, parseList, &objc, &objv) ||
+	    TCL_OK != Tcl_ParseArgsObjv(interp, table, &objc, objv, &rest)) {
 	    Tcl_AddErrorInfo(interp,
 		    "\n    (processing arguments in argv variable)");
 	    code = TCL_ERROR;
-	    goto done;
 	}
-	if (Tk_ParseArgv(interp, (Tk_Window) NULL, &argc, argv,
-		argTable, TK_ARGV_DONT_SKIP_FIRST_ARG|TK_ARGV_NO_DEFAULTS)
-		!= TCL_OK) {
-	    goto argError;
+	if (code == TCL_OK) {
+	    Tcl_SetVar2Ex(interp, "argv", NULL,
+		    Tcl_NewListObj(objc-1, rest+1), TCL_GLOBAL_ONLY);
+	    Tcl_SetVar2Ex(interp, "argc", NULL,
+		    Tcl_NewIntObj(objc-1), TCL_GLOBAL_ONLY);
+	    ckfree(rest);
+	}
+	Tcl_DecrRefCount(parseList);
+	if (code != TCL_OK) {
+	    goto done;
 	}
-	p = Tcl_Merge(argc, argv);
-	Tcl_SetVar2(interp, "argv", NULL, p, TCL_GLOBAL_ONLY);
-	sprintf(buffer, "%d", argc);
-	Tcl_SetVar2(interp, "argc", NULL, buffer, TCL_GLOBAL_ONLY);
-	ckfree(p);
     }
 
     /*
      * Figure out the application's name and class.
      */
 
-    Tcl_DStringInit(&class);
-    if (name == NULL) {
-	int offset;
+    /*
+     * If we got no -name argument, fetch from TkpGetAppName().
+     */
 
-	TkpGetAppName(interp, &class);
-	offset = Tcl_DStringLength(&class)+1;
-	Tcl_DStringSetLength(&class, offset);
-	Tcl_DStringAppend(&class, Tcl_DStringValue(&class), offset-1);
-	name = Tcl_DStringValue(&class) + offset;
-    } else {
-	Tcl_DStringAppend(&class, name, -1);
+    if (nameObj == NULL) {
+	Tcl_DString nameDS;
+
+	Tcl_DStringInit(&nameDS);
+	TkpGetAppName(interp, &nameDS);
+	nameObj = Tcl_NewStringObj(Tcl_DStringValue(&nameDS),
+		Tcl_DStringLength(&nameDS));
+	Tcl_DStringFree(&nameDS);
     }
 
-    p = Tcl_DStringValue(&class);
-    if (*p) {
-	Tcl_UtfToTitle(p);
+    /*
+     * The -class argument is always the ToTitle of the -name
+     */
+
+    {
+	int numBytes;
+	const char *bytes = Tcl_GetStringFromObj(nameObj, &numBytes);
+
+	classObj = Tcl_NewStringObj(bytes, numBytes);
+
+	numBytes = Tcl_UtfToTitle(Tcl_GetString(classObj));
+	Tcl_SetObjLength(classObj, numBytes);
     }
 
     /*
@@ -3222,15 +3201,14 @@ Initialize(
      * information parsed from argv, if any.
      */
 
-    args[0] = "toplevel";
-    args[1] = ".";
-    args[2] = "-class";
-    args[3] = Tcl_DStringValue(&class);
-    argc = 4;
-    if (display != NULL) {
-	args[argc] = "-screen";
-	args[argc+1] = display;
-	argc += 2;
+    cmd = Tcl_NewStringObj("toplevel . -class", -1);
+
+    Tcl_ListObjAppendElement(NULL, cmd, classObj);
+    classObj = NULL;
+
+    if (displayObj) {
+	Tcl_ListObjAppendElement(NULL, cmd, Tcl_NewStringObj("-screen", -1));
+	Tcl_ListObjAppendElement(NULL, cmd, displayObj);
 
 	/*
 	 * If this is the first application for this process, save the display
@@ -3239,36 +3217,35 @@ Initialize(
 	 */
 
 	if (tsdPtr->numMainWindows == 0) {
-	    Tcl_SetVar2(interp, "env", "DISPLAY", display, TCL_GLOBAL_ONLY);
+	    Tcl_SetVar2Ex(interp, "env", "DISPLAY", displayObj, TCL_GLOBAL_ONLY);
 	}
+	displayObj = NULL;
     }
-    if (colormap != NULL) {
-	args[argc] = "-colormap";
-	args[argc+1] = colormap;
-	argc += 2;
-	colormap = NULL;
+    if (colorMapObj) {
+	Tcl_ListObjAppendElement(NULL, cmd, Tcl_NewStringObj("-colormap", -1));
+	Tcl_ListObjAppendElement(NULL, cmd, colorMapObj);
+	colorMapObj = NULL;
     }
-    if (use != NULL) {
-	args[argc] = "-use";
-	args[argc+1] = use;
-	argc += 2;
-	use = NULL;
+    if (useObj) {
+	Tcl_ListObjAppendElement(NULL, cmd, Tcl_NewStringObj("-use", -1));
+	Tcl_ListObjAppendElement(NULL, cmd, useObj);
+	useObj = NULL;
     }
-    if (visual != NULL) {
-	args[argc] = "-visual";
-	args[argc+1] = visual;
-	argc += 2;
-	visual = NULL;
+    if (visualObj) {
+	Tcl_ListObjAppendElement(NULL, cmd, Tcl_NewStringObj("-visual", -1));
+	Tcl_ListObjAppendElement(NULL, cmd, visualObj);
+	visualObj = NULL;
     }
-    args[argc] = NULL;
-    code = TkCreateFrame(NULL, interp, argc, args, 1, name);
 
-    Tcl_DStringFree(&class);
+    code = TkListCreateFrame(NULL, interp, cmd, 1, nameObj);
+
+    Tcl_DecrRefCount(cmd);
+
     if (code != TCL_OK) {
 	goto done;
     }
     Tcl_ResetResult(interp);
-    if (synchronize) {
+    if (sync) {
 	XSynchronize(Tk_Display(Tk_MainWindow(interp)), True);
     }
 
@@ -3277,19 +3254,19 @@ Initialize(
      * geometry into the "geometry" variable.
      */
 
-    if (geometry != NULL) {
-	Tcl_DString buf;
+    if (geometryObj) {
+
+	Tcl_SetVar2Ex(interp, "geometry", NULL, geometryObj, TCL_GLOBAL_ONLY);
 
-	Tcl_SetVar2(interp, "geometry", NULL, geometry, TCL_GLOBAL_ONLY);
-	Tcl_DStringInit(&buf);
-	Tcl_DStringAppend(&buf, "wm geometry . ", -1);
-	Tcl_DStringAppend(&buf, geometry, -1);
-	code = Tcl_EvalEx(interp, Tcl_DStringValue(&buf), -1, 0);
-	Tcl_DStringFree(&buf);
+	cmd = Tcl_NewStringObj("wm geometry .", -1);
+	Tcl_ListObjAppendElement(NULL, cmd, geometryObj);
+	Tcl_IncrRefCount(cmd);
+	code = Tcl_EvalObjEx(interp, cmd, 0);
+	Tcl_DecrRefCount(cmd);
+	geometryObj = NULL;
 	if (code != TCL_OK) {
 	    goto done;
 	}
-	geometry = NULL;
     }
 
     /*
@@ -3326,10 +3303,6 @@ Initialize(
      * console window interpreter.
      */
 
-    Tcl_MutexUnlock(&windowMutex);
-    if (argv != NULL) {
-	ckfree(argv);
-    }
     code = TkpInit(interp);
     if (code == TCL_OK) {
 
@@ -3362,12 +3335,10 @@ tkInit", -1, 0);
 
 	TkCreateThreadExitHandler(DeleteWindowsExitProc, tsdPtr);
     }
-    return code;
-
   done:
-    Tcl_MutexUnlock(&windowMutex);
-    if (argv != NULL) {
-	ckfree(argv);
+    if (value) {
+	Tcl_DecrRefCount(value);
+	value = NULL;
     }
     return code;
 }
diff --git a/tests/safe.test b/tests/safe.test
index bbd9d25..9a3bcfc 100644
--- a/tests/safe.test
+++ b/tests/safe.test
@@ -187,7 +187,7 @@ test safe-5.1 {loading Tk in safe interps without master's clearance} -body {
     interp eval $i {load {} Tk}
 } -cleanup {
     safe::interpDelete $i
-} -returnCodes error -result {not allowed to start Tk by master's safe::TkInit}
+} -returnCodes error -result {not allowed}
 test safe-5.2 {multi-level Tk loading with clearance} -setup {
     set safeParent [safe::interpCreate]
 } -body {