Tcl Source Code

				 * the transformation. Used to execute the
				 * code below. */
    Tcl_Obj *command;		/* Tcl code to execute for a buffer */
    ResultBuffer result;	/* Internal buffer used to store the result of
				 * a transformation of incoming data. Also
				 * serves as buffer of all data not yet
				 * consumed by the reader. */
    int refCount;
};

static void
PreserveData(
    TransformChannelData *dataPtr)
{
    dataPtr->refCount++;
}

static void
ReleaseData(
    TransformChannelData *dataPtr)
{
    if (--dataPtr->refCount) {
	return;
    }
    ResultClear(&dataPtr->result);
    Tcl_DecrRefCount(dataPtr->command);
    ckfree(dataPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclChannelTransform --
 *
 *	Implements the Tcl "testchannel transform" debugging command. This is

    Tcl_Interp *interp,		/* Interpreter for result. */
    Tcl_Channel chan,		/* Channel to transform. */
    Tcl_Obj *cmdObjPtr)		/* Script to use for transform. */
{
    Channel *chanPtr;		/* The actual channel. */
    ChannelState *statePtr;	/* State info for channel. */
    int mode;			/* Read/write mode of the channel. */
    int objc;
    TransformChannelData *dataPtr;
    Tcl_DString ds;

    if (chan == NULL) {
	return TCL_ERROR;
    }

    if (TCL_OK != Tcl_ListObjLength(interp, cmdObjPtr, &objc)) {
	Tcl_SetObjResult(interp,
		Tcl_NewStringObj("-command value is not a list", -1));
	return TCL_ERROR;
    }

    chanPtr = (Channel *) chan;
    statePtr = chanPtr->state;
    chanPtr = statePtr->topChanPtr;
    chan = (Tcl_Channel) chanPtr;
    mode = (statePtr->flags & (TCL_READABLE|TCL_WRITABLE));

    /*
     * Now initialize the transformation state and stack it upon the specified
     * channel. One of the necessary things to do is to retrieve the blocking
     * regime of the underlying channel and to use the same for us too.
     */

    dataPtr = ckalloc(sizeof(TransformChannelData));

    dataPtr->refCount = 1;
    Tcl_DStringInit(&ds);
    Tcl_GetChannelOption(interp, chan, "-blocking", &ds);
    dataPtr->readIsFlushed = 0;
    dataPtr->flags = 0;
    if (ds.string[0] == '0') {
	dataPtr->flags |= CHANNEL_ASYNC;
    }

    ResultInit(&dataPtr->result);

    dataPtr->self = Tcl_StackChannel(interp, &transformChannelType, dataPtr,
	    mode, chan);
    if (dataPtr->self == NULL) {
	Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp),
		"\nfailed to stack channel \"%s\"", Tcl_GetChannelName(chan));


	ReleaseData(dataPtr);
	return TCL_ERROR;
    }

    /*
     * At last initialize the transformation at the script level.
     */

    PreserveData(dataPtr);
    if ((dataPtr->mode & TCL_WRITABLE) && ExecuteCallback(dataPtr, NULL,
	    A_CREATE_WRITE, NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE) != TCL_OK){
	Tcl_UnstackChannel(interp, chan);
	ReleaseData(dataPtr);
	return TCL_ERROR;
    }

    if ((dataPtr->mode & TCL_READABLE) && ExecuteCallback(dataPtr, NULL,
	    A_CREATE_READ, NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE) != TCL_OK) {
	ExecuteCallback(dataPtr, NULL, A_DELETE_WRITE, NULL, 0, TRANSMIT_DONT,
		P_NO_PRESERVE);
	Tcl_UnstackChannel(interp, chan);
	ReleaseData(dataPtr);
	return TCL_ERROR;
    }

    ReleaseData(dataPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * ExecuteCallback --

				 * interpreters. */
{
    Tcl_Obj *resObj;		/* See below, switch (transmit). */
    int resLen;
    unsigned char *resBuf;
    Tcl_InterpState state = NULL;
    int res = TCL_OK;
    Tcl_Obj *command = TclListObjCopy(NULL, dataPtr->command);
    Tcl_Interp *eval = dataPtr->interp;

    Tcl_Preserve(eval);

    /*
     * Step 1, create the complete command to execute. Do this by appending
     * operation and buffer to operate upon to a copy of the callback
     * definition. We *cannot* create a list containing 3 objects and then use
     * 'Tcl_EvalObjv', because the command may contain additional prefixed
     * arguments. Feather's curried commands would come in handy here.
     */

    if (preserve == P_PRESERVE) {
	state = Tcl_SaveInterpState(eval, res);
    }

    Tcl_IncrRefCount(command);

    Tcl_ListObjAppendElement(NULL, command, Tcl_NewStringObj((char *) op, -1));




    /*
     * Use a byte-array to prevent the misinterpretation of binary data coming
     * through as UTF while at the tcl level.
     */


    Tcl_ListObjAppendElement(NULL, command, Tcl_NewByteArrayObj(buf, bufLen));




    /*
     * Step 2, execute the command at the global level of the interpreter used
     * to create the transformation. Destroy the command afterward. If an
     * error occured and the current interpreter is defined and not equal to
     * the interpreter for the callback, then copy the error message into
     * current interpreter. Don't copy if in preservation mode.
     */

    res = Tcl_EvalObjEx(eval, command, TCL_EVAL_GLOBAL);
    Tcl_DecrRefCount(command);
    command = NULL;

    if ((res != TCL_OK) && (interp != NULL) && (eval != interp)
	    && (preserve == P_NO_PRESERVE)) {
	Tcl_SetObjResult(interp, Tcl_GetObjResult(eval));
	Tcl_Release(eval);
	return res;
    }

    /*
     * Step 3, transmit a possible conversion result to the underlying
     * channel, or ourselves.
     */

    switch (transmit) {
    case TRANSMIT_DONT:
	/* nothing to do */
	break;

    case TRANSMIT_DOWN:
	resObj = Tcl_GetObjResult(eval);
	resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen);
	Tcl_WriteRaw(Tcl_GetStackedChannel(dataPtr->self), (char *) resBuf,
		resLen);
	break;

    case TRANSMIT_SELF:
	resObj = Tcl_GetObjResult(eval);
	resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen);
	Tcl_WriteRaw(dataPtr->self, (char *) resBuf, resLen);
	break;

    case TRANSMIT_IBUF:
	resObj = Tcl_GetObjResult(eval);
	resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen);
	ResultAdd(&dataPtr->result, resBuf, resLen);
	break;

    case TRANSMIT_NUM:
	/*
	 * Interpret result as integer number.
	 */

	resObj = Tcl_GetObjResult(eval);
	TclGetIntFromObj(eval, resObj, &dataPtr->maxRead);
	break;
    }

    Tcl_ResetResult(eval);
    if (preserve == P_PRESERVE) {
	(void) Tcl_RestoreInterpState(eval, state);
    }

    Tcl_Release(eval);







    return res;
}

/*
 *----------------------------------------------------------------------
 *
 * TransformBlockModeProc --

    /*
     * Now flush data waiting in internal buffers to output and input. The
     * input must be done despite the fact that there is no real receiver for
     * it anymore. But the scripts might have sideeffects other parts of the
     * system rely on (f.e. signaling the close to interested parties).
     */

    PreserveData(dataPtr);
    if (dataPtr->mode & TCL_WRITABLE) {
	ExecuteCallback(dataPtr, interp, A_FLUSH_WRITE, NULL, 0,
		TRANSMIT_DOWN, P_PRESERVE);
    }

    if ((dataPtr->mode & TCL_READABLE) && !dataPtr->readIsFlushed) {
	dataPtr->readIsFlushed = 1;
	ExecuteCallback(dataPtr, interp, A_FLUSH_READ, NULL, 0, TRANSMIT_IBUF,
		P_PRESERVE);
    }

    if (dataPtr->mode & TCL_WRITABLE) {
	ExecuteCallback(dataPtr, interp, A_DELETE_WRITE, NULL, 0,
		TRANSMIT_DONT, P_PRESERVE);
    }
    if (dataPtr->mode & TCL_READABLE) {
	ExecuteCallback(dataPtr, interp, A_DELETE_READ, NULL, 0,
		TRANSMIT_DONT, P_PRESERVE);
    }
    ReleaseData(dataPtr);

    /*
     * General cleanup.
     */



    ReleaseData(dataPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TransformInputProc --

	 */
	return 0;
    }

    gotBytes = 0;
    downChan = Tcl_GetStackedChannel(dataPtr->self);

    PreserveData(dataPtr);
    while (toRead > 0) {
	/*
	 * Loop until the request is satisfied (or no data is available from
	 * below, possibly EOF).
	 */

	copied = ResultCopy(&dataPtr->result, UCHARP(buf), toRead);
	toRead -= copied;
	buf += copied;
	gotBytes += copied;

	if (toRead == 0) {
	    /*
	     * The request was completely satisfied from our buffers. We can
	     * break out of the loop and return to the caller.
	     */

	    break;
	}

	/*
	 * Length (dataPtr->result) == 0, toRead > 0 here. Use the incoming
	 * 'buf'! as target to store the intermediary information read from
	 * the underlying channel.
	 *

	if (dataPtr->maxRead >= 0) {
	    if (dataPtr->maxRead < toRead) {
		toRead = dataPtr->maxRead;
	    }
	} /* else: 'maxRead < 0' == Accept the current value of toRead. */
	if (toRead <= 0) {
	    break;
	}

	/*
	 * Get bytes from the underlying channel.
	 */

	read = Tcl_ReadRaw(downChan, buf, toRead);
	if (read < 0) {
	    /*
	     * Report errors to caller. EAGAIN is a special situation. If we
	     * had some data before we report that instead of the request to
	     * re-try.
	     */
		int error = Tcl_GetErrno();

	    if ((error == EAGAIN) && (gotBytes > 0)) {
		break;
	    }

	    *errorCodePtr = error;
	    gotBytes = -1;
	    break;
	} else if (read == 0) {
	    /*
	     * Check wether we hit on EOF in the underlying channel or not. If
	     * not differentiate between blocking and non-blocking modes. In
	     * non-blocking mode we ran temporarily out of data. Signal this
	     * to the caller via EWOULDBLOCK and error return (-1). In the
	     * other cases we simply return what we got and let the caller
	     * wait for more. On the other hand, if we got an EOF we have to
	     * convert and flush all waiting partial data.
	     */

	    if (!Tcl_Eof(downChan)) {
		if ((gotBytes == 0) && (dataPtr->flags & CHANNEL_ASYNC)) {
		    *errorCodePtr = EWOULDBLOCK;
		    gotBytes = -1;
		}
		break;
	    }

	    if (dataPtr->readIsFlushed) {
		/*
		 * Already flushed, nothing to do anymore.
		 */

		break;
	    }

	    dataPtr->readIsFlushed = 1;
	    ExecuteCallback(dataPtr, NULL, A_FLUSH_READ, NULL, 0,
		    TRANSMIT_IBUF, P_PRESERVE);

	    if (ResultEmpty(&dataPtr->result)) {
		/*
		 * We had nothing to flush.
		 */

		break;
	    }

	    continue;		/* at: while (toRead > 0) */
	} /* read == 0 */

	/*
	 * Transform the read chunk and add the result to our read buffer
	 * (dataPtr->result).
	 */

	if (ExecuteCallback(dataPtr, NULL, A_READ, UCHARP(buf), read,
		TRANSMIT_IBUF, P_PRESERVE) != TCL_OK) {
	    *errorCodePtr = EINVAL;
	    gotBytes = -1;
	    break;
	}
    } /* while toRead > 0 */
    ReleaseData(dataPtr);

    return gotBytes;
}

/*
 *----------------------------------------------------------------------
 *

	/*
	 * Catch a no-op.
	 */

	return 0;
    }

    PreserveData(dataPtr);
    if (ExecuteCallback(dataPtr, NULL, A_WRITE, UCHARP(buf), toWrite,
	    TRANSMIT_DOWN, P_NO_PRESERVE) != TCL_OK) {
	*errorCodePtr = EINVAL;
	toWrite = -1;
    }
    ReleaseData(dataPtr);

    return toWrite;
}

/*
 *----------------------------------------------------------------------
 *

    /*
     * It is a real request to change the position. Flush all data waiting for
     * output and discard everything in the input buffers. Then pass the
     * request down, unchanged.
     */

    PreserveData(dataPtr);
    if (dataPtr->mode & TCL_WRITABLE) {
	ExecuteCallback(dataPtr, NULL, A_FLUSH_WRITE, NULL, 0, TRANSMIT_DOWN,
		P_NO_PRESERVE);
    }

    if (dataPtr->mode & TCL_READABLE) {
	ExecuteCallback(dataPtr, NULL, A_CLEAR_READ, NULL, 0, TRANSMIT_DONT,
		P_NO_PRESERVE);
	ResultClear(&dataPtr->result);
	dataPtr->readIsFlushed = 0;
    }
    ReleaseData(dataPtr);

    return parentSeekProc(Tcl_GetChannelInstanceData(parent), offset, mode,
	    errorCodePtr);
}

/*
 *----------------------------------------------------------------------

    /*
     * It is a real request to change the position. Flush all data waiting for
     * output and discard everything in the input buffers. Then pass the
     * request down, unchanged.
     */

    PreserveData(dataPtr);
    if (dataPtr->mode & TCL_WRITABLE) {
	ExecuteCallback(dataPtr, NULL, A_FLUSH_WRITE, NULL, 0, TRANSMIT_DOWN,
		P_NO_PRESERVE);
    }

    if (dataPtr->mode & TCL_READABLE) {
	ExecuteCallback(dataPtr, NULL, A_CLEAR_READ, NULL, 0, TRANSMIT_DONT,
		P_NO_PRESERVE);
	ResultClear(&dataPtr->result);
	dataPtr->readIsFlushed = 0;
    }
    ReleaseData(dataPtr);

    /*
     * If we have a wide seek capability, we should stick with that.
     */

    if (parentWideSeekProc != NULL) {
	return parentWideSeekProc(parentData, offset, mode, errorCodePtr);

             */

            Tcl_DeleteEvents(ReflectEventDelete, rcPtr);

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

        Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
	return EOK;
    }

        /*
         * 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);
	if ((result != TCL_OK) && (interp != NULL)) {

	Tcl_DeleteHashEntry(hPtr);

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

	Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
	break;

    case ForwardedInput: {
	Tcl_Obj *toReadObj = Tcl_NewIntObj(paramPtr->input.toRead);
        Tcl_IncrRefCount(toReadObj);

        Tcl_Preserve(rcPtr);

MODULE_SCOPE void	TclFinalizeLock(void);
MODULE_SCOPE void	TclFinalizeMemorySubsystem(void);
MODULE_SCOPE void	TclFinalizeNotifier(void);
MODULE_SCOPE void	TclFinalizeObjects(void);
MODULE_SCOPE void	TclFinalizePreserve(void);
MODULE_SCOPE void	TclFinalizeSynchronization(void);
MODULE_SCOPE void	TclFinalizeThreadAlloc(void);
MODULE_SCOPE void	TclFinalizeThreadAllocThread(void);
MODULE_SCOPE void	TclFinalizeThreadData(void);
MODULE_SCOPE void	TclFinalizeThreadObjects(void);
MODULE_SCOPE double	TclFloor(const mp_int *a);
MODULE_SCOPE void	TclFormatNaN(double value, char *buffer);
MODULE_SCOPE int	TclFSFileAttrIndex(Tcl_Obj *pathPtr,
			    const char *attributeName, int *indexPtr);
MODULE_SCOPE int	TclNREvalFile(Tcl_Interp *interp, Tcl_Obj *pathPtr,

}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeThreadData --
 *
 *	This function cleans up the thread-local storage. Secondary, it cleans
 *	thread alloc cache.
 *	This is called once for each thread before thread exits.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Frees up all thread local storage.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeThreadData(void)
{
    TclFinalizeThreadDataThread();
#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
    TclFinalizeThreadAllocThread();
#endif
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeSynchronization --
 *

    objLockPtr = NULL;

    TclpFreeAllocMutex(listLockPtr);
    listLockPtr = NULL;

    TclpFreeAllocCache(NULL);
}

/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeThreadAllocThread --
 *
 *	This procedure is used to destroy single thread private resources used
 *	in this file. 
 * Called in TclpFinalizeThreadData when a thread exits (Tcl_FinalizeThread).
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
TclFinalizeThreadAllocThread(void)
{
    Cache *cachePtr = TclpGetAllocCache();
    if (cachePtr != NULL) {
	TclpFreeAllocCache(cachePtr);
    }
}

#else /* !(TCL_THREADS && USE_THREAD_ALLOC) */
/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetMemoryInfo --
 *

{
    if (ptr != NULL) {
	/*
	 * Called by the pthread lib when a thread exits
	 */

	TclFreeAllocCache(ptr);
	pthread_setspecific(key, NULL);

    } else if (initialized) {
	/*
	 * Called by us in TclFinalizeThreadAlloc() during the library
	 * finalization initiated from Tcl_Finalize()
	 */