diff options
| -rw-r--r-- | ChangeLog | 7 | ||||
| -rw-r--r-- | generic/tclMain.c | 134 | ||||
| -rw-r--r-- | tests/main.test | 23 |
3 files changed, 96 insertions, 68 deletions
@@ -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.4.14 diff --git a/generic/tclMain.c b/generic/tclMain.c index 2847bd8..937d2aa 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.20.2.2 2005/10/23 22:01:30 msofer Exp $ + * RCS: @(#) $Id: tclMain.c,v 1.20.2.3 2006/05/05 18:08:58 dgp Exp $ */ #include "tcl.h" @@ -335,84 +335,84 @@ Tcl_Main(argc, argv, appInitProc) 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 (mainLoopProc == NULL) { + if (tty) { + Prompt(interp, &prompt); + if (Tcl_InterpDeleted(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; - } + /* + * Add the newline removed by Tcl_GetsObj back to the string. + */ - /* - * 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); + } + Tcl_AppendToObj(commandPtr, "\n", 1); + if (!TclObjCommandComplete(commandPtr)) { + prompt = PROMPT_CONTINUE; + continue; + } - if (Tcl_IsShared(commandPtr)) { + 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_DuplicateObj(commandPtr); + commandPtr = Tcl_NewObj(); Tcl_IncrRefCount(commandPtr); - } - Tcl_AppendToObj(commandPtr, "\n", 1); - if (!TclObjCommandComplete(commandPtr)) { - 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); + 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 diff --git a/tests/main.test b/tests/main.test index 26b40eb..4e91478 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.13.2.2 2006/02/09 15:23:52 dgp Exp $ +# RCS: @(#) $Id: main.test,v 1.13.2.3 2006/05/05 18:08:58 dgp Exp $ if {[catch {package require tcltest 2.0.2}]} { puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required." @@ -499,6 +499,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 { |