From 1b9647ed07ffe728a63f34d0b6799ec123f99532 Mon Sep 17 00:00:00 2001
From: dgp <dgp@noemail.net>
Date: Mon, 5 Jun 2006 18:06:47 +0000
Subject: * generic/tkInt.h: Thread safety for the data structures
of * generic/tkConsole.c: the wish [console]. [Bug 1188340].
FossilOrigin-Name: 10a79ac1bed99e6824053237f89e440d5572672d
---
ChangeLog | 5 +
generic/tkConsole.c | 772 +++++++++++++++++++++++++++++++---------------------
generic/tkInt.h | 5 +-
3 files changed, 461 insertions(+), 321 deletions(-)
diff --git a/ChangeLog b/ChangeLog
index 1967726..44149b1 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2006-06-05 Don Porter <dgp@users.sourceforge.net>
+
+ * generic/tkInt.h: Thread safety for the data structures of
+ * generic/tkConsole.c: the wish [console]. [Bug 1188340].
+
2006-06-01 Don Porter <dgp@users.sourceforge.net>
* generic/tkConsole.c: Added Tcl_RegisterChannel() calls to bump
diff --git a/generic/tkConsole.c b/generic/tkConsole.c
index 1aaf2c9..d0ce932 100644
--- a/generic/tkConsole.c
+++ b/generic/tkConsole.c
@@ -10,70 +10,62 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tkConsole.c,v 1.18.2.3 2006/06/01 18:21:41 dgp Exp $
+ * RCS: @(#) $Id: tkConsole.c,v 1.18.2.4 2006/06/05 18:06:47 dgp Exp $
+ *
*/
#include "tk.h"
-#include <string.h>
-
-#include "tkInt.h"
/*
- * A data structure of the following type holds information for each console
- * which a handler (i.e. a Tcl command) has been defined for a particular
- * top-level window.
+ * Each console is associated with an instance of the ConsoleInfo struct.
+ * It keeps track of what interp holds the Tk application that displays
+ * the console, and what interp is controlled by the interactions in that
+ * console. A refCount permits the struct to be shared as instance data
+ * by commands and by channels.
*/
typedef struct ConsoleInfo {
- Tcl_Interp *consoleInterp; /* Interpreter for the console. */
- Tcl_Interp *interp; /* Interpreter to send console commands. */
+ Tcl_Interp *consoleInterp; /* Interpreter displaying the console. */
+ Tcl_Interp *interp; /* Interpreter controlled by console. */
+ int refCount;
} ConsoleInfo;
/*
- * Each interpreter with a console attached stores a reference to the
- * interpreter's ConsoleInfo in the interpreter's AssocData store. The
- * alternative is to look the values up by examining the "console"
- * command and that is fragile. [Bug 1016385]
+ * Each console channel holds an instance of the ChannelData struct as
+ * its instance data. It contains ConsoleInfo, so the channel can work
+ * with the appropriate console window, and a type value to distinguish
+ * the stdout channel from the stderr channel.
*/
-#define TK_CONSOLE_INFO_KEY "tk::ConsoleInfo"
-
-typedef struct ThreadSpecificData {
- Tcl_Interp *gStdoutInterp;
-} ThreadSpecificData;
-static Tcl_ThreadDataKey dataKey;
-static int consoleInitialized = 0;
+typedef struct ChannelData {
+ ConsoleInfo *info;
+ int type; /* TCL_STDOUT or TCL_STDERR */
+} ChannelData;
/*
- * The Mutex below is used to lock access to the consoleIntialized flag
+ * Prototypes for local procedures defined in this file:
*/
-TCL_DECLARE_MUTEX(consoleMutex)
-
-/*
- * Forward declarations for procedures defined later in this file:
- *
- * The first three will be used in the tk app shells...
- */
-
-static int ConsoleCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, CONST char **argv));
+static int ConsoleClose _ANSI_ARGS_((ClientData instanceData,
+ Tcl_Interp *interp));
static void ConsoleDeleteProc _ANSI_ARGS_((ClientData clientData));
static void ConsoleEventProc _ANSI_ARGS_((ClientData clientData,
XEvent *eventPtr));
-static int InterpreterCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, CONST char **argv));
-
+static int ConsoleHandle _ANSI_ARGS_((ClientData instandeData,
+ int direction, ClientData *handlePtr));
static int ConsoleInput _ANSI_ARGS_((ClientData instanceData,
char *buf, int toRead, int *errorCode));
+static int ConsoleObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
static int ConsoleOutput _ANSI_ARGS_((ClientData instanceData,
CONST char *buf, int toWrite, int *errorCode));
-static int ConsoleClose _ANSI_ARGS_((ClientData instanceData,
- Tcl_Interp *interp));
static void ConsoleWatch _ANSI_ARGS_((ClientData instanceData,
int mask));
-static int ConsoleHandle _ANSI_ARGS_((ClientData instanceData,
- int direction, ClientData *handlePtr));
+static void DeleteConsoleInterp _ANSI_ARGS_((ClientData clientData));
+static void InterpDeleteProc _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp));
+static int InterpreterObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
/*
* This structure describes the channel type structure for file based IO:
@@ -221,8 +213,8 @@ static int ShouldUseConsoleChannel(type)
* Tk_InitConsoleChannels --
*
* Create the console channels and install them as the standard
- * channels. All I/O will be discarded until TkConsoleInit is
- * called to attach the console to a text widget.
+ * channels. All I/O will be discarded until Tk_CreateConsoleWindow
+ * is called to attach the console to a text widget.
*
* Results:
* None.
@@ -238,6 +230,9 @@ void
Tk_InitConsoleChannels(interp)
Tcl_Interp *interp;
{
+ static Tcl_ThreadDataKey consoleInitKey;
+ int *consoleInitPtr, doIn, doOut, doErr;
+ ConsoleInfo *info;
Tcl_Channel consoleChannel;
/*
@@ -249,78 +244,91 @@ Tk_InitConsoleChannels(interp)
return;
}
- Tcl_MutexLock(&consoleMutex);
- if (!consoleInitialized) {
+ consoleInitPtr = Tcl_GetThreadData(&consoleInitKey, (int)sizeof(int));
+ if (*consoleInitPtr) {
+ /* We've already initialized console channels in this thread. */
+ return;
+ }
+ *consoleInitPtr = 1;
- consoleInitialized = 1;
-
+ doIn = ShouldUseConsoleChannel(TCL_STDIN);
+ doOut = ShouldUseConsoleChannel(TCL_STDOUT);
+ doErr = ShouldUseConsoleChannel(TCL_STDERR);
+
+ if (!(doIn || doOut || doErr)) {
/*
- * check for STDIN, otherwise create it
- *
- * Don't do this check on the Mac, because it is hard to prevent
- * callbacks from the SIOUX layer from opening stdout & stdin, but
- * we don't want to use the SIOUX console. Since the console is not
- * actually created till something is written to the channel, it is
- * okay to just ignore it here.
- *
- * This is still a bit of a hack, however, and should be cleaned up
- * when we have a better abstraction for the console.
+ * No std channels should be tied to the console;
+ * Thus, no need to create the console
*/
+ return;
+ }
- if (ShouldUseConsoleChannel(TCL_STDIN)) {
- consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console0",
- (ClientData) TCL_STDIN, TCL_READABLE);
- if (consoleChannel != NULL) {
- Tcl_SetChannelOption(NULL, consoleChannel,
- "-translation", "lf");
- Tcl_SetChannelOption(NULL, consoleChannel,
- "-buffering", "none");
- Tcl_SetChannelOption(NULL, consoleChannel,
- "-encoding", "utf-8");
- }
- Tcl_SetStdChannel(consoleChannel, TCL_STDIN);
- Tcl_RegisterChannel(NULL, consoleChannel);
+ /*
+ * At least one std channel wants to be tied to the console,
+ * so create the interp for it to live in.
+ */
+
+ info = (ConsoleInfo *) ckalloc(sizeof(ConsoleInfo));
+ info->consoleInterp = NULL;
+ info->interp = NULL;
+ info->refCount = 0;
+
+ if (doIn) {
+ ChannelData *data = (ChannelData *) ckalloc(sizeof(ChannelData));
+ data->info = info;
+ data->info->refCount++;
+ data->type = TCL_STDIN;
+ consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console0",
+ (ClientData) data, TCL_READABLE);
+ if (consoleChannel != NULL) {
+ Tcl_SetChannelOption(NULL, consoleChannel,
+ "-translation", "lf");
+ Tcl_SetChannelOption(NULL, consoleChannel,
+ "-buffering", "none");
+ Tcl_SetChannelOption(NULL, consoleChannel,
+ "-encoding", "utf-8");
}
+ Tcl_SetStdChannel(consoleChannel, TCL_STDIN);
+ Tcl_RegisterChannel(NULL, consoleChannel);
+ }
- /*
- * check for STDOUT, otherwise create it
- */
-
- if (ShouldUseConsoleChannel(TCL_STDOUT)) {
- consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console1",
- (ClientData) TCL_STDOUT, TCL_WRITABLE);
- if (consoleChannel != NULL) {
- Tcl_SetChannelOption(NULL, consoleChannel,
- "-translation", "lf");
- Tcl_SetChannelOption(NULL, consoleChannel,
- "-buffering", "none");
- Tcl_SetChannelOption(NULL, consoleChannel,
- "-encoding", "utf-8");
- }
- Tcl_SetStdChannel(consoleChannel, TCL_STDOUT);
- Tcl_RegisterChannel(NULL, consoleChannel);
+ if (doOut) {
+ ChannelData *data = (ChannelData *) ckalloc(sizeof(ChannelData));
+ data->info = info;
+ data->info->refCount++;
+ data->type = TCL_STDOUT;
+ consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console1",
+ (ClientData) data, TCL_WRITABLE);
+ if (consoleChannel != NULL) {
+ Tcl_SetChannelOption(NULL, consoleChannel,
+ "-translation", "lf");
+ Tcl_SetChannelOption(NULL, consoleChannel,
+ "-buffering", "none");
+ Tcl_SetChannelOption(NULL, consoleChannel,
+ "-encoding", "utf-8");
}
-
- /*
- * check for STDERR, otherwise create it
- */
-
- if (ShouldUseConsoleChannel(TCL_STDERR)) {
- consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console2",
- (ClientData) TCL_STDERR, TCL_WRITABLE);
- if (consoleChannel != NULL) {
- Tcl_SetChannelOption(NULL, consoleChannel,
- "-translation", "lf");
- Tcl_SetChannelOption(NULL, consoleChannel,
- "-buffering", "none");
- Tcl_SetChannelOption(NULL, consoleChannel,
- "-encoding", "utf-8");
- }
- Tcl_SetStdChannel(consoleChannel, TCL_STDERR);
- Tcl_RegisterChannel(NULL, consoleChannel);
+ Tcl_SetStdChannel(consoleChannel, TCL_STDOUT);
+ Tcl_RegisterChannel(NULL, consoleChannel);
+ }
+
+ if (doErr) {
+ ChannelData *data = (ChannelData *) ckalloc(sizeof(ChannelData));
+ data->info = info;
+ data->info->refCount++;
+ data->type = TCL_STDERR;
+ consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console2",
+ (ClientData) data, TCL_WRITABLE);
+ if (consoleChannel != NULL) {
+ Tcl_SetChannelOption(NULL, consoleChannel,
+ "-translation", "lf");
+ Tcl_SetChannelOption(NULL, consoleChannel,
+ "-buffering", "none");
+ Tcl_SetChannelOption(NULL, consoleChannel,
+ "-encoding", "utf-8");
}
+ Tcl_SetStdChannel(consoleChannel, TCL_STDERR);
+ Tcl_RegisterChannel(NULL, consoleChannel);
}
- Tcl_MutexUnlock(&consoleMutex);
}
/*
@@ -345,60 +353,148 @@ int
Tk_CreateConsoleWindow(interp)
Tcl_Interp *interp; /* Interpreter to use for prompting. */
{
- Tcl_Interp *consoleInterp;
+ Tcl_Channel chan;
ConsoleInfo *info;
- Tk_Window mainWindow = Tk_MainWindow(interp);
- ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
- Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
+ Tk_Window mainWindow;
+ Tcl_Command token;
+ int result = TCL_OK;
+ int haveConsoleChannel = 1;
+
#ifdef MAC_TCL
static const char *initCmd = "if {[catch {source $tk_library:console.tcl}]} {source -rsrc console}";
#else
static const char *initCmd = "source $tk_library/console.tcl";
#endif
- consoleInterp = Tcl_CreateInterp();
- if (consoleInterp == NULL) {
+ /* Init an interp with Tcl and Tk */
+ Tcl_Interp *consoleInterp = Tcl_CreateInterp();
+ if (Tcl_Init(consoleInterp) != TCL_OK) {
+ goto error;
+ }
+ if (Tk_Init(consoleInterp) != TCL_OK) {
goto error;
}
/*
- * Initialized Tcl and Tk.
+ * Fetch the instance data from whatever std channel is a
+ * console channel. If none, create fresh instance data.
*/
- if (Tcl_Init(consoleInterp) != TCL_OK) {
- goto error;
+ if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDIN))
+ == &consoleChannelType) {
+ } else if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDOUT))
+ == &consoleChannelType) {
+ } else if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDERR))
+ == &consoleChannelType) {
+ } else {
+ haveConsoleChannel = 0;
}
- if (Tk_Init(consoleInterp) != TCL_OK) {
- goto error;
+
+ if (haveConsoleChannel) {
+ ChannelData *data = (ChannelData *)Tcl_GetChannelInstanceData(chan);
+ info = data->info;
+ if (info->consoleInterp) {
+ /* New ConsoleInfo for a new console window */
+ info = (ConsoleInfo *) ckalloc(sizeof(ConsoleInfo));
+ info->refCount = 0;
+
+ /* Update any console channels to make use of the new console */
+ if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDIN))
+ == &consoleChannelType) {
+ data = (ChannelData *)Tcl_GetChannelInstanceData(chan);
+ data->info->refCount--;
+ data->info = info;
+ data->info->refCount++;
+ }
+ if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDOUT))
+ == &consoleChannelType) {
+ data = (ChannelData *)Tcl_GetChannelInstanceData(chan);
+ data->info->refCount--;
+ data->info = info;
+ data->info->refCount++;
+ }
+ if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDERR))
+ == &consoleChannelType) {
+ data = (ChannelData *)Tcl_GetChannelInstanceData(chan);
+ data->info->refCount--;
+ data->info = info;
+ data->info->refCount++;
+ }
+ }
+ } else {
+ info = (ConsoleInfo *) ckalloc(sizeof(ConsoleInfo));
+ info->refCount = 0;
}
- tsdPtr->gStdoutInterp = interp;
+
+ info->consoleInterp = consoleInterp;
+ info->interp = interp;
+
+ Tcl_CallWhenDeleted(consoleInterp, InterpDeleteProc, (ClientData) info);
+ info->refCount++;
+ Tcl_CreateThreadExitHandler(DeleteConsoleInterp,
+ (ClientData) consoleInterp);
/*
* Add console commands to the interp
*/
- info = (ConsoleInfo *) ckalloc(sizeof(ConsoleInfo));
- info->interp = interp;
- info->consoleInterp = consoleInterp;
- Tcl_CreateCommand(interp, "console", ConsoleCmd, (ClientData) info,
- (Tcl_CmdDeleteProc *) ConsoleDeleteProc);
- Tcl_CreateCommand(consoleInterp, "consoleinterp", InterpreterCmd,
- (ClientData) info, (Tcl_CmdDeleteProc *) NULL);
- Tcl_SetAssocData(interp, TK_CONSOLE_INFO_KEY, NULL, (ClientData) info);
- Tk_CreateEventHandler(mainWindow, StructureNotifyMask, ConsoleEventProc,
- (ClientData) info);
+ token = Tcl_CreateObjCommand(interp, "console", ConsoleObjCmd,
+ (ClientData) info, ConsoleDeleteProc);
+ info->refCount++;
+
+ /*
+ * We don't have to count the ref held by the [consoleinterp] command
+ * in the consoleInterp. The ref held by the consoleInterp delete
+ * handler takes care of us.
+ */
+ Tcl_CreateObjCommand(consoleInterp, "consoleinterp", InterpreterObjCmd,
+ (ClientData) info, NULL);
+
+ mainWindow = Tk_MainWindow(interp);
+ if (mainWindow) {
+ Tk_CreateEventHandler(mainWindow, StructureNotifyMask,
+ ConsoleEventProc, (ClientData) info);
+ info->refCount++;
+ }
Tcl_Preserve((ClientData) consoleInterp);
- if (Tcl_Eval(consoleInterp, initCmd) == TCL_ERROR) {
- /* goto error; -- no problem for now... */
- printf("Eval error: %s", consoleInterp->result);
+ result = Tcl_GlobalEval(consoleInterp, initCmd);
+ if (result == TCL_ERROR) {
+ Tcl_Obj *objPtr = Tcl_GetVar2Ex(consoleInterp, "errorCode", NULL,
+ TCL_GLOBAL_ONLY);
+ Tcl_ResetResult(interp);
+ if (objPtr) {
+ Tcl_SetObjErrorCode(interp, objPtr);
+ }
+
+ objPtr = Tcl_GetVar2Ex(consoleInterp, "errorInfo", NULL,
+ TCL_GLOBAL_ONLY);
+ if (objPtr) {
+ int numBytes;
+ CONST char *message = Tcl_GetStringFromObj(objPtr, &numBytes);
+ Tcl_AddObjErrorInfo(interp, message, numBytes);
+ }
+ Tcl_SetObjResult(interp, Tcl_GetObjResult(consoleInterp));
}
Tcl_Release((ClientData) consoleInterp);
+ if (result == TCL_ERROR) {
+ Tcl_DeleteCommandFromToken(interp, token);
+ mainWindow = Tk_MainWindow(interp);
+ if (mainWindow) {
+ Tk_DeleteEventHandler(mainWindow, StructureNotifyMask,
+ ConsoleEventProc, (ClientData) info);
+ if (--info->refCount <= 0) {
+ ckfree((char *) info);
+ }
+ }
+ goto error;
+ }
return TCL_OK;
error:
- if (consoleInterp != NULL) {
- Tcl_DeleteInterp(consoleInterp);
+ Tcl_AddErrorInfo(interp, "\n (creating console window)");
+ if (!Tcl_InterpDeleted(consoleInterp)) {
+ Tcl_DeleteInterp(consoleInterp);
}
return TCL_ERROR;
}
@@ -428,17 +524,30 @@ ConsoleOutput(instanceData, buf, toWrite, errorCode)
int toWrite; /* How many bytes to write? */
int *errorCode; /* Where to store error code. */
{
- ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
- Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
+ ChannelData *data = (ChannelData *)instanceData;
+ ConsoleInfo *info = data->info;
*errorCode = 0;
Tcl_SetErrno(0);
- if (tsdPtr->gStdoutInterp != NULL) {
- TkConsolePrint(tsdPtr->gStdoutInterp, (int) instanceData, buf,
- toWrite);
+ if (info) {
+ Tcl_Interp *consoleInterp = info->consoleInterp;
+
+ if (consoleInterp && !Tcl_InterpDeleted(consoleInterp)) {
+ Tcl_Obj *cmd = Tcl_NewStringObj("tk::ConsoleOutput", -1);
+ if (data->type == TCL_STDERR) {
+ Tcl_ListObjAppendElement(NULL, cmd,
+ Tcl_NewStringObj("stderr", -1));
+ } else {
+ Tcl_ListObjAppendElement(NULL, cmd,
+ Tcl_NewStringObj("stdout", -1));
+ }
+ Tcl_ListObjAppendElement(NULL, cmd, Tcl_NewStringObj(buf, toWrite));
+ Tcl_IncrRefCount(cmd);
+ Tcl_GlobalEvalObj(consoleInterp, cmd);
+ Tcl_DecrRefCount(cmd);
+ }
}
-
return toWrite;
}
@@ -492,9 +601,16 @@ ConsoleClose(instanceData, interp)
ClientData instanceData; /* Unused. */
Tcl_Interp *interp; /* Unused. */
{
- ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
- Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
- tsdPtr->gStdoutInterp = NULL;
+ ChannelData *data = (ChannelData *)instanceData;
+ ConsoleInfo *info = data->info;
+
+ if (info) {
+ if (--info->refCount <= 0) {
+ /* Assuming the Tcl_Interp * fields must already be NULL */
+ ckfree((char *) info);
+ }
+ }
+ ckfree((char *) data);
return 0;
}
@@ -560,282 +676,304 @@ ConsoleHandle(instanceData, direction, handlePtr)
/*
*----------------------------------------------------------------------
*
- * ConsoleCmd --
+ * ConsoleObjCmd --
*
* The console command implements a Tcl interface to the various console
* options.
*
* Results:
- * None.
+ * A standard Tcl result.
*
* Side effects:
- * None.
+ * See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
-ConsoleCmd(clientData, interp, argc, argv)
- ClientData clientData; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+ConsoleObjCmd(clientData, interp, objc, objv)
+ ClientData clientData; /* Access to the console interp */
+ Tcl_Interp *interp; /* Current interpreter */
+ int objc; /* Number of arguments */
+ Tcl_Obj *CONST objv[]; /* Argument objects */
{
+ int index, result;
+ static CONST char *options[] = {"eval", "hide", "show", "title", NULL};
+ enum option {CON_EVAL, CON_HIDE, CON_SHOW, CON_TITLE};
+ Tcl_Obj *cmd = NULL;
ConsoleInfo *info = (ConsoleInfo *) clientData;
- char c;
- size_t length;
- int result;
- Tcl_Interp *consoleInterp;
-
- if (argc < 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " option ?arg arg ...?\"", (char *) NULL);
+ Tcl_Interp *consoleInterp = info->consoleInterp;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "option ?arg?");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &index)
+ != TCL_OK) {
return TCL_ERROR;
}
-
- c = argv[1][0];
- length = strlen(argv[1]);
- result = TCL_OK;
- consoleInterp = info->consoleInterp;
- Tcl_Preserve((ClientData) consoleInterp);
-
- if ((c == 't') && (strncmp(argv[1], "title", length)) == 0) {
- Tcl_DString dString;
- Tcl_DStringInit(&dString);
- Tcl_DStringAppend(&dString, "wm title . ", -1);
- if (argc == 3) {
- Tcl_DStringAppendElement(&dString, argv[2]);
+ switch ((enum option) index) {
+ case CON_EVAL:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "script");
+ return TCL_ERROR;
+ }
+ cmd = objv[2];
+ break;
+ case CON_HIDE:
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+ cmd = Tcl_NewStringObj("wm withdraw .", -1);
+ break;
+ case CON_SHOW:
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
+ return TCL_ERROR;
}
- Tcl_Eval(consoleInterp, Tcl_DStringValue(&dString));
- Tcl_DStringFree(&dString);
- } else if ((c == 'h') && (strncmp(argv[1], "hide", length)) == 0) {
- Tcl_Eval(consoleInterp, "wm withdraw .");
- } else if ((c == 's') && (strncmp(argv[1], "show", length)) == 0) {
- Tcl_Eval(consoleInterp, "wm deiconify .");
- } else if ((c == 'e') && (strncmp(argv[1], "eval", length)) == 0) {
- if (argc == 3) {
- result = Tcl_Eval(consoleInterp, argv[2]);
- Tcl_AppendResult(interp, Tcl_GetStringResult(consoleInterp),
- (char *) NULL);
- } else {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " eval command\"", (char *) NULL);
- result = TCL_ERROR;
+ cmd = Tcl_NewStringObj("wm deiconify .", -1);
+ break;
+ case CON_TITLE:
+ if (objc > 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?title?");
+ return TCL_ERROR;
+ }
+ cmd = Tcl_NewStringObj("wm title .", -1);
+ if (objc == 3) {
+ Tcl_ListObjAppendElement(NULL, cmd, objv[2]);
+ }
+ break;
+ }
+
+ Tcl_IncrRefCount(cmd);
+ if (consoleInterp && !Tcl_InterpDeleted(consoleInterp)) {
+ Tcl_Preserve((ClientData) consoleInterp);
+ result = Tcl_GlobalEvalObj(consoleInterp, cmd);
+ if (result == TCL_ERROR) {
+ Tcl_Obj *objPtr = Tcl_GetVar2Ex(consoleInterp, "errorCode",
+ NULL, TCL_GLOBAL_ONLY);
+ Tcl_ResetResult(interp);
+ if (objPtr) {
+ Tcl_SetObjErrorCode(interp, objPtr);
+ }
+
+ objPtr = Tcl_GetVar2Ex(consoleInterp, "errorInfo",
+ NULL, TCL_GLOBAL_ONLY);
+ if (objPtr) {
+ int numBytes;
+ CONST char *message = Tcl_GetStringFromObj(objPtr, &numBytes);
+ Tcl_AddObjErrorInfo(interp, message, numBytes);
+ }
}
+ Tcl_SetObjResult(interp, Tcl_GetObjResult(consoleInterp));
+ Tcl_Release((ClientData) consoleInterp);
} else {
- Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": should be hide, show, or title",
- (char *) NULL);
- result = TCL_ERROR;
+ Tcl_AppendResult(interp, "no active console interp", NULL);
+ result = TCL_ERROR;
}
- Tcl_Release((ClientData) consoleInterp);
+ Tcl_DecrRefCount(cmd);
return result;
}
/*
*----------------------------------------------------------------------
*
- * InterpreterCmd --
+ * InterpreterObjCmd --
*
* This command allows the console interp to communicate with the
* main interpreter.
*
* Results:
- * None.
- *
- * Side effects:
- * None.
+ * A standard Tcl result.
*
*----------------------------------------------------------------------
*/
static int
-InterpreterCmd(clientData, interp, argc, argv)
- ClientData clientData; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- CONST char **argv; /* Argument strings. */
+InterpreterObjCmd(clientData, interp, objc, objv)
+ ClientData clientData; /* Not used */
+ Tcl_Interp *interp; /* Current interpreter */
+ int objc; /* Number of arguments */
+ Tcl_Obj *CONST objv[]; /* Argument objects */
{
+ int index, result = TCL_OK;
+ static CONST char *options[] = {"eval", "record", NULL};
+ enum option {OTHER_EVAL, OTHER_RECORD};
ConsoleInfo *info = (ConsoleInfo *) clientData;
- char c;
- size_t length;
- int result;
- Tcl_Interp *consoleInterp;
- Tcl_Interp *otherInterp;
-
- if (argc < 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " option ?arg arg ...?\"", (char *) NULL);
+ Tcl_Interp *otherInterp = info->interp;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "option arg");
return TCL_ERROR;
}
-
- c = argv[1][0];
- length = strlen(argv[1]);
- consoleInterp = info->consoleInterp;
- Tcl_Preserve((ClientData) consoleInterp);
- otherInterp = info->interp;
+ if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &index)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "script");
+ return TCL_ERROR;
+ }
+
+ if ((otherInterp == NULL) || Tcl_InterpDeleted(otherInterp)) {
+ Tcl_AppendResult(interp, "no active master interp", NULL);
+ return TCL_ERROR;
+ }
+
Tcl_Preserve((ClientData) otherInterp);
- if ((c == 'e') && (strncmp(argv[1], "eval", length)) == 0) {
- result = Tcl_GlobalEval(otherInterp, argv[2]);
- Tcl_AppendResult(interp, otherInterp->result, (char *) NULL);
- } else if ((c == 'r') && (strncmp(argv[1], "record", length)) == 0) {
- Tcl_RecordAndEval(otherInterp, argv[2], TCL_EVAL_GLOBAL);
- result = TCL_OK;
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, otherInterp->result, (char *) NULL);
- } else {
- Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": should be eval or record",
- (char *) NULL);
- result = TCL_ERROR;
+ switch ((enum option) index) {
+ case OTHER_EVAL:
+ result = Tcl_GlobalEvalObj(otherInterp, objv[2]);
+ /*
+ * TODO: Should exceptions be filtered here?
+ */
+ if (result == TCL_ERROR) {
+ Tcl_Obj *objPtr = Tcl_GetVar2Ex(otherInterp, "errorCode",
+ NULL, TCL_GLOBAL_ONLY);
+ Tcl_ResetResult(interp);
+ if (objPtr) {
+ Tcl_SetObjErrorCode(interp, objPtr);
+ }
+
+ objPtr = Tcl_GetVar2Ex(otherInterp, "errorInfo",
+ NULL, TCL_GLOBAL_ONLY);
+ if (objPtr) {
+ int numBytes;
+ CONST char *message = Tcl_GetStringFromObj(objPtr, &numBytes);
+ Tcl_AddObjErrorInfo(interp, message, numBytes);
+ }
+ }
+ Tcl_SetObjResult(interp, Tcl_GetObjResult(otherInterp));
+ break;
+ case OTHER_RECORD:
+ Tcl_RecordAndEvalObj(otherInterp, objv[2], TCL_EVAL_GLOBAL);
+ /*
+ * By not setting result, we discard any exceptions or errors here
+ * and always return TCL_OK. All the caller wants is the
+ * interp result to display, whether that's result or error message.
+ */
+ Tcl_SetObjResult(interp, Tcl_GetObjResult(otherInterp));
+ break;
}
Tcl_Release((ClientData) otherInterp);
- Tcl_Release((ClientData) consoleInterp);
return result;
}
/*
*----------------------------------------------------------------------
*
- * ConsoleDeleteProc --
+ * DeleteConsoleInterp --
*
- * If the console command is deleted we destroy the console window
- * and all associated data structures.
+ * Thread exit handler to destroy a console interp when the
+ * thread it lives in gets torn down.
*
- * Results:
- * None.
+ *----------------------------------------------------------------------
+ */
+
+static void
+DeleteConsoleInterp(clientData)
+ ClientData clientData;
+{
+ Tcl_Interp *interp = (Tcl_Interp *)clientData;
+ Tcl_DeleteInterp(interp);
+}
+
+/*
+ *----------------------------------------------------------------------
*
- * Side effects:
- * A new console it created.
+ * InterpDeleteProc --
*
- *----------------------------------------------------------------------
+ * React when the interp in which the console is displayed is deleted
+ * for any reason.
+ *
+ * Results:
+ * None.
*/
static void
-ConsoleDeleteProc(clientData)
+InterpDeleteProc(clientData, interp)
ClientData clientData;
+ Tcl_Interp *interp;
{
ConsoleInfo *info = (ConsoleInfo *) clientData;
- ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
- Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
- /*
- * Also need to null this out to prevent any further use.
- *
- * Fix [Bug #756840]
- */
- if (tsdPtr != NULL) {
- tsdPtr->gStdoutInterp = NULL;
+ if(info->consoleInterp == interp) {
+ Tcl_DeleteThreadExitHandler(DeleteConsoleInterp,
+ (ClientData) info-> consoleInterp);
+ info->consoleInterp = NULL;
+ }
+ if (--info->refCount <= 0) {
+ ckfree((char *) info);
}
-
- Tcl_DeleteInterp(info->consoleInterp);
- info->consoleInterp = NULL;
}
/*
*----------------------------------------------------------------------
*
- * ConsoleEventProc --
- *
- * This event procedure is registered on the main window of the
- * slave interpreter. If the user or a running script causes the
- * main window to be destroyed, then we need to inform the console
- * interpreter by invoking "::tk::ConsoleExit".
+ * ConsoleDeleteProc --
*
+ * If the console command is deleted we destroy the console window and
+ * all associated data structures.
+
* Results:
* None.
*
* Side effects:
- * Invokes the "::tk::ConsoleExit" procedure in the console interp.
+ * A new console is created.
*
*----------------------------------------------------------------------
*/
static void
-ConsoleEventProc(clientData, eventPtr)
+ConsoleDeleteProc(clientData)
ClientData clientData;
- XEvent *eventPtr;
{
ConsoleInfo *info = (ConsoleInfo *) clientData;
- Tcl_Interp *consoleInterp;
-
- if (eventPtr->type == DestroyNotify) {
- consoleInterp = info->consoleInterp;
-
- /*
- * It is possible that the console interpreter itself has
- * already been deleted. In that case the consoleInterp
- * field will be set to NULL. If the interpreter is already
- * gone, we do not have to do any work here.
- */
-
- if (consoleInterp == (Tcl_Interp *) NULL) {
- return;
- } else {
- Tcl_Preserve((ClientData) consoleInterp);
- Tcl_Eval(consoleInterp, "::tk::ConsoleExit");
- Tcl_Release((ClientData) consoleInterp);
- }
+ if (info->consoleInterp) {
+ Tcl_DeleteInterp(info->consoleInterp);
+ }
+ if (--info->refCount <= 0) {
+ ckfree((char *) info);
}
}
/*
*----------------------------------------------------------------------
*
- * TkConsolePrint --
- *
- * Prints to the give text to the console. Given the main interp
- * this functions find the appropiate console interp and forwards
- * the text to be added to that console.
+ * ConsoleEventProc --
*
+ * This event function is registered on the main window of the slave
+ * interpreter. If the user or a running script causes the main window to
+ * be destroyed, then we need to inform the console interpreter by
+ * invoking "::tk::ConsoleExit".
* Results:
* None.
*
* Side effects:
- * None.
+ * Invokes the "::tk::ConsoleExit" command in the console interp.
*
*----------------------------------------------------------------------
*/
-void
-TkConsolePrint(interp, devId, buffer, size)
- Tcl_Interp *interp; /* Main interpreter. */
- int devId; /* TCL_STDOUT for stdout, TCL_STDERR for
- * stderr. */
- CONST char *buffer; /* Text buffer. */
- long size; /* Size of text buffer. */
+static void
+ConsoleEventProc(clientData, eventPtr)
+ ClientData clientData;
+ XEvent *eventPtr;
{
- Tcl_DString command, output;
- ConsoleInfo *info;
- Tcl_Interp *consoleInterp;
-
- if (interp == NULL) {
- return;
- }
+ if (eventPtr->type == DestroyNotify) {
+ ConsoleInfo *info = (ConsoleInfo *) clientData;
+ Tcl_Interp *consoleInterp = info->consoleInterp;
- info = (ConsoleInfo *) Tcl_GetAssocData(interp, TK_CONSOLE_INFO_KEY, NULL);
- if (info == NULL || info->consoleInterp == NULL) {
- return;
- }
+ if (consoleInterp && !Tcl_InterpDeleted(consoleInterp)) {
+ Tcl_GlobalEval(consoleInterp, "tk::ConsoleExit");
+ }
- Tcl_DStringInit(&command);
- if (devId == TCL_STDERR) {
- Tcl_DStringAppend(&command, "::tk::ConsoleOutput stderr ", -1);
- } else {
- Tcl_DStringAppend(&command, "::tk::ConsoleOutput stdout ", -1);
+ if (--info->refCount <= 0) {
+ ckfree((char *) info);
+ }
}
-
- Tcl_DStringInit(&output);
- Tcl_DStringAppend(&output, buffer, size);
- Tcl_DStringAppendElement(&command, Tcl_DStringValue(&output));
- Tcl_DStringFree(&output);
-
- consoleInterp = info->consoleInterp;
- Tcl_Preserve((ClientData) consoleInterp);
- Tcl_Eval(consoleInterp, Tcl_DStringValue(&command));
- Tcl_Release((ClientData) consoleInterp);
-
- Tcl_DStringFree(&command);
}
diff --git a/generic/tkInt.h b/generic/tkInt.h
index 1d779b4..848a8e9 100644
--- a/generic/tkInt.h
+++ b/generic/tkInt.h
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: $Id: tkInt.h,v 1.56.2.7 2005/11/27 02:44:25 das Exp $
+ * RCS: $Id: tkInt.h,v 1.56.2.8 2006/06/05 18:06:47 dgp Exp $
*/
#ifndef _TKINT
@@ -1128,9 +1128,6 @@ EXTERN int Tk_WmObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
-EXTERN void TkConsolePrint _ANSI_ARGS_((Tcl_Interp *interp,
- int devId, CONST char *buffer, long size));
-
EXTERN void TkEventInit _ANSI_ARGS_((void));
EXTERN void TkRegisterObjTypes _ANSI_ARGS_((void));
--
cgit v0.12