Tcl Source Code

		TclChannelPreserve((Tcl_Channel)chanPtr);
		statePtr->timerChanPtr = chanPtr;
		statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
			ChannelTimerProc, chanPtr);
	    }
	}
    }

    if (!statePtr->timer
	    && mask & TCL_WRITABLE
	    && GotFlag(statePtr, CHANNEL_NONBLOCKING)
	    && (
		statePtr->curOutPtr
		&&
		!IsBufferEmpty(statePtr->curOutPtr)
		&&
		!IsBufferFull(statePtr->curOutPtr)
	   )
    ) {
	TclChannelPreserve((Tcl_Channel)chanPtr);
	statePtr->timerChanPtr = chanPtr;
	statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
		ChannelTimerProc,chanPtr);
    }


    ChanWatch(chanPtr, mask);
}

/*
 *----------------------------------------------------------------------
 *
 * ChannelTimerProc --

static void
ChannelTimerProc(
    void *clientData)
{
    Channel *chanPtr = (Channel *)clientData;
    /* State info for channel */
    ChannelState *statePtr = chanPtr->state;
    int notified = 0;

    if (chanPtr->typePtr == NULL) {
	statePtr->timer = NULL;
	TclChannelRelease((Tcl_Channel)statePtr->timerChanPtr);
	statePtr->timerChanPtr = NULL;
    } else {
	if (!GotFlag(statePtr, CHANNEL_NEED_MORE_DATA)
		&& (statePtr->interestMask & TCL_READABLE)
		&& (statePtr->inQueueHead != NULL)
		&& IsBufferReady(statePtr->inQueueHead)) {
	    /*
	     * Restart the timer in case a channel handler reenters the event loop
	     * before UpdateInterest gets called by Tcl_NotifyChannel.
	     */
	    statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
		ChannelTimerProc,chanPtr);

	    Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_READABLE);
	    notified = 1;
	} 

	if (chanPtr->typePtr != NULL
	    && statePtr->interestMask & TCL_WRITABLE
	    && GotFlag(statePtr, CHANNEL_NONBLOCKING)
	    && !GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
	    /*
	     * Restart the timer in case a channel handler reenters the event loop
	     * before UpdateInterest gets called by Tcl_NotifyChannel.
	     */
	    statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
		ChannelTimerProc,chanPtr);
	    Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_WRITABLE);
	    notified = 1;
	}

	if (!notified) {
	    statePtr->timer = NULL;
	    UpdateInterest(chanPtr);
	    /* Was set in UpdateInterest. */
	    TclChannelRelease((Tcl_Channel)statePtr->timerChanPtr);
	    statePtr->timerChanPtr = NULL;
	}
    }
}

static void

        close $chan
        set ::io-44.7-result success
    } [namespace current]]
    vwait ::io-44.7-result
    set ::io-44.7-result
} -result success


test io-44.8 {write-only refchan should not hang} -setup {
    catch {namespace delete rc}
    namespace eval rc {
	namespace export *
	namespace ensemble create

	proc buffer chan {
	    namespace upvar chan_$chan buffer buffer
	    return $buffer
	}

	proc initialize {chan mode} {
	    namespace eval chan_$chan {
		variable buffer {}
		variable watch {}
		variable writetask {}
	    }
	    return {initialize finalize watch write}
	}


	proc finalize chan {
	    namespace upvar chan_$chan writetask writetask
	    after cancel $writetask
	    set writetask {}
	    namespace delete chan_$chan
	}


	proc watch {chan spec} {
	    set channs [namespace current]::chan_$chan
	    namespace upvar $channs watch watch writetask writetask
	    set watch $spec
	    after cancel $writetask
	    if {{write} in $spec} {
		set writetask [after 0 [list after idle [
		    list ::apply {{channs chan} {
			if {[namespace exists $channs]} {
			    chan postevent $chan write
			}
		    }} $channs $chan]]]
	    } else {
		set writetask {}
	    }
	    return
	}


	proc write {chan data} {
	    set channs [namespace current]::chan_$chan
	    namespace upvar $channs buffer buffer watch watch \
		writetask writetask
	    append buffer $data
	    after cancel writetask
	    if {{write} in $watch} {
		set writetask [after 0 [list after idle [
		    list ::apply {{channs chan} {
			if {[namespace exists $channs]} {
			    chan postevent $chan write
			}
		}} $channs $chan]]]
	    } else {
		set writetask {}
	    }
	    return [string length $data]
	}


	proc post {chan side} {
	    set ns chan_$chan
	    if [namespace exists $ns] {
		chan postevent $chan $side
	    }
	    return
	}
    }
} -cleanup {
    namespace delete rc
} -body {
    variable done
    set chan [chan create write [namespace which rc]]
    try {
	chan configure $chan -blocking 0
	coroutine c1 apply [list chan {
	    variable done
	    after 0 [list [info coroutine]] 
	    set written 0
	    yield
	    chan event $chan writable [list [info coroutine]]
	    # Perform enough to exercise more than one buffer.
	    while {[incr i] < 500000}  {
		yield
		puts $chan $i
		set written [expr {$written + [string length $i] + 1}]
	    }
	    chan configure $chan -blocking 1
	    flush $chan
	    set buffersize [string length [rc buffer $chan]]
	    set done [list $written $buffersize]
	} [namespace current]] $chan
	vwait [namespace current]::done
    } finally {
	close $chan
    }
    return $done
} -result {3388888 3388888}

makeFile "foo bar" foo

test io-45.1 {DeleteFileEvent, cleanup on close} {fileevent} {
    set f [open $path(foo) r]
    fileevent $f readable [namespace code {
	lappend x "binding triggered: \"[gets $f]\""
	fileevent $f readable {}