Tcl Source Code

	     * events too. This compiles on all platforms, and also passes the
	     * testsuite on all of them.
	     */

	    mask &= ~TCL_EXCEPTION;

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

    if (!statePtr->timer
	&& mask & TCL_WRITABLE
	&& GotFlag(statePtr, CHANNEL_NONBLOCKING)) {

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


    ChanWatch(chanPtr, mask);
}

    void *clientData)
{
    Channel *chanPtr = (Channel *)clientData;

    /* State info for channel */
    ChannelState *statePtr = chanPtr->state;

    /* TclChannelPreserve() must be called before the current function was
     * scheduled, is already in effect.  In this function it guards against
     * deallocation in Tcl_NotifyChannel and also keps the channel preserved
     * until ChannelTimerProc is later called again.
     */

    if (chanPtr->typePtr == NULL) {
	TclChannelRelease((Tcl_Channel)chanPtr);
    } else {
	Tcl_Preserve(statePtr);
	statePtr->timer = NULL;
	if (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);

	} else {
	    /* The channel may have just been closed from within Tcl_NotifyChannel */
	    if (!GotFlag(statePtr, CHANNEL_INCLOSE)) {
		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);
		} else {
		    TclChannelRelease((Tcl_Channel)chanPtr);
		    UpdateInterest(chanPtr);
		}
	    } else {
		TclChannelRelease((Tcl_Channel)chanPtr);
	    }
	}

	Tcl_Release(statePtr);
    }

}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CreateChannelHandler --
 *

                if {[string length $result] == 0} {
                    driver finalize $chan
                }
                return $result
            }
        }
    }



namespace eval reflector {
    proc initialize {_ chan mode} {
	return {initialize finalize watch read}
    }


    proc finalize {_ chan} {
	namespace delete $_
    }


    proc read {_ chan count} {
	namespace upvar $_ source source
	set res [string range $source 0 $count-1]
	set source [string range $source $count end]
	return $res
    }


    proc watch {_ chan events} {
	after 0 [list chan postevent $chan read]
	return read
    }

    namespace ensemble create -parameters _
    namespace export *
}




namespace eval inputfilter {
    proc initialize {chan mode} {
	return {initialize finalize read}
    }
    
    proc read {chan buffer} {
	return $buffer
    }

    proc finalize chan {
	namespace delete $chan
    }

    namespace ensemble create
    namespace export *
}



# Channel read transform that is just the identity - pass all through
    proc idxform {cmd handle args} {
      switch -- $cmd {
        initialize {
            return {initialize finalize read}
        }

    vwait ::res
    set res
} -cleanup {
    thread::send $tidb tempdone
    thread::release $tidb
} -result {Owner lost}


test iortrans-ea69b0258a9833cb {
    Crash when using a channel transformation on TCP client socket

    "line two" does not make it into result.  This issue should probably be
    addressed, but it is outside the scope of this test.
} -setup {
    set res {}
    set read 0
} -body {
    namespace eval reflector1 {
	variable source "line one\nline two"
	interp alias {} [namespace current]::dispatch {} [
	    namespace parent]::reflector [namespace current]
    }
    set chan [chan create read [namespace which reflector1::dispatch]]
    chan configure $chan -blocking 0
    chan push $chan inputfilter
    chan event $chan read [list ::apply [list chan {
	variable res
	variable read
	set gets [gets $chan]
	append res $gets
	incr read
    } [namespace current]] $chan]
    vwait [namespace current]::read
    chan pop $chan
    vwait [namespace current]::read
    return $res
} -cleanup {
    catch {unset read}
    close $chan
} -result {line one}

cleanupTests
return