generic/interface/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 "TclTk.license.terms" for information on usage and
 * redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * SCCS: @(#) tkConsole.c 1.51 97/04/25 16:52:39
 */

#include <tcl.h>
#include <utilities/ascConfig.h>
#include "tkConsole.h"

#ifdef ASC_USE_TK_CONSOLE

#ifndef __WIN32__
# include <tkInt.h>
#else
# include <X11/Xlib.h>
# include <tkIntXlibDecls.h>
# include <tk.h>
#endif

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

static Tcl_Interp *gStdoutInterp = NULL;

/*
 * Forward declarations for procedures defined later in this file:
 */

static int  ConsoleCmd _ANSI_ARGS_((ClientData clientData,
            Tcl_Interp *interp, int argc, char **argv));
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, char **argv));

static int  ConsoleInput _ANSI_ARGS_((ClientData instanceData,
            char *buf, int toRead, int *errorCode));
static int  ConsoleOutput _ANSI_ARGS_((ClientData instanceData,
            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     TkConsolePrint _ANSI_ARGS_((Tcl_Interp *interp,
            int devId, char *buffer, long size));
/*
 * 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. */
};

/*
 *----------------------------------------------------------------------
 *
 * TkConsoleCreate --
 *
 *  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
TkConsoleCreate()
{
    Tcl_Channel consoleChannel;

    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_SetStdChannel(consoleChannel, TCL_STDIN);
    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_SetStdChannel(consoleChannel, TCL_STDOUT);
    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_SetStdChannel(consoleChannel, TCL_STDERR);
}

/*
 *----------------------------------------------------------------------
 *
 * TkConsoleInit --
 *
 *  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
TkConsoleInit(interp)
    Tcl_Interp *interp;         /* Interpreter to use for prompting. */
{
    Tcl_Interp *consoleInterp;
    ConsoleInfo *info;
    Tk_Window mainWindow = Tk_MainWindow(interp);
#ifdef MAC_TCL
    static char initCmd[] = "source -rsrc {Console}";
#else
    static char initCmd[] = "source $tk_library/console.tcl";
#endif

    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;
    }
    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, (Tcl_CmdDeleteProc *) NULL);

    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(instanceData, buf, toWrite, errorCode)
    ClientData instanceData;        /* Indicates which device to use. */
    char *buf;              /* The data buffer. */
    int toWrite;            /* How many bytes to write? */
    int *errorCode;         /* Where to store error code. */
{
    *errorCode = 0;
    Tcl_SetErrno(0);

    if (gStdoutInterp != NULL) {
    TkConsolePrint(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(instanceData, buf, bufSize, errorCode)
    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(instanceData, interp)
    ClientData instanceData;    /* Unused. */
    Tcl_Interp *interp;     /* Unused. */
{
    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(instanceData, mask)
    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(instanceData, direction, handlePtr)
    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, interp, argc, argv)
    ClientData clientData;      /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int argc;               /* Number of arguments. */
    CONST84 char **argv;            /* Argument strings. */
{
    ConsoleInfo *info = (ConsoleInfo *) clientData;
    char c;
    int length;
    int result;
    Tcl_Interp *consoleInterp;

    if (argc < 2) {
    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
        " option ?arg arg ...?\"", (char *) 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(info->consoleInterp, "wm withdraw .");
    } else if ((c == 's') && (strncmp(argv[1], "show", length)) == 0) {
    Tcl_Eval(info->consoleInterp, "wm deiconify .");
    } else if ((c == 'e') && (strncmp(argv[1], "eval", length)) == 0) {
    if (argc == 3) {
        Tcl_Eval(info->consoleInterp, argv[2]);
    } else {
        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
            " eval command\"", (char *) NULL);
        return TCL_ERROR;
    }
    } else {
    Tcl_AppendResult(interp, "bad option \"", argv[1],
        "\": should be hide, show, or title",
        (char *) 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, interp, argc, argv)
    ClientData clientData;      /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int argc;               /* Number of arguments. */
    CONST84 char **argv;            /* Argument strings. */
{
    ConsoleInfo *info = (ConsoleInfo *) clientData;
    char c;
    int length;
    int result;
    Tcl_Interp *otherInterp;

    if (argc < 2) {
    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
        " option ?arg arg ...?\"", (char *) NULL);
    return TCL_ERROR;
    }

    c = argv[1][0];
    length = strlen(argv[1]);
    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, (char *) NULL);
    } else if ((c == 'r') && (strncmp(argv[1], "record", length)) == 0) {
    Tcl_RecordAndEval(otherInterp, argv[2], TCL_EVAL_GLOBAL);
    result = TCL_OK;
        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;
    }
    Tcl_Release((ClientData) otherInterp);
    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.
 *
 *----------------------------------------------------------------------
 */

void
ConsoleDeleteProc(clientData)
    ClientData clientData;
{
    ConsoleInfo *info = (ConsoleInfo *) clientData;

    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 "tkConsoleExit".
 *
 * Results:
 *  None.
 *
 * Side effects:
 *  Invokes the "tkConsoleExit" procedure in the console interp.
 *
 *----------------------------------------------------------------------
 */

static void
ConsoleEventProc(clientData, eventPtr)
    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;
        }
        Tcl_Preserve((ClientData) consoleInterp);
    Tcl_Eval(consoleInterp, "tkConsoleExit");
        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(interp, devId, buffer, size)
    Tcl_Interp *interp;     /* Main interpreter. */
    int devId;          /* TCL_STDOUT for stdout, TCL_STDERR for
                                 * stderr. */
    char *buffer;       /* Text buffer. */
    long size;          /* Size of text buffer. */
{
    Tcl_DString command, output;
    Tcl_CmdInfo cmdInfo;
    char *cmd;
    ConsoleInfo *info;
    Tcl_Interp *consoleInterp;
    int result;

    if (interp == NULL) {
    return;
    }

    if (devId == TCL_STDERR) {
    cmd = "tkConsoleOutput stderr ";
    } else {
    cmd = "tkConsoleOutput stdout ";
    }

    result = Tcl_GetCommandInfo(interp, "console", &cmdInfo);
    if (result == 0) {
    return;
    }
    info = (ConsoleInfo *) cmdInfo.clientData;

    Tcl_DStringInit(&output);
    Tcl_DStringAppend(&output, buffer, size);

    Tcl_DStringInit(&command);
    Tcl_DStringAppend(&command, cmd, strlen(cmd));
    Tcl_DStringAppendElement(&command, output.string);

    consoleInterp = info->consoleInterp;
    Tcl_Preserve((ClientData) consoleInterp);
    Tcl_Eval(consoleInterp, command.string);
    Tcl_Release((ClientData) consoleInterp);

    Tcl_DStringFree(&command);
    Tcl_DStringFree(&output);
}

#endif /* ASC_USE_TK_CONSOLE */
1	/*
2	* tkConsole.c --
3	*
4	* This file implements a Tcl console for systems that may not
5	* otherwise have access to a console. It uses the Text widget
6	* and provides special access via a console command.
7	*
8	* Copyright (c) 1995-1996 Sun Microsystems, Inc.
9	*
10	* See the file "TclTk.license.terms" for information on usage and
11	* redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
12	*
13	* SCCS: @(#) tkConsole.c 1.51 97/04/25 16:52:39
14	*/
15
16	#include <tcl.h>
17	#include <utilities/ascConfig.h>
18	#include "tkConsole.h"
19
20	#ifdef ASC_USE_TK_CONSOLE
21
22	#ifndef __WIN32__
23	# include <tkInt.h>
24	#else
25	# include <X11/Xlib.h>
26	# include <tkIntXlibDecls.h>
27	# include <tk.h>
28	#endif
29
30	/*
31	* A data structure of the following type holds information for each console
32	* which a handler (i.e. a Tcl command) has been defined for a particular
33	* top-level window.
34	*/
35
36	typedef struct ConsoleInfo {
37	Tcl_Interp consoleInterp; / Interpreter for the console. */
38	Tcl_Interp interp; / Interpreter to send console commands. */
39	} ConsoleInfo;
40
41	static Tcl_Interp *gStdoutInterp = NULL;
42
43	/*
44	* Forward declarations for procedures defined later in this file:
45	*/
46
47	static int ConsoleCmd _ANSI_ARGS_((ClientData clientData,
48	Tcl_Interp interp, int argc, char *argv));
49	static void ConsoleDeleteProc _ANSI_ARGS_((ClientData clientData));
50	static void ConsoleEventProc _ANSI_ARGS_((ClientData clientData,
51	XEvent *eventPtr));
52	static int InterpreterCmd _ANSI_ARGS_((ClientData clientData,
53	Tcl_Interp interp, int argc, char *argv));
54
55	static int ConsoleInput _ANSI_ARGS_((ClientData instanceData,
56	char buf, int toRead, int errorCode));
57	static int ConsoleOutput _ANSI_ARGS_((ClientData instanceData,
58	char buf, int toWrite, int errorCode));
59	static int ConsoleClose _ANSI_ARGS_((ClientData instanceData,
60	Tcl_Interp *interp));
61	static void ConsoleWatch _ANSI_ARGS_((ClientData instanceData,
62	int mask));
63	static int ConsoleHandle _ANSI_ARGS_((ClientData instanceData,
64	int direction, ClientData *handlePtr));
65	static void TkConsolePrint _ANSI_ARGS_((Tcl_Interp *interp,
66	int devId, char *buffer, long size));
67	/*
68	* This structure describes the channel type structure for file based IO:
69	*/
70
71	static Tcl_ChannelType consoleChannelType = {
72	"console", /* Type name. */
73	NULL, /* Always non-blocking.*/
74	ConsoleClose, /* Close proc. */
75	ConsoleInput, /* Input proc. */
76	ConsoleOutput, /* Output proc. */
77	NULL, /* Seek proc. */
78	NULL, /* Set option proc. */
79	NULL, /* Get option proc. */
80	ConsoleWatch, /* Watch for events on console. */
81	ConsoleHandle, /* Get a handle from the device. */
82	};
83
84	/*
85	*----------------------------------------------------------------------
86	*
87	* TkConsoleCreate --
88	*
89	* Create the console channels and install them as the standard
90	* channels. All I/O will be discarded until TkConsoleInit is
91	* called to attach the console to a text widget.
92	*
93	* Results:
94	* None.
95	*
96	* Side effects:
97	* Creates the console channel and installs it as the standard
98	* channels.
99	*
100	*----------------------------------------------------------------------
101	*/
102
103	void
104	TkConsoleCreate()
105	{
106	Tcl_Channel consoleChannel;
107
108	consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console0",
109	(ClientData) TCL_STDIN, TCL_READABLE);
110	if (consoleChannel != NULL) {
111	Tcl_SetChannelOption(NULL, consoleChannel, "-translation", "lf");
112	Tcl_SetChannelOption(NULL, consoleChannel, "-buffering", "none");
113	}
114	Tcl_SetStdChannel(consoleChannel, TCL_STDIN);
115	consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console1",
116	(ClientData) TCL_STDOUT, TCL_WRITABLE);
117	if (consoleChannel != NULL) {
118	Tcl_SetChannelOption(NULL, consoleChannel, "-translation", "lf");
119	Tcl_SetChannelOption(NULL, consoleChannel, "-buffering", "none");
120	}
121	Tcl_SetStdChannel(consoleChannel, TCL_STDOUT);
122	consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console2",
123	(ClientData) TCL_STDERR, TCL_WRITABLE);
124	if (consoleChannel != NULL) {
125	Tcl_SetChannelOption(NULL, consoleChannel, "-translation", "lf");
126	Tcl_SetChannelOption(NULL, consoleChannel, "-buffering", "none");
127	}
128	Tcl_SetStdChannel(consoleChannel, TCL_STDERR);
129	}
130
131	/*
132	*----------------------------------------------------------------------
133	*
134	* TkConsoleInit --
135	*
136	* Initialize the console. This code actually creates a new
137	* application and associated interpreter. This effectivly hides
138	* the implementation from the main application.
139	*
140	* Results:
141	* None.
142	*
143	* Side effects:
144	* A new console it created.
145	*
146	*----------------------------------------------------------------------
147	*/
148
149	int
150	TkConsoleInit(interp)
151	Tcl_Interp interp; / Interpreter to use for prompting. */
152	{
153	Tcl_Interp *consoleInterp;
154	ConsoleInfo *info;
155	Tk_Window mainWindow = Tk_MainWindow(interp);
156	#ifdef MAC_TCL
157	static char initCmd[] = "source -rsrc {Console}";
158	#else
159	static char initCmd[] = "source $tk_library/console.tcl";
160	#endif
161
162	consoleInterp = Tcl_CreateInterp();
163	if (consoleInterp == NULL) {
164	goto error;
165	}
166
167	/*
168	* Initialized Tcl and Tk.
169	*/
170
171	if (Tcl_Init(consoleInterp) != TCL_OK) {
172	goto error;
173	}
174	if (Tk_Init(consoleInterp) != TCL_OK) {
175	goto error;
176	}
177	gStdoutInterp = interp;
178
179	/*
180	* Add console commands to the interp
181	*/
182	info = (ConsoleInfo *) ckalloc(sizeof(ConsoleInfo));
183	info->interp = interp;
184	info->consoleInterp = consoleInterp;
185	Tcl_CreateCommand(interp, "console", ConsoleCmd, (ClientData) info,
186	(Tcl_CmdDeleteProc *) ConsoleDeleteProc);
187	Tcl_CreateCommand(consoleInterp, "consoleinterp", InterpreterCmd,
188	(ClientData) info, (Tcl_CmdDeleteProc *) NULL);
189
190	Tk_CreateEventHandler(mainWindow, StructureNotifyMask, ConsoleEventProc,
191	(ClientData) info);
192
193	Tcl_Preserve((ClientData) consoleInterp);
194	if (Tcl_Eval(consoleInterp, initCmd) == TCL_ERROR) {
195	/* goto error; -- no problem for now... */
196	printf("Eval error: %s", consoleInterp->result);
197	}
198	Tcl_Release((ClientData) consoleInterp);
199	return TCL_OK;
200
201	error:
202	if (consoleInterp != NULL) {
203	Tcl_DeleteInterp(consoleInterp);
204	}
205	return TCL_ERROR;
206	}
207
208	/*
209	*----------------------------------------------------------------------
210	*
211	* ConsoleOutput--
212	*
213	* Writes the given output on the IO channel. Returns count of how
214	* many characters were actually written, and an error indication.
215	*
216	* Results:
217	* A count of how many characters were written is returned and an
218	* error indication is returned in an output argument.
219	*
220	* Side effects:
221	* Writes output on the actual channel.
222	*
223	*----------------------------------------------------------------------
224	*/
225
226	static int
227	ConsoleOutput(instanceData, buf, toWrite, errorCode)
228	ClientData instanceData; /* Indicates which device to use. */
229	char buf; / The data buffer. */
230	int toWrite; /* How many bytes to write? */
231	int errorCode; / Where to store error code. */
232	{
233	*errorCode = 0;
234	Tcl_SetErrno(0);
235
236	if (gStdoutInterp != NULL) {
237	TkConsolePrint(gStdoutInterp, (int) instanceData, buf, toWrite);
238	}
239
240	return toWrite;
241	}
242
243	/*
244	*----------------------------------------------------------------------
245	*
246	* ConsoleInput --
247	*
248	* Read input from the console. Not currently implemented.
249	*
250	* Results:
251	* Always returns EOF.
252	*
253	* Side effects:
254	* None.
255	*
256	*----------------------------------------------------------------------
257	*/
258
259	/* ARGSUSED */
260	static int
261	ConsoleInput(instanceData, buf, bufSize, errorCode)
262	ClientData instanceData; /* Unused. */
263	char buf; / Where to store data read. */
264	int bufSize; /* How much space is available
265	* in the buffer? */
266	int errorCode; / Where to store error code. */
267	{
268	return 0; /* Always return EOF. */
269	}
270
271	/*
272	*----------------------------------------------------------------------
273	*
274	* ConsoleClose --
275	*
276	* Closes the IO channel.
277	*
278	* Results:
279	* Always returns 0 (success).
280	*
281	* Side effects:
282	* Frees the dummy file associated with the channel.
283	*
284	*----------------------------------------------------------------------
285	*/
286
287	/* ARGSUSED */
288	static int
289	ConsoleClose(instanceData, interp)
290	ClientData instanceData; /* Unused. */
291	Tcl_Interp interp; / Unused. */
292	{
293	return 0;
294	}
295
296	/*
297	*----------------------------------------------------------------------
298	*
299	* ConsoleWatch --
300	*
301	* Called by the notifier to set up the console device so that
302	* events will be noticed. Since there are no events on the
303	* console, this routine just returns without doing anything.
304	*
305	* Results:
306	* None.
307	*
308	* Side effects:
309	* None.
310	*
311	*----------------------------------------------------------------------
312	*/
313
314	/* ARGSUSED */
315	static void
316	ConsoleWatch(instanceData, mask)
317	ClientData instanceData; /* Device ID for the channel. */
318	int mask; /* OR-ed combination of
319	* TCL_READABLE, TCL_WRITABLE and
320	* TCL_EXCEPTION, for the events
321	* we are interested in. */
322	{
323	}
324
325	/*
326	*----------------------------------------------------------------------
327	*
328	* ConsoleHandle --
329	*
330	* Invoked by the generic IO layer to get a handle from a channel.
331	* Because console channels are not devices, this function always
332	* fails.
333	*
334	* Results:
335	* Always returns TCL_ERROR.
336	*
337	* Side effects:
338	* None.
339	*
340	*----------------------------------------------------------------------
341	*/
342
343	/* ARGSUSED */
344	static int
345	ConsoleHandle(instanceData, direction, handlePtr)
346	ClientData instanceData; /* Device ID for the channel. */
347	int direction; /* TCL_READABLE or TCL_WRITABLE to indicate
348	* which direction of the channel is being
349	* requested. */
350	ClientData handlePtr; / Where to store handle */
351	{
352	return TCL_ERROR;
353	}
354
355	/*
356	*----------------------------------------------------------------------
357	*
358	* ConsoleCmd --
359	*
360	* The console command implements a Tcl interface to the various console
361	* options.
362	*
363	* Results:
364	* None.
365	*
366	* Side effects:
367	* None.
368	*
369	*----------------------------------------------------------------------
370	*/
371
372	static int
373	ConsoleCmd(clientData, interp, argc, argv)
374	ClientData clientData; /* Not used. */
375	Tcl_Interp interp; / Current interpreter. */
376	int argc; /* Number of arguments. */
377	CONST84 char *argv; / Argument strings. */
378	{
379	ConsoleInfo info = (ConsoleInfo ) clientData;
380	char c;
381	int length;
382	int result;
383	Tcl_Interp *consoleInterp;
384
385	if (argc < 2) {
386	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
387	" option ?arg arg ...?\"", (char *) NULL);
388	return TCL_ERROR;
389	}
390
391	c = argv[1][0];
392	length = strlen(argv[1]);
393	result = TCL_OK;
394	consoleInterp = info->consoleInterp;
395	Tcl_Preserve((ClientData) consoleInterp);
396	if ((c == 't') && (strncmp(argv[1], "title", length)) == 0) {
397	Tcl_DString dString;
398
399	Tcl_DStringInit(&dString);
400	Tcl_DStringAppend(&dString, "wm title . ", -1);
401	if (argc == 3) {
402	Tcl_DStringAppendElement(&dString, argv[2]);
403	}
404	Tcl_Eval(consoleInterp, Tcl_DStringValue(&dString));
405	Tcl_DStringFree(&dString);
406	} else if ((c == 'h') && (strncmp(argv[1], "hide", length)) == 0) {
407	Tcl_Eval(info->consoleInterp, "wm withdraw .");
408	} else if ((c == 's') && (strncmp(argv[1], "show", length)) == 0) {
409	Tcl_Eval(info->consoleInterp, "wm deiconify .");
410	} else if ((c == 'e') && (strncmp(argv[1], "eval", length)) == 0) {
411	if (argc == 3) {
412	Tcl_Eval(info->consoleInterp, argv[2]);
413	} else {
414	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
415	" eval command\"", (char *) NULL);
416	return TCL_ERROR;
417	}
418	} else {
419	Tcl_AppendResult(interp, "bad option \"", argv[1],
420	"\": should be hide, show, or title",
421	(char *) NULL);
422	result = TCL_ERROR;
423	}
424	Tcl_Release((ClientData) consoleInterp);
425	return result;
426	}
427
428	/*
429	*----------------------------------------------------------------------
430	*
431	* InterpreterCmd --
432	*
433	* This command allows the console interp to communicate with the
434	* main interpreter.
435	*
436	* Results:
437	* None.
438	*
439	* Side effects:
440	* None.
441	*
442	*----------------------------------------------------------------------
443	*/
444
445	static int
446	InterpreterCmd(clientData, interp, argc, argv)
447	ClientData clientData; /* Not used. */
448	Tcl_Interp interp; / Current interpreter. */
449	int argc; /* Number of arguments. */
450	CONST84 char *argv; / Argument strings. */
451	{
452	ConsoleInfo info = (ConsoleInfo ) clientData;
453	char c;
454	int length;
455	int result;
456	Tcl_Interp *otherInterp;
457
458	if (argc < 2) {
459	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
460	" option ?arg arg ...?\"", (char *) NULL);
461	return TCL_ERROR;
462	}
463
464	c = argv[1][0];
465	length = strlen(argv[1]);
466	otherInterp = info->interp;
467	Tcl_Preserve((ClientData) otherInterp);
468	if ((c == 'e') && (strncmp(argv[1], "eval", length)) == 0) {
469	result = Tcl_GlobalEval(otherInterp, argv[2]);
470	Tcl_AppendResult(interp, otherInterp->result, (char *) NULL);
471	} else if ((c == 'r') && (strncmp(argv[1], "record", length)) == 0) {
472	Tcl_RecordAndEval(otherInterp, argv[2], TCL_EVAL_GLOBAL);
473	result = TCL_OK;
474	Tcl_AppendResult(interp, otherInterp->result, (char *) NULL);
475	} else {
476	Tcl_AppendResult(interp, "bad option \"", argv[1],
477	"\": should be eval or record",
478	(char *) NULL);
479	result = TCL_ERROR;
480	}
481	Tcl_Release((ClientData) otherInterp);
482	return result;
483	}
484
485	/*
486	*----------------------------------------------------------------------
487	*
488	* ConsoleDeleteProc --
489	*
490	* If the console command is deleted we destroy the console window
491	* and all associated data structures.
492	*
493	* Results:
494	* None.
495	*
496	* Side effects:
497	* A new console it created.
498	*
499	*----------------------------------------------------------------------
500	*/
501
502	void
503	ConsoleDeleteProc(clientData)
504	ClientData clientData;
505	{
506	ConsoleInfo info = (ConsoleInfo ) clientData;
507
508	Tcl_DeleteInterp(info->consoleInterp);
509	info->consoleInterp = NULL;
510	}
511
512	/*
513	*----------------------------------------------------------------------
514	*
515	* ConsoleEventProc --
516	*
517	* This event procedure is registered on the main window of the
518	* slave interpreter. If the user or a running script causes the
519	* main window to be destroyed, then we need to inform the console
520	* interpreter by invoking "tkConsoleExit".
521	*
522	* Results:
523	* None.
524	*
525	* Side effects:
526	* Invokes the "tkConsoleExit" procedure in the console interp.
527	*
528	*----------------------------------------------------------------------
529	*/
530
531	static void
532	ConsoleEventProc(clientData, eventPtr)
533	ClientData clientData;
534	XEvent *eventPtr;
535	{
536	ConsoleInfo info = (ConsoleInfo ) clientData;
537	Tcl_Interp *consoleInterp;
538
539	if (eventPtr->type == DestroyNotify) {
540	consoleInterp = info->consoleInterp;
541
542	/*
543	* It is possible that the console interpreter itself has
544	* already been deleted. In that case the consoleInterp
545	* field will be set to NULL. If the interpreter is already
546	* gone, we do not have to do any work here.
547	*/
548
549	if (consoleInterp == (Tcl_Interp *) NULL) {
550	return;
551	}
552	Tcl_Preserve((ClientData) consoleInterp);
553	Tcl_Eval(consoleInterp, "tkConsoleExit");
554	Tcl_Release((ClientData) consoleInterp);
555	}
556	}
557
558	/*
559	*----------------------------------------------------------------------
560	*
561	* TkConsolePrint --
562	*
563	* Prints to the give text to the console. Given the main interp
564	* this functions find the appropiate console interp and forwards
565	* the text to be added to that console.
566	*
567	* Results:
568	* None.
569	*
570	* Side effects:
571	* None.
572	*
573	*----------------------------------------------------------------------
574	*/
575
576	void
577	TkConsolePrint(interp, devId, buffer, size)
578	Tcl_Interp interp; / Main interpreter. */
579	int devId; /* TCL_STDOUT for stdout, TCL_STDERR for
580	* stderr. */
581	char buffer; / Text buffer. */
582	long size; /* Size of text buffer. */
583	{
584	Tcl_DString command, output;
585	Tcl_CmdInfo cmdInfo;
586	char *cmd;
587	ConsoleInfo *info;
588	Tcl_Interp *consoleInterp;
589	int result;
590
591	if (interp == NULL) {
592	return;
593	}
594
595	if (devId == TCL_STDERR) {
596	cmd = "tkConsoleOutput stderr ";
597	} else {
598	cmd = "tkConsoleOutput stdout ";
599	}
600
601	result = Tcl_GetCommandInfo(interp, "console", &cmdInfo);
602	if (result == 0) {
603	return;
604	}
605	info = (ConsoleInfo *) cmdInfo.clientData;
606
607	Tcl_DStringInit(&output);
608	Tcl_DStringAppend(&output, buffer, size);
609
610	Tcl_DStringInit(&command);
611	Tcl_DStringAppend(&command, cmd, strlen(cmd));
612	Tcl_DStringAppendElement(&command, output.string);
613
614	consoleInterp = info->consoleInterp;
615	Tcl_Preserve((ClientData) consoleInterp);
616	Tcl_Eval(consoleInterp, command.string);
617	Tcl_Release((ClientData) consoleInterp);
618
619	Tcl_DStringFree(&command);
620	Tcl_DStringFree(&output);
621	}
622
623	#endif /* ASC_USE_TK_CONSOLE */