Tcl Source Code

	/*
	 * If the queue is empty and there is a ready current buffer, OR if
	 * the current buffer is full, then move the current buffer to the
	 * queue.
	 */


	if (((statePtr->curOutPtr != NULL) &&
		IsBufferFull(statePtr->curOutPtr))
		|| (GotFlag(statePtr, BUFFER_READY) &&
			(statePtr->outQueueHead == NULL))) {
	    ResetFlag(statePtr, BUFFER_READY);
	    statePtr->curOutPtr->nextPtr = NULL;
	    if (statePtr->outQueueHead == NULL) {
................................................................................
	if (wroteSome) {
	    return errorCode;
	} else if (statePtr->outQueueHead == NULL) {
	    ResetFlag(statePtr, BG_FLUSH_SCHEDULED);
	    (chanPtr->typePtr->watchProc)(chanPtr->instanceData,
		    statePtr->interestMask);
	}


    }

    /*
     * If the channel is flagged as closed, delete it when the refCount drops
     * to zero, the output queue is empty and there is no output in the
     * current output buffer.
     */

	/*
	 * If the queue is empty and there is a ready current buffer, OR if
	 * the current buffer is full, then move the current buffer to the
	 * queue.
	 */

start:
	if (((statePtr->curOutPtr != NULL) &&
		IsBufferFull(statePtr->curOutPtr))
		|| (GotFlag(statePtr, BUFFER_READY) &&
			(statePtr->outQueueHead == NULL))) {
	    ResetFlag(statePtr, BUFFER_READY);
	    statePtr->curOutPtr->nextPtr = NULL;
	    if (statePtr->outQueueHead == NULL) {
................................................................................
	if (wroteSome) {
	    return errorCode;
	} else if (statePtr->outQueueHead == NULL) {
	    ResetFlag(statePtr, BG_FLUSH_SCHEDULED);
	    (chanPtr->typePtr->watchProc)(chanPtr->instanceData,
		    statePtr->interestMask);
	}
    } else if (statePtr->curOutPtr && BytesLeft(statePtr->curOutPtr)) {
	goto start;
    }

    /*
     * If the channel is flagged as closed, delete it when the refCount drops
     * to zero, the output queue is empty and there is no output in the
     * current output buffer.
     */

    fconfigure $f1 -blocking 0
    puts $f1 $big
    flush $f1
    after 500
    set result ""
    fileevent $f1 read [namespace code {
	append result [read $f1 1024]
	if {[string length $result] >= [string length $big]} {
	    set x done
	}
    }]
    vwait [namespace which -variable x]
    close $f1
    set big {}
    set x
} done































set result {}
proc FcopyTestAccept {sock args} {
    after 1000 "close $sock"
}
proc FcopyTestDone {bytes {error {}}} {
    variable fcopyTestDone
    if {[string length $error]} {

    fconfigure $f1 -blocking 0
    puts $f1 $big
    flush $f1
    after 500
    set result ""
    fileevent $f1 read [namespace code {
	append result [read $f1 1024]
	if {[string length $result] >= [string length $big]+1} {
	    set x done
	}
    }]
    vwait [namespace which -variable x]
    close $f1
    set big {}
    set x
} done
test io-53.4.1 {Bug 894da183c8} {stdio fcopy} {
    set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
    variable x
    for {set x 0} {$x < 12} {incr x} {
	append big $big
    }
    file delete $path(pipe)
    set f1 [open $path(pipe) w]
    puts $f1 [list file delete $path(test1)]
    puts $f1 {
	puts ready
	set f [open io-53.4.1 w]
	fcopy stdin $f -command { set x }
	vwait x
	close $f
    }
    puts $f1 "close \[[list open $path(test1) w]]"
    close $f1
    set f1 [open "|[list [interpreter] $path(pipe)]" r+]
    set result [gets $f1]
    fconfigure $f1 -blocking 0 -buffersize 125000
    puts $f1 $big
    fconfigure $f1 -blocking 1
    close $f1
    set big {}
    while {[catch {glob $path(test1)}]} {after 50}
    file delete $path(test1)
    set check [file size io-53.4.1]
    file delete io-53.4.1
    set check
} 266241
set result {}
proc FcopyTestAccept {sock args} {
    after 1000 "close $sock"
}
proc FcopyTestDone {bytes {error {}}} {
    variable fcopyTestDone
    if {[string length $error]} {