* generic/tclMain.c (Tcl_Main): Corrected flaw that required

        * tests/main.test: (Tcl_Main-4.5):      processing of one interactive
        command before passing control to the loop routine registered with
        Tcl_SetMainLoop() [Bug 1481986].


FossilOrigin-Name: aedf5e48e961a866afd44b72035cf3e08711d837

3 files changed, 140 insertions, 112 deletions

diff --git a/ChangeLog b/ChangeLog
index 72580e0..64c44f3 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2006-05-05  Don Porter  <dgp@users.sourceforge.net>
+
+        * generic/tclMain.c (Tcl_Main):         Corrected flaw that required
+        * tests/main.test: (Tcl_Main-4.5):      processing of one interactive
+        command before passing control to the loop routine registered with
+        Tcl_SetMainLoop() [Bug 1481986].
+
 2006-05-04  Don Porter  <dgp@users.sourceforge.net>
 
         * README:               Bump version number to 8.5a5
diff --git a/generic/tclMain.c b/generic/tclMain.c
index 7961d0f..c3a75ef 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.c
@@ -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: tclMain.c,v 1.35 2005/11/01 15:30:52 dkf Exp $
+ * RCS: @(#) $Id: tclMain.c,v 1.36 2006/05/05 18:09:47 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -487,85 +487,85 @@ Tcl_Main(
     inChannel = Tcl_GetStdChannel(TCL_STDIN);
     outChannel = Tcl_GetStdChannel(TCL_STDOUT);
     while ((inChannel != (Tcl_Channel) NULL) && !Tcl_InterpDeleted(interp)) {
-	if (tty) {
-	    Prompt(interp, &prompt);
-	    if (Tcl_InterpDeleted(interp)) {
-		break;
-	    }
-	    if (Tcl_LimitExceeded(interp)) {
-		break;
+	if (mainLoopProc == NULL) {
+	    if (tty) {
+		Prompt(interp, &prompt);
+		if (Tcl_InterpDeleted(interp)) {
+		    break;
+		}
+		if (Tcl_LimitExceeded(interp)) {
+		    break;
+		}
+		inChannel = Tcl_GetStdChannel(TCL_STDIN);
+		if (inChannel == (Tcl_Channel) NULL) {
+		    break;
+		}
 	    }
-	    inChannel = Tcl_GetStdChannel(TCL_STDIN);
-	    if (inChannel == (Tcl_Channel) NULL) {
-		break;
+	    if (Tcl_IsShared(commandPtr)) {
+		Tcl_DecrRefCount(commandPtr);
+		commandPtr = Tcl_DuplicateObj(commandPtr);
+		Tcl_IncrRefCount(commandPtr);
 	    }
-	}
-	if (Tcl_IsShared(commandPtr)) {
-	    Tcl_DecrRefCount(commandPtr);
-	    commandPtr = Tcl_DuplicateObj(commandPtr);
-	    Tcl_IncrRefCount(commandPtr);
-	}
-	length = Tcl_GetsObj(inChannel, commandPtr);
-	if (length < 0) {
-	    if (Tcl_InputBlocked(inChannel)) {
+	    length = Tcl_GetsObj(inChannel, commandPtr);
+	    if (length < 0) {
+		if (Tcl_InputBlocked(inChannel)) {
+		    /*
+		     * This can only happen if stdin has been set to
+		     * non-blocking.  In that case cycle back and try again.
+		     * This sets up a tight polling loop (since we have no
+		     * event loop running). If this causes bad CPU hogging,
+		     * we might try toggling the blocking on stdin instead.
+		     */
+
+		    continue;
+		}
+
 		/*
-		 * This can only happen if stdin has been set to non-blocking.
-		 * In that case cycle back and try again. This sets up a tight
-		 * polling loop (since we have no event loop running). If this
-		 * causes bad CPU hogging, we might try toggling the blocking
-		 * on stdin instead.
+		 * Either EOF, or an error on stdin; we're done
 		 */
 
-		continue;
+		break;
 	    }
 
-	    /*
-	     * Either EOF, or an error on stdin; we're done
-	     */
-
-	    break;
-	}
-
-	if (!TclObjCommandComplete(commandPtr)) {
-	    /*
-	     * Add the newline removed by Tcl_GetsObj back to the string.
-	     */
+	    if (!TclObjCommandComplete(commandPtr)) {
+		/*
+		 * Add the newline removed by Tcl_GetsObj back to the string.
+		 */
 
-	    if (Tcl_IsShared(commandPtr)) {
-		Tcl_DecrRefCount(commandPtr);
-		commandPtr = Tcl_DuplicateObj(commandPtr);
-		Tcl_IncrRefCount(commandPtr);
+		if (Tcl_IsShared(commandPtr)) {
+		    Tcl_DecrRefCount(commandPtr);
+		    commandPtr = Tcl_DuplicateObj(commandPtr);
+		    Tcl_IncrRefCount(commandPtr);
+		}
+		Tcl_AppendToObj(commandPtr, "\n", 1);
+		prompt = PROMPT_CONTINUE;
+		continue;
 	    }
-	    Tcl_AppendToObj(commandPtr, "\n", 1);
-	    prompt = PROMPT_CONTINUE;
-	    continue;
-	}
 
-	prompt = PROMPT_START;
-	code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL);
-	inChannel = Tcl_GetStdChannel(TCL_STDIN);
-	outChannel = Tcl_GetStdChannel(TCL_STDOUT);
-	errChannel = Tcl_GetStdChannel(TCL_STDERR);
-	Tcl_DecrRefCount(commandPtr);
-	commandPtr = Tcl_NewObj();
-	Tcl_IncrRefCount(commandPtr);
-	if (code != TCL_OK) {
-	    if (errChannel) {
-		Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
-		Tcl_WriteChars(errChannel, "\n", 1);
-	    }
-	} else if (tty) {
-	    resultPtr = Tcl_GetObjResult(interp);
-	    Tcl_IncrRefCount(resultPtr);
-	    Tcl_GetStringFromObj(resultPtr, &length);
-	    if ((length > 0) && outChannel) {
-		Tcl_WriteObj(outChannel, resultPtr);
-		Tcl_WriteChars(outChannel, "\n", 1);
+	    prompt = PROMPT_START;
+	    code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL);
+	    inChannel = Tcl_GetStdChannel(TCL_STDIN);
+	    outChannel = Tcl_GetStdChannel(TCL_STDOUT);
+	    errChannel = Tcl_GetStdChannel(TCL_STDERR);
+	    Tcl_DecrRefCount(commandPtr);
+	    commandPtr = Tcl_NewObj();
+	    Tcl_IncrRefCount(commandPtr);
+	    if (code != TCL_OK) {
+		if (errChannel) {
+		    Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
+		    Tcl_WriteChars(errChannel, "\n", 1);
+		}
+ 	    } else if (tty) {
+		resultPtr = Tcl_GetObjResult(interp);
+		Tcl_IncrRefCount(resultPtr);
+		Tcl_GetStringFromObj(resultPtr, &length);
+		if ((length > 0) && outChannel) {
+		    Tcl_WriteObj(outChannel, resultPtr);
+		    Tcl_WriteChars(outChannel, "\n", 1);
+		}
+		Tcl_DecrRefCount(resultPtr);
 	    }
-	    Tcl_DecrRefCount(resultPtr);
-	}
-
-	if (mainLoopProc != NULL) {
+	} else {	/* (mainLoopProc != NULL) */
 	    /*
 	     * If a main loop has been defined while running interactively, we
 	     * want to start a fileevent based prompt by establishing a
@@ -635,55 +635,55 @@ Tcl_Main(
 	 * 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)();
-	mainLoopProc = NULL;
-    }
-    if (commandPtr != NULL) {
-	Tcl_DecrRefCount(commandPtr);
-    }
+		(*mainLoopProc)();
+		mainLoopProc = NULL;
+	    }
+	    if (commandPtr != NULL) {
+		Tcl_DecrRefCount(commandPtr);
+	    }
 
-    /*
-     * Rather than calling exit, invoke the "exit" command so that users can
-     * replace "exit" with some other command to do additional cleanup on
-     * exit. The Tcl_EvalObjEx call should never return.
-     */
+	    /*
+	     * Rather than calling exit, invoke the "exit" command so that users can
+	     * replace "exit" with some other command to do additional cleanup on
+	     * exit. The Tcl_EvalObjEx call should never return.
+	     */
 
-    if (!Tcl_InterpDeleted(interp)) {
-	if (!Tcl_LimitExceeded(interp)) {
-	    Tcl_Obj *cmd = Tcl_NewObj();
-	    TclObjPrintf(NULL, cmd, "exit %d", exitCode);
-	    Tcl_IncrRefCount(cmd);
-	    Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL);
-	    Tcl_DecrRefCount(cmd);
-	}
+	    if (!Tcl_InterpDeleted(interp)) {
+		if (!Tcl_LimitExceeded(interp)) {
+		    Tcl_Obj *cmd = Tcl_NewObj();
+		    TclObjPrintf(NULL, cmd, "exit %d", exitCode);
+		    Tcl_IncrRefCount(cmd);
+		    Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL);
+		    Tcl_DecrRefCount(cmd);
+		}
 
-	/*
-	 * If Tcl_EvalObjEx returns, trying to eval [exit], something unusual
-	 * is happening. Maybe interp has been deleted; maybe [exit] was
-	 * redefined, maybe we've blown up because of an exceeded limit. We
-	 * still want to cleanup and exit.
-	 */
+		/*
+		 * If Tcl_EvalObjEx returns, trying to eval [exit], something unusual
+		 * is happening. Maybe interp has been deleted; maybe [exit] was
+		 * redefined, maybe we've blown up because of an exceeded limit. We
+		 * still want to cleanup and exit.
+		 */
 
-	if (!Tcl_InterpDeleted(interp)) {
-	    Tcl_DeleteInterp(interp);
-	}
-    }
-    Tcl_SetStartupScript(NULL, NULL);
+		if (!Tcl_InterpDeleted(interp)) {
+		    Tcl_DeleteInterp(interp);
+		}
+	    }
+	    Tcl_SetStartupScript(NULL, NULL);
 
-    /*
-     * If we get here, the master interp has been deleted. Allow its
-     * destruction with the last matching Tcl_Release.
-     */
+	    /*
+	     * If we get here, the master interp has been deleted. Allow its
+	     * destruction with the last matching Tcl_Release.
+	     */
 
-    Tcl_Release((ClientData) interp);
-    Tcl_Exit(exitCode);
-}
-
-/*
- *---------------------------------------------------------------
- *
+	    Tcl_Release((ClientData) interp);
+	    Tcl_Exit(exitCode);
+	}
+	
+	/*
+	 *---------------------------------------------------------------
+	 *
  * Tcl_SetMainLoop --
  *
  *	Sets an alternative main loop function.
diff --git a/tests/main.test b/tests/main.test
index 5eab892..689d9f0 100644
--- a/tests/main.test
+++ b/tests/main.test
@@ -1,6 +1,6 @@
 # This file contains a collection of tests for generic/tclMain.c.
 #
-# RCS: @(#) $Id: main.test,v 1.18 2006/03/21 11:12:29 dkf Exp $
+# RCS: @(#) $Id: main.test,v 1.19 2006/05/05 18:09:47 dgp Exp $
 
 if {[catch {package require tcltest 2.0.2}]} {
     puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
@@ -557,6 +557,27 @@ namespace eval ::tcl::test::main {
     } -result "application-specific initialization failed:\
 	\nIn script\nExit MainLoop\nIn exit\neven 0\n"
 
+    test Tcl_Main-4.5 {
+        Tcl_Main: Bug 1481986
+    } -constraints {
+        exec Tcltest
+    } -setup {
+        set rc [makeFile {
+                testsetmainloop
+                after 0 {puts "Event callback"}
+        } rc]
+    } -body {
+        set f [open "|[list [interpreter] -appinitprocsetrcfile $rc]" w+]
+        after 1000
+        type $f {puts {Interactive output}
+            exit
+        }
+        read $f
+    } -cleanup {
+        catch {close $f}
+        removeFile rc
+    } -result "Event callback\nInteractive output\n"
+
     # Tests Tcl_Main-5.*: interactive operations
 
     test Tcl_Main-5.1 {