From c802ec354b63ada12adc6522c9d96b60bd16687a Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 5 May 2006 18:09:47 +0000 Subject: * 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]. --- ChangeLog | 7 ++ generic/tclMain.c | 222 +++++++++++++++++++++++++++--------------------------- tests/main.test | 23 +++++- 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 + + * 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 * 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 { -- cgit v0.12