Tcl Source Code

Check-in [f4e4abd17f]
Login
Core Home Timeline Branches Tags Tickets Wiki Clone or Download
Bounty program for improvements to Tcl and certain Tcl packages.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:
* 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].
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | core-8-4-branch
Files: files | file ages | folders
SHA1: f4e4abd17fd6355fbea233c0181074455e89066a
User & Date: dgp 2006-05-05 18:08:57
Context
2006-05-13
17:17
* generic/tclProc.c (ProcCompileProc): When a bump of the compile epoch forces the ...
 check-in: 463e0bb43d user: dgp tags: core-8-4-branch
2006-05-05
18:08
* generic/tclMain.c (Tcl_Main): Corrected flaw that required * tests/main.te...
 check-in: f4e4abd17f user: dgp tags: core-8-4-branch
2006-05-04
13:09
* README: Bump version number to 8.4.14 * generic/tcl.h: * too...
 check-in: 318c584699 user: dgp tags: core-8-4-branch
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ChangeLog. 








1
2
3
4
5
6
7







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:

>
>
>
>
>
>
>








1
2
3
4
5
6
7
8
9
10
11
12
13
14

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:

Changes to generic/tclMain.c. 

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
331
332
333
334
335
336
337

338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422

 * 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.2 2005/10/23 22:01:30 msofer 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 (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);
	}
	if (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;







|







 







>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|

|
|

|
|
|

|
|

|
|
|

|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
<








6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415

416
417
418
419
420
421
422

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

Changes to tests/main.test. 

1
2
3
4
5
6
7
8
9
10
...
495
496
497
498
499
500
501





















502
503
504
505
506
507
508

# 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 $

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"






















    # Tests Tcl_Main-5.*: interactive operations

    test Tcl_Main-5.1 {
	Tcl_Main: tcl_interactive must be boolean
    } -constraints {
	exec
    } -body {


|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>








1
2
3
4
5
6
7
8
9
10
...
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529

# 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 {

This page was generated in about 0.095s by Fossil 2.10 [eb804dc674] 2019-09-19 14:14:14