summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2006-05-05 18:09:47 (GMT)
committerdgp <dgp@users.sourceforge.net>2006-05-05 18:09:47 (GMT)
commitc802ec354b63ada12adc6522c9d96b60bd16687a (patch)
tree798c410899336ae3a0e0642c314d7af97a06dd75
parent567b7209bf2c1079048fca82605f2f468b9bf66b (diff)
downloadtcl-c802ec354b63ada12adc6522c9d96b60bd16687a.zip
tcl-c802ec354b63ada12adc6522c9d96b60bd16687a.tar.gz
tcl-c802ec354b63ada12adc6522c9d96b60bd16687a.tar.bz2
* 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].
-rw-r--r--ChangeLog7
-rw-r--r--generic/tclMain.c222
-rw-r--r--tests/main.test23
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 {