Tcl Source Code

2006-05-05  Don Porter  <[email protected]>

	* 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  <[email protected]>

	* README:		Bump version number to 8.4.14
	* generic/tcl.h:
	* tools/tcl.wse.in:
	* unix/configure.in:
	* unix/tcl.spec:

/* 
 * tclMain.c --
 *
 *	Main program for Tcl shells and other Tcl-based applications.
 *
 * 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.20.2.3 2006/05/05 18:08:58 dgp Exp $
 */

#include "tcl.h"
#include "tclInt.h"

# undef TCL_STORAGE_CLASS
# define TCL_STORAGE_CLASS DLLEXPORT

    /*
     * Get a new value for tty if anyone writes to ::tcl_interactive
     */
    Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty, TCL_LINK_BOOLEAN);
    inChannel = Tcl_GetStdChannel(TCL_STDIN);
    outChannel = Tcl_GetStdChannel(TCL_STDOUT);
    while ((inChannel != (Tcl_Channel) NULL) && !Tcl_InterpDeleted(interp)) {
	if (mainLoopProc == NULL) {
	    if (tty) {
		Prompt(interp, &prompt);
		if (Tcl_InterpDeleted(interp)) {
		    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);
	    }
            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;
		}

		/* 
		 * Either EOF, or an error on stdin; we're done
		 */

		break;
	    }

            /*
             * 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;
	    }

	    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);
	    }
	} else {	/* (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.
	     */

	    InteractiveState *isPtr = NULL;

# This file contains a collection of tests for generic/tclMain.c.
#
# 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."
    return
}

namespace eval ::tcl::test::main {

    } -cleanup {
	close $f
	file delete result
	removeFile rc
    } -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 {
	Tcl_Main: tcl_interactive must be boolean
    } -constraints {
	exec
    } -body {