* generic/tclStubInit.c:

	* generic/tclDecls.h:
	* generic/tcl.decls: added Tcl_SetMainLoop proc that allows people
	to set a main loop that will run for tclsh.
	* generic/tcl.h: added Tcl_MainLoopProc typedef
	* generic/tclMain.c (Tcl_SetMainLoop, StdinProc, Prompt): new
	StdinProc and Prompt static procs and Tcl_SetMainLoop stubs proc.
	The first two handle a fileevent based prompt (taken from
	tkMain.c).  Tcl_SetMainLoop enables the interactive setting of a
	main loop procedure.  This enables Tk to be a loadable package.

5 files changed, 271 insertions, 18 deletions

diff --git a/generic/tcl.decls b/generic/tcl.decls
index 47643d4..28905ca 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -10,7 +10,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 # 
-# RCS: @(#) $Id: tcl.decls,v 1.41 2000/09/28 06:38:19 hobbs Exp $
+# RCS: @(#) $Id: tcl.decls,v 1.42 2000/11/03 18:46:10 hobbs Exp $
 
 library tcl
 
@@ -992,9 +992,13 @@ declare 282 generic {
 declare 283 generic {
     Tcl_Channel Tcl_GetStackedChannel(Tcl_Channel chan)
 }
+
+# 284 was reserved, but added in 8.4a2
+declare 284 generic {
+    void Tcl_SetMainLoop(Tcl_MainLoopProc *proc)
+}
+
 # Reserved for future use (8.0.x vs. 8.1)
-#  declare 284 generic {
-#  }
 #  declare 285 generic {
 #  }
 
diff --git a/generic/tcl.h b/generic/tcl.h
index 9349b15..95eece8 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -12,7 +12,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tcl.h,v 1.82 2000/10/19 18:00:56 jenn Exp $
+ * RCS: @(#) $Id: tcl.h,v 1.83 2000/11/03 18:46:10 hobbs Exp $
  */
 
 #ifndef _TCL
@@ -609,6 +609,7 @@ typedef void (Tcl_CommandTraceProc) _ANSI_ARGS_((ClientData clientData,
 typedef void (Tcl_CreateFileHandlerProc) _ANSI_ARGS_((int fd, int mask,
 	Tcl_FileProc *proc, ClientData clientData));
 typedef void (Tcl_DeleteFileHandlerProc) _ANSI_ARGS_((int fd));
+typedef void (Tcl_MainLoopProc) _ANSI_ARGS_((void));
 
 /*
  * The following structure represents a type of object, which is a
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 0656d76..743cef2 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -8,7 +8,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclDecls.h,v 1.42 2000/09/28 06:38:19 hobbs Exp $
+ * RCS: @(#) $Id: tclDecls.h,v 1.43 2000/11/03 18:46:11 hobbs Exp $
  */
 
 #ifndef _TCLDECLS
@@ -913,7 +913,8 @@ EXTERN int		Tcl_UnstackChannel _ANSI_ARGS_((Tcl_Interp * interp,
 				Tcl_Channel chan));
 /* 283 */
 EXTERN Tcl_Channel	Tcl_GetStackedChannel _ANSI_ARGS_((Tcl_Channel chan));
-/* Slot 284 is reserved */
+/* 284 */
+EXTERN void		Tcl_SetMainLoop _ANSI_ARGS_((Tcl_MainLoopProc * proc));
 /* Slot 285 is reserved */
 /* 286 */
 EXTERN void		Tcl_AppendObjToObj _ANSI_ARGS_((Tcl_Obj * objPtr, 
@@ -1700,7 +1701,7 @@ typedef struct TclStubs {
     Tcl_Channel (*tcl_StackChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_ChannelType * typePtr, ClientData instanceData, int mask, Tcl_Channel prevChan)); /* 281 */
     int (*tcl_UnstackChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 282 */
     Tcl_Channel (*tcl_GetStackedChannel) _ANSI_ARGS_((Tcl_Channel chan)); /* 283 */
-    void *reserved284;
+    void (*tcl_SetMainLoop) _ANSI_ARGS_((Tcl_MainLoopProc * proc)); /* 284 */
     void *reserved285;
     void (*tcl_AppendObjToObj) _ANSI_ARGS_((Tcl_Obj * objPtr, Tcl_Obj * appendObjPtr)); /* 286 */
     Tcl_Encoding (*tcl_CreateEncoding) _ANSI_ARGS_((Tcl_EncodingType * typePtr)); /* 287 */
@@ -3036,7 +3037,10 @@ extern TclStubs *tclStubsPtr;
 #define Tcl_GetStackedChannel \
 	(tclStubsPtr->tcl_GetStackedChannel) /* 283 */
 #endif
-/* Slot 284 is reserved */
+#ifndef Tcl_SetMainLoop
+#define Tcl_SetMainLoop \
+	(tclStubsPtr->tcl_SetMainLoop) /* 284 */
+#endif
 /* Slot 285 is reserved */
 #ifndef Tcl_AppendObjToObj
 #define Tcl_AppendObjToObj \
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);
+    }
+}
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index c716732..263e2a8 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -8,7 +8,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclStubInit.c,v 1.45 2000/09/28 06:38:22 hobbs Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.46 2000/11/03 18:46:12 hobbs Exp $
  */
 
 #include "tclInt.h"
@@ -687,7 +687,7 @@ TclStubs tclStubs = {
     Tcl_StackChannel, /* 281 */
     Tcl_UnstackChannel, /* 282 */
     Tcl_GetStackedChannel, /* 283 */
-    NULL, /* 284 */
+    Tcl_SetMainLoop, /* 284 */
     NULL, /* 285 */
     Tcl_AppendObjToObj, /* 286 */
     Tcl_CreateEncoding, /* 287 */