Tcl Source Code

	    Tcl_SetErrno(errorCode);
	}
    }

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



    /*
     * Mark the channel as deleted by clearing the type structure.
     */

    if (chanPtr->downChanPtr != NULL) {
	Channel *downChanPtr = chanPtr->downChanPtr;

    if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) {
	return 0;
    }
    return GotFlag(statePtr, CHANNEL_EOF) ? 1 : 0;
}


/*
 *----------------------------------------------------------------------
 *
 * TclChannelGetBlockingMode --
 *
 *	Returns 1 if the channel is in blocking mode (default), 0 otherwise.
 *

    Tcl_Channel chan)
{
    ChannelState *statePtr = ((Channel *) chan)->state;
				/* State of real channel structure. */

    return GotFlag(statePtr, CHANNEL_NONBLOCKING) ? 0 : 1;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InputBlocked --
 *
 *	Returns 1 if input is blocked on this channel, 0 otherwise.
 *

    NULL,		   /* Get OS handle from the channel.	NULL'able */
    ReflectClose,	   /* No close2 support.		NULL'able */
    ReflectBlock,	   /* Set blocking/nonblocking.		NULL'able */
    NULL,		   /* Flush channel. Not used by core.	NULL'able */
    NULL,		   /* Handle events.			NULL'able */
    ReflectSeekWide,	   /* Move access point (64 bit).	NULL'able */
#if TCL_THREADS
    ReflectThread,         /* thread action, tracking owner */
#else
	NULL,		   /* thread action */
#endif
    ReflectTruncate	   /* Truncate.				NULL'able */
};

/*

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

     * Verify the result.
     * - List, of method names. Convert to mask.
     *   Check for non-optionals through the mask.
     *   Compare open mode against optional r/w.
     */

    if (TclListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) {
        Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                "chan handler \"%s initialize\" returned non-list: %s",
                TclGetString(cmdObj), TclGetString(resObj)));
	Tcl_DecrRefCount(resObj);
	goto error;
    }

    methods = 0;
    while (listc > 0) {
	if (Tcl_GetIndexFromObj(interp, listv[listc-1], methodNames,

	methods |= FLAG(methIndex);
	listc--;
    }
    Tcl_DecrRefCount(resObj);

    if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) {
        Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                "chan handler \"%s\" does not support all required methods",
                TclGetString(cmdObj)));
	goto error;
    }

    if ((mode & TCL_READABLE) && !HAS(methods, METH_READ)) {
        Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                "chan handler \"%s\" lacks a \"read\" method",
                TclGetString(cmdObj)));
	goto error;
    }

    if ((mode & TCL_WRITABLE) && !HAS(methods, METH_WRITE)) {
        Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                "chan handler \"%s\" lacks a \"write\" method",
                TclGetString(cmdObj)));
	goto error;
    }

    if (!IMPLIES(HAS(methods, METH_CGET), HAS(methods, METH_CGETALL))) {
        Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                "chan handler \"%s\" supports \"cget\" but not \"cgetall\"",
                TclGetString(cmdObj)));
	goto error;
    }

    if (!IMPLIES(HAS(methods, METH_CGETALL), HAS(methods, METH_CGET))) {
        Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                "chan handler \"%s\" supports \"cgetall\" but not \"cget\"",
                TclGetString(cmdObj)));
	goto error;
    }

    Tcl_ResetResult(interp);

    /*
     * Everything is fine now.

#endif

    /*
     * Return handle as result of command.
     */

    Tcl_SetObjResult(interp,
            Tcl_NewStringObj(chanPtr->state->channelName, -1));
    return TCL_OK;

  error:
    Tcl_DecrRefCount(rcPtr->name);
    Tcl_DecrRefCount(rcPtr->methods);
    Tcl_DecrRefCount(rcPtr->cmd);
    Tcl_Free(rcPtr);

     * latter ensures that no pending events of this type are run on an
     * invalid channel.
     */

    ReflectEvent *e = (ReflectEvent *) ev;

    if ((ev->proc != ReflectEventRun) || ((cd != NULL) && (cd != e->rcPtr))) {
        return 0;
    }
    return 1;
}
#endif

int
TclChanPostEventObjCmd(

    chanId = TclGetString(objv[CHAN]);

    rcmPtr = GetReflectedChannelMap(interp);
    hPtr = Tcl_FindHashEntry(&rcmPtr->map, chanId);

    if (hPtr == NULL) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                "can not find reflected channel named \"%s\"", chanId));
	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CHANNEL", chanId, (char *)NULL);
	return TCL_ERROR;
    }

    /*
     * Note that the search above subsumes several of the older checks,
     * namely:

    /*
     * Check that the channel is actually interested in the provided events.
     */

    if (events & ~rcPtr->interest) {
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
                "tried to post events channel \"%s\" is not interested in",
                chanId));
	return TCL_ERROR;
    }

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

	    if (rcPtr->writeTimer == NULL) {
		rcPtr->writeTimer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
			TimerRunWrite, rcPtr);
	    }
	}
#if TCL_THREADS
    } else {
        ReflectEvent *ev = (ReflectEvent *)Tcl_Alloc(sizeof(ReflectEvent));

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

        /*
         * We are not preserving the structure here. When the channel is
         * closed any pending events are deleted, see ReflectClose(), and
         * ReflectEventDelete(). Trying to preserve and later release when the
         * event is run may generate a situation where the channel structure
         * is deleted but not our structure, crashing in
         * FreeReflectedChannel().
         *
         * Force creation of the RCM, for proper cleanup on thread teardown.
         * The teardown of unprocessed events is currently coupled to the
         * thread reflected channel map
         */

        (void) GetThreadReflectedChannelMap();

        /*
         * XXX Race condition !!
         * XXX The destination thread may not exist anymore already.
         * XXX (Delayed postevent executed after channel got removed).
         * XXX Can we detect this ? (check the validity of the owner threadid ?)
         * XXX Actually, in that case the channel should be dead also !
         */

        Tcl_ThreadQueueEvent(rcPtr->owner, (Tcl_Event *) ev,
		TCL_QUEUE_TAIL|TCL_QUEUE_ALERT_IF_EMPTY);
    }
#endif

    /*
     * Squash interp results left by the event script.
     */

#if TCL_THREADS
	if (rcPtr->thread != Tcl_GetCurrentThread()) {
	    ForwardParam p;

	    ForwardOpToHandlerThread(rcPtr, ForwardedClose, &p);
	    result = p.base.code;

            /*
             * Now squash the pending reflection events for this channel.
             */

            Tcl_DeleteEvents(ReflectEventDelete, rcPtr);

	    if (result != TCL_OK) {
		FreeReceivedError(&p);
	    }
	}
#endif

#if TCL_THREADS
    if (rcPtr->thread != Tcl_GetCurrentThread()) {
	ForwardParam p;

	ForwardOpToHandlerThread(rcPtr, ForwardedClose, &p);
	result = p.base.code;

        /*
         * Now squash the pending reflection events for this channel.
         */

        Tcl_DeleteEvents(ReflectEventDelete, rcPtr);

	if (result != TCL_OK) {
	    PassReceivedErrorInterp(interp, &p);
	}
    } else {
#endif
	result = InvokeTclMethod(rcPtr, METH_FINAL, NULL, NULL, &resObj);

    Tcl_IncrRefCount(toReadObj);

    if (InvokeTclMethod(rcPtr, METH_READ, toReadObj, NULL, &resObj)!=TCL_OK) {
	int code = ErrnoReturn(rcPtr, resObj);

	if (code < 0) {
	    *errorCodePtr = -code;
            goto error;
	}

	Tcl_SetChannelError(rcPtr->chan, resObj);
        goto invalid;
    }

    bytev = Tcl_GetBytesFromObj(NULL, resObj, &bytec);

    if (bytev == NULL) {
	SetChannelErrorStr(rcPtr->chan, msg_read_nonbyte);
	goto invalid;

	    if (p.base.code < 0) {
		/*
		 * No error message, this is an errno signal.
		 */

		*errorCodePtr = -p.base.code;
	    } else {
                PassReceivedError(rcPtr->chan, &p);
                *errorCodePtr = EINVAL;
            }
	    p.output.toWrite = -1;
	} else {
	    *errorCodePtr = EOK;
	}

	return p.output.toWrite;
    }

    Tcl_IncrRefCount(bufObj);

    if (InvokeTclMethod(rcPtr, METH_WRITE, bufObj, NULL, &resObj) != TCL_OK) {
	int code = ErrnoReturn(rcPtr, resObj);

	if (code < 0) {
	    *errorCodePtr = -code;
            goto error;
	}

	Tcl_SetChannelError(rcPtr->chan, resObj);
        goto invalid;
    }

    if (Tcl_InterpDeleted(rcPtr->interp)) {
	/*
	 * The interp was destroyed during InvokeTclMethod().
	 */

	SetChannelErrorStr(rcPtr->chan, msg_send_dstlost);
        goto invalid;
    }
    if (Tcl_GetIntFromObj(rcPtr->interp, resObj, &written) != TCL_OK) {
	Tcl_SetChannelError(rcPtr->chan, MarshallError(rcPtr->interp));
        goto invalid;
    }

    if ((written == 0) && (toWrite > 0)) {
	/*
	 * The handler claims to have written nothing of what it was given.
	 * That is bad.
	 */

	SetChannelErrorStr(rcPtr->chan, msg_write_nothing);
        goto invalid;
    }
    if (toWrite < written) {
	/*
	 * The handler claims to have written more than it was given. That is
	 * bad. Note that the I/O core would crash if we were to return this
	 * information, trying to write -nnn bytes in the next iteration.
	 */

	SetChannelErrorStr(rcPtr->chan, msg_write_toomuch);
        goto invalid;
    }

    *errorCodePtr = EOK;
 stop:
    Tcl_DecrRefCount(bufObj);
    Tcl_DecrRefCount(resObj);		/* Remove reference held from invoke */
    Tcl_Release(rcPtr->interp);

    /* ASSERT: rcPtr->method & FLAG(METH_SEEK) */

    Tcl_Preserve(rcPtr);

    TclNewIntObj(offObj, offset);
    baseObj = Tcl_NewStringObj(
            (seekMode == SEEK_SET) ? "start" :
            (seekMode == SEEK_CUR) ? "current" : "end", -1);
    Tcl_IncrRefCount(offObj);
    Tcl_IncrRefCount(baseObj);

    if (InvokeTclMethod(rcPtr, METH_SEEK, offObj, baseObj, &resObj)!=TCL_OK) {
	Tcl_SetChannelError(rcPtr->chan, resObj);
        goto invalid;
    }

    if (TclGetWideIntFromObj(rcPtr->interp, resObj, &newLoc) != TCL_OK) {
	Tcl_SetChannelError(rcPtr->chan, MarshallError(rcPtr->interp));
        goto invalid;
    }

    if (newLoc < 0) {
	SetChannelErrorStr(rcPtr->chan, msg_seek_beforestart);
        goto invalid;
    }

    *errorCodePtr = EOK;
 stop:
    Tcl_DecrRefCount(offObj);
    Tcl_DecrRefCount(baseObj);
    Tcl_DecrRefCount(resObj);		/* Remove reference held from invoke */

    void *clientData,
    int action)
{
    ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;

    switch (action) {
    case TCL_CHANNEL_THREAD_INSERT:
        rcPtr->owner = Tcl_GetCurrentThread();
        break;
    case TCL_CHANNEL_THREAD_REMOVE:
        rcPtr->owner = NULL;
        break;
    default:
        Tcl_Panic("Unknown thread action code.");
        break;
    }
}

#endif
/*
 *----------------------------------------------------------------------
 *

    } else {
	/*
	 * Retrieve the value of one option.
	 */

	method = METH_CGET;
	optionObj = Tcl_NewStringObj(optionName, -1);
        Tcl_IncrRefCount(optionObj);
    }

    Tcl_Preserve(rcPtr);

    if (InvokeTclMethod(rcPtr, method, optionObj, NULL, &resObj)!=TCL_OK) {
	UnmarshallErrorResult(interp, resObj);
        goto error;
    }

    /*
     * The result has to go into the 'dsPtr' for propagation to the caller of
     * the driver.
     */

    if (optionObj != NULL) {
	TclDStringAppendObj(dsPtr, resObj);
        goto ok;
    }

    /*
     * Extract the list and append each item as element.
     */

    /*
     * NOTE (4): If we extract the string rep we can assume a properly quoted
     * string. Together with a separating space this way of simply appending
     * the whole string rep might be faster. It also doesn't check if the
     * result is a valid list. Nor that the list has an even number elements.
     */

    if (TclListObjGetElements(interp, resObj, &listc, &listv) != TCL_OK) {
        goto error;
    }

    if ((listc % 2) == 1) {
	/*
	 * Odd number of elements is wrong.
	 */

	Tcl_ResetResult(interp);
	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
		"Expected list with even number of "
		"elements, got %" TCL_SIZE_MODIFIER "d element%s instead", listc,
		(listc == 1 ? "" : "s")));
        goto error;
    } else {
	Tcl_Size len;
	const char *str = TclGetStringFromObj(resObj, &len);

	if (len) {
	    TclDStringAppendLiteral(dsPtr, " ");
	    Tcl_DStringAppend(dsPtr, str, len);
	}
        goto ok;
    }

 ok:
    result = TCL_OK;
 stop:
    if (optionObj) {
        Tcl_DecrRefCount(optionObj);
    }
    Tcl_DecrRefCount(resObj);	/* Remove reference held from invoke */
    Tcl_Release(rcPtr);
    return result;
 error:
    result = TCL_ERROR;
    goto stop;

	if (resultObjPtr != NULL) {
	    resObj = Tcl_NewStringObj(msg_dstlost,-1);
	    *resultObjPtr = resObj;
	    Tcl_IncrRefCount(resObj);
	}

        /*
         * Not touching argOneObj, argTwoObj, they have not been used.
         * See the contract as well.
         */

	return TCL_ERROR;
    }

    /*
     * Insert method into the callback command, after the command prefix,
     * before the channel id.

	    continue;
	}

	/*
	 * The receiver for the event exited, before processing the event. We
	 * detach the result now, wake the originator up and signal failure.
         *
         * Attention: Results may have been detached already, by either the
         * receiver, or this thread, as part of other parts in the thread
         * teardown. Such results are ignored. See ticket [b47b176adf] for the
         * identical race condition in Tcl 8.6 IORTrans.
	 */

	evPtr = resultPtr->evPtr;

	/*
	 * Basic crash safety until this routine can get revised [3411310]
	 */

	    continue;
	}

	/*
	 * The receiver for the event exited, before processing the event. We
	 * detach the result now, wake the originator up and signal failure.
         *
         * Attention: Results may have been detached already, by either the
         * receiver, or this thread, as part of other parts in the thread
         * teardown. Such results are ignored. See ticket [b47b176adf] for the
         * identical race condition in Tcl 8.6 IORTrans.
	 */

	evPtr = resultPtr->evPtr;

	/*
	 * Basic crash safety until this routine can get revised [3411310]
	 */

    ForwardingEvent *evPtr = (ForwardingEvent *) evGPtr;
    ForwardingResult *resultPtr = evPtr->resultPtr;
    ReflectedChannel *rcPtr = evPtr->rcPtr;
    Tcl_Interp *interp = rcPtr->interp;
    ForwardParam *paramPtr = evPtr->param;
    Tcl_Obj *resObj = NULL;	/* Interp result of InvokeTclMethod */
    ReflectedChannelMap *rcmPtr;/* Map of reflected channels with handlers in
                                 * this interp. */
    Tcl_HashEntry *hPtr;	/* Entry in the above map */

    /*
     * Ignore the event if no one is waiting for its result anymore.
     */

    if (!resultPtr) {

	 * We remove the channel from both interpreter and thread maps before
	 * releasing the memory, to prevent future accesses (like by
	 * 'postevent') from finding and dereferencing a dangling pointer.
	 */

	rcmPtr = GetReflectedChannelMap(interp);
	hPtr = Tcl_FindHashEntry(&rcmPtr->map,
                Tcl_GetChannelName(rcPtr->chan));
	Tcl_DeleteHashEntry(hPtr);

	rcmPtr = GetThreadReflectedChannelMap();
	hPtr = Tcl_FindHashEntry(&rcmPtr->map,
                Tcl_GetChannelName(rcPtr->chan));
	Tcl_DeleteHashEntry(hPtr);
	MarkDead(rcPtr);
	break;
    }

    case ForwardedInput: {
	Tcl_Obj *toReadObj;

	    } else {
		if (bytec > 0) {
		    memcpy(paramPtr->input.buf, bytev, bytec);
		}
		paramPtr->input.toRead = bytec;
	    }
	}
        Tcl_Release(rcPtr);
        Tcl_DecrRefCount(toReadObj);
	break;
    }

    case ForwardedOutput: {
	Tcl_Obj *bufObj = Tcl_NewByteArrayObj((unsigned char *)
                paramPtr->output.buf, paramPtr->output.toWrite);
        Tcl_IncrRefCount(bufObj);

        Tcl_Preserve(rcPtr);
	if (InvokeTclMethod(rcPtr, METH_WRITE, bufObj, NULL, &resObj) != TCL_OK) {
	    int code = ErrnoReturn(rcPtr, resObj);

	    if (code < 0) {
		paramPtr->base.code = code;
	    } else {
		ForwardSetObjError(paramPtr, resObj);

	    } else if (written==0 || paramPtr->output.toWrite<written) {
		ForwardSetStaticError(paramPtr, msg_write_toomuch);
		paramPtr->output.toWrite = -1;
	    } else {
		paramPtr->output.toWrite = written;
	    }
	}
        Tcl_Release(rcPtr);
        Tcl_DecrRefCount(bufObj);
	break;
    }

    case ForwardedSeek: {
	Tcl_Obj *offObj;
	Tcl_Obj *baseObj;

	    } else {
		Tcl_DecrRefCount(resObj);
		resObj = MarshallError(interp);
		ForwardSetObjError(paramPtr, resObj);
		paramPtr->seek.offset = -1;
	    }
	}
        Tcl_Release(rcPtr);
        Tcl_DecrRefCount(offObj);
        Tcl_DecrRefCount(baseObj);
	break;
    }

    case ForwardedWatch: {
	Tcl_Obj *maskObj = DecodeEventMask(paramPtr->watch.mask);
        /* assert maskObj.refCount == 1 */

        Tcl_Preserve(rcPtr);
	rcPtr->interest = paramPtr->watch.mask;
	(void) InvokeTclMethod(rcPtr, METH_WATCH, maskObj, NULL, NULL);
	Tcl_DecrRefCount(maskObj);
        Tcl_Release(rcPtr);
	break;
    }

    case ForwardedBlock: {
	Tcl_Obj *blockObj = Tcl_NewBooleanObj(!paramPtr->block.nonblocking);

        Tcl_IncrRefCount(blockObj);
        Tcl_Preserve(rcPtr);
	if (InvokeTclMethod(rcPtr, METH_BLOCKING, blockObj, NULL,
                &resObj) != TCL_OK) {
	    ForwardSetObjError(paramPtr, resObj);
	}
        Tcl_Release(rcPtr);
        Tcl_DecrRefCount(blockObj);
	break;
    }

    case ForwardedSetOpt: {
	Tcl_Obj *optionObj = Tcl_NewStringObj(paramPtr->setOpt.name, -1);
	Tcl_Obj *valueObj  = Tcl_NewStringObj(paramPtr->setOpt.value, -1);

        Tcl_IncrRefCount(optionObj);
        Tcl_IncrRefCount(valueObj);
        Tcl_Preserve(rcPtr);
	if (InvokeTclMethod(rcPtr, METH_CONFIGURE, optionObj, valueObj,
                &resObj) != TCL_OK) {
	    ForwardSetObjError(paramPtr, resObj);
	}
        Tcl_Release(rcPtr);
        Tcl_DecrRefCount(optionObj);
        Tcl_DecrRefCount(valueObj);
	break;
    }

    case ForwardedGetOpt: {
	/*
	 * Retrieve the value of one option.
	 */

	Tcl_Obj *optionObj = Tcl_NewStringObj(paramPtr->getOpt.name, -1);

        Tcl_IncrRefCount(optionObj);
        Tcl_Preserve(rcPtr);
	if (InvokeTclMethod(rcPtr, METH_CGET, optionObj, NULL, &resObj)!=TCL_OK){
	    ForwardSetObjError(paramPtr, resObj);
	} else {
	    TclDStringAppendObj(paramPtr->getOpt.value, resObj);
	}
        Tcl_Release(rcPtr);
        Tcl_DecrRefCount(optionObj);
	break;
    }

    case ForwardedGetOptAll:
	/*
	 * Retrieve all options.
	 */

        Tcl_Preserve(rcPtr);
	if (InvokeTclMethod(rcPtr, METH_CGETALL, NULL, NULL, &resObj) != TCL_OK){
	    ForwardSetObjError(paramPtr, resObj);
	} else {
	    /*
	     * Extract list, validate that it is a list, and #elements. See
	     * NOTE (4) as well.
	     */

	    Tcl_Size listc;
	    Tcl_Obj **listv;

	    if (TclListObjGetElements(interp, resObj, &listc,
                    &listv) != TCL_OK) {
		Tcl_DecrRefCount(resObj);
		resObj = MarshallError(interp);
		ForwardSetObjError(paramPtr, resObj);
	    } else if ((listc % 2) == 1) {
		/*
		 * Odd number of elements is wrong. [x].
		 */

		if (len) {
		    TclDStringAppendLiteral(paramPtr->getOpt.value, " ");
		    Tcl_DStringAppend(paramPtr->getOpt.value, str, len);
		}
	    }
	}
        Tcl_Release(rcPtr);
	break;

    case ForwardedTruncate: {
	Tcl_Obj *lenObj = Tcl_NewWideIntObj(paramPtr->truncate.length);

	Tcl_IncrRefCount(lenObj);
	Tcl_Preserve(rcPtr);