Logo Search packages:      
Sourcecode: tcl8.6 version File versions

tclIORTrans.c

/*
 * tclIORTrans.c --
 *
 *    This file contains the implementation of Tcl's generic transformation
 *    reflection code, which allows the implementation of Tcl channel
 *    transformations in Tcl code.
 *
 *    Parts of this file are based on code contributed by Jean-Claude
 *    Wippler.
 *
 *    See TIP #230 for the specification of this functionality.
 *
 * Copyright (c) 2007-2008 ActiveState.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclIORTrans.c,v 1.3 2008/06/12 06:28:41 das Exp $
 */

#include <tclInt.h>
#include <tclIO.h>
#include <assert.h>

#ifndef EINVAL
#define EINVAL    9
#endif
#ifndef EOK
#define EOK 0
#endif

/* DUPLICATE of HaveVersion() in tclIO.c // TODO - MODULE_SCOPE */
static int        HaveVersion(const Tcl_ChannelType *typePtr,
                      Tcl_ChannelTypeVersion minimumVersion);

/*
 * Signatures of all functions used in the C layer of the reflection.
 */

static int        ReflectClose(ClientData clientData,
                      Tcl_Interp *interp);
static int        ReflectInput(ClientData clientData, char *buf,
                      int toRead, int *errorCodePtr);
static int        ReflectOutput(ClientData clientData, const char *buf,
                      int toWrite, int *errorCodePtr);
static void       ReflectWatch(ClientData clientData, int mask);
static int        ReflectBlock(ClientData clientData, int mode);
static Tcl_WideInt      ReflectSeekWide(ClientData clientData,
                      Tcl_WideInt offset, int mode, int *errorCodePtr);
static int        ReflectSeek(ClientData clientData, long offset,
                      int mode, int *errorCodePtr);
static int        ReflectGetOption(ClientData clientData,
                      Tcl_Interp *interp, const char *optionName,
                      Tcl_DString *dsPtr);
static int        ReflectSetOption(ClientData clientData,
                      Tcl_Interp *interp, const char *optionName,
                      const char *newValue);
static int        ReflectHandle(ClientData clientData, int direction,
                              ClientData* handle);
static int        ReflectNotify(ClientData clientData, int mask);

/*
 * The C layer channel type/driver definition used by the reflection. This is
 * a version 3 structure.
 */

static Tcl_ChannelType tclRTransformType = {
    "tclrtransform",       /* Type name.                                  */
    TCL_CHANNEL_VERSION_5, /* v5 channel */
    ReflectClose,          /* Close channel, clean instance data          */
    ReflectInput,          /* Handle read request                         */
    ReflectOutput,         /* Handle write request                        */
    ReflectSeek,           /* Move location of access point.              */
    ReflectSetOption,      /* Set options.                                */
    ReflectGetOption,      /* Get options.                                */
    ReflectWatch,          /* Initialize notifier                         */
    ReflectHandle,         /* Get OS handle from the channel.             */
    NULL,                  /* No close2 support.               NULL'able  */
    ReflectBlock,          /* Set blocking/nonblocking.                   */
    NULL,                  /* Flush channel. Not used by core. NULL'able  */
    ReflectNotify,         /* Handle events.                              */
    ReflectSeekWide,       /* Move access point (64 bit).                 */
    NULL,                  /* thread action */
    NULL,                  /* truncate */
};

/*
 * Structure of the buffer to hold transform results to be consumed by higher
 * layers upon reading from the channel, plus the functions to manage such.
 */

typedef struct _ResultBuffer_ {
  unsigned char* buf;       /* Reference to the buffer area */
  int            allocated; /* Allocated size of the buffer area */
  int            used;      /* Number of bytes in the buffer, <= allocated */
} ResultBuffer;

#define ResultLength(r) ((r)->used)
/* static int ResultLength        (ResultBuffer* r); */

static void  ResultClear          (ResultBuffer* r);
static void  ResultInit           (ResultBuffer* r);
static void  ResultAdd            (ResultBuffer* r, unsigned char* buf, int toWrite);
static int   ResultCopy           (ResultBuffer* r, unsigned char* buf, int toRead);

#define RB_INCREMENT (512)

/*
 * Convenience macro to make some casts easier to use.
 */

#define UCHARP(x) ((unsigned char *) (x))

/*
 * Instance data for a reflected transformation. ===========================
 */

typedef struct {
    Tcl_Channel chan;         /* Back reference to the channel of the
                         * transformation itself. */
    Tcl_Channel parent;         /* Reference to the channel the transformation
                         * was pushed on. */
    Tcl_Interp *interp;       /* Reference to the interpreter containing the
                         * Tcl level part of the channel. */
    Tcl_Obj    *handle;         /* Reference to transform handle. Also stored
                         * in the argv, see below. The separate field
                         * gives us direct access, needed when working
                         * with the reflection maps.
                         */
#ifdef TCL_THREADS
    Tcl_ThreadId thread;      /* Thread the 'interp' belongs to. */
#endif

    Tcl_TimerToken timer;

    /* See [==] as well.
     * Storage for the command prefix and the additional words required for
     * the invocation of methods in the command handler.
     *
     * argv [0] ... [.] | [argc-2] [argc-1] | [argc]  [argc+2]
     *      cmd ... pfx | method   chan     | detail1 detail2
     *      ~~~~ CT ~~~            ~~ CT ~~
     *
     * CT = Belongs to the 'Command handler Thread'.
     */

    int argc;                 /* Number of preallocated words - 2 */
    Tcl_Obj **argv;           /* Preallocated array for calling the handler.
                         * args[0] is placeholder for cmd word.
                         * Followed by the arguments in the prefix,
                         * plus 4 placeholders for method, channel,
                         * and at most two varying (method specific)
                         * words. */
    int methods;        /* Bitmask of supported methods */

    /*
     * NOTE (9): Should we have predefined shared literals for the method
     * names?
     */

    int mode;                 /* Mask of R/W mode */
    int nonblocking;            /* Flag: Channel is blocking or not */
    int readIsDrained;          /* Flag: Read buffers are flushed*/

    ResultBuffer result;

} ReflectedTransform;

/*
 * Structure of the table mapping from transform handles to reflected
 * transform (channels). Each interpreter which has the handler command for
 * one or more reflected transforms records them in such a table, so that we
 * are able to find them during interpreter/thread cleanup even if the actual
 * channel they belong to was moved to a different interpreter and/or thread.
 *
 * The table is reachable via the standard interpreter AssocData, the key is
 * defined below.
 */

typedef struct {
    Tcl_HashTable map;
} ReflectedTransformMap;

#define RTMKEY "ReflectedTransformMap"

/*
 * Method literals. ==================================================
 */

static const char *methodNames[] = {
    "clear",            /* OPT */
    "drain",            /* OPT, drain => read */
    "finalize",         /*     */
    "flush",            /* OPT, flush => write */
    "initialize", /*     */
    "limit?",           /* OPT */
    "read",       /* OPT */
    "write",            /* OPT */
    NULL
};
typedef enum {
    METH_CLEAR,
    METH_DRAIN,
    METH_FINAL,
    METH_FLUSH,
    METH_INIT,
    METH_LIMIT,
    METH_READ,
    METH_WRITE
} MethodName;

#define FLAG(m) (1 << (m))
#define REQUIRED_METHODS \
      (FLAG(METH_INIT) | FLAG(METH_FINAL))
#define RANDW \
      (TCL_READABLE | TCL_WRITABLE)

#define IMPLIES(a,b)    ((!(a)) || (b))
#define NEGIMPL(a,b)
#define HAS(x,f)  (x & FLAG(f))

#ifdef TCL_THREADS
/*
 * Thread specific types and structures.
 *
 * We are here essentially creating a very specific implementation of 'thread
 * send'.
 */

/*
 * Enumeration of all operations which can be forwarded.
 */

typedef enum {
    ForwardedClear,
    ForwardedClose,
    ForwardedDrain,
    ForwardedFlush,
    ForwardedInput,
    ForwardedLimit,
    ForwardedOutput
} ForwardedOperation;

/*
 * Event used to forward driver invocations to the thread actually managing
 * the channel. We cannot construct the command to execute and forward
 * that. Because then it will contain a mixture of Tcl_Obj's belonging to both
 * the command handler thread (CT), and the thread managing the channel (MT),
 * executed in CT. Tcl_Obj's are not allowed to cross thread boundaries. So we
 * forward an operation code, the argument details, and reference to results.
 * The command is assembled in the CT and belongs fully to that thread. No
 * sharing problems.
 */

typedef struct ForwardParamBase {
    int code;                 /* O: Ok/Fail of the cmd handler */
    char *msgStr;       /* O: Error message for handler failure */
    int mustFree;       /* O: True if msgStr is allocated, false if
                         * otherwise (static). */
} ForwardParamBase;

/*
 * Operation specific parameter/result structures. (These are "subtypes" of
 * ForwardParamBase. Where an operation does not need any special types, it
 * has no "subtype" and just uses ForwardParamBase, as listed above.)
 */

struct ForwardParamTransform {
    ForwardParamBase base;    /* "Supertype". MUST COME FIRST. */
    char *buf;                /* I: Bytes to transform,
                         * O: Bytes in transform result */
    int size;                 /* I: #bytes to transform,
                         * O: #bytes in the transform result */
};
struct ForwardParamLimit {
    ForwardParamBase base;    /* "Supertype". MUST COME FIRST. */
    int max;                  /* O: Character read limit */
};

/*
 * Now join all these together in a single union for convenience.
 */

typedef union ForwardParam {
    ForwardParamBase base;
    struct ForwardParamTransform transform;
    struct ForwardParamLimit     limit;
} ForwardParam;

/*
 * Forward declaration.
 */

typedef struct ForwardingResult ForwardingResult;

/*
 * General event structure, with reference to operation specific data.
 */

typedef struct ForwardingEvent {
    Tcl_Event event;          /* Basic event data, has to be first item */
    ForwardingResult *resultPtr;
    ForwardedOperation op;    /* Forwarded driver operation */
    ReflectedTransform *rtPtr;      /* Channel instance */
    ForwardParam *param;      /* Packaged arguments and return values, a
                         * ForwardParam pointer. */
} ForwardingEvent;

/*
 * Structure to manage the result of the forwarding. This is not the result of
 * the operation itself, but about the success of the forward event itself.
 * The event can be successful, even if the operation which was forwarded
 * failed. It is also there to manage the synchronization between the involved
 * threads.
 */

struct ForwardingResult {
    Tcl_ThreadId src;         /* Originating thread. */
    Tcl_ThreadId dst;         /* Thread the op was forwarded to. */
    Tcl_Interp *dsti;         /* Interpreter in the thread the op was
                         * forwarded to. */
    Tcl_Condition done;       /* Condition variable the forwarder blocks
                         * on. */
    int result;               /* TCL_OK or TCL_ERROR */
    ForwardingEvent *evPtr;   /* Event the result belongs to. */
    ForwardingResult *prevPtr, *nextPtr;
                        /* Links into the list of pending forwarded
                         * results. */
};

typedef struct ThreadSpecificData {
    /*
     * Table of all reflected transformations owned by this thread.
     */

    ReflectedTransformMap* rtmPtr;
} ThreadSpecificData;

static Tcl_ThreadDataKey dataKey;

/*
 * List of forwarded operations which have not completed yet, plus the mutex
 * to protect the access to this process global list.
 */

static ForwardingResult *forwardList = NULL;
TCL_DECLARE_MUTEX(rtForwardMutex)

/*
 * Function containing the generic code executing a forward, and wrapper
 * macros for the actual operations we wish to forward. Uses ForwardProc as
 * the event function executed by the thread receiving a forwarding event
 * (which executes the appropriate function and collects the result, if any).
 *
 * The two ExitProcs are handlers so that things do not deadlock when either
 * thread involved in the forwarding exits. They also clean things up so that
 * we don't leak resources when threads go away.
 */

static void       ForwardOpToOwnerThread(ReflectedTransform *rtPtr,
                      ForwardedOperation op, const VOID *param);
static int        ForwardProc(Tcl_Event *evPtr, int mask);
static void       SrcExitProc(ClientData clientData);

#define FreeReceivedError(p) \
      if ((p)->base.mustFree) { \
          ckfree((p)->base.msgStr); \
      }
#define PassReceivedErrorInterp(i,p) \
      if ((i) != NULL) { \
          Tcl_SetChannelErrorInterp((i), \
                Tcl_NewStringObj((p)->base.msgStr, -1)); \
      } \
      FreeReceivedError(p)
#define PassReceivedError(c,p) \
      Tcl_SetChannelError((c), Tcl_NewStringObj((p)->base.msgStr, -1)); \
      FreeReceivedError(p)
#define ForwardSetStaticError(p,emsg) \
      (p)->base.code = TCL_ERROR; \
      (p)->base.mustFree = 0; \
      (p)->base.msgStr = (char *) (emsg)
#define ForwardSetDynamicError(p,emsg) \
      (p)->base.code = TCL_ERROR; \
      (p)->base.mustFree = 1; \
      (p)->base.msgStr = (char *) (emsg)

static void       ForwardSetObjError(ForwardParam *p,
                      Tcl_Obj *objPtr);

static ReflectedTransformMap *      GetThreadReflectedTransformMap(void);
static void       DeleteThreadReflectedTransformMap(ClientData clientData);

#endif /* TCL_THREADS */

#define SetChannelErrorStr(c,msgStr) \
      Tcl_SetChannelError((c), Tcl_NewStringObj((msgStr), -1))

static Tcl_Obj *  MarshallError(Tcl_Interp *interp);
static void       UnmarshallErrorResult(Tcl_Interp *interp,
                      Tcl_Obj *msgObj);

/*
 * Static functions for this file:
 */

static Tcl_Obj *  DecodeEventMask(int mask);
static ReflectedTransform * NewReflectedTransform(Tcl_Interp *interp,
                      Tcl_Obj *cmdpfxObj, int mode, Tcl_Obj *handleObj,
                      Tcl_Channel parentChan);
static Tcl_Obj *  NextHandle(void);
static void       FreeReflectedTransform(ReflectedTransform *rtPtr);
static int        InvokeTclMethod(ReflectedTransform *rtPtr,
                      const char *method, Tcl_Obj *argOneObj,
                      Tcl_Obj *argTwoObj, Tcl_Obj **resultObjPtr);

static ReflectedTransformMap *      GetReflectedTransformMap(Tcl_Interp *interp);
static void       DeleteReflectedTransformMap(ClientData clientData,
                      Tcl_Interp *interp);

/*
 * Global constant strings (messages). ==================
 * These string are used directly as bypass errors, thus they have to be valid
 * Tcl lists where the last element is the message itself. Hence the
 * list-quoting to keep the words of the message together. See also [x].
 */

static const char *msg_read_badlimit = "{Tcl driver returned bad read limit '0'}";
static const char *msg_read_unsup = "{read not supported by Tcl driver}";
static const char *msg_write_unsup = "{write not supported by Tcl driver}";
#ifdef TCL_THREADS
static const char *msg_send_originlost = "{Channel thread lost}";
static const char *msg_send_dstlost = "{Owner lost}";
#endif /* TCL_THREADS */
static const char *msg_dstlost    = "-code 1 -level 0 -errorcode NONE -errorinfo {} -errorline 1 {Owner lost}";

/*
 * Timer management (flushing out buffered data via artificial events).
 */

/*
 * Number of milliseconds to wait before firing an event to try to
 * flush out information waiting in buffers (fileevent support).
 */

#define FLUSH_DELAY (5)

static void TimerKill  (ReflectedTransform* rtPtr);
static void TimerSetup (ReflectedTransform* rtPtr);
static void TimerRun   (ClientData clientData);

/*
 * Helper functions encapsulating some of the thread forwarding to make the
 * control flow in callers easier.
 */

static int  TransformRead  (ReflectedTransform* rtPtr, int* errorCodePtr, unsigned char* buf, int toRead);
static int  TransformWrite (ReflectedTransform* rtPtr, int* errorCodePtr, unsigned char* buf, int toWrite);
static int  TransformDrain (ReflectedTransform* rtPtr, int* errorCodePtr);
static int  TransformFlush (ReflectedTransform* rtPtr, int* errorCodePtr, int op);
static void TransformClear (ReflectedTransform* rtPtr);
static int  TransformLimit (ReflectedTransform* rtPtr, int* errorCodePtr, int* maxPtr);

/* op'codes for TransformFlush */
#define FLUSH_WRITE   1
#define FLUSH_DISCARD 0

/*
 * Main methods to plug into the 'chan' ensemble'. ==================
 */

/*
 *----------------------------------------------------------------------
 *
 * TclChanPushObjCmd --
 *
 *    This function is invoked to process the "chan push" Tcl command.
 *    See the user documentation for details on what it does.
 *
 * Results:
 *    A standard Tcl result. The handle of the new channel is placed in the
 *    interp result.
 *
 * Side effects:
 *    Creates a new channel.
 *
 *----------------------------------------------------------------------
 */

int
TclChanPushObjCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    ReflectedTransform *rtPtr;      /* Instance data of the new (transform) channel */
    Tcl_Obj*    chanObj;        /* Handle of parent channel */
    Tcl_Channel parentChan;     /* Token of parent channel */
    int mode;                 /* R/W mode of parent, later the new
                         * channel. Has to match the abilities of the
                         * handler commands */
    Tcl_Obj *cmdObj;          /* Command prefix, list of words */
    Tcl_Obj *cmdNameObj;      /* Command name */
    Tcl_Obj *rtId;            /* Handle of the new transform (channel) */
    Tcl_Obj *modeObj;         /* mode in obj form for method call */

    int listc;                /* Result of 'initialize', and of */
    Tcl_Obj **listv;          /* its sublist in the 2nd element */
    int methIndex;            /* Encoded method name */
    int result;               /* Result code for 'initialize' */
    Tcl_Obj *resObj;          /* Result data for 'initialize' */
    int methods;        /* Bitmask for supported methods. */
    Tcl_Obj *err;       /* Error message */
    ReflectedTransformMap *rtmPtr;
                        /* Map of reflected transforms with handlers in
                         * this interp. */
    Tcl_HashEntry *hPtr;      /* Entry in the above map */
    int isNew;                /* Placeholder. */

    /*
     * Syntax:   chan push CHANNEL CMDPREFIX
     *           [0]  [1]  [2]     [3]
     *
     * Actually: rPush CHANNEL CMDPREFIX
     *           [0]   [1]     [2]
     */

#define CHAN      (1)
#define CMD (2)

    /*
     * Number of arguments...
     */

    if (objc != 3) {
      Tcl_WrongNumArgs(interp, 1, objv, "channel cmdprefix");
      return TCL_ERROR;
    }

    /*
     * First argument is a channel handle.
     */

    chanObj    = objv[CHAN];
    parentChan = Tcl_GetChannel (interp, Tcl_GetString (chanObj), &mode);
    if (parentChan == NULL) {
      return TCL_ERROR;
    }
    parentChan = Tcl_GetTopChannel (parentChan);

    /*
     * Second argument is command prefix, i.e. list of words, first word is
     * name of handler command, other words are fixed arguments. Run
     * 'initialize' method to get the list of supported methods. Validate
     * this.
     */

    cmdObj = objv[CMD];

    /*
     * Basic check that the command prefix truly is a list.
     */

    if (Tcl_ListObjIndex(interp, cmdObj, 0, &cmdNameObj) != TCL_OK) {
      return TCL_ERROR;
    }

    /*
     * Now create the transformation (channel).
     */

    rtId  = NextHandle();
    rtPtr = NewReflectedTransform(interp, cmdObj, mode, rtId, parentChan);

    /*
     * Invoke 'initialize' and validate that the handler is present and ok.
     * Squash the transformation if not.
     */

    modeObj = DecodeEventMask(mode);
    result  = InvokeTclMethod(rtPtr, "initialize", modeObj, NULL, &resObj);
    Tcl_DecrRefCount(modeObj);
    if (result != TCL_OK) {
      UnmarshallErrorResult(interp, resObj);
      Tcl_DecrRefCount(resObj);     /* Remove reference held from invoke */
      goto error;
    }

    /*
     * 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 (Tcl_ListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) {
      TclNewLiteralStringObj(err, "chan handler \"");
      Tcl_AppendObjToObj(err, cmdObj);
      Tcl_AppendToObj(err, " initialize\" returned non-list: ", -1);
      Tcl_AppendObjToObj(err, resObj);
      Tcl_SetObjResult(interp, err);
      Tcl_DecrRefCount(resObj);
      goto error;
    }

    methods = 0;
    while (listc > 0) {
      if (Tcl_GetIndexFromObj(interp, listv[listc-1], methodNames,
            "method", TCL_EXACT, &methIndex) != TCL_OK) {
          TclNewLiteralStringObj(err, "chan handler \"");
          Tcl_AppendObjToObj(err, cmdObj);
          Tcl_AppendToObj(err, " initialize\" returned ", -1);
          Tcl_AppendObjToObj(err, Tcl_GetObjResult(interp));
          Tcl_SetObjResult(interp, err);
          Tcl_DecrRefCount(resObj);
          goto error;
      }

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

    if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) {
      TclNewLiteralStringObj(err, "chan handler \"");
      Tcl_AppendObjToObj(err, cmdObj);
      Tcl_AppendToObj(err, "\" does not support all required methods", -1);
      Tcl_SetObjResult(interp, err);
      goto error;
    }

    /*
     * Mode tell us what the parent channel supports. The methods tell us what
     * the handler supports. We remove the non-supported bits from the mode
     * and check that the channel is not completely inacessible. Afterward the
     * mode tells us which methods are still required, and these methods will
     * also be supported by the handler, by design of the check.
     */

    if (!HAS(methods, METH_READ))  { mode &= ~TCL_READABLE; }
    if (!HAS(methods, METH_WRITE)) { mode &= ~TCL_WRITABLE; }

    if (!mode) {
      TclNewLiteralStringObj(err, "chan handler \"");
      Tcl_AppendObjToObj(err, cmdObj);
      Tcl_AppendToObj(err, "\" makes the channel inacessible", -1);
      Tcl_SetObjResult(interp, err);
      goto error;
    }

    /*
     * The mode and support for it is ok, now check the internal constraints.
     */

    if (!IMPLIES(HAS(methods, METH_DRAIN), HAS(methods, METH_READ))) {
      TclNewLiteralStringObj(err, "chan handler \"");
      Tcl_AppendObjToObj(err, cmdObj);
      Tcl_AppendToObj(err, "\" supports \"drain\" but not \"read\"", -1);
      Tcl_SetObjResult(interp, err);
      goto error;
    }

    if (!IMPLIES(HAS(methods, METH_FLUSH), HAS(methods, METH_WRITE))) {
      TclNewLiteralStringObj(err, "chan handler \"");
      Tcl_AppendObjToObj(err, cmdObj);
      Tcl_AppendToObj(err, "\" supports \"flush\" but not \"write\"", -1);
      Tcl_SetObjResult(interp, err);
      goto error;
    }

    Tcl_ResetResult(interp);

    /*
     * Everything is fine now.
     */

    rtPtr->methods = methods;
    rtPtr->mode    = mode;
    rtPtr->chan    = Tcl_StackChannel (interp, &tclRTransformType,
                               (ClientData) rtPtr, mode,
                               rtPtr->parent);

    /*
     * Register the transform in our our map for proper handling of deleted
     * interpreters and/or threads.
     */

    rtmPtr = GetReflectedTransformMap (interp);
    hPtr = Tcl_CreateHashEntry(&rtmPtr->map, Tcl_GetString(rtId),
          &isNew);
    if (!isNew && rtPtr != Tcl_GetHashValue(hPtr)) {
      Tcl_Panic("TclChanPushObjCmd: duplicate transformation handle");
    }
    Tcl_SetHashValue(hPtr, rtPtr);
#ifdef TCL_THREADS
    rtmPtr = GetThreadReflectedTransformMap();
    hPtr = Tcl_CreateHashEntry(&rtmPtr->map, Tcl_GetString(rtId),
          &isNew);
    Tcl_SetHashValue(hPtr, rtPtr);
#endif

    /*
     * Return the channel as the result of the command.
     */

    Tcl_AppendResult (interp, Tcl_GetChannelName (rtPtr->chan),
                (char*) NULL);
    return TCL_OK;

 error:
    /*
     * We are not going through ReflectClose as we never had a channel
     * structure.
     */

    FreeReflectedTransform(rtPtr);
    return TCL_ERROR;

#undef CHAN
#undef CMD
}

/*
 *----------------------------------------------------------------------
 *
 * TclChanPopObjCmd --
 *
 *    This function is invoked to process the "chan pop" Tcl command.
 *    See the user documentation for details on what it does.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    Posts events to a reflected channel, invokes event handlers. The
 *    latter implies that arbitrary side effects are possible.
 *
 *----------------------------------------------------------------------
 */

int
TclChanPopObjCmd(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv)
{
    /*
     * Syntax:   chan pop CHANNEL
     *           [0]  [1] [2]
     *
     * Actually: rPop CHANNEL
     *           [0]  [1]
     */

#define CHAN      (1)

    const char *chanId;       /* Tcl level channel handle */
    Tcl_Channel chan;         /* Channel associated to the handle */
    int         mode;           /* Channel r/w mode */

    /*
     * Number of arguments...
     */

    if (objc != 2) {
      Tcl_WrongNumArgs(interp, 1, objv, "channel");
      return TCL_ERROR;
    }

    /*
     * First argument is a channel, which may have a (reflected)
     * transformation.
     */

    chanId = TclGetString(objv[CHAN]);
    chan   = Tcl_GetChannel(interp, chanId, &mode);

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

    /* Removing transformations is generic, and not restricted to reflected
     * transformations.
     */

    Tcl_UnstackChannel(interp, chan);
    return TCL_OK;

#undef CHAN
}

/*
 * Channel error message marshalling utilities.
 */

static Tcl_Obj*
MarshallError(
    Tcl_Interp *interp)
{
    /*
     * Capture the result status of the interpreter into a string. => List of
     * options and values, followed by the error message. The result has
     * refCount 0.
     */

    Tcl_Obj *returnOpt = Tcl_GetReturnOptions(interp, TCL_ERROR);

    /*
     * => returnOpt.refCount == 0. We can append directly.
     */

    Tcl_ListObjAppendElement(NULL, returnOpt, Tcl_GetObjResult(interp));
    return returnOpt;
}

static void
UnmarshallErrorResult(
    Tcl_Interp *interp,
    Tcl_Obj *msgObj)
{
    int lc;
    Tcl_Obj **lv;
    int explicitResult;
    int numOptions;

    /*
     * Process the caught message.
     *
     * Syntax = (option value)... ?message?
     *
     * Bad syntax causes a panic. This is OK because the other side uses
     * Tcl_GetReturnOptions and list construction functions to marshall the
     * information; if we panic here, something has gone badly wrong already.
     */

    if (Tcl_ListObjGetElements(interp, msgObj, &lc, &lv) != TCL_OK) {
      Tcl_Panic("TclChanCaughtErrorBypass: Bad syntax of caught result");
    }
    if (interp == NULL) {
      return;
    }

    explicitResult = lc & 1;        /* Odd number of values? */
    numOptions = lc - explicitResult;

    if (explicitResult) {
      Tcl_SetObjResult(interp, lv[lc-1]);
    }

    (void) Tcl_SetReturnOptions(interp, Tcl_NewListObj(numOptions, lv));
    ((Interp *)interp)->flags &= ~ERR_ALREADY_LOGGED;
}

/*
 * Driver functions. ================================================
 */

/*
 *----------------------------------------------------------------------
 *
 * ReflectClose --
 *
 *    This function is invoked when the channel is closed, to delete the
 *    driver specific instance data.
 *
 * Results:
 *    A posix error.
 *
 * Side effects:
 *    Releases memory. Arbitrary, as it calls upon a script.
 *
 *----------------------------------------------------------------------
 */

static int
ReflectClose(
    ClientData clientData,
    Tcl_Interp *interp)
{
    ReflectedTransform *rtPtr = (ReflectedTransform *) clientData;
    int result;               /* Result code for 'close' */
    Tcl_Obj *resObj;          /* Result data for 'close' */
    ReflectedTransformMap *rtmPtr;/* Map of reflected transforms with handlers in
                         * this interp */
    Tcl_HashEntry *hPtr;      /* Entry in the above map */

    if (interp == NULL) {
      /*
       * This call comes from TclFinalizeIOSystem. There are no
       * interpreters, and therefore we cannot call upon the handler command
       * anymore. Threading is irrelevant as well. We simply clean up all
       * our C level data structures and leave the Tcl level to the other
       * finalization functions.
       */

      /*
       * THREADED => Forward this to the origin thread
       *
       * Note: DeleteThreadReflectedTransformMap() is the thread exit handler
       * for the origin thread. Use this to clean up the structure? Except
       * if lost?
       */

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

          ForwardOpToOwnerThread(rtPtr, ForwardedClose, &p);
          result = p.base.code;

          /*
           * FreeReflectedTransform is done in the forwarded operation!, in
           * the other thread. rtPtr here is gone!
           */

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

      FreeReflectedTransform(rtPtr);
      return EOK;
    }

    /*
     * In the reflected channel implementation a cleaned method mask here
     * implies that the channel creation was aborted, and "finalize" must not
     * be called. for transformations however we are not going through here on
     * such an abort, but directly through FreeReflectedTransform. So for us
     * that check is not necessary. We always go through 'finalize'.
     */

    if (HAS(rtPtr->methods, METH_DRAIN) && (!rtPtr->readIsDrained)) {
      int errorCode;
      if (!TransformDrain (rtPtr, &errorCode)) {
          return errorCode;
      }
    }

    if (HAS(rtPtr->methods, METH_FLUSH)) {
      int errorCode;
      if (!TransformFlush (rtPtr, &errorCode, FLUSH_WRITE)) {
          return errorCode;
      }
    }

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

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

      ForwardOpToOwnerThread(rtPtr, ForwardedClose, &p);
      result = p.base.code;

      /*
       * FreeReflectedTransform is done in the forwarded operation!, in the
       * other thread. rtPtr here is gone!
       */

      if (result != TCL_OK) {
          PassReceivedErrorInterp(interp, &p);
      }
    } else {
#endif
      result = InvokeTclMethod(rtPtr, "finalize", NULL, NULL, &resObj);
      if ((result != TCL_OK) && (interp != NULL)) {
          Tcl_SetChannelErrorInterp(interp, resObj);
      }

      Tcl_DecrRefCount(resObj);     /* Remove reference we held from the
                               * invoke */

      /*
       * Remove the transform from the map before releasing the memory, to
       * prevent future accesses from finding and dereferencing a dangling
       * pointer.
       *
       * NOTE: The transform may not be in the map. This is ok, that happens
       * when the transform was created in a different interpreter and/or
       * thread and then was moved here.
       */

      rtmPtr = GetReflectedTransformMap(interp);
      hPtr = Tcl_FindHashEntry (&rtmPtr->map, 
                          Tcl_GetString(rtPtr->handle));
      if (hPtr) {
          Tcl_DeleteHashEntry (hPtr);
      }
#ifdef TCL_THREADS
      /*
       * In a threaded interpreter we manage a per-thread map as well, to
       * allow us to survive if the script level pulls the rug out under a
       * channel by deleting the owning thread.
       */
 
        rtmPtr = GetThreadReflectedTransformMap();
      hPtr = Tcl_FindHashEntry (&rtmPtr->map, 
                          Tcl_GetString(rtPtr->handle));
      if (hPtr) {
          Tcl_DeleteHashEntry (hPtr);
      }
#endif

      FreeReflectedTransform(rtPtr);
#ifdef TCL_THREADS
    }
#endif
    return (result == TCL_OK) ? EOK : EINVAL;
}

/*
 *----------------------------------------------------------------------
 *
 * ReflectInput --
 *
 *    This function is invoked when more data is requested from the channel.
 *
 * Results:
 *    The number of bytes read.
 *
 * Side effects:
 *    Allocates memory. Arbitrary, as it calls upon a script.
 *
 *----------------------------------------------------------------------
 */

static int
ReflectInput(
           ClientData clientData,
           char *buf,
           int toRead,
           int *errorCodePtr)
{
    ReflectedTransform *rtPtr = (ReflectedTransform *) clientData;
    int gotBytes, copied, read;

    /*
     * The following check can be done before thread redirection, because we
     * are reading from an item which is readonly, i.e. will never change
     * during the lifetime of the channel.
     */

    if (!(rtPtr->methods & FLAG(METH_READ))) {
      SetChannelErrorStr(rtPtr->chan, msg_read_unsup);
      *errorCodePtr = EINVAL;
      return -1;
    }

    gotBytes = 0;

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

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

      if (toRead == 0) {
          return gotBytes;
      }

      /*
       * The buffer is exhausted, but the caller wants even more. We now
       * have to go to the underlying channel, get more bytes and then
       * transform them for delivery. We may not get what we want (full EOF
       * or temporarily out of data).
       */

      /*
       * Length (rtPtr->result) == 0, toRead > 0 here. Use 'buf'! as target
       * to store the intermediary information read from the parent channel.
       *
       * Ask the transform how much data it allows us to read from the
       * underlying channel. This feature allows the transform to signal EOF
       * upstream although there is none downstream. Useful to control an
       * unbounded 'fcopy' for example, either through counting bytes, or by
       * pattern matching.
       */

      if ((rtPtr->methods & FLAG(METH_LIMIT))) {
          int maxRead = -1;
          if (!TransformLimit (rtPtr, errorCodePtr, &maxRead)) {
            return -1;
          }
          if (maxRead == 0) {
            SetChannelErrorStr(rtPtr->chan, msg_read_badlimit);
            return -1;
          } else if (maxRead > 0) {
            if (maxRead < toRead) {
                toRead = maxRead;
            }
          } /* else: 'maxRead < 0' == Accept the current value of toRead */
      }

      if (toRead <= 0) {
          return gotBytes;
      }

      read = Tcl_ReadRaw (rtPtr->parent, buf, toRead);
      if (read < 0) {
          /* Report errors to caller.
           * The state of the seek system is unchanged!
           */

          if ((Tcl_GetErrno () == EAGAIN) && (gotBytes > 0)) {
            /* EAGAIN is a special situation.  If we had some data
             * before we report that instead of the request to re-try.
             */

            return gotBytes;
          }

          *errorCodePtr = Tcl_GetErrno ();
          return -1;      
      }

      if (read == 0) {
          /*
           * Check wether we hit on EOF in 'parent' 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 (rtPtr->parent)) {
            /* The state of the seek system is unchanged! */

            if ((gotBytes == 0) && rtPtr->nonblocking) {
                *errorCodePtr = EWOULDBLOCK;
                return -1;
            } else {
                return gotBytes;
            }
          } else {
            /* Eof in parent */
            if (rtPtr->readIsDrained) {
                return gotBytes;
            }

            /*
             * Now this is a bit different. The partial data waiting is
             * converted and returned.
             */

            if (HAS(rtPtr->methods, METH_DRAIN)) {
                if(!TransformDrain (rtPtr, errorCodePtr)) {
                  return -1;
                }
            }

            if (ResultLength (&rtPtr->result) == 0) {
                /* The drain delivered nothing */
                return gotBytes;
            }

            /* Reset eof, force caller to drain result buffer */
                ((Channel*) rtPtr->parent)->state->flags &= ~CHANNEL_EOF;
            continue; /* at: while (toRead > 0) */
          }
      } /* read == 0 */

      /*
       * Transform the read chunk, which was not empty. Anything we got back
       * is a transformation result is put into our buffers, and the next
       * iteration will put it into the result.
       */

      if (!TransformRead (rtPtr, errorCodePtr, UCHARP(buf), read)) {
          return -1;
      }
    } /* while toRead > 0 */

    return gotBytes;

}

/*
 *----------------------------------------------------------------------
 *
 * ReflectOutput --
 *
 *    This function is invoked when data is writen to the channel.
 *
 * Results:
 *    The number of bytes actually written.
 *
 * Side effects:
 *    Allocates memory. Arbitrary, as it calls upon a script.
 *
 *----------------------------------------------------------------------
 */

static int
ReflectOutput(
    ClientData clientData,
    const char *buf,
    int toWrite,
    int *errorCodePtr)
{
    ReflectedTransform *rtPtr = (ReflectedTransform *) clientData;

    /*
     * The following check can be done before thread redirection, because we
     * are reading from an item which is readonly, i.e. will never change
     * during the lifetime of the channel.
     */

    if (!(rtPtr->methods & FLAG(METH_WRITE))) {
      SetChannelErrorStr(rtPtr->chan, msg_write_unsup);
      *errorCodePtr = EINVAL;
      return -1;
    }

    if (toWrite == 0) {
      /* Nothing came in to write, ignore the call
       */
      return 0;
    }

    /*
     * Discard partial data in the input buffers, i.e. on the read side. Like
     * we do when explicitly seeking as well.
     */

    if ((rtPtr->methods & FLAG(METH_CLEAR))) {
      TransformClear (rtPtr);
    }

    /*
     * Hand the data to the transformation itself. Anything it deigned to
     * return to us is a (partial) transformation result and written to the
     * parent channel for further processing.
     */

    if (!TransformWrite (rtPtr, errorCodePtr, UCHARP(buf), toWrite)) {
      return -1;
    }

    *errorCodePtr = EOK;
    return toWrite;
}

/*
 *----------------------------------------------------------------------
 *
 * ReflectSeekWide / ReflectSeek --
 *
 *    This function is invoked when the user wishes to seek on the channel.
 *
 * Results:
 *    The new location of the access point.
 *
 * Side effects:
 *    Allocates memory. Arbitrary, per the parent channel, and the called scripts.
 *
 *----------------------------------------------------------------------
 */

static Tcl_WideInt
ReflectSeekWide(
    ClientData clientData,
    Tcl_WideInt offset,
    int seekMode,
    int *errorCodePtr)
{
    ReflectedTransform *rtPtr = (ReflectedTransform *) clientData;
    Channel* parent = (Channel*) rtPtr->parent;
    Tcl_WideInt curPos;       /* Position on the device. */

    Tcl_DriverSeekProc *seekProc      =
      Tcl_ChannelSeekProc(Tcl_GetChannelType (rtPtr->parent));

    /*
     * Fail if the parent channel is not seekable.
     */

    if (seekProc == NULL) {
      Tcl_SetErrno(EINVAL);
      return Tcl_LongAsWide(-1);
    }

    /*
     * Check if we can leave out involving the Tcl level, i.e. transformation
     * handler. This is true for tell requests, and transformations which
     * support neither flush, nor drain. For these cases we can pass the
     * request down and the result back up unchanged.
     */

    if (
      ((seekMode != SEEK_CUR) || (offset != 0)) &&
      (HAS(rtPtr->methods, METH_CLEAR) ||
       HAS(rtPtr->methods, METH_FLUSH))
      ) {
      /*
       * Neither a tell request, nor clear/flush both not supported.  We
       * have to go through the Tcl level to clear and/or flush the
       * transformation.
       */

      if ((rtPtr->methods & FLAG(METH_CLEAR))) {
          TransformClear (rtPtr);
      }

      /*
       * When flushing the transform for seeking the generated results are
       * irrelevant. We cannot put them into the channel, this would move
       * the location, throwing it off with regard to where we are and are
       * seeking to.
       */

      if (HAS(rtPtr->methods, METH_FLUSH)) {
          if (!TransformFlush (rtPtr, errorCodePtr, FLUSH_DISCARD)) {
            return -1;
          }
      }
    }

    /*
     * Now seek to the new position in the channel as requested by the
     * caller. Note that we prefer the wideSeekProc if that is available and
     * non-NULL...
     */

    if (HaveVersion(parent->typePtr, TCL_CHANNEL_VERSION_3) &&
      parent->typePtr->wideSeekProc != NULL) {
      curPos = (parent->typePtr->wideSeekProc) (parent->instanceData,
                                      offset, seekMode, errorCodePtr);
    } else if (offset < Tcl_LongAsWide(LONG_MIN) ||
             offset > Tcl_LongAsWide(LONG_MAX)) {
      *errorCodePtr = EOVERFLOW;
      curPos = Tcl_LongAsWide(-1);
    } else {
      curPos = Tcl_LongAsWide((parent->typePtr->seekProc) (
            parent->instanceData, Tcl_WideAsLong(offset), seekMode,
            errorCodePtr));
    }
    if (curPos == Tcl_LongAsWide(-1)) {
      Tcl_SetErrno(*errorCodePtr);
    }

    *errorCodePtr = EOK;
    return curPos;
}

static int
ReflectSeek(
    ClientData clientData,
    long offset,
    int seekMode,
    int *errorCodePtr)
{
    /*
     * This function can be invoked from a transformation which is based on
     * standard seeking, i.e. non-wide. Because of this we have to implement
     * it, a dummy is not enough. We simply delegate the call to the wide
     * routine.
     */

    return (int) ReflectSeekWide(clientData, Tcl_LongAsWide(offset), seekMode,
          errorCodePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * ReflectWatch --
 *
 *    This function is invoked to tell the channel what events the I/O
 *    system is interested in.
 *
 * Results:
 *    None.
 *
 * Side effects:
 *    Allocates memory. Arbitrary, as it calls upon a script.
 *
 *----------------------------------------------------------------------
 */

static void
ReflectWatch(
    ClientData clientData,
    int mask)
{
    ReflectedTransform *rtPtr = (ReflectedTransform *) clientData;
    Tcl_DriverWatchProc* watchProc;

    watchProc = Tcl_ChannelWatchProc (Tcl_GetChannelType (rtPtr->parent));
    (*watchProc) (Tcl_GetChannelInstanceData(rtPtr->parent),
              mask);

    /*
     * Management of the internal timer.
     */

    if (!(mask & TCL_READABLE) || (ResultLength(&rtPtr->result) == 0)) {
      /*
       * A pending timer may exist, but either is there no (more) interest
       * in the events it generates or nothing is available for
       * reading. Remove it, if existing.
       */

      TimerKill (rtPtr);
    } else {
      /*
       * There might be no pending timer, but there is interest in readable
       * events and we actually have data waiting, so generate a timer to
       * flush that if it does not exist.
       */

      TimerSetup (rtPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * ReflectBlock --
 *
 *    This function is invoked to tell the channel which blocking behaviour
 *    is required of it.
 *
 * Results:
 *    A posix error number.
 *
 * Side effects:
 *    Allocates memory. Arbitrary, as it calls upon a script.
 *
 *----------------------------------------------------------------------
 */

static int
ReflectBlock(
    ClientData clientData,
    int nonblocking)
{
    ReflectedTransform *rtPtr = (ReflectedTransform *) clientData;

    /*
     * Transformations simply record the blocking mode in their C level
     * structure for use by --> ReflectInput. The Tcl level doesn't see this
     * information or change. As such thread forwarding is not required.
     */

    rtPtr->nonblocking = nonblocking;
    return EOK;
}

/*
 *----------------------------------------------------------------------
 *
 * ReflectSetOption --
 *
 *    This function is invoked to configure a channel option.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    Arbitrary, per the parent channel.
 *
 *----------------------------------------------------------------------
 */

static int
ReflectSetOption(
    ClientData clientData,    /* Channel to query */
    Tcl_Interp *interp,       /* Interpreter to leave error messages in */
    const char *optionName,   /* Name of requested option */
    const char *newValue)     /* The new value */
{
    ReflectedTransform *rtPtr = (ReflectedTransform *) clientData;

    /*
     * Transformations have no options. Thus the call is passed down unchanged
     * to the parent channel for processing. Its results are passed back
     * unchanged as well. This all happens in the thread we are in. As the Tcl
     * level is not involved there is no need for thread forwarding.
     */

    Tcl_DriverSetOptionProc *setOptionProc = 
      Tcl_ChannelSetOptionProc (Tcl_GetChannelType (rtPtr->parent));

    if (setOptionProc != NULL) {
      return (*setOptionProc) (Tcl_GetChannelInstanceData (rtPtr->parent),
                         interp, optionName, newValue);
    } else {
      return TCL_ERROR;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * ReflectGetOption --
 *
 *    This function is invoked to retrieve all or a channel options.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    Arbitrary, per the parent channel.
 *
 *----------------------------------------------------------------------
 */

static int
ReflectGetOption(
    ClientData clientData,    /* Channel to query */
    Tcl_Interp *interp,       /* Interpreter to leave error messages in */
    const char *optionName,   /* Name of reuqested option */
    Tcl_DString *dsPtr)       /* String to place the result into */
{
    ReflectedTransform *rtPtr = (ReflectedTransform *) clientData;

    /*
     * Transformations have no options. Thus the call is passed down unchanged
     * to the parent channel for processing. Its results are passed back
     * unchanged as well. This all happens in the thread we are in. As the Tcl
     * level is not involved there is no need for thread forwarding.
     *
     * Note that the parent not having a driver for option retrieval is not an
     * immediate error. A query for all options is ok. Only a request for a
     * specific option has to fail.
     */

    Tcl_DriverGetOptionProc *getOptionProc = 
      Tcl_ChannelGetOptionProc (Tcl_GetChannelType (rtPtr->parent));

    if (getOptionProc != NULL) {
      return (*getOptionProc) (Tcl_GetChannelInstanceData (rtPtr->parent),
                         interp, optionName, dsPtr);
    } else if (optionName == (char*) NULL) {
      return TCL_OK;
    } else {
      return TCL_ERROR;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * ReflectHandle --
 *
 *    This function is invoked to retrieve the associated file handle.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    Arbitrary, per the parent channel.
 *
 *----------------------------------------------------------------------
 */

static int
ReflectHandle(
            ClientData  clientData,
            int         direction,
            ClientData* handlePtr)
{
    ReflectedTransform *rtPtr = (ReflectedTransform *) clientData;

    /*
     * Transformations have no handle of their own. As such we simply query
     * the parent channel for it. This way the qery will ripple down through
     * all transformations until reaches the base channel. Which then returns
     * its handle, or fails. The former will then ripple up the stack.
     *
     * This all happens in the thread we are in. As the Tcl level is not
     * involved no forwarding is required.
     */

    return Tcl_GetChannelHandle (rtPtr->parent, direction, handlePtr);
}
/*
 *----------------------------------------------------------------------
 *
 * ReflectNotify --
 *
 *    This function is invoked to reported incoming events.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    Arbitrary, per the parent channel.
 *
 *----------------------------------------------------------------------
 */

static int
ReflectNotify(
            ClientData clientData,
            int mask)
{
    ReflectedTransform *rtPtr = (ReflectedTransform *) clientData;

    /*
     * An event occured in the underlying channel.
     *
     * We delete our timer. It was not fired, yet we are here, so the channel
     * below generated such an event and we don't have to. The renewal of the
     * interest after the execution of channel handlers will eventually cause
     * us to recreate the timer (in ReflectWatch).
     */

    TimerKill (rtPtr);

    /*
     * Pass to higher layers.
     */

    return mask;
}

/*
 * Helpers. =========================================================
 */


/*
 *----------------------------------------------------------------------
 *
 * DecodeEventMask --
 *
 *    This function takes an internal bitmask of events and constructs the
 *    equivalent list of event items.
 *
 * Results:
 *    A Tcl_Obj reference. The object will have a refCount of one. The user
 *    has to decrement it to release the object.
 *
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 * DUPLICATE of 'DecodeEventMask' in tclIORChan.c
 */

static Tcl_Obj *
DecodeEventMask(
    int mask)
{
    register const char *eventStr;
    Tcl_Obj *evObj;

    switch (mask & RANDW) {
    case RANDW:
      eventStr = "read write";
      break;
    case TCL_READABLE:
      eventStr = "read";
      break;
    case TCL_WRITABLE:
      eventStr = "write";
      break;
    default:
      eventStr = "";
      break;
    }

    evObj = Tcl_NewStringObj(eventStr, -1);
    Tcl_IncrRefCount(evObj);
    return evObj;
}

/*
 *----------------------------------------------------------------------
 *
 * NewReflectedTransform --
 *
 *    This function is invoked to allocate and initialize the instance data
 *    of a new reflected channel.
 *
 * Results:
 *    A heap-allocated channel instance.
 *
 * Side effects:
 *    Allocates memory.
 *
 *----------------------------------------------------------------------
 */

static ReflectedTransform *
NewReflectedTransform(
    Tcl_Interp *interp,
    Tcl_Obj *cmdpfxObj,
    int mode,
    Tcl_Obj *handleObj,
    Tcl_Channel parentChan)
{
    ReflectedTransform *rtPtr;
    int listc;
    Tcl_Obj **listv;
    int i;

    rtPtr = (ReflectedTransform *) ckalloc(sizeof(ReflectedTransform));

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

    rtPtr->chan = NULL;
    rtPtr->methods = 0;
#ifdef TCL_THREADS
    rtPtr->thread = Tcl_GetCurrentThread();
#endif
    rtPtr->parent = parentChan;
    rtPtr->interp = interp;
    rtPtr->handle = handleObj;
    Tcl_IncrRefCount(handleObj);
    rtPtr->timer  = (Tcl_TimerToken) NULL;
    rtPtr->mode = 0;
    rtPtr->readIsDrained = 0;
    rtPtr->nonblocking = 
      (((Channel*) parentChan)->state->flags & CHANNEL_NONBLOCKING);
    /* Query parent for current blocking mode. */

    ResultInit (&rtPtr->result);

    /*
     * Method placeholder.
     */

    /* ASSERT: cmdpfxObj is a Tcl List */

    Tcl_ListObjGetElements(interp, cmdpfxObj, &listc, &listv);

    /*
     * See [==] as well.
     * Storage for the command prefix and the additional words required for
     * the invocation of methods in the command handler.
     *
     * listv [0] [listc-1] | [listc]  [listc+1] |
     * argv  [0]   ... [.] | [argc-2] [argc-1]  | [argc]  [argc+2]
     *       cmd   ... pfx | method   chan      | detail1 detail2
     */

    rtPtr->argc = listc + 2;
    rtPtr->argv = (Tcl_Obj**) ckalloc(sizeof(Tcl_Obj*) * (listc+4));

    /*
     * Duplicate object references.
     */

    for (i=0; i<listc ; i++) {
      Tcl_Obj *word = rtPtr->argv[i] = listv[i];
      Tcl_IncrRefCount(word);
    }

    i++;                      /* Skip placeholder for method */

    /*
     * See [x] in FreeReflectedTransform for release
     */
    rtPtr->argv[i] = handleObj;
    Tcl_IncrRefCount(handleObj);

    /*
     * The next two objects are kept empty, varying arguments.
     */

    /*
     * Initialization complete.
     */

    return rtPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * NextHandle --
 *
 *    This function is invoked to generate a channel handle for a new
 *    reflected channel.
 *
 * Results:
 *    A Tcl_Obj containing the string of the new channel handle. The
 *    refcount of the returned object is -- zero --.
 *
 * Side effects:
 *    May allocate memory. Mutex protected critical section locks out other
 *    threads for a short time.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Obj *
NextHandle(void)
{
    /*
     * Count number of generated reflected channels. Used for id generation.
     * Ids are never reclaimed and there is no dealing with wrap around. On
     * the other hand, "unsigned long" should be big enough except for
     * absolute longrunners (generate a 100 ids per second => overflow will
     * occur in 1 1/3 years).
     */

    TCL_DECLARE_MUTEX(rtCounterMutex)
    static unsigned long rtCounter = 0;
    Tcl_Obj *resObj;

    Tcl_MutexLock(&rtCounterMutex);
    resObj = Tcl_ObjPrintf("rt%lu", rtCounter);
    rtCounter++;
    Tcl_MutexUnlock(&rtCounterMutex);

    return resObj;
}

static void
FreeReflectedTransform(
    ReflectedTransform *rtPtr)
{
    int i, n;

    TimerKill   (rtPtr);
    ResultClear (&rtPtr->result);

    Tcl_DecrRefCount(rtPtr->handle);
    rtPtr->handle = NULL;

    n = rtPtr->argc - 2;
    for (i=0; i<n; i++) {
      Tcl_DecrRefCount(rtPtr->argv[i]);
    }

    /*
     * See [x] in NewReflectedTransform for lock
     * n+1 = argc-1.
     */
    Tcl_DecrRefCount(rtPtr->argv[n+1]);

    ckfree((char*) rtPtr->argv);
    ckfree((char*) rtPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * InvokeTclMethod --
 *
 *    This function is used to invoke the Tcl level of a reflected channel.
 *    It handles all the command assembly, invokation, and generic state and
 *    result mgmt. It does *not* handle thread redirection; that is the
 *    responsibility of clients of this function.
 *
 * Results:
 *    Result code and data as returned by the method.
 *
 * Side effects:
 *    Arbitrary, as it calls upon a Tcl script.
 *
 *----------------------------------------------------------------------
 * Semi-DUPLICATE of 'InvokeTclMethod' in tclIORChan.c
 * - Semi because different structures are used.
 * - Still possible to factor out the commonalities into a separate structure.
 */

static int
InvokeTclMethod(
    ReflectedTransform *rtPtr,
    const char *method,
    Tcl_Obj *argOneObj,       /* NULL'able */
    Tcl_Obj *argTwoObj,       /* NULL'able */
    Tcl_Obj **resultObjPtr)   /* NULL'able */
{
    int cmdc;                 /* #words in constructed command */
    Tcl_Obj *methObj = NULL;  /* Method name in object form */
    Tcl_InterpState sr;       /* State of handler interp */
    int result;               /* Result code of method invokation */
    Tcl_Obj *resObj = NULL;   /* Result of method invokation. */

    if (!rtPtr->interp) {
      /*
       * The transform is marked as dead. Bail out immediately, with an
       * appropriate error.
       */

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

    /*
     * NOTE (5): Decide impl. issue: Cache objects with method names?
     * Requires TSD data as reflections can be created in many different
     * threads.
     * NO: Caching of command resolutions means storage per channel.
     */

    /*
     * Insert method into the pre-allocated area, after the command prefix,
     * before the channel id.
     */

    methObj = Tcl_NewStringObj(method, -1);
    Tcl_IncrRefCount(methObj);
    rtPtr->argv[rtPtr->argc - 2] = methObj;

    /*
     * Append the additional argument containing method specific details
     * behind the channel id. If specified.
     */

    cmdc = rtPtr->argc;
    if (argOneObj) {
      Tcl_IncrRefCount(argOneObj);
      rtPtr->argv[cmdc] = argOneObj;
      cmdc++;
      if (argTwoObj) {
          Tcl_IncrRefCount(argTwoObj);
          rtPtr->argv[cmdc] = argTwoObj;
          cmdc++;
      }
    }

    /*
     * And run the handler... This is done in auch a manner which leaves any
     * existing state intact.
     */

    sr = Tcl_SaveInterpState(rtPtr->interp, 0 /* Dummy */);
    Tcl_Preserve(rtPtr->interp);
    result = Tcl_EvalObjv(rtPtr->interp, cmdc, rtPtr->argv, TCL_EVAL_GLOBAL);

    /*
     * We do not try to extract the result information if the caller has no
     * interest in it. I.e. there is no need to put effort into creating
     * something which is discarded immediately after.
     */

    if (resultObjPtr) {
      if (result == TCL_OK) {
          /*
           * Ok result taken as is, also if the caller requests that there
           * is no capture.
           */

          resObj = Tcl_GetObjResult(rtPtr->interp);
      } else {
          /*
           * Non-ok result is always treated as an error. We have to capture
           * the full state of the result, including additional options.
           *
           * This is complex and ugly, and would be completely unnecessary
           * if we only added support for a TCL_FORBID_EXCEPTIONS flag.
           */
          if (result != TCL_ERROR) {
            Tcl_Obj *cmd = Tcl_NewListObj(cmdc, rtPtr->argv);
            int cmdLen;
            const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen);

            Tcl_IncrRefCount(cmd);
            Tcl_ResetResult(rtPtr->interp);
            Tcl_SetObjResult(rtPtr->interp, Tcl_ObjPrintf(
                  "chan handler returned bad code: %d", result));
            Tcl_LogCommandInfo(rtPtr->interp, cmdString, cmdString, cmdLen);
            Tcl_DecrRefCount(cmd);
            result = TCL_ERROR;
          }
          Tcl_AppendObjToErrorInfo(rtPtr->interp, Tcl_ObjPrintf(
                "\n    (chan handler subcommand \"%s\")", method));
          resObj = MarshallError(rtPtr->interp);
      }
      Tcl_IncrRefCount(resObj);
    }
    Tcl_RestoreInterpState(rtPtr->interp, sr);
    Tcl_Release(rtPtr->interp);

    /*
     * Cleanup of the dynamic parts of the command.
     */

    Tcl_DecrRefCount(methObj);
    if (argOneObj) {
      Tcl_DecrRefCount(argOneObj);
      if (argTwoObj) {
          Tcl_DecrRefCount(argTwoObj);
      }
    }

    /*
     * The resObj has a ref count of 1 at this location. This means that the
     * caller of InvokeTclMethod has to dispose of it (but only if it was
     * returned to it).
     */

    if (resultObjPtr != NULL) {
      *resultObjPtr = resObj;
    }

    /*
     * There no need to handle the case where nothing is returned, because for
     * that case resObj was not set anyway.
     */

    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * GetReflectedTransformMap --
 *
 *    Gets and potentially initializes the reflected channel map for an
 *    interpreter.
 *
 * Results:
 *    A pointer to the map created, for use by the caller.
 *
 * Side effects:
 *    Initializes the reflected channel map for an interpreter.
 *
 *----------------------------------------------------------------------
 */

static ReflectedTransformMap *
GetReflectedTransformMap(
    Tcl_Interp *interp)
{
    ReflectedTransformMap *rtmPtr = Tcl_GetAssocData(interp, RTMKEY, NULL);

    if (rtmPtr == NULL) {
      rtmPtr = (ReflectedTransformMap *) ckalloc(sizeof(ReflectedTransformMap));
      Tcl_InitHashTable(&rtmPtr->map, TCL_STRING_KEYS);
      Tcl_SetAssocData(interp, RTMKEY,
            (Tcl_InterpDeleteProc *) DeleteReflectedTransformMap, rtmPtr);
    }
    return rtmPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * DeleteReflectedTransformMap --
 *
 *    Deletes the channel table for an interpreter, closing any open
 *    channels whose refcount reaches zero. This procedure is invoked when
 *    an interpreter is deleted, via the AssocData cleanup mechanism.
 *
 * Results:
 *    None.
 *
 * Side effects:
 *    Deletes the hash table of channels. May close channels. May flush
 *    output on closed channels. Removes any channeEvent handlers that were
 *    registered in this interpreter.
 *
 *----------------------------------------------------------------------
 */

static void
DeleteReflectedTransformMap(
    ClientData clientData,    /* The per-interpreter data structure. */
    Tcl_Interp *interp)       /* The interpreter being deleted. */
{
    ReflectedTransformMap *rtmPtr; /* The map */
    Tcl_HashSearch hSearch;    /* Search variable. */
    Tcl_HashEntry *hPtr;       /* Search variable. */
    ReflectedTransform *rtPtr;

#ifdef TCL_THREADS
    ForwardingResult *resultPtr;
    ForwardingEvent *evPtr;
    ForwardParam *paramPtr;
#endif

    /*
     * Delete all entries. The channels may have been closed already, or will
     * be closed later, by the standard IO finalization of an interpreter
     * under destruction. Except for the channels which were moved to a
     * different interpreter and/or thread. They do not exist from the IO
     * systems point of view and will not get closed. Therefore mark all as
     * dead so that any future access will cause a proper error. For channels
     * in a different thread we actually do the same as
     * DeleteThreadReflectedTransformMap(), just restricted to the channels of
     * this interp.
     */

    rtmPtr = clientData;
    for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch);
          hPtr != NULL;
          hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) {
      rtPtr = (ReflectedTransform *) Tcl_GetHashValue (hPtr);

      //fprintf(stdout,"[%ld] dd t-rcm %p /h %p  /rt %p\n", (long)Tcl_GetCurrentThread(),rtmPtr,hPtr,rtPtr);fflush(stdout);


      rtPtr->interp = NULL;
      Tcl_DeleteHashEntry(hPtr);
    }
    Tcl_DeleteHashTable(&rtmPtr->map);
    ckfree((char *) &rtmPtr->map);

#ifdef TCL_THREADS
    /*
     * The origin interpreter for one or more reflected channels is gone.
     */

    /*
     * Go through the list of pending results and cancel all whose events were
     * destined for this interpreter. While this is in progress we block any
     * other access to the list of pending results.
     */

    Tcl_MutexLock(&rtForwardMutex);

    for (resultPtr = forwardList;
          resultPtr != NULL;
          resultPtr = resultPtr->nextPtr) {
      if (resultPtr->dsti != interp) {
          /*
           * Ignore results/events for other interpreters.
           */

          continue;
      }

      /*
       * The receiver for the event exited, before processing the event. We
       * detach the result now, wake the originator up and signal failure.
       */

      evPtr = resultPtr->evPtr;
      paramPtr = evPtr->param;

      evPtr->resultPtr = NULL;
      resultPtr->evPtr = NULL;
      resultPtr->result = TCL_ERROR;

      ForwardSetStaticError(paramPtr, msg_send_dstlost);

      Tcl_ConditionNotify(&resultPtr->done);
    }

    /*
     * Get the map of all channels handled by the current thread. This is a
     * ReflectedTransformMap, but on a per-thread basis, not per-interp. Go
     * through the channels and remove all which were handled by this
     * interpreter. They have already been marked as dead.
     */

    rtmPtr = GetThreadReflectedTransformMap();
    for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch);
          hPtr != NULL;
          hPtr = Tcl_NextHashEntry(&hSearch)) {
      rtPtr = (ReflectedTransform *) Tcl_GetHashValue (hPtr);

      if (rtPtr->interp != interp) {
          /*
           * Ignore entries for other interpreters.
           */

          continue;
      }

      Tcl_DeleteHashEntry(hPtr);
    }

    Tcl_MutexUnlock(&rtForwardMutex);
#endif
}

#ifdef TCL_THREADS
/*
 *----------------------------------------------------------------------
 *
 * GetThreadReflectedTransformMap --
 *
 *    Gets and potentially initializes the reflected channel map for a
 *    thread.
 *
 * Results:
 *    A pointer to the map created, for use by the caller.
 *
 * Side effects:
 *    Initializes the reflected channel map for a thread.
 *
 *----------------------------------------------------------------------
 */

static ReflectedTransformMap *
GetThreadReflectedTransformMap(void)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

    if (!tsdPtr->rtmPtr) {
      tsdPtr->rtmPtr = (ReflectedTransformMap *)
            ckalloc(sizeof(ReflectedTransformMap));
      Tcl_InitHashTable(&tsdPtr->rtmPtr->map, TCL_STRING_KEYS);
      Tcl_CreateThreadExitHandler(DeleteThreadReflectedTransformMap, NULL);
    }

    return tsdPtr->rtmPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * DeleteThreadReflectedTransformMap --
 *
 *    Deletes the channel table for a thread. This procedure is invoked when
 *    a thread is deleted. The channels have already been marked as dead, in
 *      DeleteReflectedTransformMap().
 *
 * Results:
 *    None.
 *
 * Side effects:
 *    Deletes the hash table of channels.
 *
 *----------------------------------------------------------------------
 */

static void
DeleteThreadReflectedTransformMap(
    ClientData clientData)    /* The per-thread data structure. */
{
    Tcl_HashSearch hSearch;    /* Search variable. */
    Tcl_HashEntry *hPtr;       /* Search variable. */
    Tcl_ThreadId self = Tcl_GetCurrentThread();
    ReflectedTransformMap *rtmPtr; /* The map */
    ForwardingResult *resultPtr;

    /*
     * The origin thread for one or more reflected channels is gone.
     * NOTE: If this function is called due to a thread getting killed the
     *       per-interp DeleteReflectedTransformMap is apparently not called.
     */

    /*
     * Go through the list of pending results and cancel all whose events were
     * destined for this thread. While this is in progress we block any
     * other access to the list of pending results.
     */

    Tcl_MutexLock(&rtForwardMutex);

    for (resultPtr = forwardList;
          resultPtr != NULL;
          resultPtr = resultPtr->nextPtr) {
      ForwardingEvent *evPtr;
      ForwardParam *paramPtr;

      if (resultPtr->dst != self) {
          /*
           * Ignore results/events for other threads.
           */

          continue;
      }

      /*
       * The receiver for the event exited, before processing the event. We
       * detach the result now, wake the originator up and signal failure.
       */

      evPtr = resultPtr->evPtr;
      paramPtr = evPtr->param;

      evPtr->resultPtr = NULL;
      resultPtr->evPtr = NULL;
      resultPtr->result = TCL_ERROR;

      ForwardSetStaticError(paramPtr, msg_send_dstlost);

      Tcl_ConditionNotify(&resultPtr->done);
    }

    /*
     * Get the map of all channels handled by the current thread. This is a
     * ReflectedTransformMap, but on a per-thread basis, not per-interp. Go
     * through the channels, remove all, mark them as dead.
     */

    rtmPtr = GetThreadReflectedTransformMap();
    for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch);
          hPtr != NULL;
          hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) {
      ReflectedTransform *rtPtr = (ReflectedTransform *) Tcl_GetHashValue(hPtr);

      rtPtr->interp = NULL;
      Tcl_DeleteHashEntry(hPtr);
    }

    Tcl_MutexUnlock(&rtForwardMutex);
}

static void
ForwardOpToOwnerThread(
    ReflectedTransform *rtPtr,      /* Channel instance */
    ForwardedOperation op,    /* Forwarded driver operation */
    const VOID *param)        /* Arguments */
{
    Tcl_ThreadId dst = rtPtr->thread;
    ForwardingEvent *evPtr;
    ForwardingResult *resultPtr;
    int result;

    /*
     * We gather the lock early. This allows us to check the liveness of the
     * channel without interference from DeleteThreadReflectedTransformMap().
     */

    Tcl_MutexLock(&rtForwardMutex);

    if (rtPtr->interp == NULL) {
      /*
       * The channel is marked as dead. Bail out immediately, with an
       * appropriate error. Do not forget to unlock the mutex on this path.
       */

      ForwardSetStaticError((ForwardParam *) param, msg_send_dstlost);
      Tcl_MutexUnlock(&rtForwardMutex);
      return;
    }

    /*
     * Create and initialize the event and data structures.
     */

    evPtr = (ForwardingEvent *) ckalloc(sizeof(ForwardingEvent));
    resultPtr = (ForwardingResult *) ckalloc(sizeof(ForwardingResult));

    evPtr->event.proc = ForwardProc;
    evPtr->resultPtr = resultPtr;
    evPtr->op = op;
    evPtr->rtPtr = rtPtr;
    evPtr->param = (ForwardParam *) param;

    resultPtr->src = Tcl_GetCurrentThread();
    resultPtr->dst = dst;
    resultPtr->done = NULL;
    resultPtr->result = -1;
    resultPtr->evPtr = evPtr;

    /*
     * Now execute the forward.
     */

    TclSpliceIn(resultPtr, forwardList);
    /* Do not unlock here. That is done by the ConditionWait */

    /*
     * Ensure cleanup of the event if the origin thread exits while this event
     * is pending or in progress. Exit of the destination thread is handled by
     * DeleteThreadReflectionChannelMap(), this is set up by
     * GetThreadReflectedTransformMap(). This is what we use the 'forwardList'
     * (see above) for.
     */

    Tcl_CreateThreadExitHandler(SrcExitProc, (ClientData) evPtr);

    /*
     * Queue the event and poke the other thread's notifier.
     */

    Tcl_ThreadQueueEvent(dst, (Tcl_Event *)evPtr, TCL_QUEUE_TAIL);
    Tcl_ThreadAlert(dst);

    /*
     * (*) Block until the other thread has either processed the transfer or
     * rejected it.
     */

    while (resultPtr->result < 0) {
      /*
       * NOTE (1): Is it possible that the current thread goes away while
       * waiting here? IOW Is it possible that "SrcExitProc" is called
       * while we are here? See complementary note (2) in "SrcExitProc"
       *
       * The ConditionWait unlocks the mutex during the wait and relocks it
       * immediately after.
       */

      Tcl_ConditionWait(&resultPtr->done, &rtForwardMutex, NULL);
    }

    /*
     * Unlink result from the forwarder list. No need to lock. Either still
     * locked, or locked by the ConditionWait
     */

    TclSpliceOut(resultPtr, forwardList);

    resultPtr->nextPtr = NULL;
    resultPtr->prevPtr = NULL;

    Tcl_MutexUnlock(&rtForwardMutex);
    Tcl_ConditionFinalize(&resultPtr->done);

    /*
     * Kill the cleanup handler now, and the result structure as well, before
     * returning the success code.
     *
     * Note: The event structure has already been deleted by the destination
     * notifier, after it serviced the event.
     */

    Tcl_DeleteThreadExitHandler(SrcExitProc, (ClientData) evPtr);

    result = resultPtr->result;
    ckfree((char*) resultPtr);
}

static int
ForwardProc(
    Tcl_Event *evGPtr,
    int mask)
{
    /*
     * Notes regarding access to the referenced data.
     *
     * In principle the data belongs to the originating thread (see
     * evPtr->src), however this thread is currently blocked at (*), i.e.
     * quiescent. Because of this we can treat the data as belonging to us,
     * without fear of race conditions. I.e. we can read and write as we like.
     *
     * The only thing we cannot be sure of is the resultPtr. This can be be
     * NULLed if the originating thread went away while the event is handled
     * here now.
     */

    ForwardingEvent *evPtr = (ForwardingEvent *) evGPtr;
    ForwardingResult *resultPtr = evPtr->resultPtr;
    ReflectedTransform *rtPtr = evPtr->rtPtr;
    Tcl_Interp *interp = rtPtr->interp;
    ForwardParam *paramPtr = evPtr->param;
    Tcl_Obj *resObj = NULL;   /* Interp result of InvokeTclMethod */
    ReflectedTransformMap* rtmPtr; /* 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) {
      return 1;
    }

    paramPtr->base.code = TCL_OK;
    paramPtr->base.msgStr = NULL;
    paramPtr->base.mustFree = 0;

    switch (evPtr->op) {
      /*
       * The destination thread for the following operations is
       * rtPtr->thread, which contains rtPtr->interp, the interp we have to
       * call upon for the driver.
       */

    case ForwardedClose:
      /*
       * No parameters/results.
       */

      if (InvokeTclMethod(rtPtr, "finalize", NULL, NULL, &resObj) != TCL_OK) {
          ForwardSetObjError(paramPtr, resObj);
      }

      /*
       * Freeing is done here, in the origin thread, because the argv[]
       * objects belong to this thread. Deallocating them in a different
       * thread is not allowed
       */

      /*
       * Remove the channel from the map before releasing the memory, to
       * prevent future accesses (like by 'postevent') from finding and
       * dereferencing a dangling pointer.
       */

      rtmPtr = GetReflectedTransformMap (interp);
      hPtr = Tcl_FindHashEntry (&rtmPtr->map, 
                          Tcl_GetString(rtPtr->handle));
      Tcl_DeleteHashEntry (hPtr);

      /*
       * In a threaded interpreter we manage a per-thread map as well, to
       * allow us to survive if the script level pulls the rug out under a
       * channel by deleting the owning thread.
       */

        rtmPtr = GetThreadReflectedTransformMap();
      hPtr = Tcl_FindHashEntry (&rtmPtr->map, 
                          Tcl_GetString(rtPtr->handle));
      Tcl_DeleteHashEntry (hPtr);
      FreeReflectedTransform(rtPtr);
      break;

    case ForwardedInput: {
      Tcl_Obj *bufObj = Tcl_NewByteArrayObj((unsigned char *) paramPtr->transform.buf,
                                    paramPtr->transform.size);

      if (InvokeTclMethod(rtPtr, "read", bufObj, NULL, &resObj) != TCL_OK) {
          ForwardSetObjError(paramPtr, resObj);
          paramPtr->transform.size = -1;
      } else {
          /*
           * Process a regular return. Contains the transformation result.
           * Sent it back to the request originator.
           */

          int bytec;          /* Number of returned bytes */
          unsigned char *bytev; /* Array of returned bytes */

          bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);

          paramPtr->transform.size = bytec;

          if (bytec > 0) {
            paramPtr->transform.buf = ckalloc (bytec);
            memcpy(paramPtr->transform.buf, bytev, (size_t)bytec);
          } else {
            paramPtr->transform.buf = NULL;
          }
      }
      break;
    }

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

      if (InvokeTclMethod(rtPtr, "write", bufObj, NULL, &resObj) != TCL_OK) {
          ForwardSetObjError(paramPtr, resObj);
          paramPtr->transform.size = -1;
      } else {
          /*
           * Process a regular return. Contains the transformation result.
           * Sent it back to the request originator.
           */

          int bytec;          /* Number of returned bytes */
          unsigned char *bytev; /* Array of returned bytes */

          bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);

          paramPtr->transform.size = bytec;

          if (bytec > 0) {
            paramPtr->transform.buf = ckalloc (bytec);
            memcpy(paramPtr->transform.buf, bytev, (size_t)bytec);
          } else {
            paramPtr->transform.buf = NULL;
          }
      }
      break;
    }

    case ForwardedDrain: {
      if (InvokeTclMethod(rtPtr, "drain", NULL, NULL, &resObj) != TCL_OK) {
          ForwardSetObjError(paramPtr, resObj);
          paramPtr->transform.size = -1;
      } else {
          /*
           * Process a regular return. Contains the transformation result.
           * Sent it back to the request originator.
           */

          int bytec;          /* Number of returned bytes */
          unsigned char *bytev; /* Array of returned bytes */

          bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);

          paramPtr->transform.size = bytec;

          if (bytec > 0) {
            paramPtr->transform.buf = ckalloc (bytec);
            memcpy(paramPtr->transform.buf, bytev, (size_t)bytec);
          } else {
            paramPtr->transform.buf = NULL;
          }
      }
      break;
    }

    case ForwardedFlush: {
      if (InvokeTclMethod(rtPtr, "flush", NULL, NULL, &resObj) != TCL_OK) {
          ForwardSetObjError(paramPtr, resObj);
          paramPtr->transform.size = -1;
      } else {
          /*
           * Process a regular return. Contains the transformation result.
           * Sent it back to the request originator.
           */

          int bytec;          /* Number of returned bytes */
          unsigned char *bytev; /* Array of returned bytes */

          bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);

          paramPtr->transform.size = bytec;

          if (bytec > 0) {
            paramPtr->transform.buf = ckalloc (bytec);
            memcpy(paramPtr->transform.buf, bytev, (size_t)bytec);
          } else {
            paramPtr->transform.buf = NULL;
          }
      }
      break;
    }

    case ForwardedClear: {
      (void) InvokeTclMethod(rtPtr, "clear", NULL, NULL, NULL);
      break;
    }

    case ForwardedLimit: {
      Tcl_Obj* resObj;

      if (InvokeTclMethod(rtPtr, "limit?", NULL, NULL, &resObj) != TCL_OK) {
          ForwardSetObjError(paramPtr, resObj);
          paramPtr->limit.max = -1;
      } else if (Tcl_GetIntFromObj(interp, resObj, &paramPtr->limit.max) != TCL_OK) {
          ForwardSetObjError(paramPtr, MarshallError(interp));
          paramPtr->limit.max = -1;
      }

      Tcl_DecrRefCount(resObj);
      break;
    }

    default:
      /*
       * Bad operation code.
       */
      Tcl_Panic("Bad operation code in ForwardProc");
      break;
    }

    /*
     * Remove the reference we held on the result of the invoke, if we had
     * such.
     */

    if (resObj != NULL) {
      Tcl_DecrRefCount(resObj);
    }

    if (resultPtr) {
      /*
       * Report the forwarding result synchronously to the waiting caller.
       * This unblocks (*) as well. This is wrapped into a conditional
       * because the caller may have exited in the mean time.
       */

      Tcl_MutexLock(&rtForwardMutex);
      resultPtr->result = TCL_OK;
      Tcl_ConditionNotify(&resultPtr->done);
      Tcl_MutexUnlock(&rtForwardMutex);
    }

    return 1;
}

static void
SrcExitProc(
    ClientData clientData)
{
    ForwardingEvent *evPtr = (ForwardingEvent *) clientData;
    ForwardingResult *resultPtr;
    ForwardParam *paramPtr;

    /*
     * NOTE (2): Can this handler be called with the originator blocked?
     */

    /*
     * The originator for the event exited. It is not sure if this can happen,
     * as the originator should be blocked at (*) while the event is in
     * transit/pending.
     *
     * We make sure that the event cannot refer to the result anymore, remove
     * it from the list of pending results and free the structure. Locking the
     * access ensures that we cannot get in conflict with "ForwardProc",
     * should it already execute the event.
     */

    Tcl_MutexLock(&rtForwardMutex);

    resultPtr = evPtr->resultPtr;
    paramPtr = evPtr->param;

    evPtr->resultPtr = NULL;
    resultPtr->evPtr = NULL;
    resultPtr->result = TCL_ERROR;

    ForwardSetStaticError(paramPtr, msg_send_originlost);

    /*
     * See below: TclSpliceOut(resultPtr, forwardList);
     */

    Tcl_MutexUnlock(&rtForwardMutex);

    /*
     * This unlocks (*). The structure will be spliced out and freed by
     * "ForwardProc". Maybe.
     */

    Tcl_ConditionNotify(&resultPtr->done);
}

static void
ForwardSetObjError(
    ForwardParam *paramPtr,
    Tcl_Obj *obj)
{
    int len;
    const char *msgStr = Tcl_GetStringFromObj(obj, &len);

    len++;
    ForwardSetDynamicError(paramPtr, ckalloc((unsigned) len));
    memcpy(paramPtr->base.msgStr, msgStr, (unsigned) len);
}
#endif

/*
 *----------------------------------------------------------------------
 *
 *    TimerKill --
 *
 *    Timer management. Removes the internal timer
 *    if it exists.
 *
 *    Sideeffects:
 *          See above.
 *
 *    Result:
 *          None.
 *
 *----------------------------------------------------------------------
 */

static void
TimerKill (ReflectedTransform* rtPtr)
{
    if (rtPtr->timer == (Tcl_TimerToken) NULL) return;

    /* Delete an existing flush-out timer, prevent it from firing on a
     * removed/dead channel.
     */

    Tcl_DeleteTimerHandler (rtPtr->timer);
    rtPtr->timer = (Tcl_TimerToken) NULL;
}

/*
 *----------------------------------------------------------------------
 *
 *    TimerSetup --
 *
 *    Timer management. Creates the internal timer
 *    if it does not exist.
 *
 *    Sideeffects:
 *          See above.
 *
 *    Result:
 *          None.
 *
 *----------------------------------------------------------------------
 */

static void
TimerSetup (ReflectedTransform* rtPtr)
{
    if (rtPtr->timer != (Tcl_TimerToken) NULL) return;

    rtPtr->timer = Tcl_CreateTimerHandler (FLUSH_DELAY, TimerRun,
                                 (ClientData) rtPtr);
}

/*
 *----------------------------------------------------------------------
 *
 *    TimerRun --
 *
 *    Called by the notifier (-> timer) to flush out
 *    information waiting in channel buffers.
 *
 *    Sideeffects:
 *          As of 'Tcl_NotifyChannel'.
 *
 *    Result:
 *          None.
 *
 *----------------------------------------------------------------------
 */

static void
TimerRun (ClientData clientData)
{
    ReflectedTransform* rtPtr = (ReflectedTransform*) clientData;

    rtPtr->timer = (Tcl_TimerToken) NULL;
    Tcl_NotifyChannel (rtPtr->chan, TCL_READABLE);
}


/*
 *----------------------------------------------------------------------
 *
 *    ResultInit --
 *
 *    Initializes the specified buffer structure. The
 *    structure will contain valid information for an
 *    emtpy buffer.
 *
 *    Sideeffects:
 *          See above.
 *
 *    Result:
 *          None.
 *
 *----------------------------------------------------------------------
 */

static void
ResultInit (ResultBuffer* r) /* Reference to the structure to initialize */
{
    r->used      = 0;
    r->allocated = 0;
    r->buf       = NULL;
}
/*
 *----------------------------------------------------------------------
 *
 *    ResultClear --
 *
 *    Deallocates any memory allocated by 'ResultAdd'.
 *
 *    Sideeffects:
 *          See above.
 *
 *    Result:
 *          None.
 *
 *----------------------------------------------------------------------
 */

static void
ResultClear (ResultBuffer* r) /* Reference to the buffer to clear out */
{
    r->used = 0;

    if (!r->allocated) return;

    Tcl_Free ((char*) r->buf);
    r->buf       = NULL;
    r->allocated = 0;
}

/*
 *----------------------------------------------------------------------
 *
 *    ResultAdd --
 *
 *    Adds the bytes in the specified array to the
 *    buffer, by appending it.
 *
 *    Sideeffects:
 *          See above.
 *
 *    Result:
 *          None.
 *
 *----------------------------------------------------------------------
 */

static void
ResultAdd (r, buf, toWrite)
     ResultBuffer*  r;       /* The buffer to extend */
     unsigned char* buf;     /* The buffer to read from */
     int            toWrite; /* The number of bytes in 'buf' */
{
    if ((r->used + toWrite + 1) > r->allocated) {
      /* Extension of the internal buffer is required.
       * NOTE: Currently linear. Should be doubling to amortize.
       */

      if (r->allocated == 0) {
          r->allocated = toWrite + RB_INCREMENT;
          r->buf       = UCHARP(Tcl_Alloc (r->allocated));
      } else {
          r->allocated += toWrite + RB_INCREMENT;
          r->buf        = UCHARP(Tcl_Realloc((char*) r->buf, r->allocated));
      }
    }

    /* now copy data */
    memcpy (r->buf + r->used, buf, toWrite);
    r->used += toWrite;
}

/*
 *----------------------------------------------------------------------
 *
 *    ResultCopy --
 *
 *    Copies the requested number of bytes from the
 *    buffer into the specified array and removes them
 *    from the buffer afterward. Copies less if there
 *    is not enough data in the buffer.
 *
 *    Sideeffects:
 *          See above.
 *
 *    Result:
 *          The number of actually copied bytes,
 *          possibly less than 'toRead'.
 *
 *----------------------------------------------------------------------
 */

static int
ResultCopy (ResultBuffer*  r,      /* The buffer to read from */
          unsigned char* buf,    /* The buffer to copy into */
          int            toRead) /* Number of requested bytes */
{
    int copied;

    if (r->used == 0) {
      /* Nothing to copy in the case of an empty buffer.
       */

      copied = 0;
      goto done;
    }

    if (r->used == toRead) {
      /* We have just enough. Copy everything to the caller.
       */

      memcpy ((VOID*) buf, (VOID*) r->buf, toRead);
      r->used = 0;
      copied  = toRead;
      goto done;
    }

    if (r->used > toRead) {
      /* The internal buffer contains more than requested.
       * Copy the requested subset to the caller, and shift
       * the remaining bytes down.
       */

      memcpy  ((VOID*) buf,    (VOID*) r->buf,            toRead);
      memmove ((VOID*) r->buf, (VOID*) (r->buf + toRead), r->used - toRead);

      r->used -= toRead;
      copied   = toRead;
      goto done;
    }

    /* There is not enough in the buffer to satisfy the caller, so
     * take everything.
     */

    memcpy ((VOID*) buf, (VOID*) r->buf, r->used);
    toRead  = r->used;
    r->used = 0;
    copied  = toRead;

    /* -- common postwork code ------- */

 done:
    return copied;
}


static int
TransformRead (
       ReflectedTransform* rtPtr,
       int* errorCodePtr,
       unsigned char* buf,
       int toRead)
{
    Tcl_Obj* bufObj;
    Tcl_Obj* resObj;
    int bytec;                /* Number of returned bytes */
    unsigned char *bytev;     /* Array of returned bytes */

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

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

      p.transform.buf  = (char*) buf;
      p.transform.size = toRead;

      ForwardOpToOwnerThread(rtPtr, ForwardedInput, &p);

      if (p.base.code != TCL_OK) {
          PassReceivedError(rtPtr->chan, &p);
          *errorCodePtr = EINVAL;
          return 0;
      } else {
          *errorCodePtr = EOK;
      }

      ResultAdd (&rtPtr->result, UCHARP(p.transform.buf), p.transform.size);
      ckfree (p.transform.buf);
    } else {
#endif
      /* ASSERT: rtPtr->method & FLAG(METH_READ) */
      /* ASSERT: rtPtr->mode & TCL_READABLE */

      bufObj = Tcl_NewByteArrayObj((unsigned char *) buf, toRead);
      if (InvokeTclMethod(rtPtr, "read", bufObj, NULL, &resObj) != TCL_OK) {
          Tcl_SetChannelError(rtPtr->chan, resObj);
          Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
          *errorCodePtr = EINVAL;
          return 0;
      }

      bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
      ResultAdd (&rtPtr->result, bytev, bytec);
      Tcl_DecrRefCount(resObj);     /* Remove reference held from invoke */
#ifdef TCL_THREADS
    }
#endif

    return 1;
}

static int
TransformWrite (
      ReflectedTransform* rtPtr,
      int* errorCodePtr,
      unsigned char* buf,
      int toWrite)
{
    Tcl_Obj *bufObj;
    Tcl_Obj *resObj;
    int bytec;                /* Number of returned bytes */
    unsigned char *bytev;     /* Array of returned bytes */
    int res;

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

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

      p.transform.buf  = (char*) buf;
      p.transform.size = toWrite;

      ForwardOpToOwnerThread(rtPtr, ForwardedOutput, &p);

      if (p.base.code != TCL_OK) {
          PassReceivedError(rtPtr->chan, &p);
          *errorCodePtr = EINVAL;
          return 0;
      } else {
          *errorCodePtr = EOK;
      }

      res = Tcl_WriteRaw (rtPtr->parent,
                      (char*) p.transform.buf, p.transform.size);
      ckfree (p.transform.buf);
    } else {
#endif
      /* ASSERT: rtPtr->method & FLAG(METH_WRITE) */
      /* ASSERT: rtPtr->mode & TCL_WRITABLE */

      bufObj = Tcl_NewByteArrayObj((unsigned char *) buf, toWrite);
      if (InvokeTclMethod(rtPtr, "write", bufObj, NULL, &resObj) != TCL_OK) {
          *errorCodePtr = EINVAL;
          Tcl_SetChannelError(rtPtr->chan, resObj);
          Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
          return 0;
      }

      *errorCodePtr = EOK;

      bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
      res   = Tcl_WriteRaw (rtPtr->parent,  (char*) bytev, bytec);
      Tcl_DecrRefCount(resObj);           /* Remove reference held from invoke */
#ifdef TCL_THREADS
    }
#endif

    if (res < 0) {
      *errorCodePtr = EINVAL;
      return 0;
    }

    return 1;
}



static int
TransformDrain(
      ReflectedTransform* rtPtr,
      int* errorCodePtr)
{
    Tcl_Obj* resObj;
    int bytec;                /* Number of returned bytes */
    unsigned char *bytev;     /* Array of returned bytes */

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

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

      ForwardOpToOwnerThread(rtPtr, ForwardedDrain, &p);

      if (p.base.code != TCL_OK) {
          PassReceivedError(rtPtr->chan, &p);
          *errorCodePtr = EINVAL;
          return 0;
      } else {
          *errorCodePtr = EOK;
      }

      ResultAdd (&rtPtr->result, UCHARP(p.transform.buf), p.transform.size);
      ckfree (p.transform.buf);
    } else {
#endif
      if (InvokeTclMethod(rtPtr, "drain", NULL, NULL, &resObj)!=TCL_OK) {
          Tcl_SetChannelError(rtPtr->chan, resObj);
          Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
          *errorCodePtr = EINVAL;
          return 0;
      }

      bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
      ResultAdd (&rtPtr->result, bytev, bytec);

      Tcl_DecrRefCount(resObj);     /* Remove reference held from invoke */

#ifdef TCL_THREADS
    }
#endif

    rtPtr->readIsDrained = 1;
    return 1;
}


static int
TransformFlush(
      ReflectedTransform* rtPtr,
      int* errorCodePtr,
      int  op)
{
    Tcl_Obj* resObj;
    int bytec;                /* Number of returned bytes */
    unsigned char *bytev;     /* Array of returned bytes */
    int res;

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

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

      ForwardOpToOwnerThread(rtPtr, ForwardedFlush, &p);

      if (p.base.code != TCL_OK) {
          PassReceivedError(rtPtr->chan, &p);
          *errorCodePtr = EINVAL;
          return 0;
      } else {
          *errorCodePtr = EOK;
      }

      if (op == FLUSH_WRITE) {
          res = Tcl_WriteRaw (rtPtr->parent,
                        (char*) p.transform.buf, p.transform.size);
      } else {
          res = 0;
      }
      ckfree(p.transform.buf);
    } else {
#endif
      if (InvokeTclMethod(rtPtr, "flush", NULL, NULL, &resObj)!=TCL_OK) {
          Tcl_SetChannelError(rtPtr->chan, resObj);
          Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
          *errorCodePtr = EINVAL;
          return 0;
      }

      if (op == FLUSH_WRITE) {
          bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
          res   = Tcl_WriteRaw (rtPtr->parent,  (char*) bytev, bytec);
      } else {
          res = 0;
      }
      Tcl_DecrRefCount(resObj);     /* Remove reference held from invoke */

#ifdef TCL_THREADS
    }
#endif
    if (res < 0) {
      *errorCodePtr = EINVAL;
      return 0;
    }

    return 1;
}

static void
TransformClear (
      ReflectedTransform* rtPtr)
{
    /*
     * Are we in the correct thread?
     */

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

      ForwardOpToOwnerThread(rtPtr, ForwardedClear, &p);
      return;
    } else {
#endif
      /* ASSERT: rtPtr->method & FLAG(METH_READ) */
      /* ASSERT: rtPtr->mode & TCL_READABLE */

      (void) InvokeTclMethod(rtPtr, "clear", NULL, NULL, NULL);

#ifdef TCL_THREADS
    }
#endif

    rtPtr->readIsDrained = 0;
    ResultClear (&rtPtr->result);
}

static int
TransformLimit (
      ReflectedTransform* rtPtr,
      int* errorCodePtr,
      int* maxPtr)
{
    Tcl_Obj* resObj;
    Tcl_InterpState sr;       /* State of handler interp */

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

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

      ForwardOpToOwnerThread(rtPtr, ForwardedLimit, &p);

      if (p.base.code != TCL_OK) {
          PassReceivedError(rtPtr->chan, &p);
          *errorCodePtr = EINVAL;
          return 0;
      } else {
          *errorCodePtr = EOK;
          *maxPtr = p.limit.max;
          return 1;
      }
    }
#endif

    /* ASSERT: rtPtr->method & FLAG(METH_WRITE) */
    /* ASSERT: rtPtr->mode & TCL_WRITABLE */

    if (InvokeTclMethod(rtPtr, "limit?", NULL, NULL, &resObj) != TCL_OK) {
      Tcl_SetChannelError(rtPtr->chan, resObj);
      Tcl_DecrRefCount(resObj);     /* Remove reference held from invoke */
      *errorCodePtr = EINVAL;
      return 0;
    }

    sr = Tcl_SaveInterpState(rtPtr->interp, 0 /* Dummy */);

    if (Tcl_GetIntFromObj(rtPtr->interp, resObj, maxPtr) != TCL_OK) {
      Tcl_DecrRefCount(resObj);     /* Remove reference held from invoke */
      Tcl_SetChannelError(rtPtr->chan, MarshallError(rtPtr->interp));
      *errorCodePtr = EINVAL;

      Tcl_RestoreInterpState(rtPtr->interp, sr);
      return 0;
    }

    Tcl_DecrRefCount(resObj);       /* Remove reference held from invoke */
    Tcl_RestoreInterpState(rtPtr->interp, sr);
    return 1;
}

/* DUPLICATE of HaveVersion() in tclIO.c
 *----------------------------------------------------------------------
 *
 * HaveVersion --
 *
 *    Return whether a channel type is (at least) of a given version.
 *
 * Results:
 *    True if the minimum version is exceeded by the version actually
 *    present.
 *
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */

static int
HaveVersion(
    const Tcl_ChannelType *chanTypePtr,
    Tcl_ChannelTypeVersion minimumVersion)
{
    Tcl_ChannelTypeVersion actualVersion = Tcl_ChannelVersion(chanTypePtr);

    return (PTR2INT(actualVersion)) >= (PTR2INT(minimumVersion));
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Generated by  Doxygen 1.6.0   Back to index