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 "interface/tkConsole.h"

#ifdef ASC_USE_TK_CONSOLE

#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;

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