summaryrefslogtreecommitdiffstats
path: root/generic/tclMain.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclMain.c')
-rw-r--r--generic/tclMain.c260
1 files changed, 252 insertions, 8 deletions
diff --git a/generic/tclMain.c b/generic/tclMain.c
index 6e846c7..5089a93 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.c
@@ -5,11 +5,12 @@
*
* Copyright (c) 1988-1994 The Regents of the University of California.
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ * Copyright (c) 2000 Ajuba Solutions.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclMain.c,v 1.7 1999/12/12 02:26:42 hobbs Exp $
+ * RCS: @(#) $Id: tclMain.c,v 1.8 2000/11/03 18:46:12 hobbs Exp $
*/
#include "tcl.h"
@@ -42,7 +43,27 @@ extern char * strcpy _ANSI_ARGS_((char *dst, CONST char *src));
static char *tclStartupScriptFileName = NULL;
+static Tcl_MainLoopProc *mainLoopProc = NULL;
+typedef struct ThreadSpecificData {
+ Tcl_Interp *interp; /* Interpreter for this thread. */
+ Tcl_DString command; /* Used to assemble lines of terminal input
+ * into Tcl commands. */
+ Tcl_DString line; /* Used to read the next line from the
+ * terminal input. */
+ int tty; /* Non-zero means standard input is a
+ * terminal-like device. Zero means it's
+ * a file. */
+} ThreadSpecificData;
+Tcl_ThreadDataKey dataKey;
+
+/*
+ * Forward declarations for procedures defined later in this file.
+ */
+
+static void Prompt _ANSI_ARGS_((Tcl_Interp *interp, int partial));
+static void StdinProc _ANSI_ARGS_((ClientData clientData,
+ int mask));
/*
@@ -101,7 +122,7 @@ char *TclGetStartupScriptFileName()
*
* Results:
* None. This procedure never returns (it exits the process when
- * it's done.
+ * it's done).
*
* Side effects:
* This procedure initializes the Tcl world and then starts
@@ -124,14 +145,18 @@ Tcl_Main(argc, argv, appInitProc)
Tcl_Obj *resultPtr;
Tcl_Obj *commandPtr = NULL;
char buffer[1000], *args;
- int code, gotPartial, tty, length;
+ int code, gotPartial, length;
int exitCode = 0;
Tcl_Channel inChannel, outChannel, errChannel;
Tcl_Interp *interp;
Tcl_DString argString;
+ ThreadSpecificData *tsdPtr;
+
+ tsdPtr = (ThreadSpecificData *)
+ Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
Tcl_FindExecutable(argv[0]);
- interp = Tcl_CreateInterp();
+ tsdPtr->interp = interp = Tcl_CreateInterp();
#ifdef TCL_MEM_DEBUG
Tcl_InitMemory(interp);
#endif
@@ -170,9 +195,9 @@ Tcl_Main(argc, argv, appInitProc)
* Set the "tcl_interactive" variable.
*/
- tty = isatty(0);
+ tsdPtr->tty = isatty(0);
Tcl_SetVar(interp, "tcl_interactive",
- ((tclStartupScriptFileName == NULL) && tty) ? "1" : "0",
+ ((tclStartupScriptFileName == NULL) && tsdPtr->tty) ? "1" : "0",
TCL_GLOBAL_ONLY);
/*
@@ -235,7 +260,7 @@ Tcl_Main(argc, argv, appInitProc)
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
gotPartial = 0;
while (1) {
- if (tty) {
+ if (tsdPtr->tty) {
Tcl_Obj *promptCmdPtr;
promptCmdPtr = Tcl_GetVar2Ex(interp,
@@ -299,7 +324,7 @@ Tcl_Main(argc, argv, appInitProc)
Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
Tcl_WriteChars(errChannel, "\n", 1);
}
- } else if (tty) {
+ } else if (tsdPtr->tty) {
resultPtr = Tcl_GetObjResult(interp);
Tcl_GetStringFromObj(resultPtr, &length);
if ((length > 0) && outChannel) {
@@ -307,6 +332,27 @@ Tcl_Main(argc, argv, appInitProc)
Tcl_WriteChars(outChannel, "\n", 1);
}
}
+ if (mainLoopProc != NULL) {
+ /*
+ * If a main loop has been defined while running interactively,
+ * we want to start a fileevent based prompt by establishing a
+ * channel handler for stdin.
+ */
+
+ if (inChannel) {
+ Tcl_CreateChannelHandler(inChannel, TCL_READABLE, StdinProc,
+ (ClientData) inChannel);
+ }
+ if (tsdPtr->tty) {
+ Prompt(interp, 0);
+ }
+ Tcl_DStringInit(&tsdPtr->command);
+ Tcl_DStringInit(&tsdPtr->line);
+
+ mainLoopProc();
+ mainLoopProc = NULL;
+ break;
+ }
#ifdef TCL_MEM_DEBUG
if (tclMemDumpFileName != NULL) {
Tcl_DecrRefCount(commandPtr);
@@ -323,9 +369,207 @@ Tcl_Main(argc, argv, appInitProc)
*/
done:
+ if ((exitCode == 0) && (mainLoopProc != NULL)) {
+ /*
+ * If everything has gone OK so far, call the main loop proc,
+ * if it exists. Packages (like Tk) can set it to start processing
+ * events at this point.
+ */
+
+ mainLoopProc();
+ }
if (commandPtr != NULL) {
Tcl_DecrRefCount(commandPtr);
}
sprintf(buffer, "exit %d", exitCode);
Tcl_Eval(interp, buffer);
}
+
+/*
+ *---------------------------------------------------------------
+ *
+ * Tcl_SetMainLoop --
+ *
+ * Sets an alternative main loop procedure.
+ *
+ * Results:
+ * Returns the previously defined main loop procedure.
+ *
+ * Side effects:
+ * This procedure will be called before Tcl exits, allowing for
+ * the creation of an event loop.
+ *
+ *---------------------------------------------------------------
+ */
+
+void
+Tcl_SetMainLoop(Tcl_MainLoopProc *proc)
+{
+ mainLoopProc = proc;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * StdinProc --
+ *
+ * This procedure is invoked by the event dispatcher whenever
+ * standard input becomes readable. It grabs the next line of
+ * input characters, adds them to a command being assembled, and
+ * executes the command if it's complete.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Could be almost arbitrary, depending on the command that's
+ * typed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+static void
+StdinProc(clientData, mask)
+ ClientData clientData; /* Not used. */
+ int mask; /* Not used. */
+{
+ static int gotPartial = 0;
+ char *cmd;
+ int code, count;
+ Tcl_Channel chan = (Tcl_Channel) clientData;
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
+ Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
+ Tcl_Interp *interp = tsdPtr->interp;
+
+ count = Tcl_Gets(chan, &tsdPtr->line);
+
+ if (count < 0) {
+ if (!gotPartial) {
+ if (tsdPtr->tty) {
+ Tcl_Exit(0);
+ } else {
+ Tcl_DeleteChannelHandler(chan, StdinProc, (ClientData) chan);
+ }
+ return;
+ }
+ }
+
+ (void) Tcl_DStringAppend(&tsdPtr->command, Tcl_DStringValue(
+ &tsdPtr->line), -1);
+ cmd = Tcl_DStringAppend(&tsdPtr->command, "\n", -1);
+ Tcl_DStringFree(&tsdPtr->line);
+ if (!Tcl_CommandComplete(cmd)) {
+ gotPartial = 1;
+ goto prompt;
+ }
+ gotPartial = 0;
+
+ /*
+ * Disable the stdin channel handler while evaluating the command;
+ * otherwise if the command re-enters the event loop we might
+ * process commands from stdin before the current command is
+ * finished. Among other things, this will trash the text of the
+ * command being evaluated.
+ */
+
+ Tcl_CreateChannelHandler(chan, 0, StdinProc, (ClientData) chan);
+ code = Tcl_RecordAndEval(interp, cmd, TCL_EVAL_GLOBAL);
+
+ chan = Tcl_GetStdChannel(TCL_STDIN);
+ if (chan) {
+ Tcl_CreateChannelHandler(chan, TCL_READABLE, StdinProc,
+ (ClientData) chan);
+ }
+ Tcl_DStringFree(&tsdPtr->command);
+ if (Tcl_GetStringResult(interp)[0] != '\0') {
+ if ((code != TCL_OK) || (tsdPtr->tty)) {
+ chan = Tcl_GetStdChannel(TCL_STDOUT);
+ if (chan) {
+ Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
+ Tcl_WriteChars(chan, "\n", 1);
+ }
+ }
+ }
+
+ /*
+ * Output a prompt.
+ */
+
+ prompt:
+ if (tsdPtr->tty) {
+ Prompt(interp, gotPartial);
+ }
+ Tcl_ResetResult(interp);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Prompt --
+ *
+ * Issue a prompt on standard output, or invoke a script
+ * to issue the prompt.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * A prompt gets output, and a Tcl script may be evaluated
+ * in interp.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+Prompt(interp, partial)
+ Tcl_Interp *interp; /* Interpreter to use for prompting. */
+ int partial; /* Non-zero means there already
+ * exists a partial command, so use
+ * the secondary prompt. */
+{
+ char *promptCmd;
+ int code;
+ Tcl_Channel outChannel, errChannel;
+
+ promptCmd = Tcl_GetVar(interp,
+ partial ? "tcl_prompt2" : "tcl_prompt1", TCL_GLOBAL_ONLY);
+ if (promptCmd == NULL) {
+defaultPrompt:
+ if (!partial) {
+
+ /*
+ * We must check that outChannel is a real channel - it
+ * is possible that someone has transferred stdout out of
+ * this interpreter with "interp transfer".
+ */
+
+ outChannel = Tcl_GetChannel(interp, "stdout", NULL);
+ if (outChannel != (Tcl_Channel) NULL) {
+ Tcl_WriteChars(outChannel, "% ", 2);
+ }
+ }
+ } else {
+ code = Tcl_Eval(interp, promptCmd);
+ if (code != TCL_OK) {
+ Tcl_AddErrorInfo(interp,
+ "\n (script that generates prompt)");
+ /*
+ * We must check that errChannel is a real channel - it
+ * is possible that someone has transferred stderr out of
+ * this interpreter with "interp transfer".
+ */
+
+ errChannel = Tcl_GetChannel(interp, "stderr", NULL);
+ if (errChannel != (Tcl_Channel) NULL) {
+ Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
+ Tcl_WriteChars(errChannel, "\n", 1);
+ }
+ goto defaultPrompt;
+ }
+ }
+ outChannel = Tcl_GetChannel(interp, "stdout", NULL);
+ if (outChannel != (Tcl_Channel) NULL) {
+ Tcl_Flush(outChannel);
+ }
+}