path: root/generic/tkConsole.c

/*
 * tkConsole.c --
 *
 *	This file implements a Tcl console for systems that may not otherwise
 *	have access to a console. It uses the Text widget and provides special
 *	access via a console command.
 *
 * Copyright (c) 1995-1996 Sun Microsystems, Inc.
 *
 * 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.24 2005/11/11 23:51:27 dkf 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.
 */

typedef struct ConsoleInfo {
    Tcl_Interp *consoleInterp;	/* Interpreter for the console. */
    Tcl_Interp *interp;		/* Interpreter to send console commands. */
} 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]
 */

#define TK_CONSOLE_INFO_KEY	"tk::ConsoleInfo"

typedef struct ThreadSpecificData {
    Tcl_Interp *gStdoutInterp;
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
static int consoleInitialized = 0;

/*
 * The Mutex below is used to lock access to the consoleIntialized flag
 */

TCL_DECLARE_MUTEX(consoleMutex)

/*
 * Forward declarations for functions defined later in this file:
 *
 * The first three will be used in the tk app shells...
 */

static int	ConsoleCmd(ClientData clientData,
		    Tcl_Interp *interp, int argc, CONST char **argv);
static void	ConsoleDeleteProc(ClientData clientData);
static void	ConsoleEventProc(ClientData clientData, XEvent *eventPtr);
static int	InterpreterCmd(ClientData clientData,
		    Tcl_Interp *interp, int argc, CONST char **argv);

static int	ConsoleInput(ClientData instanceData,
		    char *buf, int toRead, int *errorCode);
static int	ConsoleOutput(ClientData instanceData,
		    CONST char *buf, int toWrite, int *errorCode);
static int	ConsoleClose(ClientData instanceData, Tcl_Interp *interp);
static void	ConsoleWatch(ClientData instanceData, int mask);
static int	ConsoleHandle(ClientData instanceData,
		    int direction, ClientData *handlePtr);

/*
 * This structure describes the channel type structure for file based IO:
 */

static Tcl_ChannelType consoleChannelType = {
    "console",			/* Type name. */
    NULL,			/* Always non-blocking.*/
    ConsoleClose,		/* Close proc. */
    ConsoleInput,		/* Input proc. */
    ConsoleOutput,		/* Output proc. */
    NULL,			/* Seek proc. */
    NULL,			/* Set option proc. */
    NULL,			/* Get option proc. */
    ConsoleWatch,		/* Watch for events on console. */
    ConsoleHandle,		/* Get a handle from the device. */
};

#ifdef __WIN32__
#include <windows.h>

/*
 *----------------------------------------------------------------------
 *
 * ShouldUseConsoleChannel
 *
 *	Check to see if console window should be used for a given standard
 *	channel.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Creates the console channel and installs it as the standard channels.
 *
 *----------------------------------------------------------------------
 */

static int
ShouldUseConsoleChannel(
    int type)
{
    DWORD handleId;		/* Standard handle to retrieve. */
    DCB dcb;
    DWORD consoleParams;
    DWORD fileType;
    int mode;
    char *bufMode;
    HANDLE handle;

    switch (type) {
    case TCL_STDIN:
	handleId = STD_INPUT_HANDLE;
	mode = TCL_READABLE;
	bufMode = "line";
	break;
    case TCL_STDOUT:
	handleId = STD_OUTPUT_HANDLE;
	mode = TCL_WRITABLE;
	bufMode = "line";
	break;
    case TCL_STDERR:
	handleId = STD_ERROR_HANDLE;
	mode = TCL_WRITABLE;
	bufMode = "none";
	break;
    default:
	return 0;
	break;
    }

    handle = GetStdHandle(handleId);

    /*
     * Note that we need to check for 0 because Windows will return 0 if this
     * is not a console mode application, even though this is not a valid
     * handle.
     */

    if ((handle == INVALID_HANDLE_VALUE) || (handle == 0)) {
	return 1;
    }

    /*
     * Win2K BUG: GetStdHandle(STD_OUTPUT_HANDLE) can return what appears to
     * be a valid handle. See TclpGetDefaultStdChannel() for this change
     * implemented. We didn't change it here because GetFileType() [below]
     * will catch this with FILE_TYPE_UNKNOWN and appropriately return a value
     * of 1, anyways.
     *
     *    char dummyBuff[1];
     *    DWORD dummyWritten;
     *
     *    if ((type == TCL_STDOUT)
     *		&& !WriteFile(handle, dummyBuff, 0, &dummyWritten, NULL)) {
     *	     return 1;
     *    }
     */

    fileType = GetFileType(handle);

    /*
     * If the file is a character device, we need to try to figure out whether
     * it is a serial port, a console, or something else. We test for the
     * console case first because this is more common.
     */

    if (fileType == FILE_TYPE_CHAR) {
	dcb.DCBlength = sizeof( DCB ) ;
	if (!GetConsoleMode(handle, &consoleParams) &&
		!GetCommState(handle, &dcb)) {
	    /*
	     * Don't use a CHAR type channel for stdio, otherwise Tk runs into
	     * trouble with the MS DevStudio debugger.
	     */

	    return 1;
	}
    } else if (fileType == FILE_TYPE_UNKNOWN) {
	return 1;
    } else if (Tcl_GetStdChannel(type) == NULL) {
	return 1;
    }

    return 0;
}
#else
/*
 * Mac should always use a console channel, Unix should if it's trying to
 */

#define ShouldUseConsoleChannel(chan) (1)
#endif

/*
 *----------------------------------------------------------------------
 *
 * 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.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Creates the console channel and installs it as the standard channels.
 *
 *----------------------------------------------------------------------
 */

void
Tk_InitConsoleChannels(
    Tcl_Interp *interp)
{
    Tcl_Channel consoleChannel;

    /*
     * Ensure that we are getting the matching version of Tcl. This is really
     * only an issue when Tk is loaded dynamically.
     */

    if (Tcl_InitStubs(interp, TCL_VERSION, 1) == NULL) {
        return;
    }

    Tcl_MutexLock(&consoleMutex);
    if (!consoleInitialized) {

	consoleInitialized = 1;

	/*
	 * 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.
	 */

	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);
	}

	/*
	 * 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);
	}

	/*
	 * 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_MutexUnlock(&consoleMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * Tk_CreateConsoleWindow --
 *
 *	Initialize the console. This code actually creates a new application
 *	and associated interpreter. This effectivly hides the implementation
 *	from the main application.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	A new console it created.
 *
 *----------------------------------------------------------------------
 */

int
Tk_CreateConsoleWindow(
    Tcl_Interp *interp)		/* Interpreter to use for prompting. */
{
    Tcl_Interp *consoleInterp;
    ConsoleInfo *info;
    Tk_Window mainWindow = Tk_MainWindow(interp);
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
            Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
    static const char *initCmd = "source $tk_library/console.tcl";

    consoleInterp = Tcl_CreateInterp();
    if (consoleInterp == NULL) {
	goto error;
    }

    /*
     * Initialized Tcl and Tk.
     */

    if (Tcl_Init(consoleInterp) != TCL_OK) {
	goto error;
    }
    if (Tk_Init(consoleInterp) != TCL_OK) {
	goto error;
    }
    tsdPtr->gStdoutInterp = interp;

    /*
     * 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, NULL);
    Tcl_SetAssocData(interp, TK_CONSOLE_INFO_KEY, NULL, (ClientData) info);

    Tk_CreateEventHandler(mainWindow, StructureNotifyMask, ConsoleEventProc,
	    (ClientData) info);

    Tcl_Preserve((ClientData) consoleInterp);
    if (Tcl_Eval(consoleInterp, initCmd) == TCL_ERROR) {
	/*
	 * goto error; -- no problem for now...
	 */
	printf("Eval error: %s", consoleInterp->result);
    }
    Tcl_Release((ClientData) consoleInterp);
    return TCL_OK;

  error:
    if (consoleInterp != NULL) {
    	Tcl_DeleteInterp(consoleInterp);
    }
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * ConsoleOutput--
 *
 *	Writes the given output on the IO channel. Returns count of how many
 *	characters were actually written, and an error indication.
 *
 * Results:
 *	A count of how many characters were written is returned and an error
 *	indication is returned in an output argument.
 *
 * Side effects:
 *	Writes output on the actual channel.
 *
 *----------------------------------------------------------------------
 */

static int
ConsoleOutput(
    ClientData instanceData,	/* Indicates which device to use. */
    CONST char *buf,		/* The data buffer. */
    int toWrite,		/* How many bytes to write? */
    int *errorCode)		/* Where to store error code. */
{
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
            Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));

    *errorCode = 0;
    Tcl_SetErrno(0);

    if (tsdPtr->gStdoutInterp != NULL) {
	TkConsolePrint(tsdPtr->gStdoutInterp, (int) instanceData, buf,
                toWrite);
    }

    return toWrite;
}

/*
 *----------------------------------------------------------------------
 *
 * ConsoleInput --
 *
 *	Read input from the console. Not currently implemented.
 *
 * Results:
 *	Always returns EOF.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static int
ConsoleInput(
    ClientData instanceData,	/* Unused. */
    char *buf,			/* Where to store data read. */
    int bufSize,		/* How much space is available in the
				 * buffer? */
    int *errorCode)		/* Where to store error code. */
{
    return 0;			/* Always return EOF. */
}

/*
 *----------------------------------------------------------------------
 *
 * ConsoleClose --
 *
 *	Closes the IO channel.
 *
 * Results:
 *	Always returns 0 (success).
 *
 * Side effects:
 *	Frees the dummy file associated with the channel.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static int
ConsoleClose(
    ClientData instanceData,	/* Unused. */
    Tcl_Interp *interp)		/* Unused. */
{
    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
            Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
    tsdPtr->gStdoutInterp = NULL;
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * ConsoleWatch --
 *
 *	Called by the notifier to set up the console device so that events
 *	will be noticed. Since there are no events on the console, this
 *	routine just returns without doing anything.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static void
ConsoleWatch(
    ClientData instanceData,	/* Device ID for the channel. */
    int mask)			/* OR-ed combination of TCL_READABLE,
				 * TCL_WRITABLE and TCL_EXCEPTION, for the
				 * events we are interested in. */
{
}

/*
 *----------------------------------------------------------------------
 *
 * ConsoleHandle --
 *
 *	Invoked by the generic IO layer to get a handle from a channel.
 *	Because console channels are not devices, this function always fails.
 *
 * Results:
 *	Always returns TCL_ERROR.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
static int
ConsoleHandle(
    ClientData instanceData,	/* Device ID for the channel. */
    int direction,		/* TCL_READABLE or TCL_WRITABLE to indicate
				 * which direction of the channel is being
				 * requested. */
    ClientData *handlePtr)	/* Where to store handle */
{
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * ConsoleCmd --
 *
 *	The console command implements a Tcl interface to the various console
 *	options.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
ConsoleCmd(
    ClientData clientData,	/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int argc,			/* Number of arguments. */
    CONST char **argv)		/* Argument strings. */
{
    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 ...?\"", NULL);
	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]);
	}
	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),
		    NULL);
	} else {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " eval command\"", NULL);
	    result = TCL_ERROR;
	}
    } else {
	Tcl_AppendResult(interp, "bad option \"", argv[1],
		"\": should be hide, show, or title", NULL);
        result = TCL_ERROR;
    }
    Tcl_Release((ClientData) consoleInterp);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * InterpreterCmd --
 *
 *	This command allows the console interp to communicate with the main
 *	interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
InterpreterCmd(
    ClientData clientData,	/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int argc,			/* Number of arguments. */
    CONST char **argv)		/* Argument strings. */
{
    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 ...?\"", NULL);
	return TCL_ERROR;
    }

    c = argv[1][0];
    length = strlen(argv[1]);
    consoleInterp = info->consoleInterp;
    Tcl_Preserve((ClientData) consoleInterp);
    otherInterp = info->interp;
    Tcl_Preserve((ClientData) otherInterp);
    if ((c == 'e') && (strncmp(argv[1], "eval", length)) == 0) {
   	result = Tcl_GlobalEval(otherInterp, argv[2]);
    	Tcl_AppendResult(interp, otherInterp->result, 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, NULL);
    } else {
	Tcl_AppendResult(interp, "bad option \"", argv[1],
		"\": should be eval or record", NULL);
	result = TCL_ERROR;
    }
    Tcl_Release((ClientData) otherInterp);
    Tcl_Release((ClientData) consoleInterp);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * ConsoleDeleteProc --
 *
 *	If the console command is deleted we destroy the console window and
 *	all associated data structures.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	A new console it created.
 *
 *----------------------------------------------------------------------
 */

static void
ConsoleDeleteProc(
    ClientData clientData)
{
    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;
    }

    Tcl_DeleteInterp(info->consoleInterp);
    info->consoleInterp = NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * 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:
 *	Invokes the "::tk::ConsoleExit" command in the console interp.
 *
 *----------------------------------------------------------------------
 */

static void
ConsoleEventProc(
    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 == NULL) {
            return;
        }

	Tcl_Preserve((ClientData) consoleInterp);
	Tcl_Eval(consoleInterp, "::tk::ConsoleExit");
	Tcl_Release((ClientData) consoleInterp);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * 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.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
TkConsolePrint(
    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. */
{
    Tcl_DString command, output;
    ConsoleInfo *info;
    Tcl_Interp *consoleInterp;

    if (interp == NULL) {
	return;
    }

    info = (ConsoleInfo *) Tcl_GetAssocData(interp, TK_CONSOLE_INFO_KEY, NULL);
    if (info == NULL || info->consoleInterp == NULL) {
	return;
    }

    Tcl_DStringInit(&command);
    if (devId == TCL_STDERR) {
	Tcl_DStringAppend(&command, "::tk::ConsoleOutput stderr ", -1);
    } else {
	Tcl_DStringAppend(&command, "::tk::ConsoleOutput stdout ", -1);
    }

    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);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */