Tcl Source Code

static int		CheckChannelErrors(ChannelState *statePtr,
			    int direction);
static int		CheckForDeadChannel(Tcl_Interp *interp,
			    ChannelState *statePtr);
static void		CheckForStdChannelsBeingClosed(Tcl_Channel chan);
static void		CleanupChannelHandlers(Tcl_Interp *interp,
			    Channel *chanPtr);
static void		CleanupTimerHandler(ChannelState *statePtr);
static int		CloseChannel(Tcl_Interp *interp, Channel *chanPtr,
			    int errorCode);
static int		CloseChannelPart(Tcl_Interp *interp, Channel *chanPtr,
			    int errorCode, int flags);
static int		CloseWrite(Tcl_Interp *interp, Channel *chanPtr);
static void		CommonGetsCleanup(Channel *chanPtr);
static int		CopyData(CopyState *csPtr, int mask);

	    TclDecrRefCount(statePtr->chanMsg);
	    statePtr->chanMsg = NULL;
	}
    }

    Tcl_ClearChannelHandlers(chan);

    /*
     * Cancel any outstanding timer.
     */
    DeleteTimerHandler(statePtr);

    /*
     * Invoke the registered close callbacks and delete their records.
     */

    while (statePtr->closeCbPtr != NULL) {
	cbPtr = statePtr->closeCbPtr;
	statePtr->closeCbPtr = cbPtr->nextPtr;

static void
UpdateInterest(
    Channel *chanPtr)		/* Channel to update. */
{
    ChannelState *statePtr = chanPtr->state;
				/* State info for channel */
    ChannelBuffer *bufPtr = statePtr->outQueueHead;
    int mask = statePtr->interestMask;

    if (chanPtr->typePtr == NULL) {
	/* Do not update interest on a closed channel */
	return;
    }

		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)
	    && bufPtr
		&& !IsBufferEmpty(bufPtr)
		&& !IsBufferFull(bufPtr)
    ) {
	TclChannelPreserve((Tcl_Channel)chanPtr);
	statePtr->timerChanPtr = chanPtr;
	statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
		ChannelTimerProc,chanPtr);
    }

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

ChannelTimerProc(
    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) {
	CleanupTimerHandler(statePtr);


    } 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 {
		    CleanupTimerHandler(statePtr);
		    UpdateInterest(chanPtr);
		}
	    } else {

		CleanupTimerHandler(statePtr);
	    }
	}
	Tcl_Release(statePtr);
    }
}

static void
DeleteTimerHandler(
    ChannelState *statePtr
)
{
    if (statePtr->timer != NULL) {
	Tcl_DeleteTimerHandler(statePtr->timer);
	CleanupTimerHandler(statePtr);
    }
}
static void
CleanupTimerHandler(
    ChannelState *statePtr
){
    TclChannelRelease((Tcl_Channel)statePtr->timerChanPtr);
    statePtr->timer = NULL;
    statePtr->timerChanPtr = NULL;

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

	     * Read up to bufSize bytes.
	     */

	    if ((csPtr->toRead == -1)
		    || (csPtr->toRead > (Tcl_WideInt)csPtr->bufSize)) {
		sizeb = csPtr->bufSize;
	    } else {
		sizeb = (int) csPtr->toRead;
	    }

	    if (inBinary || sameEncoding) {
		size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, sizeb,
			      !GotFlag(inStatePtr, CHANNEL_NONBLOCKING));
	    } else {
		size = DoReadChars(inStatePtr->topChanPtr, bufObj, sizeb,

	/*
	 * Don't read more data if we have what we need.
	 */

	while (!bufPtr ||			/* We got no buffer!   OR */
		(!IsBufferFull(bufPtr) && 	/* Our buffer has room AND */
		(BytesLeft(bufPtr) < bytesToRead))) {
						/* Not enough bytes in it yet
						 * to fill the dst */
	    int code;

	moreData:
	    code = GetInput(chanPtr);
	    bufPtr = statePtr->inQueueHead;

    assert(!GotFlag(statePtr, CHANNEL_EOF)
	    || GotFlag(statePtr, CHANNEL_STICKY_EOF|CHANNEL_ENCODING_ERROR)
	    || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0);
    assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED)
	    == (CHANNEL_EOF|CHANNEL_BLOCKED)));
    UpdateInterest(chanPtr);
    TclChannelRelease((Tcl_Channel)chanPtr);
    return (int)(p - dst);
}

/*
 *----------------------------------------------------------------------
 *
 * CopyEventProc --
 *

			    Tcl_Interp *interp, const char *optionName,
			    Tcl_DString *dsPtr);
static int		ReflectSetOption(void *clientData,
			    Tcl_Interp *interp, const char *optionName,
			    const char *newValue);
static int		ReflectTruncate(void *clientData,
			    long long length);
static void     TimerRunRead(void *clientData);
static void     TimerRunWrite(void *clientData);

/*
 * The C layer channel type/driver definition used by the reflection.
 */

static const Tcl_ChannelType tclRChannelType = {
    "tclrchannel",	   /* Type name.				  */

typedef struct {
    Tcl_Channel chan;		/* Back reference to generic channel
				 * structure. */
    Tcl_Interp *interp;		/* Reference to the interpreter containing the
				 * Tcl level part of the channel. NULL here
				 * signals the channel is dead because the
				 * interpreter/thread containing its Tcl
				 * command is gone.
				 */
#if TCL_THREADS
    Tcl_ThreadId thread;	/* Thread the 'interp' belongs to. == Handler thread */
    Tcl_ThreadId owner;	 /* Thread owning the structure.    == Channel thread */
#endif
    Tcl_Obj *cmd;		/* Callback command prefix */
    Tcl_Obj *methods;		/* Methods to append to command prefix */
    Tcl_Obj *name;		/* Name of the channel as created */

    int mode;			/* Mask of R/W mode */
    int interest;		/* Mask of events the channel is interested
				 * in. */

    int dead;			/* Boolean signal that some operations
				 * should no longer be attempted. */

    Tcl_TimerToken readTimer;   /*
				   A token for the timer that is scheduled in
				   order to call Tcl_NotifyChannel when the
				   channel is readable
				*/
    Tcl_TimerToken writeTimer;  /*
				   A token for the timer that is scheduled in
				   order to call Tcl_NotifyChannel when the
				   channel is writable
				*/

    /*
     * Note regarding the usage of timers.
     *
     * Most channel implementations need a timer in the C level to ensure that
     * data in buffers is flushed out through the generation of fake file
     * events.
     *
     * See 'refchan', 'memchan', etc.
     *


     * A timer is used here as well in order to ensure at least on pass through

     * the event loop when a channel becomes ready. See issues 67a5eabbd3d1 and
     * ef28eb1f1516.
     */
} ReflectedChannel;

/*
 * Structure of the table mapping from channel handles to reflected
 * channels. Each interpreter which has the handler command for one or more
 * reflected channels records them in such a table, so that 'chan postevent'

    /*
     * We have the channel and the events to post.
     */

#if TCL_THREADS
    if (rcPtr->owner == rcPtr->thread) {
#endif
	if (events & TCL_READABLE) {
	    if (rcPtr->readTimer == NULL) {
		rcPtr->readTimer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
			TimerRunRead, rcPtr);
	    }
	}
	if (events & TCL_WRITABLE) {
	    if (rcPtr->writeTimer == NULL) {
		rcPtr->writeTimer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
			TimerRunWrite, rcPtr);
	    }
	}
#if TCL_THREADS
    } else {
	ReflectEvent *ev = (ReflectEvent *)ckalloc(sizeof(ReflectEvent));

	ev->header.proc = ReflectEventRun;
	ev->events = events;
	ev->rcPtr = rcPtr;

    Tcl_ResetResult(interp);
    return TCL_OK;

#undef CHAN
#undef EVENT
}

static void
TimerRunRead(
    void *clientData)
{
    ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
    rcPtr->readTimer = NULL;
    Tcl_NotifyChannel(rcPtr->chan, TCL_READABLE);
}

static void
TimerRunWrite(
    void *clientData)
{
    ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
    rcPtr->writeTimer = NULL;
    Tcl_NotifyChannel(rcPtr->chan, TCL_WRITABLE);
}

/*
 * Channel error message marshalling utilities.
 */

static Tcl_Obj *
MarshallError(

#endif

	tctPtr = ((Channel *)rcPtr->chan)->typePtr;
	if (tctPtr && tctPtr != &tclRChannelType) {
	    ckfree(tctPtr);
	    ((Channel *)rcPtr->chan)->typePtr = NULL;
	}
	if (rcPtr->readTimer != NULL) {
	    Tcl_DeleteTimerHandler(rcPtr->readTimer);
	}
	if (rcPtr->writeTimer != NULL) {
	    Tcl_DeleteTimerHandler(rcPtr->writeTimer);
	}
	Tcl_EventuallyFree(rcPtr, FreeReflectedChannel);
	return EOK;
    }

    /*
     * Are we in the correct thread?
     */

    }
#endif
    tctPtr = ((Channel *)rcPtr->chan)->typePtr;
    if (tctPtr && tctPtr != &tclRChannelType) {
	ckfree(tctPtr);
	((Channel *)rcPtr->chan)->typePtr = NULL;
    }
    if (rcPtr->readTimer != NULL) {
	Tcl_DeleteTimerHandler(rcPtr->readTimer);
    }
    if (rcPtr->writeTimer != NULL) {
	Tcl_DeleteTimerHandler(rcPtr->writeTimer);
    }
    Tcl_EventuallyFree(rcPtr, FreeReflectedChannel);
    return (result == TCL_OK) ? EOK : EINVAL;
}

/*
 *----------------------------------------------------------------------
 *

    rcPtr = (ReflectedChannel *)ckalloc(sizeof(ReflectedChannel));

    /* rcPtr->chan: Assigned by caller. Dummy data here. */

    rcPtr->chan = NULL;
    rcPtr->interp = interp;
    rcPtr->dead = 0;
    rcPtr->readTimer = 0;
    rcPtr->writeTimer = 0;
#if TCL_THREADS
    rcPtr->thread = Tcl_GetCurrentThread();
#endif
    rcPtr->mode = mode;
    rcPtr->interest = 0;		/* Initially no interest registered */

    rcPtr->cmd = TclListObjCopy(NULL, cmdpfxObj);

test io-28.6 {
	close channel in write event handler

	Should not produce a segmentation fault in a Tcl built with
	--enable-symbols and -DPURIFY
} debugpurify {
    variable done
    variable res


    after 0 [list coroutine c1 apply [list {} {
	variable done
	set chan [chan create w {apply {args {







	    list initialize finalize watch write configure blocking





	}}}]
	chan configure $chan -blocking 0
	while 1 {
	    chan event $chan writable [list [info coroutine]]
	    yield
	    close $chan
	    set done 1
	    return
	}
    } [namespace current]]]
    vwait [namespace current]::done
return success


} success


test io-28.7 {
    close channel in read event handler

	Should not produce a segmentation fault in a Tcl built with
	--enable-symbols and -DPURIFY
} debugpurify {
    variable done
    variable res
    after 0 [list coroutine c1 apply [list {} {
	variable done


	set chan [chan create r {apply {{cmd chan args} {
	    switch $cmd {
		blocking - finalize {
		}
		watch {
		    chan postevent $chan read
		}
		initialize {
		    list initialize finalize watch read write configure blocking
		}
		default {
		    error [list {unexpected command} $cmd]
		}
	    }
	}}}]
	chan configure $chan -blocking 0
	while 1 {
	    chan event $chan readable [list [info coroutine]]
	    yield
	    close $chan
	    set done 1
	    return
	}
    } [namespace current]]]
    vwait [namespace current]::done
return success
} success



test io-29.1 {Tcl_WriteChars, channel not writable} {
    list [catch {puts stdin hello} msg] $msg
} {1 {channel "stdin" wasn't opened for writing}}
test io-29.2 {Tcl_WriteChars, empty string} {
    file delete $path(test1)
    set f [open $path(test1) w]

    set x
} -cleanup {
    close $f4
} -result {initial foo eof}

close $f




test io-44.6 {FileEventProc procedure: write-only non-blocking channel} -setup {
} -constraints {stdio fileevent openpipe} -body {

    namespace eval refchan {
	namespace ensemble create
	namespace export *



	proc finalize {chan args} {


	    namespace delete c_$chan
	}

	proc initialize {chan args} {
	    namespace eval c_$chan {}
	    namespace upvar c_$chan watching watching
	    set watching {}
	    list finalize initialize seek watch write
	}


	proc watch {chan args} {
	    namespace upvar c_$chan watching watching
	    foreach arg $args {
		switch $arg {
		    write {
			if {$arg ni $watching} {
			    lappend watching $arg
			}
			chan postevent $chan $arg
		    }
		}
	    }

	}






	proc write {chan args} {
















	    chan postevent $chan write
	    return 1
	}

    }
    set f [chan create w [namespace which refchan]]
    chan configure $f -blocking 0
    set data "some data"
    set x 0
    chan event $f writable [namespace code {
	puts $f $data
	incr count [string length $data]
	if {$count > 262144} {
	    chan event $f writable {}
	    set x done
	}
    }]

    set token [after 10000 [namespace code {
	set x timeout
    }]]
    vwait [namespace which -variable x]
    return $x
} -cleanup {
    after cancel $token
    catch {chan close $f}
} -result done












































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]\""

    return -code return $args
}
proc onfinal {} {
    upvar args hargs
    if {[lindex $hargs 0] ne "finalize"} {return}
    return -code return ""
}

proc onwatch {} {
    upvar args hargs
    lassign $hargs watch chan eventspec
    if {$watch ne "watch"} return
    foreach spec $eventspec {
	chan postevent $chan $spec
    }
    return
}

}

# Set everything up in the main thread.
eval $helperscript

# --- --- --- --------- --------- ---------
# method finalize

    set stop [after 15000 {lappend res TIMEOUT; set tock 1}]
    after  1000 {note [chan postevent $c r]}
    vwait ::tock
    catch {after cancel $stop}
    close $c
    rename foo {}
    set res
} -result {{watch rc* read} {} {} TOCK {watch rc* {}}}
test iocmd-31.7 {chan postevent, posted events do happen} -match glob -body {
    set res {}
    proc foo {args} {oninit; onfinal; track; return}
    set c [chan create {r w} foo]
    note [fileevent $c writable {lappend res TOCK; set tock 1}]
    set stop [after 15000 {lappend res TIMEOUT; set tock 1}]
    after  1000 {note [chan postevent $c w]}
    vwait ::tock
    catch {after cancel $stop}
    close $c
    rename foo {}
    set res
} -result {{watch rc* write} {} {} TOCK {watch rc* {}}}
test iocmd-31.8 {chan postevent after close throws error} -match glob -setup {
    proc foo {args} {oninit; onfinal; track; return}
    proc dummy args { return }
    set c [chan create {r w} foo]
    fileevent $c readable dummy
} -body {
    close $c
    chan postevent $c read
} -cleanup {
    rename foo   {}
    rename dummy {}
} -returnCodes error -result {can not find reflected channel named "rc*"}
test iocmd-31.9 {
    chan postevent

    call to current coroutine

    see 67a5eabbd3d1
} -match glob -body {
    set res {}
    proc foo {args} {oninit; onwatch; onfinal; track; return}
    set c [chan create {r w} foo]
    after 0 [list ::apply [list c {
	coroutine c1 ::apply [list c {
	    chan event $c readable [list [info coroutine]]
	    yield
	    set ::done READING
	} [namespace current]] $c
    } [namespace current]] $c]
    set stop [after 10000 {set done TIMEOUT}]
    vwait ::done
    catch {after cancel $stop}
    lappend res $done
    close $c
    rename foo {}
    set res
} -result {{watch rc* read} READING {watch rc* {}}}

# --- === *** ###########################
# 'Pull the rug' tests. Create channel in a interpreter A, move to
# other interpreter B, destroy the origin interpreter (A) before or
# during access from B. Must not crash, must return proper errors.

test iocmd-32.0 {origin interpreter of moved channel gone} -match glob -body {